Merge pull request #4532 from psafont/reuuid

CP-34028: implement Uuid with Uuidm

dune

@@ -4,7 +4,10 @@
     (flags (:standard -w -39))
   )
   (dev (flags (:standard -g -w -39)))
-  (release (flags (:standard -w -39-6)))
+  (release
+    (flags (:standard -w -39-6))
+    (env-vars (ALCOTEST_COMPACT 1))
+  )
 )
 
 (executable

forkexec.opam

@@ -15,7 +15,7 @@ depends: [
   "fd-send-recv"
   "ppx_deriving_rpc"
   "rpclib"
-  "uuidm"
+  "uuid"
   "xapi-idl"
   "xapi-stdext-pervasives"
   "xapi-stdext-unix"

http-svr.opam

@@ -17,6 +17,7 @@ depends: [
   "rpclib"
   "sha"
   "stunnel"
+  "uuid"
   "xapi-stdext-date"
   "xapi-stdext-pervasives"
   "xapi-stdext-threads"

ocaml/database/block_device_io.ml

@@ -104,7 +104,7 @@ let magic_size = 16
 
 let generation_size = 16
 
-let marker_size = String.length (Uuid.to_string (Uuid.make_uuid ()))
+let marker_size = String.length (Uuid.to_string (Uuid.make ()))
 
 let size_size = 16 (* decimal digits *)
 

ocaml/database/dune

@@ -93,6 +93,3 @@
   (package xapi-database)
   (action (run %{x} --master db.xml --test))
 )
-
-(env (_ (env-vars (ALCOTEST_COMPACT 1))))
-

ocaml/database/redo_log.ml

@@ -779,7 +779,7 @@ let create ~name ~state_change_callback ~read_only =
   let instance =
     {
       name
-    ; marker= Uuid.to_string (Uuid.make_uuid ())
+    ; marker= Uuid.to_string (Uuid.make ())
     ; read_only
     ; enabled= ref false
     ; device= ref None

ocaml/forkexecd/cli/dune

@@ -1,7 +1,7 @@
 (executable
  (modes byte exe)
  (name fe_cli)
- (libraries forkexec uuidm))
+ (libraries forkexec))
 
 (install
  (package xapi-forkexecd)

ocaml/forkexecd/lib/dune

@@ -2,7 +2,7 @@
  (name forkexec)
  (public_name forkexec)
  (wrapped false)
- (libraries fd-send-recv rpclib.json threads uuidm xapi-stdext-pervasives
+ (libraries fd-send-recv rpclib.json threads uuid xapi-stdext-pervasives
    xapi-stdext-unix xapi-idl)
  (preprocess
   (pps ppx_deriving_rpc)))

ocaml/forkexecd/lib/forkhelpers.ml

@@ -137,9 +137,9 @@ let safe_close_and_exec ?env stdin stdout stderr
   let sock =
     Fecomms.open_unix_domain_sock_client (runtime_path ^ "/xapi/forker/main")
   in
-  let stdinuuid = Uuidm.to_string (Uuidm.create `V4) in
-  let stdoutuuid = Uuidm.to_string (Uuidm.create `V4) in
-  let stderruuid = Uuidm.to_string (Uuidm.create `V4) in
+  let stdinuuid = Uuid.(to_string (make ())) in
+  let stdoutuuid = Uuid.(to_string (make ())) in
+  let stderruuid = Uuid.(to_string (make ())) in
 
   let fds_to_close = ref [] in
 

ocaml/forkexecd/src/dune

@@ -1,7 +1,7 @@
 (executable
  (modes byte exe)
  (name fe_main)
- (libraries astring forkexec systemd uuidm xapi-stdext-unix))
+ (libraries astring forkexec systemd uuid xapi-stdext-unix))
 
 (install
  (package xapi-forkexecd)

ocaml/forkexecd/src/fe_main.ml

@@ -4,7 +4,7 @@ let setup sock cmdargs id_to_fd_map syslog_stdout redirect_stderr_to_stdout env
     =
   let fd_sock_path =
     Printf.sprintf "%s/fd_%s" Forkhelpers.temp_dir_server
-      (Uuidm.to_string (Uuidm.create `V4))
+      Uuid.(to_string (make ()))
   in
   let fd_sock = Fecomms.open_unix_domain_sock () in
   Xapi_stdext_unix.Unixext.unlink_safe fd_sock_path ;

ocaml/forkexecd/test/dune

@@ -1,7 +1,7 @@
 (executable
  (modes byte exe)
  (name fe_test)
- (libraries forkexec uuidm xapi-stdext-unix))
+ (libraries forkexec xapi-stdext-unix))
 
 (rule
  (alias runtest)

ocaml/forkexecd/test/fe_test.ml

@@ -75,7 +75,7 @@ let one fds x =
     Printf.fprintf stderr "extra = %d\n" x.extra;*)
   let fd = Unix.stdin in
   let make_names n =
-    List.map (fun _ -> Uuidm.to_string (Uuidm.create `V4)) (mkints n)
+    List.map (fun _ -> Uuid.(to_string (make ()))) (mkints n)
   in
   let names = make_names x.named_fds in
   let cmdline_names = irrelevant_strings @ names @ names in

ocaml/gencert/dune

@@ -59,6 +59,3 @@
   )
   (action (run %{test} --color=always))
 )
-
-(env (_ (env-vars (ALCOTEST_COMPACT 1))))
-

ocaml/idl/ocaml_backend/gen_rbac.ml

@@ -57,26 +57,15 @@ let writer_csv static_permissions_roles =
 
 let hash2uuid str =
   let h = Digest.string str in
-  let hex = Digest.to_hex h in
-  let int_array hex =
-    let l = ref [] in
-    Scanf.sscanf hex
-      "%02x%02x%02x%02x%02x%02x%02x%02x%02x%02x%02x%02x%02x%02x%02x%02x"
-      (fun a0 a1 a2 a3 a4 a5 a6 a7 a8 a9 a10 a11 a12 a13 a14 a15 ->
-        l :=
-          [a0; a1; a2; a3; a4; a5; a6; a7; a8; a9; a10; a11; a12; a13; a14; a15]
-    ) ;
-    Array.of_list !l
-  in
-  Uuid.string_of_uuid (Uuid.uuid_of_int_array (int_array hex))
+  Option.map Uuid.to_string (Uuid.of_bytes h)
 
 let replace_char str c1 c2 =
   let buf = Bytes.of_string str in
   (*defensive copy*)
   String.iteri (fun i _ -> if str.[i] = c1 then Bytes.set buf i c2 else ()) str ;
   Bytes.unsafe_to_string buf
 
-let role_uuid name = hash2uuid name
+let role_uuid name = Option.get (hash2uuid name)
 
 let permission_description = "A basic permission"
 

ocaml/libs/http-svr/dune

@@ -11,6 +11,7 @@
     sha
     stunnel
     threads.posix
+    uuid
     xapi-idl
     xapi-idl.updates
     xapi-stdext-date

ocaml/libs/http-svr/xmlrpc_client.ml

@@ -68,7 +68,7 @@ let write_to_log x = StunnelDebug.debug "%s" (Astring.String.trim x)
     closed or left in some other inconsistent state. *)
 let check_reusable_inner (x : Unixfd.t) =
   let msg_name = "system.isAlive" in
-  let msg_uuid = Uuidm.to_string (Uuidm.create `V4) in
+  let msg_uuid = Uuid.(to_string (make ())) in
   (* This is for backward compatability *)
   let msg_func = Printf.sprintf "%s:%s" msg_name msg_uuid in
   let msg_param = [XMLRPC.To.string msg_uuid] in

ocaml/libs/resources/test/dune

@@ -8,6 +8,3 @@
     alcotest
   )
 )
