CP-52911: Negative scheduler for xapi threads.

dune-project

@@ -350,6 +350,7 @@
     astring
     base-threads
     base64
+    bechamel
     (bos :with-test)
     cdrom
     (clock (= :version))

ocaml/libs/http-lib/dune

@@ -59,6 +59,7 @@
   tracing_propagator
   uri
   xapi-backtrace
+  xapi-consts
   xapi-log
   xapi-stdext-pervasives
   xapi-stdext-threads

ocaml/libs/http-lib/http.ml

@@ -676,14 +676,6 @@ 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

@@ -129,8 +129,6 @@ 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 *)
@@ -229,6 +227,8 @@ module Hdr : sig
 
   val hsts : string
   (** Header used for HTTP Strict Transport Security *)
+
+  val originator : string
 end
 
 val output_http : Unix.file_descr -> string list -> unit

ocaml/libs/http-lib/http_svr.ml

@@ -575,12 +575,31 @@ 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
-        ~some:(handle_one x ss x.Server.default_context)
+        ~some:(fun req ->
+          if !Constants.tgroups_enabled then (
+            let open Xapi_stdext_threads.Threadext in
+            let originator =
+              List.assoc_opt Http.Hdr.originator
+                req.Http.Request.additional_headers
+            in
+            originator
+            |> Tgroup.of_req_originator
+            |> Option.iter (fun tgroup ->
+                   ThreadRuntimeContext.get ()
+                   |> ThreadRuntimeContext.update (fun thread_ctx ->
+                          {thread_ctx with tgroup}
+                      )
+               ) ;
+
+            let thread_ctx = ThreadRuntimeContext.get () in
+            Tgroup.with_one_thread_of_group thread_ctx.tgroup @@ fun () ->
+            handle_one x ss x.Server.default_context req
+          ) else
+            handle_one x ss x.Server.default_context req
+        )
         req
     in
     (* 3. do it again if the connection is kept open, but without timeouts *)

ocaml/libs/tgroup/dune

@@ -2,7 +2,12 @@
  (name tgroup)
  (modules tgroup)
  (public_name tgroup)
- (libraries xapi-log xapi-stdext-unix xapi-stdext-std))
+ (libraries
+   xapi-log
+   xapi-stdext-pervasives
+   xapi-stdext-unix
+   xapi-stdext-std)
+)
 
 (test
  (name test_tgroup)

ocaml/libs/tgroup/test_tgroup.ml

@@ -20,7 +20,7 @@ let test_identity () =
 
   let test_make ((user_agent, subject_sid), expected_identity) =
     let actual_identity =
-      Tgroup.Group.Identity.(make ?user_agent subject_sid |> to_string)
+      Tgroup.Description.Identity.(make ?user_agent subject_sid |> to_string)
     in
     Alcotest.(check string)
       "Check expected identity" expected_identity actual_identity
@@ -29,28 +29,28 @@ let test_identity () =
 
 let test_of_creator () =
   let dummy_identity =
-    Tgroup.Group.Identity.make ~user_agent:"XenCenter2024" "root"
+    Tgroup.Description.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 Tgroup.Description.Endpoint.External
         , Some dummy_identity
         , Some "sm"
         )
       , "external/intrapool"
       )
     ; ( ( Some true
-        , Some Tgroup.Group.Endpoint.Internal
+        , Some Tgroup.Description.Endpoint.Internal
         , Some dummy_identity
         , Some "sm"
         )
       , "external/intrapool"
       )
     ; ( ( None
-        , Some Tgroup.Group.Endpoint.Internal
+        , Some Tgroup.Description.Endpoint.Internal
         , Some dummy_identity
         , Some "cli"
         )
@@ -62,9 +62,11 @@ let test_of_creator () =
     ]
   in
   let test_make ((intrapool, endpoint, identity, originator), expected_group) =
-    let originator = Option.map Tgroup.Group.Originator.of_string originator in
+    let originator =
+      Option.map Tgroup.Description.Originator.of_string originator
+    in
     let actual_group =
-      Tgroup.Group.(
+      Tgroup.Description.(
         Creator.make ?intrapool ?endpoint ?identity ?originator ()
         |> of_creator
         |> to_string