IH-577 Implement v7 UUID generation

* New function Uuidx.make_v7_uuid, with the idea being that ordering v7
  UUIDs alphabetically will also order them by creation time. The code
  that constructs a v7 UUIDs from a time and some random bytes has been
  submitted in a PR to the uuidm module, with the intention that if it
  gets merged we can delete our version of it.
* The values produced by Uuidx.make_uuid_urnd hadn't necessarily been
  valid UUIDs, since the variant and version fields were being filled in
  randomly - this is now fixed so that it returns v4 UUIDs as
  constructed by the uuidm module.
* There is a function for generating v7 from known inputs, for the
  purpose of unit testing.

Signed-off-by: Robin Newton <[email protected]>

Author: Robin Newton

ocaml/libs/uuid/dune

@@ -3,7 +3,12 @@
   (public_name uuid)
   (modules uuidx)
   (libraries
-    unix (re_export uuidm)
+    mtime
+    mtime.clock.os
+    ptime
+    ptime.clock.os
+    unix
+    (re_export uuidm)
   )
   (wrapped false)
 )

ocaml/libs/uuid/uuid_test.ml

@@ -25,6 +25,46 @@ let uuid_arrays =
 let non_uuid_arrays =
   [[|0|]; [|0; 1; 2; 3; 4; 5; 6; 7; 8; 9; 10; 11; 12; 13; 14|]]
 
+let uuid_v7_times =
+  let of_ms ms = Int64.mul 1_000_000L (Int64.of_float ms) in
+  let power_of_2_ms n = Float.pow 2.0 (Float.of_int n) |> of_ms in
+  let zero = 0L in
+  let ms = 1_000_000L in
+  let ns = 1L in
+  (* Using RFC9562 "method 3" for representiong sub-millisecond fractions,
+     that smallest amount of time a v7 UUID can represent is 1 / 4096 ms,
+     which is (just more than) 244 nanoseconds *)
+  let tick = 245L in
+  let ( + ) = Int64.add in
+  let ( - ) = Int64.sub in
+  [
+    (zero, "00000000-0000-7000-8000-000000000000")
+  ; (tick, "00000000-0000-7001-8000-000000000000")
+  ; (ms, "00000000-0001-7000-8000-000000000000")
+  ; (ms - ns, "00000000-0000-7fff-8000-000000000000")
+    (* Test a wide range of dates - however, we can't express dates of
+       beyond epoch + (2^64 - 1) nanoseconds, which is about approximately
+       epoch + 2^44 milliseconds - some point in the 26th century *)
+  ; (power_of_2_ms 05, "00000000-0020-7000-8000-000000000000")
+  ; (power_of_2_ms 10, "00000000-0400-7000-8000-000000000000")
+  ; (power_of_2_ms 15, "00000000-8000-7000-8000-000000000000")
+  ; (power_of_2_ms 20, "00000010-0000-7000-8000-000000000000")
+  ; (power_of_2_ms 25, "00000200-0000-7000-8000-000000000000")
+  ; (power_of_2_ms 30, "00004000-0000-7000-8000-000000000000")
+  ; (power_of_2_ms 35, "00080000-0000-7000-8000-000000000000")
+  ; (power_of_2_ms 40, "01000000-0000-7000-8000-000000000000")
+  ; (power_of_2_ms 44, "10000000-0000-7000-8000-000000000000")
+  ; (power_of_2_ms 44 - ns, "0fffffff-ffff-7fff-8000-000000000000")
+  ; (power_of_2_ms 44 + tick, "10000000-0000-7001-8000-000000000000")
+  ]
+
+let uuid_v7_bytes =
+  [
+    (1L, "00000000-0000-7000-8000-000000000001")
+  ; (-1L, "00000000-0000-7000-bfff-ffffffffffff")
+  ; (0x1234_5678_9abc_def0L, "00000000-0000-7000-9234-56789abcdef0")
+  ]
+
 type resource
 
 let uuid_testable : (module Alcotest.TESTABLE with type t = resource Uuidx.t) =
