mmzk-typeid 0.7.1.1 → 0.7.1.2
raw patch · 32 files changed
+196/−87 lines, 32 filesdep +directorydep +filepathPVP ok
version bump matches the API change (PVP)
Dependencies added: directory, filepath
API changes (from Hackage documentation)
Files
- CHANGELOG.md +20/−1
- LICENSE +1/−1
- README.md +5/−5
- mmzk-typeid.cabal +6/−4
- src/Data/KindID.hs +0/−1
- src/Data/KindID/Class.hs +0/−1
- src/Data/KindID/Internal.hs +1/−1
- src/Data/KindID/Unsafe.hs +1/−2
- src/Data/KindID/V1.hs +1/−1
- src/Data/KindID/V1/Unsafe.hs +0/−1
- src/Data/KindID/V4.hs +1/−1
- src/Data/KindID/V4/Unsafe.hs +0/−1
- src/Data/KindID/V5.hs +1/−1
- src/Data/KindID/V5/Unsafe.hs +0/−1
- src/Data/KindID/V7.hs +1/−1
- src/Data/KindID/V7/Unsafe.hs +0/−1
- src/Data/TypeID.hs +0/−1
- src/Data/TypeID/Class.hs +3/−2
- src/Data/TypeID/Error.hs +0/−1
- src/Data/TypeID/Internal.hs +61/−26
- src/Data/TypeID/Unsafe.hs +0/−1
- src/Data/TypeID/V1.hs +0/−1
- src/Data/TypeID/V1/Unsafe.hs +0/−1
- src/Data/TypeID/V4.hs +0/−1
- src/Data/TypeID/V4/Unsafe.hs +0/−1
- src/Data/TypeID/V5.hs +0/−1
- src/Data/TypeID/V5/Unsafe.hs +0/−1
- src/Data/TypeID/V7.hs +0/−1
- src/Data/TypeID/V7/Unsafe.hs +0/−1
- src/Data/UUID/V7.hs +53/−13
- src/Data/UUID/Versions.hs +0/−1
- test/Spec.hs +41/−10
CHANGELOG.md view
@@ -1,6 +1,25 @@ # Revision history for mmzk-typeid +## 0.7.1.2 -- 2026-09-06++* Fix an out-of-bounds read in the `Storable` instance when the prefix length byte is corrupt. The length is now validated before any bytes are read, and `poke` rejects prefixes that would overflow the record.++* Fix the dead prefix validation in the `Binary` and `Storable` instances. The character check was a tautology and never rejected anything; malformed serialised `TypeID`s could produce values with invalid prefixes. Both instances now also run the full prefix validation on decoding.++* Fix the unsafe parsers (`unsafeParseString`, `unsafeParseText`, `unsafeParseByteString`) splitting at the first underscore while the safe parsers split at the last. A spec-valid ID with an underscored prefix (e.g. `super_user_...`) was silently parsed into a wrong prefix and a garbage UUID.++* Make `parseByteString` (and the `byteString2ID` class method) total: invalid UTF-8 in the prefix now yields a `TypeIDError` instead of throwing a `UnicodeException`.++* `getTime` now returns 0 for non-v7 `TypeID`/`KindID`, as its documentation always claimed, instead of the top bits of the UUID.++* Reduce the OS entropy syscalls in `Data.UUID.V7` by buffering reads (256-byte chunks), and avoid spinning the CPU when the clock steps backwards during batch generation.++* `Storable.poke` now errors on prefixes longer than 63 characters instead of writing past the end of the record. Only reachable via the unsafe API.++* Documentation fixes: the `Binary` format description, the `README` examples, and notes on the `decorateTypeID` and custom-timestamp behaviour.++ ## 0.7.1.1 -- 2026-05-13 * Support `random` 1.3.@@ -77,7 +96,7 @@ ## 0.6.2.0 -- 2024-05-28 -* Fix the bug where the first 32768 `TypeID`s may not of the same timestamp.+* Fix the bug where the first 32768 `TypeID`s may not be of the same timestamp. * Test on GHC 9.8.2.
LICENSE view
@@ -1,6 +1,6 @@ MIT License -Copyright (c) 2023 Yitang Chen+Copyright (c) 2026 MMZK1526 Permission is hereby granted, free of charge, to any person obtaining a copy of this software and associated documentation files (the "Software"), to deal
README.md view
@@ -14,7 +14,7 @@ It also serves as a (temporary) UUIDv7 implementation in Haskell, since there are no official ones yet. -If you notice any issues or have any suggestions, please feel free to open an issue or contact me via email.+If you notice any issues or have any suggestions, please feel free to open an issue. ## Highlights @@ -144,7 +144,7 @@ For a full list of functions on `KindID`, see [Data.KindID](https://hackage.haskell.org/package/mmzk-typeid/docs/Data-KindID.html). ### Functions with More General Types-`TypeID` and `KindID` shares many functions with the same name and functionality. So far, we are using qualified imports to diffentiate them (*e.g* `KID.fromString` and `TID.fromString`). Alternatively, we can use the methods of `IDConv` to use the same functions for both `TypeID` and `KindID`.+`TypeID` and `KindID` shares many functions with the same name and functionality. So far, we are using qualified imports to diffentiate them (*e.g* `KID.parseString` and `TID.parseString`). Alternatively, we can use the methods of `IDConv` to use the same functions for both `TypeID` and `KindID`. ```Haskell {-# LANGUAGE DataKinds #-}@@ -167,17 +167,17 @@ print kindID -- Parse a TypeID from string:- case string2ID "mmzk_01h455vb4pex5vsknk084sn02q" :: Maybe TypeID of+ case string2ID "mmzk_01h455vb4pex5vsknk084sn02q" :: Either TypeIDError TypeID of Left err -> throwIO err Right typeID -> print typeID -- Parse a KindID from string:- case string2ID "mmzk_01h455vb4pex5vsknk084sn02q" :: Maybe (KindID "mmzk") of+ case string2ID "mmzk_01h455vb4pex5vsknk084sn02q" :: Either TypeIDError (KindID "mmzk") of Left err -> throwIO err Right kindID -> print kindID -- Parse a KindID from string (wrong prefix):- case string2ID "mmzk_01h455vb4pex5vsknk084sn02q" :: Maybe (KindID "foo") of+ case string2ID "mmzk_01h455vb4pex5vsknk084sn02q" :: Either TypeIDError (KindID "foo") of Left err -> throwIO err -- Will throw here as the prefix matches not Right kindID -> print kindID ```
mmzk-typeid.cabal view
@@ -1,6 +1,6 @@ cabal-version: 2.4 name: mmzk-typeid-version: 0.7.1.1+version: 0.7.1.2 synopsis: A TypeID and UUIDv7 implementation for Haskell description:@@ -8,7 +8,7 @@ . The specification is available at https://github.com/jetpack-io/typeid. .- This library supports generating and parsing speç-conforming 'TypeID's, with the following additional features:+ This library supports generating and parsing spec-conforming 'TypeID's, with the following additional features: . - Batch generating 'TypeID's with the same UUIDv7 timestamp .@@ -31,8 +31,8 @@ homepage: https://github.com/MMZK1526/mmzk-typeid bug-reports: https://github.com/MMZK1526/mmzk-typeid/issues license: MIT-author: Yitang Chen <mmzk1526@outlook.com>-maintainer: Yitang Chen <mmzk1526@outlook.com>+author: MMZK1526+maintainer: MMZK1526 category: Data, UUID, UUIDv7, TypeID tested-with: GHC == 9.4.8@@ -173,7 +173,9 @@ binary, bytestring, containers >=0.6 && <1,+ directory, entropy,+ filepath, hashable, hint ^>=0.9, hspec ^>=2.11,
src/Data/KindID.hs view
@@ -1,7 +1,6 @@ -- | -- Module : Data.KindID -- License : MIT--- Maintainer : mmzk1526@outlook.com -- Portability : GHC -- -- Similar to "Data.TypeID", but the type is statically determined in the type
src/Data/KindID/Class.hs view
@@ -4,7 +4,6 @@ -- | -- Module : Data.KindID.Class -- License : MIT--- Maintainer : mmzk1526@outlook.com -- Portability : GHC -- -- This module contains the type-level mechanisms that are used to define
src/Data/KindID/Internal.hs view
@@ -3,7 +3,6 @@ -- | -- Module : Data.KindID.Internal -- License : MIT--- Maintainer : mmzk1526@outlook.com -- Portability : GHC -- module Data.KindID.Internal where@@ -591,6 +590,7 @@ checkKindIDV5 :: (ToPrefix prefix, ValidPrefix (PrefixSymbol prefix)) => KindID' 'V5 prefix -> Maybe TypeIDError checkKindIDV5 = TID.checkTypeIDV5 . toTypeID+{-# INLINE checkKindIDV5 #-} -- | Convert a 'TypeID'' to a 'KindID''. If the actual prefix does not match -- with the expected one as defined by the type, it does not complain and
src/Data/KindID/Unsafe.hs view
@@ -1,12 +1,11 @@ -- | -- Module : Data.KindID.Unsafe -- License : MIT--- Maintainer : mmzk1526@outlook.com -- Portability : GHC -- -- Unsafe 'Data.KindID.V7.KindID' functions. ----- It is a re-export of "Data.TypeID.V7.Unsafe".+-- It is a re-export of "Data.KindID.V7.Unsafe". -- module Data.KindID.Unsafe (
src/Data/KindID/V1.hs view
@@ -1,7 +1,6 @@ -- | -- Module : Data.KindID.V1 -- License : MIT--- Maintainer : mmzk1526@outlook.com -- Portability : GHC -- -- 'Data.KindID.V7.KindID' with 'UUID'v1.@@ -127,6 +126,7 @@ . (ToPrefix prefix, ValidPrefix (PrefixSymbol prefix)) => ByteString -> Either TypeIDError (KindIDV1 prefix) parseByteString = KID.parseByteString+{-# INLINE parseByteString #-} -- | Parse a 'KindIDV1' from its 'String' representation, throwing an error when -- the parsing fails. It is 'string2IDM' with concrete type.
src/Data/KindID/V1/Unsafe.hs view
@@ -1,7 +1,6 @@ -- | -- Module : Data.KindID.V1.Unsafe -- License : MIT--- Maintainer : mmzk1526@outlook.com -- Portability : GHC -- -- Unsafe 'KindIDV1' functions.
src/Data/KindID/V4.hs view
@@ -1,7 +1,6 @@ -- | -- Module : Data.KindID.V4 -- License : MIT--- Maintainer : mmzk1526@outlook.com -- Portability : GHC -- -- 'Data.KindID.V7.KindID' with 'UUID'v4.@@ -135,6 +134,7 @@ . (ToPrefix prefix, ValidPrefix (PrefixSymbol prefix)) => ByteString -> Either TypeIDError (KindIDV4 prefix) parseByteString = KID.parseByteString+{-# INLINE parseByteString #-} -- | Parse a 'KindIDV4' from its 'String' representation, throwing an error when -- the parsing fails. It is 'string2IDM' with concrete type.
src/Data/KindID/V4/Unsafe.hs view
@@ -1,7 +1,6 @@ -- | -- Module : Data.KindID.V4.Unsafe -- License : MIT--- Maintainer : mmzk1526@outlook.com -- Portability : GHC -- -- Unsafe 'KindIDV4' functions.
src/Data/KindID/V5.hs view
@@ -1,7 +1,6 @@ -- | -- Module : Data.KindID.V5 -- License : MIT--- Maintainer : mmzk1526@outlook.com -- Portability : GHC -- -- 'Data.KindID.V7.KindID' with 'UUID'v5.@@ -128,6 +127,7 @@ . (ToPrefix prefix, ValidPrefix (PrefixSymbol prefix)) => ByteString -> Either TypeIDError (KindIDV5 prefix) parseByteString = KID.parseByteString+{-# INLINE parseByteString #-} -- | Parse a 'KindIDV5' from its 'String' representation, throwing an error when -- the parsing fails. It is 'string2IDM' with concrete type.
src/Data/KindID/V5/Unsafe.hs view
@@ -1,7 +1,6 @@ -- | -- Module : Data.KindID.V5.Unsafe -- License : MIT--- Maintainer : mmzk1526@outlook.com -- Portability : GHC -- -- Unsafe 'KindIDV5' functions.
src/Data/KindID/V7.hs view
@@ -1,7 +1,6 @@ -- | -- Module : Data.KindID.V7 -- License : MIT--- Maintainer : mmzk1526@outlook.com -- Portability : GHC -- -- Similar to "Data.TypeID", but the type is statically determined in the type@@ -204,6 +203,7 @@ . (ToPrefix prefix, ValidPrefix (PrefixSymbol prefix)) => ByteString -> Either TypeIDError (KindID prefix) parseByteString = KID.parseByteString+{-# INLINE parseByteString #-} -- | Parse a 'KindID' from its 'String' representation, throwing an error when -- the parsing fails. It is 'string2IDM' with concrete type.
src/Data/KindID/V7/Unsafe.hs view
@@ -1,7 +1,6 @@ -- | -- Module : Data.KindID.V7.Unsafe -- License : MIT--- Maintainer : mmzk1526@outlook.com -- Portability : GHC -- -- Unsafe 'KindID' functions.
src/Data/TypeID.hs view
@@ -1,7 +1,6 @@ -- | -- Module : Data.TypeID -- License : MIT--- Maintainer : mmzk1526@outlook.com -- Portability : GHC -- -- An implementation of the 'TypeID' specification:
src/Data/TypeID/Class.hs view
@@ -3,7 +3,6 @@ -- | -- Module : Data.TypeID.Class -- License : MIT--- Maintainer : mmzk1526@outlook.com -- Portability : GHC -- -- A module with the APIs for any 'Data.TypeID.V7.TypeID'-ish identifier type.@@ -76,7 +75,9 @@ -- | Parse the identifier from its string representation as a lazy -- 'ByteString'. byteString2ID :: ByteString -> Either TypeIDError a- byteString2ID = string2ID . T.unpack . decodeUtf8 . BSL.toStrict+ byteString2ID bs = case decodeUtf8' (BSL.toStrict bs) of+ Left _ -> Left TypeIDErrorUUIDError+ Right txt -> string2ID (T.unpack txt) {-# INLINE byteString2ID #-} -- | Pretty-print the identifier to a 'String'.
src/Data/TypeID/Error.hs view
@@ -1,7 +1,6 @@ -- | -- Module : Data.TypeID.Error -- License : MIT--- Maintainer : mmzk1526@outlook.com -- Portability : GHC -- -- TypeID Error type.
src/Data/TypeID/Internal.hs view
@@ -1,7 +1,6 @@ -- | -- Module : Data.TypeID.Internal -- License : MIT--- Maintainer : mmzk1526@outlook.com -- Portability : GHC -- module Data.TypeID.Internal where@@ -48,7 +47,8 @@ -- other than v7. -- -- The constructor is not exposed to the public API to prevent generating--- invalid 'TypeID''s.+-- invalid 'TypeID''s. Note that the 'Generic' and 'Data' instances still allow+-- constructing arbitrary (including invalid) values. data TypeID' (version :: UUIDVersion) = TypeID' Text UUID deriving (Eq, Ord, Data, Generic) @@ -93,8 +93,8 @@ -- | Since the specification does not formulate a concrete binary format, this -- instance is based on the following custom format: ----- * The first 16 bytes are the suffix 'UUID' encoded in base32.--- * The next byte is the length of the prefix encoded in a byte.+-- * The first 16 bytes are the raw big-endian suffix 'UUID'.+-- * The next byte is the number of 5-bit groups in the encoded prefix. -- * The next bytes are the prefix, each letter taking 5 bits, mapping \'a\' to -- 1 and \'z\' to 26. The underscore \'_\' is mapped to 27. --@@ -119,13 +119,19 @@ get = do uuid <- get len <- getWord8+ when (len > fromIntegral maxEncodedPrefixLen) $ fail "Binary: Prefix too long" encodedPrefix <- separate5BitInts <$> replicateM (fromIntegral len) getWord8- when (length encodedPrefix > 63) do fail "Binary: Prefix too long"- when (any (liftM2 (&&) (< 1) (> 26)) encodedPrefix) do+ when (any (\v -> v < 1 || v > 27) encodedPrefix) do fail "Binary: Invalid prefix" let back 27 = 95 back a = a + 96- pure $ TypeID' (decodeUtf8 . BS.pack $ fmap back encodedPrefix) uuid+ let bs = BS.pack $ fmap back encodedPrefix+ prefix <- case decodeUtf8' bs of+ Right p -> pure p+ Left _ -> fail "Binary: Invalid prefix"+ case checkPrefix prefix of+ Just err -> fail $ "Binary: " ++ show err+ Nothing -> pure $ TypeID' prefix uuid {-# INLINE get #-} -- | Similar to the 'Binary' instance, but the 'UUID' is stored in host endian.@@ -140,27 +146,36 @@ peek :: Ptr (TypeID' version) -> IO (TypeID' version) peek ptr = do- uuid <- peek (castPtr ptr :: Ptr UUID)- len <- fromIntegral <$> (peekByteOff ptr 16 :: IO Word8)+ uuid <- peek (castPtr ptr :: Ptr UUID)+ len <- peekByteOff ptr uuidSize :: IO Word8+ when (len > fromIntegral maxEncodedPrefixLen) $ fail "Storable: Prefix too long" encodedPrefix <- separate5BitInts- <$> forM [1..len] \ix -> peekByteOff @Word8 ptr (16 + ix)- when (length encodedPrefix > 63) $ fail "Storable: Prefix too long"- when (any (liftM2 (&&) (< 1) (> 26)) encodedPrefix) do+ <$> forM [1 .. fromIntegral len] \ix -> peekByteOff @Word8 ptr (uuidSize + ix)+ when (any (\v -> v < 1 || v > 27) encodedPrefix) do fail "Storable: Invalid prefix" let back 27 = 95 back a = a + 96- pure $ TypeID' (decodeUtf8 . BS.pack $ fmap back encodedPrefix) uuid+ let bs = BS.pack $ fmap back encodedPrefix+ prefix <- case decodeUtf8' bs of+ Right p -> pure p+ Left _ -> fail "Storable: Invalid prefix"+ case checkPrefix prefix of+ Just err -> fail $ "Storable: " ++ show err+ Nothing -> pure $ TypeID' prefix uuid {-# INLINE peek #-} poke :: Ptr (TypeID' version) -> TypeID' version -> IO () poke ptr (TypeID' prefix uuid) = do- poke (castPtr ptr) uuid let fore 95 = 27 fore a = a - 96 let encodedPrefix = concat5BitInts . fmap fore . BS.unpack $ encodeUtf8 prefix- pokeByteOff @Word8 ptr 16 (fromIntegral $ length encodedPrefix)- zipWithM_ (pokeByteOff ptr . (+ 16)) [1..] encodedPrefix+ -- A prefix that is too long would overflow the fixed 60-byte record.+ when (T.length prefix > 63 || length encodedPrefix > maxEncodedPrefixLen) $+ error "Storable: Prefix too long"+ poke (castPtr ptr) uuid+ pokeByteOff @Word8 ptr uuidSize (fromIntegral $ length encodedPrefix)+ zipWithM_ (pokeByteOff ptr . (+ uuidSize)) [1..] encodedPrefix {-# INLINE poke #-} instance Hashable (TypeID' version) where@@ -180,7 +195,9 @@ {-# INLINE getUUID #-} getTime :: TypeID' version -> Word64- getTime = V7.getTime . getUUID+ getTime tid@(TypeID' _ uuid)+ | validateWithVersion uuid V7 = V7.getTime uuid+ | otherwise = 0 {-# INLINE getTime #-} -- | Conversion between 'TypeID'' and 'String'/'Text'/'ByteString'.@@ -439,6 +456,9 @@ {-# INLINE genTypeIDV5 #-} -- | Obtain a 'TypeID'' from a prefix and a 'UUID'.+--+-- Note: the 'UUID' is not validated against the version of the 'TypeID''.+-- Use 'checkID' if it needs to be validated. decorateTypeID :: Text -> UUID -> Either TypeIDError (TypeID' version) decorateTypeID prefix uuid = case checkPrefix prefix of Nothing -> Right $ TypeID' prefix uuid@@ -515,7 +535,8 @@ (_, Just ("", _)) -> Left TypeIDExtraSeparator (_, Nothing) -> TypeID' "" <$> decodeUUID bs (suffix, Just (prefix, _)) -> do- let prefix' = decodeUtf8 $ BSL.toStrict prefix+ prefix' <- either (const $ Left TypeIDErrorUUIDError) Right+ $ decodeUtf8' (BSL.toStrict prefix) case checkPrefix prefix' of Nothing -> TypeID' prefix' <$> decodeUUID suffix Just err -> Left err@@ -706,29 +727,32 @@ -- | Parse a 'TypeID'' from its 'String' representation, but crashes when -- parsing fails. unsafeParseString :: String -> TypeID' version-unsafeParseString str = case span (/= '_') str of+unsafeParseString str = case spanEnd (/= '_') str of (_, "") -> TypeID' "" . unsafeDecodeUUID $ fromString str- (prefix, _ : suffix) -> TypeID' (T.pack prefix)+ (suffix, "_") -> TypeID' "" . unsafeDecodeUUID $ fromString suffix+ (suffix, prefix) -> TypeID' (T.pack $ init prefix) . unsafeDecodeUUID $ fromString suffix {-# INLINE unsafeParseString #-} -- | Parse a 'TypeID'' from its string representation as a strict 'Text', but -- crashes when parsing fails. unsafeParseText :: Text -> TypeID' version-unsafeParseText text = case second T.uncons $ T.span (/= '_') text of+unsafeParseText text = case second T.unsnoc . swap . runIdentity+ $ T.spanEndM (pure . (/= '_')) text of (_, Nothing) -> TypeID' "" . unsafeDecodeUUID . BSL.fromStrict $ encodeUtf8 text- (prefix, Just (_, suffix)) -> TypeID' prefix . unsafeDecodeUUID+ (suffix, Just (prefix, _)) -> TypeID' prefix . unsafeDecodeUUID . BSL.fromStrict . encodeUtf8 $ suffix {-# INLINE unsafeParseText #-} -- | Parse a 'TypeID'' from its string representation as a lazy 'ByteString', -- but crashes when parsing fails. unsafeParseByteString :: ByteString -> TypeID' version-unsafeParseByteString bs = case second BSL.uncons $ BSL.span (/= 95) bs of+unsafeParseByteString bs = case second BSL.unsnoc . swap $ BSL.spanEnd (/= 95) bs of (_, Nothing) -> TypeID' "" $ unsafeDecodeUUID bs- (prefix, Just (_, suffix)) -> TypeID' (decodeUtf8 $ BSL.toStrict prefix)- . unsafeDecodeUUID $ suffix+ (suffix, Just (prefix, _)) ->+ let prefix' = either (error . show) id . decodeUtf8' $ BSL.toStrict prefix+ in TypeID' prefix' . unsafeDecodeUUID $ suffix {-# INLINE unsafeParseByteString #-} -- | A helper for generating 'UUID'v1.@@ -738,6 +762,17 @@ -- Helpers +-- | The maximum number of bytes needed to 5-bit-encode a 63-character prefix,+-- i.e. @ceil(63 * 5 / 8)@.+maxEncodedPrefixLen :: Int+maxEncodedPrefixLen = 40+{-# INLINE maxEncodedPrefixLen #-}++-- | The size in bytes of the 'UUID' at the start of the 'Storable' record.+uuidSize :: Int+uuidSize = 16+{-# INLINE uuidSize #-}+ concat5BitInts :: [Word8] -> [Word8] concat5BitInts = reverse . toBytes@@ -810,7 +845,7 @@ writeArray dest 8 $ ((base32Table ! (bs `BSL.index` 13)) `shiftL` 4) .|. ((base32Table ! (bs `BSL.index` 14)) `shiftR` 1) writeArray dest 9 $ ((base32Table ! (bs `BSL.index` 14)) `shiftL` 7) .|. ((base32Table ! (bs `BSL.index` 15)) `shiftL` 2) .|. ((base32Table ! (bs `BSL.index` 16)) `shiftR` 3) writeArray dest 10 $ ((base32Table ! (bs `BSL.index` 16)) `shiftL` 5) .|. (base32Table ! (bs `BSL.index` 17))- writeArray dest 11 $ ((base32Table ! (bs `BSL.index` 18)) `shiftL` 3) .|. (base32Table ! (bs `BSL.index` 19)) `shiftR` 2+ writeArray dest 11 $ ((base32Table ! (bs `BSL.index` 18)) `shiftL` 3) .|. ((base32Table ! (bs `BSL.index` 19)) `shiftR` 2) writeArray dest 12 $ ((base32Table ! (bs `BSL.index` 19)) `shiftL` 6) .|. ((base32Table ! (bs `BSL.index` 20)) `shiftL` 1) .|. ((base32Table ! (bs `BSL.index` 21)) `shiftR` 4) writeArray dest 13 $ ((base32Table ! (bs `BSL.index` 21)) `shiftL` 4) .|. ((base32Table ! (bs `BSL.index` 22)) `shiftR` 1) writeArray dest 14 $ ((base32Table ! (bs `BSL.index` 22)) `shiftL` 7) .|. ((base32Table ! (bs `BSL.index` 23)) `shiftL` 2) .|. ((base32Table ! (bs `BSL.index` 24)) `shiftR` 3)
src/Data/TypeID/Unsafe.hs view
@@ -1,7 +1,6 @@ -- | -- Module : Data.TypeID.Unsafe -- License : MIT--- Maintainer : mmzk1526@outlook.com -- Portability : GHC -- -- Unsafe 'Data.TypeID.V7.TypeID' functions.
src/Data/TypeID/V1.hs view
@@ -1,7 +1,6 @@ -- | -- Module : Data.TypeID.V1 -- License : MIT--- Maintainer : mmzk1526@outlook.com -- Portability : GHC -- -- 'Data.TypeID.V7.TypeID' with 'UUID'v1.
src/Data/TypeID/V1/Unsafe.hs view
@@ -1,7 +1,6 @@ -- | -- Module : Data.TypeID.V1.Unsafe -- License : MIT--- Maintainer : mmzk1526@outlook.com -- Portability : GHC -- -- Unsafe 'TypeIDV1' functions.
src/Data/TypeID/V4.hs view
@@ -1,7 +1,6 @@ -- | -- Module : Data.TypeID.V4 -- License : MIT--- Maintainer : mmzk1526@outlook.com -- Portability : GHC -- -- 'Data.TypeID.V7.TypeID' with 'UUID'v4.
src/Data/TypeID/V4/Unsafe.hs view
@@ -1,7 +1,6 @@ -- | -- Module : Data.TypeID.V4.Unsafe -- License : MIT--- Maintainer : mmzk1526@outlook.com -- Portability : GHC -- -- Unsafe 'TypeIDV4' functions.
src/Data/TypeID/V5.hs view
@@ -1,7 +1,6 @@ -- | -- Module : Data.TypeID.V5 -- License : MIT--- Maintainer : mmzk1526@outlook.com -- Portability : GHC -- -- 'Data.TypeID.V7.TypeID' with 'UUID'v5.
src/Data/TypeID/V5/Unsafe.hs view
@@ -1,7 +1,6 @@ -- | -- Module : Data.TypeID.V5.Unsafe -- License : MIT--- Maintainer : mmzk1526@outlook.com -- Portability : GHC -- -- Unsafe 'TypeIDV5' functions.
src/Data/TypeID/V7.hs view
@@ -1,7 +1,6 @@ -- | -- Module : Data.TypeID.V7 -- License : MIT--- Maintainer : mmzk1526@outlook.com -- Portability : GHC -- -- An implementation of the 'TypeID' specification:
src/Data/TypeID/V7/Unsafe.hs view
@@ -1,7 +1,6 @@ -- | -- Module : Data.TypeID.V7.Unsafe -- License : MIT--- Maintainer : mmzk1526@outlook.com -- Portability : GHC -- -- Unsafe 'TypeID' functions.
src/Data/UUID/V7.hs view
@@ -1,7 +1,6 @@ -- | -- Module : Data.UUID.V7 -- License : MIT--- Maintainer : mmzk1526@outlook.com -- Portability : GHC -- -- UUIDv7 implementation.@@ -29,12 +28,14 @@ , getEpochMilli ) where +import Control.Concurrent import Control.Monad import Control.Monad.IO.Class import Data.Binary import Data.Binary.Get import Data.Binary.Put import Data.Bits+import qualified Data.ByteString as BS import qualified Data.ByteString.Lazy as BSL import Data.IORef import Data.Time.Clock.POSIX@@ -67,14 +68,16 @@ -- 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+genUUIDs n = liftIO $ go True n Nothing where- go _ 0 = pure []- go mustSameTime n = do- timestamp <- getEpochMilli+ go _ 0 _ = pure []+ go mustSameTime n mEntropy16 = 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+ entropy16 <- case mEntropy16 of+ Just e -> pure e+ Nothing -> (.&. 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@@ -83,16 +86,16 @@ 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+ (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.+ -- has changed. The threadDelay avoids pegging the CPU on clock step-backs. if n' == 0- then go mustSameTime n+ then threadDelay 100 >> go mustSameTime n (Just entropy16) else do uuids <- forM [0..(n' - 1)] $ \curN -> do entropy64 <- getEntropyWord64@@ -103,7 +106,7 @@ pure . uncurry UUID $ runGet (join (liftM2 (,)) getWord64be) bs if n' == n then pure uuids- else (uuids ++) <$> go False (n - n')+ else (uuids ++) <$> go False (n - n') Nothing -- | Generate a t'UUID'v7 with a custom timestamp (milliseconds since Unix -- epoch).@@ -113,6 +116,8 @@ -- -- Note: a future timestamp will produce a valid t'UUID' that nonetheless -- fails 'validateWithTime'.+--+-- Note: a timestamp wider than the 48-bit time field is truncated. genUUIDWithTime :: MonadIO m => Word64 -> m UUID genUUIDWithTime ts = head <$> genUUIDsWithTime ts 1 {-# INLINE genUUIDWithTime #-}@@ -126,6 +131,8 @@ -- -- Note: a future timestamp will produce a valid t'UUID' that nonetheless -- fails 'validateWithTime'.+--+-- Note: a timestamp wider than the 48-bit time field is truncated. genUUIDWithTime' :: MonadIO m => Word64 -> m UUID genUUIDWithTime' timestamp = do entropy16 <- getEntropyWord16@@ -153,6 +160,8 @@ -- -- Note: a future timestamp will produce valid t'UUID's that nonetheless -- fail 'validateWithTime'.+--+-- Note: a timestamp wider than the 48-bit time field is truncated. genUUIDsWithTime :: MonadIO m => Word64 -> Word16 -> m [UUID] genUUIDsWithTime timestamp = liftIO . go where@@ -200,7 +209,7 @@ -- | The global mutable state of (timestamp, sequence number). -- -- The \"NOINLINE\" pragma is IMPORTANT! The logic would be flawed if it is--- is inlined by its definition.+-- is inlined by its definition. A @fork()@'ed child inherits this state. __state__ :: IORef (Word64, Word16) __state__ = unsafePerformIO (newIORef (0, 0)) {-# NOINLINE __state__ #-}@@ -250,14 +259,45 @@ in (b3, b2, b1, b0) {-# INLINE splitWord64ToWord16s #-} +-- | The global entropy buffer, refilled from the OS CSPRNG in chunks to avoid+-- one syscall per t'UUID'.+--+-- The \"NOINLINE\" pragma is IMPORTANT! The logic would be flawed if it is+-- is inlined by its definition. A @fork()@'ed child inherits this buffer.+__entropy__ :: IORef [Word8]+__entropy__ = unsafePerformIO (newIORef [])+{-# NOINLINE __entropy__ #-}++-- | The maximum size of a single OS entropy request. macOS caps+-- @getentropy()@ at 256 bytes.+maxEntropyRequestSize :: Int+maxEntropyRequestSize = 256+{-# INLINE maxEntropyRequestSize #-}++-- | Draw @n@ bytes of entropy from the shared buffer, refilling it from the+-- OS in chunks of 'maxEntropyRequestSize' when exhausted.+getEntropyBytes :: Int -> IO [Word8]+getEntropyBytes n = do+ taken <- atomicModifyIORef' __entropy__ \buffer ->+ if length buffer >= n+ then (drop n buffer, Just (take n buffer))+ else (buffer, Nothing)+ case taken of+ Just bytes -> pure bytes+ Nothing -> do+ chunk <- BS.unpack <$> getEntropy (max n maxEntropyRequestSize)+ atomicModifyIORef' __entropy__ \buffer ->+ let newBuffer = buffer ++ chunk+ in (drop n newBuffer, take n newBuffer)+ getEntropyWord16 :: MonadIO m => m Word16 getEntropyWord16 = liftIO do- bs <- BSL.fromStrict <$> getEntropy 2+ bs <- BSL.fromStrict . BS.pack <$> getEntropyBytes 2 pure $ runGet getWord16host bs {-# INLINE getEntropyWord16 #-} getEntropyWord64 :: MonadIO m => m Word64 getEntropyWord64 = liftIO do- bs <- BSL.fromStrict <$> getEntropy 8+ bs <- BSL.fromStrict . BS.pack <$> getEntropyBytes 8 pure $ runGet getWord64host bs {-# INLINE getEntropyWord64 #-}
src/Data/UUID/Versions.hs view
@@ -1,7 +1,6 @@ -- | -- Module : Data.UUID.Versions -- License : MIT--- Maintainer : mmzk1526@outlook.com -- Portability : GHC -- -- Supported t'UUID' versions for 'Data.TypeID.TypeID''.
test/Spec.hs view
@@ -6,6 +6,7 @@ {-# OPTIONS_GHC -Wno-x-partial #-} #endif +import Control.Exception import Control.Monad import Data.Aeson import Data.Binary (get, put)@@ -17,6 +18,7 @@ import Data.KindID.V5 (KindIDV5) import Data.KindID import Data.KindID.Class+import Data.List (find, isInfixOf) import Data.Map (Map) import qualified Data.Map as M import Data.String@@ -24,6 +26,7 @@ import qualified Data.Text as T import Data.Text.Encoding import Data.TypeID+import qualified Data.TypeID as TID import Data.TypeID.Unsafe import Data.TypeID.V1 (TypeIDV1) import Data.TypeID.V4 (TypeIDV4)@@ -87,10 +90,12 @@ runStmt $ "foo :: ValidPrefix " <> show str <> " => () <- return ()" eval "foo" case result of- Left (WontCompile [e]) -> head (lines (errMsg e)) `shouldBe` expectedErr- Left (WontCompile _) -> fail "Unexpected number of type errors!"- Left _ -> fail "Impossible: cannot interpret!"- Right _ -> fail "Unexpected success!"+ Left (WontCompile es) -> case find (isInfixOf expectedErr . errMsg) es of+ Just _ -> pure ()+ Nothing -> expectationFailure $ "Expected error containing "+ ++ show expectedErr ++ " but got: " ++ unlines (map errMsg es)+ Left _ -> fail "Impossible: cannot interpret!"+ Right _ -> fail "Unexpected success!" withCheck :: HasCallStack => (IDConv a, IDGen a) => IO a -> IO a withCheck action = do@@ -120,7 +125,7 @@ v5Test typeLevelTest :: Spec-typeLevelTest = describe "Reject malformed KindID previx at compile time" do+typeLevelTest = describe "Reject malformed KindID prefix at compile time" do it "rejects invalid alphabet" do prefixHasExpectedError "sZb" "The prefix \"sZb\" contains invalid character 'Z'!" it "rejects single underscore" do@@ -367,6 +372,32 @@ kid'' `shouldBe` kid' free ptr + describe "Unsafe parsing" do+ let underscoredPrefixes = ["super_user", "user_post", "a_b_c"]+ it "unsafeParseString roundtrips with the safe parsers on underscored prefixes" do+ forM_ underscoredPrefixes \pref -> do+ tid <- withCheck $ genID @TypeID pref+ let str = TID.toString tid+ unsafeParseString str `shouldBe` tid+ Right tid `shouldBe` string2ID str+ it "unsafeParseText roundtrips with the safe parsers on underscored prefixes" do+ forM_ underscoredPrefixes \pref -> do+ tid <- withCheck $ genID @TypeID pref+ let str = T.pack $ TID.toString tid+ unsafeParseText str `shouldBe` tid+ Right tid `shouldBe` text2ID str+ it "unsafeParseByteString roundtrips with the safe parsers on underscored prefixes" do+ forM_ underscoredPrefixes \pref -> do+ tid <- withCheck $ genID @TypeID pref+ let bs = BSL.fromStrict . encodeUtf8 . T.pack $ TID.toString tid+ unsafeParseByteString bs `shouldBe` tid+ Right tid `shouldBe` byteString2ID bs+ it "unsafe parsers crash on too-short suffix" do+ -- 'show' forces deep evaluation of the lazy UUID fields+ evaluate (show (unsafeParseString "no" :: TypeID)) `shouldThrow` anyException+ evaluate (show (unsafeParseText "no" :: TypeID)) `shouldThrow` anyException+ evaluate (show (unsafeParseByteString "no" :: TypeID)) `shouldThrow` anyException+ v7WithTimeTest :: Spec v7WithTimeTest = do let testTimestamp = 1234567890123 :: Word64@@ -467,7 +498,7 @@ tid <- withCheck $ genID @TypeIDV1 "" getPrefix tid `shouldBe` "" validateWithVersion (getUUID tid) V1 `shouldBe` True- it "can generate TypeIDV1 with insecure UUIDv4" do+ it "can generate TypeIDV1 with stateless UUIDv7 generator" do tid <- withCheck $ genID' @TypeIDV1 "mmzk" getPrefix tid `shouldBe` "mmzk" validateWithVersion (getUUID tid) V1 `shouldBe` True@@ -476,11 +507,11 @@ Left err -> expectationFailure $ "Parse error: " ++ show err Right tid -> getPrefix tid `shouldBe` "mmzk" it "can parse TypeIDV1 from Text" do- case text2ID @TypeID "mmzk_00041061050r3gg28a1c60t3gf" of+ case text2ID @TypeIDV1 "mmzk_00041061050r3gg28a1c60t3gf" of Left err -> expectationFailure $ "Parse error: " ++ show err Right tid -> getPrefix tid `shouldBe` "mmzk" it "can parse TypeIDV1 from ByteString" do- case byteString2ID @TypeID "mmzk_00041061050r3gg28a1c60t3gf" of+ case byteString2ID @TypeIDV1 "mmzk_00041061050r3gg28a1c60t3gf" of Left err -> expectationFailure $ "Parse error: " ++ show err Right tid -> getPrefix tid `shouldBe` "mmzk" @@ -669,11 +700,11 @@ Left err -> expectationFailure $ "Parse error: " ++ show err Right tid -> getPrefix tid `shouldBe` "mmzk" it "can parse TypeIDV4 from Text" do- case text2ID @TypeID "mmzk_00041061050r3gg28a1c60t3gf" of+ case text2ID @TypeIDV4 "mmzk_00041061050r3gg28a1c60t3gf" of Left err -> expectationFailure $ "Parse error: " ++ show err Right tid -> getPrefix tid `shouldBe` "mmzk" it "can parse TypeIDV4 from ByteString" do- case byteString2ID @TypeID "mmzk_00041061050r3gg28a1c60t3gf" of+ case byteString2ID @TypeIDV4 "mmzk_00041061050r3gg28a1c60t3gf" of Left err -> expectationFailure $ "Parse error: " ++ show err Right tid -> getPrefix tid `shouldBe` "mmzk"