Update feature/perf from master (#6111)

ocaml/forkexecd/lib/fe_systemctl.ml

@@ -60,8 +60,6 @@ let start_transient ?(env = Array.of_list default_env) ?(properties = [])
          )
        ; ("SyslogIdentifier", syslog_key)
        ; ("SyslogLevel", "debug")
-       ; ("StandardOutput", "syslog")
-       ; ("StandardError", "inherit")
        ; ("StartLimitInterval", "0") (* no rate-limit, for bootstorms *)
        ; ("ExecStart", String.concat " " (cmd :: List.map Filename.quote args))
        ; ("Type", Type.to_string exec_ty)

ocaml/forkexecd/test/fe_test.ml

@@ -292,7 +292,7 @@ let slave = function
       (*
 		  Printf.fprintf stderr "%s %d\n" total_fds (List.length present - 1)
 		*)
-      if total_fds + 1 (* Uuid.dev_urandom *) <> List.length filtered then
+      if total_fds <> List.length filtered then
         fail "Expected %d fds; /proc/self/fd has %d: %s" total_fds
           (List.length filtered) ls
 

ocaml/idl/datamodel.ml

@@ -4181,6 +4181,13 @@ module SR = struct
           , "Exporting a bitmap that shows the changed blocks between two VDIs"
           )
         ; ("vdi_set_on_boot", "Setting the on_boot field of the VDI")
+        ; ("vdi_blocked", "Blocking other operations for a VDI")
+        ; ("vdi_copy", "Copying the VDI")
+        ; ("vdi_force_unlock", "Forcefully unlocking the VDI")
+        ; ("vdi_forget", "Forgetting about the VDI")
+        ; ("vdi_generate_config", "Generating the configuration of the VDI")
+        ; ("vdi_resize_online", "Resizing the VDI online")
+        ; ("vdi_update", "Refreshing the fields on the VDI")
         ; ("pbd_create", "Creating a PBD for this SR")
         ; ("pbd_destroy", "Destroying one of this SR's PBDs")
         ]
@@ -4994,11 +5001,21 @@ module SM = struct
                 , "capabilities of the SM plugin, with capability version \
                    numbers"
                 )
+              ; ( Changed
+                , "24.37.0"
+                , "features are now pool-wide, instead of what is available on \
+                   the coordinator sm"
+                )
               ]
             ~ty:(Map (String, Int))
             "features"
             "capabilities of the SM plugin, with capability version numbers"
             ~default_value:(Some (VMap []))
+        ; field ~in_oss_since:None ~qualifier:DynamicRO ~lifecycle:[]
+            ~ty:(Map (Ref _host, Set String))
+            ~internal_only:true "host_pending_features"
+            "SM features that are waiting to be declared per host."
+            ~default_value:(Some (VMap []))
         ; field
             ~lifecycle:[(Published, rel_miami, "additional configuration")]
             ~default_value:(Some (VMap []))

ocaml/idl/datamodel_common.ml

@@ -10,7 +10,7 @@ open Datamodel_roles
               to leave a gap for potential hotfixes needing to increment the schema version.*)
 let schema_major_vsn = 5
 
-let schema_minor_vsn = 783
+let schema_minor_vsn = 785
 
 (* Historical schema versions just in case this is useful later *)
 let rio_schema_major_vsn = 5

ocaml/idl/datamodel_errors.ml

@@ -890,6 +890,13 @@ let _ =
       "The host joining the pool has different CA certificates from the pool \
        coordinator while using the same name, uninstall them and try again."
     () ;
+  error Api_errors.pool_joining_sm_features_incompatible
+    ["pool_sm_ref"; "candidate_sm_ref"]
+    ~doc:
+      "The host joining the pool has an incompatible set of sm features from \
+       the pool coordinator. Make sure the sm are of the same versions and try \
+       again."
+    () ;
 
   (* External directory service *)
   error Api_errors.subject_cannot_be_resolved []

