diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -1,9 +1,23 @@ # Revision history for mmzk-typeid +## 0.6.3.0 -- 2024-06-01 + +* Update implementation so that the prefix for `KindID` now conforms with specification v0.3.0. + +* More useful compile-time errors for invalid `KindID` prefixes. + +* `TypeIDError` now includes the contextual prefix when necessary to produce better error messages. + +* More tests. + +* Fix known documentation typos. + + ## 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. @@ -11,7 +25,9 @@ * Fix typo in the maintainer's email address. * Astounded at the fact that I mismatched the local part and domain name and didn't realise it for a year. + * More test cases on parsing. + * Fix other typos and inconsistencies in the documentation. @@ -21,6 +37,7 @@ * 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. @@ -136,6 +153,8 @@ * Remove dependency on 'transformers'. * Fix typos in the documentation. + +* Update README examples. * More tests. diff --git a/README.md b/README.md --- a/README.md +++ b/README.md @@ -21,7 +21,7 @@ In addition to the features provided by [TypeID](https://github.com/jetpack-io/typeid), this implementation also supports: 1. Generating TypeIDs in a batch. They are guaranteed to have the same timestamp (up to the first 32768 ids) and of ascending order; -2. Encoding the prefix in the [type level](https://hackage.haskell.org/package/mmzk-typeid/docs/Data-KindID.html), so that if you accidentally pass in a wrong prefix, the code won't compile, avoiding the need for runtime checks; +2. Encoding the prefix in the [type level](https://hackage.haskell.org/package/mmzk-typeid/docs/Data-KindID.html), so that if you accidentally pass in an invalid prefix, the code won't compile, avoiding the need for runtime checks; 3. Support TypeID with other UUID versions. Currently v7 (default), v1, v4, and v5 are supported. ## Quick start @@ -157,6 +157,7 @@ main :: IO () main = do + -- Make a TypeID with prefix 'mmzk': typeID <- genID @TypeID "mmzk" print typeID @@ -174,6 +175,11 @@ case string2ID "mmzk_01h455vb4pex5vsknk084sn02q" :: Maybe (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 + Left err -> throwIO err -- Will throw here as the prefix matches not + Right kindID -> print kindID ``` We no longer need to use qualified imports, but on the down side, we need to add explicit type annotations. Therefore it is a matter of preference. @@ -214,13 +220,13 @@ main :: IO () main = do -- ... - userID <- genKindID @'User -- Same as genKindID @"user" - postID <- genKindID @'Post -- Same as genKindID @"post" + userID <- genKindID @'User -- Same as genKindID @"user" + postID <- genKindID @'Post -- Same as genKindID @"post" commentID <- genKindID @'Comment -- Same as genKindID @"comment" -- ... ``` -For more information, see [Data.KindID.Class]([src/Data/KindID/Class.hs](https://hackage.haskell.org/package/mmzk-typeid/docs/Data-KindID-Class.html)). +For more information, see [Data.KindID.Class](https://hackage.haskell.org/package/mmzk-typeid/docs/Data-KindID-Class.html). ## Note 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.6.2.0 +version: 0.6.3.0 synopsis: A TypeID and UUIDv7 implementation for Haskell description: diff --git a/src/Data/KindID/Class.hs b/src/Data/KindID/Class.hs --- a/src/Data/KindID/Class.hs +++ b/src/Data/KindID/Class.hs @@ -15,45 +15,26 @@ ValidPrefix , ToPrefix(..) -- * Helpers + , LengthLT64C + , IsLUSymbolC , LengthSymbol - , IsLowerSymbol , IsLowerChar + , IsUnderscore + , IsLUSymbol + , ILUSUH1 + , ILUSUH2 + -- * Deprecated Helpers + , IsLowerSymbol , LSUH , ILSUH ) where +import Data.Kind import Data.Type.Bool import Data.Type.Equality import Data.Type.Ord import GHC.TypeLits --- | A constraint for valid prefix 'Symbol's. -type ValidPrefix prefix = ( KnownSymbol prefix - , LengthSymbol prefix < 64 - , IsLowerSymbol prefix ~ 'True ) - --- | The length of a 'Symbol' as a 'Nat'. -type family LengthSymbol (prefix :: Symbol) :: Nat where - LengthSymbol prefix = LSUH (UnconsSymbol prefix) - --- | Length Symbol Uncons Helper. -type family LSUH (uncons :: Maybe (Char, Symbol)) :: Nat where - LSUH 'Nothing = 0 - LSUH ('Just '(c, s)) = 1 + LengthSymbol s - --- | Is a type-level 'Char' lower case? -type family IsLowerChar (ch :: Char) :: Bool where - IsLowerChar ch = Compare '`' ch == 'LT && Compare ch '{' == 'LT - --- | Is a 'Symbol' lower case? -type family IsLowerSymbol (prefix :: Symbol) :: Bool where - IsLowerSymbol prefix = ILSUH (UnconsSymbol prefix) - --- | Is Lower Symbol Uncons Helper. -type family ILSUH (uncons :: Maybe (Char, Symbol)) :: Bool where - ILSUH 'Nothing = 'True - ILSUH ('Just '(c, s)) = IsLowerChar c && IsLowerSymbol s - -- | A class that translates any kind to a 'Symbol'. It is used to translate -- custom data kinds to a 'Symbol' so that they can be used as -- 'Data.KindID.KindID' prefixes. @@ -61,7 +42,7 @@ -- For example, suppose we have the following data structure that represents the -- prefixes we are going to use: -- --- > data Prefix = User | Post | Comment +-- > data Prefix = User | Post | Comment | SuperUser -- -- Then we can make it an instance of 'ToPrefix' like this: -- @@ -73,16 +54,95 @@ -- > -- > instance ToPrefix 'Comment where -- > type PrefixSymbol 'Comment = "comment" +-- > +-- > instance ToPrefix 'SuperUser where +-- > type PrefixSymbol 'SuperUser = "super_user" -- -- Now we can use Prefix as a prefix for 'Data.KindID.KindID's, e.g. -- -- > do --- > userID <- genKindID @'User -- Same as genKindID @"user" --- > postID <- genKindID @'Post -- Same as genKindID @"post" --- > commentID <- genKindID @'Comment -- Same as genKindID @"comment" +-- > userID <- genKindID @'User -- Same as genKindID @"user" +-- > postID <- genKindID @'Post -- Same as genKindID @"post" +-- > commentID <- genKindID @'Comment -- Same as genKindID @"comment" +-- > suID <- genKindID @'SuperUser -- Same as genKindID @"super_user" class ToPrefix a where type PrefixSymbol a :: Symbol -- | The 'PrefixSymbol' of a 'Symbol' is the 'Symbol' itself. -instance ToPrefix (a :: Symbol) where - type PrefixSymbol a = a +instance ToPrefix (s :: Symbol) where + type PrefixSymbol s = s + +-- | A constraint for valid prefix 'Symbol's. +type ValidPrefix prefix = ( KnownSymbol prefix + , LengthLT64C prefix + , IsLUSymbolC prefix ) + +-- | Contains a custom error message if the prefix 'Symbol' is too long. +type family LengthLT64C (prefix :: Symbol) :: Constraint where + LengthLT64C s + = If (Compare (LengthSymbol s) 64 == 'LT) (() :: Constraint) + ( TypeError ( Text "The prefix " + :<>: ShowType s + :<>: Text " with " + :<>: ShowType (LengthSymbol s) + :<>: Text " characters is too long!" ) ) + +-- | Contains a custom error message if the prefix 'Symbol' is not lowercase + +-- underscore or it starts or ends with underscores. +type family IsLUSymbolC (prefix :: Symbol) :: Constraint where + IsLUSymbolC s + = If (IsLUSymbol s) (() :: Constraint) + ( TypeError ( Text "The prefix " + :<>: ShowType s + :<>: Text " is not valid!" ) ) + +-- | The length of a 'Symbol' as a 'Nat'. +type family LengthSymbol (prefix :: Symbol) :: Nat where + LengthSymbol prefix = LSUH (UnconsSymbol prefix) + +-- | LengthSymbol Uncons Helper. +type family LSUH (uncons :: Maybe (Char, Symbol)) :: Nat where + LSUH 'Nothing = 0 + LSUH ('Just '( c, s )) = 1 + LengthSymbol s + +-- | Is a type-level 'Char' lowercase? +type family IsLowerChar (ch :: Char) :: Bool where + IsLowerChar ch = Compare '`' ch == 'LT && Compare ch '{' == 'LT + +-- | Is a type-level 'Char' an underscore? +type family IsUnderscore (ch :: Char) :: Bool where + IsUnderscore ch = Compare '_' ch == 'EQ + +-- | Is a 'Symbol' lowercase + underscore and not start or end with underscores? +type family IsLUSymbol (prefix :: Symbol) :: Bool where + IsLUSymbol prefix = ILUSUH1 (UnconsSymbol prefix) + +-- | First IsLUSymbol Uncons Helper. +type family ILUSUH1 (uncons :: Maybe (Char, Symbol)) :: Bool where + ILUSUH1 'Nothing = True + ILUSUH1 ('Just '( '_', _ )) = False + ILUSUH1 ('Just '( c, s )) = (IsLowerChar c || IsUnderscore c) + && ILUSUH2 (UnconsSymbol s) + +-- | Second IsLUSymbol Uncons Helper. +type family ILUSUH2 (uncons :: Maybe (Char, Symbol)) :: Bool where + ILUSUH2 'Nothing = True + ILUSUH2 ('Just '( c, "" )) = IsLowerChar c + ILUSUH2 ('Just '( c, s )) = (IsLowerChar c || IsUnderscore c) + && ILUSUH2 (UnconsSymbol s) + + +-------------------------------------------------------------------------------- +-- Deprecated +-------------------------------------------------------------------------------- + +-- | Is a 'Symbol' lowercase? +type family IsLowerSymbol (prefix :: Symbol) :: Bool where + IsLowerSymbol prefix = ILSUH (UnconsSymbol prefix) +{-# DEPRECATED IsLowerSymbol "No longer used; to be removed in version 0.7" #-} + +-- | Is LowerSymbol Uncons Helper. +type family ILSUH (uncons :: Maybe (Char, Symbol)) :: Bool where + ILSUH 'Nothing = 'True + ILSUH ('Just '( c, s )) = IsLowerChar c && IsLowerSymbol s +{-# DEPRECATED ILSUH "No longer used; to be removed in the version 0.7" #-} 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 @@ -14,20 +14,24 @@ import Control.Exception import Data.Text (Text) +import qualified Data.Text as T -- | Errors from parsing TypeIDs. +-- +-- Should NOT rely on \"grepping\" the output produced by 'show' since the +-- exact output format may differ across library versions. data TypeIDError - = -- | The prefix longer than 63 characters. - TypeIDErrorPrefixTooLong Int + = -- | The prefix is longer than 63 characters. + TypeIDErrorPrefixTooLong Text -- | The ID contains an extra underscore separator. | TypeIDExtraSeparator -- | The ID starts with an underscore separator. - | TypeIDStartWithUnderscore + | TypeIDStartWithUnderscore Text -- | The ID ends with an underscore separator. - | TypeIDEndWithUnderscore + | TypeIDEndWithUnderscore Text -- | The prefix contains an invalid character, namely not lowercase Latin. - | TypeIDErrorPrefixInvalidChar Char - -- | From a `Data.KindID.KindID` conversion. The prefix doesn't match with + | TypeIDErrorPrefixInvalidChar Text Char + -- | From a 'Data.KindID.V7KindID' conversion. The prefix doesn't match with -- the expected. | TypeIDErrorPrefixMismatch Text Text -- | The 'Data.UUID.Types.Internal.UUID' suffix has errors. @@ -36,16 +40,18 @@ instance Show TypeIDError where show :: TypeIDError -> String - show (TypeIDErrorPrefixTooLong n) - = concat ["Prefix with ", show n, " characters is too long!"] + show (TypeIDErrorPrefixTooLong txt) + = concat [ "The prefix ", show txt + , " with ", show (T.length txt), " 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 (TypeIDStartWithUnderscore txt) + = concat ["The prefix ", show txt, " should not start with an underscore!"] + show (TypeIDEndWithUnderscore txt) + = concat ["The prefix ", show txt, " should not end with an underscore!"] + show (TypeIDErrorPrefixInvalidChar txt c) + = concat [ "The prefix ", show txt + , " contains invalid character ", show c, "!"] show (TypeIDErrorPrefixMismatch expPrefix actPrefix) = concat [ "Expected prefix ", show expPrefix, " but got " , show 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 @@ -543,16 +543,16 @@ -- | Check if the given prefix is a valid 'TypeID'' prefix. checkPrefix :: Text -> Maybe TypeIDError checkPrefix prefix - | T.length prefix > 63 = Just $ TypeIDErrorPrefixTooLong (T.length prefix) + | T.length prefix > 63 = Just $ TypeIDErrorPrefixTooLong prefix | T.null prefix = Nothing - | T.head prefix == '_' = Just TypeIDStartWithUnderscore - | T.last prefix == '_' = Just TypeIDEndWithUnderscore + | T.head prefix == '_' = Just $ TypeIDStartWithUnderscore prefix + | T.last prefix == '_' = Just $ TypeIDEndWithUnderscore prefix | otherwise = case T.uncons ( T.dropWhile ( liftM2 (||) (== '_') $ liftM2 (&&) isLower isAscii) prefix) of Nothing -> Nothing - Just (c, _) -> Just $ TypeIDErrorPrefixInvalidChar c + Just (c, _) -> Just $ TypeIDErrorPrefixInvalidChar prefix c {-# INLINE checkPrefix #-} -- | Check if the prefix is valid and the suffix 'UUID' has the correct v7 diff --git a/src/Data/UUID/Versions.hs b/src/Data/UUID/Versions.hs --- a/src/Data/UUID/Versions.hs +++ b/src/Data/UUID/Versions.hs @@ -19,8 +19,6 @@ -- | The supported 'UUID' versions. These constructors are used as type-level -- tags for 'Data.TypeID.TypeID''. --- --- 'V5' is not supported yet. data UUIDVersion = V1 | V4 | V5 | V7 deriving (Eq, Ord, Bounded, Enum, Show) diff --git a/test/Spec.hs b/test/Spec.hs --- a/test/Spec.hs +++ b/test/Spec.hs @@ -1,7 +1,10 @@ +{-# LANGUAGE CPP #-} {-# LANGUAGE DuplicateRecordFields #-} {-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-} +#if __GLASGOW_HASKELL__ >= 908 {-# OPTIONS_GHC -Wno-x-partial #-} +#endif import Control.Monad import Data.Aeson @@ -30,6 +33,7 @@ import Data.UUID.V4 (nextRandom) import Data.UUID.V7 (UUID) import qualified Data.UUID.V7 as V7 +import Data.UUID.Versions import Foreign import GHC.Generics (Generic) import Test.Hspec @@ -46,7 +50,7 @@ , uuid :: UUID } deriving (Generic, FromJSON, ToJSON) -data Prefix = User | Post | Comment +data Prefix = User | Post | SuperUser instance ToPrefix 'User where type PrefixSymbol 'User = "user" @@ -54,8 +58,8 @@ instance ToPrefix 'Post where type PrefixSymbol 'Post = "post" -instance ToPrefix 'Comment where - type PrefixSymbol 'Comment = "comment" +instance ToPrefix 'SuperUser where + type PrefixSymbol 'SuperUser = "super_user" anyTypeIDError :: Selector TypeIDError anyTypeIDError = const True @@ -95,16 +99,19 @@ start <- V7.getEpochMilli tid <- withCheck $ genID @TypeID "mmzk" getPrefix tid `shouldBe` "mmzk" + validateWithVersion (getUUID tid) V7 `shouldBe` True getTime tid `shouldSatisfy` \t -> t >= start it "can generate TypeID without prefix" do start <- V7.getEpochMilli tid <- withCheck $ genID @TypeID "" getPrefix tid `shouldBe` "" + validateWithVersion (getUUID tid) V7 `shouldBe` True getTime tid `shouldSatisfy` \t -> t >= start it "can generate TypeID with stateless UUIDv7" do start <- V7.getEpochMilli tid <- withCheck $ genID' @TypeID "mmzk" getPrefix tid `shouldBe` "mmzk" + validateWithVersion (getUUID tid) V7 `shouldBe` True getTime tid `shouldSatisfy` \t -> t >= start it "can generate in batch with same timestamp and in ascending order" do start <- V7.getEpochMilli @@ -112,6 +119,7 @@ all ((== "mmzk") . getPrefix) tids `shouldBe` True let timestamp = getTime $ head tids all ((== timestamp) . getTime) tids `shouldBe` True + all (\tid -> validateWithVersion (getUUID tid) V7) tids `shouldBe` True all (uncurry (<)) (zip tids $ tail tids) `shouldBe` True timestamp `shouldSatisfy` \t -> t >= start it "can parse TypeID from String" do @@ -228,16 +236,19 @@ start <- V7.getEpochMilli kid <- withCheck $ genID @(KindID "mmzk") getPrefix kid `shouldBe` "mmzk" + validateWithVersion (getUUID kid) V7 `shouldBe` True getTime kid `shouldSatisfy` \t -> start <= t it "can generate KindID without prefix" do start <- V7.getEpochMilli kid <- withCheck $ genID @(KindID "") getPrefix kid `shouldBe` "" + validateWithVersion (getUUID kid) V7 `shouldBe` True getTime kid `shouldSatisfy` \t -> start <= t it "can generate KindID with stateless UUIDv7" do start <- V7.getEpochMilli kid <- withCheck $ genID' @(KindID "mmzk") getPrefix kid `shouldBe` "mmzk" + validateWithVersion (getUUID kid) V7 `shouldBe` True getTime kid `shouldSatisfy` \t -> start <= t it "can generate in batch with same timestamp and in ascending order" do start <- V7.getEpochMilli @@ -245,6 +256,7 @@ all ((== "mmzk") . getPrefix) kids `shouldBe` True let timestamp = getTime $ head kids all ((== timestamp) . getTime) kids `shouldBe` True + all (\kid -> validateWithVersion (getUUID kid) V7) kids `shouldBe` True all (uncurry (<)) (zip kids $ tail kids) `shouldBe` True timestamp `shouldSatisfy` \t -> start <= t it "can parse KindID from String" do @@ -261,16 +273,16 @@ kid <- withCheck $ genID @(KindID 'Post) getPrefix kid `shouldBe` "post" it "can parse KindID from String" do - case string2ID @(KindID 'User) "user_00041061050r3gg28a1c60t3gf" of + case string2ID @(KindID 'SuperUser) "super_user_00041061050r3gg28a1c60t3gf" of Left err -> expectationFailure $ "Parse error: " ++ show err - Right kid -> getPrefix kid `shouldBe` "user" + Right kid -> getPrefix kid `shouldBe` "super_user" it "cannot parse KindID into wrong prefix" do - case string2ID @(KindID 'Comment) "user_00041061050r3gg28a1c60t3gf" of + case string2ID @(KindID 'User) "super_user_00041061050r3gg28a1c60t3gf" of 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) 32768 - all ((== "comment") . getPrefix) kids `shouldBe` True + kids <- withChecks $ genIDs @(KindID 'User) 32768 + all ((== "user") . getPrefix) kids `shouldBe` True let timestamp = getTime $ head kids all ((== timestamp) . getTime) kids `shouldBe` True all (uncurry (<)) (zip kids $ tail kids) `shouldBe` True @@ -323,9 +335,11 @@ it "can generate TypeIDV1 without prefix" do tid <- withCheck $ genID @TypeIDV1 "" getPrefix tid `shouldBe` "" + validateWithVersion (getUUID tid) V1 `shouldBe` True it "can generate TypeIDV1 with insecure UUIDv4" do tid <- withCheck $ genID' @TypeIDV1 "mmzk" getPrefix tid `shouldBe` "mmzk" + validateWithVersion (getUUID tid) V1 `shouldBe` True it "can parse TypeIDV1 from String" do case string2ID @TypeIDV1 "mmzk_5hjpeh96458fct8t49fnf9farw" of Left err -> expectationFailure $ "Parse error: " ++ show err @@ -439,9 +453,11 @@ it "can generate KindIDV1 with prefix" do kid <- withCheck $ genID @(KindIDV1 "mmzk") getPrefix kid `shouldBe` "mmzk" + validateWithVersion (getUUID kid) V1 `shouldBe` True it "can generate KindIDV1 without prefix" do kid <- withCheck $ genID @(KindIDV1 "") getPrefix kid `shouldBe` "" + validateWithVersion (getUUID kid) V1 `shouldBe` True it "can parse KindID from String" do case string2ID @(KindIDV1 "mmzk") "mmzk_5hjpeh96458fct8t49fnf9farw" of Left err -> expectationFailure $ "Parse error: " ++ show err @@ -456,11 +472,11 @@ kid <- withCheck $ genID @(KindID 'Post) getPrefix kid `shouldBe` "post" it "can parse KindIDV1 from String" do - case string2ID @(KindIDV1 'User) "user_00041061050r3gg28a1c60t3gf" of + case string2ID @(KindIDV1 'SuperUser) "super_user_00041061050r3gg28a1c60t3gf" of Left err -> expectationFailure $ "Parse error: " ++ show err - Right kid -> getPrefix kid `shouldBe` "user" + Right kid -> getPrefix kid `shouldBe` "super_user" it "cannot parse KindIDV1 into wrong prefix" do - case string2ID @(KindIDV1 'Comment) "user_00041061050r3gg28a1c60t3gf" of + case string2ID @(KindIDV1 'User) "post_00041061050r3gg28a1c60t3gf" of Left _ -> pure () Right kid -> expectationFailure $ "Parsed KindIDV1: " ++ show kid @@ -509,9 +525,11 @@ it "can generate TypeIDV4 with prefix" do tid <- withCheck $ genID @TypeIDV4 "mmzk" getPrefix tid `shouldBe` "mmzk" + validateWithVersion (getUUID tid) V4 `shouldBe` True it "can generate TypeIDV4 without prefix" do tid <- withCheck $ genID @TypeIDV4 "" getPrefix tid `shouldBe` "" + validateWithVersion (getUUID tid) V4 `shouldBe` True it "can generate TypeIDV4 with insecure UUIDv4" do tid <- withCheck $ genID' @TypeIDV4 "mmzk" getPrefix tid `shouldBe` "mmzk" @@ -628,9 +646,11 @@ it "can generate KindIDV4 with prefix" do kid <- withCheck $ genID @(KindIDV4 "mmzk") getPrefix kid `shouldBe` "mmzk" + validateWithVersion (getUUID kid) V4 `shouldBe` True it "can generate KindIDV4 without prefix" do kid <- withCheck $ genID @(KindIDV4 "") getPrefix kid `shouldBe` "" + validateWithVersion (getUUID kid) V4 `shouldBe` True it "can generate KindIDV4 with insecure UUIDv4" do kid <- withCheck $ genID' @(KindIDV4 "mmzk") getPrefix kid `shouldBe` "mmzk" @@ -648,11 +668,11 @@ kid <- withCheck $ genID @(KindID 'Post) getPrefix kid `shouldBe` "post" it "can parse KindIDV4 from String" do - case string2ID @(KindIDV4 'User) "user_00041061050r3gg28a1c60t3gf" of + case string2ID @(KindIDV4 'SuperUser) "super_user_00041061050r3gg28a1c60t3gf" of Left err -> expectationFailure $ "Parse error: " ++ show err - Right kid -> getPrefix kid `shouldBe` "user" + Right kid -> getPrefix kid `shouldBe` "super_user" it "cannot parse KindIDV4 into wrong prefix" do - case string2ID @(KindIDV4 'Comment) "user_00041061050r3gg28a1c60t3gf" of + case string2ID @(KindIDV4 'User) "post_00041061050r3gg28a1c60t3gf" of Left _ -> pure () Right kid -> expectationFailure $ "Parsed KindIDV4: " ++ show kid @@ -703,19 +723,21 @@ it "can generate TypeIDV5 with prefix" do tid <- withCheck $ genID @TypeIDV5 "mmzk" uid [11, 45, 14] getPrefix tid `shouldBe` "mmzk" + validateWithVersion (getUUID tid) V5 `shouldBe` True it "can generate TypeIDV5 without prefix" do tid <- withCheck $ genID @TypeIDV5 "" uid [11, 45, 14] getPrefix tid `shouldBe` "" + validateWithVersion (getUUID tid) V5 `shouldBe` True it "can parse TypeIDV5 from String" do case string2ID @TypeIDV5 "mmzk_5hjpeh96458fct8t49fnf9farw" of Left err -> expectationFailure $ "Parse error: " ++ show err Right tid -> getPrefix tid `shouldBe` "mmzk" it "can parse TypeIDV5 from Text" do - case text2ID @TypeID "mmzk_00041061050r3gg28a1c60t3gf" of + case text2ID @TypeIDV5 "mmzk_00041061050r3gg28a1c60t3gf" of Left err -> expectationFailure $ "Parse error: " ++ show err Right tid -> getPrefix tid `shouldBe` "mmzk" it "can parse TypeIDV5 from ByteString" do - case byteString2ID @TypeID "mmzk_00041061050r3gg28a1c60t3gf" of + case byteString2ID @TypeIDV5 "mmzk_00041061050r3gg28a1c60t3gf" of Left err -> expectationFailure $ "Parse error: " ++ show err Right tid -> getPrefix tid `shouldBe` "mmzk" @@ -822,9 +844,11 @@ it "can generate KindIDV5 with prefix" do kid <- withCheck $ genID @(KindIDV5 "mmzk") uid [11, 45, 14] getPrefix kid `shouldBe` "mmzk" + validateWithVersion (getUUID kid) V5 `shouldBe` True it "can generate KindIDV5 without prefix" do kid <- withCheck $ genID @(KindIDV5 "") uid [11, 45, 14] getPrefix kid `shouldBe` "" + validateWithVersion (getUUID kid) V5 `shouldBe` True it "can parse KindID from String" do case string2ID @(KindIDV5 "mmzk") "mmzk_5hjpeh96458fct8t49fnf9farw" of Left err -> expectationFailure $ "Parse error: " ++ show err @@ -839,11 +863,11 @@ kid <- withCheck $ genID @(KindID 'Post) getPrefix kid `shouldBe` "post" it "can parse KindIDV5 from String" do - case string2ID @(KindIDV5 'User) "user_00041061050r3gg28a1c60t3gf" of + case string2ID @(KindIDV5 'SuperUser) "super_user_00041061050r3gg28a1c60t3gf" of Left err -> expectationFailure $ "Parse error: " ++ show err - Right kid -> getPrefix kid `shouldBe` "user" + Right kid -> getPrefix kid `shouldBe` "super_user" it "cannot parse KindIDV5 into wrong prefix" do - case string2ID @(KindIDV5 'Comment) "user_00041061050r3gg28a1c60t3gf" of + case string2ID @(KindIDV5 'User) "post_00041061050r3gg28a1c60t3gf" of Left _ -> pure () Right kid -> expectationFailure $ "Parsed KindIDV5: " ++ show kid