-- |
-- 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 :: 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 #-}

-- | Get the prefix of the 'TypeID'.
getPrefix :: TypeID -> Text
getPrefix :: TypeID -> Text
getPrefix = TypeID -> Text
_getPrefix
{-# INLINE getPrefix #-}

-- | Get the 'UUID' of the 'TypeID'.
getUUID :: TypeID -> UUID
getUUID :: TypeID -> UUID
getUUID = TypeID -> UUID
_getUUID
{-# INLINE getUUID #-}

-- | Get the timestamp of the 'TypeID'.
getTime :: TypeID -> Word64
getTime :: TypeID -> Word64
getTime (TypeID Text
_ UUID
uuid) = UUID -> Word64
UUID.getTime UUID
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 :: 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 #-}

-- | 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 :: 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 #-}

-- | The nil 'TypeID'.
nil :: TypeID
nil :: TypeID
nil = Text -> UUID -> TypeID
TypeID Text
"" UUID
UUID.nil
{-# INLINE nil #-}

-- | Obtain a 'TypeID' from a prefix and a 'UUID'.
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 #-}

-- | Pretty-print a 'TypeID'.
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 #-}

-- | Pretty-print a 'TypeID' to strict 'Text'.
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 #-}

-- | Pretty-print a 'TypeID' to lazy 'ByteString'.
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 #-}

-- | Parse a 'TypeID' from its 'String' representation.
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

-- | Parse a 'TypeID' from its string representation as a strict 'Text'.
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

-- | Parse a 'TypeID' from its string representation as a lazy 'ByteString'.
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

-- | Parse a 'TypeID' from the given prefix and the 'String' representation of a
-- suffix.
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 #-}

-- | 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 :: 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 #-}

-- | 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 :: 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 #-}

-- | Check if the given prefix is a valid TypeID prefix.
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 #-}