ocaml/idl/datamodel_lifecycle.ml

@@ -51,6 +51,8 @@ let prototyped_of_field = function
       Some "22.26.0"
   | "VTPM", "persistence_backend" ->
       Some "22.26.0"
+  | "SM", "host_pending_features" ->
+      Some "24.36.0-next"
   | "host", "last_update_hash" ->
       Some "24.10.0"
   | "host", "pending_guidances_full" ->

ocaml/idl/schematest.ml

@@ -3,7 +3,7 @@ let hash x = Digest.string x |> Digest.to_hex
 (* BEWARE: if this changes, check that schema has been bumped accordingly in
    ocaml/idl/datamodel_common.ml, usually schema_minor_vsn *)
 
-let last_known_schema_hash = "8fcd8892ec0c7d130b0da44c5fd3990b"
+let last_known_schema_hash = "18df8c33434e3df1982e11ec55d1f3f8"
 
 let current_schema_hash : string =
   let open Datamodel_types in

ocaml/libs/http-lib/http_svr.ml

@@ -648,7 +648,7 @@ let start ?header_read_timeout ?header_total_timeout ?max_header_length
     ; body=
         handle_connection ~header_read_timeout ~header_total_timeout
           ~max_header_length x
-    ; lock= Xapi_stdext_threads.Semaphore.create conn_limit
+    ; lock= Semaphore.Counting.make conn_limit
     }
   in
   let server = Server_io.server handler socket in

ocaml/libs/http-lib/server_io.ml

@@ -23,15 +23,15 @@ type handler = {
     name: string
   ; (* body should close the provided fd *)
     body: Unix.sockaddr -> Unix.file_descr -> unit
-  ; lock: Xapi_stdext_threads.Semaphore.t
+  ; lock: Semaphore.Counting.t
 }
 
 let handler_by_thread (h : handler) (s : Unix.file_descr)
     (caller : Unix.sockaddr) =
   Thread.create
     (fun () ->
       Fun.protect
-        ~finally:(fun () -> Xapi_stdext_threads.Semaphore.release h.lock 1)
+        ~finally:(fun () -> Semaphore.Counting.release h.lock)
         (Debug.with_thread_named h.name (fun () -> h.body caller s))
     )
     ()
@@ -49,7 +49,7 @@ let establish_server ?(signal_fds = []) forker handler sock =
       @@ Polly.wait epoll 2 (-1) (fun _ fd _ ->
              (* If any of the signal_fd is active then bail out *)
              if List.mem fd signal_fds then raise PleaseClose ;
-             Xapi_stdext_threads.Semaphore.acquire handler.lock 1 ;
+             Semaphore.Counting.acquire handler.lock ;
              let s, caller = Unix.accept ~cloexec:true sock in
              try ignore (forker handler s caller)
              with exc ->

ocaml/libs/http-lib/server_io.mli

@@ -16,7 +16,7 @@ type handler = {
     name: string  (** used for naming the thread *)
   ; body: Unix.sockaddr -> Unix.file_descr -> unit
         (** function called in a thread for each connection*)
-  ; lock: Xapi_stdext_threads.Semaphore.t
+  ; lock: Semaphore.Counting.t
 }
 
 type server = {

ocaml/libs/sexpr/sExpr.ml

@@ -11,11 +11,7 @@
  * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  * GNU Lesser General Public License for more details.
  *)
-type t =
-  | Node of t list
-  | Symbol of string
-  | String of string
-  | WeirdString of string * string
+type t = Node of t list | Symbol of string | String of string
 
 let unescape_buf buf s =
   let aux esc = function
@@ -84,31 +80,13 @@ let string_of sexpr =
             List.iter (fun i -> Buffer.add_char buf ' ' ; __string_of_rec i) l
         ) ;
         Buffer.add_char buf ')'
