CP-49029: Instrument xapi_session.ml with tracing

ocaml/libs/tracing/tracing.ml

@@ -132,6 +132,12 @@ module Attributes = struct
   let of_list list = List.to_seq list |> of_seq
 
   let to_assoc_list attr = to_seq attr |> List.of_seq
+
+  let attr_of_originator = function
+    | None ->
+        []
+    | Some originator ->
+        [("xs.xapi.session.originator", originator)]
 end
 
 module SpanEvent = struct

ocaml/libs/tracing/tracing.mli

@@ -40,6 +40,8 @@ module Attributes : sig
   val of_list : (string * 'a) list -> 'a t
 
   val to_assoc_list : 'a t -> (string * 'a) list
+
+  val attr_of_originator : string option -> (string * string) list
 end
 
 module Status : sig

ocaml/xapi/context.ml

@@ -500,14 +500,15 @@ let get_client_ip context =
 let get_user_agent context =
   match context.origin with Internal -> None | Http (rq, _) -> rq.user_agent
 
-let with_tracing context name f =
+let with_tracing ?originator ~__context name f =
   let open Tracing in
-  let parent = context.tracing in
-  match start_tracing_helper (fun _ -> parent) name with
+  let parent = __context.tracing in
+  let span_attributes = Attributes.attr_of_originator originator in
+  match start_tracing_helper ~span_attributes (fun _ -> parent) name with
   | Some _ as span ->
-      let new_context = {context with tracing= span} in
+      let new_context = {__context with tracing= span} in
       let result = f new_context in
       let _ = Tracer.finish span in
       result
   | None ->
-      f context
+      f __context

ocaml/xapi/context.mli

@@ -146,6 +146,7 @@ val complete_tracing : ?error:exn * string -> t -> unit
 
 val tracing_of : t -> Tracing.Span.t option
 
