diff --git a/ocaml/libs/tgroup/dune b/ocaml/libs/tgroup/dune index 40b75ad1bb..cff00ee115 100644 --- a/ocaml/libs/tgroup/dune +++ b/ocaml/libs/tgroup/dune @@ -1,4 +1,11 @@ (library (name tgroup) + (modules tgroup) (public_name tgroup) - (libraries xapi-log xapi-stdext-unix)) + (libraries xapi-log xapi-stdext-unix xapi-stdext-std)) + +(test + (name test_tgroup) + (modules test_tgroup) + (package tgroup) + (libraries tgroup alcotest xapi-log)) diff --git a/ocaml/libs/tgroup/test_tgroup.ml b/ocaml/libs/tgroup/test_tgroup.ml new file mode 100644 index 0000000000..0ff9e4db33 --- /dev/null +++ b/ocaml/libs/tgroup/test_tgroup.ml @@ -0,0 +1,64 @@ +module D = Debug.Make (struct let name = __MODULE__ end) + +let test_identity () = + let specs = + [ + ((Some "XenCenter2024", "u1000"), "u1000/XenCenter2024") + ; ((None, "u1001"), "u1001") + ; ((None, "Special!@#"), "Special") + ; ((Some "With-Hyphen", "123"), "123/WithHyphen") + ; ((Some "", ""), "root") + ; ((Some " Xen Center 2024 ", ", u 1000 "), "u1000/XenCenter2024") + ; ((Some "Xen Center ,/@.~# 2024", "root"), "root/XenCenter2024") + ; ((Some "XenCenter 2024.3.18", ""), "root/XenCenter2024318") + ] + in + + let test_make ((user_agent, subject_sid), expected_identity) = + let actual_identity = + Tgroup.Group.Identity.(make ?user_agent subject_sid |> to_string) + in + Alcotest.(check string) + "Check expected identity" expected_identity actual_identity + in + List.iter test_make specs + +let test_of_creator () = + let dummy_identity = + Tgroup.Group.Identity.make ~user_agent:"XenCenter2024" "root" + in + let specs = + [ + ((None, None, None, None), "external/unauthenticated") + ; ((Some true, None, None, None), "external/intrapool") + ; ( (Some true, Some "external", Some dummy_identity, Some "sm") + , "external/intrapool" + ) + ; ( (Some true, Some "internal", Some dummy_identity, Some "sm") + , "external/intrapool" + ) + ; ((None, Some "intenal", Some dummy_identity, Some "cli"), "internal/cli") + ; ( (None, None, Some dummy_identity, Some "sm") + , "external/authenticated/root/XenCenter2024" + ) + ] + in + let test_make ((intrapool, endpoint, identity, originator), expected_group) = + let actual_group = + Tgroup.Group.( + Creator.make ?intrapool ?endpoint ?identity ?originator () + |> of_creator + |> to_string + ) + in + Alcotest.(check string) "Check expected group" expected_group actual_group + in + List.iter test_make specs + +let tests = + [ + ("identity make", `Quick, test_identity) + ; ("group of creator", `Quick, test_of_creator) + ] + +let () = Alcotest.run "Tgroup library" [("Thread classification", tests)] diff --git a/ocaml/libs/tgroup/test_tgroup.mli b/ocaml/libs/tgroup/test_tgroup.mli new file mode 100644 index 0000000000..e69de29bb2 diff --git a/ocaml/libs/tgroup/tgroup.ml b/ocaml/libs/tgroup/tgroup.ml index a063997467..297b6af3cc 100644 --- a/ocaml/libs/tgroup/tgroup.ml +++ b/ocaml/libs/tgroup/tgroup.ml @@ -29,12 +29,24 @@ module Group = struct type t let name = "external" - end - module Host = struct - type t + module Intrapool = struct + type t + + let name = "intrapool" + end + + module Authenticated = struct + type t = string + + let name = "authenticated" + end + + module Unauthenticated = struct + type t - let name = "host" + let name = "unauthenticated" + end end module SM = struct @@ -43,73 +55,190 @@ module Group = struct let name = "SM" end + module CLI = struct + type t + + let name = "cli" + end + + module Identity = struct + type t = {user_agent: string option; subject_sid: string} + + let is_alphanum = function + | '0' .. '9' | 'a' .. 'z' | 'A' .. 'Z' -> + true + | _ -> + false + + let sanitize s = + Xapi_stdext_std.Xstringext.String.filter_chars s is_alphanum + + let make ?user_agent subject_sid = + let user_agent = + user_agent + |> Option.map sanitize + |> Option.map (fun user_agent -> + let len = Int.min (String.length user_agent) 16 in + String.sub user_agent 0 len + ) + in + + let user_agent = if user_agent = Some "" then None else user_agent in + let subject_sid = + if subject_sid = "" then "root" else sanitize subject_sid + in + {user_agent; subject_sid} + + let to_string i = + match i.user_agent with + | Some user_agent -> + i.subject_sid // user_agent + | None -> + i.subject_sid + + let root_identity = make "root" + end + type _ group = - | Internal_Host_SM : (Internal.t * Host.t * SM.t) group - | EXTERNAL : External.t group + | Internal_SM : (Internal.t * SM.t) group + | Internal_CLI : (Internal.t * CLI.t) group + | External_Intrapool : (External.t * External.Intrapool.t) group + | External_Authenticated : + Identity.t + -> (External.t * External.Authenticated.t) group + | External_Unautheticated : (External.t * External.Unauthenticated.t) group type t = Group : 'a group -> t - let all = [Group Internal_Host_SM; Group EXTERNAL] + let all = + [ + Group Internal_SM + ; Group Internal_CLI + ; Group External_Intrapool + ; Group (External_Authenticated Identity.root_identity) + ; Group External_Unautheticated + ] + + module Kind = struct + type t = Intrapool | Authenticated of Identity.t | Unautheticated + + let to_string = function + | Some Intrapool -> + External.Intrapool.name + | Some (Authenticated identity) -> + External.Authenticated.name // Identity.to_string identity + | Some Unautheticated -> + External.Unauthenticated.name + | None -> + "internal" + end module Originator = struct - type t = Internal_Host_SM | EXTERNAL + type t = Internal_SM | Internal_CLI | External let of_string = function | s when String.equal (String.lowercase_ascii SM.name) (String.lowercase_ascii s) -> - Internal_Host_SM + Internal_SM | s when String.equal - (String.lowercase_ascii External.name) + (String.lowercase_ascii CLI.name) (String.lowercase_ascii s) -> - EXTERNAL + Internal_CLI | _ -> - EXTERNAL + External let to_string = function - | Internal_Host_SM -> + | Internal_SM -> SM.name - | EXTERNAL -> + | Internal_CLI -> + CLI.name + | External -> External.name end module Creator = struct - type t = { - user: string option - ; endpoint: string option - ; originator: Originator.t - } - - let make ?user ?endpoint originator = {originator; user; endpoint} + type t = {kind: Kind.t option; originator: Originator.t} + + let make ?(intrapool = false) ?(endpoint = External.name) ?identity + ?originator () = + let kind = + match (intrapool, endpoint) with + | true, _ -> + Some Kind.Intrapool + | false, endpoint when String.equal endpoint Internal.name -> + None + | false, _ -> ( + match identity with + | None -> + Some Kind.Unautheticated + | Some identity -> + Some (Kind.Authenticated identity) + ) + in + let originator = + if String.equal endpoint External.name || intrapool then + Originator.External + else + let originator = Option.map Originator.of_string originator in + match originator with + | None -> + Originator.External + | Some originator -> + originator + in + + {kind; originator} + + let default_creator = + { + kind= Some (Kind.Authenticated (Identity.make "root")) + ; originator= Originator.External + } let to_string c = - Printf.sprintf "Creator -> user:%s endpoint:%s originator:%s" - (Option.value c.user ~default:"") - (Option.value c.endpoint ~default:"") + Printf.sprintf "Creator -> kind:%s originator:%s" (Kind.to_string c.kind) (Originator.to_string c.originator) end - let of_originator = function - | Originator.Internal_Host_SM -> - Group Internal_Host_SM - | Originator.EXTERNAL -> - Group EXTERNAL - let get_originator = function - | Group Internal_Host_SM -> - Originator.Internal_Host_SM - | Group EXTERNAL -> - Originator.EXTERNAL - - let of_creator creator = of_originator creator.Creator.originator + | Group Internal_SM -> + Originator.Internal_SM + | Group Internal_CLI -> + Originator.Internal_CLI + | _ -> + Originator.External + + let of_creator creator = + match (creator.Creator.originator, creator.Creator.kind) with + | _, Some Intrapool -> + Group External_Intrapool + | Internal_SM, _ -> + Group Internal_SM + | Internal_CLI, _ -> + Group Internal_CLI + | External, Some (Authenticated identity) -> + Group (External_Authenticated identity) + | External, Some Unautheticated | External, None -> + Group External_Unautheticated let to_cgroup : type a. a group -> string = function - | Internal_Host_SM -> - Internal.name // Host.name // SM.name - | EXTERNAL -> + | Internal_SM -> + Internal.name // SM.name + | Internal_CLI -> + Internal.name // CLI.name + | External_Authenticated identity -> External.name + // External.Authenticated.name + // Identity.to_string identity + | External_Intrapool -> + External.name // External.Intrapool.name + | External_Unautheticated -> + External.name // External.Unauthenticated.name + + let to_string g = match g with Group group -> to_cgroup group end module Cgroup = struct @@ -124,6 +253,10 @@ module Cgroup = struct (fun dir -> dir // Group.to_cgroup group) (Atomic.get cgroup_dir) + let with_dir dir f arg = + Xapi_stdext_unix.Unixext.mkdir_rec dir 0o755 ; + f arg + let write_cur_tid_to_cgroup_file filename = try let perms = 0o640 in @@ -146,39 +279,33 @@ module Cgroup = struct Option.iter (fun dir -> let tasks_file = dir // "tasks" in - write_cur_tid_to_cgroup_file tasks_file + with_dir dir write_cur_tid_to_cgroup_file tasks_file ) (dir_of group) - let set_cur_cgroup ~originator = - match originator with - | Group.Originator.Internal_Host_SM -> - attach_task (Group Internal_Host_SM) - | Group.Originator.EXTERNAL -> - attach_task (Group EXTERNAL) + let set_cur_cgroup ~creator = attach_task (Group.of_creator creator) - let set_cgroup creator = - set_cur_cgroup ~originator:creator.Group.Creator.originator + let set_cgroup creator = set_cur_cgroup ~creator let init dir = let () = Atomic.set cgroup_dir (Some dir) in Group.all |> List.filter_map dir_of - |> List.iter (fun dir -> Xapi_stdext_unix.Unixext.mkdir_rec dir 0o755) ; - set_cur_cgroup ~originator:Group.Originator.EXTERNAL + |> List.iter (fun dir -> with_dir dir debug "created cgroup for: %s" dir) ; + set_cur_cgroup ~creator:Group.Creator.default_creator end -let of_originator originator = - originator |> Group.Creator.make |> Cgroup.set_cgroup - let of_req_originator originator = Option.iter (fun _ -> try originator - |> Option.value ~default:Group.Originator.(to_string EXTERNAL) - |> Group.Originator.of_string - |> of_originator + |> Option.iter (fun originator -> + Group.Creator.make ~endpoint:Group.Internal.name ~originator () + |> Cgroup.set_cgroup + ) with _ -> () ) (Atomic.get Cgroup.cgroup_dir) + +let of_creator creator = creator |> Cgroup.set_cgroup diff --git a/ocaml/libs/tgroup/tgroup.mli b/ocaml/libs/tgroup/tgroup.mli index e1d5c7f0b8..1d47911e1f 100644 --- a/ocaml/libs/tgroup/tgroup.mli +++ b/ocaml/libs/tgroup/tgroup.mli @@ -16,18 +16,29 @@ threads.*) module Group : sig (** Abstract type that represents a group of execution threads in xapi. Each - group corresponds to a Creator, and has a designated level of priority.*) + group corresponds to a Creator, and has a designated level of priority.*) type t + (** Data structures that represents the identity *) + module Identity : sig + type t + + val root_identity : t + + val make : ?user_agent:string -> string -> t + + val to_string : t -> string + end + (** Generic representation of different xapi threads originators. *) module Originator : sig (** Type that represents different originators of xapi threads. *) - type t = Internal_Host_SM | EXTERNAL + type t = Internal_SM | Internal_CLI | External val of_string : string -> t (** [of_string s] creates an originator from a string [s]. - - e.g create an originator based on a http header. *) + + e.g create an originator based on a http header. *) val to_string : t -> string (** [to_string o] converts an originator [o] to its string representation.*) @@ -38,7 +49,13 @@ module Group : sig (** Abstract type that represents different creators of xapi threads.*) type t - val make : ?user:string -> ?endpoint:string -> Originator.t -> t + val make : + ?intrapool:bool + -> ?endpoint:string + -> ?identity:Identity.t + -> ?originator:string + -> unit + -> t (** [make o] creates a creator type based on a given originator [o].*) val to_string : t -> string @@ -50,29 +67,35 @@ module Group : sig val of_creator : Creator.t -> t (** [of_creator c] returns the corresponding group based on the creator [c].*) + + val to_string : t -> string + (** [to_string g] returns the string representation of the group [g].*) end (** [Cgroup] module encapsulates different function for managing the cgroups -corresponding with [Groups].*) + corresponding with [Groups].*) module Cgroup : sig (** Represents one of the children of the cgroup directory.*) type t = string val dir_of : Group.t -> t option (** [dir_of group] returns the full path of the cgroup directory corresponding - to the group [group] as [Some dir]. - - Returns [None] if [init dir] has not been called. *) + to the group [group] as [Some dir]. + + Returns [None] if [init dir] has not been called. *) val init : string -> unit (** [init dir] initializes the hierachy of cgroups associated to all [Group.t] - types under the directory [dir].*) + types under the directory [dir].*) val set_cgroup : Group.Creator.t -> unit (** [set_cgroup c] sets the current xapi thread in a cgroup based on the - creator [c].*) + creator [c].*) end +val of_creator : Group.Creator.t -> unit +(** [of_creator g] classifies the current thread based based on the creator [c].*) + val of_req_originator : string option -> unit -(** [of_req_originator o] same as [of_originator] but it classifies based on the -http request header.*) +(** [of_req_originator o] same as [of_creator] but it classifies based on the + http request header.*) diff --git a/ocaml/xapi/dune b/ocaml/xapi/dune index 048bd4963f..810fbe71e8 100644 --- a/ocaml/xapi/dune +++ b/ocaml/xapi/dune @@ -78,6 +78,7 @@ sexplib0 sexplib sexpr + tgroup forkexec xapi-idl xapi_aux diff --git a/ocaml/xapi/server_helpers.ml b/ocaml/xapi/server_helpers.ml index e4952769c2..6503277362 100644 --- a/ocaml/xapi/server_helpers.ml +++ b/ocaml/xapi/server_helpers.ml @@ -133,6 +133,19 @@ 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 = + try + 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 + with _ -> None + 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 diff --git a/ocaml/xapi/xapi_session.ml b/ocaml/xapi/xapi_session.ml index 7e77def1f4..95d310a085 100644 --- a/ocaml/xapi/xapi_session.ml +++ b/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) diff --git a/ocaml/xe-cli/newcli.ml b/ocaml/xe-cli/newcli.ml index 56279d6a32..c624eddec5 100644 --- a/ocaml/xe-cli/newcli.ml +++ b/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 ;