TypeID.hs

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