{-# 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 Control.DeepSeq
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
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]
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
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
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
Ord)

-- |
-- @since 2.14.4.0
instance NFData PersistValue where
  rnf :: PersistValue -> ()
rnf PersistValue
val = case PersistValue
val of
    PersistText Text
txt -> forall a. NFData a => a -> ()
rnf Text
txt
    PersistByteString ByteString
bs -> forall a. NFData a => a -> ()
rnf ByteString
bs
    PersistInt64 Int64
i -> forall a. NFData a => a -> ()
rnf Int64
i
    PersistDouble Double
d -> forall a. NFData a => a -> ()
rnf Double
d
    PersistRational Rational
q -> forall a. NFData a => a -> ()
rnf Rational
q
    PersistBool Bool
b -> forall a. NFData a => a -> ()
rnf Bool
b
    PersistDay Day
d -> forall a. NFData a => a -> ()
rnf Day
d
    PersistTimeOfDay TimeOfDay
t -> forall a. NFData a => a -> ()
rnf TimeOfDay
t
    PersistUTCTime UTCTime
t -> forall a. NFData a => a -> ()
rnf UTCTime
t
    PersistValue
PersistNull -> ()
    PersistList [PersistValue]
vals -> forall a. NFData a => a -> ()
rnf [PersistValue]
vals
    PersistMap [(Text, PersistValue)]
vals -> forall a. NFData a => a -> ()
rnf [(Text, PersistValue)]
vals
    PersistObjectId ByteString
bs -> forall a. NFData a => a -> ()
rnf ByteString
bs
    PersistArray [PersistValue]
vals -> forall a. NFData a => a -> ()
rnf [PersistValue]
vals
    PersistLiteral_ LiteralType
ty ByteString
bs -> LiteralType
ty seq :: forall a b. a -> b -> b
`seq` forall a. NFData a => a -> ()
rnf ByteString
bs


