mmzk-typeid 0.3.0.1 → 0.3.1.0

raw patch · 11 files changed

+357/−59 lines, 11 filesPVP ok

version bump matches the API change (PVP)

API changes (from Hackage documentation)

Files

• CHANGELOG.md +13/−0
• mmzk-typeid.cabal +3/−3
• src/Data/KindID.hs +6/−0
• src/Data/KindID/Internal.hs +79/−2
• src/Data/KindID/Unsafe.hs +6/−1
• src/Data/TypeID.hs +7/−1
• src/Data/TypeID/Class.hs +46/−8
• src/Data/TypeID/Internal.hs +142/−28
• src/Data/TypeID/Unsafe.hs +6/−1
• src/Data/UUID/V7.hs +1/−0
• test/Spec.hs +48/−15

@@ -1,6 +1,19 @@ # Revision history for mmzk-typeid  +## 0.3.1.0 -- 2023-07-23++* Add `parseStringM`, `parseTextM`, and `parseByteStringM` to `IDConv`.+  * Instead of returning an `Either`, they throw an exception when the input is+    invalid.++* Add unsafe methods to `IDConv`.++* Implement `Storable` and `Binary` instances for `TypeID` and `KindID`.+  * These instances are experimental since the specification does not propose+    any serialisation format.++ ## 0.3.0.1 -- 2023-07-18  * Add a version upper-bound for 'uuid-types'.

@@ -1,14 +1,14 @@ cabal-version:      2.4 name:               mmzk-typeid-version:            0.3.0.1+version:            0.3.1.0  synopsis:           A TypeID implementation for Haskell description:-  TypeID is a type-safe, K-sortable, globally unique identifier inspired by Stripe IDs.+  '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:+  This library supports generating and parsing speç-conforming 'TypeID's, with the following additional features:   .     - Batch generating 'TypeID's with the same UUIDv7 timestamp   .

@@ -65,6 +65,9 @@   , parseString   , parseText   , parseByteString+  , parseStringM+  , parseTextM+  , parseByteStringM   -- * Encoding & decoding (class methods)   , id2String   , id2Text@@ -72,6 +75,9 @@   , string2ID   , text2ID   , byteString2ID+  , string2IDM+  , text2IDM+  , byteString2IDM   -- * Type-level & term-level conversion   , toTypeID   , fromTypeID

