mmzk-typeid 0.4.0.0 → 0.4.0.1
raw patch · 13 files changed
+746/−9 lines, 13 files
Files
- CHANGELOG.md +16/−2
- mmzk-typeid.cabal +9/−1
- src/Data/KindID/Internal.hs +44/−0
- src/Data/KindID/V1.hs +168/−0
- src/Data/KindID/V1/Unsafe.hs +69/−0
- src/Data/KindID/V4.hs +0/−2
- src/Data/TypeID/Class.hs +2/−1
- src/Data/TypeID/Internal.hs +62/−1
- src/Data/TypeID/V1.hs +138/−0
- src/Data/TypeID/V1/Unsafe.hs +53/−0
- src/Data/TypeID/V4.hs +0/−1
- src/Data/UUID/Versions.hs +1/−1
- test/Spec.hs +184/−0
CHANGELOG.md view
@@ -1,6 +1,20 @@ # Revision history for mmzk-typeid +## 0.4.0.1 -- 2023-08-19++* Support `TypeID` and `KindID` with `UUID` suffixes of version 1.+ * They are exported in `Data.TypeID.V1` and `Data.KindID.V1`.++* Tests for V1 `TypeID` and `KindID`.++* Fix documentation typos.++* The `decorate` method will be moved from `IDGen` to `IDType` in the next major release.++* The type signature for `genID_` is likely to change in the next major release to support `UUID`v5. Hopefully it will not affect any existing concrete functions.++ ## 0.4.0.0 -- 2023-08-08 * Support `TypeID` and `KindID` with `UUID` suffixes of version 4.@@ -16,7 +30,7 @@ * Provide some default implementations for methods of `IDConv`. * Fix typoes in the Haddock.- + * Tests for V4 `TypeID` and `KindID`. @@ -37,7 +51,7 @@ * Add a version upper-bound for 'uuid-types'. -* Fix documentation typos. +* Fix documentation typos. ## 0.3.0.0 -- 2023-07-17
mmzk-typeid.cabal view
@@ -1,6 +1,6 @@ cabal-version: 2.4 name: mmzk-typeid-version: 0.4.0.0+version: 0.4.0.1 synopsis: A TypeID implementation for Haskell description:@@ -50,6 +50,8 @@ Data.KindID, Data.KindID.Class, Data.KindID.Unsafe,+ Data.KindID.V1,+ Data.KindID.V1.Unsafe, Data.KindID.V4, Data.KindID.V4.Unsafe, Data.KindID.V7,@@ -58,6 +60,8 @@ Data.TypeID.Class, Data.TypeID.Error, Data.TypeID.Unsafe,+ Data.TypeID.V1,+ Data.TypeID.V1.Unsafe, Data.TypeID.V4, Data.TypeID.V4.Unsafe, Data.TypeID.V7,@@ -107,6 +111,8 @@ Data.KindID.Class, Data.KindID.Internal, Data.KindID.Unsafe,+ Data.KindID.V1,+ Data.KindID.V1.Unsafe, Data.KindID.V4, Data.KindID.V4.Unsafe, Data.KindID.V7,@@ -116,6 +122,8 @@ Data.TypeID.Error, Data.TypeID.Internal, Data.TypeID.Unsafe,+ Data.TypeID.V1,+ Data.TypeID.V1.Unsafe, Data.TypeID.V4, Data.TypeID.V4.Unsafe, Data.TypeID.V7,
src/Data/KindID/Internal.hs view
@@ -24,6 +24,7 @@ import qualified Data.TypeID.Internal as TID import Data.UUID.Types.Internal (UUID(..)) import Data.TypeID.V7 (TypeID)+import qualified Data.UUID.V1 as V1 import qualified Data.UUID.V4 as V4 import qualified Data.UUID.V7 as V7 import Data.UUID.Versions@@ -217,6 +218,32 @@ checkIDWithEnv_ _ = checkKindIDWithEnv {-# INLINE checkIDWithEnv_ #-} ++-- | Generate 'KindID'' ''V1's.+instance (ToPrefix prefix, ValidPrefix (PrefixSymbol prefix))+ => IDGen (KindID' 'V1 prefix) where+ type IDGenPrefix (KindID' 'V1 prefix) = 'Nothing++ genID_ :: MonadIO m => Proxy (KindID' 'V1 prefix) -> m (KindID' 'V1 prefix)+ genID_ _ = genKindIDV1+ {-# INLINE genID_ #-}++ genIDs_ :: MonadIO m+ => Proxy (KindID' 'V1 prefix) -> Word16 -> m [KindID' 'V1 prefix]+ genIDs_ _ n+ = fmap KindID' <$> replicateM (fromIntegral n) (liftIO TID.nextUUID)+ {-# INLINE genIDs_ #-}++ decorate_ :: Proxy (KindID' 'V1 prefix) -> UUID -> KindID' 'V1 prefix+ decorate_ _ = decorateKindID+ {-# INLINE decorate_ #-}++ checkID_ :: Proxy (KindID' 'V1 prefix)+ -> KindID' 'V1 prefix+ -> Maybe TypeIDError+ checkID_ _ = checkKindIDV1+ {-# INLINE checkID_ #-}+ -- | Generate 'KindID'' ''V4's. instance (ToPrefix prefix, ValidPrefix (PrefixSymbol prefix)) => IDGen (KindID' 'V4 prefix) where@@ -278,6 +305,16 @@ genKindIDs n = fmap KindID' <$> V7.genUUIDs n {-# INLINE genKindIDs #-} +-- | Generate a new 'KindID'' ''V1' from a prefix.+--+-- It throws a 'TypeIDError' if the prefix does not match the specification,+-- namely if it's longer than 63 characters or if it contains characters other+-- than lowercase latin letters.+genKindIDV1 :: (ToPrefix prefix, ValidPrefix (PrefixSymbol prefix), MonadIO m)+ => m (KindID' 'V1 prefix)+genKindIDV1 = KindID' <$> liftIO TID.nextUUID+{-# INLINE genKindIDV1 #-}+ -- | Generate a new 'KindID'' ''V4' from a prefix. -- -- It throws a 'TypeIDError' if the prefix does not match the specification,@@ -419,6 +456,13 @@ => KindID' 'V7 prefix -> m (Maybe TypeIDError) checkKindIDWithEnv = TID.checkTypeIDWithEnv . toTypeID {-# INLINE checkKindIDWithEnv #-}++-- | Check if the prefix is valid and the suffix 'UUID' has the correct v1+-- version and variant.+checkKindIDV1 :: (ToPrefix prefix, ValidPrefix (PrefixSymbol prefix))+ => KindID' 'V1 prefix -> Maybe TypeIDError+checkKindIDV1 = TID.checkTypeIDV1 . toTypeID+{-# INLINE checkKindIDV1 #-} -- | Check if the prefix is valid and the suffix 'UUID' has the correct v4 -- version and variant.
+ src/Data/KindID/V1.hs view
@@ -0,0 +1,168 @@+-- |+-- Module : Data.KindID.V1+-- License : MIT+-- Maintainer : mmzk1526@outlook.com+-- Portability : GHC+--+-- 'Data.KindID.V7.KindID' with 'UUID'v1.+--+module Data.KindID.V1+ (+ -- * Data types+ KindIDV1+ , getPrefix+ , getUUID+ , getTime+ -- * 'KindIDV1' generation ('KindIDV1'-specific)+ , genKindID+ , decorateKindID+ -- * 'KindIDV1' generation (class methods)+ , genID+ , decorate+ -- * Validation ('KindIDV1'-specific)+ , checkKindID+ -- * Validation (class methods)+ , checkID+ -- * Encoding & decoding ('KindIDV1'-specific)+ , toString+ , toText+ , toByteString+ , parseString+ , parseText+ , parseByteString+ , parseStringM+ , parseTextM+ , parseByteStringM+ -- * Encoding & decoding (class methods)+ , id2String+ , id2Text+ , id2ByteString+ , string2ID+ , text2ID+ , byteString2ID+ , string2IDM+ , text2IDM+ , byteString2IDM+ -- * Type-level & term-level conversion+ , toTypeID+ , fromTypeID+ ) where++import Control.Monad.IO.Class+import Data.ByteString.Lazy (ByteString)+import Data.KindID.Class+import Data.KindID.Internal (KindID'(..))+import qualified Data.KindID.Internal as KID+import Data.Text (Text)+import Data.TypeID.Class+import Data.TypeID.Error+import Data.TypeID.V1 (TypeIDV1)+import Data.TypeID.V7 (TypeID)+import Data.UUID.Types.Internal (UUID)+import Data.UUID.Versions++-- | Similar to 'Data.KindID.V7.KindID', but uses 'UUID'v1.+type KindIDV1 = KID.KindID' 'V1++-- | Generate a new 'KindIDV1' from a prefix.+--+-- It throws a 'TypeIDError' if the prefix does not match the specification,+-- namely if it's longer than 63 characters or if it contains characters other+-- than lowercase latin letters.+genKindID :: (ToPrefix prefix, ValidPrefix (PrefixSymbol prefix), MonadIO m)+ => m (KindIDV1 prefix)+genKindID = KID.genKindIDV1+{-# INLINE genKindID #-}++-- | Obtain a 'KindIDV1' from a prefix and a 'UUID'.+decorateKindID :: (ToPrefix prefix, ValidPrefix (PrefixSymbol prefix))+ => UUID -> KindIDV1 prefix+decorateKindID = KID.decorateKindID+{-# INLINE decorateKindID #-}++-- | Check if the prefix is valid and the suffix 'UUID' has the correct v1+-- version and variant.+checkKindID :: (ToPrefix prefix, ValidPrefix (PrefixSymbol prefix))+ => KindIDV1 prefix -> Maybe TypeIDError+checkKindID = KID.checkKindIDV1+{-# INLINE checkKindID #-}++-- | Pretty-print a 'KindIDV1'. It is 'id2String' with concrete type.+toString :: (ToPrefix prefix, ValidPrefix (PrefixSymbol prefix))+ => KindIDV1 prefix -> String+toString = KID.toString+{-# INLINE toString #-}++-- | Pretty-print a 'KindIDV1' to strict 'Text'. It is 'id2Text' with concrete+-- type.+toText :: (ToPrefix prefix, ValidPrefix (PrefixSymbol prefix))+ => KindIDV1 prefix -> Text+toText = KID.toText+{-# INLINE toText #-}++-- | Pretty-print a 'KindIDV1' to lazy 'ByteString'. It is 'id2ByteString' with+-- concrete type.+toByteString :: (ToPrefix prefix, ValidPrefix (PrefixSymbol prefix))+ => KindIDV1 prefix -> ByteString+toByteString = KID.toByteString+{-# INLINE toByteString #-}++-- | Parse a 'KindIDV1' from its 'String' representation. It is 'parseString'+-- with concrete type.+parseString :: forall prefix+ . (ToPrefix prefix, ValidPrefix (PrefixSymbol prefix))+ => String -> Either TypeIDError (KindIDV1 prefix)+parseString = KID.parseString+{-# INLINE parseString #-}++-- | Parse a 'KindIDV1' from its string representation as a strict 'Text'. It is+-- 'parseText' with concrete type.+parseText :: forall prefix+ . (ToPrefix prefix, ValidPrefix (PrefixSymbol prefix))+ => Text -> Either TypeIDError (KindIDV1 prefix)+parseText = KID.parseText+{-# INLINE parseText #-}++-- | Parse a 'KindIDV1' from its string representation as a lazy 'ByteString'.+-- It is 'parseByteString' with concrete type.+parseByteString :: forall prefix+ . (ToPrefix prefix, ValidPrefix (PrefixSymbol prefix))+ => ByteString -> Either TypeIDError (KindIDV1 prefix)+parseByteString = KID.parseByteString++-- | Parse a 'KindIDV1' from its 'String' representation, throwing an error when+-- the parsing fails. It is 'string2IDM' with concrete type.+parseStringM :: (ToPrefix prefix, ValidPrefix (PrefixSymbol prefix), MonadIO m)+ => String -> m (KindIDV1 prefix)+parseStringM = KID.parseStringM+{-# INLINE parseStringM #-}++-- | Parse a 'KindIDV1' from its string representation as a strict 'Text',+-- throwing an error when the parsing fails. It is 'text2IDM' with concrete+-- type. It is 'parseTextM' with concrete type.+parseTextM :: (ToPrefix prefix, ValidPrefix (PrefixSymbol prefix), MonadIO m)+ => Text -> m (KindIDV1 prefix)+parseTextM = KID.parseTextM+{-# INLINE parseTextM #-}++-- | Parse a 'KindIDV1' from its string representation as a lazy 'ByteString',+-- throwing an error when the parsing fails. It is 'byteString2IDM' with+-- concrete type. It is 'parseByteStringM' with concrete type.+parseByteStringM :: ( ToPrefix prefix+ , ValidPrefix (PrefixSymbol prefix)+ , MonadIO m )+ => ByteString -> m (KindIDV1 prefix)+parseByteStringM = KID.parseByteStringM+{-# INLINE parseByteStringM #-}++-- | Convert a 'KindIDV1' to a 'Data.TypeID.V4.TypeIDV1'.+toTypeID :: (ToPrefix prefix, ValidPrefix (PrefixSymbol prefix))+ => KindIDV1 prefix -> TypeIDV1+toTypeID = KID.toTypeID+{-# INLINE toTypeID #-}++-- | Convert a 'TypeIDV1' to a 'KindIDV1'.+fromTypeID :: (ToPrefix prefix, ValidPrefix (PrefixSymbol prefix))+ => TypeIDV1 -> Maybe (KindIDV1 prefix)+fromTypeID = KID.fromTypeID+{-# INLINE fromTypeID #-}
+ src/Data/KindID/V1/Unsafe.hs view
@@ -0,0 +1,69 @@+-- |+-- Module : Data.KindID.V1.Unsafe+-- License : MIT+-- Maintainer : mmzk1526@outlook.com+-- Portability : GHC+--+-- Unsafe 'KindIDV1' functions.+--+module Data.KindID.V1.Unsafe+ (+ -- * Unsafe 'KindIDV1' decoding ('KindIDV1'-specific)+ unsafeParseString+ , unsafeParseText+ , unsafeParseByteString+ -- * Unsafe 'KindIDV1' decoding (class methods)+ , unsafeString2ID+ , unsafeText2ID+ , unsafeByteString2ID+ -- * Unsafe conversion+ , unsafeFromTypeID+ ) where++import Data.ByteString.Lazy (ByteString)+import Data.KindID.Class+import Data.KindID.Internal (KindID')+import qualified Data.KindID.Internal as KID+import Data.KindID.V1 (KindIDV1)+import Data.TypeID.Internal (TypeID')+import Data.TypeID.V1 (TypeIDV1)+import Data.Text (Text)+import Data.TypeID.Class++-- | Parse a 'KindIDV1' from its 'String' representation, but does not behave+-- correctly when parsing fails.+--+-- More specifically, if the prefix does not match, it will not complain and+-- produce the wrong 'KindIDV1'. If there are other parse errors, it will crash.+unsafeParseString :: (ToPrefix prefix, ValidPrefix (PrefixSymbol prefix))+ => String -> KindIDV1 prefix+unsafeParseString = KID.unsafeParseString+{-# INLINE unsafeParseString #-}++-- | Parse a 'KindIDV1' from its string representation as a strict 'Text', but+-- does not behave correctly when parsing fails.+--+-- More specifically, if the prefix does not match, it will not complain and+-- produce the wrong 'KindIDV1'. If there are other parse errors, it will crash.+unsafeParseText :: (ToPrefix prefix, ValidPrefix (PrefixSymbol prefix))+ => Text -> KindIDV1 prefix+unsafeParseText = KID.unsafeParseText+{-# INLINE unsafeParseText #-}++-- | Parse a 'KindIDV1' from its string representation as a lazy 'ByteString',+-- but does not behave correctly when parsing fails.+--+-- More specifically, if the prefix does not match, it will not complain and+-- produce the wrong 'KindIDV1'. If there are other parse errors, it will crash.+unsafeParseByteString :: (ToPrefix prefix, ValidPrefix (PrefixSymbol prefix))+ => ByteString -> KindIDV1 prefix+unsafeParseByteString = KID.unsafeParseByteString+{-# INLINE unsafeParseByteString #-}++-- | Convert a 'TypeIDV1' to a 'KindIDV1'. If the actual prefix does not match+-- with the expected one as defined by the type, it does not complain and+-- produces a wrong 'KindIDV1'.+unsafeFromTypeID :: (ToPrefix prefix, ValidPrefix (PrefixSymbol prefix))+ => TypeIDV1 -> KindIDV1 prefix+unsafeFromTypeID = KID.unsafeFromTypeID+{-# INLINE unsafeFromTypeID #-}
src/Data/KindID/V4.hs view
@@ -62,7 +62,6 @@ import Data.TypeID.V7 (TypeID) import Data.UUID.Types.Internal (UUID) import Data.UUID.Versions-import Data.Word -- | Similar to 'Data.KindID.V7.KindID', but uses 'UUID'v4. type KindIDV4 = KID.KindID' 'V4@@ -95,7 +94,6 @@ => KindIDV4 prefix -> Maybe TypeIDError checkKindID = KID.checkKindIDV4 {-# INLINE checkKindID #-}- -- | Pretty-print a 'KindIDV4'. It is 'id2String' with concrete type. toString :: (ToPrefix prefix, ValidPrefix (PrefixSymbol prefix))
src/Data/TypeID/Class.hs view
@@ -199,7 +199,8 @@ {-# INLINE genID'_ #-} -- | Generate a list of identifiers with the given prefix.- genIDs_ :: MonadIO m => Proxy a -> GenFunc (IDGenPrefix a) (Word16 -> m [a])+ genIDs_ :: forall m. MonadIO m+ => Proxy a -> GenFunc (IDGenPrefix a) (Word16 -> m [a]) -- | Generate a new identifier with the given prefix and 'UUID' suffix. decorate_ :: Proxy a
src/Data/TypeID/Internal.hs view
@@ -33,6 +33,7 @@ import Data.TypeID.Error import Data.UUID.Types.Internal (UUID(..)) import qualified Data.UUID.Types.Internal as UUID+import qualified Data.UUID.V1 as V1 import qualified Data.UUID.V4 as V4 import qualified Data.UUID.V7 as V7 import Data.UUID.Versions@@ -246,6 +247,35 @@ checkIDWithEnv_ _ = checkTypeIDWithEnv {-# INLINE checkIDWithEnv_ #-} +instance IDGen (TypeID' 'V1) where+ type IDGenPrefix (TypeID' 'V1) = 'Just Text++ genID_ :: MonadIO m => Proxy (TypeID' 'V1) -> Text -> m (TypeID' 'V1)+ genID_ _ = genTypeIDV1+ {-# INLINE genID_ #-}++ genIDs_ :: MonadIO m+ => Proxy (TypeID' 'V1)+ -> Text+ -> Word16+ -> m [TypeID' 'V1]+ genIDs_ _ prefix n = case checkPrefix prefix of+ Nothing -> map (TypeID' prefix)+ <$> replicateM (fromIntegral n) (liftIO nextUUID)+ Just err -> liftIO $ throwIO err+ {-# INLINE genIDs_ #-}++ decorate_ :: Proxy (TypeID' 'V1)+ -> Text+ -> UUID+ -> Either TypeIDError (TypeID' 'V1)+ decorate_ _ = decorateTypeID+ {-# INLINE decorate_ #-}++ checkID_ :: Proxy (TypeID' 'V1) -> TypeID' 'V1 -> Maybe TypeIDError+ checkID_ _ = checkTypeIDV1+ {-# INLINE checkID_ #-}+ instance IDGen (TypeID' 'V4) where type IDGenPrefix (TypeID' 'V4) = 'Just Text @@ -263,7 +293,8 @@ -> Word16 -> m [TypeID' 'V4] genIDs_ _ prefix n = case checkPrefix prefix of- Nothing -> map (TypeID' prefix) <$> replicateM (fromIntegral n) randomIO+ Nothing -> map (TypeID' prefix)+ <$> replicateM (fromIntegral n) (liftIO V4.nextRandom) Just err -> liftIO $ throwIO err {-# INLINE genIDs_ #-} @@ -311,6 +342,17 @@ Just err -> liftIO $ throwIO err {-# INLINE genTypeIDs #-} +-- | Generate a new 'TypeID'' ''V1' from a prefix.+--+-- It throws a 'TypeIDError' if the prefix does not match the specification,+-- namely if it's longer than 63 characters or if it contains characters other+-- than lowercase latin letters.+genTypeIDV1 :: MonadIO m => Text -> m (TypeID' 'V1)+genTypeIDV1 prefix = case checkPrefix prefix of+ Nothing -> unsafeGenTypeIDV1 prefix+ Just err -> liftIO $ throwIO err+{-# INLINE genTypeIDV1 #-}+ -- | Generate a new 'TypeID'' ''V4' from a prefix. -- -- It throws a 'TypeIDError' if the prefix does not match the specification,@@ -448,6 +490,14 @@ , TypeIDErrorUUIDError <$ guard (not $ V7.validate uuid) ] {-# INLINE checkTypeID #-} +-- | Check if the prefix is valid and the suffix 'UUID' has the correct v1+-- version and variant.+checkTypeIDV1 :: TypeID' 'V1 -> Maybe TypeIDError+checkTypeIDV1 (TypeID' prefix uuid)+ = msum [ checkPrefix prefix+ , TypeIDErrorUUIDError <$ guard (not $ validateWithVersion uuid V1) ]+{-# INLINE checkTypeIDV1 #-}+ -- | Check if the prefix is valid and the suffix 'UUID' has the correct v4 -- version and variant. checkTypeIDV4 :: TypeID' 'V4 -> Maybe TypeIDError@@ -470,6 +520,12 @@ unsafeGenTypeID = fmap head . (`unsafeGenTypeIDs` 1) {-# INLINE unsafeGenTypeID #-} +-- | Generate a new 'TypeID'' ''V1' from a prefix, but without checking if the+-- prefix is valid.+unsafeGenTypeIDV1 :: MonadIO m => Text -> m (TypeID' 'V1)+unsafeGenTypeIDV1 prefix = TypeID' prefix <$> liftIO nextUUID+{-# INLINE unsafeGenTypeIDV1 #-}+ -- | Generate a new 'TypeID'' ''V4' from a prefix, but without checking if the -- prefix is valid. unsafeGenTypeIDV4 :: MonadIO m => Text -> m (TypeID' 'V4)@@ -546,6 +602,11 @@ toBytes 0 = [] toBytes x = fromIntegral (x .&. 0x1F) : toBytes (x `shiftR` 5) {-# INLINE separate5BitInts #-}++-- | A helper for generating 'UUID'v1.+nextUUID :: IO UUID+nextUUID = V1.nextUUID >>= maybe nextUUID pure+{-# INLINE nextUUID #-} -- The helpers below are verbatim translations from the official highly magical -- Go implementation.
+ src/Data/TypeID/V1.hs view
@@ -0,0 +1,138 @@+-- |+-- Module : Data.TypeID.V1+-- License : MIT+-- Maintainer : mmzk1526@outlook.com+-- Portability : GHC+--+-- 'Data.TypeID.V7.TypeID' with 'UUID'v1.+--+module Data.TypeID.V1+ (+ -- * Data types+ TypeIDV1+ , getPrefix+ , getUUID+ -- * 'TypeIDV1' generation ('TypeIDV1'-specific)+ , genTypeID+ , decorateTypeID+ -- * 'TypeIDV1' generation (class methods)+ , genID+ , decorate+ -- * Validation ('TypeIDV1'-specific)+ , checkPrefix+ , checkTypeID+ -- * Validation (class methods)+ , checkID+ -- * Encoding & decoding ('TypeIDV1'-specific)+ , toString+ , toText+ , toByteString+ , parseString+ , parseText+ , parseByteString+ , parseStringM+ , parseTextM+ , parseByteStringM+ -- * Encoding & decoding (class methods)+ , id2String+ , id2Text+ , id2ByteString+ , string2ID+ , text2ID+ , byteString2ID+ , string2IDM+ , text2IDM+ , byteString2IDM+ ) where++import Control.Monad.IO.Class+import Data.ByteString.Lazy (ByteString)+import Data.Text (Text)+import Data.TypeID.Class+import Data.TypeID.Error+import qualified Data.TypeID.Internal as TID+import Data.UUID.Types (UUID)+import Data.UUID.Versions++-- | Similar to 'Data.TypeID.V7.TypeID', but uses 'UUID'v1.+type TypeIDV1 = TID.TypeID' 'V1++-- | Generate a new 'TypeIDV1' from a prefix.+--+-- It throws a 'TypeIDError' if the prefix does not match the specification,+-- namely if it's longer than 63 characters or if it contains characters other+-- than lowercase latin letters.+genTypeID :: MonadIO m => Text -> m TypeIDV1+genTypeID = TID.genTypeIDV1+{-# INLINE genTypeID #-}++-- | Obtain a 'TypeIDV1' from a prefix and a 'UUID'.+decorateTypeID :: Text -> UUID -> Either TypeIDError TypeIDV1+decorateTypeID = TID.decorateTypeID+{-# INLINE decorateTypeID #-}++-- | Check if the given prefix is a valid 'TypeIDV1' prefix.+checkPrefix :: Text -> Maybe TypeIDError+checkPrefix = TID.checkPrefix+{-# INLINE checkPrefix #-}++-- | Check if the prefix is valid and the suffix 'UUID' has the correct v1+-- version and variant.+checkTypeID :: TypeIDV1 -> Maybe TypeIDError+checkTypeID = TID.checkTypeIDV1+{-# INLINE checkTypeID #-}++-- | Pretty-print a 'TypeIDV1'. It is 'id2String' with concrete type.+toString :: TypeIDV1 -> String+toString = TID.toString+{-# INLINE toString #-}++-- | Pretty-print a 'TypeIDV1' to strict 'Text'. It is 'id2Text' with concrete+-- type.+toText :: TypeIDV1 -> Text+toText = TID.toText+{-# INLINE toText #-}++-- | Pretty-print a 'TypeIDV1' to lazy 'ByteString'. It is 'id2ByteString'+-- with concrete type.+toByteString :: TypeIDV1 -> ByteString+toByteString = TID.toByteString+{-# INLINE toByteString #-}++-- | Parse a 'TypeIDV1' from its 'String' representation. It is 'string2ID' with+-- concrete type.+parseString :: String -> Either TypeIDError TypeIDV1+parseString = TID.parseString+{-# INLINE parseString #-}++-- | Parse a 'TypeIDV1' from its string representation as a strict 'Text'. It+-- is 'text2ID' with concrete type.+parseText :: Text -> Either TypeIDError TypeIDV1+parseText = TID.parseText+{-# INLINE parseText #-}++-- | Parse a 'TypeIDV1' from its string representation as a lazy 'ByteString'.+-- It is 'byteString2ID' with concrete type.+parseByteString :: ByteString -> Either TypeIDError TypeIDV1+parseByteString = TID.parseByteString+{-# INLINE parseByteString #-}++-- | Parse a 'TypeIDV1' from its 'String' representation, throwing an error when+-- the parsing fails. It is 'string2IDM' with concrete type.+parseStringM :: MonadIO m => String -> m TypeIDV1+parseStringM = TID.parseStringM+{-# INLINE parseStringM #-}++-- | Parse a 'TypeIDV1' from its string representation as a strict 'Text',+-- throwing an error when the parsing fails. It is 'text2IDM' with concrete+-- type.+parseTextM :: MonadIO m => Text -> m TypeIDV1+parseTextM = TID.parseTextM+{-# INLINE parseTextM #-}++-- | Parse a 'TypeIDV1' from its string representation as a lazy 'ByteString',+-- throwing an error when the parsing fails. It is 'byteString2IDM' with+-- concrete type.+parseByteStringM :: MonadIO m => ByteString -> m TypeIDV1+parseByteStringM = TID.parseByteStringM+{-# INLINE parseByteStringM #-}
+ src/Data/TypeID/V1/Unsafe.hs view
@@ -0,0 +1,53 @@+-- |+-- Module : Data.TypeID.V1.Unsafe+-- License : MIT+-- Maintainer : mmzk1526@outlook.com+-- Portability : GHC+--+-- Unsafe 'TypeIDV1' functions.+--+module Data.TypeID.V1.Unsafe+ (+ -- * Unsafe 'TypeIDV1' generation+ unsafeGenTypeID+ -- * Unsafe decoding ('TypeIDV1'-specific)+ , unsafeParseString+ , unsafeParseText+ , unsafeParseByteString+ -- * Unsafe decoding (class methods)+ , unsafeString2ID+ , unsafeText2ID+ , unsafeByteString2ID+ ) where++import Control.Monad.IO.Class+import Data.ByteString.Lazy (ByteString)+import Data.Text (Text)+import Data.TypeID.Class+import qualified Data.TypeID.Internal as TID+import Data.TypeID.V1 (TypeIDV1)+import Data.UUID.Types.Internal (UUID)++-- | Generate a new 'TypeIDV1' from a prefix, but without checking if the prefix+-- is valid.+unsafeGenTypeID :: MonadIO m => Text -> m TypeIDV1+unsafeGenTypeID = TID.unsafeGenTypeIDV1+{-# INLINE unsafeGenTypeID #-}++-- | Parse a 'TypeIDV1' from its 'String' representation, but crashes when+-- parsing fails.+unsafeParseString :: String -> TypeIDV1+unsafeParseString = TID.unsafeParseString+{-# INLINE unsafeParseString #-}++-- | Parse a 'TypeIDV1' from its string representation as a strict 'Text', but+-- crashes when parsing fails.+unsafeParseText :: Text -> TypeIDV1+unsafeParseText = TID.unsafeParseText+{-# INLINE unsafeParseText #-}++-- | Parse a 'TypeIDV1' from its string representation as a lazy 'ByteString',+-- but crashes when parsing fails.+unsafeParseByteString :: ByteString -> TypeIDV1+unsafeParseByteString = TID.unsafeParseByteString+{-# INLINE unsafeParseByteString #-}
src/Data/TypeID/V4.hs view
@@ -55,7 +55,6 @@ import qualified Data.TypeID.Internal as TID import Data.UUID.Types (UUID) import Data.UUID.Versions-import Data.Word -- | Similar to 'Data.TypeID.V7.TypeID', but uses 'UUID'v4. type TypeIDV4 = TID.TypeID' 'V4
src/Data/UUID/Versions.hs view
@@ -20,7 +20,7 @@ -- | The supported 'UUID' versions. These constructors are used as type-level -- tags for 'Data.TypeID.TypeID''. ----- 'V1' and 'V5' are not supported yet.+-- 'V5' are not supported yet. data UUIDVersion = V1 | V4 | V5 | V7 deriving (Eq, Ord, Bounded, Enum, Show)
test/Spec.hs view
@@ -8,6 +8,7 @@ import Data.Binary.Get import Data.Binary.Put import qualified Data.ByteString.Lazy as BSL+import Data.KindID.V1 (KindIDV1) import Data.KindID.V4 (KindIDV4) import Data.KindID import Data.KindID.Class@@ -17,6 +18,7 @@ import Data.Text (Text) import qualified Data.Text as T import Data.TypeID+import Data.TypeID.V1 (TypeIDV1) import Data.TypeID.V4 (TypeIDV4) import Data.TypeID.Class import Data.TypeID.Error@@ -74,6 +76,7 @@ main :: IO () main = hspec do v7Test+ v1Test v4Test v7Test :: Spec@@ -291,6 +294,187 @@ kid'' `shouldBe` kid' free ptr +v1Test :: Spec+v1Test = do+ invalid <- runIO (BSL.readFile "test/invalid.json" >>= throwDecode :: IO [TestData])+ valid <- runIO (BSL.readFile "test/valid.json" >>= throwDecode :: IO [TestData])+ validUUID <- runIO (BSL.readFile "test/valid.json" >>= throwDecode :: IO [TestDataUUID TypeIDV1])+ describe "Generate TypeIDV1" do+ it "can generate TypeIDV1 with prefix" do+ tid <- withCheck $ genID @TypeIDV1 "mmzk"+ getPrefix tid `shouldBe` "mmzk"+ it "can generate TypeIDV1 without prefix" do+ tid <- withCheck $ genID @TypeIDV1 ""+ getPrefix tid `shouldBe` ""+ it "can generate TypeIDV1 with insecure UUIDv4" do+ start <- V7.getEpochMilli+ tid <- withCheck $ genID' @TypeIDV1 "mmzk"+ getPrefix tid `shouldBe` "mmzk"+ it "can parse TypeIDV1 from String" do+ case string2ID @TypeIDV1 "mmzk_5hjpeh96458fct8t49fnf9farw" of+ Left err -> expectationFailure $ "Parse error: " ++ show err+ Right tid -> getPrefix tid `shouldBe` "mmzk"++ describe "Parse TypeIDV1" do+ let invalidPrefixes = [ ("caps", "PREFIX")+ , ("numeric", "12323")+ , ("symbols", "pre.fix")+ , ("spaces", " ")+ , ("long", "abcdefghijklmnopqrstuvwxyzabcdefghijklmnopqrstuvwxyzabcdefghijklmnopqrstuvwxyzabcdefghijklmnopqrstuvwxyz")+ , ("ascii", "château") ]+ describe "can detect invalid prefix" do+ forM_ invalidPrefixes \(reason, prefix) -> it reason do+ genID @TypeIDV1 prefix `shouldThrow` anyTypeIDError+ case decorate @TypeIDV1 prefix nil of+ Left _ -> pure ()+ Right _ -> expectationFailure "Should not be able to decorate with invalid prefix"+ let invalidSuffixes = [ ("spaces", " ")+ , ("short", "01234")+ , ("long", "012345678901234567890123456789012345678901234567890123456789012345678901234567890123456789")+ , ("caps", "00041061050R3GG28A1C60T3GF") -- Would be valid in lowercase+ , ("hyphens", "00041061050-3gg28a1-60t3gf")+ , ("crockford_ambiguous", "ooo41o61o5or3gg28a1c6ot3gi") -- Would be valid if we followed Crockford's substitution rules+ , ("symbols", "00041061050.3gg28a1_60t3gf")+ , ("wrong_alphabet", "ooooooiiiiiiuuuuuuulllllll") ]+ describe "can detect invalid suffix" do+ forM_ invalidSuffixes \(reason, suffix) -> it reason do+ case string2ID @TypeIDV1 suffix of+ Left _ -> pure ()+ Right tid -> expectationFailure $ "Parsed TypeID: " ++ show tid++ describe "Parse special values" do+ let specialValues = [ ("nil", "00000000000000000000000000", "00000000-0000-0000-0000-000000000000")+ , ("one", "00000000000000000000000001", "00000000-0000-0000-0000-000000000001")+ , ("ten", "0000000000000000000000000a", "00000000-0000-0000-0000-00000000000a")+ , ("sixteen", "0000000000000000000000000g", "00000000-0000-0000-0000-000000000010")+ , ("thirty-two", "00000000000000000000000010", "00000000-0000-0000-0000-000000000020") ]+ forM_ specialValues \(reason, tid, uuid) -> it reason do+ case string2ID @TypeIDV1 tid of+ Left err -> expectationFailure $ "Parse error: " ++ show err+ Right tid -> show (getUUID tid) `shouldBe` uuid++ describe "TypeIDV1 valid JSON instances" do+ it "Decode and then encode should be identity" do+ tid <- genID @TypeIDV1 "mmzk"+ tid' <- genID @TypeIDV1 "foo"+ let mapping = M.fromList [(tid, tid')]+ let json = encode mapping+ decode json `shouldBe` Just mapping+ fmap encode (decode @(Map TypeIDV1 TypeIDV1) json) `shouldBe` Just json+ describe "Valid JSON value" do+ forM_ valid \(TestData name tid (Just prefix) (Just uuid)) -> it name do+ case decode @TypeIDV1 (fromString $ show tid) of+ Nothing -> expectationFailure "Parse JSON failed!"+ Just tid -> do+ getPrefix tid `shouldBe` prefix+ show (getUUID tid) `shouldBe` uuid+ describe "Valid JSON key" do+ forM_ valid \(TestData name tid (Just prefix) (Just uuid)) -> it name do+ case decode @(Map TypeIDV1 Int) (fromString $ "{" ++ show tid ++ ":" ++ "114514" ++ "}") of+ Nothing -> expectationFailure "Parse JSON failed!"+ Just mapping -> do+ let (tid, _) = M.elemAt 0 mapping+ getPrefix tid `shouldBe` prefix+ show (getUUID tid) `shouldBe` uuid++ describe "TypeIDV1 invalid JSON instances" do+ describe "Invalid JSON value" do+ forM_ invalid \(TestData name tid _ _) -> it name do+ case decode @TypeIDV1 (fromString $ show tid) of+ Nothing -> pure ()+ Just tid -> expectationFailure $ "Parsed TypeID: " ++ show tid+ describe "Invalid JSON key" do+ forM_ invalid \(TestData name tid _ _) -> it name do+ case decode @(Map TypeIDV1 Int) (fromString $ "{" ++ show tid ++ ":" ++ "114514" ++ "}") of+ Nothing -> pure ()+ Just tid -> expectationFailure "Invalid TypeID key shouldn't be parsed!"++ describe "Test invalid.json" do+ forM_ invalid \(TestData name tid _ _) -> it name do+ case string2ID @TypeIDV1 tid of+ Left _ -> pure ()+ Right tid -> expectationFailure $ "Parsed TypeID: " ++ show tid++ describe "Test valid.json (TypeIDV1 as literal)" do+ forM_ valid \(TestData name tid (Just prefix) (Just uuid)) -> it name do+ case string2ID @TypeIDV1 tid of+ Left err -> expectationFailure $ "Parse error: " ++ show err+ Right tid -> do+ getPrefix tid `shouldBe` prefix+ show (getUUID tid) `shouldBe` uuid++ describe "Test valid.json (TypeIDV1 as JSON)" do+ forM_ validUUID \(TestDataUUID name tid prefix uuid) -> it name do+ getPrefix tid `shouldBe` prefix+ getUUID tid `shouldBe` uuid++ describe "Generate KindIDV1 with 'Symbol' prefixes" do+ it "can generate KindIDV1 with prefix" do+ kid <- withCheck $ genID @(KindIDV1 "mmzk")+ getPrefix kid `shouldBe` "mmzk"+ it "can generate KindIDV1 without prefix" do+ kid <- withCheck $ genID @(KindIDV1 "")+ getPrefix kid `shouldBe` ""+ it "can generate KindIDV1 with stateless UUID v7" do+ kid <- withCheck $ genID' @(KindIDV1 "mmzk")+ getPrefix kid `shouldBe` "mmzk"+ it "can parse KindID from String" do+ case string2ID @(KindIDV1 "mmzk") "mmzk_5hjpeh96458fct8t49fnf9farw" of+ Left err -> expectationFailure $ "Parse error: " ++ show err+ Right kid -> getPrefix kid `shouldBe` "mmzk"+ it "cannot parse KindID into wrong prefix" do+ case string2ID @(KindIDV1 "foo") "mmzk_5hjpeh96458fct8t49fnf9farw" of+ Left err -> pure ()+ Right kid -> expectationFailure $ "Parsed TypeID: " ++ show kid++ describe "Generate KindIDV1 with custom data kind prefixes" do+ it "can generate KindIDV1 with prefix" do+ kid <- withCheck $ genID @(KindID 'Post)+ getPrefix kid `shouldBe` "post"+ it "can parse KindIDV1 from String" do+ case string2ID @(KindIDV1 'User) "user_00041061050r3gg28a1c60t3gf" of+ Left err -> expectationFailure $ "Parse error: " ++ show err+ Right kid -> getPrefix kid `shouldBe` "user"+ it "cannot parse KindIDV1 into wrong prefix" do+ case string2ID @(KindIDV1 'Comment) "user_00041061050r3gg28a1c60t3gf" of+ Left err -> pure ()+ Right kid -> expectationFailure $ "Parsed KindIDV1: " ++ show kid++ describe "Binary instance for TypeIDV1 and KindIDV1" do+ it "has correct binary instance for TypeIDV1" do+ tids <- withChecks $ genIDs @TypeIDV1 "abcdefghijklmnopqrstuvwxyz" 114+ forM_ tids \tid -> do+ let bytes = runPut (put tid)+ let tid' = runGet get bytes+ tid' `shouldBe` tid+ it "has correct binary instance for KindIDV1" do+ kids <- withChecks $ genIDs @(KindIDV1 "abcdefghijklmnopqrstuvwxyz") 114+ forM_ kids \kid -> do+ let bytes = runPut (put kid)+ let kid' = runGet get bytes+ kid' `shouldBe` kid++ describe "Storable instance for TypeIDV1 and KindIDV1" do+ it "has correct Storable instance for TypeIDV1" do+ tids <- withChecks $ genIDs @TypeIDV1 "abcdefghijklmnopqrstuvwxyz" 114+ forM_ tids \tid -> do+ ptr <- new tid+ tid' <- peek ptr+ tid' `shouldBe` tid+ poke ptr tid'+ tid'' <- peek ptr+ tid'' `shouldBe` tid'+ free ptr+ it "has correct Storable instance for KindIDV1" do+ kids <- withChecks $ genIDs @(KindIDV1 "abcdefghijklmnopqrstuvwxyz") 114+ forM_ kids \kid -> do+ ptr <- new kid+ kid' <- peek ptr+ kid' `shouldBe` kid+ poke ptr kid'+ kid'' <- peek ptr+ kid'' `shouldBe` kid'+ free ptr v4Test :: Spec v4Test = do