CP-48195: Instrument client side of forkexecd

Instrument:

- `forkhelpers.ml`,
- `fecomms.ml`

to create spans around functions when a parent span is supplied as
`tracing`.

Signed-off-by: Gabriel Buica <[email protected]>

ocaml/forkexecd/lib/fecomms.ml

@@ -1,25 +1,40 @@
 module Unixext = Xapi_stdext_unix.Unixext
 
-let open_unix_domain_sock () = Unix.socket Unix.PF_UNIX Unix.SOCK_STREAM 0
+let update_ferpc_env tracing (ferpc : Fe.ferpc) : Fe.ferpc =
+  match ferpc with
+  | Setup setup_cmd ->
+      let env = setup_cmd.env @ Tracing.EnvHelpers.of_span tracing in
+      Setup {setup_cmd with env}
+  | Setup_response _ | Exec | Execed _ | Finished _ | Dontwaitpid ->
+      ferpc
 
-let open_unix_domain_sock_server path =
+let with_tracing ~tracing ~name f = Tracing.with_tracing ~parent:tracing ~name f
+
+let open_unix_domain_sock ?tracing () =
+  with_tracing ~tracing ~name:__FUNCTION__ @@ fun _ ->
+  Unix.socket Unix.PF_UNIX Unix.SOCK_STREAM 0
+
+let open_unix_domain_sock_server ?tracing path =
+  with_tracing ~tracing ~name:__FUNCTION__ @@ fun tracing ->
   Unixext.mkdir_rec (Filename.dirname path) 0o755 ;
   Unixext.unlink_safe path ;
-  let sock = open_unix_domain_sock () in
+  let sock = open_unix_domain_sock ?tracing () in
   try
     Unix.bind sock (Unix.ADDR_UNIX path) ;
     Unix.listen sock 5 ;
     sock
   with e -> Unix.close sock ; raise e
 
-let open_unix_domain_sock_client path =
-  let sock = open_unix_domain_sock () in
+let open_unix_domain_sock_client ?tracing path =
+  with_tracing ~tracing ~name:__FUNCTION__ @@ fun tracing ->
+  let sock = open_unix_domain_sock ?tracing () in
   try
     Unix.connect sock (Unix.ADDR_UNIX path) ;
     sock
   with e -> Unix.close sock ; raise e
 
-let read_raw_rpc sock =
+let read_raw_rpc ?tracing sock =
+  with_tracing ~tracing ~name:__FUNCTION__ @@ fun _ ->
   let buffer = Bytes.make 12 '\000' in
   Unixext.really_read sock buffer 0 12 ;
   let header = Bytes.unsafe_to_string buffer in
@@ -31,20 +46,24 @@ let read_raw_rpc sock =
       Unix.(shutdown sock SHUTDOWN_ALL) ;
       Error ("Header is not an integer: " ^ header)
 
-let write_raw_rpc sock ferpc =
+let write_raw_rpc ?tracing sock ferpc =
+  with_tracing ~tracing ~name:__FUNCTION__ @@ fun tracing ->
+  let ferpc = update_ferpc_env tracing ferpc in
   let body = Jsonrpc.to_string (Fe.rpc_of_ferpc ferpc) in
   let len = String.length body in
   let buffer = Printf.sprintf "%012d%s" len body in
   Unixext.really_write_string sock buffer
 
 exception Connection_closed
 
-let receive_named_fd sock =
+let receive_named_fd ?tracing sock =
+  with_tracing ~tracing ~name:__FUNCTION__ @@ fun _ ->
   let buffer = Bytes.make 36 '\000' in
   let len, _from, newfd = Unixext.recv_fd sock buffer 0 36 [] in
   let buffer = Bytes.unsafe_to_string buffer in
   if len = 0 then raise Connection_closed ;
   (newfd, buffer)
 
-let send_named_fd sock uuid fd =
+let send_named_fd ?tracing sock uuid fd =
+  with_tracing ~tracing ~name:__FUNCTION__ @@ fun _ ->
   ignore (Unixext.send_fd_substring sock uuid 0 (String.length uuid) [] fd)

ocaml/forkexecd/lib/forkhelpers.ml

@@ -36,9 +36,7 @@ let test_path =
 
 let runtime_path = Option.value ~default:"/var" test_path
 
-let _with_tracing ?tracing ~name f =
-  let name = Printf.sprintf "forkhelpers.%s" name in
-  Tracing.with_tracing ?parent:tracing ~name f
+let with_tracing ~tracing ~name f = Tracing.with_tracing ~parent:tracing ~name f
 
 let finally = Xapi_stdext_pervasives.Pervasiveext.finally
 
