module Data.TypeID
(
TypeID
, getPrefix
, getUUID
, getTime
, TypeIDError(..)
, genTypeID
, genTypeIDs
, nil
, decorate
, checkPrefix
, 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 :: TypeID -> Value
toJSON = forall a. ToJSON a => a -> Value
toJSON forall b c a. (b -> c) -> (a -> b) -> a -> c
. TypeID -> Text
toText
{-# INLINE toJSON #-}
instance FromJSON TypeID where
parseJSON :: Value -> Parser TypeID
parseJSON :: Value -> Parser TypeID
parseJSON Value
str = do
Text
s <- forall a. FromJSON a => Value -> Parser a
parseJSON Value
str
case Text -> Either TypeIDError TypeID
parseText Text
s of
Left TypeIDError
err -> forall (m :: * -> *) a. MonadFail m => [Char] -> m a
fail forall a b. (a -> b) -> a -> b
$ forall a. Show a => a -> [Char]
show TypeIDError
err
Right TypeID
tid -> forall (f :: * -> *) a. Applicative f => a -> f a
pure TypeID
tid
{-# INLINE parseJSON #-}
getPrefix :: TypeID -> Text
getPrefix :: TypeID -> Text
getPrefix = TypeID -> Text
_getPrefix
{-# INLINE getPrefix #-}
getUUID :: TypeID -> UUID
getUUID :: TypeID -> UUID
getUUID = TypeID -> UUID
_getUUID
{-# INLINE getUUID #-}
getTime :: TypeID -> Word64
getTime :: TypeID -> Word64
getTime (TypeID Text
_ UUID
uuid) = UUID -> Word64
UUID.getTime UUID
uuid
{-# INLINE getTime #-}
genTypeID :: Text -> IO TypeID
genTypeID :: Text -> IO TypeID
genTypeID = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall a. [a] -> a
head forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Text -> Word16 -> IO [TypeID]
`genTypeIDs` Word16
1)
{-# INLINE genTypeID #-}
genTypeIDs :: Text -> Word16 -> IO [TypeID]
genTypeIDs :: Text -> Word16 -> IO [TypeID]
genTypeIDs Text
prefix Word16
n = case Text -> Maybe TypeIDError
checkPrefix Text
prefix of
Maybe TypeIDError
Nothing -> forall a b. (a -> b) -> [a] -> [b]
map (Text -> UUID -> TypeID
TypeID Text
prefix) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Word16 -> IO [UUID]
UUID.genUUIDs Word16
n
Just TypeIDError
err -> forall e a. Exception e => e -> IO a
throwIO TypeIDError
err
{-# INLINE genTypeIDs #-}
nil :: TypeID
nil :: TypeID
nil = Text -> UUID -> TypeID
TypeID Text
"" UUID
UUID.nil
{-# INLINE nil #-}
decorate :: Text -> UUID -> Either TypeIDError TypeID
decorate :: Text -> UUID -> Either TypeIDError TypeID
decorate Text
prefix UUID
uuid = case Text -> Maybe TypeIDError
checkPrefix Text
prefix of
Maybe TypeIDError
Nothing -> forall a b. b -> Either a b
Right forall a b. (a -> b) -> a -> b
$ Text -> UUID -> TypeID
TypeID Text
prefix UUID
uuid
Just TypeIDError
err -> forall a b. a -> Either a b
Left TypeIDError
err
{-# INLINE decorate #-}
toString :: TypeID -> String
toString :: TypeID -> [Char]
toString (TypeID Text
prefix UUID
uuid) = if Text -> Bool
T.null Text
prefix
then ByteString -> [Char]
suffixEncode (UUID -> ByteString
UUID.unUUID UUID
uuid)
else Text -> [Char]
T.unpack Text
prefix forall a. [a] -> [a] -> [a]
++ [Char]
"_" forall a. [a] -> [a] -> [a]
++ ByteString -> [Char]
suffixEncode (UUID -> ByteString
UUID.unUUID UUID
uuid)
{-# INLINE toString #-}
toText :: TypeID -> Text
toText :: TypeID -> Text
toText (TypeID Text
prefix UUID
uuid) = if Text -> Bool
T.null Text
prefix
then [Char] -> Text
T.pack (ByteString -> [Char]
suffixEncode forall a b. (a -> b) -> a -> b
$ UUID -> ByteString
UUID.unUUID UUID
uuid)
else Text
prefix forall a. Semigroup a => a -> a -> a
<> Text
"_" forall a. Semigroup a => a -> a -> a
<> [Char] -> Text
T.pack (ByteString -> [Char]
suffixEncode forall a b. (a -> b) -> a -> b
$ UUID -> ByteString
UUID.unUUID UUID
uuid)
{-# INLINE toText #-}
toByteString :: TypeID -> ByteString
toByteString :: TypeID -> ByteString
toByteString = forall a. IsString a => [Char] -> a
fromString forall b c a. (b -> c) -> (a -> b) -> a -> c
. TypeID -> [Char]
toString
{-# INLINE toByteString #-}
parseString :: String -> Either TypeIDError TypeID
parseString :: [Char] -> Either TypeIDError TypeID
parseString [Char]
str = case forall a. (a -> Bool) -> [a] -> ([a], [a])
span (forall a. Eq a => a -> a -> Bool
/= Char
'_') [Char]
str of
([Char]
"", [Char]
_) -> forall a b. a -> Either a b
Left TypeIDError
TypeIDExtraSeparator
([Char]
_, [Char]
"") -> Text -> UUID -> TypeID
TypeID Text
"" forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ByteString -> Either TypeIDError UUID
decodeUUID ByteString
bs
([Char]
prefix, Char
_ : [Char]
suffix) -> do
let prefix' :: Text
prefix' = [Char] -> Text
T.pack [Char]
prefix
let bs :: ByteString
bs = forall a. IsString a => [Char] -> a
fromString [Char]
suffix
case Text -> Maybe TypeIDError
checkPrefix Text
prefix' of
Maybe TypeIDError
Nothing -> Text -> UUID -> TypeID
TypeID Text
prefix' forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ByteString -> Either TypeIDError UUID
decodeUUID ByteString
bs
Just TypeIDError
err -> forall a b. a -> Either a b
Left TypeIDError
err
where
bs :: ByteString
bs = forall a. IsString a => [Char] -> a
fromString [Char]
str
parseText :: Text -> Either TypeIDError TypeID
parseText :: Text -> Either TypeIDError TypeID
parseText Text
text = case forall (p :: * -> * -> *) b c a.
Bifunctor p =>
(b -> c) -> p a b -> p a c
second Text -> Maybe (Char, Text)
T.uncons forall a b. (a -> b) -> a -> b
$ (Char -> Bool) -> Text -> (Text, Text)
T.span (forall a. Eq a => a -> a -> Bool
/= Char
'_') Text
text of
(Text
"", Maybe (Char, Text)
_) -> forall a b. a -> Either a b
Left TypeIDError
TypeIDExtraSeparator
(Text
_, Maybe (Char, Text)
Nothing) -> Text -> UUID -> TypeID
TypeID Text
"" forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ByteString -> Either TypeIDError UUID
decodeUUID ByteString
bs
(Text
prefix, Just (Char
_, Text
suffix)) -> do
let bs :: ByteString
bs = ByteString -> ByteString
BSL.fromStrict forall a b. (a -> b) -> a -> b
$ Text -> ByteString
encodeUtf8 Text
suffix
case Text -> Maybe TypeIDError
checkPrefix Text
prefix of
Maybe TypeIDError
Nothing -> Text -> UUID -> TypeID
TypeID Text
prefix forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ByteString -> Either TypeIDError UUID
decodeUUID ByteString
bs
Just TypeIDError
err -> forall a b. a -> Either a b
Left TypeIDError
err
where
bs :: ByteString
bs = ByteString -> ByteString
BSL.fromStrict forall a b. (a -> b) -> a -> b
$ Text -> ByteString
encodeUtf8 Text
text
parseByteString :: ByteString -> Either TypeIDError TypeID
parseByteString :: ByteString -> Either TypeIDError TypeID
parseByteString ByteString
bs = case forall (p :: * -> * -> *) b c a.
Bifunctor p =>
(b -> c) -> p a b -> p a c
second ByteString -> Maybe (Word8, ByteString)
BSL.uncons forall a b. (a -> b) -> a -> b
$ (Word8 -> Bool) -> ByteString -> (ByteString, ByteString)
BSL.span (forall a. Eq a => a -> a -> Bool
/= Word8
95) ByteString
bs of
(ByteString
"", Maybe (Word8, ByteString)
_) -> forall a b. a -> Either a b
Left TypeIDError
TypeIDExtraSeparator
(ByteString
_, Maybe (Word8, ByteString)
Nothing) -> Text -> UUID -> TypeID
TypeID Text
"" forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ByteString -> Either TypeIDError UUID
decodeUUID ByteString
bs
(ByteString
prefix, Just (Word8
_, ByteString
suffix)) -> do
let prefix' :: Text
prefix' = ByteString -> Text
decodeUtf8 forall a b. (a -> b) -> a -> b
$ ByteString -> ByteString
BSL.toStrict ByteString
prefix
case Text -> Maybe TypeIDError
checkPrefix Text
prefix' of
Maybe TypeIDError
Nothing -> Text -> UUID -> TypeID
TypeID Text
prefix' forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ByteString -> Either TypeIDError UUID
decodeUUID ByteString
suffix
Just TypeIDError
err -> forall a b. a -> Either a b
Left TypeIDError
err
parseStringWithPrefix :: Text -> String -> Either TypeIDError TypeID
parseStringWithPrefix :: Text -> [Char] -> Either TypeIDError TypeID
parseStringWithPrefix Text
prefix [Char]
str = case [Char] -> Either TypeIDError TypeID
parseString [Char]
str of
Right (TypeID Text
"" UUID
uuid) -> Text -> UUID -> Either TypeIDError TypeID
decorate Text
prefix UUID
uuid
Right (TypeID Text
p UUID
_) -> forall a b. a -> Either a b
Left forall a b. (a -> b) -> a -> b
$ Text -> TypeIDError
TypeIDErrorAlreadyHasPrefix Text
p
Left TypeIDError
err -> forall a b. a -> Either a b
Left TypeIDError
err
{-# INLINE parseStringWithPrefix #-}
parseTextWithPrefix :: Text -> Text -> Either TypeIDError TypeID
parseTextWithPrefix :: Text -> Text -> Either TypeIDError TypeID
parseTextWithPrefix Text
prefix Text
text = case Text -> Either TypeIDError TypeID
parseText Text
text of
Right (TypeID Text
"" UUID
uuid) -> Text -> UUID -> Either TypeIDError TypeID
decorate Text
prefix UUID
uuid
Right (TypeID Text
p UUID
_) -> forall a b. a -> Either a b
Left forall a b. (a -> b) -> a -> b
$ Text -> TypeIDError
TypeIDErrorAlreadyHasPrefix Text
p
Left TypeIDError
err -> forall a b. a -> Either a b
Left TypeIDError
err
{-# INLINE parseTextWithPrefix #-}
parseByteStringWithPrefix :: Text -> ByteString -> Either TypeIDError TypeID
parseByteStringWithPrefix :: Text -> ByteString -> Either TypeIDError TypeID
parseByteStringWithPrefix Text
prefix ByteString
bs = case ByteString -> Either TypeIDError TypeID
parseByteString ByteString
bs of
Right (TypeID Text
"" UUID
uuid) -> Text -> UUID -> Either TypeIDError TypeID
decorate Text
prefix UUID
uuid
Right (TypeID Text
p UUID
_) -> forall a b. a -> Either a b
Left forall a b. (a -> b) -> a -> b
$ Text -> TypeIDError
TypeIDErrorAlreadyHasPrefix Text
p
Left TypeIDError
err -> forall a b. a -> Either a b
Left TypeIDError
err
{-# INLINE parseByteStringWithPrefix #-}
checkPrefix :: Text -> Maybe TypeIDError
checkPrefix :: Text -> Maybe TypeIDError
checkPrefix Text
prefix
| Text -> Int
T.length Text
prefix forall a. Ord a => a -> a -> Bool
> Int
63 = forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ Int -> TypeIDError
TypeIDErrorPrefixTooLong (Text -> Int
T.length Text
prefix)
| Bool
otherwise
= case Text -> Maybe (Char, Text)
T.uncons ((Char -> Bool) -> Text -> Text
T.dropWhile (forall (m :: * -> *) a1 a2 r.
Monad m =>
(a1 -> a2 -> r) -> m a1 -> m a2 -> m r
liftM2 Bool -> Bool -> Bool
(&&) Char -> Bool
isLower Char -> Bool
isAscii) Text
prefix) of
Maybe (Char, Text)
Nothing -> forall a. Maybe a
Nothing
Just (Char
c, Text
_) -> forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ Char -> TypeIDError
TypeIDErrorPrefixInvalidChar Char
c
{-# INLINE checkPrefix #-}