@@ -12,6 +12,7 @@ import           Control.Monad import           Control.Monad.IO.Class import           Data.Aeson.Types hiding (String)+import           Data.Binary import           Data.ByteString.Lazy (ByteString) import           Data.Hashable import           Data.Proxy@@ -24,7 +25,7 @@ import qualified Data.TypeID.Internal as TID import           Data.UUID.Types.Internal (UUID(..)) import qualified Data.UUID.V7 as V7-import           Data.Word+import           Foreign import           GHC.TypeLits (symbolVal)  -- | A TypeID with the prefix encoded at type level.@@ -80,7 +81,45 @@       Right kid -> pure kid     {-# INLINE fromJSONKey #-} +-- | See The 'Binary' instance of 'TypeID'. instance (ToPrefix prefix, ValidPrefix (PrefixSymbol prefix))+  => Binary (KindID prefix) where+    put :: KindID prefix -> Put+    put = put . toTypeID+    {-# INLINE put #-}++    get :: Get (KindID prefix)+    get = do+      tid <- get :: Get TypeID+      case fromTypeID tid of+        Nothing  -> fail "Binary: Prefix mismatch"+        Just kid -> pure kid+    {-# INLINE get #-}++-- | Similar to the 'Binary' instance, but the 'UUID' is stored in host endian.+instance (ToPrefix prefix, ValidPrefix (PrefixSymbol prefix))+  => Storable (KindID prefix) where+    sizeOf :: KindID prefix -> Int+    sizeOf = sizeOf . toTypeID+    {-# INLINE sizeOf #-}++    alignment :: KindID prefix -> Int+    alignment = alignment . toTypeID+    {-# INLINE alignment #-}++    peek :: Ptr (KindID prefix) -> IO (KindID prefix)+    peek ptr = do+      tid <- peek $ castPtr ptr :: IO TypeID+      case fromTypeID tid of+        Nothing  -> fail "Storable: Prefix mismatch"+        Just kid -> pure kid+    {-# INLINE peek #-}++    poke :: Ptr (KindID prefix) -> KindID prefix -> IO ()+    poke ptr = poke (castPtr ptr) . toTypeID+    {-# INLINE poke #-}++instance (ToPrefix prefix, ValidPrefix (PrefixSymbol prefix))   => Hashable (KindID prefix) where     hashWithSalt :: Int -> KindID prefix -> Int     hashWithSalt salt = hashWithSalt salt . toTypeID@@ -128,6 +167,18 @@     id2ByteString = toByteString     {-# INLINE id2ByteString #-} +    unsafeString2ID :: String -> KindID prefix+    unsafeString2ID = unsafeParseString+    {-# INLINE unsafeString2ID #-}++    unsafeText2ID :: Text -> KindID prefix+    unsafeText2ID = unsafeParseText+    {-# INLINE unsafeText2ID #-}++    unsafeByteString2ID :: ByteString -> KindID prefix+    unsafeByteString2ID = unsafeParseByteString+    {-# INLINE unsafeByteString2ID #-}+ -- | Generate 'KindID's. instance (ToPrefix prefix, ValidPrefix (PrefixSymbol prefix))   => IDGen (KindID prefix) where@@ -153,7 +204,7 @@     checkID_ _ = checkKindID     {-# INLINE checkID_ #-} -    checkIDWithEnv_ :: MonadIO m +    checkIDWithEnv_ :: MonadIO m                     => Proxy (KindID prefix)                     -> KindID prefix                     -> m (Maybe TypeIDError)@@ -278,6 +329,32 @@                        (getPrefix tid)     Just kid -> pure kid {-# INLINE parseByteString #-}++-- | Parse a 'KindID' from its 'String' representation, throwing an error when+-- the parsing fails. It is 'string2IDM' with concrete type.+parseStringM :: (ToPrefix prefix, ValidPrefix (PrefixSymbol prefix), MonadIO m)+             => String -> m (KindID prefix)+parseStringM = string2IDM+{-# INLINE parseStringM #-}++-- | Parse a 'KindID' from its string representation as a strict 'Text',+-- throwing an error when the parsing fails. It is 'text2IDM' with concrete+-- type.+parseTextM :: (ToPrefix prefix, ValidPrefix (PrefixSymbol prefix), MonadIO m)+           => Text -> m (KindID prefix)+parseTextM = text2IDM+{-# INLINE parseTextM #-}++-- | Parse a 'KindID' from its string representation as a lazy 'ByteString',+-- throwing an error when the parsing fails. It is 'byteString2IDM' with+-- concrete type.+parseByteStringM :: ( ToPrefix prefix+                    , ValidPrefix (PrefixSymbol prefix)+                    , MonadIO m )+                 => ByteString+                 -> m (KindID prefix)+parseByteStringM = byteString2IDM+{-# INLINE parseByteStringM #-}  -- | Check if the prefix is valid and the suffix 'UUID' has the correct v7 -- version and variant.

@@ -8,12 +8,17 @@ -- module Data.KindID.Unsafe   (-  -- * Unsafe 'KindID' decoding+  -- * Unsafe 'KindID' decoding ('KindID'-specific)     unsafeParseString   , unsafeParseText   , unsafeParseByteString+  -- * Unsafe 'KindID' decoding (class methods)+  , unsafeString2ID+  , unsafeText2ID+  , unsafeByteString2ID   -- * Unsafe conversion   , unsafeFromTypeID   ) where  import           Data.KindID.Internal+import           Data.TypeID.Class

@@ -4,7 +4,7 @@ -- Maintainer  : mmzk1526@outlook.com -- Portability : GHC ----- An implementation of the typeid specification:+-- An implementation of the TypeID specification: -- https://github.com/jetpack-io/typeid. -- module Data.TypeID@@ -39,6 +39,9 @@   , parseString   , parseText   , parseByteString+  , parseStringM+  , parseTextM+  , parseByteStringM   -- * Encoding & decoding (class methods)   , id2String   , id2Text@@ -46,6 +49,9 @@   , string2ID   , text2ID   , byteString2ID+  , string2IDM+  , text2IDM+  , byteString2IDM   ) where  import           Data.TypeID.Class

@@ -25,10 +25,12 @@   , genIDs   , checkID   , checkIDWithEnv+  -- * Helper types   , GenFunc(..)   , ResWithErr(..)   ) where +import           Control.Exception import           Control.Monad.IO.Class import           Data.ByteString.Lazy (ByteString) import           Data.Kind (Type)@@ -38,12 +40,12 @@ import           Data.UUID.V7 (UUID) import           Data.Word --- | A constraint synonym for a TypeID-ish identifier type that supports ID--- generation and string conversion.+-- | A constraint synonym for a 'Data.TypeID.TypeID'-ish identifier type that+-- supports ID generation and string conversion. type TypeIDLike a = (IDType a, IDConv a, IDGen a) --- | A type class for a TypeID-ish identifier type, which has a 'Text' prefix--- and a 'UUID' suffix.+-- | A type class for a 'Data.TypeID.TypeID'-ish identifier type, which has a+-- 'Text' prefix and a 'UUID' suffix. class IDType a where   -- | Get the prefix of the identifier.   getPrefix :: a -> Text@@ -55,8 +57,8 @@   -- timestamp-based.   getTime :: a -> Word64 --- | A type class for converting between a TypeID-ish identifier type and some--- string representations.+-- | A type class for converting between a 'Data.TypeID.TypeID'-ish identifier+-- type and some string representations. class IDConv a where   -- | Parse the identifier from its 'String' representation.   string2ID :: String -> Either TypeIDError a@@ -77,6 +79,42 @@   -- | Pretty-print the identifier to a lazy 'ByteString'.   id2ByteString :: a -> ByteString +  -- | Parse the identifier from its 'String' representation, throwing an error+  -- when the parsing fails.+  string2IDM :: MonadIO m => String -> m a+  string2IDM = either (liftIO . throwIO) pure . string2ID+  {-# INLINE string2IDM #-}++  -- | Parse the identifier from its string representation as a strict 'Text',+  -- throwing an error when the parsing fails.+  text2IDM :: MonadIO m => Text -> m a+  text2IDM = either (liftIO . throwIO) pure . text2ID+  {-# INLINE text2IDM #-}++  -- | Parse the identifier from its string representation as a lazy+  -- 'ByteString', throwing an error when the parsing fails.+  byteString2IDM :: MonadIO m => ByteString -> m a+  byteString2IDM = either (liftIO . throwIO) pure . byteString2ID+  {-# INLINE byteString2IDM #-}++  -- | Parse the identifier from its 'String' representation, but crashes when+  -- the parsing fails.+  unsafeString2ID :: String -> a+  unsafeString2ID = either (error . show) id . string2ID+  {-# INLINE unsafeString2ID #-}++  -- | Parse the identifier from its string representation as a strict 'Text',+  -- but crashes when the parsing fails.+  unsafeText2ID :: Text -> a+  unsafeText2ID = either (error . show) id . text2ID+  {-# INLINE unsafeText2ID #-}++  -- | Parse the identifier from its string representation as a lazy+  -- 'ByteString', but crashes when the parsing fails.+  unsafeByteString2ID :: ByteString -> a+  unsafeByteString2ID = either (error . show) id . byteString2ID+  {-# INLINE unsafeByteString2ID #-}+ -- | Generate a new identifier with the given prefix. genID :: forall a m. (IDGen a, MonadIO m) => GenFunc (IDGenPrefix a) (m a) genID = genID_ @a @m Proxy@@ -113,7 +151,7 @@ checkIDWithEnv = checkIDWithEnv_ @a @m Proxy {-# INLINE checkIDWithEnv #-} --- | A type class for generating TypeID-ish identifiers.+-- | A type class for generating 'Data.TypeID.TypeID'-ish identifiers. -- -- The methods in this type class are not directly used since each of them has -- a dummy 'Proxy' in order to compile. We implement the methods here and use@@ -160,7 +198,7 @@ -- -- In other words, if the prefix type is already encoded in the type level, -- we are certain that the prefix is valid, so the result type does not need the--- "Either TypeIDError" part.+-- @Either TypeIDError@ part. type family ResWithErr prefix res where   ResWithErr ('Just prefix) res = Either TypeIDError res   ResWithErr 'Nothing res       = res

@@ -14,10 +14,12 @@ import           Data.Array import           Data.Array.ST import           Data.Array.Unsafe (unsafeFreeze)+import           Data.Binary import           Data.Binary.Get import           Data.Binary.Put import           Data.Bifunctor import           Data.Bits+import qualified Data.ByteString as BS import           Data.ByteString.Lazy (ByteString) import qualified Data.ByteString.Lazy as BSL import           Data.Char@@ -32,7 +34,7 @@ import           Data.UUID.Types.Internal (UUID(..)) import qualified Data.UUID.Types.Internal as UUID import qualified Data.UUID.V7 as V7-import           Data.Word+import           Foreign  -- | The constructor is not exposed to the public API to prevent generating -- invalid @TypeID@s.@@ -78,6 +80,71 @@     Right tid -> pure tid   {-# INLINE fromJSONKey #-} +-- | Since the specification does not formulate a concrete binary format, this+-- instance is based on the following custom format:+--+-- * The first 16 bytes are the suffix 'UUID' encoded in base32.+-- * The next byte is the length of the prefix encoded in a byte.+-- * The next bytes are the prefix, each letter taking 5 bits, mapping \'a\' to+--   1 and \'z\' to 26.+--+-- Note that the prefix and the 'UUID' is swapped compared to the string+-- representation, this is for the convenience of the use case where only the+-- suffix 'UUID' is required. Because of this, the sorting order may be+-- different from the string representation, but they are guaranteed to be the+-- same if the same prefix is used.+instance Binary TypeID where+  put :: TypeID -> Put+  put (TypeID prefix uuid) = do+    put uuid+    let encodedPrefix = concat5BitInts . fmap (subtract 96) . BS.unpack+                      $ encodeUtf8 prefix+    putWord8 . fromIntegral $ length encodedPrefix+    forM_ encodedPrefix putWord8+  {-# INLINE put #-}++  get :: Get TypeID+  get = do+    uuid          <- get+    len           <- getWord8+    encodedPrefix <- separate5BitInts <$> replicateM (fromIntegral len) getWord8+    when (length encodedPrefix > 63) $ fail "Binary: Prefix too long"+    when (any (liftM2 (&&) (< 1) (> 25)) encodedPrefix)+         (fail "Binary: Invalid prefix")+    pure $ TypeID (decodeUtf8 . BS.pack $ fmap (+ 96) encodedPrefix) uuid+  {-# INLINE get #-}++-- | Similar to the 'Binary' instance, but the 'UUID' is stored in host endian.+instance Storable TypeID where+  sizeOf :: TypeID -> Int+  sizeOf _ = 60+  {-# INLINE sizeOf #-}++  alignment :: TypeID -> Int+  alignment _ = 4+  {-# INLINE alignment #-}++  peek :: Ptr TypeID -> IO TypeID+  peek ptr = do+    uuid          <- peek (castPtr ptr :: Ptr UUID)+    len           <- fromIntegral <$> (peekByteOff ptr 16 :: IO Word8)+    encodedPrefix <- separate5BitInts+                 <$> forM [1..len] \ix -> peekByteOff @Word8 ptr (16 + ix)+    when (length encodedPrefix > 63) $ fail "Storable: Prefix too long"+    when (any (liftM2 (&&) (< 1) (> 25)) encodedPrefix)+         (fail "Storable: Invalid prefix")+    pure $ TypeID (decodeUtf8 . BS.pack $ fmap (+ 96) encodedPrefix) uuid+  {-# INLINE peek #-}++  poke :: Ptr TypeID -> TypeID -> IO ()+  poke ptr (TypeID prefix uuid) = do+    poke (castPtr ptr) uuid+    let encodedPrefix = concat5BitInts . fmap (subtract 96) . BS.unpack+                      $ encodeUtf8 prefix+    pokeByteOff @Word8 ptr 16 (fromIntegral $ length encodedPrefix)+    zipWithM_ (pokeByteOff ptr . (+ 16)) [1..] encodedPrefix+  {-# INLINE poke #-}+ instance Hashable TypeID where   hashWithSalt :: Int -> TypeID -> Int   hashWithSalt salt (TypeID prefix uuid)@@ -124,6 +191,18 @@   id2ByteString = toByteString   {-# INLINE id2ByteString #-} +  unsafeString2ID :: String -> TypeID+  unsafeString2ID = unsafeParseString+  {-# INLINE unsafeString2ID #-}++  unsafeText2ID :: Text -> TypeID+  unsafeText2ID = unsafeParseText+  {-# INLINE unsafeText2ID #-}++  unsafeByteString2ID :: ByteString -> TypeID+  unsafeByteString2ID = unsafeParseByteString+  {-# INLINE unsafeByteString2ID #-}+ -- | Generate 'TypeID's. instance IDGen TypeID where   type IDGenPrefix TypeID = 'Just Text@@ -296,6 +375,26 @@       Nothing  -> TypeID prefix' <$> decodeUUID suffix       Just err -> Left err +-- | Parse a 'TypeID' from its 'String' representation, throwing an error when+-- the parsing fails. It is 'string2IDM' with concrete type.+parseStringM :: MonadIO m => String -> m TypeID+parseStringM = string2IDM+{-# INLINE parseStringM #-}++-- | Parse a 'TypeID' from its string representation as a strict 'Text',+-- throwing an error when the parsing fails. It is 'text2IDM' with concrete+-- type.+parseTextM :: MonadIO m => Text -> m TypeID+parseTextM = text2IDM+{-# INLINE parseTextM #-}++-- | Parse a 'TypeID' from its string representation as a lazy 'ByteString',+-- throwing an error when the parsing fails. It is 'byteString2IDM' with+-- concrete type.+parseByteStringM :: MonadIO m => ByteString -> m TypeID+parseByteStringM = byteString2IDM+{-# INLINE parseByteStringM #-}+ -- | Check if the given prefix is a valid TypeID prefix. checkPrefix :: Text -> Maybe TypeIDError checkPrefix prefix@@ -326,22 +425,19 @@ -- parsing fails. unsafeParseString :: String -> TypeID unsafeParseString str = case span (/= '_') str of-  (_, "")              -> TypeID "" $ unsafeDecodeUUID bs+  (_, "")              -> TypeID "" . unsafeDecodeUUID $ fromString str   (prefix, _ : suffix) -> TypeID (T.pack prefix)                         . unsafeDecodeUUID $ fromString suffix-  where-    bs = fromString str {-# INLINE unsafeParseString #-}  -- | Parse a 'TypeID' from its string representation as a strict 'Text', but -- crashes when parsing fails. unsafeParseText :: Text -> TypeID unsafeParseText text = case second T.uncons $ T.span (/= '_') text of-  (_, Nothing)               -> TypeID "" $ unsafeDecodeUUID bs+  (_, Nothing)               -> TypeID "" . unsafeDecodeUUID+                              . BSL.fromStrict $ encodeUtf8 text   (prefix, Just (_, suffix)) -> TypeID prefix . unsafeDecodeUUID                               . BSL.fromStrict . encodeUtf8 $ suffix-  where-    bs = BSL.fromStrict $ encodeUtf8 text {-# INLINE unsafeParseText #-}  -- | Parse a 'TypeID' from its string representation as a lazy 'ByteString',@@ -353,6 +449,24 @@                               . unsafeDecodeUUID $ suffix {-# INLINE unsafeParseByteString #-} +concat5BitInts :: [Word8] -> [Word8]+concat5BitInts+  = reverse . toBytes+  . foldl (\(acc :: Integer) w -> acc `shiftL` 5 + fromIntegral w) 0+  where+    toBytes 0 = []+    toBytes x = fromIntegral (x .&. 0xFF) : toBytes (x `shiftR` 8)+{-# INLINE concat5BitInts #-}++separate5BitInts :: [Word8] -> [Word8]+separate5BitInts+  = reverse . toBytes+  . foldl (\(acc :: Integer) w -> acc `shiftL` 8 + fromIntegral w) 0+  where+    toBytes 0 = []+    toBytes x = fromIntegral (x .&. 0x1F) : toBytes (x `shiftR` 5)+{-# INLINE separate5BitInts #-}+ -- The helpers below are verbatim translations from the official highly magical -- Go implementation. @@ -392,39 +506,39 @@ 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))+  writeArray dest 0 $ ((base32Table ! (bs `BSL.index` 0)) `shiftL` 5) .|. (base32Table ! (bs `BSL.index` 1))+  writeArray dest 1 $ ((base32Table ! (bs `BSL.index` 2)) `shiftL` 3) .|. ((base32Table ! (bs `BSL.index` 3)) `shiftR` 2)+  writeArray dest 2 $ ((base32Table ! (bs `BSL.index` 3)) `shiftL` 6) .|. ((base32Table ! (bs `BSL.index` 4)) `shiftL` 1) .|. ((base32Table ! (bs `BSL.index` 5)) `shiftR` 4)+  writeArray dest 3 $ ((base32Table ! (bs `BSL.index` 5)) `shiftL` 4) .|. ((base32Table ! (bs `BSL.index` 6)) `shiftR` 1)+  writeArray dest 4 $ ((base32Table ! (bs `BSL.index` 6)) `shiftL` 7) .|. ((base32Table ! (bs `BSL.index` 7)) `shiftL` 2) .|. ((base32Table ! (bs `BSL.index` 8)) `shiftR` 3)+  writeArray dest 5 $ ((base32Table ! (bs `BSL.index` 8)) `shiftL` 5) .|. (base32Table ! (bs `BSL.index` 9))+  writeArray dest 6 $ ((base32Table ! (bs `BSL.index` 10)) `shiftL` 3) .|. ((base32Table ! (bs `BSL.index` 11)) `shiftR` 2)+  writeArray dest 7 $ ((base32Table ! (bs `BSL.index` 11)) `shiftL` 6) .|. ((base32Table ! (bs `BSL.index` 12)) `shiftL` 1) .|. ((base32Table ! (bs `BSL.index` 13)) `shiftR` 4)+  writeArray dest 8 $ ((base32Table ! (bs `BSL.index` 13)) `shiftL` 4) .|. ((base32Table ! (bs `BSL.index` 14)) `shiftR` 1)+  writeArray dest 9 $ ((base32Table ! (bs `BSL.index` 14)) `shiftL` 7) .|. ((base32Table ! (bs `BSL.index` 15)) `shiftL` 2) .|. ((base32Table ! (bs `BSL.index` 16)) `shiftR` 3)+  writeArray dest 10 $ ((base32Table ! (bs `BSL.index` 16)) `shiftL` 5) .|. (base32Table ! (bs `BSL.index` 17))+  writeArray dest 11 $ ((base32Table ! (bs `BSL.index` 18)) `shiftL` 3) .|. (base32Table ! (bs `BSL.index` 19)) `shiftR` 2+  writeArray dest 12 $ ((base32Table ! (bs `BSL.index` 19)) `shiftL` 6) .|. ((base32Table ! (bs `BSL.index` 20)) `shiftL` 1) .|. ((base32Table ! (bs `BSL.index` 21)) `shiftR` 4)+  writeArray dest 13 $ ((base32Table ! (bs `BSL.index` 21)) `shiftL` 4) .|. ((base32Table ! (bs `BSL.index` 22)) `shiftR` 1)+  writeArray dest 14 $ ((base32Table ! (bs `BSL.index` 22)) `shiftL` 7) .|. ((base32Table ! (bs `BSL.index` 23)) `shiftL` 2) .|. ((base32Table ! (bs `BSL.index` 24)) `shiftR` 3)+  writeArray dest 15 $ ((base32Table ! (bs `BSL.index` 24)) `shiftL` 5) .|. (base32Table ! (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+  when (any ((== 0xFF) . (base32Table !)) $ BSL.unpack bs) $ Left TypeIDErrorUUIDError   pure $ unsafeDecodeUUID bs {-# INLINE decodeUUID #-}  unsafeDecodeUUID :: ByteString -> UUID-unsafeDecodeUUID bs-  = uncurry UUID . runGet (join (liftM2 (,)) getWord64be) $ suffixDecode bs+unsafeDecodeUUID+  = uncurry UUID . runGet (join (liftM2 (,)) getWord64be) . suffixDecode {-# INLINE unsafeDecodeUUID #-} -table :: Array Word8 Word8-table = listArray (0, 255)+base32Table :: Array Word8 Word8+base32Table = 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

@@ -12,10 +12,15 @@     unsafeGenTypeID   , unsafeGenTypeID'   , unsafeGenTypeIDs-  -- * Unsafe decoding+  -- * Unsafe decoding ('TypeID'-specific)   , unsafeParseString   , unsafeParseText   , unsafeParseByteString+  -- * Unsafe decoding (class methods)+  , unsafeString2ID+  , unsafeText2ID+  , unsafeByteString2ID   ) where +import           Data.TypeID.Class import           Data.TypeID.Internal

@@ -67,6 +67,7 @@         fillVerAndRandA entropy16         fillVarAndRandB entropy16 entropy64   pure . uncurry UUID $ runGet (join (liftM2 (,)) getWord64be) bs+{-# INLINE genUUID' #-}  -- | Generate a list of 'UUID'v7s. --

@@ -4,6 +4,9 @@  import           Control.Monad import           Data.Aeson+import           Data.Binary (get, put)+import           Data.Binary.Get+import           Data.Binary.Put import qualified Data.ByteString.Lazy as BSL import           Data.KindID import           Data.KindID.Class@@ -17,6 +20,7 @@ import           Data.TypeID.Error import           Data.UUID.V7 (UUID) import qualified Data.UUID.V7 as V7+import           Foreign import           GHC.Generics (Generic) import           Test.Hspec @@ -75,30 +79,26 @@       it "can generate TypeID with prefix" do         start <- V7.getEpochMilli         tid   <- withCheck $ genID @TypeID "mmzk"-        end   <- V7.getEpochMilli         getPrefix tid `shouldBe` "mmzk"-        getTime tid `shouldSatisfy` \t -> t >= start && t <= end+        getTime tid `shouldSatisfy` \t -> t >= start       it "can generate TypeID without prefix" do         start <- V7.getEpochMilli         tid   <- withCheck $ genID @TypeID ""-        end   <- V7.getEpochMilli         getPrefix tid `shouldBe` ""-        getTime tid `shouldSatisfy` \t -> t >= start && t <= end+        getTime tid `shouldSatisfy` \t -> t >= start       it "can generate TypeID with stateless UUIDv7" do         start <- V7.getEpochMilli         tid   <- withCheck $ genID' @TypeID "mmzk"-        end   <- V7.getEpochMilli         getPrefix tid `shouldBe` "mmzk"-        getTime tid `shouldSatisfy` \t -> t >= start && t <= end+        getTime tid `shouldSatisfy` \t -> t >= start       it "can generate in batch with same timestamp and in ascending order" do         start <- V7.getEpochMilli         tids  <- withChecks $ genIDs @TypeID "mmzk" 1526-        end   <- V7.getEpochMilli         all ((== "mmzk") . getPrefix) tids `shouldBe` True         let timestamp = getTime $ head tids         all ((== timestamp) . getTime) tids `shouldBe` True         all (uncurry (<)) (zip tids $ tail tids) `shouldBe` True-        timestamp `shouldSatisfy` \t -> t >= start && t <= end+        timestamp `shouldSatisfy` \t -> t >= start       it "can parse TypeID from String" do         case string2ID @TypeID "mmzk_00041061050r3gg28a1c60t3gf" of           Left err  -> expectationFailure $ "Parse error: " ++ show err@@ -201,29 +201,26 @@       it "can generate KindID with prefix" do         start <- V7.getEpochMilli         kid   <- withCheck $ genID @(KindID "mmzk")-        end   <- V7.getEpochMilli         getPrefix kid `shouldBe` "mmzk"-        getTime kid `shouldSatisfy` \t -> start <= t && t <= end+        getTime kid `shouldSatisfy` \t -> start <= t       it "can generate KindID without prefix" do         start <- V7.getEpochMilli         kid   <- withCheck $ genID @(KindID "")-        end   <- V7.getEpochMilli         getPrefix kid `shouldBe` ""-        getTime kid `shouldSatisfy` \t -> start <= t && t <= end+        getTime kid `shouldSatisfy` \t -> start <= t       it "can generate KindID with stateless UUID v7" do         start <- V7.getEpochMilli         kid   <- withCheck $ genID' @(KindID "mmzk")-        end   <- V7.getEpochMilli         getPrefix kid `shouldBe` "mmzk"+        getTime kid `shouldSatisfy` \t -> start <= t       it "can generate in batch with same timestamp and in ascending order" do         start <- V7.getEpochMilli         kids  <- withChecks $ genIDs @(KindID "mmzk") 1526-        end   <- V7.getEpochMilli         all ((== "mmzk") . getPrefix) kids `shouldBe` True         let timestamp = getTime $ head kids         all ((== timestamp) . getTime) kids `shouldBe` True         all (uncurry (<)) (zip kids $ tail kids) `shouldBe` True-        timestamp `shouldSatisfy` \t -> start <= t && t <= end+        timestamp `shouldSatisfy` \t -> start <= t       it "can parse KindID from String" do         case string2ID @(KindID "mmzk") "mmzk_00041061050r3gg28a1c60t3gf" of           Left err  -> expectationFailure $ "Parse error: " ++ show err@@ -251,3 +248,39 @@         let timestamp = getTime $ head kids         all ((== timestamp) . getTime) kids `shouldBe` True         all (uncurry (<)) (zip kids $ tail kids) `shouldBe` True++    describe "Binary instance for TypeID and KindID" do+      it "has correct binary instance for TypeID" do+        tids <- withChecks $ genIDs @TypeID "abcdefghijklmnopqrstuvwxyz" 114+        forM_ tids \tid -> do+          let bytes = runPut (put tid)+          let tid'  = runGet get bytes+          tid' `shouldBe` tid+      it "has correct binary instance for KindID" do+        kids <- withChecks $ genIDs @(KindID "abcdefghijklmnopqrstuvwxyz") 114+        forM_ kids \kid -> do+          let bytes = runPut (put kid)+          let kid'  = runGet get bytes+          kid' `shouldBe` kid++    describe "Storable instance for TypeID and KindID" do+      it "has correct Storable instance for TypeID" do+        tids <- withChecks $ genIDs @TypeID "abcdefghijklmnopqrstuvwxyz" 114+        forM_ tids \tid -> do+          ptr   <- new tid+          tid'  <- peek ptr+          tid' `shouldBe` tid+          poke ptr tid'+          tid'' <- peek ptr+          tid'' `shouldBe` tid'+          free ptr+      it "has correct Storable instance for KindID" do+        kids <- withChecks $ genIDs @(KindID "abcdefghijklmnopqrstuvwxyz") 114+        forM_ kids \kid -> do+          ptr   <- new kid+          kid'  <- peek ptr+          kid' `shouldBe` kid+          poke ptr kid'+          kid'' <- peek ptr+          kid'' `shouldBe` kid'+          free ptr