@@ -146,7 +144,8 @@ let getpid (_sock, pid) = pid
 
 type 'a result = Success of string * 'a | Failure of string * exn
 
-let temp_dir_server = runtime_path ^ "/run/nonpersistent/forkexecd/"
+let temp_dir_server =
+  Filename.concat runtime_path "/run/nonpersistent/forkexecd/"
 
 let temp_dir =
   try
@@ -182,11 +181,13 @@ type syslog_stdout =
 
 (** Safe function which forks a command, closing all fds except a whitelist and
     having performed some fd operations in the child *)
-let safe_close_and_exec ?env stdin stdout stderr
+let safe_close_and_exec ?tracing ?env stdin stdout stderr
     (fds : (string * Unix.file_descr) list) ?(syslog_stdout = NoSyslogging)
     ?(redirect_stderr_to_stdout = false) (cmd : string) (args : string list) =
+  with_tracing ~tracing ~name:__FUNCTION__ @@ fun tracing ->
   let sock =
-    Fecomms.open_unix_domain_sock_client (runtime_path ^ "/xapi/forker/main")
+    Fecomms.open_unix_domain_sock_client ?tracing
+      (Filename.concat runtime_path "/xapi/forker/main")
   in
   let stdinuuid = Uuidx.(to_string (make ())) in
   let stdoutuuid = Uuidx.(to_string (make ())) in
@@ -233,7 +234,7 @@ let safe_close_and_exec ?env stdin stdout stderr
         | Syslog_WithKey k ->
             {Fe.enabled= true; Fe.key= Some k}
       in
-      Fecomms.write_raw_rpc sock
+      Fecomms.write_raw_rpc ?tracing sock
         (Fe.Setup
            {
              Fe.cmdargs= cmd :: args
@@ -244,7 +245,7 @@ let safe_close_and_exec ?env stdin stdout stderr
            }
         ) ;
 
-      let response = Fecomms.read_raw_rpc sock in
+      let response = Fecomms.read_raw_rpc ?tracing sock in
 
       let s =
         match response with
@@ -267,10 +268,14 @@ let safe_close_and_exec ?env stdin stdout stderr
             failwith msg
       in
 
-      let fd_sock = Fecomms.open_unix_domain_sock_client s.Fe.fd_sock_path in
+      let fd_sock =
+        Fecomms.open_unix_domain_sock_client ?tracing s.Fe.fd_sock_path
+      in
       add_fd_to_close_list fd_sock ;
 
-      let send_named_fd uuid fd = Fecomms.send_named_fd fd_sock uuid fd in
+      let send_named_fd uuid fd =
+        Fecomms.send_named_fd ?tracing fd_sock uuid fd
+      in
 
       List.iter
         (fun (uuid, _, srcfdo) ->
@@ -282,8 +287,8 @@ let safe_close_and_exec ?env stdin stdout stderr
         )
         predefined_fds ;
       List.iter (fun (uuid, srcfd) -> send_named_fd uuid srcfd) fds ;
-      Fecomms.write_raw_rpc sock Fe.Exec ;
-      match Fecomms.read_raw_rpc sock with
+      Fecomms.write_raw_rpc ?tracing sock Fe.Exec ;
+      match Fecomms.read_raw_rpc ?tracing sock with
       | Ok (Fe.Execed pid) ->
           (sock, pid)
       | Ok status ->
@@ -304,8 +309,9 @@ let safe_close_and_exec ?env stdin stdout stderr
     )
     close_fds
 
