diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -1,6 +1,12 @@ # Revision history for mmzk-typeid +## 0.6.2.0 -- 2024-05-28 + +* Fix the bug where the first 32768 `TypeID`s may not of the same timestamp. +* Test on GHC 9.8.2. + + ## 0.6.0.1 -- 2024-04-26 * Fix typo in the maintainer's email address. diff --git a/mmzk-typeid.cabal b/mmzk-typeid.cabal --- a/mmzk-typeid.cabal +++ b/mmzk-typeid.cabal @@ -1,8 +1,8 @@ cabal-version: 2.4 name: mmzk-typeid -version: 0.6.0.1 +version: 0.6.2.0 -synopsis: A TypeID implementation for Haskell +synopsis: A TypeID and UUIDv7 implementation for Haskell description: 'TypeID' is a type-safe, K-sortable, globally unique identifier inspired by Stripe IDs. . @@ -33,10 +33,11 @@ license: MIT author: Yitang Chen maintainer: Yitang Chen -category: Data, UUID, TypeID +category: Data, UUID, UUIDv7, TypeID tested-with: GHC == 9.2.8 GHC == 9.6.1 + GHC == 9.8.2 extra-source-files: CHANGELOG.md LICENSE @@ -102,7 +103,7 @@ entropy ^>=0.4, hashable ^>=1.4, random ^>=1.2, - text ^>=2.0, + text ^>=2.1, time >=1.11 && <1.13, uuid ^>=1.3, uuid-types ^>=1.0, diff --git a/src/Data/UUID/V7.hs b/src/Data/UUID/V7.hs --- a/src/Data/UUID/V7.hs +++ b/src/Data/UUID/V7.hs @@ -76,38 +76,43 @@ -- It is guaranteed that the first 32768 'UUID's are generated at the same -- timestamp. genUUIDs :: MonadIO m => Word16 -> m [UUID] -genUUIDs 0 = pure [] -genUUIDs n = liftIO do - timestamp <- getEpochMilli - -- We set the first bit of the entropy to 0 to ensure that there's enough - -- room for incrementing the sequence number. - entropy16 <- (.&. 0x7FFF) <$> getEntropyWord16 - -- Calculate the maximum number of slots we can use for the current timestamp - -- before the sequence number overflows. - let getMaxSlots num seqNo = if 0xFFFF - seqNo < num - then (0xFFFF - seqNo, 0xFFFF) - else (num, seqNo + num) - -- Get the sequence number corresponding to the current timestamp and the - -- number of UUIDs we can generate. - (n', seqNo) <- atomicModifyIORef __state__ $ \(ts, seqNo) -> if - | ts < timestamp -> let (n', entropy16') = getMaxSlots n entropy16 - in ((timestamp, entropy16'), (n', entropy16 + 1)) - | ts > timestamp -> ((ts, seqNo), (0, 0)) - | otherwise -> let (n', entropy16') = getMaxSlots n seqNo - in ((timestamp, entropy16'), (n', seqNo + 1)) - -- If we can't generate any UUIDs, we try again, hoping that the timestamp - -- has changed. - if n' == 0 - then genUUIDs n - else do - uuids <- forM [0..(n' - 1)] $ \curN -> do - entropy64 <- getEntropyWord64 - let bs = runPut do - fillTime timestamp - fillVerAndRandA (seqNo + curN) - fillVarAndRandB (seqNo + curN) entropy64 - pure . uncurry UUID $ runGet (join (liftM2 (,)) getWord64be) bs - if n' == n then pure uuids else (uuids ++) <$> genUUIDs (n - n') +genUUIDs = liftIO . go True + where + go _ 0 = pure [] + go mustSameTime n = do + timestamp <- getEpochMilli + -- We set the first bit of the entropy to 0 to ensure that there's enough + -- room for incrementing the sequence number. + entropy16 <- (.&. 0x7FFF) <$> getEntropyWord16 + -- Calculate the maximum number of slots we can use for the current + -- timestamp before the sequence number overflows. + let getMaxSlots num seqNo = if 0xFFFF - seqNo < num + then ( if mustSameTime && num <= 32768 then 0 else 0xFFFF - seqNo + , 0xFFFF ) + else (num, seqNo + num) + -- Get the sequence number corresponding to the current timestamp and the + -- number of UUIDs we can generate. + (n', seqNo) <- atomicModifyIORef __state__ \(ts, seqNo) -> if + | ts < timestamp -> let (n', entropy16') = getMaxSlots n entropy16 + in ((timestamp, entropy16'), (n', entropy16 + 1)) + | ts > timestamp -> ((ts, seqNo), (0, 0)) + | otherwise -> let (n', entropy16') = getMaxSlots n seqNo + in ((timestamp, entropy16'), (n', seqNo + 1)) + -- If we can't generate any UUIDs, we try again, hoping that the timestamp + -- has changed. + if n' == 0 + then go mustSameTime n + else do + uuids <- forM [0..(n' - 1)] $ \curN -> do + entropy64 <- getEntropyWord64 + let bs = runPut do + fillTime timestamp + fillVerAndRandA (seqNo + curN) + fillVarAndRandB (seqNo + curN) entropy64 + pure . uncurry UUID $ runGet (join (liftM2 (,)) getWord64be) bs + if n' == n + then pure uuids + else (uuids ++) <$> go False (n - n') -- | Validate the version and variant of the 'UUID'v7. validate :: UUID -> Bool diff --git a/test/Spec.hs b/test/Spec.hs --- a/test/Spec.hs +++ b/test/Spec.hs @@ -1,6 +1,7 @@ {-# LANGUAGE DuplicateRecordFields #-} {-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-} +{-# OPTIONS_GHC -Wno-x-partial #-} import Control.Monad import Data.Aeson @@ -107,7 +108,7 @@ getTime tid `shouldSatisfy` \t -> t >= start it "can generate in batch with same timestamp and in ascending order" do start <- V7.getEpochMilli - tids <- withChecks $ genIDs @TypeID "mmzk" 1526 + tids <- withChecks $ genIDs @TypeID "mmzk" 32768 all ((== "mmzk") . getPrefix) tids `shouldBe` True let timestamp = getTime $ head tids all ((== timestamp) . getTime) tids `shouldBe` True @@ -240,7 +241,7 @@ getTime kid `shouldSatisfy` \t -> start <= t it "can generate in batch with same timestamp and in ascending order" do start <- V7.getEpochMilli - kids <- withChecks $ genIDs @(KindID "mmzk") 1526 + kids <- withChecks $ genIDs @(KindID "mmzk") 32768 all ((== "mmzk") . getPrefix) kids `shouldBe` True let timestamp = getTime $ head kids all ((== timestamp) . getTime) kids `shouldBe` True @@ -268,7 +269,7 @@ Left _ -> pure () Right kid -> expectationFailure $ "Parsed KindID: " ++ show kid it "can generate in batch with same timestamp and in ascending order" do - kids <- withChecks $ genIDs @(KindID 'Comment) 1526 + kids <- withChecks $ genIDs @(KindID 'Comment) 32768 all ((== "comment") . getPrefix) kids `shouldBe` True let timestamp = getTime $ head kids all ((== timestamp) . getTime) kids `shouldBe` True