CP-49135: speed up UUID generation

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 <> List.length filtered then
+      if total_fds + 1 (* Uuid.dev_urandom *) <> List.length filtered then
         fail "Expected %d fds; /proc/self/fd has %d: %s" total_fds
           (List.length filtered) ls
 

ocaml/idl/ocaml_backend/gen_api.ml

@@ -400,15 +400,7 @@ let gen_client_types highapi =
          ; "  Rpc.failure (rpc_of_failure ([\"Fault\"; code]))"
          ]
        ; ["include Rpc"; "type string_list = string list [@@deriving rpc]"]
-       ; [
-           "module Ref = struct"
-         ; "  include Ref"
-         ; "  let rpc_of_t (_:'a -> Rpc.t) (x: 'a Ref.t) = rpc_of_string \
-            (Ref.string_of x)"
-         ; "  let t_of_rpc (_:Rpc.t -> 'a) x : 'a t = of_string (string_of_rpc \
-            x);"
-         ; "end"
-         ]
+       ; ["module Ref = Ref"]
        ; [
            "module Date = struct"
          ; "  open Xapi_stdext_date"

ocaml/idl/ocaml_backend/gen_db_actions.ml

@@ -134,8 +134,12 @@ let string_to_dm tys : O.Module.t =
       | DT.Map (key, value) ->
           let kf = OU.alias_of_ty key and vf = OU.alias_of_ty value in
           "fun m -> map " ^ kf ^ " " ^ vf ^ " m"
-      | DT.Ref _ ->
-          "fun x -> (Ref.of_string x : " ^ OU.ocaml_of_ty ty ^ ")"
+      | DT.Ref t ->
+          "fun x -> (Ref.of_"
+          ^ (if t = "session" then "secret_" else "")
+          ^ "string x : "
+          ^ OU.ocaml_of_ty ty
+          ^ ")"
       | DT.Set ty ->
           "fun s -> set " ^ OU.alias_of_ty ty ^ " s"
       | DT.String ->
@@ -360,7 +364,8 @@ let db_action api : O.Module.t =
               expr
           ; Printf.sprintf
               "List.map (fun (ref,(__regular_fields,__set_refs)) -> \
-               Ref.of_string ref, %s __regular_fields __set_refs) records"
+               Ref.of_%sstring ref, %s __regular_fields __set_refs) records"
+              (if obj.DT.name = "session" then "secret_" else "")
               conversion_fn
           ]
         )
@@ -374,9 +379,10 @@ let db_action api : O.Module.t =
             obj.DT.name
         ; Printf.sprintf
             "(fun ~__context ~self -> (fun () -> API.rpc_of_%s_t \
-             (%s.get_record ~__context ~self:(Ref.of_string self))))"
+             (%s.get_record ~__context ~self:(Ref.of_%sstring self))))"
             (OU.ocaml_of_record_name obj.DT.name)
             (OU.ocaml_of_obj_name obj.DT.name)
+            (if obj.DT.name = "session" then "secret_" else "")
         ]
       ()
   in

ocaml/libs/uuid/dune

@@ -4,6 +4,7 @@
   (modules uuidx)
   (libraries
     unix (re_export uuidm)
+    threads.posix
   )
   (wrapped false)
 )

ocaml/libs/uuid/uuid_test.ml

@@ -25,7 +25,7 @@ let uuid_arrays =
 let non_uuid_arrays =
   [[|0|]; [|0; 1; 2; 3; 4; 5; 6; 7; 8; 9; 10; 11; 12; 13; 14|]]
 
-type resource
+type resource = [`Generic]
 
 let uuid_testable : (module Alcotest.TESTABLE with type t = resource Uuidx.t) =
   Alcotest.testable Uuidx.pp Uuidx.equal

ocaml/libs/uuid/uuidx.ml

@@ -12,7 +12,85 @@
  * GNU Lesser General Public License for more details.
  *)
 
-type 'a t = Uuidm.t
+type without_secret =
+  [ `auth
+  | `blob
+  | `Bond
+  | `Certificate
+  | `Cluster
+  | `Cluster_host
+  | `console
+  | `crashdump
+  | `data_source
+  | `Diagnostics
+  | `DR_task
+  | `event
+  | `Feature
+  | `generation
+  | `Generic
+  | `GPU_group
+  | `host
+  | `host_cpu
+  | `host_crashdump
+  | `host_metrics
+  | `host_patch
+  | `LVHD
+  | `message
+  | `network
+  | `network_sriov
+  | `Observer
+  | `PBD
+  | `PCI
+  | `PGPU
+  | `PIF
+  | `PIF_metrics
+  | `pool
+  | `pool_patch
+  | `pool_update
+  | `probe_result
+  | `PUSB
+  | `PVS_cache_storage
+  | `PVS_proxy
+  | `PVS_server
+  | `PVS_site
+  | `Repository
+  | `role
+  | `SDN_controller
+  | `secret
+  | `SM
+  | `SR
+  | `sr_stat
+  | `subject
+  | `task
+  | `tunnel
+  | `USB_group
+  | `user
+  | `VBD
+  | `VBD_metrics
+  | `VDI
+  | `vdi_nbd_server_info
+  | `VGPU
+  | `VGPU_type
+  | `VIF
+  | `VIF_metrics
+  | `VLAN
+  | `VM
+  | `VM_appliance
+  | `VM_group
+  | `VM_guest_metrics
+  | `VM_metrics
+  | `VMPP
+  | `VMSS
+  | `VTPM
+  | `VUSB ]
+
+type secret = [`session]
+
+type not_secret = [without_secret | `session of [`use_make_uuid_rnd_instead]]
+
+type all = [without_secret | secret]
+
+type 'a t = Uuidm.t constraint 'a = [< all]
 
 let null = Uuidm.nil
 
@@ -38,34 +116,40 @@ 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 fd = Unix.openfile dev [Unix.O_RDONLY] 0o640 in
-  let finally body_f clean_f =
-    try
-      let ret = body_f () in
-      clean_f () ; ret
-    with e -> clean_f () ; raise e
-  in
-  finally
-    (fun () ->
-      let buf = Bytes.create n in
-      let read = Unix.read fd buf 0 n in
-      if read <> n then
-        raise End_of_file
-      else
-        Bytes.to_string buf
-    )
-    (fun () -> Unix.close fd)
-
-let make_uuid_urnd () = of_bytes (read_bytes dev_urandom 16) |> Option.get
-
-(* Use the CSPRNG-backed urandom *)
-let make = make_uuid_urnd
+  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
+
+(** Use non-CSPRNG by default, for CSPRNG see {!val:make_uuid_urnd} *)
+let make_uuid_fast =
+  let uuid_state = Random.State.make_self_init () in
+  (* On OCaml 5 we could use Random.State.split instead,
+     and on OCaml 4 the mutex may not be strictly needed
+  *)
+  let m = Mutex.create () in
+  let finally () = Mutex.unlock m in
+  let gen = Uuidm.v4_gen uuid_state in
+  fun () -> Mutex.lock m ; Fun.protect ~finally gen
+
+let make_default = ref make_uuid_urnd
+
+let make () = !make_default ()
 
 type cookie = string
 
 let make_cookie () =
-  read_bytes dev_urandom 64
+  read_bytes dev_urandom_fd 64
   |> String.to_seq
   |> Seq.map (fun c -> Printf.sprintf "%1x" (int_of_char c))
   |> List.of_seq