mmzk-typeid 0.1.0.0 → 0.2.0.0
raw patch · 10 files changed
+810/−407 lines, 10 filesdep +containersdep ~aesondep ~binarydep ~time
Dependencies added: containers
Dependency ranges changed: aeson, binary, time
Files
- CHANGELOG.md +30/−0
- mmzk-typeid.cabal +20/−9
- src/Data/KindID.hs +16/−145
- src/Data/KindID/Internal.hs +251/−6
- src/Data/TypeID.hs +13/−174
- src/Data/TypeID/Class.hs +50/−0
- src/Data/TypeID/Error.hs +40/−0
- src/Data/TypeID/Internal.hs +225/−26
- src/Data/UUID/V7.hs +40/−7
- test/Spec.hs +125/−40
CHANGELOG.md view
@@ -1,5 +1,35 @@ # Revision history for mmzk-typeid ++## 0.2.0.0 -- 2023-07-14++* Implement `KindID` to take arbitrary prefix type.+ * It can be a `Symbol` as before, but it can also be any type that implements+ `ToPrefix` which dictates how to translate the prefix type to a `Symbol`.++* Fix orphan instances for `TypeID` and `KindID`.++* Add `FromJSONKey` and `ToJSONKey` instances for `TypeID` and `KindID`.++* Introduce `IDType` class to unify the `getPrefix`, `getUUID`, and `getTime`+ functions of `TypeID` and `KindID`.++* Introduce `IDConv` class to unify the various conversion functions between+ `TypeID`/`KindID` and `String`/`Text`/`ByteString`.+ * The original concrete functions remain, and the class is provided as an+ alternative.++* Deprecate `unUUID`, `parseStringWithPrefix`, `parseTextWithPrefix`,+ `parseByteStringWithPrefix`, `nil`, and `decorate`. They are either replaced+ by functions of other names or are no longer necessary.+ * They will be removed in the next major version.++* The `UUID` type is expected to be removed in the next major version in favour+ of the type from the 'uuid-types' package.++* More tests.++ ## 0.1.0.0 -- 2023-07-11 * First version. Released on an unsuspecting world.
mmzk-typeid.cabal view
@@ -1,6 +1,6 @@ cabal-version: 2.4 name: mmzk-typeid-version: 0.1.0.0+version: 0.2.0.0 synopsis: A TypeID implementation for Haskell description:@@ -14,15 +14,17 @@ . - Encode prefixes at type-level for better type-safety .- The following extensions are recommended when using this library:+ Please enable the following extensions if working with 'KindID': .- > {-# LANGUAGE BlockArguments #-} > {-# LANGUAGE DataKinds #-}- > {-# LANGUAGE InstanceSigs #-}- > {-# LANGUAGE MultiWayIf #-}- > {-# LANGUAGE OverloadedStrings #-}+ > {-# LANGUAGE PolyKinds #-} > {-# LANGUAGE TypeApplications #-}+ > {-# LANGUAGE TypeFamilies #-} .+ While the following is not required, it is quite convenient to have+ .+ > {-# LANGUAGE OverloadedStrings #-}+ . For a quick "how-to-use" guide, please refer to the README.md file at https://github.com/MMZK1526/mmzk-typeid#readme. homepage: https://github.com/MMZK1526/mmzk-typeid@@ -42,6 +44,8 @@ exposed-modules: Data.KindID, Data.TypeID,+ Data.TypeID.Class,+ Data.TypeID.Error, Data.UUID.V7 other-modules: Data.KindID.Internal,@@ -52,17 +56,19 @@ InstanceSigs MultiWayIf OverloadedStrings+ PolyKinds TypeApplications+ TypeFamilies build-depends: base >=4.16 && <5,- aeson ^>=2.1,+ aeson >=2.1 && <3, array ^>=0.5,- binary ^>=0.8.9,+ binary >=0.8.5 && <0.9, bytestring ^>= 0.11, entropy ^>=0.4, text ^>=2.0, transformers ^>=0.6,- time ^>=1.11,+ time >=1.11 && <1.13, hs-source-dirs: src default-language: Haskell2010 @@ -74,6 +80,8 @@ Data.KindID, Data.KindID.Internal, Data.TypeID,+ Data.TypeID.Class,+ Data.TypeID.Error, Data.TypeID.Internal, Data.UUID.V7 default-extensions:@@ -82,13 +90,16 @@ InstanceSigs MultiWayIf OverloadedStrings+ PolyKinds TypeApplications+ TypeFamilies build-depends: base, aeson, array, binary, bytestring,+ containers ^>=0.6, entropy, hspec ^>=2.11, text,
src/Data/KindID.hs view
@@ -1,7 +1,3 @@-{-# LANGUAGE ScopedTypeVariables #-}-{-# LANGUAGE TypeFamilies #-}-{-# LANGUAGE UndecidableInstances #-}- -- | -- Module : Data.KindID -- License : MIT@@ -11,8 +7,8 @@ -- Similar to "Data.TypeID", but the type is statically determined in the type -- level. ----- When using TypeID, if we want to check if the type matches, we usually need--- to get the prefix of the TypeID and compare it with the desired prefix at+-- When using 'TypeID', if we want to check if the type matches, we usually need+-- to get the prefix of the 'TypeID' and compare it with the desired prefix at -- runtime. However, with Haskell's type system, we can do this at compile time -- instead. We call this TypeID with compile-time prefix a 'KindID'. --@@ -46,12 +42,22 @@ , getUUID , getTime , ValidPrefix+ , ToPrefix(..) -- * KindID generation+ , nil+ , nilKindID , genKindID , genKindIDs- , nil , decorate- -- * Encoding & decoding+ , decorateKindID+ -- * Encoding & decoding (class methods)+ , id2String+ , id2Text+ , id2ByteString+ , string2ID+ , text2ID+ , byteString2ID+ -- * Encoding & decoding ('KindID'-specific) , toString , toText , toByteString@@ -63,141 +69,6 @@ , fromTypeID ) where -import Control.Monad-import Data.Aeson.Types hiding (String)-import Data.ByteString.Lazy (ByteString)-import Data.Proxy-import Data.Text (Text)-import qualified Data.Text as T import Data.KindID.Internal-import Data.TypeID (TypeID, TypeIDError)-import qualified Data.TypeID as TID-import qualified Data.TypeID.Internal as TID-import Data.UUID.V7 (UUID)-import qualified Data.UUID.V7 as V7-import Data.Word-import GHC.TypeLits hiding (Text)--instance ValidPrefix prefix => ToJSON (KindID prefix) where- toJSON :: KindID prefix -> Value- toJSON = toJSON . toText- {-# INLINE toJSON #-}--instance ValidPrefix prefix => FromJSON (KindID prefix) where- parseJSON :: Value -> Parser (KindID prefix)- parseJSON str = do- s <- parseJSON str- case parseText s of- Left err -> fail $ show err- Right kid -> pure kid- {-# INLINE parseJSON #-}---- | Generate a new 'KindID' 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 :: forall prefix. ValidPrefix prefix => IO (KindID prefix)-genKindID = KindID <$> V7.genUUID-{-# INLINE genKindID #-}---- | Generate n 'KindID's from a prefix.------ It tries its best to generate 'KindID's at the same timestamp, but it may not--- be possible if we are asking too many 'UUID's at the same time.------ It is guaranteed that the first 32768 'KindID's are generated at the same--- timestamp.-genKindIDs :: forall prefix. ValidPrefix prefix => Word16 -> IO [KindID prefix]-genKindIDs n = fmap KindID <$> V7.genUUIDs n-{-# INLINE genKindIDs #-}---- | The nil 'KindID'.-nil :: KindID ""-nil = KindID V7.nil-{-# INLINE nil #-}---- | Obtain a 'KindID' from a prefix and a 'UUID'.-decorate :: forall prefix. ValidPrefix prefix => UUID -> KindID prefix-decorate = KindID-{-# INLINE decorate #-}---- | Get the prefix of the 'KindID'.-getPrefix :: forall prefix. ValidPrefix prefix => KindID prefix -> Text-getPrefix _ = T.pack $ symbolVal (Proxy @prefix)-{-# INLINE getPrefix #-}---- | Get the 'UUID' of the 'KindID'.-getUUID :: forall prefix. ValidPrefix prefix => KindID prefix -> UUID-getUUID = _getUUID-{-# INLINE getUUID #-}---- | Get the timestamp of the 'KindID'.-getTime :: forall prefix. ValidPrefix prefix => KindID prefix -> Word64-getTime = V7.getTime . getUUID-{-# INLINE getTime #-}---- | Convert a 'KindID' to a 'TypeID'.-toTypeID :: forall prefix. ValidPrefix prefix => KindID prefix -> TypeID-toTypeID kid = TID.TypeID (getPrefix kid) (getUUID kid)-{-# INLINE toTypeID #-}---- | Convert a 'TypeID' to a 'KindID'. If the actual prefix does not match--- with the expected one as defined by the type, it returns @Nothing@.-fromTypeID :: forall prefix. ValidPrefix prefix- => TypeID -> Maybe (KindID prefix)-fromTypeID tid = do- guard (T.pack (symbolVal (Proxy @prefix)) == TID.getPrefix tid)- pure $ KindID (TID.getUUID tid)-{-# INLINE fromTypeID #-}---- | Pretty-print a 'KindID'.-toString :: forall prefix. ValidPrefix prefix => KindID prefix -> String-toString = TID.toString . toTypeID-{-# INLINE toString #-}---- | Pretty-print a 'KindID' to strict 'Text'.-toText :: forall prefix. ValidPrefix prefix => KindID prefix -> Text-toText = TID.toText . toTypeID-{-# INLINE toText #-}---- | Pretty-print a 'KindID' to lazy 'ByteString'.-toByteString :: forall prefix. ValidPrefix prefix => KindID prefix -> ByteString-toByteString = TID.toByteString . toTypeID-{-# INLINE toByteString #-}---- | Parse a 'KindID' from its 'String' representation.-parseString :: forall prefix. ValidPrefix prefix- => String -> Either TID.TypeIDError (KindID prefix)-parseString str = do- tid <- TID.parseString str- case fromTypeID tid of- Nothing -> Left $ TID.TypeIDErrorPrefixMismatch- (T.pack (symbolVal (Proxy @prefix)))- (TID.getPrefix tid)- Just kid -> pure kid-{-# INLINE parseString #-}---- | Parse a 'KindID' from its string representation as a strict 'Text'.-parseText :: forall prefix. ValidPrefix prefix- => Text -> Either TID.TypeIDError (KindID prefix)-parseText str = do- tid <- TID.parseText str- case fromTypeID tid of- Nothing -> Left $ TID.TypeIDErrorPrefixMismatch- (T.pack (symbolVal (Proxy @prefix)))- (TID.getPrefix tid)- Just kid -> pure kid-{-# INLINE parseText #-}---- | Parse a 'KindID' from its string representation as a lazy 'ByteString'.-parseByteString :: forall prefix. ValidPrefix prefix- => ByteString -> Either TID.TypeIDError (KindID prefix)-parseByteString str = do- tid <- TID.parseByteString str- case fromTypeID tid of- Nothing -> Left $ TID.TypeIDErrorPrefixMismatch- (T.pack (symbolVal (Proxy @prefix)))- (TID.getPrefix tid)- Just kid -> pure kid-{-# INLINE parseByteString #-}+import Data.TypeID.Class+import Data.TypeID.Internal (TypeID)
src/Data/KindID/Internal.hs view
@@ -1,15 +1,28 @@ {-# LANGUAGE ConstraintKinds #-}+{-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-}-{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeOperators #-} {-# LANGUAGE UndecidableInstances #-} module Data.KindID.Internal where +import Control.Monad+import Data.Aeson.Types hiding (String)+import Data.ByteString.Lazy (ByteString)+import Data.Proxy+import Data.Text (Text)+import qualified Data.Text as T import Data.Type.Bool import Data.Type.Equality import Data.Type.Ord+import Data.TypeID.Class+import Data.TypeID.Error+import Data.TypeID.Internal (TypeID)+import qualified Data.TypeID.Internal as TID import Data.UUID.V7 (UUID)+import qualified Data.UUID.V7 as V7+import Data.Word import GHC.TypeLits hiding (Text) -- | A TypeID with the prefix encoded at type level.@@ -18,15 +31,214 @@ -- a type. -- -- Note that the 'Show' instance is for debugging purposes only. To pretty-print--- a 'KindID', use 'toString', 'toText' or 'toByteString'.-newtype KindID (prefix :: Symbol) = KindID { _getUUID :: UUID }+-- a 'KindID', use 'toString', 'toText' or 'toByteString'. However, this+-- behaviour will be changed in the next major version as it is not useful. By+-- then, the 'Show' instance will be the same as 'toString'.+newtype KindID prefix = KindID { _getUUID :: UUID } deriving (Eq, Ord, Show) -- | A constraint for valid prefix 'Symbol's.-type ValidPrefix (prefix :: Symbol) = ( KnownSymbol prefix- , LengthSymbol prefix < 64- , IsLowerSymbol prefix ~ 'True )+type ValidPrefix prefix = ( KnownSymbol prefix+ , LengthSymbol prefix < 64+ , IsLowerSymbol prefix ~ 'True ) +instance (ToPrefix prefix, ValidPrefix (PrefixSymbol prefix))+ => ToJSON (KindID prefix) where+ toJSON :: KindID prefix -> Value+ toJSON = toJSON . toText+ {-# INLINE toJSON #-}++instance (ToPrefix prefix, ValidPrefix (PrefixSymbol prefix))+ => FromJSON (KindID prefix) where+ parseJSON :: Value -> Parser (KindID prefix)+ parseJSON str = do+ s <- parseJSON str+ case parseText s of+ Left err -> fail $ show err+ Right kid -> pure kid+ {-# INLINE parseJSON #-}++instance (ToPrefix prefix, ValidPrefix (PrefixSymbol prefix))+ => ToJSONKey (KindID prefix) where+ toJSONKey :: ToJSONKeyFunction (KindID prefix)+ toJSONKey = toJSONKeyText toText+ {-# INLINE toJSONKey #-}++instance (ToPrefix prefix, ValidPrefix (PrefixSymbol prefix))+ => FromJSONKey (KindID prefix) where+ fromJSONKey :: FromJSONKeyFunction (KindID prefix)+ fromJSONKey = FromJSONKeyTextParser \t -> case parseText t of+ Left err -> fail $ show err+ Right kid -> pure kid+ {-# INLINE fromJSONKey #-}++-- | Get the prefix, 'UUID', and timestamp of a 'KindID'.+instance (ToPrefix prefix, ValidPrefix (PrefixSymbol prefix))+ => IDType (KindID prefix) where+ getPrefix :: KindID prefix -> Text+ getPrefix _ = T.pack (symbolVal (Proxy @(PrefixSymbol prefix)))+ {-# INLINE getPrefix #-}++ getUUID :: KindID prefix -> UUID+ getUUID = _getUUID+ {-# INLINE getUUID #-}++ getTime :: KindID prefix -> Word64+ getTime = V7.getTime . getUUID+ {-# INLINE getTime #-}++-- | Conversion between 'KindID' and 'String'/'Text'/'ByteString'.+instance (ToPrefix prefix, ValidPrefix (PrefixSymbol prefix))+ => IDConv (KindID prefix) where+ string2ID :: String -> Either TypeIDError (KindID prefix)+ string2ID = parseString+ {-# INLINE string2ID #-}++ text2ID :: Text -> Either TypeIDError (KindID prefix)+ text2ID = parseText+ {-# INLINE text2ID #-}++ byteString2ID :: ByteString -> Either TypeIDError (KindID prefix)+ byteString2ID = parseByteString+ {-# INLINE byteString2ID #-}++ id2String :: KindID prefix -> String+ id2String = toString+ {-# INLINE id2String #-}++ id2Text :: KindID prefix -> Text+ id2Text = toText+ {-# INLINE id2Text #-}++ id2ByteString :: KindID prefix -> ByteString+ id2ByteString = toByteString+ {-# INLINE id2ByteString #-}++-- | Generate a new 'KindID' 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 :: forall prefix. (ToPrefix prefix, ValidPrefix (PrefixSymbol prefix))+ => IO (KindID prefix)+genKindID = KindID <$> V7.genUUID+{-# INLINE genKindID #-}++-- | Generate n 'KindID's from a prefix.+--+-- It tries its best to generate 'KindID's at the same timestamp, but it may not+-- be possible if we are asking too many 'UUID's at the same time.+--+-- It is guaranteed that the first 32768 'KindID's are generated at the same+-- timestamp.+genKindIDs :: forall prefix+ . (ToPrefix prefix, ValidPrefix (PrefixSymbol prefix))+ => Word16 -> IO [KindID prefix]+genKindIDs n = fmap KindID <$> V7.genUUIDs n+{-# INLINE genKindIDs #-}++-- | The nil 'KindID'.+nil :: KindID ""+nil = KindID V7.nil+{-# INLINE nil #-}+{-# DEPRECATED nil "Use 'nilKindID' instead." #-}++-- | The nil 'KindID'.+nilKindID :: KindID ""+nilKindID = KindID V7.nil+{-# INLINE nilKindID #-}++-- | Obtain a 'KindID' from a prefix and a 'UUID'.+decorate :: forall prefix. (ToPrefix prefix, ValidPrefix (PrefixSymbol prefix))+ => UUID -> KindID prefix+decorate = KindID+{-# INLINE decorate #-}+{-# DEPRECATED decorate "Use 'decorateKindID' instead." #-}++-- | Obtain a 'KindID' from a prefix and a 'UUID'.+decorateKindID :: forall prefix+ . (ToPrefix prefix, ValidPrefix (PrefixSymbol prefix))+ => UUID -> KindID prefix+decorateKindID = KindID++-- | Convert a 'KindID' to a 'TypeID'.+toTypeID :: forall prefix. (ToPrefix prefix, ValidPrefix (PrefixSymbol prefix))+ => KindID prefix -> TypeID+toTypeID kid = TID.TypeID (getPrefix kid) (getUUID kid)+{-# INLINE toTypeID #-}++-- | Convert a 'TypeID' to a 'KindID'. If the actual prefix does not match+-- with the expected one as defined by the type, it returns @Nothing@.+fromTypeID :: forall prefix+ . (ToPrefix prefix, ValidPrefix (PrefixSymbol prefix))+ => TypeID -> Maybe (KindID prefix)+fromTypeID tid = do+ guard (T.pack (symbolVal (Proxy @(PrefixSymbol prefix))) == getPrefix tid)+ pure $ KindID (getUUID tid)+{-# INLINE fromTypeID #-}++-- | Pretty-print a 'KindID'. It is 'id2String' with concrete type.+toString :: forall prefix. (ToPrefix prefix, ValidPrefix (PrefixSymbol prefix))+ => KindID prefix -> String+toString = TID.toString . toTypeID+{-# INLINE toString #-}++-- | Pretty-print a 'KindID' to strict 'Text'. It is 'id2Text' with concrete+-- type.+toText :: forall prefix. (ToPrefix prefix, ValidPrefix (PrefixSymbol prefix))+ => KindID prefix -> Text+toText = TID.toText . toTypeID+{-# INLINE toText #-}++-- | Pretty-print a 'KindID' to lazy 'ByteString'. It is 'id2ByteString' with+-- concrete type.+toByteString :: forall prefix+ . (ToPrefix prefix, ValidPrefix (PrefixSymbol prefix))+ => KindID prefix -> ByteString+toByteString = TID.toByteString . toTypeID+{-# INLINE toByteString #-}++-- | Parse a 'KindID' from its 'String' representation. It is 'parseString'+-- with concrete type.+parseString :: forall prefix+ . (ToPrefix prefix, ValidPrefix (PrefixSymbol prefix))+ => String -> Either TypeIDError (KindID prefix)+parseString str = do+ tid <- TID.parseString str+ case fromTypeID tid of+ Nothing -> Left $ TypeIDErrorPrefixMismatch+ (T.pack (symbolVal (Proxy @(PrefixSymbol prefix))))+ (getPrefix tid)+ Just kid -> pure kid+{-# INLINE parseString #-}++-- | Parse a 'KindID' 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 (KindID prefix)+parseText str = do+ tid <- TID.parseText str+ case fromTypeID tid of+ Nothing -> Left $ TypeIDErrorPrefixMismatch+ (T.pack (symbolVal (Proxy @(PrefixSymbol prefix))))+ (getPrefix tid)+ Just kid -> pure kid+{-# INLINE parseText #-}++-- | Parse a 'KindID' 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 (KindID prefix)+parseByteString str = do+ tid <- TID.parseByteString str+ case fromTypeID tid of+ Nothing -> Left $ TypeIDErrorPrefixMismatch+ (T.pack (symbolVal (Proxy @(PrefixSymbol prefix))))+ (getPrefix tid)+ Just kid -> pure kid+{-# INLINE parseByteString #-}+ type family LengthSymbol (prefix :: Symbol) :: Nat where LengthSymbol prefix = LSUH (UnconsSymbol prefix) @@ -45,3 +257,36 @@ 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 'KindID'+-- prefixes.+--+-- For example, suppose we have the following data structure that represents the+-- prefixes we are going to use:+--+-- > data Prefix = User | Post | Comment+--+-- Then we can make it an instance of 'ToPrefix' like this:+--+-- > instance ToPrefix 'User where+-- > type PrefixSymbol 'User = "user"+-- >+-- > instance ToPrefix 'Post where+-- > type PrefixSymbol 'Post = "post"+-- >+-- > instance ToPrefix 'Comment where+-- > type PrefixSymbol 'Comment = "comment"+--+-- Now we can use Prefix as a prefix for '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"+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
src/Data/TypeID.hs view
@@ -6,6 +6,7 @@ -- -- An implementation of the typeid specification: -- https://github.com/jetpack-io/typeid.+-- module Data.TypeID ( -- * Data types@@ -13,15 +14,23 @@ , getPrefix , getUUID , getTime- , TypeIDError(..) -- * TypeID generation+ , nil+ , nilTypeID , genTypeID , genTypeIDs- , nil , decorate+ , decorateTypeID -- * Prefix validation , checkPrefix- -- * Encoding & decoding+ -- * Encoding & decoding (class methods)+ , id2String+ , id2Text+ , id2ByteString+ , string2ID+ , text2ID+ , byteString2ID+ -- * Encoding & decoding ('TypeID'-specific) , toString , toText , toByteString@@ -33,175 +42,5 @@ , parseByteStringWithPrefix ) where -import Control.Exception-import Control.Monad-import Data.Aeson.Types hiding (Array, String)-import Data.Bifunctor-import Data.ByteString.Lazy (ByteString)-import qualified Data.ByteString.Lazy as BSL-import Data.Char-import Data.String-import Data.Text (Text)-import qualified Data.Text as T-import Data.Text.Encoding+import Data.TypeID.Class import Data.TypeID.Internal-import Data.UUID.V7 (UUID(..))-import qualified Data.UUID.V7 as UUID-import Data.Word--instance ToJSON TypeID where- toJSON :: TypeID -> Value- toJSON = toJSON . toText- {-# INLINE toJSON #-}--instance FromJSON TypeID where- parseJSON :: Value -> Parser TypeID- parseJSON str = do- s <- parseJSON str- case parseText s of- Left err -> fail $ show err- Right tid -> pure tid- {-# INLINE parseJSON #-}---- | Get the prefix of the 'TypeID'.-getPrefix :: TypeID -> Text-getPrefix = _getPrefix-{-# INLINE getPrefix #-}---- | Get the 'UUID' of the 'TypeID'.-getUUID :: TypeID -> UUID-getUUID = _getUUID-{-# INLINE getUUID #-}---- | Get the timestamp of the 'TypeID'.-getTime :: TypeID -> Word64-getTime (TypeID _ uuid) = UUID.getTime uuid-{-# INLINE getTime #-}---- | Generate a new 'TypeID' 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 :: Text -> IO TypeID-genTypeID = fmap head . (`genTypeIDs` 1)-{-# INLINE genTypeID #-}---- | Generate n 'TypeID's from a prefix.------ It tries its best to generate 'TypeID's at the same timestamp, but it may not--- be possible if we are asking too many 'UUID's at the same time.------ It is guaranteed that the first 32768 'TypeID's are generated at the same--- timestamp.-genTypeIDs :: Text -> Word16 -> IO [TypeID]-genTypeIDs prefix n = case checkPrefix prefix of- Nothing -> map (TypeID prefix) <$> UUID.genUUIDs n- Just err -> throwIO err-{-# INLINE genTypeIDs #-}---- | The nil 'TypeID'.-nil :: TypeID-nil = TypeID "" UUID.nil-{-# INLINE nil #-}---- | Obtain a 'TypeID' from a prefix and a 'UUID'.-decorate :: Text -> UUID -> Either TypeIDError TypeID-decorate prefix uuid = case checkPrefix prefix of- Nothing -> Right $ TypeID prefix uuid- Just err -> Left err-{-# INLINE decorate #-}---- | Pretty-print a 'TypeID'.-toString :: TypeID -> String-toString (TypeID prefix uuid) = if T.null prefix- then suffixEncode (UUID.unUUID uuid)- else T.unpack prefix ++ "_" ++ suffixEncode (UUID.unUUID uuid)-{-# INLINE toString #-}---- | Pretty-print a 'TypeID' to strict 'Text'.-toText :: TypeID -> Text-toText (TypeID prefix uuid) = if T.null prefix- then T.pack (suffixEncode $ UUID.unUUID uuid)- else prefix <> "_" <> T.pack (suffixEncode $ UUID.unUUID uuid)-{-# INLINE toText #-}---- | Pretty-print a 'TypeID' to lazy 'ByteString'.-toByteString :: TypeID -> ByteString-toByteString = fromString . toString-{-# INLINE toByteString #-}---- | Parse a 'TypeID' from its 'String' representation.-parseString :: String -> Either TypeIDError TypeID-parseString str = case span (/= '_') str of- ("", _) -> Left TypeIDExtraSeparator- (_, "") -> TypeID "" <$> decodeUUID bs- (prefix, _ : suffix) -> do- let prefix' = T.pack prefix- let bs = fromString suffix- case checkPrefix prefix' of- Nothing -> TypeID prefix' <$> decodeUUID bs- Just err -> Left err- where- bs = fromString str---- | Parse a 'TypeID' from its string representation as a strict 'Text'.-parseText :: Text -> Either TypeIDError TypeID-parseText text = case second T.uncons $ T.span (/= '_') text of- ("", _) -> Left TypeIDExtraSeparator- (_, Nothing) -> TypeID "" <$> decodeUUID bs- (prefix, Just (_, suffix)) -> do- let bs = BSL.fromStrict $ encodeUtf8 suffix- case checkPrefix prefix of- Nothing -> TypeID prefix <$> decodeUUID bs- Just err -> Left err- where- bs = BSL.fromStrict $ encodeUtf8 text---- | Parse a 'TypeID' from its string representation as a lazy 'ByteString'.-parseByteString :: ByteString -> Either TypeIDError TypeID-parseByteString bs = case second BSL.uncons $ BSL.span (/= 95) bs of- ("", _) -> Left TypeIDExtraSeparator- (_, Nothing) -> TypeID "" <$> decodeUUID bs- (prefix, Just (_, suffix)) -> do- let prefix' = decodeUtf8 $ BSL.toStrict prefix- case checkPrefix prefix' of- Nothing -> TypeID prefix' <$> decodeUUID suffix- Just err -> Left err---- | Parse a 'TypeID' from the given prefix and the 'String' representation of a--- suffix.-parseStringWithPrefix :: Text -> String -> Either TypeIDError TypeID-parseStringWithPrefix prefix str = case parseString str of- Right (TypeID "" uuid) -> decorate prefix uuid- Right (TypeID p _) -> Left $ TypeIDErrorAlreadyHasPrefix p- Left err -> Left err-{-# INLINE parseStringWithPrefix #-}---- | Parse a 'TypeID' from the given prefix and the string representation of a--- suffix as a strict 'Text'.-parseTextWithPrefix :: Text -> Text -> Either TypeIDError TypeID-parseTextWithPrefix prefix text = case parseText text of- Right (TypeID "" uuid) -> decorate prefix uuid- Right (TypeID p _) -> Left $ TypeIDErrorAlreadyHasPrefix p- Left err -> Left err-{-# INLINE parseTextWithPrefix #-}---- | Parse a 'TypeID' from the given prefix and the string representation of a--- suffix as a lazy 'ByteString'.-parseByteStringWithPrefix :: Text -> ByteString -> Either TypeIDError TypeID-parseByteStringWithPrefix prefix bs = case parseByteString bs of- Right (TypeID "" uuid) -> decorate prefix uuid- Right (TypeID p _) -> Left $ TypeIDErrorAlreadyHasPrefix p- Left err -> Left err-{-# INLINE parseByteStringWithPrefix #-}---- | 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)- | otherwise - = case T.uncons (T.dropWhile (liftM2 (&&) isLower isAscii) prefix) of- Nothing -> Nothing- Just (c, _) -> Just $ TypeIDErrorPrefixInvalidChar c-{-# INLINE checkPrefix #-}
+ src/Data/TypeID/Class.hs view
@@ -0,0 +1,50 @@+-- | A module with the APIs for any TypeID-ish identifier type.+--+-- It is not completed as most of the functions are still implemented+-- individually in the "Data.TypeID" and "Data.KindID" modules.+module Data.TypeID.Class+ (+ -- * Type classes+ IDType(..)+ , IDConv(..)+ ) where++import Data.ByteString.Lazy (ByteString)+import Data.Text (Text)+import Data.TypeID.Error+import Data.UUID.V7 (UUID)+import Data.Word++-- | A type class for a TypeID-ish identifier type, which has a 'Text' prefix+-- and a 'UUID' suffix.+class IDType a where+ -- | Get the prefix of the identifier.+ getPrefix :: a -> Text++ -- | Get the UUID suffix of the identifier.+ getUUID :: a -> UUID++ -- | Get the timestamp of the identifier.+ getTime :: a -> Word64++-- | A type class for converting between a TypeID-ish identifier type and some+-- string representations.+class IDConv a where+ -- | Parse the identifier from its 'String' representation.+ string2ID :: String -> Either TypeIDError a++ -- | Parse the identifier from its string representation as a strict 'Text'.+ text2ID :: Text -> Either TypeIDError a++ -- | Parse the identifier from its string representation as a lazy+ -- 'ByteString'.+ byteString2ID :: ByteString -> Either TypeIDError a++ -- | Pretty-print the identifier to a 'String'.+ id2String :: a -> String++ -- | Pretty-print the identifier to a strict 'Text'.+ id2Text :: a -> Text++ -- | Pretty-print the identifier to a lazy 'ByteString'.+ id2ByteString :: a -> ByteString
+ src/Data/TypeID/Error.hs view
@@ -0,0 +1,40 @@+-- | TypeID Error type.+module Data.TypeID.Error+ (+ -- * Data type+ TypeIDError(..)+ ) where++import Control.Exception+import Data.Text (Text)++-- | Errors from parsing TypeIDs.+--+-- It will not be explicitly exported from "Data.TypeID" in the future.+data TypeIDError = TypeIDErrorPrefixTooLong Int+ | TypeIDExtraSeparator+ | TypeIDErrorPrefixInvalidChar Char+ -- | Will be removed in the next major release.+ | TypeIDErrorAlreadyHasPrefix Text+ | TypeIDErrorPrefixMismatch Text Text+ | TypeIDErrorUUIDError+ deriving (Eq, Ord)++instance Show TypeIDError where+ show :: TypeIDError -> String+ show (TypeIDErrorPrefixTooLong n)+ = concat ["Prefix with ", show n, " characters is too long!"]+ show TypeIDExtraSeparator+ = "The underscore separator should not be present if the prefix is empty!"+ show (TypeIDErrorPrefixInvalidChar c)+ = concat ["Prefix contains invalid character ", show c, "!"]+ show (TypeIDErrorAlreadyHasPrefix prefix)+ = concat ["TypeID already has prefix ", show prefix, "!"]+ show (TypeIDErrorPrefixMismatch expPrefix actPrefix)+ = concat [ "Expected prefix ", show expPrefix, " but got "+ , show actPrefix, "!" ]+ show TypeIDErrorUUIDError+ = "Invalid UUID part!"+ {-# INLINE show #-}++instance Exception TypeIDError
src/Data/TypeID/Internal.hs view
@@ -3,52 +3,251 @@ import Control.Exception import Control.Monad import Control.Monad.ST+import Data.Aeson.Types hiding (Array, String) import Data.Array import Data.Array.ST import Data.Array.Unsafe (unsafeFreeze)+import Data.Bifunctor import Data.Bits import Data.ByteString.Lazy (ByteString) import qualified Data.ByteString.Lazy as BSL+import Data.Char+import Data.String import Data.Text (Text)+import qualified Data.Text as T+import Data.Text.Encoding+import Data.TypeID.Class+import Data.TypeID.Error import Data.UUID.V7 (UUID(..))+import qualified Data.UUID.V7 as UUID import Data.Word -- | The constructor is not exposed to the public API to prevent generating -- invalid @TypeID@s. -- -- Note that the 'Show' instance is for debugging purposes only. To pretty-print--- a 'TypeID', use 'toString', 'toText' or 'toByteString'.+-- a 'TypeID', use 'toString', 'toText' or 'toByteString'. However, this+-- behaviour will be changed in the next major version as it is not useful. By+-- then, the 'Show' instance will be the same as 'toString'. data TypeID = TypeID { _getPrefix :: Text , _getUUID :: UUID } deriving (Eq, Ord, Show) --- | Errors from parsing a @TypeID@.-data TypeIDError = TypeIDErrorPrefixTooLong Int- | TypeIDExtraSeparator- | TypeIDErrorPrefixInvalidChar Char- | TypeIDErrorAlreadyHasPrefix Text- | TypeIDErrorPrefixMismatch Text Text- | TypeIDErrorUUIDError- deriving (Eq, Ord)+instance ToJSON TypeID where+ toJSON :: TypeID -> Value+ toJSON = toJSON . toText+ {-# INLINE toJSON #-} -instance Show TypeIDError where- show :: TypeIDError -> String- show (TypeIDErrorPrefixTooLong n)- = concat ["Prefix with ", show n, " characters is too long!"]- show TypeIDExtraSeparator- = "The underscore separator should not be present if the prefix is empty!"- show (TypeIDErrorPrefixInvalidChar c)- = concat ["Prefix contains invalid character ", show c, "!"]- show (TypeIDErrorAlreadyHasPrefix prefix)- = concat ["TypeID already has prefix ", show prefix, "!"]- show (TypeIDErrorPrefixMismatch expPrefix actPrefix)- = concat [ "Expected prefix ", show expPrefix, " but got "- , show actPrefix, "!" ]- show TypeIDErrorUUIDError- = "Invalid UUID part!"- {-# INLINE show #-}+instance FromJSON TypeID where+ parseJSON :: Value -> Parser TypeID+ parseJSON str = do+ s <- parseJSON str+ case parseText s of+ Left err -> fail $ show err+ Right tid -> pure tid+ {-# INLINE parseJSON #-} -instance Exception TypeIDError+instance ToJSONKey TypeID where+ toJSONKey :: ToJSONKeyFunction TypeID+ toJSONKey = toJSONKeyText toText+ {-# INLINE toJSONKey #-}++instance FromJSONKey TypeID where+ fromJSONKey :: FromJSONKeyFunction TypeID+ fromJSONKey = FromJSONKeyTextParser \t -> case parseText t of+ Left err -> fail $ show err+ Right tid -> pure tid+ {-# INLINE fromJSONKey #-}++-- | Get the prefix, 'UUID', and timestamp of a 'TypeID'.+instance IDType TypeID where+ getPrefix :: TypeID -> Text+ getPrefix = _getPrefix+ {-# INLINE getPrefix #-}++ getUUID :: TypeID -> UUID+ getUUID = _getUUID+ {-# INLINE getUUID #-}++ getTime :: TypeID -> Word64+ getTime = UUID.getTime . getUUID+ {-# INLINE getTime #-}++-- | Conversion between 'TypeID' and 'String'/'Text'/'ByteString'.+instance IDConv TypeID where+ string2ID :: String -> Either TypeIDError TypeID+ string2ID = parseString+ {-# INLINE string2ID #-}++ text2ID :: Text -> Either TypeIDError TypeID+ text2ID = parseText+ {-# INLINE text2ID #-}++ byteString2ID :: ByteString -> Either TypeIDError TypeID+ byteString2ID = parseByteString+ {-# INLINE byteString2ID #-}++ id2String :: TypeID -> String+ id2String = toString+ {-# INLINE id2String #-}++ id2Text :: TypeID -> Text+ id2Text = toText+ {-# INLINE id2Text #-}++ id2ByteString :: TypeID -> ByteString+ id2ByteString = toByteString+ {-# INLINE id2ByteString #-}++-- | Generate a new 'TypeID' 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 :: Text -> IO TypeID+genTypeID = fmap head . (`genTypeIDs` 1)+{-# INLINE genTypeID #-}++-- | Generate n 'TypeID's from a prefix.+--+-- It tries its best to generate 'TypeID's at the same timestamp, but it may not+-- be possible if we are asking too many 'UUID's at the same time.+--+-- It is guaranteed that the first 32768 'TypeID's are generated at the same+-- timestamp.+genTypeIDs :: Text -> Word16 -> IO [TypeID]+genTypeIDs prefix n = case checkPrefix prefix of+ Nothing -> map (TypeID prefix) <$> UUID.genUUIDs n+ Just err -> throwIO err+{-# INLINE genTypeIDs #-}++-- | The nil 'TypeID'.+nil :: TypeID+nil = TypeID "" UUID.nil+{-# INLINE nil #-}+{-# DEPRECATED nil "Use nilTypeID instead." #-}++-- | The nil 'TypeID'.+nilTypeID :: TypeID+nilTypeID = TypeID "" UUID.nil+{-# INLINE nilTypeID #-}++-- | Obtain a 'TypeID' from a prefix and a 'UUID'.+decorate :: Text -> UUID -> Either TypeIDError TypeID+decorate prefix uuid = case checkPrefix prefix of+ Nothing -> Right $ TypeID prefix uuid+ Just err -> Left err+{-# INLINE decorate #-}+{-# DEPRECATED decorate "Use decorateTypeID instead." #-}++-- | Obtain a 'TypeID' from a prefix and a 'UUID'.+decorateTypeID :: Text -> UUID -> Either TypeIDError TypeID+decorateTypeID prefix uuid = case checkPrefix prefix of+ Nothing -> Right $ TypeID prefix uuid+ Just err -> Left err+{-# INLINE decorateTypeID #-}++-- | Pretty-print a 'TypeID'. It is 'id2String' with concrete type.+toString :: TypeID -> String+toString (TypeID prefix (UUID bs)) = if T.null prefix+ then suffixEncode bs+ else T.unpack prefix ++ "_" ++ suffixEncode bs+{-# INLINE toString #-}++-- | Pretty-print a 'TypeID' to strict 'Text'. It is 'id2Text' with concrete+-- type.+toText :: TypeID -> Text+toText (TypeID prefix (UUID bs)) = if T.null prefix+ then T.pack (suffixEncode bs)+ else prefix <> "_" <> T.pack (suffixEncode bs)+{-# INLINE toText #-}++-- | Pretty-print a 'TypeID' to lazy 'ByteString'. It is 'id2ByteString' with+-- concrete type.+toByteString :: TypeID -> ByteString+toByteString = fromString . toString+{-# INLINE toByteString #-}++-- | Parse a 'TypeID' from its 'String' representation. It is 'string2ID' with+-- concrete type.+parseString :: String -> Either TypeIDError TypeID+parseString str = case span (/= '_') str of+ ("", _) -> Left TypeIDExtraSeparator+ (_, "") -> TypeID "" <$> decodeUUID bs+ (prefix, _ : suffix) -> do+ let prefix' = T.pack prefix+ let bs = fromString suffix+ case checkPrefix prefix' of+ Nothing -> TypeID prefix' <$> decodeUUID bs+ Just err -> Left err+ where+ bs = fromString str++-- | Parse a 'TypeID' from its string representation as a strict 'Text'. It is+-- 'text2ID' with concrete type.+parseText :: Text -> Either TypeIDError TypeID+parseText text = case second T.uncons $ T.span (/= '_') text of+ ("", _) -> Left TypeIDExtraSeparator+ (_, Nothing) -> TypeID "" <$> decodeUUID bs+ (prefix, Just (_, suffix)) -> do+ let bs = BSL.fromStrict $ encodeUtf8 suffix+ case checkPrefix prefix of+ Nothing -> TypeID prefix <$> decodeUUID bs+ Just err -> Left err+ where+ bs = BSL.fromStrict $ encodeUtf8 text++-- | Parse a 'TypeID' from its string representation as a lazy 'ByteString'. It+-- is 'byteString2ID' with concrete type.+parseByteString :: ByteString -> Either TypeIDError TypeID+parseByteString bs = case second BSL.uncons $ BSL.span (/= 95) bs of+ ("", _) -> Left TypeIDExtraSeparator+ (_, Nothing) -> TypeID "" <$> decodeUUID bs+ (prefix, Just (_, suffix)) -> do+ let prefix' = decodeUtf8 $ BSL.toStrict prefix+ case checkPrefix prefix' of+ Nothing -> TypeID prefix' <$> decodeUUID suffix+ Just err -> Left err++-- | Parse a 'TypeID' from the given prefix and the 'String' representation of a+-- suffix.+parseStringWithPrefix :: Text -> String -> Either TypeIDError TypeID+parseStringWithPrefix prefix str = case parseString str of+ Right (TypeID "" uuid) -> decorate prefix uuid+ Right (TypeID p _) -> Left $ TypeIDErrorAlreadyHasPrefix p+ Left err -> Left err+{-# INLINE parseStringWithPrefix #-}+{-# DEPRECATED parseStringWithPrefix "Use 'parseString' and 'decorate' instead" #-}++-- | Parse a 'TypeID' from the given prefix and the string representation of a+-- suffix as a strict 'Text'.+parseTextWithPrefix :: Text -> Text -> Either TypeIDError TypeID+parseTextWithPrefix prefix text = case parseText text of+ Right (TypeID "" uuid) -> decorate prefix uuid+ Right (TypeID p _) -> Left $ TypeIDErrorAlreadyHasPrefix p+ Left err -> Left err+{-# INLINE parseTextWithPrefix #-}+{-# DEPRECATED parseTextWithPrefix "Use 'parseText' and 'decorate' instead" #-}++-- | Parse a 'TypeID' from the given prefix and the string representation of a+-- suffix as a lazy 'ByteString'.+parseByteStringWithPrefix :: Text -> ByteString -> Either TypeIDError TypeID+parseByteStringWithPrefix prefix bs = case parseByteString bs of+ Right (TypeID "" uuid) -> decorate prefix uuid+ Right (TypeID p _) -> Left $ TypeIDErrorAlreadyHasPrefix p+ Left err -> Left err+{-# INLINE parseByteStringWithPrefix #-}+{-# DEPRECATED parseByteStringWithPrefix "Use 'parseByteString' and 'decorate' instead" #-}++-- | 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)+ | otherwise + = case T.uncons (T.dropWhile (liftM2 (&&) isLower isAscii) prefix) of+ Nothing -> Nothing+ Just (c, _) -> Just $ TypeIDErrorPrefixInvalidChar c+{-# INLINE checkPrefix #-} -- The helpers below are verbatim translations from the official highly magical -- Go implementation.
src/Data/UUID/V7.hs view
@@ -4,19 +4,22 @@ -- Maintainer : mmzk1526@outlook.com -- Portability : GHC --+-- IMPORTANT: In the next major release (breaking change), I will unify the+-- 'UUID' type with the one from the uuid-type package.+-- -- UUIDv7 implementation. -- -- UUIDv7 is not currently present in the uuid package, therefore I have to--- make a quick patch of my own. In the future I will try to add uuid as a--- dependency and try to use the same interface.+-- make a quick patch of my own. -- -- Note that since the specification for v7 is not yet finalised, this module's -- implementation may change in the future according to the potential -- adjustments in the specification. module Data.UUID.V7- ( + ( -- * Data type UUID(..)+ , unUUID -- * UUID generation , nil , genUUID@@ -38,6 +41,7 @@ import Control.Monad.Trans.Maybe import Data.Aeson.Types hiding (String) import Data.Array+import Data.Binary import Data.Binary.Get import Data.Binary.Put import Data.Bits@@ -49,7 +53,6 @@ import qualified Data.Text as T import Data.Text.Encoding import Data.Time.Clock.POSIX-import Data.Word import System.Entropy import System.IO.Unsafe (unsafePerformIO) @@ -57,9 +60,18 @@ -- -- Note that the 'Show' instance is for debugging purposes only. To pretty-print -- a 'UUID'v7, use 'toString', 'toText' or 'toByteString'.-newtype UUID = UUID { unUUID :: ByteString }+--+-- The 'UUID' constructor will be hidden in favour of the 'Binary' instance in+-- the future.+newtype UUID = UUID ByteString deriving (Eq, Ord, Show) +-- | Deprecated. Use the 'Binary' instance instead.+unUUID :: UUID -> ByteString+unUUID (UUID bs) = bs+{-# INLINE unUUID #-}+{-# DEPRECATED unUUID "Use the 'Binary' instance instead" #-}+ instance ToJSON UUID where toJSON :: UUID -> Value toJSON = toJSON . toString@@ -74,7 +86,28 @@ Just uuid -> pure uuid {-# INLINE parseJSON #-} --- | Pretty-print a 'UUID'v7. +instance ToJSONKey UUID where+ toJSONKey :: ToJSONKeyFunction UUID+ toJSONKey = toJSONKeyText toText+ {-# INLINE toJSONKey #-}++instance FromJSONKey UUID where+ fromJSONKey :: FromJSONKeyFunction UUID+ fromJSONKey = FromJSONKeyTextParser \t -> case parseText t of+ Nothing -> fail "Invalid UUID"+ Just uuid -> pure uuid+ {-# INLINE fromJSONKey #-}++instance Binary UUID where+ put :: UUID -> Put+ put (UUID bs) = putLazyByteString bs+ {-# INLINE put #-}++ get :: Get UUID+ get = UUID <$> getLazyByteString 16+ {-# INLINE get #-}++-- | Pretty-print a 'UUID'v7. toString :: UUID -> String toString (UUID bs) | BSL.length bs /= 16 = "<INVALID-UUID>"@@ -163,7 +196,7 @@ w <- lift getWord8 guard (w == 45) --- | The nil UUID.+-- | The nil 'UUID'v7. nil :: UUID nil = UUID $ BSL.replicate 16 0 {-# INLINE nil #-}
test/Spec.hs view
@@ -1,51 +1,76 @@ {-# LANGUAGE DeriveAnyClass #-} {-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE DuplicateRecordFields #-} import Control.Monad import Data.Aeson import qualified Data.ByteString.Lazy as BSL-import Data.KindID (KindID)+import Data.KindID import qualified Data.KindID as KID+import Data.Map (Map)+import qualified Data.Map as M+import Data.String+import Data.Text (Text) import qualified Data.Text as T-import Data.TypeID (TypeID, TypeIDError)+import Data.TypeID+import Data.TypeID.Error import qualified Data.TypeID as TID+import Data.UUID.V7 (UUID) import qualified Data.UUID.V7 as V7 import GHC.Generics (Generic) import Test.Hspec -data TestData = TestData { name :: String- , typeid :: String- , prefix :: Maybe String- , uuid :: Maybe String }+data TestData = TestData { name :: String+ , typeid :: String+ , prefix :: Maybe Text+ , uuid :: Maybe String } deriving (Generic, FromJSON, ToJSON) +data TestDataUUID = TestDataUUID { name :: String+ , typeid :: TypeID+ , prefix :: Text+ , uuid :: UUID }+ deriving (Generic, FromJSON, ToJSON)++data Prefix = User | Post | Comment++instance ToPrefix 'User where+ type PrefixSymbol 'User = "user"++instance ToPrefix 'Post where+ type PrefixSymbol 'Post = "post"++instance ToPrefix 'Comment where+ type PrefixSymbol 'Comment = "comment"+ anyTypeIDError :: Selector TypeIDError anyTypeIDError = const True main :: IO () main = do- invalid <- BSL.readFile "test/invalid.json" >>= throwDecode :: IO [TestData]- valid <- BSL.readFile "test/valid.json" >>= throwDecode :: IO [TestData]+ invalid <- BSL.readFile "test/invalid.json" >>= throwDecode :: IO [TestData]+ valid <- BSL.readFile "test/valid.json" >>= throwDecode :: IO [TestData]+ validUUID <- BSL.readFile "test/valid.json" >>= throwDecode :: IO [TestDataUUID] hspec do describe "Generate TypeID" do it "can generate TypeID with prefix" do tid <- TID.genTypeID "mmzk"- TID.getPrefix tid `shouldBe` "mmzk"+ getPrefix tid `shouldBe` "mmzk" it "can generate TypeID without prefix" do tid <- TID.genTypeID ""- TID.getPrefix tid `shouldBe` ""+ getPrefix tid `shouldBe` "" it "can parse TypeID from String" do- case TID.parseString "mmzk_00041061050r3gg28a1c60t3gf" of+ case string2ID @TypeID "mmzk_00041061050r3gg28a1c60t3gf" of Left err -> expectationFailure $ "Parse error: " ++ show err- Right tid -> pure ()+ Right tid -> getPrefix tid `shouldBe` "mmzk" it "has the correct nil" do- Right TID.nil `shouldBe` TID.parseString "00000000000000000000000000"+ Right TID.nilTypeID `shouldBe` string2ID "00000000000000000000000000" it "can generate in batch with same timestamp and in ascending order" do tids <- TID.genTypeIDs "mmzk" 1526- all ((== "mmzk") . TID.getPrefix) tids `shouldBe` True- let timestamp = TID.getTime $ head tids- all ((== timestamp) . TID.getTime) tids `shouldBe` True+ all ((== "mmzk") . getPrefix) tids `shouldBe` True+ let timestamp = getTime $ head tids+ all ((== timestamp) . getTime) tids `shouldBe` True all (uncurry (<)) (zip tids $ tail tids) `shouldBe` True describe "Parse TypeID" do@@ -58,7 +83,7 @@ describe "can detect invalid prefix" do forM_ invalidPrefixes \(reason, prefix) -> it reason do TID.genTypeID prefix `shouldThrow` anyTypeIDError- case TID.decorate prefix V7.nil of+ case TID.decorateTypeID prefix V7.nil of Left _ -> pure () Right _ -> expectationFailure "Should not be able to decorate with invalid prefix" let invalidSuffixes = [ ("spaces", " ")@@ -71,9 +96,9 @@ , ("wrong_alphabet", "ooooooiiiiiiuuuuuuulllllll") ] describe "can detect invalid suffix" do forM_ invalidSuffixes \(reason, suffix) -> it reason do- case TID.parseStringWithPrefix "mmzk" suffix of+ case string2ID @TypeID suffix of Left _ -> pure ()- Right tid -> expectationFailure $ "Parsed TypeID: " ++ TID.toString tid+ Right tid -> expectationFailure $ "Parsed TypeID: " ++ id2String tid describe "Parse special values" do let specialValues = [ ("nil", "00000000000000000000000000", "00000000-0000-0000-0000-000000000000")@@ -82,44 +107,104 @@ , ("sixteen", "0000000000000000000000000g", "00000000-0000-0000-0000-000000000010") , ("thirty-two", "00000000000000000000000010", "00000000-0000-0000-0000-000000000020") ] forM_ specialValues \(reason, tid, uuid) -> it reason do- case TID.parseString tid of+ case string2ID @TypeID tid of Left err -> expectationFailure $ "Parse error: " ++ show err- Right tid -> V7.toString (TID.getUUID tid) `shouldBe` uuid+ Right tid -> V7.toString (KID.getUUID tid) `shouldBe` uuid + describe "TypeID valid JSON instances" do+ it "Decode and then encode should be identity" do+ tid <- TID.genTypeID "mmzk"+ tid' <- TID.genTypeID "foo"+ let mapping = M.fromList [(tid, tid')]+ let json = encode mapping+ decode json `shouldBe` Just mapping+ fmap encode (decode json :: Maybe (Map TypeID TypeID)) `shouldBe` Just json+ describe "Valid JSON value" do+ forM_ valid \(TestData name tid (Just prefix) (Just uuid)) -> it name do+ case decode (fromString $ show tid) :: Maybe TypeID of+ Nothing -> expectationFailure "Parse JSON failed!"+ Just tid -> do+ getPrefix tid `shouldBe` prefix+ V7.toString (KID.getUUID tid) `shouldBe` uuid+ describe "Valid JSON key" do+ forM_ valid \(TestData name tid (Just prefix) (Just uuid)) -> it name do+ case decode (fromString $ "{" ++ show tid ++ ":" ++ "114514" ++ "}") :: Maybe (Map TypeID Int) of+ Nothing -> expectationFailure "Parse JSON failed!"+ Just tid -> do+ let (tid', _) = M.elemAt 0 tid+ getPrefix tid' `shouldBe` prefix+ V7.toString (KID.getUUID tid') `shouldBe` uuid++ describe "TypeID invalid JSON instances" do+ describe "Invalid JSON value" do+ forM_ invalid \(TestData name tid _ _) -> it name do + case decode (fromString $ show tid) :: Maybe TypeID of+ Nothing -> pure ()+ Just tid -> expectationFailure $ "Parsed TypeID: " ++ id2String tid+ describe "Invalid JSON key" do+ forM_ invalid \(TestData name tid _ _) -> it name do + case decode (fromString $ "{" ++ show tid ++ ":" ++ "114514" ++ "}") :: Maybe (Map TypeID Int) 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 TID.parseString tid of+ case string2ID @TypeID tid of Left _ -> pure ()- Right tid -> expectationFailure $ "Parsed TypeID: " ++ TID.toString tid+ Right tid -> expectationFailure $ "Parsed TypeID: " ++ id2String tid - describe "Test valid.json" do+ describe "Test valid.json (TypeID as literal)" do forM_ valid \(TestData name tid (Just prefix) (Just uuid)) -> it name do- case TID.parseString tid of+ case string2ID @TypeID tid of Left err -> expectationFailure $ "Parse error: " ++ show err Right tid -> do- TID.getPrefix tid `shouldBe` T.pack prefix- V7.toString (TID.getUUID tid) `shouldBe` uuid+ getPrefix tid `shouldBe` prefix+ V7.toString (KID.getUUID tid) `shouldBe` uuid - describe "Generate type-level TypeID" do+ describe "Test valid.json (TypeID as JSON)" do+ forM_ validUUID \(TestDataUUID name tid prefix uuid) -> it name do+ getPrefix tid `shouldBe` prefix+ KID.getUUID tid `shouldBe` uuid++ describe "Generate type-level TypeID with 'Symbol' prefixes" do it "can generate TypeID with prefix" do- tid <- KID.genKindID @"mmzk"- KID.getPrefix tid `shouldBe` "mmzk"+ kid <- KID.genKindID @"mmzk"+ getPrefix kid `shouldBe` "mmzk" it "can generate TypeID without prefix" do- tid <- KID.genKindID @""- KID.getPrefix tid `shouldBe` ""+ kid <- KID.genKindID @""+ getPrefix kid `shouldBe` "" it "can parse TypeID from String" do- case KID.parseString @"mmzk" "mmzk_00041061050r3gg28a1c60t3gf" of+ case string2ID @(KindID "mmzk") "mmzk_00041061050r3gg28a1c60t3gf" of Left err -> expectationFailure $ "Parse error: " ++ show err- Right tid -> pure ()+ Right kid -> getPrefix kid `shouldBe` "mmzk" it "cannot parse TypeID into wrong prefix" do- case KID.parseString @"foo" "mmzk_00041061050r3gg28a1c60t3gf" of+ case string2ID @(KindID "foo") "mmzk_00041061050r3gg28a1c60t3gf" of Left err -> pure ()- Right tid -> expectationFailure $ "Parsed TypeID: " ++ KID.toString tid+ Right kid -> expectationFailure $ "Parsed TypeID: " ++ id2String kid it "has the correct nil" do- Right KID.nil `shouldBe` KID.parseString @"" "00000000000000000000000000"+ Right KID.nilKindID `shouldBe` string2ID "00000000000000000000000000" it "can generate in batch with same timestamp and in ascending order" do kids <- KID.genKindIDs @"mmzk" 1526- all ((== "mmzk") . KID.getPrefix) kids `shouldBe` True- let timestamp = KID.getTime $ head kids- all ((== timestamp) . KID.getTime) kids `shouldBe` True+ all ((== "mmzk") . getPrefix) kids `shouldBe` True+ let timestamp = getTime $ head kids+ all ((== timestamp) . getTime) kids `shouldBe` True+ all (uncurry (<)) (zip kids $ tail kids) `shouldBe` True+ + describe "Generate type-level TypeID with custom data kind prefixes" do+ it "can generate TypeID with prefix" do+ kid <- KID.genKindID @'Post+ getPrefix kid `shouldBe` "post"+ it "can parse TypeID from String" do+ case string2ID @(KindID User) "user_00041061050r3gg28a1c60t3gf" of+ Left err -> expectationFailure $ "Parse error: " ++ show err+ Right kid -> getPrefix kid `shouldBe` "user"+ it "cannot parse TypeID into wrong prefix" do+ case string2ID @(KindID Comment) "user_00041061050r3gg28a1c60t3gf" of+ Left err -> pure ()+ Right kid -> expectationFailure $ "Parsed TypeID: " ++ id2String kid+ it "can generate in batch with same timestamp and in ascending order" do+ kids <- KID.genKindIDs @'Comment 1526+ all ((== "comment") . getPrefix) kids `shouldBe` True+ let timestamp = getTime $ head kids+ all ((== timestamp) . getTime) kids `shouldBe` True all (uncurry (<)) (zip kids $ tail kids) `shouldBe` True