diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -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`. diff --git a/README.md b/README.md --- a/README.md +++ b/README.md @@ -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. diff --git a/mmzk-typeid.cabal b/mmzk-typeid.cabal --- a/mmzk-typeid.cabal +++ b/mmzk-typeid.cabal @@ -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, diff --git a/src/Data/TypeID/Error.hs b/src/Data/TypeID/Error.hs --- a/src/Data/TypeID/Error.hs +++ b/src/Data/TypeID/Error.hs @@ -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) diff --git a/src/Data/TypeID/Internal.hs b/src/Data/TypeID/Internal.hs --- a/src/Data/TypeID/Internal.hs +++ b/src/Data/TypeID/Internal.hs @@ -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 #-} diff --git a/test/Spec.hs b/test/Spec.hs --- a/test/Spec.hs +++ b/test/Spec.hs @@ -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 diff --git a/test/invalid.json b/test/invalid.json --- a/test/invalid.json +++ b/test/invalid.json @@ -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" } ] diff --git a/test/valid.json b/test/valid.json --- a/test/valid.json +++ b/test/valid.json @@ -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" } ]