-- | 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
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]
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
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
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
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) -> ((# #) -> 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) -> ((# #) -> 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) -> ((# #) -> 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 -> forall a. HasCallStack => String -> a
error 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 forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a. FromHttpApiData a => Text -> Either Text a
parseUrlPiece Text
input
      forall {a} {b}. Either a b -> Either a b -> Either a b
<!> [PersistValue] -> PersistValue
PersistList  forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a. Read a => Text -> Either Text a
readTextData Text
input
      forall {a} {b}. Either a b -> Either a b -> Either a b
<!> Text -> PersistValue
PersistText  forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> 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   = forall a. ToHttpApiData a => a -> Text
toUrlPiece
  fromPathPiece :: Text -> Maybe PersistValue
fromPathPiece = forall a. FromHttpApiData a => Text -> Maybe a
parseUrlPieceMaybe

fromPersistValueText :: PersistValue -> Either Text Text
fromPersistValueText :: PersistValue -> Either Text Text
fromPersistValueText (PersistText Text
s) = forall a b. b -> Either a b
Right Text
s
fromPersistValueText (PersistByteString ByteString
bs) =
    forall a b. b -> Either a b
Right forall a b. (a -> b) -> a -> b
$ OnDecodeError -> ByteString -> Text
TE.decodeUtf8With OnDecodeError
lenientDecode ByteString
bs
fromPersistValueText (PersistInt64 Int64
i) = forall a b. b -> Either a b
Right forall a b. (a -> b) -> a -> b
$ String -> Text
Text.pack forall a b. (a -> b) -> a -> b
$ forall a. Show a => a -> String
show Int64
i
fromPersistValueText (PersistDouble Double
d) = forall a b. b -> Either a b
Right forall a b. (a -> b) -> a -> b
$ String -> Text
Text.pack forall a b. (a -> b) -> a -> b
$ forall a. Show a => a -> String
show Double
d
fromPersistValueText (PersistRational Rational
r) = forall a b. b -> Either a b
Right forall a b. (a -> b) -> a -> b
$ String -> Text
Text.pack forall a b. (a -> b) -> a -> b
$ forall a. Show a => a -> String
show Rational
r
fromPersistValueText (PersistDay Day
d) = forall a b. b -> Either a b
Right forall a b. (a -> b) -> a -> b
$ String -> Text
Text.pack forall a b. (a -> b) -> a -> b
$ forall a. Show a => a -> String
show Day
d
fromPersistValueText (PersistTimeOfDay TimeOfDay
d) = forall a b. b -> Either a b
Right forall a b. (a -> b) -> a -> b
$ String -> Text
Text.pack forall a b. (a -> b) -> a -> b
$ forall a. Show a => a -> String
show TimeOfDay
d
fromPersistValueText (PersistUTCTime UTCTime
d) = forall a b. b -> Either a b
Right forall a b. (a -> b) -> a -> b
$ String -> Text
Text.pack forall a b. (a -> b) -> a -> b
$ forall a. Show a => a -> String
show UTCTime
d
fromPersistValueText PersistValue
PersistNull = forall a b. a -> Either a b
Left Text
"Unexpected null"
fromPersistValueText (PersistBool Bool
b) = forall a b. b -> Either a b
Right forall a b. (a -> b) -> a -> b
$ String -> Text
Text.pack forall a b. (a -> b) -> a -> b
$ forall a. Show a => a -> String
show Bool
b
fromPersistValueText (PersistList [PersistValue]
_) = forall a b. a -> Either a b
Left Text
"Cannot convert PersistList to Text"
fromPersistValueText (PersistMap [(Text, PersistValue)]
_) = forall a b. a -> Either a b
Left Text
"Cannot convert PersistMap to Text"
fromPersistValueText (PersistObjectId ByteString
_) = forall a b. a -> Either a b
Left Text
"Cannot convert PersistObjectId to Text"
fromPersistValueText (PersistArray [PersistValue]
_) = forall a b. a -> Either a b
Left Text
"Cannot convert PersistArray to Text"
fromPersistValueText (PersistLiteral_ LiteralType
_ ByteString
_) = 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 forall a b. (a -> b) -> a -> b
$ Char -> Text -> Text
Text.cons Char
's' Text
t
    toJSON (PersistByteString ByteString
b) = Text -> Value
A.String forall a b. (a -> b) -> a -> b
$ Char -> Text -> Text
Text.cons Char
'b' forall a b. (a -> b) -> a -> b
$ ByteString -> Text
TE.decodeUtf8 forall a b. (a -> b) -> a -> b
$ ByteString -> ByteString
B64.encode ByteString
b
    toJSON (PersistInt64 Int64
i) = Scientific -> Value
A.Number forall a b. (a -> b) -> a -> b
$ forall a b. (Integral a, Num b) => a -> b
fromIntegral Int64
i
    toJSON (PersistDouble Double
d) = Scientific -> Value
A.Number forall a b. (a -> b) -> a -> b
$ forall a. RealFloat a => a -> Scientific
Data.Scientific.fromFloatDigits Double
d
    toJSON (PersistRational Rational
r) = Text -> Value
A.String forall a b. (a -> b) -> a -> b
$ String -> Text
Text.pack forall a b. (a -> b) -> a -> b
$ Char
'r' forall a. a -> [a] -> [a]
: 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 forall a b. (a -> b) -> a -> b
$ String -> Text
Text.pack forall a b. (a -> b) -> a -> b
$ Char
't' forall a. a -> [a] -> [a]
: forall a. Show a => a -> String
show TimeOfDay
t
    toJSON (PersistUTCTime UTCTime
u) = Text -> Value
A.String forall a b. (a -> b) -> a -> b
$ String -> Text
Text.pack forall a b. (a -> b) -> a -> b
$ Char
'u' forall a. a -> [a] -> [a]
: forall a. Show a => a -> String
show UTCTime
u
    toJSON (PersistDay Day
d) = Text -> Value
A.String forall a b. (a -> b) -> a -> b
$ String -> Text
Text.pack forall a b. (a -> b) -> a -> b
$ Char
'd' forall a. a -> [a] -> [a]
: forall a. Show a => a -> String
show Day
d
    toJSON PersistValue
PersistNull = Value
A.Null
    toJSON (PersistList [PersistValue]
l) = Array -> Value
A.Array forall a b. (a -> b) -> a -> b
$ forall a. [a] -> Vector a
V.fromList forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map forall a. ToJSON a => a -> Value
A.toJSON [PersistValue]
l
    toJSON (PersistMap [(Text, PersistValue)]
m) = [Pair] -> Value
A.object forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map 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, forall a. ToJSON a => a -> Value
A.toJSON a
v)
    toJSON (PersistLiteral_ LiteralType
litTy ByteString
b) =
        let encoded :: Text
encoded = ByteString -> Text
TE.decodeUtf8 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 forall a b. (a -> b) -> a -> b
$ Char -> Text -> Text
Text.cons Char
prefix Text
encoded
    toJSON (PersistArray [PersistValue]
a) = Array -> Value
A.Array forall a b. (a -> b) -> a -> b
$ forall a. [a] -> Vector a
V.fromList forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map forall a. ToJSON a => a -> Value
A.toJSON [PersistValue]
a
    toJSON (PersistObjectId ByteString
o) =
      forall a. ToJSON a => a -> Value
A.toJSON forall a b. (a -> b) -> a -> b
$ Char -> ShowS
showChar Char
'o' forall a b. (a -> b) -> a -> b
$ forall n. (Show n, Integral n) => Int -> n -> ShowS
showHexLen Int
8 (ByteString -> Integer
bs2i ByteString
four) forall a b. (a -> b) -> a -> b
$ 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 = forall a. (a -> Word8 -> a) -> a -> ByteString -> a
foldl' (\Integer
i Word8
b -> (Integer
i forall a. Bits a => a -> Int -> a
`shiftL` Int
8) forall a. Num a => a -> a -> a
+ 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 :: forall n. (Show n, Integral n) => Int -> n -> ShowS
showHexLen Int
d n
n = String -> ShowS
showString (forall a. Int -> a -> [a]
replicate (Int
d forall a. Num a => a -> a -> a
- forall {a} {a}. (Integral a, Integral a) => a -> a
sigDigits n
n) Char
'0') forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. (Integral a, Show a) => a -> ShowS
showHex n
n  where
             sigDigits :: a -> a
sigDigits a
0 = a
1
             sigDigits a
n' = forall a b. (RealFrac a, Integral b) => a -> b
truncate (forall a. Floating a => a -> a -> a
logBase (Double
16 :: Double) forall a b. (a -> b) -> a -> b
$ forall a b. (Integral a, Num b) => a -> b
fromIntegral a
n') forall a. Num a => a -> a -> a
+ a
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 -> forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"Null string"
            Just (Char
'p', Text
t) -> forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (\String
_ -> forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"Invalid base64") (forall (m :: * -> *) a. Monad m => a -> m a
return forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> PersistValue
PersistDbSpecific)
                           forall a b. (a -> b) -> a -> b
$ ByteString -> Either String ByteString
B64.decode forall a b. (a -> b) -> a -> b
$ Text -> ByteString
TE.encodeUtf8 Text
t
            Just (Char
'l', Text
t) -> forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (\String
_ -> forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"Invalid base64") (forall (m :: * -> *) a. Monad m => a -> m a
return forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> PersistValue
PersistLiteral)
                           forall a b. (a -> b) -> a -> b
$ ByteString -> Either String ByteString
B64.decode forall a b. (a -> b) -> a -> b
$ Text -> ByteString
TE.encodeUtf8 Text
t
            Just (Char
'e', Text
t) -> forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (\String
_ -> forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"Invalid base64") (forall (m :: * -> *) a. Monad m => a -> m a
return forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> PersistValue
PersistLiteralEscaped)
                           forall a b. (a -> b) -> a -> b
$ ByteString -> Either String ByteString
B64.decode forall a b. (a -> b) -> a -> b
$ Text -> ByteString
TE.encodeUtf8 Text
t
            Just (Char
's', Text
t) -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ Text -> PersistValue
PersistText Text
t
            Just (Char
'b', Text
t) -> forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (\String
_ -> forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"Invalid base64") (forall (m :: * -> *) a. Monad m => a -> m a
return forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> PersistValue
PersistByteString)
                           forall a b. (a -> b) -> a -> b
$ ByteString -> Either String ByteString
B64.decode forall a b. (a -> b) -> a -> b
$ Text -> ByteString
TE.encodeUtf8 Text
t
            Just (Char
't', Text
t) -> TimeOfDay -> PersistValue
PersistTimeOfDay forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall {a} {m :: * -> *}. (Read a, MonadFail m) => Text -> m a
readMay Text
t
            Just (Char
'u', Text
t) -> UTCTime -> PersistValue
PersistUTCTime forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall {a} {m :: * -> *}. (Read a, MonadFail m) => Text -> m a
readMay Text
t
            Just (Char
'd', Text
t) -> Day -> PersistValue
PersistDay forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall {a} {m :: * -> *}. (Read a, MonadFail m) => Text -> m a
readMay Text
t
            Just (Char
'r', Text
t) -> Rational -> PersistValue
PersistRational forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall {a} {m :: * -> *}. (Read a, MonadFail m) => Text -> m a
readMay Text
t
            Just (Char
'o', Text
t) -> forall b a. b -> (a -> b) -> Maybe a -> b
maybe
                (forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"Invalid base64")
                (forall (m :: * -> *) a. Monad m => a -> m a
return forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> PersistValue
PersistObjectId forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> Integer -> ByteString
i2bs (Int
8 forall a. Num a => a -> a -> a
* Int
12) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a, b) -> a
fst)
                forall a b. (a -> b) -> a -> b
$ forall {a}. [a] -> Maybe a
headMay forall a b. (a -> b) -> a -> b
$ forall a. (Eq a, Num a) => ReadS a
readHex forall a b. (a -> b) -> a -> b
$ Text -> String
Text.unpack Text
t
            Just (Char
c, Text
_) -> forall (m :: * -> *) a. MonadFail m => String -> m a
fail forall a b. (a -> b) -> a -> b
$ String
"Unknown prefix: " forall a. [a] -> [a] -> [a]
++ [Char
c]
      where
        headMay :: [a] -> Maybe a
headMay []    = forall a. Maybe a
Nothing
        headMay (a
x:[a]
_) = forall a. a -> Maybe a
Just a
x
        readMay :: Text -> m a
readMay Text
t =
            case forall a. Read a => ReadS a
reads forall a b. (a -> b) -> a -> b
$ Text -> String
Text.unpack Text
t of
                (a
x, String
_):[(a, String)]
_ -> forall (m :: * -> *) a. Monad m => a -> m a
return a
x
                [] -> 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 = forall a. (a -> Maybe (Word8, a)) -> a -> ByteString
BS.unfoldr (\Int
l' -> if Int
l' forall a. Ord a => a -> a -> Bool
< Int
0 then forall a. Maybe a
Nothing else forall a. a -> Maybe a
Just (forall a b. (Integral a, Num b) => a -> b
fromIntegral (Integer
i forall a. Bits a => a -> Int -> a
`shiftR` Int
l'), Int
l' forall a. Num a => a -> a -> a
- Int
8)) (Int
lforall a. Num a => a -> a -> a
-Int
8)
        {-# INLINE i2bs #-}


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