mmzk-typeid 0.5.0.2 → 0.6.0.0
raw patch · 8 files changed
+96/−34 lines, 8 files
Files
- CHANGELOG.md +9/−0
- README.md +3/−3
- mmzk-typeid.cabal +2/−2
- src/Data/TypeID/Error.hs +8/−0
- src/Data/TypeID/Internal.hs +44/−24
- test/Spec.hs +14/−0
- test/invalid.json +10/−5
- test/valid.json +6/−0
CHANGELOG.md view
@@ -1,6 +1,15 @@ # Revision history for mmzk-typeid +## 0.6.0.0 -- Unreleased++* Update implementation to conform with specification v0.3.0.+ * Allow `TypeID` prefix to contain underscores.+ * Update parsing logic as well as `Binary` and `Storable` instances to reflect the changes.+ * Add tests.+* Have a breaking change in `TypeIDError` to better reflect the error cases for the update in the specification.++ ## 0.5.0.2 -- 2024-3-10 * Add `Typeable` and `Data` instances for `TypeID` and `KindID`.
README.md view
@@ -6,11 +6,11 @@ TypeIDs are canonically encoded as lowercase strings consisting of three parts: -1. A type prefix (at most 63 characters in all lowercase ASCII [a-z]);+1. A type prefix (at most 63 characters in all lowercase snake_case ASCII [a-z_]); 2. An underscore '_' separator; 3. A 128-bit UUIDv7 encoded as a 26-character string using a modified base32 encoding. -For more information, please check out the [specification](https://github.com/jetpack-io/typeid/blob/main/README.md).+For more information, please check out [specification v0.3.0](https://github.com/jetpack-io/typeid/blob/main/README.md). It also serves as a (temporary) UUIDv7 implementation in Haskell, since there are no official ones yet. @@ -222,4 +222,4 @@ For more information, see [Data.KindID.Class]([src/Data/KindID/Class.hs](https://hackage.haskell.org/package/mmzk-typeid/docs/Data-KindID-Class.html)). ## Note-Not explicitly exported functions are considered internal and are subjected to changes.+Functions not explicitly exported are considered internal and are subjected to changes.
mmzk-typeid.cabal view
@@ -1,6 +1,6 @@ cabal-version: 2.4 name: mmzk-typeid-version: 0.5.0.2+version: 0.6.0.0 synopsis: A TypeID implementation for Haskell description:@@ -98,7 +98,7 @@ aeson >=2.1 && <3, array ^>=0.5, binary >=0.8.5 && <0.9,- bytestring ^>= 0.11,+ bytestring ^>=0.11, entropy ^>=0.4, hashable ^>=1.4, random ^>=1.2,
src/Data/TypeID/Error.hs view
@@ -21,6 +21,10 @@ TypeIDErrorPrefixTooLong Int -- | The ID contains an extra underscore separator. | TypeIDExtraSeparator+ -- | The ID starts with an underscore separator.+ | TypeIDStartWithUnderscore+ -- | The ID ends with an underscore separator.+ | TypeIDEndWithUnderscore -- | The prefix contains an invalid character, namely not lowercase Latin. | TypeIDErrorPrefixInvalidChar Char -- | From a `Data.KindID.KindID` conversion. The prefix doesn't match with@@ -36,6 +40,10 @@ = concat ["Prefix with ", show n, " characters is too long!"] show TypeIDExtraSeparator = "The underscore separator should not be present if the prefix is empty!"+ show TypeIDStartWithUnderscore+ = "The prefix should not start with an underscore!"+ show TypeIDEndWithUnderscore+ = "The prefix should not end with an underscore!" show (TypeIDErrorPrefixInvalidChar c) = concat ["Prefix contains invalid character ", show c, "!"] show (TypeIDErrorPrefixMismatch expPrefix actPrefix)
src/Data/TypeID/Internal.hs view
@@ -1,4 +1,3 @@-{-# LANGUAGE UndecidableInstances #-} -- | -- Module : Data.TypeID.Internal -- License : MIT@@ -25,6 +24,7 @@ import qualified Data.ByteString.Lazy as BSL import Data.Char import Data.Data (Data)+import Data.Functor.Identity import Data.Hashable import Data.Proxy import Data.String@@ -42,6 +42,7 @@ import Data.UUID.Versions import System.Random import Foreign+import Data.Tuple -- | This data type also supports 'Data.TypeID.V7.TypeID's with 'UUID' versions -- other than v7.@@ -95,7 +96,7 @@ -- * 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 next bytes are the prefix, each letter taking 5 bits, mapping \'a\' to--- 1 and \'z\' to 26.+-- 1 and \'z\' to 26. The underscore \'_\' is mapped to 27. -- -- Note that the prefix and the 'UUID' is swapped compared to the string -- representation, this is for the convenience of the use case where only the@@ -106,7 +107,9 @@ put :: TypeID' version -> Put put (TypeID' prefix uuid) = do put uuid- let encodedPrefix = concat5BitInts . fmap (subtract 96) . BS.unpack+ let fore 95 = 27+ fore a = a - 96+ let encodedPrefix = concat5BitInts . fmap fore . BS.unpack $ encodeUtf8 prefix putWord8 . fromIntegral $ length encodedPrefix forM_ encodedPrefix putWord8@@ -117,10 +120,12 @@ uuid <- get len <- getWord8 encodedPrefix <- separate5BitInts <$> replicateM (fromIntegral len) getWord8- when (length encodedPrefix > 63) $ fail "Binary: Prefix too long"- when (any (liftM2 (&&) (< 1) (> 25)) encodedPrefix)- (fail "Binary: Invalid prefix")- pure $ TypeID' (decodeUtf8 . BS.pack $ fmap (+ 96) encodedPrefix) uuid+ when (length encodedPrefix > 63) do fail "Binary: Prefix too long"+ when (any (liftM2 (&&) (< 1) (> 26)) encodedPrefix) do+ fail "Binary: Invalid prefix"+ let back 27 = 95+ back a = a + 96+ pure $ TypeID' (decodeUtf8 . BS.pack $ fmap back encodedPrefix) uuid {-# INLINE get #-} -- | Similar to the 'Binary' instance, but the 'UUID' is stored in host endian.@@ -140,15 +145,19 @@ encodedPrefix <- separate5BitInts <$> forM [1..len] \ix -> peekByteOff @Word8 ptr (16 + ix) when (length encodedPrefix > 63) $ fail "Storable: Prefix too long"- when (any (liftM2 (&&) (< 1) (> 25)) encodedPrefix)- (fail "Storable: Invalid prefix")- pure $ TypeID' (decodeUtf8 . BS.pack $ fmap (+ 96) encodedPrefix) uuid+ when (any (liftM2 (&&) (< 1) (> 26)) encodedPrefix) do+ fail "Storable: Invalid prefix"+ let back 27 = 95+ back a = a + 96+ pure $ TypeID' (decodeUtf8 . BS.pack $ fmap back encodedPrefix) uuid {-# INLINE peek #-} poke :: Ptr (TypeID' version) -> TypeID' version -> IO () poke ptr (TypeID' prefix uuid) = do poke (castPtr ptr) uuid- let encodedPrefix = concat5BitInts . fmap (subtract 96) . BS.unpack+ 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@@ -471,14 +480,14 @@ {-# INLINE parseString #-} parseStringS :: String -> Either TypeIDError (TypeID' version, String)-parseStringS str = case span (/= '_') str of- ("", _) -> Left TypeIDExtraSeparator- (_, "") -> do+parseStringS str = case spanEnd (/= '_') str of+ (_, "") -> do let (uuid, nks) = splitAt 26 str bs = fromString uuid (, nks) . TypeID' "" <$> decodeUUID bs- (prefix, _ : suffix) -> do- let prefix' = T.pack prefix+ (_, "_") -> Left TypeIDExtraSeparator+ (suffix, prefix) -> do+ let prefix' = T.pack $ init prefix (uuid, nks) = splitAt 26 suffix bs = fromString uuid case checkPrefix prefix' of@@ -488,11 +497,12 @@ -- | Parse a 'TypeID'' from its string representation as a strict 'Text'. It is -- 'text2ID' with concrete type. parseText :: Text -> Either TypeIDError (TypeID' version)-parseText text = case second T.uncons $ T.span (/= '_') text of- ("", _) -> Left TypeIDExtraSeparator+parseText text = case second T.unsnoc . swap . runIdentity+ $ T.spanEndM (pure . (/= '_')) text of (_, Nothing) -> TypeID' "" <$> decodeUUID (BSL.fromStrict $ encodeUtf8 text)- (prefix, Just (_, suffix)) -> do+ (_, Just ("", _)) -> Left TypeIDExtraSeparator+ (suffix, Just (prefix, _)) -> do case checkPrefix prefix of Nothing -> TypeID' prefix <$> decodeUUID (BSL.fromStrict $ encodeUtf8 suffix)@@ -501,10 +511,10 @@ -- | Parse a 'TypeID'' from its string representation as a lazy 'ByteString'. It -- is 'byteString2ID' with concrete type. parseByteString :: ByteString -> Either TypeIDError (TypeID' version)-parseByteString bs = case second BSL.uncons $ BSL.span (/= 95) bs of- ("", _) -> Left TypeIDExtraSeparator+parseByteString bs = case second BSL.unsnoc . swap $ BSL.spanEnd (/= 95) bs of+ (_, Just ("", _)) -> Left TypeIDExtraSeparator (_, Nothing) -> TypeID' "" <$> decodeUUID bs- (prefix, Just (_, suffix)) -> do+ (suffix, Just (prefix, _)) -> do let prefix' = decodeUtf8 $ BSL.toStrict prefix case checkPrefix prefix' of Nothing -> TypeID' prefix' <$> decodeUUID suffix@@ -534,8 +544,13 @@ checkPrefix :: Text -> Maybe TypeIDError checkPrefix prefix | T.length prefix > 63 = Just $ TypeIDErrorPrefixTooLong (T.length prefix)+ | T.null prefix = Nothing+ | T.head prefix == '_' = Just TypeIDStartWithUnderscore+ | T.last prefix == '_' = Just TypeIDEndWithUnderscore | otherwise- = case T.uncons (T.dropWhile (liftM2 (&&) isLower isAscii) prefix) of+ = case T.uncons ( T.dropWhile ( liftM2 (||) (== '_')+ $ liftM2 (&&) isLower isAscii)+ prefix) of Nothing -> Nothing Just (c, _) -> Just $ TypeIDErrorPrefixInvalidChar c {-# INLINE checkPrefix #-}@@ -680,6 +695,10 @@ nextUUID = V1.nextUUID >>= maybe nextUUID pure {-# INLINE nextUUID #-} +spanEnd :: (a -> Bool) -> [a] -> ([a], [a])+spanEnd p = bimap reverse reverse . span p . reverse+{-# INLINE spanEnd #-}+ -- The helpers below are verbatim translations from the official highly magical -- Go implementation. @@ -741,7 +760,8 @@ decodeUUID bs = do unless (BSL.length bs == 26) $ Left TypeIDErrorUUIDError unless (bs `BSL.index` 0 <= 55) $ Left TypeIDErrorUUIDError- when (any ((== 0xFF) . (base32Table !)) $ BSL.unpack bs) $ Left TypeIDErrorUUIDError+ when (any ((== 0xFF) . (base32Table !)) $ BSL.unpack bs) do+ Left TypeIDErrorUUIDError pure $ unsafeDecodeUUID bs {-# INLINE decodeUUID #-}
test/Spec.hs view
@@ -17,6 +17,8 @@ import qualified Data.Map as M import Data.String import Data.Text (Text)+import qualified Data.Text as T+import Data.Text.Encoding import Data.TypeID import Data.TypeID.V1 (TypeIDV1) import Data.TypeID.V4 (TypeIDV4)@@ -169,6 +171,9 @@ Just t -> do getPrefix t `shouldBe` pref show (getUUID t) `shouldBe` uid+ Right t `shouldBe` string2ID tid+ Right t `shouldBe` text2ID (T.pack tid)+ Right t `shouldBe` byteString2ID (BSL.fromStrict . encodeUtf8 $ T.pack tid) describe "Valid JSON key" do forM_ valid \(TestData n tid (Just pref) (Just uid)) -> it n do case decode @(Map TypeID Int) (fromString $ "{" ++ show tid ++ ":" ++ "114514" ++ "}") of@@ -370,6 +375,9 @@ Just t -> do getPrefix t `shouldBe` pref show (getUUID t) `shouldBe` uid+ Right t `shouldBe` string2ID tid+ Right t `shouldBe` text2ID (T.pack tid)+ Right t `shouldBe` byteString2ID (BSL.fromStrict . encodeUtf8 $ T.pack tid) describe "Valid JSON key" do forM_ valid \(TestData n tid (Just pref) (Just uid)) -> it n do case decode @(Map TypeIDV1 Int) (fromString $ "{" ++ show tid ++ ":" ++ "114514" ++ "}") of@@ -548,6 +556,9 @@ Just t -> do getPrefix t `shouldBe` pref show (getUUID t) `shouldBe` uid+ Right t `shouldBe` string2ID tid+ Right t `shouldBe` text2ID (T.pack tid)+ Right t `shouldBe` byteString2ID (BSL.fromStrict . encodeUtf8 $ T.pack tid) describe "Valid JSON key" do forM_ valid \(TestData n tid (Just pref) (Just uid)) -> it n do case decode @(Map TypeIDV4 Int) (fromString $ "{" ++ show tid ++ ":" ++ "114514" ++ "}") of@@ -730,6 +741,9 @@ Just t -> do getPrefix t `shouldBe` pref show (getUUID t) `shouldBe` uid+ Right t `shouldBe` string2ID tid+ Right t `shouldBe` text2ID (T.pack tid)+ Right t `shouldBe` byteString2ID (BSL.fromStrict . encodeUtf8 $ T.pack tid) describe "Valid JSON key" do forM_ valid \(TestData n tid (Just pref) (Just uid)) -> it n do case decode @(Map TypeIDV5 Int) (fromString $ "{" ++ show tid ++ ":" ++ "114514" ++ "}") of
test/invalid.json view
@@ -15,11 +15,6 @@ "description": "The prefix can't have symbols, it needs to be alphabetic" }, {- "name": "prefix-underscore",- "typeid": "pre_fix_00000000000000000000000000",- "description": "The prefix can't have symbols, it needs to be alphabetic"- },- { "name": "prefix-non-ascii", "typeid": "préfix_00000000000000000000000000", "description": "The prefix can only have ascii letters"@@ -88,5 +83,15 @@ "name": "suffix-overflow", "typeid": "prefix_8zzzzzzzzzzzzzzzzzzzzzzzzz", "description": "The suffix should encode at most 128-bits"+ },+ {+ "name": "prefix-underscore-start",+ "typeid": "_prefix_00000000000000000000000000",+ "description": "The prefix can't start with an underscore"+ },+ {+ "name": "prefix-underscore-end",+ "typeid": "prefix__00000000000000000000000000",+ "description": "The prefix can't end with an underscore" } ]
test/valid.json view
@@ -46,5 +46,11 @@ "typeid": "prefix_01h455vb4pex5vsknk084sn02q", "prefix": "prefix", "uuid": "01890a5d-ac96-774b-bcce-b302099a8057"+ },+ {+ "name": "prefix-underscore",+ "typeid": "pre_fix_00000000000000000000000000",+ "prefix": "pre_fix",+ "uuid": "00000000-0000-0000-0000-000000000000" } ]