-val with_tracing : t -> string -> (t -> 'a) -> 'a
+val with_tracing :
+  ?originator:string -> __context:t -> string -> (t -> 'a) -> 'a
 
 val set_client_span : t -> Tracing.Span.t option

ocaml/xapi/xapi_session.ml

@@ -246,6 +246,7 @@ let _record_login_failure ~__context ~now ~uname ~originator ~record f =
       on_fail e
 
 let record_login_failure ~__context ~uname ~originator ~record f =
+  Context.with_tracing ?originator ~__context __FUNCTION__ @@ fun __context ->
   let now = Unix.time () |> Date.of_float in
   _record_login_failure ~__context ~now ~uname ~originator ~record f
 
@@ -305,6 +306,7 @@ let trackid session_id = Context.trackid_of_session (Some session_id)
 (* finds the intersection between group_membership_closure and pool's table of subject_ids *)
 let get_intersection ~__context subject_ids_in_db subject_identifier
     group_membership_closure =
+  Context.with_tracing ~__context __FUNCTION__ @@ fun __context ->
   let reflexive_membership_closure =
     subject_identifier :: group_membership_closure
   in
@@ -314,6 +316,7 @@ let get_intersection ~__context subject_ids_in_db subject_identifier
   intersection
 
 let get_subject_in_intersection ~__context subjects_in_db intersection =
+  Context.with_tracing ~__context __FUNCTION__ @@ fun __context ->
   List.find
     (fun subj ->
       (* is this the subject ref that returned the non-empty intersection?*)
@@ -323,6 +326,7 @@ let get_subject_in_intersection ~__context subjects_in_db intersection =
     subjects_in_db
 
 let get_permissions ~__context ~subject_membership =
+  Context.with_tracing ~__context __FUNCTION__ @@ fun __context ->
   (* see also rbac.ml *)
   let get_union_of_subsets ~get_subset_fn ~set =
     Listext.List.setify
@@ -351,6 +355,7 @@ let get_permissions ~__context ~subject_membership =
 
 (* CP-827: finds out if the subject was suspended (ie. disabled,expired,locked-out) *)
 let is_subject_suspended ~__context ~cache subject_identifier =
+  Context.with_tracing ~__context __FUNCTION__ @@ fun __context ->
   (* obtains the subject's info containing suspension information *)
   let info =
     try
@@ -409,6 +414,7 @@ let is_subject_suspended ~__context ~cache subject_identifier =
   (is_suspended, subject_name)
 
 let destroy_db_session ~__context ~self =
+  Context.with_tracing ~__context __FUNCTION__ @@ fun __context ->
   Xapi_event.on_session_deleted self ;
   (* unregister from the event system *)
   (* This info line is important for tracking, auditability and client accountability purposes on XenServer *)
@@ -425,6 +431,7 @@ let destroy_db_session ~__context ~self =
 (* in response to external authentication/directory services updates, such as *)
 (* e.g. group membership changes, or even account disabled *)
 let revalidate_external_session ~__context ~session =
+  Context.with_tracing ~__context __FUNCTION__ @@ fun __context ->
   try
     (* guard: we only want to revalidate external sessions, where is_local_superuser is false *)
     (* Neither do we want to revalidate the special read-only external database sessions, since they can exist independent of external authentication. *)
@@ -592,6 +599,7 @@ let revalidate_external_session ~__context ~session =
 (* in response to external authentication/directory services updates, such as *)
 (* e.g. group membership changes, or even account disabled *)
 let revalidate_all_sessions ~__context =
+  Context.with_tracing ~__context __FUNCTION__ @@ fun __context ->
   try
     debug "revalidating all external sessions in the local host" ;
     (* obtain all sessions in the pool *)
@@ -618,6 +626,7 @@ let revalidate_all_sessions ~__context =
 let login_no_password_common ~__context ~uname ~originator ~host ~pool
     ~is_local_superuser ~subject ~auth_user_sid ~auth_user_name
     ~rbac_permissions ~db_ref ~client_certificate =
+  Context.with_tracing ~originator ~__context __FUNCTION__ @@ fun __context ->
   let create_session () =
     let session_id = Ref.make () in
     let uuid = Uuidx.to_string (Uuidx.make ()) in
@@ -670,6 +679,7 @@ let login_no_password_common ~__context ~uname ~originator ~host ~pool
    Needs to be protected by a proper access control system *)
 let login_no_password ~__context ~uname ~host ~pool ~is_local_superuser ~subject
     ~auth_user_sid ~auth_user_name ~rbac_permissions =
+  Context.with_tracing ~__context __FUNCTION__ @@ fun __context ->
   login_no_password_common ~__context ~uname
     ~originator:xapi_internal_originator ~host ~pool ~is_local_superuser
     ~subject ~auth_user_sid ~auth_user_name ~rbac_permissions ~db_ref:None
@@ -689,6 +699,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 ->
   if not (Helpers.PoolSecret.is_authorized psecret) then (
     let msg = "Pool credentials invalid" in
     debug "Failed to authenticate slave %s: %s" host_str msg ;
@@ -698,19 +709,22 @@ let slave_login_common ~__context ~host_str ~psecret =
 
 (* Normal login, uses the master's database *)
 let slave_login ~__context ~host ~psecret =
+  Context.with_tracing ~__context __FUNCTION__ @@ fun __context ->
   slave_login_common ~__context ~host_str:(Ref.string_of host) ~psecret ;
   login_no_password ~__context ~uname:None ~host ~pool:true
     ~is_local_superuser:true ~subject:Ref.null ~auth_user_sid:""
     ~auth_user_name:(Ref.string_of host) ~rbac_permissions:[]
 
 (* Emergency mode login, uses local storage *)
 let slave_local_login ~__context ~psecret =
+  Context.with_tracing ~__context __FUNCTION__ @@ fun __context ->
   slave_login_common ~__context ~host_str:"localhost" ~psecret ;
   debug "Add session to local storage" ;
   Xapi_local_session.create ~__context ~pool:true
 
 (* Emergency mode login, uses local storage *)
 let slave_local_login_with_password ~__context ~uname ~pwd =
+  Context.with_tracing ~__context __FUNCTION__ @@ fun __context ->
   let pwd = Bytes.of_string pwd in
   wipe_params_after_fn [pwd] (fun () ->
       if Context.preauth ~__context <> Some `root then (
@@ -742,6 +756,7 @@ let slave_local_login_with_password ~__context ~uname ~pwd =
       against the local superuser credentials
 *)
 let login_with_password ~__context ~uname ~pwd ~version:_ ~originator =
+  Context.with_tracing ~originator ~__context __FUNCTION__ @@ fun __context ->
   let pwd = Bytes.of_string pwd in
   wipe_params_after_fn [pwd] (fun () ->
       (* !!! Do something with the version number *)
@@ -1138,6 +1153,7 @@ let login_with_password ~__context ~uname ~pwd ~version:_ ~originator =
   )
 
 let change_password ~__context ~old_pwd ~new_pwd =
+  Context.with_tracing ~__context __FUNCTION__ @@ fun __context ->
   let old_pwd = Bytes.of_string old_pwd in
   let new_pwd = Bytes.of_string new_pwd in
   wipe_params_after_fn [old_pwd; new_pwd] (fun () ->
@@ -1204,14 +1220,17 @@ let change_password ~__context ~old_pwd ~new_pwd =
   )
 
 let logout ~__context =
+  Context.with_tracing ~__context __FUNCTION__ @@ fun __context ->
   let session_id = Context.get_session_id __context in
   destroy_db_session ~__context ~self:session_id
 
 let local_logout ~__context =
+  Context.with_tracing ~__context __FUNCTION__ @@ fun __context ->
   let session_id = Context.get_session_id __context in
   Xapi_local_session.destroy ~__context ~self:session_id
 
 let get_group_subject_identifier_from_session ~__context ~session =
+  Context.with_tracing ~__context __FUNCTION__ @@ fun __context ->
   let subj = Db.Session.get_subject ~__context ~self:session in
   try Db.Subject.get_subject_identifier ~__context ~self:subj with
   | Db_exn.DBCache_NotFound ("missing row", _, _) ->
@@ -1225,6 +1244,7 @@ let get_group_subject_identifier_from_session ~__context ~session =
       ""
 
 let get_all_subject_identifiers ~__context =
+  Context.with_tracing ~__context __FUNCTION__ @@ fun __context ->
   let all_sessions = Db.Session.get_all ~__context in
   let all_extauth_sessions =
     List.filter
@@ -1256,6 +1276,7 @@ let get_all_subject_identifiers ~__context =
     (all_auth_user_sids_in_sessions @ all_subject_list_sids_in_sessions)
 
 let logout_subject_identifier ~__context ~subject_identifier =
+  Context.with_tracing ~__context __FUNCTION__ @@ fun __context ->
   let all_sessions = Db.Session.get_all ~__context in
   let current_session = Context.get_session_id __context in
   (* we filter the sessions to be destroyed *)
@@ -1329,6 +1350,7 @@ let get_top ~__context ~self =
 
 (* This function should only be called from inside XAPI. *)
 let create_readonly_session ~__context ~uname ~db_ref =
+  Context.with_tracing ~__context __FUNCTION__ @@ fun __context ->
   debug "Creating readonly session." ;
   let role =
     List.hd
@@ -1347,6 +1369,7 @@ let create_readonly_session ~__context ~uname ~db_ref =
 
 (* Create a database reference from a DB dump, and register it with a new readonly session. *)
 let create_from_db_file ~__context ~filename =
+  Context.with_tracing ~__context __FUNCTION__ @@ fun __context ->
   let db =
     Xapi_database.Db_xml.From.file (Datamodel_schema.of_datamodel ()) filename
     |> Xapi_database.Db_upgrade.generic_database_upgrade