CP-52320 & CP-52743: Classify xapi threads.

Classifies the threads at the time of session creation and inside
`do_dispatch`.

This ensures that new threads created by current session/request inherit
the propper classification.

Note: threads created by xenopsd calling back into xapi are yet to be
classified.

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

ocaml/xapi/dune

@@ -78,6 +78,7 @@
     sexplib0
     sexplib
     sexpr
+    tgroup
     forkexec
     xapi-idl
     xapi_aux

ocaml/xapi/server_helpers.ml

@@ -133,6 +133,17 @@ let do_dispatch ?session_id ?forward_op ?self:_ supports_async called_fn_name
       Context.of_http_req ?session_id ~internal_async_subtask ~generate_task_for
         ~supports_async ~label ~http_req ~fd ()
     in
+    let identity =
+      Option.map
+        (fun session_id ->
+          let subject =
+            Db.Session.get_auth_user_sid ~__context ~self:session_id
+          in
+          Tgroup.Group.Identity.make ?user_agent:http_req.user_agent subject
+        )
+        session_id
+    in
+    Tgroup.of_creator (Tgroup.Group.Creator.make ?identity ()) ;
     let sync () =
       let need_complete = not (Context.forwarded_task __context) in
       exec_with_context ~__context ~need_complete ~called_async

ocaml/xapi/xapi_session.ml

@@ -686,6 +686,7 @@ let consider_touching_session rpc session_id =
 (* Make sure the pool secret matches *)
 let slave_login_common ~__context ~host_str ~psecret =
   Context.with_tracing ~__context __FUNCTION__ @@ fun __context ->
+  Tgroup.of_creator (Tgroup.Group.Creator.make ~intrapool:true ()) ;
   if not (Helpers.PoolSecret.is_authorized psecret) then (
     let msg = "Pool credentials invalid" in
     debug "Failed to authenticate slave %s: %s" host_str msg ;
@@ -881,6 +882,8 @@ let login_with_password ~__context ~uname ~pwd ~version:_ ~originator =
   | Some `root ->
       (* in this case, the context origin of this login request is a unix socket bound locally to a filename *)
       (* we trust requests from local unix filename sockets, so no need to authenticate them before login *)
+      Tgroup.of_creator
+        Tgroup.Group.(Creator.make ~identity:Identity.root_identity ()) ;
       login_no_password_common ~__context ~uname:(Some uname) ~originator
         ~host:(Helpers.get_localhost ~__context)
         ~pool:false ~is_local_superuser:true ~subject:Ref.null ~auth_user_sid:""
@@ -929,6 +932,8 @@ let login_with_password ~__context ~uname ~pwd ~version:_ ~originator =
           do_local_auth uname pwd ;
           debug "Success: local auth, user %s from %s" uname
             (Context.get_origin __context) ;
+          Tgroup.of_creator
+            Tgroup.Group.(Creator.make ~identity:Identity.root_identity ()) ;
           login_no_password_common ~__context ~uname:(Some uname) ~originator
             ~host:(Helpers.get_localhost ~__context)
             ~pool:false ~is_local_superuser:true ~subject:Ref.null
@@ -1224,6 +1229,10 @@ let login_with_password ~__context ~uname ~pwd ~version:_ ~originator =
                 Caching.memoize ~__context uname pwd
                   ~slow_path:query_external_auth
               in
+              Tgroup.of_creator
+                Tgroup.Group.(
+                  Creator.make ~identity:(Identity.make subject_identifier) ()
+                ) ;
               login_no_password_common ~__context ~uname:(Some uname)
                 ~originator
                 ~host:(Helpers.get_localhost ~__context)

ocaml/xe-cli/newcli.ml

@@ -816,6 +816,7 @@ let main () =
         in
         let args = String.concat "\n" args in
         Printf.fprintf oc "User-agent: xe-cli/Unix/%d.%d\r\n" major minor ;
+        Printf.fprintf oc "originator: cli\r\n" ;
         Option.iter (Printf.fprintf oc "traceparent: %s\r\n") traceparent ;
         Printf.fprintf oc "content-length: %d\r\n\r\n" (String.length args) ;
         Printf.fprintf oc "%s" args ;