@@ -51,6 +91,39 @@ let roundtrip_tests testing_uuid =
   ; ("Roundtrip array conversion", `Quick, test_array)
   ]
 
+let uuid_v7_time_tests (t, expected_as_string) =
+  let expected =
+    match Uuidx.of_string expected_as_string with
+    | Some uuid ->
+        uuid
+    | None ->
+        Alcotest.fail
+          (Printf.sprintf "Couldn't convert to UUID: %s" expected_as_string)
+  in
+  let zeros = Bytes.make 8 '\x00' in
+  let test () =
+    let result = Uuidx.make_v7_uuid_from_parts t zeros in
+    Alcotest.(check @@ uuid_testable) "make UUIDv7" expected result
+  in
+  (expected_as_string, [("Make UUIDv7 from time", `Quick, test)])
+
+let uuid_v7_bytes_tests (rand_b, expected_as_string) =
+  let expected =
+    match Uuidx.of_string expected_as_string with
+    | Some uuid ->
+        uuid
+    | None ->
+        Alcotest.fail
+          (Printf.sprintf "Couldn't convert to UUID: %s" expected_as_string)
+  in
+  let test () =
+    let bs = Bytes.create 8 in
+    Bytes.set_int64_be bs 0 rand_b ;
+    let result = Uuidx.make_v7_uuid_from_parts 0L bs in
+    Alcotest.(check @@ uuid_testable) "make UUIDv7" expected result
+  in
+  (expected_as_string, [("Make UUIDv7 from bytes", `Quick, test)])
+
 let string_roundtrip_tests testing_string =
   let testing_uuid =
     match Uuidx.of_string testing_string with
@@ -111,6 +184,8 @@ let regression_tests =
     ; List.map array_roundtrip_tests uuid_arrays
     ; List.map invalid_string_tests non_uuid_strings
     ; List.map invalid_array_tests non_uuid_arrays
+    ; List.map uuid_v7_time_tests uuid_v7_times
+    ; List.map uuid_v7_bytes_tests uuid_v7_bytes
     ]
 
 let () = Alcotest.run "Uuid" regression_tests

ocaml/libs/uuid/uuidx.ml

@@ -53,11 +53,49 @@ let read_bytes dev n =
       if read <> n then
         raise End_of_file
       else
-        Bytes.to_string buf
+        buf
     )
     (fun () -> Unix.close fd)
 
-let make_uuid_urnd () = of_bytes (read_bytes dev_urandom 16) |> Option.get
+let make_uuid_urnd () =
+  let buf = read_bytes dev_urandom 16 in
+  Uuidm.v4 buf
+
+(* Implementation of UUIDv7 from https://github.com/dbuenzli/uuidm/pull/14. If
+   this (or something like it) is merged then this can be deleted. *)
+let v7 =
+  let open Int64 in
+  let ns_in_ms = 1_000_000L in
+  let sub_ms_frac_multiplier = unsigned_div minus_one ns_in_ms in
+  fun ts b ->
+    let u = Bytes.create 16 in
+    Bytes.blit b 0 u 8 8 ;
+    (* RFC9562 requires we use 48 bits for a timestamp in milliseconds, and
+       allows for 12 bits to store a sub-millisecond fraction. We get the
+       latter by multiplying to put the fraction in a 64-bit range, then
+       shifting into 12 bits. *)
+    let ms = unsigned_div ts ns_in_ms in
+    let ns = unsigned_rem ts ns_in_ms in
+    let sub_ms_frac = shift_right_logical (mul ns sub_ms_frac_multiplier) 52 in
+    Bytes.set_int64_be u 0 (shift_left ms 16) ;
+    Bytes.set_int16_be u 6 (to_int sub_ms_frac) ;
+    let b6 = 0b0111_0000 lor (Char.code (Bytes.get u 6) land 0b0000_1111) in
+    let b8 = 0b1000_0000 lor (Char.code (Bytes.get u 8) land 0b0011_1111) in
+    Bytes.set u 6 (Char.unsafe_chr b6) ;
+    Bytes.set u 8 (Char.unsafe_chr b8) ;
+    Bytes.unsafe_to_string u
+
+let make_v7_uuid_from_parts ts b = v7 ts b |> of_bytes |> Option.get
+
+let make_v7_uuid =
+  let start = Mtime_clock.counter () in
+  let t0 =
+    let d, ps = Ptime_clock.now () |> Ptime.to_span |> Ptime.Span.to_d_ps in
+    Int64.(add (mul (of_int d) 86_400_000_000_000L) (div ps 1000L))
+  in
+  fun () ->
+    let since_t0 = Mtime_clock.count start |> Mtime.Span.to_uint64_ns in
+    make_v7_uuid_from_parts (Int64.add t0 since_t0) (read_bytes dev_urandom 8)
 
 (* Use the CSPRNG-backed urandom *)
 let make = make_uuid_urnd
@@ -66,7 +104,7 @@ type cookie = string
 
 let make_cookie () =
   read_bytes dev_urandom 64
-  |> String.to_seq
+  |> Bytes.to_seq
   |> Seq.map (fun c -> Printf.sprintf "%1x" (int_of_char c))
   |> List.of_seq
   |> String.concat ""

ocaml/libs/uuid/uuidx.mli

@@ -27,14 +27,24 @@
 type 'a t
 
 val null : 'a t
-(** A null UUID, as if such a thing actually existed. It turns out to be
-    useful though. *)
+(** A null UUID, as defined in RFC 9562 5.9. *)
 
 val make : unit -> 'a t
 (** Create a fresh UUID *)
 
 val make_uuid_urnd : unit -> 'a t
 
+val make_v7_uuid_from_parts : int64 -> bytes -> 'a t
+(** For testing only: create a v7 UUID, as defined in RFC 9562 5.7 *)
+
+val make_v7_uuid : unit -> 'a t
+(** Create a fresh v7 UUID, as defined in RFC 9562 5.7. This incorporates a
+    POSIX timestamp, such that the alphabetic of any two such UUIDs will match
+    the timestamp order - provided that they are at least 245 nanoseconds
+    apart. Note that in order to ensure that the timestamps used are
+    monotonic, operating time adjustments are ignored and hence timestamps
+    only approximate system time. *)
+
 val pp : Format.formatter -> 'a t -> unit
 
 val equal : 'a t -> 'a t -> bool