mmzk-typeid 0.7.0.2 → 0.7.1.0
raw patch · 14 files changed
+414/−43 lines, 14 files
Files
- CHANGELOG.md +16/−0
- mmzk-typeid.cabal +1/−1
- src/Data/KindID.hs +4/−1
- src/Data/KindID/Internal.hs +40/−2
- src/Data/KindID/V7.hs +35/−0
- src/Data/TypeID.hs +4/−1
- src/Data/TypeID/Class.hs +7/−7
- src/Data/TypeID/Internal.hs +58/−2
- src/Data/TypeID/Unsafe.hs +4/−0
- src/Data/TypeID/V7.hs +38/−0
- src/Data/TypeID/V7/Unsafe.hs +26/−0
- src/Data/UUID/V7.hs +88/−25
- src/Data/UUID/Versions.hs +4/−4
- test/Spec.hs +89/−0
CHANGELOG.md view
@@ -1,6 +1,22 @@ # Revision history for mmzk-typeid +## 0.7.1.0 -- 2026-03-18++* Add custom timestamp support for V7 UUID/TypeID/KindID generation.+ * New functions `genUUIDWithTime`, `genUUIDWithTime'`, and `genUUIDsWithTime` in `Data.UUID.V7`.+ * New functions `genTypeIDWithTime`, `genTypeIDWithTime'`, and `genTypeIDsWithTime` in `Data.TypeID.V7` (and re-exported from `Data.TypeID`).+ * New unsafe variants `unsafeGenTypeIDWithTime`, `unsafeGenTypeIDWithTime'`, and `unsafeGenTypeIDsWithTime` in `Data.TypeID.V7.Unsafe` (and re-exported from `Data.TypeID.Unsafe`).+ * New functions `genKindIDWithTime`, `genKindIDWithTime'`, and `genKindIDsWithTime` in `Data.KindID.V7` (and re-exported from `Data.KindID`).+ * These functions accept a `Word64` timestamp (milliseconds since Unix epoch) and do not interact with the global monotonic state.++* Drop redundant `Typeable` derivation.++* More tests.++* Kindly contributed by @johnhampton.++ ## 0.7.0.2 -- 2025-04-22 * Fix a Haddock error on `ValidPrefix` related to conditional compilation.
mmzk-typeid.cabal view
@@ -1,6 +1,6 @@ cabal-version: 2.4 name: mmzk-typeid-version: 0.7.0.2+version: 0.7.1.0 synopsis: A TypeID and UUIDv7 implementation for Haskell description:
src/Data/KindID.hs view
@@ -41,7 +41,7 @@ ( -- * Data types KindID- , KindID'+ , KindID'() , getPrefix , getUUID , getTime@@ -49,6 +49,9 @@ , genKindID , genKindID' , genKindIDs+ , genKindIDWithTime+ , genKindIDWithTime'+ , genKindIDsWithTime , decorateKindID -- * 'KindID' generation (class methods) , genID
src/Data/KindID/Internal.hs view
@@ -19,7 +19,6 @@ import Data.KindID.Class import Data.Text (Text) import qualified Data.Text as T-import Data.Typeable (Typeable) import Data.TypeID.Class import Data.TypeID.Error import Data.TypeID.Internal (TypeID'(..))@@ -40,7 +39,7 @@ -- It is dubbed 'Data.KindID.V7.KindID' because the prefix here is a data kind -- rather than a type. newtype KindID' (version :: UUIDVersion) prefix = KindID' UUID- deriving (Eq, Ord, Data, Typeable, Generic)+ deriving (Eq, Ord, Data, Generic) instance (ToPrefix prefix, ValidPrefix (PrefixSymbol prefix)) => Show (KindID' version prefix) where@@ -357,6 +356,45 @@ genKindIDs n = fmap (unsafeFromTypeID <$>) . flip V7.unsafeGenTypeIDs n . T.pack $ symbolVal @(PrefixSymbol prefix) Proxy {-# INLINE genKindIDs #-}++-- | Generate a new 'Data.KindID.V7.KindID' from a prefix with a custom+-- timestamp (milliseconds since Unix epoch).+genKindIDWithTime :: forall prefix m+ . ( ToPrefix prefix+ , ValidPrefix (PrefixSymbol prefix)+ , MonadIO m )+ => Word64 -> m (KindID' 'V7 prefix)+genKindIDWithTime ts = unsafeFromTypeID+ <$> V7.unsafeGenTypeIDWithTime (T.pack $ symbolVal @(PrefixSymbol prefix) Proxy) ts+{-# INLINE genKindIDWithTime #-}++-- | Generate a new 'Data.KindID.V7.KindID' from a prefix with a custom+-- timestamp based on stateless 'UUID'v7.+genKindIDWithTime' :: forall prefix m+ . ( ToPrefix prefix+ , ValidPrefix (PrefixSymbol prefix)+ , MonadIO m )+ => Word64 -> m (KindID' 'V7 prefix)+genKindIDWithTime' ts = fmap unsafeFromTypeID+ . flip V7.unsafeGenTypeIDWithTime' ts . T.pack+ $ symbolVal @(PrefixSymbol prefix) Proxy+{-# INLINE genKindIDWithTime' #-}++-- | Generate a list of 'Data.KindID.V7.KindID's from a prefix with a custom+-- timestamp (milliseconds since Unix epoch).+--+-- The first 32768 'Data.KindID.V7.KindID's are guaranteed to be monotonically+-- increasing.+genKindIDsWithTime :: forall prefix m+ . ( ToPrefix prefix+ , ValidPrefix (PrefixSymbol prefix)+ , MonadIO m )+ => Word64 -> Word16 -> m [KindID' 'V7 prefix]+genKindIDsWithTime ts n+ = fmap (unsafeFromTypeID <$>)+ . (\p -> V7.unsafeGenTypeIDsWithTime p ts n) . T.pack+ $ symbolVal @(PrefixSymbol prefix) Proxy+{-# INLINE genKindIDsWithTime #-} -- | Generate a new 'KindID'' ''V1' from a prefix. --
src/Data/KindID/V7.hs view
@@ -19,6 +19,9 @@ , genKindID , genKindID' , genKindIDs+ , genKindIDWithTime+ , genKindIDWithTime'+ , genKindIDsWithTime , decorateKindID -- * 'KindID' generation (class methods) , genID@@ -104,6 +107,38 @@ => Word16 -> m [KindID prefix] genKindIDs = KID.genKindIDs {-# INLINE genKindIDs #-}++-- | Generate a new 'KindID' from a prefix with a custom timestamp+-- (milliseconds since Unix epoch).+--+-- Note: a future timestamp will produce a valid 'KindID' that nonetheless+-- fails 'checkKindIDWithEnv'.+genKindIDWithTime :: (ToPrefix prefix, ValidPrefix (PrefixSymbol prefix), MonadIO m)+ => Word64 -> m (KindID prefix)+genKindIDWithTime = KID.genKindIDWithTime+{-# INLINE genKindIDWithTime #-}++-- | Generate a new 'KindID' from a prefix with a custom timestamp based on+-- stateless 'UUID'v7.+--+-- Note: a future timestamp will produce a valid 'KindID' that nonetheless+-- fails 'checkKindIDWithEnv'.+genKindIDWithTime' :: (ToPrefix prefix, ValidPrefix (PrefixSymbol prefix), MonadIO m)+ => Word64 -> m (KindID prefix)+genKindIDWithTime' = KID.genKindIDWithTime'+{-# INLINE genKindIDWithTime' #-}++-- | Generate a list of 'KindID's from a prefix with a custom timestamp+-- (milliseconds since Unix epoch).+--+-- The first 32768 'KindID's are guaranteed to be monotonically increasing.+--+-- Note: a future timestamp will produce valid 'KindID's that nonetheless+-- fail 'checkKindIDWithEnv'.+genKindIDsWithTime :: (ToPrefix prefix, ValidPrefix (PrefixSymbol prefix), MonadIO m)+ => Word64 -> Word16 -> m [KindID prefix]+genKindIDsWithTime = KID.genKindIDsWithTime+{-# INLINE genKindIDsWithTime #-} -- | Obtain a 'KindID' from a prefix and a 'UUID'. decorateKindID :: (ToPrefix prefix, ValidPrefix (PrefixSymbol prefix))
src/Data/TypeID.hs view
@@ -13,7 +13,7 @@ ( -- * Data types TypeID- , TypeID'+ , TypeID'() , getPrefix , getUUID , getTime@@ -21,6 +21,9 @@ , genTypeID , genTypeID' , genTypeIDs+ , genTypeIDWithTime+ , genTypeIDWithTime'+ , genTypeIDsWithTime , decorateTypeID -- * 'TypeID' generation (class methods) , genID
src/Data/TypeID/Class.hs view
@@ -48,7 +48,7 @@ type TypeIDLike a = (IDType a, IDConv a, IDGen a) -- | A type class for a 'Data.TypeID.V7.TypeID'-ish identifier type, which has a--- 'Text' prefix and a 'UUID' suffix.+-- 'Text' prefix and a t'UUID' suffix. class IDType a where -- | Get the prefix of the identifier. getPrefix :: a -> Text@@ -147,7 +147,7 @@ -- | Similar to 'genID', but stateless. It can be a faster implementation than -- 'genID', but it does not guarantee any stateful property, such as--- monotonically increasing for 'UUID'v7-based identifiers.+-- monotonically increasing for t'UUID'v7-based identifiers. -- -- The default implementation is the same as 'genID'. genID' :: forall a m. (IDGen a, MonadIO m)@@ -161,7 +161,7 @@ genIDs = genIDs_ @a @m Proxy {-# INLINE genIDs #-} --- | Generate a new identifier with the given prefix and 'UUID' suffix.+-- | Generate a new identifier with the given prefix and t'UUID' suffix. decorate :: forall a. IDGen a => GenFunc (IDGenPrefix a) (UUID -> ResWithErr (IDGenPrefix a) a) decorate = decorate_ @a Proxy@@ -180,7 +180,7 @@ -- | A type class for generating 'Data.TypeID.V7.TypeID'-ish identifiers. -- -- The methods in this type class are not directly used since each of them has--- a dummy 'Proxy' in order to compile. We implement the methods here and use+-- a dummy t'Proxy' in order to compile. We implement the methods here and use -- the methods without the underscore suffix instead. class IDGen a where -- | If the identifier has compile-time determined prefix, this type should be@@ -189,7 +189,7 @@ type IDGenPrefix a :: Maybe Type -- | If the identifier's generation requires additional information (such as- -- 'UUID' version 5), this type corresponds to how to generate @r@ from the+ -- t'UUID' version 5), this type corresponds to how to generate @r@ from the -- required information. Otherwise it should be simply -- @ type IDGenReq a r = r @. type IDGenReq a r :: Type@@ -199,7 +199,7 @@ -- | Similar to 'genID'_, but stateless. It can be a faster implementation -- than 'genID'_, but it does not guarantee any stateful property, such as- -- monotonically increasing for 'UUID'v7-based identifiers.+ -- monotonically increasing for t'UUID'v7-based identifiers. -- -- The default implementation is the same as 'genID'_. genID'_ :: forall m. MonadIO m@@ -211,7 +211,7 @@ genIDs_ :: forall m. MonadIO m => Proxy a -> GenFunc (IDGenPrefix a) (IDGenReq a (Word16 -> m [a])) - -- | Generate a new identifier with the given prefix and 'UUID' suffix.+ -- | Generate a new identifier with the given prefix and t'UUID' suffix. decorate_ :: Proxy a -> GenFunc (IDGenPrefix a) (UUID -> ResWithErr (IDGenPrefix a) a)
src/Data/TypeID/Internal.hs view
@@ -32,7 +32,6 @@ import qualified Data.Text as T import Data.Text.Encoding import Data.Tuple-import Data.Typeable (Typeable) import Data.TypeID.Class import Data.TypeID.Error import Data.UUID.Types.Internal (UUID(..))@@ -51,7 +50,7 @@ -- The constructor is not exposed to the public API to prevent generating -- invalid 'TypeID''s. data TypeID' (version :: UUIDVersion) = TypeID' Text UUID- deriving (Eq, Ord, Data, Typeable, Generic)+ deriving (Eq, Ord, Data, Generic) instance Show (TypeID' version) where show :: TypeID' version -> String@@ -646,6 +645,63 @@ unsafeGenTypeIDs :: MonadIO m => Text -> Word16 -> m [TypeID' 'V7] unsafeGenTypeIDs prefix n = map (TypeID' prefix) <$> V7.genUUIDs n {-# INLINE unsafeGenTypeIDs #-}++-- | Generate a new 'Data.TypeID.V7.TypeID' from a prefix with a custom+-- timestamp (milliseconds since Unix epoch).+--+-- It throws a 'TypeIDError' if the prefix does not match the specification,+-- namely if it's longer than 63 characters or if it contains characters other+-- than lowercase latin letters.+genTypeIDWithTime :: MonadIO m => Text -> Word64 -> m (TypeID' 'V7)+genTypeIDWithTime prefix ts = case checkPrefix prefix of+ Nothing -> unsafeGenTypeIDWithTime prefix ts+ Just err -> liftIO $ throwIO err+{-# INLINE genTypeIDWithTime #-}++-- | Generate a new 'Data.TypeID.V7.TypeID' from a prefix with a custom+-- timestamp based on stateless 'UUID'v7.+--+-- See the documentation of 'V7.genUUIDWithTime'' for more information.+genTypeIDWithTime' :: MonadIO m => Text -> Word64 -> m (TypeID' 'V7)+genTypeIDWithTime' prefix ts = case checkPrefix prefix of+ Nothing -> unsafeGenTypeIDWithTime' prefix ts+ Just err -> liftIO $ throwIO err+{-# INLINE genTypeIDWithTime' #-}++-- | Generate a list of 'Data.TypeID.V7.TypeID's from a prefix with a custom+-- timestamp (milliseconds since Unix epoch).+--+-- The first 32768 'Data.TypeID.V7.TypeID's are guaranteed to be monotonically+-- increasing.+genTypeIDsWithTime :: MonadIO m => Text -> Word64 -> Word16 -> m [TypeID' 'V7]+genTypeIDsWithTime prefix ts n = case checkPrefix prefix of+ Nothing -> unsafeGenTypeIDsWithTime prefix ts n+ Just err -> liftIO $ throwIO err+{-# INLINE genTypeIDsWithTime #-}++-- | Generate a new 'Data.TypeID.V7.TypeID' from a prefix with a custom+-- timestamp, but without checking if the prefix is valid.+unsafeGenTypeIDWithTime :: MonadIO m => Text -> Word64 -> m (TypeID' 'V7)+unsafeGenTypeIDWithTime prefix ts = TypeID' prefix <$> V7.genUUIDWithTime ts+{-# INLINE unsafeGenTypeIDWithTime #-}++-- | Generate a new 'Data.TypeID.V7.TypeID' from a prefix with a custom+-- timestamp based on stateless 'UUID'v7, but without checking if the prefix+-- is valid.+unsafeGenTypeIDWithTime' :: MonadIO m => Text -> Word64 -> m (TypeID' 'V7)+unsafeGenTypeIDWithTime' prefix ts = TypeID' prefix <$> V7.genUUIDWithTime' ts+{-# INLINE unsafeGenTypeIDWithTime' #-}++-- | Generate n 'Data.TypeID.V7.TypeID's from a prefix with a custom timestamp,+-- but without checking if the prefix is valid.+--+-- The first 32768 'Data.TypeID.V7.TypeID's are guaranteed to be monotonically+-- increasing.+unsafeGenTypeIDsWithTime :: MonadIO m+ => Text -> Word64 -> Word16 -> m [TypeID' 'V7]+unsafeGenTypeIDsWithTime prefix ts n+ = map (TypeID' prefix) <$> V7.genUUIDsWithTime ts n+{-# INLINE unsafeGenTypeIDsWithTime #-} -- | Parse a 'TypeID'' from its 'String' representation, but crashes when -- parsing fails.
src/Data/TypeID/Unsafe.hs view
@@ -14,6 +14,10 @@ unsafeGenTypeID , unsafeGenTypeID' , unsafeGenTypeIDs+ -- * Unsafe 'Data.TypeID.V7.TypeID' generation with custom timestamp+ , unsafeGenTypeIDWithTime+ , unsafeGenTypeIDWithTime'+ , unsafeGenTypeIDsWithTime -- * Unsafe decoding ('Data.TypeID.V7.TypeID'-specific) , unsafeParseString , unsafeParseText
src/Data/TypeID/V7.hs view
@@ -19,6 +19,9 @@ , genTypeID , genTypeID' , genTypeIDs+ , genTypeIDWithTime+ , genTypeIDWithTime'+ , genTypeIDsWithTime , decorateTypeID -- * 'TypeID' generation (class methods) , genID@@ -96,6 +99,41 @@ genTypeIDs :: MonadIO m => Text -> Word16 -> m [TypeID] genTypeIDs = TID.genTypeIDs {-# INLINE genTypeIDs #-}++-- | Generate a new 'TypeID' from a prefix with a custom timestamp+-- (milliseconds since Unix epoch).+--+-- It throws a 'TypeIDError' if the prefix does not match the specification,+-- namely if it's longer than 63 characters or if it contains characters other+-- than lowercase latin letters.+--+-- Note: a future timestamp will produce a valid 'TypeID' that nonetheless+-- fails 'checkTypeIDWithEnv'.+genTypeIDWithTime :: MonadIO m => Text -> Word64 -> m TypeID+genTypeIDWithTime = TID.genTypeIDWithTime+{-# INLINE genTypeIDWithTime #-}++-- | Generate a new 'TypeID' from a prefix with a custom timestamp based on+-- stateless 'UUID'v7.+--+-- See the documentation of 'V7.genUUIDWithTime'' for more information.+--+-- Note: a future timestamp will produce a valid 'TypeID' that nonetheless+-- fails 'checkTypeIDWithEnv'.+genTypeIDWithTime' :: MonadIO m => Text -> Word64 -> m TypeID+genTypeIDWithTime' = TID.genTypeIDWithTime'+{-# INLINE genTypeIDWithTime' #-}++-- | Generate a list of 'TypeID's from a prefix with a custom timestamp+-- (milliseconds since Unix epoch).+--+-- The first 32768 'TypeID's are guaranteed to be monotonically increasing.+--+-- Note: a future timestamp will produce valid 'TypeID's that nonetheless+-- fail 'checkTypeIDWithEnv'.+genTypeIDsWithTime :: MonadIO m => Text -> Word64 -> Word16 -> m [TypeID]+genTypeIDsWithTime = TID.genTypeIDsWithTime+{-# INLINE genTypeIDsWithTime #-} -- | Obtain a 'TypeID' from a prefix and a 'UUID'. decorateTypeID :: Text -> UUID -> Either TypeIDError TypeID
src/Data/TypeID/V7/Unsafe.hs view
@@ -12,6 +12,10 @@ unsafeGenTypeID , unsafeGenTypeID' , unsafeGenTypeIDs+ -- * Unsafe 'TypeID' generation with custom timestamp+ , unsafeGenTypeIDWithTime+ , unsafeGenTypeIDWithTime'+ , unsafeGenTypeIDsWithTime -- * Unsafe decoding ('TypeID'-specific) , unsafeParseString , unsafeParseText@@ -55,6 +59,28 @@ unsafeGenTypeIDs :: MonadIO m => Text -> Word16 -> m [TypeID] unsafeGenTypeIDs = TID.unsafeGenTypeIDs {-# INLINE unsafeGenTypeIDs #-}++-- | Generate a new 'TypeID' from a prefix with a custom timestamp+-- (milliseconds since Unix epoch), but without checking if the prefix is+-- valid.+unsafeGenTypeIDWithTime :: MonadIO m => Text -> Word64 -> m TypeID+unsafeGenTypeIDWithTime = TID.unsafeGenTypeIDWithTime+{-# INLINE unsafeGenTypeIDWithTime #-}++-- | Generate a new 'TypeID' from a prefix with a custom timestamp based on+-- stateless 'Data.UUID.Types.Internal.UUID'v7, but without checking if the+-- prefix is valid.+unsafeGenTypeIDWithTime' :: MonadIO m => Text -> Word64 -> m TypeID+unsafeGenTypeIDWithTime' = TID.unsafeGenTypeIDWithTime'+{-# INLINE unsafeGenTypeIDWithTime' #-}++-- | Generate n 'TypeID's from a prefix with a custom timestamp, but without+-- checking if the prefix is valid.+--+-- The first 32768 'TypeID's are guaranteed to be monotonically increasing.+unsafeGenTypeIDsWithTime :: MonadIO m => Text -> Word64 -> Word16 -> m [TypeID]+unsafeGenTypeIDsWithTime = TID.unsafeGenTypeIDsWithTime+{-# INLINE unsafeGenTypeIDsWithTime #-} -- | Parse a 'TypeID' from its 'String' representation, but crashes when -- parsing fails.
src/Data/UUID/V7.hs view
@@ -13,10 +13,14 @@ ( -- * Data type UUID- -- * 'UUID'v7 generation+ -- * t'UUID'v7 generation , genUUID , genUUID' , genUUIDs+ -- * t'UUID'v7 generation with custom timestamp+ , genUUIDWithTime+ , genUUIDWithTime'+ , genUUIDsWithTime -- * Validation , validate , validateWithTime@@ -39,36 +43,28 @@ import System.Entropy import System.IO.Unsafe (unsafePerformIO) --- | Generate a 'UUID'v7.+-- | Generate a t'UUID'v7. genUUID :: MonadIO m => m UUID genUUID = head <$> genUUIDs 1 {-# INLINE genUUID #-} --- | Generate a stateless 'UUID'v7.+-- | Generate a stateless t'UUID'v7. -- -- It is faster than 'genUUID' but it is not guaranteed to be monotonically--- increasing if multiple 'UUID's are generated at the same timestamp.+-- increasing if multiple t'UUID's are generated at the same timestamp. ----- In use cases where the ordering is not important, this function is could be+-- In use cases where the ordering is not important, this function may be -- preferred. genUUID' :: MonadIO m => m UUID-genUUID' = do- timestamp <- getEpochMilli- entropy16 <- getEntropyWord16- entropy64 <- getEntropyWord64- let bs = runPut do- fillTime timestamp- fillVerAndRandA entropy16- fillVarAndRandB entropy16 entropy64- pure . uncurry UUID $ runGet (join (liftM2 (,)) getWord64be) bs+genUUID' = getEpochMilli >>= genUUIDWithTime' {-# INLINE genUUID' #-} --- | Generate a list of 'UUID'v7s.+-- | Generate a list of t'UUID'v7s. ----- It tries its best to generate 'UUID's at the same timestamp, but it may not--- be possible if we are asking too many 'UUID's at the same time.+-- It tries its best to generate t'UUID's at the same timestamp, but it may not+-- be possible if we are asking too many t'UUID's at the same time. ----- It is guaranteed that the first 32768 'UUID's are generated at the same+-- It is guaranteed that the first 32768 t'UUID's are generated at the same -- timestamp. genUUIDs :: MonadIO m => Word16 -> m [UUID] genUUIDs = liftIO . go True@@ -109,19 +105,86 @@ then pure uuids else (uuids ++) <$> go False (n - n') --- | Validate the version and variant of the 'UUID'v7.+-- | Generate a t'UUID'v7 with a custom timestamp (milliseconds since Unix+-- epoch).+--+-- It does not interact with the global state, so it is safe to interleave+-- with 'genUUID'.+--+-- Note: a future timestamp will produce a valid t'UUID' that nonetheless+-- fails 'validateWithTime'.+genUUIDWithTime :: MonadIO m => Word64 -> m UUID+genUUIDWithTime ts = head <$> genUUIDsWithTime ts 1+{-# INLINE genUUIDWithTime #-}++-- | Generate a stateless t'UUID'v7 with a custom timestamp (milliseconds since+-- Unix epoch).+--+-- It is faster than 'genUUIDWithTime' but it is not guaranteed to be+-- monotonically increasing if multiple t'UUID's are generated with the same+-- timestamp.+--+-- Note: a future timestamp will produce a valid t'UUID' that nonetheless+-- fails 'validateWithTime'.+genUUIDWithTime' :: MonadIO m => Word64 -> m UUID+genUUIDWithTime' timestamp = do+ entropy16 <- getEntropyWord16+ entropy64 <- getEntropyWord64+ let bs = runPut do+ fillTime timestamp+ fillVerAndRandA entropy16+ fillVarAndRandB entropy16 entropy64+ pure . uncurry UUID $ runGet (join (liftM2 (,)) getWord64be) bs+{-# INLINE genUUIDWithTime' #-}++-- | Generate a list of t'UUID'v7s with a custom timestamp (milliseconds since+-- Unix epoch).+--+-- The first 32768 t'UUID's are guaranteed to be monotonically increasing.+-- Beyond that, if the sequence number space is exhausted, a new random+-- starting sequence number is drawn for the remaining t'UUID's. That new+-- starting point may be lower than where the previous batch ended, so+-- later t'UUID's in the list can sort before earlier ones, or even share+-- the same sequence number (though a full t'UUID' collision remains+-- astronomically unlikely due to the independent 58-bit rand_b entropy).+--+-- It does not interact with the global state, so it is safe to interleave+-- with 'genUUIDs'.+--+-- Note: a future timestamp will produce valid t'UUID's that nonetheless+-- fail 'validateWithTime'.+genUUIDsWithTime :: MonadIO m => Word64 -> Word16 -> m [UUID]+genUUIDsWithTime timestamp = liftIO . go+ where+ go 0 = pure []+ go n = do+ entropy16 <- (.&. 0x7FFF) <$> getEntropyWord16+ let slots = min n (0xFFFF - entropy16)+ uuids <- forM [0..(slots - 1)] \curN -> do+ entropy64 <- getEntropyWord64+ let seqNo = entropy16 + curN+ bs = runPut do+ fillTime timestamp+ fillVerAndRandA seqNo+ fillVarAndRandB seqNo entropy64+ pure . uncurry UUID $ runGet (join (liftM2 (,)) getWord64be) bs+ if slots == n+ then pure uuids+ else (uuids ++) <$> go (n - slots)++-- | Validate the version and variant of the t'UUID'v7. validate :: UUID -> Bool validate = flip validateWithVersion V7 {-# INLINE validate #-} --- | Validate the version and variant of the 'UUID'v7 as well as its timestamp+-- | Validate the version and variant of the t'UUID'v7 as well as its timestamp -- is no greater than the current time. validateWithTime :: MonadIO m => UUID -> m Bool validateWithTime uuid = do curTime <- getEpochMilli pure $ validate uuid && (getTime uuid <= curTime) {-# INLINE validateWithTime #-}- + -- | Get the current time in milliseconds since the Unix epoch. getEpochMilli :: MonadIO m => m Word64 getEpochMilli = liftIO do@@ -129,7 +192,7 @@ pure . round $ t * 1000 {-# INLINE getEpochMilli #-} --- | Get the time field (unix_ts_ms) of a 'UUID'v7.+-- | Get the time field (unix_ts_ms) of a t'UUID'v7. getTime :: UUID -> Word64 getTime (UUID w1 _) = w1 `shiftR` 16 {-# INLINE getTime #-}@@ -142,7 +205,7 @@ __state__ = unsafePerformIO (newIORef (0, 0)) {-# NOINLINE __state__ #-} --- | Fill in the 48-bit time field (unix_ts_ms) of a 'UUID'v7 with the given+-- | Fill in the 48-bit time field (unix_ts_ms) of a t'UUID'v7 with the given -- time. fillTime :: Word64 -> Put fillTime timestamp = do@@ -150,7 +213,7 @@ mapM_ putWord16be [p2, p1, p0] {-# INLINE fillTime #-} --- | Fill in the version and rand_a part of a 'UUID'v7 with the given sequence+-- | Fill in the version and rand_a part of a t'UUID'v7 with the given sequence -- number. -- -- The sequence number is a 16-bit integer, of which the first 12 bits are used@@ -162,7 +225,7 @@ putWord16be randAWithVer {-# INLINE fillVerAndRandA #-} --- | Fill in the variant and rand_b part of a 'UUID'v7 with the given sequence+-- | Fill in the variant and rand_b part of a t'UUID'v7 with the given sequence -- number and random number. The variant is 2. -- -- The sequence number is a 16-bit integer, of which the last 4 bits are used
src/Data/UUID/Versions.hs view
@@ -4,11 +4,11 @@ -- Maintainer : mmzk1526@outlook.com -- Portability : GHC ----- Supported 'UUID' versions for 'Data.TypeID.TypeID''.+-- Supported t'UUID' versions for 'Data.TypeID.TypeID''. -- module Data.UUID.Versions (- -- * Supported 'UUID' versions+ -- * Supported t'UUID' versions UUIDVersion(..) -- * Validation , validateWithVersion@@ -18,7 +18,7 @@ import Data.UUID.Types.Internal import GHC.Generics (Generic) --- | The supported 'UUID' versions. These constructors are used as type-level+-- | The supported t'UUID' versions. These constructors are used as type-level -- tags for 'Data.TypeID.TypeID''. data UUIDVersion = V1 | V4 | V5 | V7 deriving (Eq, Ord, Bounded, Enum, Show, Generic)@@ -30,7 +30,7 @@ toInt V7 = 7 {-# INLINE toInt #-} --- | Validate the given 'UUID' with the given 'UUIDVersion'.+-- | Validate the given t'UUID' with the given 'UUIDVersion'. -- -- The variant is supposed to be 0x2. validateWithVersion :: UUID -> UUIDVersion -> Bool
test/Spec.hs view
@@ -24,6 +24,7 @@ import qualified Data.Text as T import Data.Text.Encoding import Data.TypeID+import Data.TypeID.Unsafe import Data.TypeID.V1 (TypeIDV1) import Data.TypeID.V4 (TypeIDV4) import Data.TypeID.V5 (TypeIDV5)@@ -113,6 +114,7 @@ main = hspec do typeLevelTest v7Test+ v7WithTimeTest v1Test v4Test v5Test@@ -364,6 +366,93 @@ kid'' <- peek ptr kid'' `shouldBe` kid' free ptr++v7WithTimeTest :: Spec+v7WithTimeTest = do+ let testTimestamp = 1234567890123 :: Word64+ describe "Generate TypeID with custom timestamp" do+ it "can generate TypeID with correct prefix and timestamp" do+ tid <- withCheck $ genTypeIDWithTime "mmzk" testTimestamp+ getPrefix tid `shouldBe` "mmzk"+ getTime tid `shouldBe` testTimestamp+ validateWithVersion (getUUID tid) V7 `shouldBe` True+ it "can generate TypeID with stateless UUIDv7 and custom timestamp" do+ tid <- withCheck $ genTypeIDWithTime' "mmzk" testTimestamp+ getPrefix tid `shouldBe` "mmzk"+ getTime tid `shouldBe` testTimestamp+ validateWithVersion (getUUID tid) V7 `shouldBe` True+ it "can generate batch with same custom timestamp and ascending order" do+ tids <- withChecks $ genTypeIDsWithTime "mmzk" testTimestamp 100+ all ((== "mmzk") . getPrefix) tids `shouldBe` True+ all ((== testTimestamp) . getTime) tids `shouldBe` True+ all (\tid -> validateWithVersion (getUUID tid) V7) tids `shouldBe` True+ all (uncurry (<)) (zip tids $ tail tids) `shouldBe` True+ it "rejects invalid prefix" do+ genTypeIDWithTime "INVALID" testTimestamp `shouldThrow` anyTypeIDError+ genTypeIDWithTime' "INVALID" testTimestamp `shouldThrow` anyTypeIDError+ genTypeIDsWithTime "INVALID" testTimestamp 1 `shouldThrow` anyTypeIDError+ it "works with timestamp 0" do+ tid <- withCheck $ genTypeIDWithTime "mmzk" 0+ getPrefix tid `shouldBe` "mmzk"+ getTime tid `shouldBe` 0+ validateWithVersion (getUUID tid) V7 `shouldBe` True+ describe "Generate KindID with custom timestamp" do+ it "can generate KindID with correct prefix and timestamp" do+ kid <- withCheck $ genKindIDWithTime @"mmzk" testTimestamp+ getPrefix kid `shouldBe` "mmzk"+ getTime kid `shouldBe` testTimestamp+ validateWithVersion (getUUID kid) V7 `shouldBe` True+ it "can generate KindID with stateless UUIDv7 and custom timestamp" do+ kid <- withCheck $ genKindIDWithTime' @"mmzk" testTimestamp+ getPrefix kid `shouldBe` "mmzk"+ getTime kid `shouldBe` testTimestamp+ validateWithVersion (getUUID kid) V7 `shouldBe` True+ it "can generate KindID batch with same custom timestamp and ascending order" do+ kids <- withChecks $ genKindIDsWithTime @"mmzk" testTimestamp 100+ all ((== "mmzk") . getPrefix) kids `shouldBe` True+ all ((== testTimestamp) . getTime) kids `shouldBe` True+ all (\kid -> validateWithVersion (getUUID kid) V7) kids `shouldBe` True+ all (uncurry (<)) (zip kids $ tail kids) `shouldBe` True+ describe "Generate UUID with custom timestamp" do+ it "can generate UUID with correct timestamp" do+ uuid <- V7.genUUIDWithTime testTimestamp+ V7.getTime uuid `shouldBe` testTimestamp+ V7.validate uuid `shouldBe` True+ it "can generate stateless UUID with correct timestamp" do+ uuid <- V7.genUUIDWithTime' testTimestamp+ V7.getTime uuid `shouldBe` testTimestamp+ V7.validate uuid `shouldBe` True+ it "can generate UUID batch with same timestamp and ascending order" do+ uuids <- V7.genUUIDsWithTime testTimestamp 100+ all ((== testTimestamp) . V7.getTime) uuids `shouldBe` True+ all V7.validate uuids `shouldBe` True+ all (uncurry (<)) (zip uuids $ tail uuids) `shouldBe` True+ it "generates across batches with first 32768 monotonically increasing" do+ uuids <- V7.genUUIDsWithTime testTimestamp 40000+ all ((== testTimestamp) . V7.getTime) uuids `shouldBe` True+ all V7.validate uuids `shouldBe` True+ let first32768 = take 32768 uuids+ all (uncurry (<)) (zip first32768 $ tail first32768) `shouldBe` True+ describe "Custom timestamp does not affect global state" do+ it "does not interfere with normal generation" do+ tids1 <- genIDs @TypeID "test" 10+ _ <- genTypeIDWithTime "test" 0+ tids2 <- genIDs @TypeID "test" 10+ let all20 = tids1 ++ tids2+ all (uncurry (<=)) (zip all20 $ tail all20) `shouldBe` True+ describe "Unsafe WithTime generation does not check prefix" do+ it "unsafeGenTypeIDWithTime accepts invalid prefix" do+ tid <- unsafeGenTypeIDWithTime "INVALID" testTimestamp+ getPrefix tid `shouldBe` "INVALID"+ getTime tid `shouldBe` testTimestamp+ it "unsafeGenTypeIDWithTime' accepts invalid prefix" do+ tid <- unsafeGenTypeIDWithTime' "INVALID" testTimestamp+ getPrefix tid `shouldBe` "INVALID"+ getTime tid `shouldBe` testTimestamp+ it "unsafeGenTypeIDsWithTime accepts invalid prefix" do+ tids <- unsafeGenTypeIDsWithTime "INVALID" testTimestamp 5+ all ((== "INVALID") . getPrefix) tids `shouldBe` True+ all ((== testTimestamp) . getTime) tids `shouldBe` True v1Test :: Spec v1Test = do