-    | Symbol s | String s | WeirdString (_, s) ->
+    | Symbol s | String s ->
         Buffer.add_string buf "\'" ;
         Buffer.add_string buf (escape s) ;
         Buffer.add_string buf "\'"
   in
   __string_of_rec sexpr ; Buffer.contents buf
 
-let weird_of_string x =
-  let random_chars = "abcdefghijklmnopqrstuvwxyz" in
-  let randchar () =
-    String.sub random_chars (Random.int (String.length random_chars)) 1
-  in
-  (* true if the parent string contains child as a substring, starting the
-     search forward from offset *)
-  let rec has_substring parent offset child =
-    String.length parent - offset >= String.length child
-    && (String.sub parent offset (String.length child) = child
-       || has_substring parent (offset + 1) child
-       )
-  in
-  let rec find delim =
-    if has_substring x 0 delim then find (delim ^ randchar ()) else delim
-  in
-  WeirdString (find "xxx", x)
-
 let rec output_fmt ff = function
   | Node list ->
       let rec aux ?(first = true) = function
@@ -121,12 +99,5 @@ let rec output_fmt ff = function
             aux ~first t
       in
       Format.fprintf ff "@[(" ; aux list ; Format.fprintf ff ")@]"
-  | Symbol s | String s | WeirdString (_, s) ->
+  | Symbol s | String s ->
       Format.fprintf ff "\"%s\"" (escape s)
-
-(*
-  | Symbol s ->
-      Format.fprintf ff "%s" s
-  | WeirdString(tag, s) ->
-      Format.fprintf ff "<<%s<%s<%s<" tag s tag
-*)

ocaml/libs/sexpr/sExpr.mli

@@ -11,16 +11,10 @@
  * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  * GNU Lesser General Public License for more details.
  *)
-type t =
-  | Node of t list
-  | Symbol of string
-  | String of string
-  | WeirdString of string * string
+type t = Node of t list | Symbol of string | String of string
 
 val mkstring : string -> t
 
 val string_of : t -> string
 
-val weird_of_string : string -> t
-
 val output_fmt : Format.formatter -> t -> unit

ocaml/libs/sexpr/sExprLexer.mll

@@ -1,14 +1,9 @@
 {
   open SExprParser
-  let line = ref 1
 }
 
 rule token = parse
-  | [' ' '\t' '\r']                     { token lexbuf }
-  | ';' [^ '\n']* '\n'                  { incr line; token lexbuf }
-  | '\n'                                { incr line; token lexbuf }
-  | "<<" ([^ '<']+ as tag1) '<' ([^ '<']* as s) '<' ([^ '<']+ as tag2) '<'
-      { if tag1=tag2 then WEIRD(tag1, s) else invalid_arg "Weird tag" }
+  | [' ' '\t' '\r' '\n']+ | ';' [^ '\n']* '\n'     { token lexbuf }
   | '"'  (([^ '"' '\\']  | ('\\' _))* as s) '"'    { STRING s }
   | '\'' (([^ '\'' '\\'] | ('\\' _))* as s) '\''   { STRING s }
   | [^ '"' ' ' '\t' '\n' '(' ')']+ as s { SYMBOL s }

ocaml/libs/sexpr/sExprParser.mly

@@ -1,17 +1,11 @@
 %token <string> SYMBOL STRING
-%token <string * string> WEIRD
 %token OPEN CLOSE
 
-%start expr
-%type <SExpr.t> expr
+%start<SExpr.t> expr
 
 %%
 
-expr_list: { [] }
-| expr expr_list { $1 :: $2 };
-
 expr:
-| OPEN expr_list CLOSE { SExpr.Node $2 }
-| SYMBOL               { SExpr.Symbol $1 }
-| STRING               { SExpr.mkstring $1 }
-| WEIRD                { (fun (tag, s) -> SExpr.WeirdString(tag, s)) $1 };
+| OPEN es = list(expr) CLOSE { SExpr.Node es }
+| s = SYMBOL { SExpr.Symbol s }
+| s = STRING { SExpr.mkstring s }