-let execute_command_get_output_inner ?env ?stdin ?(syslog_stdout = NoSyslogging)
-    ?(redirect_stderr_to_stdout = false) ?(timeout = -1.0) cmd args =
+let execute_command_get_output_inner ?tracing ?env ?stdin
+    ?(syslog_stdout = NoSyslogging) ?(redirect_stderr_to_stdout = false)
+    ?(timeout = -1.0) cmd args =
   let to_close = ref [] in
   let close fd =
     if List.mem fd !to_close then (
@@ -325,10 +331,14 @@ let execute_command_get_output_inner ?env ?stdin ?(syslog_stdout = NoSyslogging)
   finally
     (fun () ->
       match
+        with_tracing ~tracing ~name:"Forkhelpers.with_logfile_out_fd"
+        @@ fun tracing ->
         with_logfile_fd "execute_command_get_out" (fun out_fd ->
+            with_tracing ~tracing ~name:"Forkhelpers.with_logfile_err_fd"
+            @@ fun tracing ->
             with_logfile_fd "execute_command_get_err" (fun err_fd ->
                 let sock, pid =
-                  safe_close_and_exec ?env
+                  safe_close_and_exec ?tracing ?env
                     (Option.map (fun (_, fd, _) -> fd) stdinandpipes)
                     (Some out_fd) (Some err_fd) [] ~syslog_stdout
                     ~redirect_stderr_to_stdout cmd args
@@ -341,6 +351,7 @@ let execute_command_get_output_inner ?env ?stdin ?(syslog_stdout = NoSyslogging)
                   stdinandpipes ;
                 if timeout > 0. then
                   Unix.setsockopt_float sock Unix.SO_RCVTIMEO timeout ;
+                with_tracing ~tracing ~name:"Forkhelpers.waitpid" @@ fun _ ->
                 try waitpid (sock, pid)
                 with Unix.(Unix_error ((EAGAIN | EWOULDBLOCK), _, _)) ->
                   Unix.kill pid Sys.sigkill ;
@@ -361,12 +372,15 @@ let execute_command_get_output_inner ?env ?stdin ?(syslog_stdout = NoSyslogging)
     )
     (fun () -> List.iter Unix.close !to_close)
 
-let execute_command_get_output ?env ?(syslog_stdout = NoSyslogging)
+let execute_command_get_output ?tracing ?env ?(syslog_stdout = NoSyslogging)
     ?(redirect_stderr_to_stdout = false) ?timeout cmd args =
-  execute_command_get_output_inner ?env ?stdin:None ?timeout ~syslog_stdout
-    ~redirect_stderr_to_stdout cmd args
-
-let execute_command_get_output_send_stdin ?env ?(syslog_stdout = NoSyslogging)
-    ?(redirect_stderr_to_stdout = false) ?timeout cmd args stdin =
-  execute_command_get_output_inner ?env ~stdin ~syslog_stdout
+  with_tracing ~tracing ~name:__FUNCTION__ @@ fun tracing ->
+  execute_command_get_output_inner ?tracing ?env ?stdin:None ?timeout
+    ~syslog_stdout ~redirect_stderr_to_stdout cmd args
+
+let execute_command_get_output_send_stdin ?tracing ?env
+    ?(syslog_stdout = NoSyslogging) ?(redirect_stderr_to_stdout = false)
+    ?timeout cmd args stdin =
+  with_tracing ~tracing ~name:__FUNCTION__ @@ fun tracing ->
+  execute_command_get_output_inner ?tracing ?env ~stdin ~syslog_stdout
     ~redirect_stderr_to_stdout ?timeout cmd args

ocaml/forkexecd/lib/forkhelpers.mli

@@ -44,7 +44,8 @@ val default_path : string list
 val default_path_env_pair : string array
 
 val execute_command_get_output :
-     ?env:string array
+     ?tracing:Tracing.Span.t
+  -> ?env:string array
   -> ?syslog_stdout:syslog_stdout
   -> ?redirect_stderr_to_stdout:bool
   -> ?timeout:float
@@ -56,7 +57,8 @@ val execute_command_get_output :
     [Spawn_internal_error(stderr, stdout, Unix.process_status)] *)
 
 val execute_command_get_output_send_stdin :
-     ?env:string array
+     ?tracing:Tracing.Span.t
+  -> ?env:string array
   -> ?syslog_stdout:syslog_stdout
   -> ?redirect_stderr_to_stdout:bool
   -> ?timeout:float
@@ -92,7 +94,8 @@ exception Subprocess_killed of int
 exception Subprocess_timeout
 
 val safe_close_and_exec :
-     ?env:string array
+     ?tracing:Tracing.Span.t
+  -> ?env:string array
   -> Unix.file_descr option
   -> Unix.file_descr option
   -> Unix.file_descr option

ocaml/libs/tracing/tracing.ml

@@ -608,7 +608,8 @@ let get_tracer ~name =
   | Some provider ->
       Tracer.create ~name ~provider
   | None ->
-      warn "No provider found for tracing %s" name ;
+      (* CP-48195: comment out warning to stop spamming the logs.*)
+      (* warn "No provider found for tracing %s" name ; *)
       Tracer.no_op
 
 let enable_span_garbage_collector ?(timeout = 86400.) () =
@@ -634,3 +635,34 @@ let with_tracing ?(attributes = []) ?(parent = None) ~name f =
     | Error e ->
         warn "Failed to start tracing: %s" (Printexc.to_string e) ;
         f None
+
+module EnvHelpers = struct
+  let traceparent_key = "TRACEPARENT"
+
+  let of_traceparent traceparent =
+    match traceparent with
+    | None ->
+        []
+    | Some traceparent ->
+        [String.concat "=" [traceparent_key; traceparent]]
+
+  let to_traceparent env =
+    let env_opt =
+      List.find_opt (String.starts_with ~prefix:traceparent_key) env
+    in
+    Option.bind env_opt (fun key_value ->
+        match String.split_on_char '=' key_value with
+        | [key; traceparent] when String.equal key traceparent_key ->
+            Some traceparent
+        | _ ->
+            None
+    )
+
+  let of_span span =
+    match span with
+    | None ->
+        []
+    | Some span ->
+        Some (span |> Span.get_context |> SpanContext.to_traceparent)
+        |> of_traceparent
+end

ocaml/libs/tracing/tracing.mli

@@ -177,3 +177,34 @@ val with_tracing :
 val set_observe : bool -> unit
 
 val validate_attribute : string * string -> bool
+
+(** [EnvHelpers] module is a helper module for the tracing library to easily 
+    transition back and forth between a string list of environment variables to 
+    a traceparent. 
+    *)
+module EnvHelpers : sig
+  val traceparent_key : string
+  (** [traceparent_key] is a constant the represents the key of the traceparent
+      environment variable. 
+      *)
+
+  val of_traceparent : string option -> string list
+  (** [of_traceparent traceparent_opt] returns a singleton list consisting of a
+      envirentment variable with the key [traceparent_key] and value [v] if 
+      [traceparent_opt] is [Some v]. Otherwise, returns an empty list. *)
+
+  val to_traceparent : string list -> string option
+  (** [to_traceparent env_var_lst] returns [Some v] where v is the value of the 
+      environmental variable coresponding to the key [traceparent_key] from a 
+      string list of environmental variables [env_var_lst]. If there is no such
+      evironmental variable in the list, it returns [None].
+      *)
+
+  val of_span : Span.t option -> string list
+  (** [of_span span] returns a singleton list consisting of a
+      envirentment variable with the key [traceparent_key] and value [v], where
+      [v] is traceparent representation of span [s] (if [span] is [Some s]).
+        
+      If [span] is [None], it returns an empty list.
+      *)
+end

ocaml/xapi/sm_exec.ml

@@ -341,7 +341,6 @@ let with_session sr f =
 let exec_xmlrpc ~dbg ?context:_ ?(needs_session = true) (driver : string)
     (call : call) =
   with_dbg ~name:call.cmd ~dbg @@ fun di ->
-  let dbg = Debuginfo.to_string di in
   let do_call call =
     let xml = xmlrpc_of_call call in
     let name = Printf.sprintf "sm_exec: %s" call.cmd in
@@ -358,12 +357,11 @@ let exec_xmlrpc ~dbg ?context:_ ?(needs_session = true) (driver : string)
                 | false ->
                     (None, exe, args)
                 | true ->
-                    let traceparent = Debuginfo.traceparent_of_dbg dbg in
                     Xapi_observer_components.env_exe_args_of
-                      ~component:Xapi_observer_components.SMApi ~traceparent
-                      ~exe ~args
+                      ~component:Xapi_observer_components.SMApi ~exe ~args
               in
-              Forkhelpers.execute_command_get_output ?env exe args
+              Forkhelpers.execute_command_get_output ?tracing:di.tracing ?env
+                exe args
             in
             try (Xml.parse_string output, stderr)
             with e ->

ocaml/xapi/xapi_observer_components.ml

@@ -99,24 +99,17 @@ let ( // ) = Filename.concat
 let dir_name_of_component component =
   Xapi_globs.observer_config_dir // to_string component // "enabled"
 
-let env_exe_args_of ~component ~traceparent ~exe ~args =
+let env_exe_args_of ~component ~exe ~args =
   let dir_name_value = Filename.quote (dir_name_of_component component) in
   let env_vars =
     Array.concat
       [
         Forkhelpers.default_path_env_pair
       ; Env_record.to_string_array
-          ([
-             Env_record.pair ("OBSERVER_CONFIG_DIR", dir_name_value)
-           ; Env_record.pair ("PYTHONPATH", Filename.dirname exe)
-           ]
-          @
-          match traceparent with
-          | None ->
-              []
-          | Some traceparent ->
-              [Env_record.pair ("TRACEPARENT", traceparent)]
-          )
+          [
+            Env_record.pair ("OBSERVER_CONFIG_DIR", dir_name_value)
+          ; Env_record.pair ("PYTHONPATH", Filename.dirname exe)
+          ]
       ]
   in
   let args = "-m" :: "observer" :: exe :: args in

ocaml/xapi/xapi_observer_components.mli

@@ -64,7 +64,6 @@ val dir_name_of_component : t -> string
 
 val env_exe_args_of :
      component:t
-  -> traceparent:string option
   -> exe:string
   -> args:string list
   -> string array option * string * string list