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

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

#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)]
    | PersistObjectId ByteString
    -- ^ Intended especially for MongoDB backend
    | PersistArray [PersistValue]
    -- ^ Intended especially for PostgreSQL backend for text arrays
    | PersistLiteral_ LiteralType ByteString
    -- ^ 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
    deriving (Int -> PersistValue -> ShowS
[PersistValue] -> ShowS
PersistValue -> String
(Int -> PersistValue -> ShowS)
-> (PersistValue -> String)
-> ([PersistValue] -> ShowS)
-> Show PersistValue
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [PersistValue] -> ShowS
$cshowList :: [PersistValue] -> ShowS
show :: PersistValue -> String
$cshow :: PersistValue -> String
showsPrec :: Int -> PersistValue -> ShowS
$cshowsPrec :: Int -> PersistValue -> ShowS
Show, ReadPrec [PersistValue]
ReadPrec PersistValue
Int -> ReadS PersistValue
ReadS [PersistValue]
(Int -> ReadS PersistValue)
-> ReadS [PersistValue]
-> ReadPrec PersistValue
-> ReadPrec [PersistValue]
-> Read PersistValue
forall a.
(Int -> ReadS a)
-> ReadS [a] -> ReadPrec a -> ReadPrec [a] -> Read a
readListPrec :: ReadPrec [PersistValue]
$creadListPrec :: ReadPrec [PersistValue]
readPrec :: ReadPrec PersistValue
$creadPrec :: ReadPrec PersistValue
readList :: ReadS [PersistValue]
$creadList :: ReadS [PersistValue]
readsPrec :: Int -> ReadS PersistValue
$creadsPrec :: Int -> ReadS PersistValue
Read, PersistValue -> PersistValue -> Bool
(PersistValue -> PersistValue -> Bool)
-> (PersistValue -> PersistValue -> Bool) -> Eq PersistValue
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: PersistValue -> PersistValue -> Bool
$c/= :: PersistValue -> PersistValue -> Bool
== :: PersistValue -> PersistValue -> Bool
$c== :: PersistValue -> PersistValue -> Bool
Eq, Eq PersistValue
Eq PersistValue
-> (PersistValue -> PersistValue -> Ordering)
-> (PersistValue -> PersistValue -> Bool)
-> (PersistValue -> PersistValue -> Bool)
-> (PersistValue -> PersistValue -> Bool)
-> (PersistValue -> PersistValue -> Bool)
-> (PersistValue -> PersistValue -> PersistValue)
-> (PersistValue -> PersistValue -> PersistValue)
-> Ord PersistValue
PersistValue -> PersistValue -> Bool
PersistValue -> PersistValue -> Ordering
PersistValue -> PersistValue -> PersistValue
forall a.
Eq a
-> (a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
min :: PersistValue -> PersistValue -> PersistValue
$cmin :: PersistValue -> PersistValue -> PersistValue
max :: PersistValue -> PersistValue -> PersistValue
$cmax :: PersistValue -> PersistValue -> PersistValue
>= :: PersistValue -> PersistValue -> Bool
$c>= :: PersistValue -> PersistValue -> Bool
> :: PersistValue -> PersistValue -> Bool
$c> :: PersistValue -> PersistValue -> Bool
<= :: PersistValue -> PersistValue -> Bool
$c<= :: PersistValue -> PersistValue -> Bool
< :: PersistValue -> PersistValue -> Bool
$c< :: PersistValue -> PersistValue -> Bool
compare :: PersistValue -> PersistValue -> Ordering
$ccompare :: PersistValue -> PersistValue -> Ordering
$cp1Ord :: Eq PersistValue
Ord)

-- | A type that determines how a backend should handle the literal.
--
-- @since 2.12.0.0
data LiteralType
    = Escaped
    -- ^ The accompanying value will be escaped before inserting into the
    -- database. This is the correct default choice to use.
    --
    -- @since 2.12.0.0
    | Unescaped
    -- ^ 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
    | DbSpecific
    -- ^ 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
    deriving (Int -> LiteralType -> ShowS
[LiteralType] -> ShowS
LiteralType -> String
(Int -> LiteralType -> ShowS)
-> (LiteralType -> String)
-> ([LiteralType] -> ShowS)
-> Show LiteralType
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [LiteralType] -> ShowS
$cshowList :: [LiteralType] -> ShowS
show :: LiteralType -> String
$cshow :: LiteralType -> String
showsPrec :: Int -> LiteralType -> ShowS
$cshowsPrec :: Int -> LiteralType -> ShowS
Show, ReadPrec [LiteralType]
ReadPrec LiteralType
Int -> ReadS LiteralType
ReadS [LiteralType]
(Int -> ReadS LiteralType)
-> ReadS [LiteralType]
-> ReadPrec LiteralType
-> ReadPrec [LiteralType]
-> Read LiteralType
forall a.
(Int -> ReadS a)
-> ReadS [a] -> ReadPrec a -> ReadPrec [a] -> Read a
readListPrec :: ReadPrec [LiteralType]
$creadListPrec :: ReadPrec [LiteralType]
readPrec :: ReadPrec LiteralType
$creadPrec :: ReadPrec LiteralType
readList :: ReadS [LiteralType]
$creadList :: ReadS [LiteralType]
readsPrec :: Int -> ReadS LiteralType
$creadsPrec :: Int -> ReadS LiteralType
Read, LiteralType -> LiteralType -> Bool
(LiteralType -> LiteralType -> Bool)
-> (LiteralType -> LiteralType -> Bool) -> Eq LiteralType
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: LiteralType -> LiteralType -> Bool
$c/= :: LiteralType -> LiteralType -> Bool
== :: LiteralType -> LiteralType -> Bool
$c== :: LiteralType -> LiteralType -> Bool
Eq, Eq LiteralType
Eq LiteralType
-> (LiteralType -> LiteralType -> Ordering)
-> (LiteralType -> LiteralType -> Bool)
-> (LiteralType -> LiteralType -> Bool)
-> (LiteralType -> LiteralType -> Bool)
-> (LiteralType -> LiteralType -> Bool)
-> (LiteralType -> LiteralType -> LiteralType)
-> (LiteralType -> LiteralType -> LiteralType)
-> Ord LiteralType
LiteralType -> LiteralType -> Bool
LiteralType -> LiteralType -> Ordering
LiteralType -> LiteralType -> LiteralType
forall a.
Eq a
-> (a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
min :: LiteralType -> LiteralType -> LiteralType
$cmin :: LiteralType -> LiteralType -> LiteralType
max :: LiteralType -> LiteralType -> LiteralType
$cmax :: LiteralType -> LiteralType -> LiteralType
>= :: LiteralType -> LiteralType -> Bool
$c>= :: LiteralType -> LiteralType -> Bool
> :: LiteralType -> LiteralType -> Bool
$c> :: LiteralType -> LiteralType -> Bool
<= :: LiteralType -> LiteralType -> Bool
$c<= :: LiteralType -> LiteralType -> Bool
< :: LiteralType -> LiteralType -> Bool
$c< :: LiteralType -> LiteralType -> Bool
compare :: LiteralType -> LiteralType -> Ordering
$ccompare :: LiteralType -> LiteralType -> Ordering
$cp1Ord :: Eq LiteralType
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 $bPersistDbSpecific :: ByteString -> PersistValue
$mPersistDbSpecific :: forall r. PersistValue -> (ByteString -> r) -> (Void# -> r) -> r
PersistDbSpecific bs <- PersistLiteral_ _ bs where
    PersistDbSpecific ByteString
bs = LiteralType -> ByteString -> PersistValue
PersistLiteral_ LiteralType
DbSpecific ByteString
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 $bPersistLiteralEscaped :: ByteString -> PersistValue
$mPersistLiteralEscaped :: forall r. PersistValue -> (ByteString -> r) -> (Void# -> r) -> r
PersistLiteralEscaped bs <- PersistLiteral_ _ bs where
    PersistLiteralEscaped ByteString
bs = LiteralType -> ByteString -> PersistValue
PersistLiteral_ LiteralType
Escaped ByteString
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 $bPersistLiteral :: ByteString -> PersistValue
$mPersistLiteral :: forall r. PersistValue -> (ByteString -> r) -> (Void# -> r) -> r
PersistLiteral bs <- PersistLiteral_ _ bs where
    PersistLiteral ByteString
bs = LiteralType -> ByteString -> PersistValue
PersistLiteral_ LiteralType
Unescaped ByteString
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 :: Key -> Text
keyToText = Key -> Text
K.toText
keyFromText :: Text -> Key
keyFromText = Text -> Key
K.fromText
#else
type Key = Text
keyToText = id
keyFromText = id
#endif

instance ToHttpApiData PersistValue where
    toUrlPiece :: PersistValue -> Text
toUrlPiece PersistValue
val =
        case PersistValue -> Either Text Text
fromPersistValueText PersistValue
val of
            Left  Text
e -> String -> Text
forall a. HasCallStack => String -> a
error (String -> Text) -> String -> Text
forall a b. (a -> b) -> a -> b
$ Text -> String
Text.unpack Text
e
            Right Text
y -> Text
y

instance FromHttpApiData PersistValue where
    parseUrlPiece :: Text -> Either Text PersistValue
parseUrlPiece Text
input =
          Int64 -> PersistValue
PersistInt64 (Int64 -> PersistValue)
-> Either Text Int64 -> Either Text PersistValue
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Text -> Either Text Int64
forall a. FromHttpApiData a => Text -> Either Text a
parseUrlPiece Text
input
      Either Text PersistValue
-> Either Text PersistValue -> Either Text PersistValue
forall a b. Either a b -> Either a b -> Either a b
<!> [PersistValue] -> PersistValue
PersistList  ([PersistValue] -> PersistValue)
-> Either Text [PersistValue] -> Either Text PersistValue
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Text -> Either Text [PersistValue]
forall a. Read a => Text -> Either Text a
readTextData Text
input
      Either Text PersistValue
-> Either Text PersistValue -> Either Text PersistValue
forall a b. Either a b -> Either a b -> Either a b
<!> Text -> PersistValue
PersistText  (Text -> PersistValue)
-> Either Text Text -> Either Text PersistValue
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Text -> Either Text Text
forall (m :: * -> *) a. Monad m => a -> m a
return Text
input
      where
        infixl 3 <!>
        Left a
_ <!> :: Either a b -> Either a b -> Either a b
<!> Either a b
y = Either a b
y
        Either a b
x      <!> Either a b
_ = Either a b
x

instance PathPiece PersistValue where
  toPathPiece :: PersistValue -> Text
toPathPiece   = PersistValue -> Text
forall a. ToHttpApiData a => a -> Text
toUrlPiece
  fromPathPiece :: Text -> Maybe PersistValue
fromPathPiece = Text -> Maybe PersistValue
forall a. FromHttpApiData a => Text -> Maybe a
parseUrlPieceMaybe

fromPersistValueText :: PersistValue -> Either Text Text
fromPersistValueText :: PersistValue -> Either Text Text
fromPersistValueText (PersistText Text
s) = Text -> Either Text Text
forall a b. b -> Either a b
Right Text
s
fromPersistValueText (PersistByteString ByteString
bs) =
    Text -> Either Text Text
forall a b. b -> Either a b
Right (Text -> Either Text Text) -> Text -> Either Text Text
forall a b. (a -> b) -> a -> b
$ OnDecodeError -> ByteString -> Text
TE.decodeUtf8With OnDecodeError
lenientDecode ByteString
bs
fromPersistValueText (PersistInt64 Int64
i) = Text -> Either Text Text
forall a b. b -> Either a b
Right (Text -> Either Text Text) -> Text -> Either Text Text
forall a b. (a -> b) -> a -> b
$ String -> Text
Text.pack (String -> Text) -> String -> Text
forall a b. (a -> b) -> a -> b
$ Int64 -> String
forall a. Show a => a -> String
show Int64
i
fromPersistValueText (PersistDouble Double
d) = Text -> Either Text Text
forall a b. b -> Either a b
Right (Text -> Either Text Text) -> Text -> Either Text Text
forall a b. (a -> b) -> a -> b
$ String -> Text
Text.pack (String -> Text) -> String -> Text
forall a b. (a -> b) -> a -> b
$ Double -> String
forall a. Show a => a -> String
show Double
d
fromPersistValueText (PersistRational Rational
r) = Text -> Either Text Text
forall a b. b -> Either a b
Right (Text -> Either Text Text) -> Text -> Either Text Text
forall a b. (a -> b) -> a -> b
$ String -> Text
Text.pack (String -> Text) -> String -> Text
forall a b. (a -> b) -> a -> b
$ Rational -> String
forall a. Show a => a -> String
show Rational
r
fromPersistValueText (PersistDay Day
d) = Text -> Either Text Text
forall a b. b -> Either a b
Right (Text -> Either Text Text) -> Text -> Either Text Text
forall a b. (a -> b) -> a -> b
$ String -> Text
Text.pack (String -> Text) -> String -> Text
forall a b. (a -> b) -> a -> b
$ Day -> String
forall a. Show a => a -> String
show Day
d
fromPersistValueText (PersistTimeOfDay TimeOfDay
d) = Text -> Either Text Text
forall a b. b -> Either a b
Right (Text -> Either Text Text) -> Text -> Either Text Text
forall a b. (a -> b) -> a -> b
$ String -> Text
Text.pack (String -> Text) -> String -> Text
forall a b. (a -> b) -> a -> b
$ TimeOfDay -> String
forall a. Show a => a -> String
show TimeOfDay
d
fromPersistValueText (PersistUTCTime UTCTime
d) = Text -> Either Text Text
forall a b. b -> Either a b
Right (Text -> Either Text Text) -> Text -> Either Text Text
forall a b. (a -> b) -> a -> b
$ String -> Text
Text.pack (String -> Text) -> String -> Text
forall a b. (a -> b) -> a -> b
$ UTCTime -> String
forall a. Show a => a -> String
show UTCTime
d
fromPersistValueText PersistValue
PersistNull = Text -> Either Text Text
forall a b. a -> Either a b
Left Text
"Unexpected null"
fromPersistValueText (PersistBool Bool
b) = Text -> Either Text Text
forall a b. b -> Either a b
Right (Text -> Either Text Text) -> Text -> Either Text Text
forall a b. (a -> b) -> a -> b
$ String -> Text
Text.pack (String -> Text) -> String -> Text
forall a b. (a -> b) -> a -> b
$ Bool -> String
forall a. Show a => a -> String
show Bool
b
fromPersistValueText (PersistList [PersistValue]
_) = Text -> Either Text Text
forall a b. a -> Either a b
Left Text
"Cannot convert PersistList to Text"
fromPersistValueText (PersistMap [(Text, PersistValue)]
_) = Text -> Either Text Text
forall a b. a -> Either a b
Left Text
"Cannot convert PersistMap to Text"
fromPersistValueText (PersistObjectId ByteString
_) = Text -> Either Text Text
forall a b. a -> Either a b
Left Text
"Cannot convert PersistObjectId to Text"
fromPersistValueText (PersistArray [PersistValue]
_) = Text -> Either Text Text
forall a b. a -> Either a b
Left Text
"Cannot convert PersistArray to Text"
fromPersistValueText (PersistLiteral_ LiteralType
_ ByteString
_) = Text -> Either Text Text
forall a b. a -> Either a b
Left Text
"Cannot convert PersistLiteral to Text"

instance A.ToJSON PersistValue where
    toJSON :: PersistValue -> Value
toJSON (PersistText Text
t) = Text -> Value
A.String (Text -> Value) -> Text -> Value
forall a b. (a -> b) -> a -> b
$ Char -> Text -> Text
Text.cons Char
's' Text
t
    toJSON (PersistByteString ByteString
b) = Text -> Value
A.String (Text -> Value) -> Text -> Value
forall a b. (a -> b) -> a -> b
$ Char -> Text -> Text
Text.cons Char
'b' (Text -> Text) -> Text -> Text
forall a b. (a -> b) -> a -> b
$ ByteString -> Text
TE.decodeUtf8 (ByteString -> Text) -> ByteString -> Text
forall a b. (a -> b) -> a -> b
$ ByteString -> ByteString
B64.encode ByteString
b
    toJSON (PersistInt64 Int64
i) = Scientific -> Value
A.Number (Scientific -> Value) -> Scientific -> Value
forall a b. (a -> b) -> a -> b
$ Int64 -> Scientific
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int64
i
    toJSON (PersistDouble Double
d) = Scientific -> Value
A.Number (Scientific -> Value) -> Scientific -> Value
forall a b. (a -> b) -> a -> b
$ Double -> Scientific
forall a. RealFloat a => a -> Scientific
Data.Scientific.fromFloatDigits Double
d
    toJSON (PersistRational Rational
r) = Text -> Value
A.String (Text -> Value) -> Text -> Value
forall a b. (a -> b) -> a -> b
$ String -> Text
Text.pack (String -> Text) -> String -> Text
forall a b. (a -> b) -> a -> b
$ Char
'r' Char -> ShowS
forall a. a -> [a] -> [a]
: Rational -> String
forall a. Show a => a -> String
show Rational
r
    toJSON (PersistBool Bool
b) = Bool -> Value
A.Bool Bool
b
    toJSON (PersistTimeOfDay TimeOfDay
t) = Text -> Value
A.String (Text -> Value) -> Text -> Value
forall a b. (a -> b) -> a -> b
$ String -> Text
Text.pack (String -> Text) -> String -> Text
forall a b. (a -> b) -> a -> b
$ Char
't' Char -> ShowS
forall a. a -> [a] -> [a]
: TimeOfDay -> String
forall a. Show a => a -> String
show TimeOfDay
t
    toJSON (PersistUTCTime UTCTime
u) = Text -> Value
A.String (Text -> Value) -> Text -> Value
forall a b. (a -> b) -> a -> b
$ String -> Text
Text.pack (String -> Text) -> String -> Text
forall a b. (a -> b) -> a -> b
$ Char
'u' Char -> ShowS
forall a. a -> [a] -> [a]
: UTCTime -> String
forall a. Show a => a -> String
show UTCTime
u
    toJSON (PersistDay Day
d) = Text -> Value
A.String (Text -> Value) -> Text -> Value
forall a b. (a -> b) -> a -> b
$ String -> Text
Text.pack (String -> Text) -> String -> Text
forall a b. (a -> b) -> a -> b
$ Char
'd' Char -> ShowS
forall a. a -> [a] -> [a]
: Day -> String
forall a. Show a => a -> String
show Day
d
    toJSON PersistValue
PersistNull = Value
A.Null
    toJSON (PersistList [PersistValue]
l) = Array -> Value
A.Array (Array -> Value) -> Array -> Value
forall a b. (a -> b) -> a -> b
$ [Value] -> Array
forall a. [a] -> Vector a
V.fromList ([Value] -> Array) -> [Value] -> Array
forall a b. (a -> b) -> a -> b
$ (PersistValue -> Value) -> [PersistValue] -> [Value]
forall a b. (a -> b) -> [a] -> [b]
map PersistValue -> Value
forall a. ToJSON a => a -> Value
A.toJSON [PersistValue]
l
    toJSON (PersistMap [(Text, PersistValue)]
m) = [Pair] -> Value
A.object ([Pair] -> Value) -> [Pair] -> Value
forall a b. (a -> b) -> a -> b
$ ((Text, PersistValue) -> Pair) -> [(Text, PersistValue)] -> [Pair]
forall a b. (a -> b) -> [a] -> [b]
map (Text, PersistValue) -> Pair
forall a. ToJSON a => (Text, a) -> Pair
go [(Text, PersistValue)]
m
        where go :: (Text, a) -> Pair
go (Text
k, a
v) = (Text -> Key
keyFromText Text
k, a -> Value
forall a. ToJSON a => a -> Value
A.toJSON a
v)
    toJSON (PersistLiteral_ LiteralType
litTy ByteString
b) =
        let encoded :: Text
encoded = ByteString -> Text
TE.decodeUtf8 (ByteString -> Text) -> ByteString -> Text
forall a b. (a -> b) -> a -> b
$ ByteString -> ByteString
B64.encode ByteString
b
            prefix :: Char
prefix =
                case LiteralType
litTy of
                    LiteralType
DbSpecific -> Char
'p'
                    LiteralType
Unescaped -> Char
'l'
                    LiteralType
Escaped -> Char
'e'
         in
            Text -> Value
A.String (Text -> Value) -> Text -> Value
forall a b. (a -> b) -> a -> b
$ Char -> Text -> Text
Text.cons Char
prefix Text
encoded
    toJSON (PersistArray [PersistValue]
a) = Array -> Value
A.Array (Array -> Value) -> Array -> Value
forall a b. (a -> b) -> a -> b
$ [Value] -> Array
forall a. [a] -> Vector a
V.fromList ([Value] -> Array) -> [Value] -> Array
forall a b. (a -> b) -> a -> b
$ (PersistValue -> Value) -> [PersistValue] -> [Value]
forall a b. (a -> b) -> [a] -> [b]
map PersistValue -> Value
forall a. ToJSON a => a -> Value
A.toJSON [PersistValue]
a
    toJSON (PersistObjectId ByteString
o) =
      String -> Value
forall a. ToJSON a => a -> Value
A.toJSON (String -> Value) -> String -> Value
forall a b. (a -> b) -> a -> b
$ Char -> ShowS
showChar Char
'o' ShowS -> ShowS
forall a b. (a -> b) -> a -> b
$ Int -> Integer -> ShowS
forall n. (Show n, Integral n) => Int -> n -> ShowS
showHexLen Int
8 (ByteString -> Integer
bs2i ByteString
four) ShowS -> ShowS
forall a b. (a -> b) -> a -> b
$ Int -> Integer -> ShowS
forall n. (Show n, Integral n) => Int -> n -> ShowS
showHexLen Int
16 (ByteString -> Integer
bs2i ByteString
eight) String
""
        where
         (ByteString
four, ByteString
eight) = Int -> ByteString -> (ByteString, ByteString)
BS8.splitAt Int
4 ByteString
o

         -- taken from crypto-api
         bs2i :: ByteString -> Integer
         bs2i :: ByteString -> Integer
bs2i ByteString
bs = (Integer -> Word8 -> Integer) -> Integer -> ByteString -> Integer
forall a. (a -> Word8 -> a) -> a -> ByteString -> a
foldl' (\Integer
i Word8
b -> (Integer
i Integer -> Int -> Integer
forall a. Bits a => a -> Int -> a
`shiftL` Int
8) Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
+ Word8 -> Integer
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word8
b) Integer
0 ByteString
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 :: Int -> n -> ShowS
showHexLen Int
d n
n = String -> ShowS
showString (Int -> Char -> String
forall a. Int -> a -> [a]
replicate (Int
d Int -> Int -> Int
forall a. Num a => a -> a -> a
- n -> Int
forall a p. (Integral p, Integral a) => a -> p
sigDigits n
n) Char
'0') ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. n -> ShowS
forall a. (Integral a, Show a) => a -> ShowS
showHex n
n  where
             sigDigits :: a -> p
sigDigits a
0 = p
1
             sigDigits a
n' = Double -> p
forall a b. (RealFrac a, Integral b) => a -> b
truncate (Double -> Double -> Double
forall a. Floating a => a -> a -> a
logBase (Double
16 :: Double) (Double -> Double) -> Double -> Double
forall a b. (a -> b) -> a -> b
$ a -> Double
forall a b. (Integral a, Num b) => a -> b
fromIntegral a
n') p -> p -> p
forall a. Num a => a -> a -> a
+ p
1

instance A.FromJSON PersistValue where
    parseJSON :: Value -> Parser PersistValue
parseJSON (A.String Text
t0) =
        case Text -> Maybe (Char, Text)
Text.uncons Text
t0 of
            Maybe (Char, Text)
Nothing -> String -> Parser PersistValue
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"Null string"
            Just (Char
'p', Text
t) -> (String -> Parser PersistValue)
-> (ByteString -> Parser PersistValue)
-> Either String ByteString
-> Parser PersistValue
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (\String
_ -> String -> Parser PersistValue
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"Invalid base64") (PersistValue -> Parser PersistValue
forall (m :: * -> *) a. Monad m => a -> m a
return (PersistValue -> Parser PersistValue)
-> (ByteString -> PersistValue)
-> ByteString
-> Parser PersistValue
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> PersistValue
PersistDbSpecific)
                           (Either String ByteString -> Parser PersistValue)
-> Either String ByteString -> Parser PersistValue
forall a b. (a -> b) -> a -> b
$ ByteString -> Either String ByteString
B64.decode (ByteString -> Either String ByteString)
-> ByteString -> Either String ByteString
forall a b. (a -> b) -> a -> b
$ Text -> ByteString
TE.encodeUtf8 Text
t
            Just (Char
'l', Text
t) -> (String -> Parser PersistValue)
-> (ByteString -> Parser PersistValue)
-> Either String ByteString
-> Parser PersistValue
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (\String
_ -> String -> Parser PersistValue
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"Invalid base64") (PersistValue -> Parser PersistValue
forall (m :: * -> *) a. Monad m => a -> m a
return (PersistValue -> Parser PersistValue)
-> (ByteString -> PersistValue)
-> ByteString
-> Parser PersistValue
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> PersistValue
PersistLiteral)
                           (Either String ByteString -> Parser PersistValue)
-> Either String ByteString -> Parser PersistValue
forall a b. (a -> b) -> a -> b
$ ByteString -> Either String ByteString
B64.decode (ByteString -> Either String ByteString)
-> ByteString -> Either String ByteString
forall a b. (a -> b) -> a -> b
$ Text -> ByteString
TE.encodeUtf8 Text
t
            Just (Char
'e', Text
t) -> (String -> Parser PersistValue)
-> (ByteString -> Parser PersistValue)
-> Either String ByteString
-> Parser PersistValue
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (\String
_ -> String -> Parser PersistValue
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"Invalid base64") (PersistValue -> Parser PersistValue
forall (m :: * -> *) a. Monad m => a -> m a
return (PersistValue -> Parser PersistValue)
-> (ByteString -> PersistValue)
-> ByteString
-> Parser PersistValue
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> PersistValue
PersistLiteralEscaped)
                           (Either String ByteString -> Parser PersistValue)
-> Either String ByteString -> Parser PersistValue
forall a b. (a -> b) -> a -> b
$ ByteString -> Either String ByteString
B64.decode (ByteString -> Either String ByteString)
-> ByteString -> Either String ByteString
forall a b. (a -> b) -> a -> b
$ Text -> ByteString
TE.encodeUtf8 Text
t
            Just (Char
's', Text
t) -> PersistValue -> Parser PersistValue
forall (m :: * -> *) a. Monad m => a -> m a
return (PersistValue -> Parser PersistValue)
-> PersistValue -> Parser PersistValue
forall a b. (a -> b) -> a -> b
$ Text -> PersistValue
PersistText Text
t
            Just (Char
'b', Text
t) -> (String -> Parser PersistValue)
-> (ByteString -> Parser PersistValue)
-> Either String ByteString
-> Parser PersistValue
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (\String
_ -> String -> Parser PersistValue
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"Invalid base64") (PersistValue -> Parser PersistValue
forall (m :: * -> *) a. Monad m => a -> m a
return (PersistValue -> Parser PersistValue)
-> (ByteString -> PersistValue)
-> ByteString
-> Parser PersistValue
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> PersistValue
PersistByteString)
                           (Either String ByteString -> Parser PersistValue)
-> Either String ByteString -> Parser PersistValue
forall a b. (a -> b) -> a -> b
$ ByteString -> Either String ByteString
B64.decode (ByteString -> Either String ByteString)
-> ByteString -> Either String ByteString
forall a b. (a -> b) -> a -> b
$ Text -> ByteString
TE.encodeUtf8 Text
t
            Just (Char
't', Text
t) -> TimeOfDay -> PersistValue
PersistTimeOfDay (TimeOfDay -> PersistValue)
-> Parser TimeOfDay -> Parser PersistValue
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Text -> Parser TimeOfDay
forall a (m :: * -> *). (Read a, MonadFail m) => Text -> m a
readMay Text
t
            Just (Char
'u', Text
t) -> UTCTime -> PersistValue
PersistUTCTime (UTCTime -> PersistValue) -> Parser UTCTime -> Parser PersistValue
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Text -> Parser UTCTime
forall a (m :: * -> *). (Read a, MonadFail m) => Text -> m a
readMay Text
t
            Just (Char
'd', Text
t) -> Day -> PersistValue
PersistDay (Day -> PersistValue) -> Parser Day -> Parser PersistValue
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Text -> Parser Day
forall a (m :: * -> *). (Read a, MonadFail m) => Text -> m a
readMay Text
t
            Just (Char
'r', Text
t) -> Rational -> PersistValue
PersistRational (Rational -> PersistValue)
-> Parser Rational -> Parser PersistValue
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Text -> Parser Rational
forall a (m :: * -> *). (Read a, MonadFail m) => Text -> m a
readMay Text
t
            Just (Char
'o', Text
t) -> Parser PersistValue
-> ((Integer, String) -> Parser PersistValue)
-> Maybe (Integer, String)
-> Parser PersistValue
forall b a. b -> (a -> b) -> Maybe a -> b
maybe
                (String -> Parser PersistValue
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"Invalid base64")
                (PersistValue -> Parser PersistValue
forall (m :: * -> *) a. Monad m => a -> m a
return (PersistValue -> Parser PersistValue)
-> ((Integer, String) -> PersistValue)
-> (Integer, String)
-> Parser PersistValue
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> PersistValue
PersistObjectId (ByteString -> PersistValue)
-> ((Integer, String) -> ByteString)
-> (Integer, String)
-> PersistValue
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> Integer -> ByteString
i2bs (Int
8 Int -> Int -> Int
forall a. Num a => a -> a -> a
* Int
12) (Integer -> ByteString)
-> ((Integer, String) -> Integer)
-> (Integer, String)
-> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Integer, String) -> Integer
forall a b. (a, b) -> a
fst)
                (Maybe (Integer, String) -> Parser PersistValue)
-> Maybe (Integer, String) -> Parser PersistValue
forall a b. (a -> b) -> a -> b
$ [(Integer, String)] -> Maybe (Integer, String)
forall a. [a] -> Maybe a
headMay ([(Integer, String)] -> Maybe (Integer, String))
-> [(Integer, String)] -> Maybe (Integer, String)
forall a b. (a -> b) -> a -> b
$ ReadS Integer
forall a. (Eq a, Num a) => ReadS a
readHex ReadS Integer -> ReadS Integer
forall a b. (a -> b) -> a -> b
$ Text -> String
Text.unpack Text
t
            Just (Char
c, Text
_) -> String -> Parser PersistValue
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String -> Parser PersistValue) -> String -> Parser PersistValue
forall a b. (a -> b) -> a -> b
$ String
"Unknown prefix: " String -> ShowS
forall a. [a] -> [a] -> [a]
++ [Char
c]
      where
        headMay :: [a] -> Maybe a
headMay []    = Maybe a
forall a. Maybe a
Nothing
        headMay (a
x:[a]
_) = a -> Maybe a
forall a. a -> Maybe a
Just a
x
        readMay :: Text -> m a
readMay Text
t =
            case ReadS a
forall a. Read a => ReadS a
reads ReadS a -> ReadS a
forall a b. (a -> b) -> a -> b
$ Text -> String
Text.unpack Text
t of
                (a
x, String
_):[(a, String)]
_ -> a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return a
x
                [] -> String -> m a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"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 :: Int -> Integer -> ByteString
i2bs Int
l Integer
i = (Int -> Maybe (Word8, Int)) -> Int -> ByteString
forall a. (a -> Maybe (Word8, a)) -> a -> ByteString
BS.unfoldr (\Int
l' -> if Int
l' Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
0 then Maybe (Word8, Int)
forall a. Maybe a
Nothing else (Word8, Int) -> Maybe (Word8, Int)
forall a. a -> Maybe a
Just (Integer -> Word8
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Integer
i Integer -> Int -> Integer
forall a. Bits a => a -> Int -> a
`shiftR` Int
l'), Int
l' Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
8)) (Int
lInt -> Int -> Int
forall a. Num a => a -> a -> a
-Int
8)
        {-# INLINE i2bs #-}


    parseJSON (A.Number Scientific
n) = PersistValue -> Parser PersistValue
forall (m :: * -> *) a. Monad m => a -> m a
return (PersistValue -> Parser PersistValue)
-> PersistValue -> Parser PersistValue
forall a b. (a -> b) -> a -> b
$
        if Integer -> Scientific
forall a. Num a => Integer -> a
fromInteger (Scientific -> Integer
forall a b. (RealFrac a, Integral b) => a -> b
floor Scientific
n) Scientific -> Scientific -> Bool
forall a. Eq a => a -> a -> Bool
== Scientific
n
            then Int64 -> PersistValue
PersistInt64 (Int64 -> PersistValue) -> Int64 -> PersistValue
forall a b. (a -> b) -> a -> b
$ Scientific -> Int64
forall a b. (RealFrac a, Integral b) => a -> b
floor Scientific
n
            else Double -> PersistValue
PersistDouble (Double -> PersistValue) -> Double -> PersistValue
forall a b. (a -> b) -> a -> b
$ Rational -> Double
forall a. Fractional a => Rational -> a
fromRational (Rational -> Double) -> Rational -> Double
forall a b. (a -> b) -> a -> b
$ Scientific -> Rational
forall a. Real a => a -> Rational
toRational Scientific
n
    parseJSON (A.Bool Bool
b) = PersistValue -> Parser PersistValue
forall (m :: * -> *) a. Monad m => a -> m a
return (PersistValue -> Parser PersistValue)
-> PersistValue -> Parser PersistValue
forall a b. (a -> b) -> a -> b
$ Bool -> PersistValue
PersistBool Bool
b
    parseJSON Value
A.Null = PersistValue -> Parser PersistValue
forall (m :: * -> *) a. Monad m => a -> m a
return PersistValue
PersistNull
    parseJSON (A.Array Array
a) = ([PersistValue] -> PersistValue)
-> Parser [PersistValue] -> Parser PersistValue
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap [PersistValue] -> PersistValue
PersistList ((Value -> Parser PersistValue) -> [Value] -> Parser [PersistValue]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM Value -> Parser PersistValue
forall a. FromJSON a => Value -> Parser a
A.parseJSON ([Value] -> Parser [PersistValue])
-> [Value] -> Parser [PersistValue]
forall a b. (a -> b) -> a -> b
$ Array -> [Value]
forall a. Vector a -> [a]
V.toList Array
a)
    parseJSON (A.Object Object
o) =
        ([(Text, PersistValue)] -> PersistValue)
-> Parser [(Text, PersistValue)] -> Parser PersistValue
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap [(Text, PersistValue)] -> PersistValue
PersistMap (Parser [(Text, PersistValue)] -> Parser PersistValue)
-> Parser [(Text, PersistValue)] -> Parser PersistValue
forall a b. (a -> b) -> a -> b
$ (Pair -> Parser (Text, PersistValue))
-> [Pair] -> Parser [(Text, PersistValue)]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM Pair -> Parser (Text, PersistValue)
forall b. FromJSON b => Pair -> Parser (Text, b)
go ([Pair] -> Parser [(Text, PersistValue)])
-> [Pair] -> Parser [(Text, PersistValue)]
forall a b. (a -> b) -> a -> b
$ Object -> [Pair]
forall v. KeyMap v -> [(Key, v)]
AM.toList Object
o
      where
        go :: Pair -> Parser (Text, b)
go (Key
k, Value
v) = (,) (Key -> Text
keyToText Key
k) (b -> (Text, b)) -> Parser b -> Parser (Text, b)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Value -> Parser b
forall a. FromJSON a => Value -> Parser a
A.parseJSON Value
v