Merge feature/perf to master

dune-project

@@ -37,6 +37,13 @@
   )
 )
 
+(package
+  (name tgroup)
+  (depends 
+    xapi-log
+    xapi-stdext-unix)
+)
+
 (package
   (name xml-light2)
 )
@@ -321,6 +328,7 @@
   (synopsis "The toolstack daemon which implements the XenAPI")
   (description "This daemon exposes the XenAPI and is used by clients such as 'xe' and 'XenCenter' to manage clusters of Xen-enabled hosts.")
   (depends
+    (ocaml (>= 4.09))
     (alcotest :with-test)
     angstrom
     astring
@@ -374,6 +382,7 @@
     tar
     tar-unix
     uri
+    tgroup
     (uuid (= :version))
     uutf
     uuidm
@@ -587,6 +596,7 @@ This package provides an Lwt compatible interface to the library.")
     (safe-resources(= :version))
     sha
     (stunnel (= :version))
+    tgroup
     uri
     (uuid (= :version))
     xapi-backtrace

http-lib.opam

@@ -22,6 +22,7 @@ depends: [
   "safe-resources" {= version}
   "sha"
   "stunnel" {= version}
+  "tgroup"
   "uri"
   "uuid" {= version}
   "xapi-backtrace"

ocaml/idl/datamodel.ml

@@ -8517,11 +8517,18 @@ module Event = struct
         ]
       ~doc:
         "Blocking call which returns a (possibly empty) batch of events. This \
-         method is only recommended for legacy use. New development should use \
-         event.from which supersedes this method."
+         method is only recommended for legacy use.It stores events in a \
+         buffer of limited size, raising EVENTS_LOST if too many events got \
+         generated. New development should use event.from which supersedes \
+         this method."
       ~custom_marshaller:true ~flags:[`Session]
       ~result:(Set (Record _event), "A set of events")
-      ~errs:[Api_errors.session_not_registered; Api_errors.events_lost]
+      ~errs:
+        [
+          Api_errors.session_not_registered
+        ; Api_errors.events_lost
+        ; Api_errors.event_subscription_parse_failure
+        ]
       ~allowed_roles:_R_ALL ()
 
   let from =
@@ -8551,7 +8558,8 @@ module Event = struct
       ~doc:
         "Blocking call which returns a new token and a (possibly empty) batch \
          of events. The returned token can be used in subsequent calls to this \
-         function."
+         function. It eliminates redundant events (e.g. same field updated \
+         multiple times)."
       ~custom_marshaller:true ~flags:[`Session]
       ~result:
         ( Set (Record _event)
@@ -8562,7 +8570,11 @@ module Event = struct
         (*In reality the event batch is not a set of records as stated here.
           Due to the difficulty of representing this in the datamodel, the doc is generated manually,
           so ensure the markdown_backend.ml and gen_json.ml is updated if something changes. *)
-      ~errs:[Api_errors.session_not_registered; Api_errors.events_lost]
+      ~errs:
+        [
+          Api_errors.event_from_token_parse_failure
+        ; Api_errors.event_subscription_parse_failure
+        ]
       ~allowed_roles:_R_ALL ()
 
   let get_current_id =

ocaml/libs/http-lib/dune

@@ -43,6 +43,7 @@
     http_lib
     ipaddr
     polly
+    tgroup
     threads.posix
     tracing
     tracing_propagator

ocaml/libs/http-lib/http.ml

@@ -132,6 +132,8 @@ module Hdr = struct
 
   let location = "location"
 
+  let originator = "originator"
+
   let hsts = "strict-transport-security"
 end
 
@@ -674,6 +676,14 @@ module Request = struct
     let headers, body = to_headers_and_body x in
     let frame_header = if x.frame then make_frame_header headers else "" in
     frame_header ^ headers ^ body
+
+  let with_originator_of req f =
+    Option.iter
+      (fun req ->
+        let originator = List.assoc_opt Hdr.originator req.additional_headers in
+        f originator
+      )
+      req
 end
 
 module Response = struct

ocaml/libs/http-lib/http.mli

@@ -126,6 +126,8 @@ module Request : sig
 
   val to_wire_string : t -> string
   (** [to_wire_string t] returns a string which could be sent to a server *)
+
+  val with_originator_of : t option -> (string option -> unit) -> unit
 end
 
 (** Parsed form of the HTTP response *)

ocaml/libs/http-lib/http_svr.ml

@@ -574,6 +574,8 @@ let handle_connection ~header_read_timeout ~header_total_timeout
         ~max_length:max_header_length ss
     in
 
+    Http.Request.with_originator_of req Tgroup.of_req_originator ;
+
     (* 2. now we attempt to process the request *)
     let finished =
       Option.fold ~none:true

ocaml/libs/stunnel/stunnel_cache.ml

@@ -40,15 +40,19 @@ let debug = if debug_enabled then debug else ignore_log
 type endpoint = {host: string; port: int}
 
 (* Need to limit the absolute number of stunnels as well as the maximum age *)
-let max_stunnel = 70
+let max_stunnel = Atomic.make 70
 
-let max_age = 180. *. 60. (* seconds *)
+let set_max_stunnel n =
+  D.info "Setting max_stunnel = %d" n ;
+  Atomic.set max_stunnel n
 
-let max_idle = 5. *. 60. (* seconds *)
+let max_age = ref (180. *. 60.) (* seconds *)
+
+let max_idle = ref (5. *. 60.) (* seconds *)
 
 (* The add function adds the new stunnel before doing gc, so the cache *)
 (* can briefly contain one more than maximum. *)
-let capacity = max_stunnel + 1
+let capacity = Atomic.get max_stunnel + 1
 
 (** An index of endpoints to stunnel IDs *)
 let index : (endpoint, int list) Hashtbl.t ref = ref (Hashtbl.create capacity)
@@ -104,6 +108,7 @@ let unlocked_gc () =
   let to_gc = ref [] in
   (* Find the ones which are too old *)
   let now = Unix.gettimeofday () in
+  let max_age = !max_age and max_idle = !max_idle in
   Tbl.iter !stunnels (fun idx stunnel ->
       match Hashtbl.find_opt !times idx with
       | Some time ->
@@ -122,6 +127,7 @@ let unlocked_gc () =
           debug "%s: found no entry for idx=%d" __FUNCTION__ idx
   ) ;
   let num_remaining = List.length all_ids - List.length !to_gc in
+  let max_stunnel = Atomic.get max_stunnel in
   if num_remaining > max_stunnel then (
     let times' = Hashtbl.fold (fun k v acc -> (k, v) :: acc) !times [] in
     let times' =

ocaml/libs/stunnel/stunnel_cache.mli

@@ -19,6 +19,11 @@
     HTTP 1.1 should be used and the connection should be kept-alive.
 *)
 
+val set_max_stunnel : int -> unit
+(** [set_max_stunnel] set the maximum number of unusued, but cached client stunnel connections.
+  This should be a low number on pool members, to avoid hitting limits on the coordinator with large pools.
+ *)
+
 val with_connect :
      ?use_fork_exec_helper:bool
   -> ?write_to_log:(string -> unit)
@@ -46,3 +51,9 @@ val flush : unit -> unit
 
 val gc : unit -> unit
 (** GCs old stunnels *)
+
+val max_age : float ref
+(** maximum time a connection is kept in the stunnel cache, counted from the time it got initially added to the cache *)
+
+val max_idle : float ref
+(** maximum time a connection is kept in the stunnel cache, counted from the most recent time it got (re)added to the cache. *)

ocaml/libs/tgroup/dune

@@ -0,0 +1,11 @@
+(library
+ (name tgroup)
+ (modules tgroup)
+ (public_name tgroup)
+ (libraries xapi-log xapi-stdext-unix xapi-stdext-std))
+
+(test
+ (name test_tgroup)
+ (modules test_tgroup)
+ (package tgroup)
+ (libraries tgroup alcotest xapi-log))

ocaml/libs/tgroup/test_tgroup.ml

@@ -0,0 +1,83 @@
+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")
+    ; ((Some "", "S-R-X-Y1-Y2-Yn-1-Yn"), "SRXY1Y2Yn1Yn")
+    ; ( (Some "XenCenter2024", "S-R-X-Y1-Y2-Yn-1-Yn")
+      , "SRXY1Y2Yn1Yn/XenCenter2024"
+      )
+    ]
+  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 Tgroup.Group.Endpoint.External
+        , Some dummy_identity
+        , Some "sm"
+        )
+      , "external/intrapool"
+      )
+    ; ( ( Some true
+        , Some Tgroup.Group.Endpoint.Internal
+        , Some dummy_identity
+        , Some "sm"
+        )
+      , "external/intrapool"
+      )
+    ; ( ( None
+        , Some Tgroup.Group.Endpoint.Internal
+        , 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 originator = Option.map Tgroup.Group.Originator.of_string originator in
+    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)]