PersistValue.hs

{-# LANGUAGE CPP #-}
{-# LANGUAGE PatternSynonyms #-}

-- | This module contains an intermediate representation of values before the
-- backends serialize them into explicit database types.
--
-- @since 2.13.0.0
module Database.Persist.PersistValue
    ( PersistValue (.., PersistLiteral, PersistLiteralEscaped, PersistDbSpecific)
    , fromPersistValueText
    , LiteralType (..)
    ) where

import Control.DeepSeq
import qualified Data.Aeson as A
import Data.Bits (shiftL, shiftR)
import Data.ByteString as BS (ByteString, foldl')
import qualified Data.ByteString as BS
import qualified Data.ByteString.Base64 as B64
import qualified Data.ByteString.Char8 as BS8
import Data.Int (Int64)
import qualified Data.Scientific
import Data.Text (Text)
import qualified Data.Text as Text
import qualified Data.Text.Encoding as TE
import Data.Text.Encoding.Error (lenientDecode)
import Data.Time (Day, TimeOfDay, UTCTime)
import qualified Data.Vector as V
import Numeric (readHex, showHex)
import Web.PathPieces (PathPiece (..))

#if MIN_VERSION_aeson(2,0,0)
import qualified Data.Aeson.Key as K
import qualified Data.Aeson.KeyMap as AM
#else
import qualified Data.HashMap.Strict as AM
#endif

import Web.HttpApiData
    ( FromHttpApiData (..)
    , ToHttpApiData (..)
    , parseUrlPieceMaybe
    , readTextData
    )

-- | A raw value which can be stored in any backend and can be marshalled to
-- and from a 'PersistField'.
data PersistValue
    = PersistText Text
    | PersistByteString ByteString
    | PersistInt64 Int64
    | PersistDouble Double
    | PersistRational Rational
    | PersistBool Bool
    | PersistDay Day
    | PersistTimeOfDay TimeOfDay
    | PersistUTCTime UTCTime
    | PersistNull
    | PersistList [PersistValue]
    | PersistMap [(Text, PersistValue)]
    | -- | Intended especially for MongoDB backend
      PersistObjectId ByteString
    | -- | Intended especially for PostgreSQL backend for text arrays
      PersistArray [PersistValue]
    | -- | This constructor is used to specify some raw literal value for the
      -- backend. The 'LiteralType' value specifies how the value should be
      -- escaped. This can be used to make special, custom types avaialable
      -- in the back end.
      --
      -- @since 2.12.0.0
      PersistLiteral_ LiteralType ByteString
    deriving (Show, Read, Eq, Ord)

-- |
-- @since 2.14.4.0
instance NFData PersistValue where
    rnf val = case val of
        PersistText txt -> rnf txt
        PersistByteString bs -> rnf bs
        PersistInt64 i -> rnf i
        PersistDouble d -> rnf d
        PersistRational q -> rnf q
        PersistBool b -> rnf b
        PersistDay d -> rnf d
        PersistTimeOfDay t -> rnf t
        PersistUTCTime t -> rnf t
        PersistNull -> ()
        PersistList vals -> rnf vals
        PersistMap vals -> rnf vals
        PersistObjectId bs -> rnf bs
        PersistArray vals -> rnf vals
        PersistLiteral_ ty bs -> ty `seq` rnf bs

-- | A type that determines how a backend should handle the literal.
--
-- @since 2.12.0.0
data LiteralType
    = -- | The accompanying value will be escaped before inserting into the
      -- database. This is the correct default choice to use.
      --
      -- @since 2.12.0.0
      Escaped
    | -- | The accompanying value will not be escaped when inserting into the
      -- database. This is potentially dangerous - use this with care.
      --
      -- @since 2.12.0.0
      Unescaped
    | -- | The 'DbSpecific' constructor corresponds to the legacy
      -- 'PersistDbSpecific' constructor. We need to keep this around because
      -- old databases may have serialized JSON representations that
      -- reference this. We don't want to break the ability of a database to
      -- load rows.
      --
      -- @since 2.12.0.0
      DbSpecific
    deriving (Show, Read, Eq, Ord)

-- | This pattern synonym used to be a data constructor for the
-- 'PersistValue' type. It was changed to be a pattern so that JSON-encoded
-- database values could be parsed into their corresponding values. You
-- should not use this, and instead prefer to pattern match on
-- `PersistLiteral_` directly.
--
-- If you use this, it will overlap a patern match on the 'PersistLiteral_,
-- 'PersistLiteral', and 'PersistLiteralEscaped' patterns. If you need to
-- disambiguate between these constructors, pattern match on
-- 'PersistLiteral_' directly.
--
-- @since 2.12.0.0
pattern PersistDbSpecific :: ByteString -> PersistValue
pattern PersistDbSpecific bs <- PersistLiteral_ _ bs
    where
        PersistDbSpecific bs = PersistLiteral_ DbSpecific bs

-- | This pattern synonym used to be a data constructor on 'PersistValue',
-- but was changed into a catch-all pattern synonym to allow backwards
-- compatiblity with database types. See the documentation on
-- 'PersistDbSpecific' for more details.
--
-- @since 2.12.0.0
pattern PersistLiteralEscaped :: ByteString -> PersistValue
pattern PersistLiteralEscaped bs <- PersistLiteral_ _ bs
    where
        PersistLiteralEscaped bs = PersistLiteral_ Escaped bs

-- | This pattern synonym used to be a data constructor on 'PersistValue',
-- but was changed into a catch-all pattern synonym to allow backwards
-- compatiblity with database types. See the documentation on
-- 'PersistDbSpecific' for more details.
--
-- @since 2.12.0.0
pattern PersistLiteral :: ByteString -> PersistValue
pattern PersistLiteral bs <- PersistLiteral_ _ bs
    where
        PersistLiteral bs = PersistLiteral_ Unescaped bs

{-# DEPRECATED
    PersistDbSpecific
    "Deprecated since 2.11 because of inconsistent escaping behavior across backends. The Postgres backend escapes these values, while the MySQL backend does not. If you are using this, please switch to 'PersistLiteral_' and provide a relevant 'LiteralType' for your conversion."
    #-}

keyToText :: Key -> Text
keyFromText :: Text -> Key
#if MIN_VERSION_aeson(2,0,0)
type Key = K.Key
keyToText = K.toText
keyFromText = K.fromText
#else
type Key = Text
keyToText = id
keyFromText = id
#endif

instance ToHttpApiData PersistValue where
    toUrlPiece val =
        case fromPersistValueText val of
            Left e -> error $ Text.unpack e
            Right y -> y

instance FromHttpApiData PersistValue where
    parseUrlPiece input =
        PersistInt64
            <$> parseUrlPiece input
                <!> PersistList
            <$> readTextData input
                <!> PersistText
            <$> return input
      where
        infixl 3 <!>
        Left _ <!> y = y
        x <!> _ = x

instance PathPiece PersistValue where
    toPathPiece = toUrlPiece
    fromPathPiece = parseUrlPieceMaybe

fromPersistValueText :: PersistValue -> Either Text Text
fromPersistValueText (PersistText s) = Right s
fromPersistValueText (PersistByteString bs) =
    Right $ TE.decodeUtf8With lenientDecode bs
fromPersistValueText (PersistInt64 i) = Right $ Text.pack $ show i
fromPersistValueText (PersistDouble d) = Right $ Text.pack $ show d
fromPersistValueText (PersistRational r) = Right $ Text.pack $ show r
fromPersistValueText (PersistDay d) = Right $ Text.pack $ show d
fromPersistValueText (PersistTimeOfDay d) = Right $ Text.pack $ show d
fromPersistValueText (PersistUTCTime d) = Right $ Text.pack $ show d
fromPersistValueText PersistNull = Left "Unexpected null"
fromPersistValueText (PersistBool b) = Right $ Text.pack $ show b
fromPersistValueText (PersistList _) = Left "Cannot convert PersistList to Text"
fromPersistValueText (PersistMap _) = Left "Cannot convert PersistMap to Text"
fromPersistValueText (PersistObjectId _) = Left "Cannot convert PersistObjectId to Text"
fromPersistValueText (PersistArray _) = Left "Cannot convert PersistArray to Text"
fromPersistValueText (PersistLiteral_ _ _) = Left "Cannot convert PersistLiteral to Text"

instance A.ToJSON PersistValue where
    toJSON (PersistText t) = A.String $ Text.cons 's' t
    toJSON (PersistByteString b) = A.String $ Text.cons 'b' $ TE.decodeUtf8 $ B64.encode b
    toJSON (PersistInt64 i) = A.Number $ fromIntegral i
    toJSON (PersistDouble d) = A.Number $ Data.Scientific.fromFloatDigits d
    toJSON (PersistRational r) = A.String $ Text.pack $ 'r' : show r
    toJSON (PersistBool b) = A.Bool b
    toJSON (PersistTimeOfDay t) = A.String $ Text.pack $ 't' : show t
    toJSON (PersistUTCTime u) = A.String $ Text.pack $ 'u' : show u
    toJSON (PersistDay d) = A.String $ Text.pack $ 'd' : show d
    toJSON PersistNull = A.Null
    toJSON (PersistList l) = A.Array $ V.fromList $ map A.toJSON l
    toJSON (PersistMap m) = A.object $ map go m
      where
        go (k, v) = (keyFromText k, A.toJSON v)
    toJSON (PersistLiteral_ litTy b) =
        let
            encoded = TE.decodeUtf8 $ B64.encode b
            prefix =
                case litTy of
                    DbSpecific -> 'p'
                    Unescaped -> 'l'
                    Escaped -> 'e'
         in
            A.String $ Text.cons prefix encoded
    toJSON (PersistArray a) = A.Array $ V.fromList $ map A.toJSON a
    toJSON (PersistObjectId o) =
        A.toJSON $
            showChar 'o' $
                showHexLen 8 (bs2i four) $
                    showHexLen 16 (bs2i eight) ""
      where
        (four, eight) = BS8.splitAt 4 o

        -- taken from crypto-api
        bs2i :: ByteString -> Integer
        bs2i bs = BS.foldl' (\i b -> (i `shiftL` 8) + fromIntegral b) 0 bs
        {-# INLINE bs2i #-}

        -- showHex of n padded with leading zeros if necessary to fill d digits
        -- taken from Data.BSON
        showHexLen :: (Show n, Integral n) => Int -> n -> ShowS
        showHexLen d n = showString (replicate (d - sigDigits n) '0') . showHex n
          where
            sigDigits 0 = 1
            sigDigits n' = truncate (logBase (16 :: Double) $ fromIntegral n') + 1

instance A.FromJSON PersistValue where
    parseJSON (A.String t0) =
        case Text.uncons t0 of
            Nothing -> fail "Null string"
            Just ('p', t) ->
                either (\_ -> fail "Invalid base64") (return . PersistDbSpecific) $
                    B64.decode $
                        TE.encodeUtf8 t
            Just ('l', t) ->
                either (\_ -> fail "Invalid base64") (return . PersistLiteral) $
                    B64.decode $
                        TE.encodeUtf8 t
            Just ('e', t) ->
                either (\_ -> fail "Invalid base64") (return . PersistLiteralEscaped) $
                    B64.decode $
                        TE.encodeUtf8 t
            Just ('s', t) -> return $ PersistText t
            Just ('b', t) ->
                either (\_ -> fail "Invalid base64") (return . PersistByteString) $
                    B64.decode $
                        TE.encodeUtf8 t
            Just ('t', t) -> PersistTimeOfDay <$> readMay t
            Just ('u', t) -> PersistUTCTime <$> readMay t
            Just ('d', t) -> PersistDay <$> readMay t
            Just ('r', t) -> PersistRational <$> readMay t
            Just ('o', t) ->
                maybe
                    (fail "Invalid base64")
                    (return . PersistObjectId . i2bs (8 * 12) . fst)
                    $ headMay
                    $ readHex
                    $ Text.unpack t
            Just (c, _) -> fail $ "Unknown prefix: " ++ [c]
      where
        headMay [] = Nothing
        headMay (x : _) = Just x
        readMay t =
            case reads $ Text.unpack t of
                (x, _) : _ -> return x
                [] -> fail "Could not read"

        -- taken from crypto-api
        -- \|@i2bs bitLen i@ converts @i@ to a 'ByteString' of @bitLen@ bits (must be a multiple of 8).
        i2bs :: Int -> Integer -> ByteString
        i2bs l i =
            BS.unfoldr
                (\l' -> if l' < 0 then Nothing else Just (fromIntegral (i `shiftR` l'), l' - 8))
                (l - 8)
        {-# INLINE i2bs #-}
    parseJSON (A.Number n) =
        return $
            if fromInteger (floor n) == n
                then PersistInt64 $ floor n
                else PersistDouble $ fromRational $ toRational n
    parseJSON (A.Bool b) = return $ PersistBool b
    parseJSON A.Null = return PersistNull
    parseJSON (A.Array a) = fmap PersistList (mapM A.parseJSON $ V.toList a)
    parseJSON (A.Object o) =
        fmap PersistMap $ mapM go $ AM.toList o
      where
        go (k, v) = (,) (keyToText k) <$> A.parseJSON v