-
-(env (_ (env-vars (ALCOTEST_COMPACT 1))))
-

ocaml/libs/stunnel/dune

@@ -6,7 +6,7 @@
     astring
     forkexec
     safe-resources
-    uuidm
+    uuid
     xapi-idl
     xapi-inventory
     xapi-stdext-pervasives

ocaml/libs/stunnel/stunnel.ml

@@ -297,7 +297,7 @@ let attempt_one_connect ?(use_fork_exec_helper = true)
     ?(write_to_log = fun _ -> ()) ?(extended_diagnosis = false) data_channel
     verify_cert host port =
   Unixfd.with_pipe () ~loc:__LOC__ @@ fun config_out config_in ->
-  let config_out_uuid = Uuidm.to_string (Uuidm.create `V4) in
+  let config_out_uuid = Uuid.(to_string (make ())) in
   let config_out_fd =
     string_of_int (Unixext.int_of_file_descr Unixfd.(!config_out))
   in

ocaml/libs/uuid/dune

@@ -1,8 +1,14 @@
 (library
   (name uuid)
   (public_name uuid)
+  (modules uuid)
   (libraries
-    unix
+    unix uuidm
   )
 )
 
+(test
+  (name uuid_test)
+  (modules uuid_test)
+  (libraries uuid alcotest)
+  )

ocaml/libs/uuid/uuid.ml

@@ -12,56 +12,33 @@
  * GNU Lesser General Public License for more details.
  *)
 
-(* Internally, a UUID is simply a string. *)
-type 'a t = string
+type 'a t = Uuidm.t
 
-type cookie = string
+let null = Uuidm.nil
 
-let of_string s = s
+let pp = Uuidm.pp
 
-let to_string s = s
+let equal = Uuidm.equal
 
-let null = ""
+let of_bytes u = Uuidm.of_bytes ~pos:0 u
 
-(* deprecated: we don't need to duplicate the uuid prefix/suffix *)
-let uuid_of_string = of_string
+let to_bytes = Uuidm.to_bytes
 
-let string_of_uuid = to_string
+let of_int_array arr =
+  arr |> Array.to_seq |> Seq.map char_of_int |> String.of_seq |> of_bytes
 
-let string_of_cookie s = s
+let to_int_array u =
+  Uuidm.to_bytes u |> String.to_seq |> Seq.map int_of_char |> Array.of_seq
 
-let cookie_of_string s = s
+let of_string = Uuidm.of_string ~pos:0
 
-let dev_random = "/dev/random"
+let to_string = Uuidm.to_string ~upper:false
 
-let dev_urandom = "/dev/urandom"
+let is_uuid str = match of_string str with None -> false | Some _ -> true
 
-let rnd_array n =
-  let fstbyte i = 0xff land i in
-  let sndbyte i = fstbyte (i lsr 8) in
-  let thdbyte i = sndbyte (i lsr 8) in
-  let rec rnd_list n acc =
-    match n with
-    | 0 ->
-        acc
-    | 1 ->
-        let b = fstbyte (Random.bits ()) in
-        b :: acc
-    | 2 ->
-        let r = Random.bits () in
-        let b1 = fstbyte r in
-        let b2 = sndbyte r in
-        b1 :: b2 :: acc
-    | n ->
-        let r = Random.bits () in
-        let b1 = fstbyte r in
-        let b2 = sndbyte r in
-        let b3 = thdbyte r in
-        rnd_list (n - 3) (b1 :: b2 :: b3 :: acc)
-  in
-  Array.of_list (rnd_list n [])
+let dev_urandom = "/dev/urandom"
 
-let read_array dev n =
+let read_bytes dev n =
   let fd = Unix.openfile dev [Unix.O_RDONLY] 0o640 in
   let finally body_f clean_f =
     try
@@ -76,45 +53,33 @@ let read_array dev n =
       if read <> n then
         raise End_of_file
       else
-        Array.init n (fun i -> Char.code (Bytes.get buf i))
+        Bytes.to_string buf
     )
     (fun () -> Unix.close fd)
 
-let uuid_of_int_array uuid =
-  Printf.sprintf
-    "%02x%02x%02x%02x-%02x%02x-%02x%02x-%02x%02x-%02x%02x%02x%02x%02x%02x"
-    uuid.(0) uuid.(1) uuid.(2) uuid.(3) uuid.(4) uuid.(5) uuid.(6) uuid.(7)
-    uuid.(8) uuid.(9) uuid.(10) uuid.(11) uuid.(12) uuid.(13) uuid.(14)
-    uuid.(15)
+let make_uuid_urnd () = of_bytes (read_bytes dev_urandom 16) |> Option.get
+
+(* Use the CSPRNG-backed urandom *)
+let make = make_uuid_urnd
+
+type cookie = string
 
-let make_uuid_prng () = uuid_of_int_array (rnd_array 16)
+let make_cookie () =
+  read_bytes dev_urandom 64
+  |> String.to_seq
+  |> Seq.map (fun c -> Printf.sprintf "%1x" (int_of_char c))
+  |> List.of_seq
+  |> String.concat ""
 
-let make_uuid_urnd () = uuid_of_int_array (read_array dev_urandom 16)
+let string_of_cookie s = s
 
-let make_uuid_rnd () = uuid_of_int_array (read_array dev_random 16)
+let cookie_of_string s = s
 
-let make_uuid = make_uuid_urnd
+(* deprecated: we don't need to duplicate the uuid prefix/suffix *)
+let uuid_of_string = of_string
 
-let make_cookie () =
-  let bytes = Array.to_list (read_array dev_urandom 64) in
-  String.concat "" (List.map (Printf.sprintf "%1x") bytes)
-
-let int_array_of_uuid s =
-  try
-    let l = ref [] in
-    Scanf.sscanf s
-      "%02x%02x%02x%02x-%02x%02x-%02x%02x-%02x%02x-%02x%02x%02x%02x%02x%02x"
-      (fun a0 a1 a2 a3 a4 a5 a6 a7 a8 a9 a10 a11 a12 a13 a14 a15 ->
-        l :=
-          [a0; a1; a2; a3; a4; a5; a6; a7; a8; a9; a10; a11; a12; a13; a14; a15]
-    ) ;
-    Array.of_list !l
-  with _ -> invalid_arg "Uuid.int_array_of_uuid"
-
-let is_uuid str =
-  try
-    Scanf.sscanf str
-      "%02x%02x%02x%02x-%02x%02x-%02x%02x-%02x%02x-%02x%02x%02x%02x%02x%02x"
-      (fun _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ -> true
-    )
-  with _ -> false
+let string_of_uuid = to_string
+
+let uuid_of_int_array = of_int_array
+
+let int_array_of_uuid = to_int_array