ocaml/libs/uuid/uuidx.ml

@@ -116,48 +116,39 @@ let is_uuid str = match of_string str with None -> false | Some _ -> true
 
 let dev_urandom = "/dev/urandom"
 
-let dev_urandom_fd = Unix.openfile dev_urandom [Unix.O_RDONLY] 0o640
-(* we can't close this in at_exit, because Crowbar runs at_exit, and
-   it'll fail because this FD will then be closed
-*)
-
-let read_bytes dev n =
-  let buf = Bytes.create n in
-  let read = Unix.read dev buf 0 n in
-  if read <> n then
-    raise End_of_file
-  else
-    Bytes.to_string buf
-
-let make_uuid_urnd () = of_bytes (read_bytes dev_urandom_fd 16) |> Option.get
-
-(* State for random number generation. Random.State.t isn't thread safe, so
-   only use this via with_non_csprng_state, which takes care of this.
-*)
-let rstate = Random.State.make_self_init ()
-
-let rstate_m = Mutex.create ()
-
-let with_non_csprng_state =
-  (* On OCaml 5 we could use Random.State.split instead,
-     and on OCaml 4 the mutex may not be strictly needed
-  *)
-  let finally () = Mutex.unlock rstate_m in
-  fun f ->
-    Mutex.lock rstate_m ;
-    Fun.protect ~finally (f rstate)
-
-(** Use non-CSPRNG by default, for CSPRNG see {!val:make_uuid_urnd} *)
-let make_uuid_fast () = with_non_csprng_state Uuidm.v4_gen
-
-let make_default = ref make_uuid_urnd
-
-let make () = !make_default ()
+let generate =
+  let mutex = Mutex.create () in
+  let dev_urandom_ic = ref None in
+  let finally () = Mutex.unlock mutex in
+  let with_mutex fn = Mutex.lock mutex ; Fun.protect ~finally fn in
+  let close_ic () =
+    with_mutex @@ fun () ->
+    !dev_urandom_ic |> Option.iter close_in_noerr ;
+    dev_urandom_ic := None
+  in
+  fun n ->
+    with_mutex @@ fun () ->
+    let ic =
+      match !dev_urandom_ic with
+      | None ->
+          let ic = open_in_bin dev_urandom in
+          at_exit close_ic ;
+          dev_urandom_ic := Some ic ;
+          ic
+      | Some ic ->
+          ic
+    in
+    really_input_string ic n
+
+let make_uuid_urnd () = of_bytes (generate 16) |> Option.get
+
+let make_uuid_fast = make_uuid_urnd
+
+let make = make_uuid_urnd
 
 let make_v7_uuid_from_parts time_ns rand_b = Uuidm.v7_ns ~time_ns ~rand_b
 
-let rand64 () =
-  with_non_csprng_state (fun rstate () -> Random.State.bits64 rstate)
+let rand64 () = String.get_int64_ne (generate 8) 0
 
 let now_ns =
   let start = Mtime_clock.counter () in
@@ -174,7 +165,7 @@ let make_v7_uuid () = make_v7_uuid_from_parts (now_ns ()) (rand64 ())
 type cookie = string
 
 let make_cookie () =
-  read_bytes dev_urandom_fd 64
+  generate 64
   |> String.to_seq
   |> Seq.map (fun c -> Printf.sprintf "%1x" (int_of_char c))
   |> List.of_seq

ocaml/libs/uuid/uuidx.mli

@@ -194,8 +194,3 @@ module Hash : sig
   (* UUID Version 5 derived from argument string and namespace UUID *)
   val string : string -> [< not_secret] t
 end
-
-(**/**)
-
-(* just for feature flag, to be removed *)
-val make_default : (unit -> [< not_secret] t) ref