Add support for UUIDv7

uuid/CHANGES.md

@@ -1,3 +1,7 @@
+1.3.17
+
+- Added support for UUIDv7 in `Data.UUID.V7`.
+
 1.3.16
 
 - Support GHC-8.6.5...9.10.1

uuid/src/Data/UUID/V7.hs

@@ -0,0 +1,70 @@
+-- |
+-- Module      : Data.UUID.V7
+-- Copyright   : (c) Taylor Fausak
+--
+-- License     : BSD-style
+--
+-- Maintainer  : [email protected]
+-- Stability   : experimental
+-- Portability : portable
+--
+--
+-- This module implements Version 7 UUIDs as specified
+-- in RFC 9562 accessible here: <https://datatracker.ietf.org/doc/html/rfc9562>.
+--
+-- These UUIDs are partly time-ordered, which improves database locality.
+
+module Data.UUID.V7 ( generate, build ) where
+
+import Data.Bits ( (.&.), (.|.), shift )
+import qualified Data.ByteString as ByteString
+import qualified Data.Int as Int
+import qualified Data.Time.Clock.System as Time
+import qualified Data.UUID.Types as UUID
+import qualified Data.Word as Word
+import qualified System.Entropy as Entropy
+
+-- | Generates a 'UUID' using the current time (from 'Time.getSystemTime') and
+-- random data (from 'Entropy.getEntropy').
+--
+-- @since 1.3.17
+generate :: IO UUID.UUID
+generate = do
+  t <- Time.getSystemTime
+  -- Note that we only need 74 bits (12 + 62) of randomness. That's a little
+  -- more than 9 bytes (72 bits), so we have to request 10 bytes (80 bits) of
+  -- entropy. The extra 6 bits are discarded.
+  b <- Entropy.getEntropy 10
+  pure $
+    let u8_u64 = fromIntegral :: Word.Word8 -> Word.Word64
+        f = shift . u8_u64 . ByteString.index b
+        r = f 0 0 + f 1 8
+        s = f 2 0 + f 3 8 + f 4 16 + f 5 24 + f 6 32 + f 7 40 + f 8 48 + f 9 56
+     in build t r s
+
+-- | Builds a 'UUID' using the provided fields. Typically you will want to use
+-- the 'generate' function instead.
+--
+-- @since 1.3.17
+build ::
+  -- | Corresponds to the @unix_ts_ms@ field.
+  Time.SystemTime ->
+  -- | Corresponds to the @rand_a@ field. Only the low 12 bits are used.
+  Word.Word64 ->
+  -- | Corresponds to the @rand_b@ field. Only the low 62 bits are used.
+  Word.Word64 ->
+  UUID.UUID
+build t r s =
+  let i64_u64 = fromIntegral :: Int.Int64 -> Word.Word64
+      u32_u64 = fromIntegral :: Word.Word32 -> Word.Word64
+      unix_ts_ms =
+        shift
+          ( (i64_u64 (Time.systemSeconds t) * 1000)
+              + u32_u64 (div (Time.systemNanoseconds t) 1000000)
+          )
+          16
+      ver = shift 0x7 12 :: Word.Word64
+      rand_a = r .&. 0x0fff -- 0x0fff = 2^12 - 1
+      var = shift 0x2 62 :: Word.Word64
+      rand_b = s .&. 0x3fffffffffffffff -- 0x3fffffffffffffff = 2^62 - 1
+   in UUID.fromWords64 (unix_ts_ms .|. ver .|. rand_a) (var .|. rand_b)

uuid/tests/TestUUID.hs

@@ -6,11 +6,14 @@ import qualified Data.ByteString.Lazy as BL
 import Data.Char (ord)
 import Data.List (nub, (\\))
 import Data.Maybe
+import qualified Data.Time as Time
+import qualified Data.Time.Clock.System as Time
 import Data.Word
 import qualified Data.UUID as U
 import qualified Data.UUID.V1 as U
 import qualified Data.UUID.V3 as U3
 import qualified Data.UUID.V5 as U5
+import qualified Data.UUID.V7 as U7
 
 import Test.QuickCheck ( Arbitrary(arbitrary), choose )
 import Test.Tasty ( TestTree, testGroup, defaultMain )
@@ -65,6 +68,32 @@ test_v5 =
     where name = map (fromIntegral . ord) "www.widgets.com" :: [Word8]
           uV5 = fromJust $ U.fromString "21f7f8de-8051-5b89-8680-0195ef798b6a"
 
+test_v7 :: Test
+test_v7 = testGroup
+    "version 7"
+    [ testGroup
+        "generate"
+        [ testCase "works" $ do
+            uuid <- U7.generate
+            length (U.toString uuid) @?= 36
+        ],
+      testGroup
+        "build"
+        [ testCase "works with nil" $ do
+            let epoch = Time.MkSystemTime 0 0
+            let uuid = U7.build epoch 0 0
+            U.toString uuid @?= "00000000-0000-7000-8000-000000000000",
+          testCase "works with test vector" $ do
+            -- https://datatracker.ietf.org/doc/html/rfc9562#name-example-of-a-uuidv7-value
+            let time =
+                  Time.utcToSystemTime
+                    . Time.localTimeToUTC (Time.hoursToTimeZone (-5))
+                    . Time.LocalTime (Time.fromGregorian 2022 2 22)
+                    $ Time.TimeOfDay 14 22 22
+            let uuid = U7.build time 0xcc3 0x18C4DC0C0C07398F
+            U.toString uuid @?= "017f22e2-79b0-7cc3-98c4-dc0c0c07398f"
+        ]
+    ]
 
 prop_randomsValid :: Test
 prop_randomsValid = testProperty "Random valid" randomsValid
@@ -101,7 +130,8 @@ main = do
         test_null,
         test_v1 v1s,
         test_v3,
-        test_v5
+        test_v5,
+        test_v7
         ]
      , [ prop_randomsValid,
          prop_v3NotNull,

uuid/uuid.cabal

@@ -61,6 +61,7 @@ library
     Data.UUID.V3
     Data.UUID.V4
     Data.UUID.V5
+    Data.UUID.V7
 
   other-modules:
     Data.UUID.Named
@@ -86,6 +87,7 @@ test-suite testuuid
       base
     , bytestring
     , random
+    , time
     , uuid
 
   -- deps w/o inherited constraints