UUIDv6 implementation.

uuid-types/src/Data/UUID/Types.hs

@@ -12,15 +12,17 @@ Portability : portable
 
 This library is useful for comparing, parsing and
 printing <http://en.wikipedia.org/wiki/UUID Universally Unique Identifiers (UUID)>.
-See <http://tools.ietf.org/html/rfc4122 RFC 4122> for the specification.
-
+See <http://datatracker.ietf.org/doc/html/rfc9562 RFC 9562> for the specification.
 -}
 module Data.UUID.Types
     ( -- * The 'UUID' Type
       UUID
       -- * Nil UUID
     , nil
     , null
+      -- * Max UUID
+    , max
+    , isMax
       -- * Textual Representation
     , toString
     , fromString

uuid-types/src/Data/UUID/Types/Internal.hs

@@ -22,6 +22,8 @@ module Data.UUID.Types.Internal
     ( UUID(..)
     , null
     , nil
+    , isMax
+    , max
     , fromByteString
     , toByteString
     , fromString
@@ -44,7 +46,7 @@ module Data.UUID.Types.Internal
     , unpack
     ) where
 
-import           Prelude                          hiding (null)
+import           Prelude                          hiding (null, max)
 
 import           Control.Applicative              ((<*>))
 import           Control.DeepSeq                  (NFData (..))
@@ -77,7 +79,7 @@ import           System.Random.Stateful (Uniform (..), uniformWord64)
 import Language.Haskell.TH.Syntax (Lift)
 
 -- | Type representing <https://en.wikipedia.org/wiki/UUID Universally Unique Identifiers (UUID)> as specified in
---  <http://tools.ietf.org/html/rfc4122 RFC 4122>.
+--  <http://datatracker.ietf.org/doc/html/rfc9562 RFC 9562>.
 data UUID = UUID {-# UNPACK #-} !Word64 {-# UNPACK #-} !Word64
           deriving (Eq, Ord, Typeable)
 {-
@@ -277,11 +279,21 @@ null = (== nil)
     --      null (UUID 0 0 0 0) = True
     --      null _              = False
 
--- |The 'nil' UUID, as defined in <http://tools.ietf.org/html/rfc4122 RFC 4122>.
+-- |The 'nil' UUID, as defined in <http://datatracker.ietf.org/doc/html/rfc9562 RFC 9562>.
 -- It is a UUID of all zeros. @'null' u@ /iff/ @'u' == 'nil'@.
 nil :: UUID
 nil = UUID 0 0
 
+-- |Returns true if the passed-in UUID is the 'max' UUID.
+isMax :: UUID -> Bool
+isMax = (== max)
+
+-- |The 'max' UUID, as defined in <http://datatracker.ietf.org/doc/html/rfc9562 RFC 9562>.
+-- It is a UUID of all ones. @'isMax' u@ /iff/ @'u' == 'max'@.
+max :: UUID
+max = UUID allOnes allOnes
+  where allOnes = complement zeroBits
+
 -- |Extract a UUID from a 'ByteString' in network byte order.
 -- The argument must be 16 bytes long, otherwise 'Nothing' is returned.
 fromByteString :: BL.ByteString -> Maybe UUID
@@ -470,7 +482,7 @@ fromLazyASCIIBytes bs =
 --
 
 -- | This 'Random' instance produces __insecure__ version 4 UUIDs as
--- specified in <http://tools.ietf.org/html/rfc4122 RFC 4122>.
+-- specified in <http://datatracker.ietf.org/doc/html/rfc9562 RFC 9562>.
 instance Random UUID where
     random = uniform
     randomR _ = random -- range is ignored
@@ -521,7 +533,7 @@ instance Read UUID where
           Nothing -> []
           Just u  -> [(u,drop 36 noSpaces)]
 
--- | This 'Storable' instance uses the memory layout as described in <http://tools.ietf.org/html/rfc4122 RFC 4122>, but in contrast to the 'Binary' instance, __the fields are stored in host byte order__.
+-- | This 'Storable' instance uses the memory layout as described in <http://datatracker.ietf.org/doc/html/rfc4122 RFC 4122>, but in contrast to the 'Binary' instance, __the fields are stored in host byte order__.
 instance Storable UUID where
     sizeOf _ = 16
     alignment _ = 4
@@ -558,7 +570,7 @@ instance Storable UUID where
                 pokeByteOff p (off+14) x9
                 pokeByteOff p (off+15) x10
 
--- | This 'Binary' instance is compatible with <http://tools.ietf.org/html/rfc4122 RFC 4122>, storing the fields in network order as 16 bytes.
+-- | This 'Binary' instance is compatible with <http://datatracker.ietf.org/doc/html/rfc4122 RFC 4122>, storing the fields in network order as 16 bytes.
 instance Binary UUID where
     put (UUID w0 w1) = putWord64be w0 >> putWord64be w1
     get = liftM2 UUID getWord64be getWord64be

uuid-types/tests/TestUUID.hs

@@ -31,16 +31,29 @@ instance Arbitrary U.UUID where
 type Test = TestTree
 
 test_null :: Test
-test_null =
-  testCase "nil is null" $
-  assertBool "" (U.null U.nil)
+test_null = testGroup "null" [
+  testCase "nil is null" $ assertBool "" (U.null U.nil),
+  testCase "nil is not isMax" $ assertBool "" (not . U.isMax $ U.nil)
+  ]
 
 test_nil :: Test
 test_nil = testGroup "nil" [
     testCase "nil string" $ U.toString U.nil @?= "00000000-0000-0000-0000-000000000000",
     testCase "nil bytes"  $ U.toByteString U.nil @?= BL.pack (replicate 16 0)
     ]
 
+test_isMax :: Test
+test_isMax = testGroup "isMax" [
+  testCase "max is isMax" $ assertBool "" (U.isMax U.max),
+  testCase "nil is not null" $ assertBool "" (not . U.null $ U.max)
+  ]
+
+test_max :: Test
+test_max = testGroup "max" [
+    testCase "max string" $ U.toString U.max @?= "ffffffff-ffff-ffff-ffff-ffffffffffff",
+    testCase "ones bytes"  $ U.toByteString U.max @?= BL.pack (replicate 16 0xFF)
+    ]
+
 test_lift :: Test
 test_lift = testCase "TH.Lift" $ do
     let uuid = U.fromWords64 123456789 987654321
@@ -122,6 +135,11 @@ prop_randomNotNull = testProperty "Random not null" randomNotNull
     where randomNotNull :: U.UUID -> Bool
           randomNotNull = not. U.null
 
+prop_randomNotMax :: Test
+prop_randomNotMax = testProperty "Random not max" randomNotMax
+    where randomNotMax :: U.UUID -> Bool
+          randomNotMax = not. U.isMax
+
 prop_readShowRoundTrip :: Test
 prop_readShowRoundTrip = testProperty "Read/Show round-trip" prop
     where -- we're using 'Maybe UUID' to add a bit of
@@ -182,6 +200,8 @@ main = do
      [ [
         test_null,
         test_nil,
+        test_isMax,
+        test_max,
         test_lift,
         test_conv,
         test_fromByteString,
@@ -196,7 +216,8 @@ main = do
          prop_stringLength,
          prop_byteStringLength,
          prop_randomsDiffer,
-         prop_randomNotNull
+         prop_randomNotNull,
+         prop_randomNotMax
          ]
      , [ testProperty "fromASCIIBytes_fromString1"  fromASCIIBytes_fromString1
        , testProperty "fromASCIIBytes_fromString2"  fromASCIIBytes_fromString2

uuid/src/Data/UUID.hs

@@ -12,14 +12,14 @@ Portability : portable
 This library is useful for comparing, parsing and
 printing Universally Unique Identifiers.
 See <http://en.wikipedia.org/wiki/UUID> for the general idea.
-See <http://tools.ietf.org/html/rfc4122> for the specification.
+See <http://datatracker.ietf.org/doc/html/rfc9562> for the specification.
 
 * Use 'Data.UUID.V4.nextRandom' to generate secure random UUIDs, and your
 favorite instance of 'System.Random.Random' for faster but insecure
 generation of UUIDs.
 
 * We have an implementation of generating a UUID from the hardware
-MAC address and current system time in "Data.UUID.V1".
+MAC address and current system time in "Data.UUID.V6".
 
 * For name-based generation of UUIDs using SHA-1 hashing see
 "Data.UUID.V5".
@@ -41,9 +41,11 @@ module Data.UUID(UUID
                 ,fromWords64
                 ,null
                 ,nil
+                ,isMax
+                ,max
                 ) where
 
-import Prelude () -- we need to hide Prelude.null
+import Prelude () -- we need to hide Prelude.null and Prelude.max
 import Data.UUID.Types
 
 -- We use explicit re-exports of everything from Data.UUID.Types in

uuid/src/Data/UUID/Named.hs

@@ -10,7 +10,7 @@
 --
 --
 -- This module implements Version 3/5 UUIDs as specified
--- in RFC 4122.
+-- in RFC 9562.
 --
 -- These UUIDs identify an object within a namespace,
 -- and are deterministic.

uuid/src/Data/UUID/Time.hs

@@ -0,0 +1,84 @@
+{-# OPTIONS_GHC -fno-cse #-}
+{-# LANGUAGE TypeFamilies #-}
+module Data.UUID.Time(stepTime, MACSource(..),(/-/))
+where
+
+import Data.Maybe
+import Data.Time
+import Data.Word
+import Data.Bits
+import Data.List
+
+import Control.Applicative ((<$>),(<*>))
+import Control.Concurrent.MVar
+import System.IO.Unsafe
+
+import qualified System.Random as R
+
+import Network.Info
+import Data.UUID.Types.Internal.Builder
+
+newtype MACSource = MACSource MAC
+instance ByteSource MACSource where
+    z /-/ (MACSource (MAC a b c d e f)) = z a b c d e f
+type instance ByteSink MACSource g = Takes3Bytes (Takes3Bytes g)
+
+-- |Approximates the clock algorithm in RFC 4122, section 4.2
+-- Isn't system wide or thread safe, nor does it properly randomize
+-- the clock value on initialization.
+stepTime :: IO (Maybe (MAC, Word16, Word64))
+stepTime = do
+  h1 <- fmap hundredsOfNanosSinceGregorianReform getCurrentTime
+  modifyMVar state $ \s@(State mac' c0 h0) ->
+   if h1 > h0
+    then
+      return (State mac' c0 h1, Just (mac', c0, h1))
+    else
+      let
+        c1 = succ c0
+      in if c1 <= 0x3fff -- when clock is initially randomized,
+                      -- then this test will need to change
+         then
+          return (State mac' c1 h1, Just (mac', c1, h1))
+        else
+          return (s, Nothing)
+
+{-# NOINLINE state #-}
+state :: MVar State
+state = unsafePerformIO $ do
+  h0 <- fmap hundredsOfNanosSinceGregorianReform getCurrentTime
+  mac' <- getMac
+  newMVar $ State mac' 0 h0 -- the 0 should be a random number
+
+-- SysMAC.mac can fail on some machines.
+-- In those cases we fake it with a random
+-- 6 bytes seed.
+getMac :: IO MAC
+getMac =
+    getNetworkInterfaces >>=
+    return . find (minBound /=) . map mac >>=
+    maybe randomMac return
+
+randomMac :: IO MAC
+randomMac =
+    -- I'm too lazy to thread through
+    -- the random state ...
+    MAC
+     <$> (R.randomIO >>= return . (1 .|.)) -- We must set the multicast bit to True. See section 4.5 of the RFC.
+     <*> R.randomIO
+     <*> R.randomIO
+     <*> R.randomIO
+     <*> R.randomIO
+     <*> R.randomIO
+
+data State = State
+    {-# UNPACK #-} !MAC
+    {-# UNPACK #-} !Word16
+    {-# UNPACK #-} !Word64
+ deriving (Show)
+
+hundredsOfNanosSinceGregorianReform :: UTCTime -> Word64
+hundredsOfNanosSinceGregorianReform t = floor $ 10000000 * dt
+ where
+  gregorianReform = UTCTime (fromGregorian 1582 10 15) 0
+  dt = t `diffUTCTime` gregorianReform