diff --git a/uuid-types/src/Data/UUID/Types.hs b/uuid-types/src/Data/UUID/Types.hs index 2757867..e1a4773 100644 --- a/uuid-types/src/Data/UUID/Types.hs +++ b/uuid-types/src/Data/UUID/Types.hs @@ -12,8 +12,7 @@ Portability : portable This library is useful for comparing, parsing and printing . -See for the specification. - +See for the specification. -} module Data.UUID.Types ( -- * The 'UUID' Type @@ -21,6 +20,9 @@ module Data.UUID.Types -- * Nil UUID , nil , null + -- * Max UUID + , max + , isMax -- * Textual Representation , toString , fromString diff --git a/uuid-types/src/Data/UUID/Types/Internal.hs b/uuid-types/src/Data/UUID/Types/Internal.hs index 83fc898..1859ab3 100644 --- a/uuid-types/src/Data/UUID/Types/Internal.hs +++ b/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 as specified in --- . +-- . 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 . +-- |The 'nil' UUID, as defined in . -- 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 . +-- 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 . +-- specified in . 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 , 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 , 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 , storing the fields in network order as 16 bytes. +-- | This 'Binary' instance is compatible with , 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 diff --git a/uuid-types/tests/TestUUID.hs b/uuid-types/tests/TestUUID.hs index 843b6b8..7b4e587 100644 --- a/uuid-types/tests/TestUUID.hs +++ b/uuid-types/tests/TestUUID.hs @@ -31,9 +31,10 @@ 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" [ @@ -41,6 +42,18 @@ test_nil = testGroup "nil" [ 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 diff --git a/uuid/src/Data/UUID.hs b/uuid/src/Data/UUID.hs index 63401e9..2a6f5d8 100644 --- a/uuid/src/Data/UUID.hs +++ b/uuid/src/Data/UUID.hs @@ -12,14 +12,14 @@ Portability : portable This library is useful for comparing, parsing and printing Universally Unique Identifiers. See for the general idea. -See for the specification. +See 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 diff --git a/uuid/src/Data/UUID/Named.hs b/uuid/src/Data/UUID/Named.hs index 66de2a9..768bedc 100644 --- a/uuid/src/Data/UUID/Named.hs +++ b/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. diff --git a/uuid/src/Data/UUID/Time.hs b/uuid/src/Data/UUID/Time.hs new file mode 100644 index 0000000..df815ec --- /dev/null +++ b/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 diff --git a/uuid/src/Data/UUID/V1.hs b/uuid/src/Data/UUID/V1.hs index 72581b3..a8fef11 100644 --- a/uuid/src/Data/UUID/V1.hs +++ b/uuid/src/Data/UUID/V1.hs @@ -1,6 +1,3 @@ -{-# OPTIONS_GHC -fno-cse #-} -{-# LANGUAGE TypeFamilies #-} - {- | Module : Data.UUID.V1 Copyright : (c) 2008 Jason Dusek @@ -13,7 +10,14 @@ Maintainer : aslatter@gmail.com Stability : experimental Portability : portable -RFC 4122 Version 1 UUID state machine. +NOTE\: This module has the wrong locality for +uses such as DB indexes. Unless you know you +need to use this module, you should probably +be using "Data.UUID.V6", which offers the same +sort of functionality as this module but with +better locality. + +RFC 9562 Version 1 UUID state machine. The generated UUID is based on the hardware MAC address and the system clock. @@ -28,24 +32,17 @@ where import Data.Bits import Data.Maybe -import Data.Time import Data.Word -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 +import Data.UUID.Time import Data.UUID.Types.Internal -- | Returns a new UUID derived from the local hardware MAC -- address and the current system time. -- Is generated according to the Version 1 UUID specified in --- RFC 4122. +-- RFC 9562. -- -- Returns 'Nothing' if you request UUIDs too quickly. nextUUID :: IO (Maybe UUID) @@ -62,74 +59,3 @@ makeUUID time clock mac' = where tLow = (fromIntegral time) :: Word32 tMid = (fromIntegral (time `shiftR` 32)) :: Word16 tHigh = (fromIntegral (time `shiftR` 48)) :: Word16 - -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 . listToMaybe . filter (minBound /=) . map mac >>= - \macM -> case macM of - Just m -> return m - Nothing -> randomMac - -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 diff --git a/uuid/src/Data/UUID/V3.hs b/uuid/src/Data/UUID/V3.hs index e94fcce..b8f7bc0 100644 --- a/uuid/src/Data/UUID/V3.hs +++ b/uuid/src/Data/UUID/V3.hs @@ -15,7 +15,7 @@ functionality as this module except implemented with SHA-1 hashing. This module implements Version 3 UUIDs as specified -in RFC 4122. +in RFC 9562. These UUIDs identify an object within a namespace, and are deterministic. diff --git a/uuid/src/Data/UUID/V4.hs b/uuid/src/Data/UUID/V4.hs index cd97e57..59b834f 100644 --- a/uuid/src/Data/UUID/V4.hs +++ b/uuid/src/Data/UUID/V4.hs @@ -9,7 +9,7 @@ Portability : portable This module implements Version 4 UUIDs as specified - in RFC 4122. + in RFC 9562. These UUIDs are generated from a pseudo-random generator. We use the 'getEntropy' method from the package, diff --git a/uuid/src/Data/UUID/V5.hs b/uuid/src/Data/UUID/V5.hs index 1990d67..c026cd2 100644 --- a/uuid/src/Data/UUID/V5.hs +++ b/uuid/src/Data/UUID/V5.hs @@ -10,7 +10,7 @@ -- -- -- This module implements Version 5 UUIDs as specified --- in RFC 4122. +-- in RFC 9562. -- -- These UUIDs identify an object within a namespace, -- and are deterministic. diff --git a/uuid/src/Data/UUID/V6.hs b/uuid/src/Data/UUID/V6.hs new file mode 100644 index 0000000..3a9ddc1 --- /dev/null +++ b/uuid/src/Data/UUID/V6.hs @@ -0,0 +1,50 @@ +{- | +Module : Data.UUID.V6 +Copyright : © 2025 ARJANEN Loïc Jean David + +License : BSD-style + +Maintainer : aslatter@gmail.com +Stability : experimental +Portability : portable + +RFC 9562 Version 6 UUID state machine. + +The generated UUID is based on the hardware MAC +address and the system clock. + +If we cannot lookup the MAC address we seed the +generator with a pseudo-random number. +-} + +module Data.UUID.V6(nextUUID) +where + +import Data.Bits +import Data.Maybe +import Data.Word + +import Network.Info + +import Data.UUID.Time +import Data.UUID.Types.Internal + +-- | Returns a new UUID derived from the local hardware MAC +-- address and the current system time. +-- Is generated according to the Version 6 UUID specified in +-- RFC 9562. +-- +-- Returns 'Nothing' if you request UUIDs too quickly. +nextUUID :: IO (Maybe UUID) +nextUUID = do + res <- stepTime + case res of + Just (mac', c, t) -> return $ Just $ makeUUID t c mac' + _ -> return Nothing + +makeUUID :: Word64 -> Word16 -> MAC -> UUID +makeUUID time clock mac' = + buildFromBytes 6 /-/ tHigh /-/ tMid /-/ tLow /-/ clock /-/ (MACSource mac') + where tHigh = (fromIntegral (time `shiftR` 28)) :: Word32 + tMid = (fromIntegral (time `shiftR` 12)) :: Word16 + tLow = (fromIntegral (time .&. 0xFFF)) :: Word16 diff --git a/uuid/tests/TestUUID.hs b/uuid/tests/TestUUID.hs index 4650354..3989be2 100644 --- a/uuid/tests/TestUUID.hs +++ b/uuid/tests/TestUUID.hs @@ -11,6 +11,7 @@ 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.V6 as U6 import Test.QuickCheck ( Arbitrary(arbitrary), choose ) import Test.Tasty ( TestTree, testGroup, defaultMain ) @@ -32,6 +33,10 @@ instance Arbitrary U.UUID where -- the UUID random instance ignores bounds arbitrary = choose (U.nil, U.nil) +test_max :: Test +test_max = + testCase "namespaceDNS is not max" $ + assertBool "" (not $ U.isMax U3.namespaceDNS) test_null :: Test test_null = @@ -42,6 +47,7 @@ test_v1 :: [Maybe U.UUID] -> Test test_v1 v1s = testGroup "version 1" [ testCase "V1 unique" $ nub (v1s \\ nub v1s) @?= [], testGroup "V1 not null" $ map (testUUID (not . U.null)) v1s, + testGroup "V1 not max" $ map (testUUID (not . U.isMax)) v1s, testGroup "V1 valid" $ map (testUUID (isValidVersion 1)) v1s ] where testUUID :: (U.UUID -> Bool) -> Maybe U.UUID -> Test @@ -65,6 +71,17 @@ test_v5 = where name = map (fromIntegral . ord) "www.widgets.com" :: [Word8] uV5 = fromJust $ U.fromString "21f7f8de-8051-5b89-8680-0195ef798b6a" +test_v6 :: [Maybe U.UUID] -> Test +test_v6 v6s = testGroup "version 6" [ + testCase "V6 unique" $ nub (v6s \\ nub v6s) @?= [], + testGroup "V6 not null" $ map (testUUID (not . U.null)) v6s, + testGroup "V6 not max" $ map (testUUID (not . U.isMax)) v6s, + testGroup "V6 valid" $ map (testUUID (isValidVersion 6)) v6s + ] + where testUUID :: (U.UUID -> Bool) -> Maybe U.UUID -> Test + testUUID p u = + testCase (show u) $ + assertBool "" $ maybe False p u prop_randomsValid :: Test prop_randomsValid = testProperty "Random valid" randomsValid @@ -76,6 +93,11 @@ prop_v3NotNull = testProperty "V3 not null" v3NotNull where v3NotNull :: [Word8] -> Bool v3NotNull = not . U.null . U3.generateNamed U3.namespaceDNS +prop_v3NotMax :: Test +prop_v3NotMax = testProperty "V3 not max" v3NotMax + where v3NotMax :: [Word8] -> Bool + v3NotMax = not . U.isMax . U3.generateNamed U3.namespaceDNS + prop_v3Valid :: Test prop_v3Valid = testProperty "V3 valid" v3Valid where v3Valid :: [Word8] -> Bool @@ -86,6 +108,11 @@ prop_v5NotNull = testProperty "V5 not null" v5NotNull where v5NotNull :: [Word8] -> Bool v5NotNull = not . U.null . U5.generateNamed U5.namespaceDNS +prop_v5NotMax :: Test +prop_v5NotMax = testProperty "V5 not max" v5NotMax + where v5NotMax :: [Word8] -> Bool + v5NotMax = not . U.isMax . U5.generateNamed U5.namespaceDNS + prop_v5Valid :: Test prop_v5Valid = testProperty "V5 valid" v5Valid where v5Valid :: [Word8] -> Bool @@ -94,19 +121,24 @@ prop_v5Valid = testProperty "V5 valid" v5Valid main :: IO () main = do v1s <- replicateM 100 U.nextUUID + v6s <- replicateM 100 U6.nextUUID defaultMain $ testGroup "tests" $ concat $ [ [ test_null, + test_max, test_v1 v1s, test_v3, - test_v5 + test_v5, + test_v6 v6s ] , [ prop_randomsValid, prop_v3NotNull, + prop_v3NotMax, prop_v3Valid, prop_v5NotNull, + prop_v5NotMax, prop_v5Valid ] ] diff --git a/uuid/uuid.cabal b/uuid/uuid.cabal index aaff410..2aaaa0d 100644 --- a/uuid/uuid.cabal +++ b/uuid/uuid.cabal @@ -62,8 +62,9 @@ library Data.UUID.V3 Data.UUID.V4 Data.UUID.V5 - + Data.UUID.V6 other-modules: + Data.UUID.Time Data.UUID.Named Data.Word.Util