{-# LANGUAGE PatternSynonyms #-}
{-# LANGUAGE CPP #-}
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
)
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
| PersistArray [PersistValue]
| PersistLiteral_ LiteralType ByteString
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)
data LiteralType
= Escaped
| Unescaped
| DbSpecific
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)
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
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
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 = K.toText
keyFromText = K.fromText
#else
type Key = Text
keyToText :: Key -> Key
keyToText = Key -> Key
forall a. a -> a
id
keyFromText :: Key -> Key
keyFromText = Key -> Key
forall a. a -> a
id
#endif
instance ToHttpApiData PersistValue where
toUrlPiece :: PersistValue -> Key
toUrlPiece PersistValue
val =
case PersistValue -> Either Key Key
fromPersistValueText PersistValue
val of
Left Key
e -> String -> Key
forall a. HasCallStack => String -> a
error (String -> Key) -> String -> Key
forall a b. (a -> b) -> a -> b
$ Key -> String
Text.unpack Key
e
Right Key
y -> Key
y
instance FromHttpApiData PersistValue where
parseUrlPiece :: Key -> Either Key PersistValue
parseUrlPiece Key
input =
Int64 -> PersistValue
PersistInt64 (Int64 -> PersistValue)
-> Either Key Int64 -> Either Key PersistValue
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Key -> Either Key Int64
forall a. FromHttpApiData a => Key -> Either Key a
parseUrlPiece Key
input
Either Key PersistValue
-> Either Key PersistValue -> Either Key PersistValue
forall a b. Either a b -> Either a b -> Either a b
<!> [PersistValue] -> PersistValue
PersistList ([PersistValue] -> PersistValue)
-> Either Key [PersistValue] -> Either Key PersistValue
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Key -> Either Key [PersistValue]
forall a. Read a => Key -> Either Key a
readTextData Key
input
Either Key PersistValue
-> Either Key PersistValue -> Either Key PersistValue
forall a b. Either a b -> Either a b -> Either a b
<!> Key -> PersistValue
PersistText (Key -> PersistValue) -> Either Key Key -> Either Key PersistValue
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Key -> Either Key Key
forall (m :: * -> *) a. Monad m => a -> m a
return Key
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 -> Key
toPathPiece = PersistValue -> Key
forall a. ToHttpApiData a => a -> Key
toUrlPiece
fromPathPiece :: Key -> Maybe PersistValue
fromPathPiece = Key -> Maybe PersistValue
forall a. FromHttpApiData a => Key -> Maybe a
parseUrlPieceMaybe
fromPersistValueText :: PersistValue -> Either Text Text
fromPersistValueText :: PersistValue -> Either Key Key
fromPersistValueText (PersistText Key
s) = Key -> Either Key Key
forall a b. b -> Either a b
Right Key
s
fromPersistValueText (PersistByteString ByteString
bs) =
Key -> Either Key Key
forall a b. b -> Either a b
Right (Key -> Either Key Key) -> Key -> Either Key Key
forall a b. (a -> b) -> a -> b
$ OnDecodeError -> ByteString -> Key
TE.decodeUtf8With OnDecodeError
lenientDecode ByteString
bs
fromPersistValueText (PersistInt64 Int64
i) = Key -> Either Key Key
forall a b. b -> Either a b
Right (Key -> Either Key Key) -> Key -> Either Key Key
forall a b. (a -> b) -> a -> b
$ String -> Key
Text.pack (String -> Key) -> String -> Key
forall a b. (a -> b) -> a -> b
$ Int64 -> String
forall a. Show a => a -> String
show Int64
i
fromPersistValueText (PersistDouble Double
d) = Key -> Either Key Key
forall a b. b -> Either a b
Right (Key -> Either Key Key) -> Key -> Either Key Key
forall a b. (a -> b) -> a -> b
$ String -> Key
Text.pack (String -> Key) -> String -> Key
forall a b. (a -> b) -> a -> b
$ Double -> String
forall a. Show a => a -> String
show Double
d
fromPersistValueText (PersistRational Rational
r) = Key -> Either Key Key
forall a b. b -> Either a b
Right (Key -> Either Key Key) -> Key -> Either Key Key
forall a b. (a -> b) -> a -> b
$ String -> Key
Text.pack (String -> Key) -> String -> Key
forall a b. (a -> b) -> a -> b
$ Rational -> String
forall a. Show a => a -> String
show Rational
r
fromPersistValueText (PersistDay Day
d) = Key -> Either Key Key
forall a b. b -> Either a b
Right (Key -> Either Key Key) -> Key -> Either Key Key
forall a b. (a -> b) -> a -> b
$ String -> Key
Text.pack (String -> Key) -> String -> Key
forall a b. (a -> b) -> a -> b
$ Day -> String
forall a. Show a => a -> String
show Day
d
fromPersistValueText (PersistTimeOfDay TimeOfDay
d) = Key -> Either Key Key
forall a b. b -> Either a b
Right (Key -> Either Key Key) -> Key -> Either Key Key
forall a b. (a -> b) -> a -> b
$ String -> Key
Text.pack (String -> Key) -> String -> Key
forall a b. (a -> b) -> a -> b
$ TimeOfDay -> String
forall a. Show a => a -> String
show TimeOfDay
d
fromPersistValueText (PersistUTCTime UTCTime
d) = Key -> Either Key Key
forall a b. b -> Either a b
Right (Key -> Either Key Key) -> Key -> Either Key Key
forall a b. (a -> b) -> a -> b
$ String -> Key
Text.pack (String -> Key) -> String -> Key
forall a b. (a -> b) -> a -> b
$ UTCTime -> String
forall a. Show a => a -> String
show UTCTime
d
fromPersistValueText PersistValue
PersistNull = Key -> Either Key Key
forall a b. a -> Either a b
Left Key
"Unexpected null"
fromPersistValueText (PersistBool Bool
b) = Key -> Either Key Key
forall a b. b -> Either a b
Right (Key -> Either Key Key) -> Key -> Either Key Key
forall a b. (a -> b) -> a -> b
$ String -> Key
Text.pack (String -> Key) -> String -> Key
forall a b. (a -> b) -> a -> b
$ Bool -> String
forall a. Show a => a -> String
show Bool
b
fromPersistValueText (PersistList [PersistValue]
_) = Key -> Either Key Key
forall a b. a -> Either a b
Left Key
"Cannot convert PersistList to Text"
fromPersistValueText (PersistMap [(Key, PersistValue)]
_) = Key -> Either Key Key
forall a b. a -> Either a b
Left Key
"Cannot convert PersistMap to Text"
fromPersistValueText (PersistObjectId ByteString
_) = Key -> Either Key Key
forall a b. a -> Either a b
Left Key
"Cannot convert PersistObjectId to Text"
fromPersistValueText (PersistArray [PersistValue]
_) = Key -> Either Key Key
forall a b. a -> Either a b
Left Key
"Cannot convert PersistArray to Text"
fromPersistValueText (PersistLiteral_ LiteralType
_ ByteString
_) = Key -> Either Key Key
forall a b. a -> Either a b
Left Key
"Cannot convert PersistLiteral to Text"
instance A.ToJSON PersistValue where
toJSON :: PersistValue -> Value
toJSON (PersistText Key
t) = Key -> Value
A.String (Key -> Value) -> Key -> Value
forall a b. (a -> b) -> a -> b
$ Char -> Key -> Key
Text.cons Char
's' Key
t
toJSON (PersistByteString ByteString
b) = Key -> Value
A.String (Key -> Value) -> Key -> Value
forall a b. (a -> b) -> a -> b
$ Char -> Key -> Key
Text.cons Char
'b' (Key -> Key) -> Key -> Key
forall a b. (a -> b) -> a -> b
$ ByteString -> Key
TE.decodeUtf8 (ByteString -> Key) -> ByteString -> Key
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) = Key -> Value
A.String (Key -> Value) -> Key -> Value
forall a b. (a -> b) -> a -> b
$ String -> Key
Text.pack (String -> Key) -> String -> Key
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) = Key -> Value
A.String (Key -> Value) -> Key -> Value
forall a b. (a -> b) -> a -> b
$ String -> Key
Text.pack (String -> Key) -> String -> Key
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) = Key -> Value
A.String (Key -> Value) -> Key -> Value
forall a b. (a -> b) -> a -> b
$ String -> Key
Text.pack (String -> Key) -> String -> Key
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) = Key -> Value
A.String (Key -> Value) -> Key -> Value
forall a b. (a -> b) -> a -> b
$ String -> Key
Text.pack (String -> Key) -> String -> Key
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 [(Key, PersistValue)]
m) = [Pair] -> Value
A.object ([Pair] -> Value) -> [Pair] -> Value
forall a b. (a -> b) -> a -> b
$ ((Key, PersistValue) -> Pair) -> [(Key, PersistValue)] -> [Pair]
forall a b. (a -> b) -> [a] -> [b]
map (Key, PersistValue) -> Pair
forall a. ToJSON a => (Key, a) -> Pair
go [(Key, PersistValue)]
m
where go :: (Key, a) -> Pair
go (Key
k, a
v) = (Key -> Key
keyFromText Key
k, a -> Value
forall a. ToJSON a => a -> Value
A.toJSON a
v)
toJSON (PersistLiteral_ LiteralType
litTy ByteString
b) =
let encoded :: Key
encoded = ByteString -> Key
TE.decodeUtf8 (ByteString -> Key) -> ByteString -> Key
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
Key -> Value
A.String (Key -> Value) -> Key -> Value
forall a b. (a -> b) -> a -> b
$ Char -> Key -> Key
Text.cons Char
prefix Key
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
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 #-}
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 Key
t0) =
case Key -> Maybe (Char, Key)
Text.uncons Key
t0 of
Maybe (Char, Key)
Nothing -> String -> Parser PersistValue
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"Null string"
Just (Char
'p', Key
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
$ Key -> ByteString
TE.encodeUtf8 Key
t
Just (Char
'l', Key
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
$ Key -> ByteString
TE.encodeUtf8 Key
t
Just (Char
'e', Key
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
$ Key -> ByteString
TE.encodeUtf8 Key
t
Just (Char
's', Key
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
$ Key -> PersistValue
PersistText Key
t
Just (Char
'b', Key
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
$ Key -> ByteString
TE.encodeUtf8 Key
t
Just (Char
't', Key
t) -> TimeOfDay -> PersistValue
PersistTimeOfDay (TimeOfDay -> PersistValue)
-> Parser TimeOfDay -> Parser PersistValue
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Key -> Parser TimeOfDay
forall a (m :: * -> *). (Read a, MonadFail m) => Key -> m a
readMay Key
t
Just (Char
'u', Key
t) -> UTCTime -> PersistValue
PersistUTCTime (UTCTime -> PersistValue) -> Parser UTCTime -> Parser PersistValue
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Key -> Parser UTCTime
forall a (m :: * -> *). (Read a, MonadFail m) => Key -> m a
readMay Key
t
Just (Char
'd', Key
t) -> Day -> PersistValue
PersistDay (Day -> PersistValue) -> Parser Day -> Parser PersistValue
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Key -> Parser Day
forall a (m :: * -> *). (Read a, MonadFail m) => Key -> m a
readMay Key
t
Just (Char
'r', Key
t) -> Rational -> PersistValue
PersistRational (Rational -> PersistValue)
-> Parser Rational -> Parser PersistValue
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Key -> Parser Rational
forall a (m :: * -> *). (Read a, MonadFail m) => Key -> m a
readMay Key
t
Just (Char
'o', Key
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
$ Key -> String
Text.unpack Key
t
Just (Char
c, Key
_) -> 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 :: Key -> m a
readMay Key
t =
case ReadS a
forall a. Read a => ReadS a
reads ReadS a -> ReadS a
forall a b. (a -> b) -> a -> b
$ Key -> String
Text.unpack Key
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"
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) =
([(Key, PersistValue)] -> PersistValue)
-> Parser [(Key, PersistValue)] -> Parser PersistValue
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap [(Key, PersistValue)] -> PersistValue
PersistMap (Parser [(Key, PersistValue)] -> Parser PersistValue)
-> Parser [(Key, PersistValue)] -> Parser PersistValue
forall a b. (a -> b) -> a -> b
$ (Pair -> Parser (Key, PersistValue))
-> [Pair] -> Parser [(Key, PersistValue)]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM Pair -> Parser (Key, PersistValue)
forall b. FromJSON b => Pair -> Parser (Key, b)
go ([Pair] -> Parser [(Key, PersistValue)])
-> [Pair] -> Parser [(Key, PersistValue)]
forall a b. (a -> b) -> a -> b
$ Object -> [Pair]
forall k v. HashMap k v -> [(k, v)]
AM.toList Object
o
where
go :: Pair -> Parser (Key, b)
go (Key
k, Value
v) = (,) (Key -> Key
keyToText Key
k) (b -> (Key, b)) -> Parser b -> Parser (Key, 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