mmzk-typeid (empty) → 0.1.0.0
raw patch · 11 files changed
+1295/−0 lines, 11 filesdep +aesondep +arraydep +base
Dependencies added: aeson, array, base, binary, bytestring, entropy, hspec, text, time, transformers
Files
- CHANGELOG.md +13/−0
- LICENSE +21/−0
- mmzk-typeid.cabal +100/−0
- src/Data/KindID.hs +203/−0
- src/Data/KindID/Internal.hs +47/−0
- src/Data/TypeID.hs +207/−0
- src/Data/TypeID/Internal.hs +144/−0
- src/Data/UUID/V7.hs +293/−0
- test/Spec.hs +125/−0
- test/invalid.json +92/−0
- test/valid.json +50/−0
+ CHANGELOG.md view
@@ -0,0 +1,13 @@+# Revision history for mmzk-typeid++## 0.1.0.0 -- 2023-07-11++* First version. Released on an unsuspecting world.++* Implement TypeID as specified at https://github.com/jetpack-io/typeid.++* Add unit tests.++* Add type-level TypeID prefixes.++* Add `FromJSON` and `ToJSON` instances for `TypeID` and `KindID`.
+ LICENSE view
@@ -0,0 +1,21 @@+MIT License++Copyright (c) 2023 Yitang Chen++Permission is hereby granted, free of charge, to any person obtaining a copy+of this software and associated documentation files (the "Software"), to deal+in the Software without restriction, including without limitation the rights+to use, copy, modify, merge, publish, distribute, sublicense, and/or sell+copies of the Software, and to permit persons to whom the Software is+furnished to do so, subject to the following conditions:++The above copyright notice and this permission notice shall be included in all+copies or substantial portions of the Software.++THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR+IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,+FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE+AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER+LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,+OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE+SOFTWARE.
+ mmzk-typeid.cabal view
@@ -0,0 +1,100 @@+cabal-version: 2.4+name: mmzk-typeid+version: 0.1.0.0++synopsis: A TypeID implementation for Haskell+description:+ TypeID is a type-safe, K-sortable, globally unique identifier inspired by Stripe IDs.+ .+ The specification is available at https://github.com/jetpack-io/typeid.+ .+ This library supports generating and parsing speç-conforming TypeIDs, with the following additional features:+ .+ - Batch generating TypeIDs with the same 'UUID'v7 timestamp+ .+ - Encode prefixes at type-level for better type-safety+ .+ The following extensions are recommended when using this library:+ .+ > {-# LANGUAGE BlockArguments #-}+ > {-# LANGUAGE DataKinds #-}+ > {-# LANGUAGE InstanceSigs #-}+ > {-# LANGUAGE MultiWayIf #-}+ > {-# LANGUAGE OverloadedStrings #-}+ > {-# LANGUAGE TypeApplications #-}+ .+ 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+bug-reports: https://github.com/MMZK1526/mmzk-typeid/issues+license: MIT+author: Yitang Chen <mmzk1526@ic.ac.uk>+maintainer: Yitang Chen <mmzk1526@ic.ac.uk>+category: Data, UUID, TypeID+extra-source-files:+ CHANGELOG.md+ LICENSE+ test/invalid.json+ test/valid.json+++library+ exposed-modules:+ Data.KindID,+ Data.TypeID,+ Data.UUID.V7+ other-modules:+ Data.KindID.Internal,+ Data.TypeID.Internal+ default-extensions:+ BlockArguments+ DataKinds+ InstanceSigs+ MultiWayIf+ OverloadedStrings+ TypeApplications+ build-depends:+ base >=4.16 && <5,+ aeson ^>=2.1,+ array ^>=0.5,+ binary ^>=0.8.9,+ bytestring ^>= 0.11,+ entropy ^>=0.4,+ text ^>=2.0,+ transformers ^>=0.6,+ time ^>=1.11,+ hs-source-dirs: src+ default-language: Haskell2010+++test-suite test+ main-is: Spec.hs+ type: exitcode-stdio-1.0+ other-modules:+ Data.KindID,+ Data.KindID.Internal,+ Data.TypeID,+ Data.TypeID.Internal,+ Data.UUID.V7+ default-extensions:+ BlockArguments+ DataKinds+ InstanceSigs+ MultiWayIf+ OverloadedStrings+ TypeApplications+ build-depends:+ base,+ aeson,+ array,+ binary,+ bytestring,+ entropy,+ hspec ^>=2.11,+ text,+ transformers,+ time,+ hs-source-dirs:+ src+ test+ default-language: Haskell2010
+ src/Data/KindID.hs view
@@ -0,0 +1,203 @@+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE UndecidableInstances #-}++-- |+-- Module : Data.KindID+-- License : MIT+-- Maintainer : mmzk1526@outlook.com+-- Portability : GHC+--+-- 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+-- 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'.+--+-- Of course, that would require the desired prefix to be known at compile time.+-- This is actually quite common, especially when we are using one prefix for+-- one table in the database.+--+-- For example, suppose we have a function that takes a 'KindID' with the prefix+-- "user", it may have a signature like this:+-- @ f :: KindID "user" -> IO () @+--+-- Then if we try to pass in a 'KindID' with the prefix "post", the compiler+-- will complain, thus removing the runtime check and the associated overhead.+--+-- All the prefixes are type-checked at compile time, so if we try to pass in+-- invalid prefixes, the compiler (again) will complain.+--+-- This module contains functions to generate and parse these type-level TypeIDs+-- as well as conversion functions to and from the usual term-level TypeIDs.+-- These functions are usually used with a type application, e.g.+--+-- > do+-- > tid <- genKindID @"user"+-- > ...+--+module Data.KindID+ (+ -- * Data types+ KindID+ , getPrefix+ , getUUID+ , getTime+ , ValidPrefix+ -- * KindID generation+ , genKindID+ , genKindIDs+ , nil+ , decorate+ -- * Encoding & decoding+ , toString+ , toText+ , toByteString+ , parseString+ , parseText+ , parseByteString+ -- * Type-level & term-level conversion+ , toTypeID+ , 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 #-}
+ src/Data/KindID/Internal.hs view
@@ -0,0 +1,47 @@+{-# LANGUAGE ConstraintKinds #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE TypeOperators #-}+{-# LANGUAGE UndecidableInstances #-}++module Data.KindID.Internal where++import Data.Type.Bool+import Data.Type.Equality+import Data.Type.Ord+import Data.UUID.V7 (UUID)+import GHC.TypeLits hiding (Text)++-- | A TypeID with the prefix encoded at type level.+--+-- It is dubbed 'KindID' because we the prefix here is a data kind rather than+-- 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 }+ deriving (Eq, Ord, Show)++-- | A constraint for valid prefix 'Symbol's.+type ValidPrefix (prefix :: Symbol) = ( KnownSymbol prefix+ , LengthSymbol prefix < 64+ , IsLowerSymbol prefix ~ 'True )++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++type family IsLowerChar (ch :: Char) :: Bool where+ IsLowerChar ch = Compare '`' ch == LT && Compare ch '{' == LT++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
+ src/Data/TypeID.hs view
@@ -0,0 +1,207 @@+-- |+-- Module : Data.KindID+-- License : MIT+-- Maintainer : mmzk1526@outlook.com+-- Portability : GHC+--+-- An implementation of the typeid specification:+-- https://github.com/jetpack-io/typeid.+module Data.TypeID+ (+ -- * Data types+ TypeID+ , getPrefix+ , getUUID+ , getTime+ , TypeIDError(..)+ -- * TypeID generation+ , genTypeID+ , genTypeIDs+ , nil+ , decorate+ -- * Prefix validation+ , checkPrefix+ -- * Encoding & decoding+ , toString+ , toText+ , toByteString+ , parseString+ , parseText+ , parseByteString+ , parseStringWithPrefix+ , parseTextWithPrefix+ , 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.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/Internal.hs view
@@ -0,0 +1,144 @@+module Data.TypeID.Internal where++import Control.Exception+import Control.Monad+import Control.Monad.ST+import Data.Array+import Data.Array.ST+import Data.Array.Unsafe (unsafeFreeze)+import Data.Bits+import Data.ByteString.Lazy (ByteString)+import qualified Data.ByteString.Lazy as BSL+import Data.Text (Text)+import Data.UUID.V7 (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'.+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 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++-- The helpers below are verbatim translations from the official highly magical+-- Go implementation.++suffixEncode :: ByteString -> String+suffixEncode bs = (alphabet !) <$> runST do+ dest <- newArray_ (0, 25) :: ST s (STUArray s Int Word8)+ writeArray dest 0 $ (bs `BSL.index` 0 .&. 224) `shiftR` 5+ writeArray dest 1 $ bs `BSL.index` 0 .&. 31+ writeArray dest 2 $ (bs `BSL.index` 1 .&. 248) `shiftR` 3+ writeArray dest 3 $ ((bs `BSL.index` 1 .&. 7) `shiftL` 2) .|. ((bs `BSL.index` 2 .&. 192) `shiftR` 6)+ writeArray dest 4 $ (bs `BSL.index` 2 .&. 62) `shiftR` 1+ writeArray dest 5 $ ((bs `BSL.index` 2 .&. 1) `shiftL` 4) .|. ((bs `BSL.index` 3 .&. 240) `shiftR` 4)+ writeArray dest 6 $ ((bs `BSL.index` 3 .&. 15) `shiftL` 1) .|. ((bs `BSL.index` 4 .&. 128) `shiftR` 7)+ writeArray dest 7 $ (bs `BSL.index` 4 .&. 124) `shiftR` 2+ writeArray dest 8 $ ((bs `BSL.index` 4 .&. 3) `shiftL` 3) .|. ((bs `BSL.index` 5 .&. 224) `shiftR` 5)+ writeArray dest 9 $ bs `BSL.index` 5 .&. 31+ writeArray dest 10 $ (bs `BSL.index` 6 .&. 248) `shiftR` 3+ writeArray dest 11 $ ((bs `BSL.index` 6 .&. 7) `shiftL` 2) .|. ((bs `BSL.index` 7 .&. 192) `shiftR` 6)+ writeArray dest 12 $ (bs `BSL.index` 7 .&. 62) `shiftR` 1+ writeArray dest 13 $ ((bs `BSL.index` 7 .&. 1) `shiftL` 4) .|. ((bs `BSL.index` 8 .&. 240) `shiftR` 4)+ writeArray dest 14 $ ((bs `BSL.index` 8 .&. 15) `shiftL` 1) .|. ((bs `BSL.index` 9 .&. 128) `shiftR` 7)+ writeArray dest 15 $ (bs `BSL.index` 9 .&. 124) `shiftR` 2+ writeArray dest 16 $ ((bs `BSL.index` 9 .&. 3) `shiftL` 3) .|. ((bs `BSL.index` 10 .&. 224) `shiftR` 5)+ writeArray dest 17 $ bs `BSL.index` 10 .&. 31+ writeArray dest 18 $ (bs `BSL.index` 11 .&. 248) `shiftR` 3+ writeArray dest 19 $ ((bs `BSL.index` 11 .&. 7) `shiftL` 2) .|. ((bs `BSL.index` 12 .&. 192) `shiftR` 6)+ writeArray dest 20 $ (bs `BSL.index` 12 .&. 62) `shiftR` 1+ writeArray dest 21 $ ((bs `BSL.index` 12 .&. 1) `shiftL` 4) .|. ((bs `BSL.index` 13 .&. 240) `shiftR` 4)+ writeArray dest 22 $ ((bs `BSL.index` 13 .&. 15) `shiftL` 1) .|. ((bs `BSL.index` 14 .&. 128) `shiftR` 7)+ writeArray dest 23 $ (bs `BSL.index` 14 .&. 124) `shiftR` 2+ writeArray dest 24 $ ((bs `BSL.index` 14 .&. 3) `shiftL` 3) .|. ((bs `BSL.index` 15 .&. 224) `shiftR` 5)+ writeArray dest 25 $ bs `BSL.index` 15 .&. 31+ elems <$> unsafeFreeze dest+ where+ alphabet = listArray (0, 31) "0123456789abcdefghjkmnpqrstvwxyz"++suffixDecode :: ByteString -> ByteString+suffixDecode bs = BSL.pack $ runST do+ dest <- newArray_ (0, 15) :: ST s (STUArray s Int Word8)+ writeArray dest 0 $ ((table ! (bs `BSL.index` 0)) `shiftL` 5) .|. (table ! (bs `BSL.index` 1))+ writeArray dest 1 $ ((table ! (bs `BSL.index` 2)) `shiftL` 3) .|. ((table ! (bs `BSL.index` 3)) `shiftR` 2)+ writeArray dest 2 $ ((table ! (bs `BSL.index` 3)) `shiftL` 6) .|. ((table ! (bs `BSL.index` 4)) `shiftL` 1) .|. ((table ! (bs `BSL.index` 5)) `shiftR` 4)+ writeArray dest 3 $ ((table ! (bs `BSL.index` 5)) `shiftL` 4) .|. ((table ! (bs `BSL.index` 6)) `shiftR` 1)+ writeArray dest 4 $ ((table ! (bs `BSL.index` 6)) `shiftL` 7) .|. ((table ! (bs `BSL.index` 7)) `shiftL` 2) .|. ((table ! (bs `BSL.index` 8)) `shiftR` 3)+ writeArray dest 5 $ ((table ! (bs `BSL.index` 8)) `shiftL` 5) .|. (table ! (bs `BSL.index` 9))+ writeArray dest 6 $ ((table ! (bs `BSL.index` 10)) `shiftL` 3) .|. ((table ! (bs `BSL.index` 11)) `shiftR` 2)+ writeArray dest 7 $ ((table ! (bs `BSL.index` 11)) `shiftL` 6) .|. ((table ! (bs `BSL.index` 12)) `shiftL` 1) .|. ((table ! (bs `BSL.index` 13)) `shiftR` 4)+ writeArray dest 8 $ ((table ! (bs `BSL.index` 13)) `shiftL` 4) .|. ((table ! (bs `BSL.index` 14)) `shiftR` 1)+ writeArray dest 9 $ ((table ! (bs `BSL.index` 14)) `shiftL` 7) .|. ((table ! (bs `BSL.index` 15)) `shiftL` 2) .|. ((table ! (bs `BSL.index` 16)) `shiftR` 3)+ writeArray dest 10 $ ((table ! (bs `BSL.index` 16)) `shiftL` 5) .|. (table ! (bs `BSL.index` 17))+ writeArray dest 11 $ ((table ! (bs `BSL.index` 18)) `shiftL` 3) .|. (table ! (bs `BSL.index` 19)) `shiftR` 2+ writeArray dest 12 $ ((table ! (bs `BSL.index` 19)) `shiftL` 6) .|. ((table ! (bs `BSL.index` 20)) `shiftL` 1) .|. ((table ! (bs `BSL.index` 21)) `shiftR` 4)+ writeArray dest 13 $ ((table ! (bs `BSL.index` 21)) `shiftL` 4) .|. ((table ! (bs `BSL.index` 22)) `shiftR` 1)+ writeArray dest 14 $ ((table ! (bs `BSL.index` 22)) `shiftL` 7) .|. ((table ! (bs `BSL.index` 23)) `shiftL` 2) .|. ((table ! (bs `BSL.index` 24)) `shiftR` 3)+ writeArray dest 15 $ ((table ! (bs `BSL.index` 24)) `shiftL` 5) .|. (table ! (bs `BSL.index` 25))+ elems <$> unsafeFreeze dest++decodeUUID :: ByteString -> Either TypeIDError UUID+decodeUUID bs = do+ unless (BSL.length bs == 26) $ Left TypeIDErrorUUIDError+ unless (bs `BSL.index` 0 <= 55) $ Left TypeIDErrorUUIDError+ when (any ((== 0xFF) . (table !)) $ BSL.unpack bs) $ Left TypeIDErrorUUIDError+ pure . UUID $ suffixDecode bs++table :: Array Word8 Word8+table = listArray (0, 255) + [ 0xFF, 0xFF, 0xFF, 0xFF, 0xFF, 0xFF, 0xFF, 0xFF, 0xFF, 0xFF+ , 0xFF, 0xFF, 0xFF, 0xFF, 0xFF, 0xFF, 0xFF, 0xFF, 0xFF, 0xFF+ , 0xFF, 0xFF, 0xFF, 0xFF, 0xFF, 0xFF, 0xFF, 0xFF, 0xFF, 0xFF+ , 0xFF, 0xFF, 0xFF, 0xFF, 0xFF, 0xFF, 0xFF, 0xFF, 0xFF, 0xFF+ , 0xFF, 0xFF, 0xFF, 0xFF, 0xFF, 0xFF, 0xFF, 0xFF, 0x00, 0x01+ , 0x02, 0x03, 0x04, 0x05, 0x06, 0x07, 0x08, 0x09, 0xFF, 0xFF+ , 0xFF, 0xFF, 0xFF, 0xFF, 0xFF, 0xFF, 0xFF, 0xFF, 0xFF, 0xFF+ , 0xFF, 0xFF, 0xFF, 0xFF, 0xFF, 0xFF, 0xFF, 0xFF, 0xFF, 0xFF+ , 0xFF, 0xFF, 0xFF, 0xFF, 0xFF, 0xFF, 0xFF, 0xFF, 0xFF, 0xFF+ , 0xFF, 0xFF, 0xFF, 0xFF, 0xFF, 0xFF, 0xFF, 0x0A, 0x0B, 0x0C+ , 0x0D, 0x0E, 0x0F, 0x10, 0x11, 0xFF, 0x12, 0x13, 0xFF, 0x14+ , 0x15, 0xFF, 0x16, 0x17, 0x18, 0x19, 0x1A, 0xFF, 0x1B, 0x1C+ , 0x1D, 0x1E, 0x1F, 0xFF, 0xFF, 0xFF, 0xFF, 0xFF, 0xFF, 0xFF+ , 0xFF, 0xFF, 0xFF, 0xFF, 0xFF, 0xFF, 0xFF, 0xFF, 0xFF, 0xFF+ , 0xFF, 0xFF, 0xFF, 0xFF, 0xFF, 0xFF, 0xFF, 0xFF, 0xFF, 0xFF+ , 0xFF, 0xFF, 0xFF, 0xFF, 0xFF, 0xFF, 0xFF, 0xFF, 0xFF, 0xFF+ , 0xFF, 0xFF, 0xFF, 0xFF, 0xFF, 0xFF, 0xFF, 0xFF, 0xFF, 0xFF+ , 0xFF, 0xFF, 0xFF, 0xFF, 0xFF, 0xFF, 0xFF, 0xFF, 0xFF, 0xFF+ , 0xFF, 0xFF, 0xFF, 0xFF, 0xFF, 0xFF, 0xFF, 0xFF, 0xFF, 0xFF+ , 0xFF, 0xFF, 0xFF, 0xFF, 0xFF, 0xFF, 0xFF, 0xFF, 0xFF, 0xFF+ , 0xFF, 0xFF, 0xFF, 0xFF, 0xFF, 0xFF, 0xFF, 0xFF, 0xFF, 0xFF+ , 0xFF, 0xFF, 0xFF, 0xFF, 0xFF, 0xFF, 0xFF, 0xFF, 0xFF, 0xFF+ , 0xFF, 0xFF, 0xFF, 0xFF, 0xFF, 0xFF, 0xFF, 0xFF, 0xFF, 0xFF+ , 0xFF, 0xFF, 0xFF, 0xFF, 0xFF, 0xFF, 0xFF, 0xFF, 0xFF, 0xFF+ , 0xFF, 0xFF, 0xFF, 0xFF, 0xFF, 0xFF, 0xFF, 0xFF, 0xFF, 0xFF+ , 0xFF, 0xFF, 0xFF, 0xFF, 0xFF, 0xFF ]
+ src/Data/UUID/V7.hs view
@@ -0,0 +1,293 @@+-- |+-- Module : Data.KindID+-- License : MIT+-- Maintainer : mmzk1526@outlook.com+-- Portability : GHC+--+-- 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.+--+-- 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(..)+ -- * UUID generation+ , nil+ , genUUID+ , genUUIDs+ -- * Encoding & decoding+ , parseString+ , parseText+ , parseByteString+ , toString+ , toText+ , toByteString+ -- * Miscellaneous helpers+ , getTime+ , getEpochMilli+ ) where++import Control.Monad+import Control.Monad.Trans.Class+import Control.Monad.Trans.Maybe+import Data.Aeson.Types hiding (String)+import Data.Array+import Data.Binary.Get+import Data.Binary.Put+import Data.Bits+import Data.ByteString.Lazy (ByteString)+import qualified Data.ByteString.Lazy as BSL+import Data.IORef+import Data.String+import Data.Text (Text)+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)++-- | A simple wrapper around a 'ByteString' representing a UUIDv7.+--+-- 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 }+ deriving (Eq, Ord, Show)++instance ToJSON UUID where+ toJSON :: UUID -> Value+ toJSON = toJSON . toString+ {-# INLINE toJSON #-}++instance FromJSON UUID where+ parseJSON :: Value -> Parser UUID+ parseJSON str = do+ s <- parseJSON str+ case parseString s of+ Nothing -> fail "Invalid UUID"+ Just uuid -> pure uuid+ {-# INLINE parseJSON #-}++-- | Pretty-print a 'UUID'v7. +toString :: UUID -> String+toString (UUID bs)+ | BSL.length bs /= 16 = "<INVALID-UUID>"+ | otherwise = word16ToHex b0+ . word16ToHex b1+ . (('-' :) . word16ToHex b2)+ . (('-' :) . word16ToHex b3)+ . (('-' :) . word16ToHex b4)+ . (('-' :) . word16ToHex b5)+ . word16ToHex b6+ $ word16ToHex b7 ""+ where+ [b0, b1, b2, b3, b4, b5, b6, b7]+ = runGet (replicateM 8 getWord16be) bs+ hexTable+ = listArray (0, 15) "0123456789abcdef"+ word16ToHex w rem+ = let (q0, r0) = w `divMod` 16+ (q1, r1) = q0 `divMod` 16+ (q2, r2) = q1 `divMod` 16+ (q3, r3) = q2 `divMod` 16+ in hexTable ! r3 : hexTable ! r2 : hexTable ! r1 : hexTable ! r0 : rem++-- | Pretty-print a 'UUID'v7 to strict 'Text'.+toText :: UUID -> Text+toText = T.pack . toString+{-# INLINE toText #-}++-- | Pretty-print a 'UUID'v7 to lazy 'ByteString'.+toByteString :: UUID -> ByteString+toByteString = fromString . toString+{-# INLINE toByteString #-}++-- | Parse a 'UUID'v7 from its 'String' representation.+--+-- The representation is either standard or has no dashes. Does not care about+-- the case of the letters.+parseString :: String -> Maybe UUID+parseString = parseByteString . fromString+{-# INLINE parseString #-}++-- | Parse a 'UUID'v7 from its string representation as a strict 'Text'.+--+-- The representation is either standard or has no dashes. Does not care about+-- the case of the letters.+parseText :: Text -> Maybe UUID+parseText = parseByteString . BSL.fromStrict . encodeUtf8+{-# INLINE parseText #-}++-- | Parse a 'UUID'v7 from its string representation as a lazy 'ByteString'.+--+-- The representation is either standard or has no dashes. Does not care about+-- the case of the letters.+parseByteString :: ByteString -> Maybe UUID+parseByteString bs+ | BSL.length bs == 32 = UUID <$> parse False+ | BSL.length bs == 36 = UUID <$> parse True+ | otherwise = Nothing+ where+ parse hasDashes = (`runGet` bs) $ runMaybeT do+ raw1 <- lift $ replicateM 4 (liftM2 (,) getWord8 getWord8)+ seg1 <- hoistMaybe $ mapM readHexPair raw1+ when hasDashes checkDash+ raw2 <- lift $ replicateM 2 (liftM2 (,) getWord8 getWord8)+ seg2 <- hoistMaybe $ mapM readHexPair raw2+ when hasDashes checkDash+ raw3 <- lift $ replicateM 2 (liftM2 (,) getWord8 getWord8)+ seg3 <- hoistMaybe $ mapM readHexPair raw3+ when hasDashes checkDash+ raw4 <- lift $ replicateM 2 (liftM2 (,) getWord8 getWord8)+ seg4 <- hoistMaybe $ mapM readHexPair raw4+ when hasDashes checkDash+ raw5 <- lift $ replicateM 6 (liftM2 (,) getWord8 getWord8)+ seg5 <- hoistMaybe $ mapM readHexPair raw5+ pure . runPut . mapM_ putWord8 $ concat [seg1, seg2, seg3, seg4, seg5]+ readHex w+ | w >= 48 && w <= 57 = Just (w - 48)+ | w >= 65 && w <= 70 = Just (w - 55)+ | w >= 97 && w <= 102 = Just (w - 87)+ | otherwise = Nothing+ readHexPair (x, y) = do+ x' <- readHex x+ y' <- readHex y+ pure (x' * 16 + y')+ checkDash = do+ w <- lift getWord8+ guard (w == 45)++-- | The nil UUID.+nil :: UUID+nil = UUID $ BSL.replicate 16 0+{-# INLINE nil #-}++-- | Generate a 'UUID'v7.+genUUID :: IO UUID+genUUID = head <$> genUUIDs 1+{-# INLINE genUUID #-}++-- | Generate n 'UUID'v7s.+--+-- It tries its best to generate 'UUID'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 'UUID's are generated at the same+-- timestamp.+genUUIDs :: Word16 -> IO [UUID]+genUUIDs 0 = pure []+genUUIDs n = do+ timestamp <- getEpochMilli+ -- We set the first bit of the entropy to 0 to ensure that there's enough+ -- room for incrementing the sequence number.+ entropy16 <- (.&. 0x7FFF) <$> getEntropyWord16+ -- Calculate the maximum number of slots we can use for the current timestamp+ -- before the sequence number overflows.+ let getMaxSlots num seqNo = if 0xFFFF - seqNo < num+ then (0xFFFF - seqNo, 0xFFFF)+ else (num, seqNo + num)+ -- Get the sequence number corresponding to the current timestamp and the+ -- number of UUIDs we can generate.+ (n', seqNo) <- atomicModifyIORef __state__ $ \(ts, seqNo) -> if+ | ts < timestamp -> let (n', entropy16') = getMaxSlots n entropy16+ in ((timestamp, entropy16'), (n', entropy16 + 1))+ | ts > timestamp -> ((ts, seqNo), (0, 0))+ | otherwise -> let (n', entropy16') = getMaxSlots n seqNo+ in ((timestamp, entropy16'), (n', seqNo + 1))+ -- If we can't generate any UUIDs, we try again, hoping that the timestamp+ -- has changed.+ if n' == 0+ then genUUIDs n+ else do+ uuids <- forM [0..(n' - 1)] $ \curN -> do+ entropy64 <- getEntropyWord64+ pure . UUID $ runPut do+ fillTime timestamp+ fillVerAndRandA (seqNo + curN)+ fillVarAndRandB (seqNo + curN) entropy64+ if n' == n+ then pure uuids+ else (uuids ++) <$> genUUIDs (n - n')++-- | Get the current time in milliseconds since the Unix epoch.+getEpochMilli :: IO Word64+getEpochMilli = do+ t <- getPOSIXTime+ pure $ round $ t * 1000+{-# INLINE getEpochMilli #-}++-- | Get the time field (unix_ts_ms) of a 'UUID'v7.+getTime :: UUID -> Word64+getTime (UUID bs) = runGet getWord64be bs `shiftR` 16+{-# INLINE getTime #-}++-- | The global mutable state of (timestamp, sequence number).+--+-- The "NOINLINE" pragma is IMPORTANT! The logic would be flawed if it is+-- is inlined by its definition.+__state__ :: IORef (Word64, Word16)+__state__ = unsafePerformIO (newIORef (0, 0))+{-# NOINLINE __state__ #-}++-- | Fill in the 48-bit time field (unix_ts_ms) of a 'UUID'v7 with the given+-- time.+fillTime :: Word64 -> Put+fillTime timestamp = do+ let (_, p2, p1, p0) = splitWord64ToWord16s timestamp+ mapM_ putWord16be [p2, p1, p0]+{-# INLINE fillTime #-}++-- | Fill in the version and rand_a part of a 'UUID'v7 with the given sequence+-- number.+--+-- The sequence number is a 16-bit integer, of which the first 12 bits are used+-- here in rand_a, and the last 4 bits are used in rand_b. The version is 7.+fillVerAndRandA :: Word16 -> Put+fillVerAndRandA seqNo = do+ let seqNoRandA = seqNo `shiftR` 4+ let randAWithVer = seqNoRandA .|. (0x7 `shiftL` 12)+ putWord16be randAWithVer+{-# INLINE fillVerAndRandA #-}++-- | Fill in the variant and rand_b part of a 'UUID'v7 with the given sequence+-- number and random number. The variant is 2.+--+-- The sequence number is a 16-bit integer, of which the last 4 bits are used+-- here in rand_b while the first 12 bits are used in rand_a.+--+-- The random number is a 64-bit integer of which the last 58 bits are used+-- while the rest are replaced by the variant bits and the last 4 bits of the+-- sequence number.+fillVarAndRandB :: Word16 -> Word64 -> Put+fillVarAndRandB seqNo entropy = do+ let seqNoRandB = seqNo .&. 0xF+ let randBWithVar = fromIntegral (seqNoRandB .|. (0x2 `shiftL` 4))+ putWord64be $ (entropy .&. 0x3FFFFFFFFFFFFFF) .|. (randBWithVar `shiftL` 58)+{-# INLINE fillVarAndRandB #-}++splitWord64ToWord16s :: Word64 -> (Word16, Word16, Word16, Word16)+splitWord64ToWord16s n =+ let b0 = fromIntegral (n .&. 0xFFFF)+ b1 = fromIntegral ((n `shiftR` 16) .&. 0xFFFF)+ b2 = fromIntegral ((n `shiftR` 32) .&. 0xFFFF)+ b3 = fromIntegral ((n `shiftR` 48) .&. 0xFFFF)+ in (b3, b2, b1, b0)+{-# INLINE splitWord64ToWord16s #-}++getEntropyWord16 :: IO Word16+getEntropyWord16 = do+ bs <- BSL.fromStrict <$> getEntropy 2+ pure $ runGet getWord16host bs+{-# INLINE getEntropyWord16 #-}++getEntropyWord64 :: IO Word64+getEntropyWord64 = do+ bs <- BSL.fromStrict <$> getEntropy 8+ pure $ runGet getWord64host bs+{-# INLINE getEntropyWord64 #-}
+ test/Spec.hs view
@@ -0,0 +1,125 @@+{-# LANGUAGE DeriveAnyClass #-}+{-# LANGUAGE DeriveGeneric #-}++import Control.Monad+import Data.Aeson+import qualified Data.ByteString.Lazy as BSL+import Data.KindID (KindID)+import qualified Data.KindID as KID+import qualified Data.Text as T+import Data.TypeID (TypeID, TypeIDError)+import qualified Data.TypeID as TID+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 }+ deriving (Generic, FromJSON, ToJSON)++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]++ hspec do+ describe "Generate TypeID" do+ it "can generate TypeID with prefix" do+ tid <- TID.genTypeID "mmzk"+ TID.getPrefix tid `shouldBe` "mmzk"+ it "can generate TypeID without prefix" do+ tid <- TID.genTypeID ""+ TID.getPrefix tid `shouldBe` ""+ it "can parse TypeID from String" do+ case TID.parseString "mmzk_00041061050r3gg28a1c60t3gf" of+ Left err -> expectationFailure $ "Parse error: " ++ show err+ Right tid -> pure ()+ it "has the correct nil" do+ Right TID.nil `shouldBe` TID.parseString "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 (uncurry (<)) (zip tids $ tail tids) `shouldBe` True++ describe "Parse TypeID" 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+ TID.genTypeID prefix `shouldThrow` anyTypeIDError+ case TID.decorate prefix V7.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 TID.parseStringWithPrefix "mmzk" suffix of+ Left _ -> pure ()+ Right tid -> expectationFailure $ "Parsed TypeID: " ++ TID.toString 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 TID.parseString tid of+ Left err -> expectationFailure $ "Parse error: " ++ show err+ Right tid -> V7.toString (TID.getUUID tid) `shouldBe` uuid++ describe "Test invalid.json" do+ forM_ invalid \(TestData name tid _ _) -> it name do + case TID.parseString tid of+ Left _ -> pure ()+ Right tid -> expectationFailure $ "Parsed TypeID: " ++ TID.toString tid++ describe "Test valid.json" do+ forM_ valid \(TestData name tid (Just prefix) (Just uuid)) -> it name do+ case TID.parseString 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++ describe "Generate type-level TypeID" do+ it "can generate TypeID with prefix" do+ tid <- KID.genKindID @"mmzk"+ KID.getPrefix tid `shouldBe` "mmzk"+ it "can generate TypeID without prefix" do+ tid <- KID.genKindID @""+ KID.getPrefix tid `shouldBe` ""+ it "can parse TypeID from String" do+ case KID.parseString @"mmzk" "mmzk_00041061050r3gg28a1c60t3gf" of+ Left err -> expectationFailure $ "Parse error: " ++ show err+ Right tid -> pure ()+ it "cannot parse TypeID into wrong prefix" do+ case KID.parseString @"foo" "mmzk_00041061050r3gg28a1c60t3gf" of+ Left err -> pure ()+ Right tid -> expectationFailure $ "Parsed TypeID: " ++ KID.toString tid+ it "has the correct nil" do+ Right KID.nil `shouldBe` KID.parseString @"" "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 (uncurry (<)) (zip kids $ tail kids) `shouldBe` True
+ test/invalid.json view
@@ -0,0 +1,92 @@+[+ {+ "name": "prefix-uppercase",+ "typeid": "PREFIX_00000000000000000000000000",+ "description": "The prefix should be lowercase with no uppercase letters"+ },+ {+ "name": "prefix-numeric",+ "typeid": "12345_00000000000000000000000000",+ "description": "The prefix can't have numbers, it needs to be alphabetic"+ },+ {+ "name": "prefix-period",+ "typeid": "pre.fix_00000000000000000000000000",+ "description": "The prefix can't have symbols, it needs to be alphabetic"+ },+ {+ "name": "prefix-underscore",+ "typeid": "pre_fix_00000000000000000000000000",+ "description": "The prefix can't have symbols, it needs to be alphabetic"+ },+ {+ "name": "prefix-non-ascii",+ "typeid": "préfix_00000000000000000000000000",+ "description": "The prefix can only have ascii letters"+ },+ {+ "name": "prefix-spaces",+ "typeid": " prefix_00000000000000000000000000",+ "description": "The prefix can't have any spaces"+ },+ {+ "name": "prefix-64-chars",+ "typeid": "abcdefghijklmnopqrstuvwxyzabcdefghijklmnopqrstuvwxyzabcdefghijkl_00000000000000000000000000",+ "description": "The prefix can't be 64 characters, it needs to be 63 characters or less"+ },+ {+ "name": "separator-empty-prefix",+ "typeid": "_00000000000000000000000000",+ "description": "If the prefix is empty, the separator should not be there"+ },+ {+ "name": "separator-empty",+ "typeid": "_",+ "description": "A separator by itself should not be treated as the empty string"+ },+ {+ "name": "suffix-short",+ "typeid": "prefix_1234567890123456789012345",+ "description": "The suffix can't be 25 characters, it needs to be exactly 26 characters"+ },+ {+ "name": "suffix-long",+ "typeid": "prefix_123456789012345678901234567",+ "description": "The suffix can't be 27 characters, it needs to be exactly 26 characters"+ },+ {+ "name": "suffix-spaces",+ "typeid": "prefix_1234567890123456789012345 ",+ "description": "The suffix can't have any spaces"+ },+ {+ "name": "suffix-uppercase",+ "typeid": "prefix_0123456789ABCDEFGHJKMNPQRS",+ "description": "The suffix should be lowercase with no uppercase letters"+ },+ {+ "name": "suffix-hyphens",+ "typeid": "prefix_123456789-123456789-123456",+ "description": "The suffix should be lowercase with no uppercase letters"+ },+ {+ "name": "suffix-wrong-alphabet",+ "typeid": "prefix_ooooooiiiiiiuuuuuuulllllll",+ "description": "The suffix should only have letters from the spec's alphabet"+ },+ {+ "name": "suffix-ambiguous-crockford",+ "typeid": "prefix_i23456789ol23456789oi23456",+ "description": "The suffix should not have any ambiguous characters from the crockford encoding"+ },+ {+ "name": "suffix-hyphens-crockford",+ "typeid": "prefix_123456789-0123456789-0123456",+ "description": "The suffix can't ignore hyphens as in the crockford encoding"+ },+ {+ "name": "suffix-overflow",+ "typeid": "prefix_8zzzzzzzzzzzzzzzzzzzzzzzzz",+ "description": "The suffix should encode at most 128-bits"+ }+]
+ test/valid.json view
@@ -0,0 +1,50 @@+[+ {+ "name": "nil",+ "typeid": "00000000000000000000000000",+ "prefix": "",+ "uuid": "00000000-0000-0000-0000-000000000000"+ },+ {+ "name": "one",+ "typeid": "00000000000000000000000001",+ "prefix": "",+ "uuid": "00000000-0000-0000-0000-000000000001"+ },+ {+ "name": "ten",+ "typeid": "0000000000000000000000000a",+ "prefix": "",+ "uuid": "00000000-0000-0000-0000-00000000000a"+ },+ {+ "name": "sixteen",+ "typeid": "0000000000000000000000000g",+ "prefix": "",+ "uuid": "00000000-0000-0000-0000-000000000010"+ },+ {+ "name": "thirty-two",+ "typeid": "00000000000000000000000010",+ "prefix": "",+ "uuid": "00000000-0000-0000-0000-000000000020"+ },+ {+ "name": "max-valid",+ "typeid": "7zzzzzzzzzzzzzzzzzzzzzzzzz",+ "prefix": "",+ "uuid": "ffffffff-ffff-ffff-ffff-ffffffffffff"+ },+ {+ "name": "valid-alphabet",+ "typeid": "prefix_0123456789abcdefghjkmnpqrs",+ "prefix": "prefix",+ "uuid": "0110c853-1d09-52d8-d73e-1194e95b5f19"+ },+ {+ "name": "valid-uuidv7",+ "typeid": "prefix_01h455vb4pex5vsknk084sn02q",+ "prefix": "prefix",+ "uuid": "01890a5d-ac96-774b-bcce-b302099a8057"+ }+]