diff --git a/CHANGELOG.md b/CHANGELOG.md new file mode 100644 --- /dev/null +++ b/CHANGELOG.md @@ -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`. diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -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. diff --git a/mmzk-typeid.cabal b/mmzk-typeid.cabal new file mode 100644 --- /dev/null +++ b/mmzk-typeid.cabal @@ -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 +maintainer: Yitang Chen +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 diff --git a/src/Data/KindID.hs b/src/Data/KindID.hs new file mode 100644 --- /dev/null +++ b/src/Data/KindID.hs @@ -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 #-} diff --git a/src/Data/KindID/Internal.hs b/src/Data/KindID/Internal.hs new file mode 100644 --- /dev/null +++ b/src/Data/KindID/Internal.hs @@ -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 diff --git a/src/Data/TypeID.hs b/src/Data/TypeID.hs new file mode 100644 --- /dev/null +++ b/src/Data/TypeID.hs @@ -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 #-} diff --git a/src/Data/TypeID/Internal.hs b/src/Data/TypeID/Internal.hs new file mode 100644 --- /dev/null +++ b/src/Data/TypeID/Internal.hs @@ -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 ] diff --git a/src/Data/UUID/V7.hs b/src/Data/UUID/V7.hs new file mode 100644 --- /dev/null +++ b/src/Data/UUID/V7.hs @@ -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 = "" + | 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 #-} diff --git a/test/Spec.hs b/test/Spec.hs new file mode 100644 --- /dev/null +++ b/test/Spec.hs @@ -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 diff --git a/test/invalid.json b/test/invalid.json new file mode 100644 --- /dev/null +++ b/test/invalid.json @@ -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" + } +] diff --git a/test/valid.json b/test/valid.json new file mode 100644 --- /dev/null +++ b/test/valid.json @@ -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" + } +]