module Database.Persist.Redis.Parser
    ( redisToPerisistValues
    , toValue
    ) where

import Control.Arrow((***))
import Control.Monad (liftM, liftM3)
import Control.Exception (throw)
import Data.Binary (Binary(..), encode, getWord8, Get)
import qualified Data.Binary as Q
import qualified Data.ByteString as B
import qualified Data.ByteString.Lazy as L
import qualified Data.ByteString.UTF8 as U
import Data.Fixed
import Data.Int (Int64)
import Data.Text (Text, unpack)
import qualified Data.Text as T
import Data.Time
import Data.Word (Word8)

import Database.Persist.Types
import Database.Persist.Redis.Exception

newtype BinText = BinText { BinText -> Text
unBinText :: Text }
instance Binary BinText where
    put :: BinText -> Put
put = ByteString -> Put
forall t. Binary t => t -> Put
put (ByteString -> Put) -> (BinText -> ByteString) -> BinText -> Put
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> ByteString
U.fromString (String -> ByteString)
-> (BinText -> String) -> BinText -> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> String
unpack (Text -> String) -> (BinText -> Text) -> BinText -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. BinText -> Text
unBinText
    get :: Get BinText
get = do
        ByteString
str <- Get ByteString
forall t. Binary t => Get t
Q.get
        BinText -> Get BinText
forall a. a -> Get a
forall (m :: * -> *) a. Monad m => a -> m a
return (BinText -> Get BinText) -> BinText -> Get BinText
forall a b. (a -> b) -> a -> b
$ Text -> BinText
BinText (Text -> BinText) -> Text -> BinText
forall a b. (a -> b) -> a -> b
$ (String -> Text
T.pack (String -> Text) -> (ByteString -> String) -> ByteString -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> String
U.toString) ByteString
str

newtype BinPico= BinPico { BinPico -> Pico
unBinPico :: Pico }
instance Binary BinPico where
    put :: BinPico -> Put
put = Rational -> Put
forall t. Binary t => t -> Put
put (Rational -> Put) -> (BinPico -> Rational) -> BinPico -> Put
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Pico -> Rational
forall a. Real a => a -> Rational
toRational (Pico -> Rational) -> (BinPico -> Pico) -> BinPico -> Rational
forall b c a. (b -> c) -> (a -> b) -> a -> c
. BinPico -> Pico
unBinPico
    get :: Get BinPico
get = do
        Rational
x <- Get Rational
forall t. Binary t => Get t
Q.get :: Get Rational
        BinPico -> Get BinPico
forall a. a -> Get a
forall (m :: * -> *) a. Monad m => a -> m a
return (BinPico -> Get BinPico) -> BinPico -> Get BinPico
forall a b. (a -> b) -> a -> b
$ Pico -> BinPico
BinPico (Rational -> Pico
forall a. Fractional a => Rational -> a
fromRational Rational
x)

newtype BinDiffTime = BinDiffTime { BinDiffTime -> DiffTime
unBinDiffTime :: DiffTime }
instance Binary BinDiffTime where
    put :: BinDiffTime -> Put
put = Rational -> Put
forall t. Binary t => t -> Put
put (Rational -> Put)
-> (BinDiffTime -> Rational) -> BinDiffTime -> Put
forall b c a. (b -> c) -> (a -> b) -> a -> c
. DiffTime -> Rational
forall a. Real a => a -> Rational
toRational (DiffTime -> Rational)
-> (BinDiffTime -> DiffTime) -> BinDiffTime -> Rational
forall b c a. (b -> c) -> (a -> b) -> a -> c
. BinDiffTime -> DiffTime
unBinDiffTime
    get :: Get BinDiffTime
get = do
        Rational
x <- Get Rational
forall t. Binary t => Get t
Q.get :: Get Rational
        BinDiffTime -> Get BinDiffTime
forall a. a -> Get a
forall (m :: * -> *) a. Monad m => a -> m a
return (BinDiffTime -> Get BinDiffTime) -> BinDiffTime -> Get BinDiffTime
forall a b. (a -> b) -> a -> b
$ DiffTime -> BinDiffTime
BinDiffTime (Rational -> DiffTime
forall a. Fractional a => Rational -> a
fromRational Rational
x)

newtype BinDay = BinDay { BinDay -> Day
unBinDay :: Day }
instance Binary BinDay where
    put :: BinDay -> Put
put (BinDay (ModifiedJulianDay Integer
x)) = Integer -> Put
forall t. Binary t => t -> Put
put Integer
x
    get :: Get BinDay
get = do
        Integer
x <- Get Integer
forall t. Binary t => Get t
Q.get :: Get Integer
        BinDay -> Get BinDay
forall a. a -> Get a
forall (m :: * -> *) a. Monad m => a -> m a
return (BinDay -> Get BinDay) -> BinDay -> Get BinDay
forall a b. (a -> b) -> a -> b
$ Day -> BinDay
BinDay (Integer -> Day
ModifiedJulianDay Integer
x)

newtype BinTimeOfDay = BinTimeOfDay { BinTimeOfDay -> TimeOfDay
unBinTimeOfDay :: TimeOfDay }
instance Binary BinTimeOfDay where
    put :: BinTimeOfDay -> Put
put (BinTimeOfDay (TimeOfDay Int
h Int
m Pico
s)) = do
        Int -> Put
forall t. Binary t => t -> Put
put Int
h
        Int -> Put
forall t. Binary t => t -> Put
put Int
m
        BinPico -> Put
forall t. Binary t => t -> Put
put (Pico -> BinPico
BinPico Pico
s)
    get :: Get BinTimeOfDay
get = do
        let s :: Get Pico
s = (BinPico -> Pico) -> Get BinPico -> Get Pico
forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
liftM BinPico -> Pico
unBinPico (Get BinPico
forall t. Binary t => Get t
Q.get :: Get BinPico)
        let tod :: Get TimeOfDay
tod = (Int -> Int -> Pico -> TimeOfDay)
-> Get Int -> Get Int -> Get Pico -> Get TimeOfDay
forall (m :: * -> *) a1 a2 a3 r.
Monad m =>
(a1 -> a2 -> a3 -> r) -> m a1 -> m a2 -> m a3 -> m r
liftM3 Int -> Int -> Pico -> TimeOfDay
TimeOfDay (Get Int
forall t. Binary t => Get t
Q.get :: Get Int) (Get Int
forall t. Binary t => Get t
Q.get :: Get Int) Get Pico
s
        (TimeOfDay -> BinTimeOfDay) -> Get TimeOfDay -> Get BinTimeOfDay
forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
liftM TimeOfDay -> BinTimeOfDay
BinTimeOfDay Get TimeOfDay
tod

{-
newtype BinZT = BinZT { unBinZT :: ZT }
instance Binary BinZT where
    put (BinZT (ZT (ZonedTime (LocalTime day timeOfDay) (TimeZone mins summer name)))) = do
        put (BinDay day)
        put (BinTimeOfDay timeOfDay)
        put mins
        put summer
        put name

    get = do
        day <- Q.get :: Get BinDay
        timeOfDay <- Q.get :: Get BinTimeOfDay
        mins <- Q.get :: Get Int
        summer <- Q.get :: Get Bool
        name <- Q.get :: Get String
        return $ BinZT $ ZT (ZonedTime (LocalTime (unBinDay day) (unBinTimeOfDay timeOfDay)) (TimeZone mins summer name))
-}
newtype BinPersistValue = BinPersistValue { BinPersistValue -> PersistValue
unBinPersistValue :: PersistValue }
instance Binary BinPersistValue where
    put :: BinPersistValue -> Put
put (BinPersistValue (PersistText Text
x)) = do
        Word8 -> Put
forall t. Binary t => t -> Put
put (Word8
1 :: Word8)
        ByteString -> Put
forall t. Binary t => t -> Put
put (ByteString -> Put) -> ByteString -> Put
forall a b. (a -> b) -> a -> b
$ (String -> ByteString
U.fromString (String -> ByteString) -> (Text -> String) -> Text -> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> String
unpack) Text
x

    put (BinPersistValue (PersistByteString ByteString
x)) = do
        Word8 -> Put
forall t. Binary t => t -> Put
put (Word8
2 :: Word8)
        ByteString -> Put
forall t. Binary t => t -> Put
put ByteString
x

    put (BinPersistValue (PersistInt64 Int64
x)) = do
        Word8 -> Put
forall t. Binary t => t -> Put
put (Word8
3 :: Word8)
        Int64 -> Put
forall t. Binary t => t -> Put
put Int64
x

    put (BinPersistValue (PersistDouble Double
x)) = do
        Word8 -> Put
forall t. Binary t => t -> Put
put (Word8
4 :: Word8)
        Double -> Put
forall t. Binary t => t -> Put
put Double
x

    put (BinPersistValue (PersistBool Bool
x)) = do
        Word8 -> Put
forall t. Binary t => t -> Put
put (Word8
5 :: Word8)
        Bool -> Put
forall t. Binary t => t -> Put
put Bool
x

    put (BinPersistValue (PersistDay Day
day)) = do
        Word8 -> Put
forall t. Binary t => t -> Put
put (Word8
6 :: Word8)
        BinDay -> Put
forall t. Binary t => t -> Put
put (Day -> BinDay
BinDay Day
day)

    put (BinPersistValue (PersistTimeOfDay TimeOfDay
tod)) = do
        Word8 -> Put
forall t. Binary t => t -> Put
put (Word8
7 :: Word8)
        BinTimeOfDay -> Put
forall t. Binary t => t -> Put
put (TimeOfDay -> BinTimeOfDay
BinTimeOfDay TimeOfDay
tod)

    put (BinPersistValue (PersistUTCTime (UTCTime Day
day DiffTime
pc))) = do
        Word8 -> Put
forall t. Binary t => t -> Put
put (Word8
8 :: Word8)
        BinDay -> Put
forall t. Binary t => t -> Put
put (Day -> BinDay
BinDay Day
day)
        BinDiffTime -> Put
forall t. Binary t => t -> Put
put (DiffTime -> BinDiffTime
BinDiffTime DiffTime
pc)

    put (BinPersistValue PersistValue
PersistNull) = Word8 -> Put
forall t. Binary t => t -> Put
put (Word8
9 :: Word8)
    put (BinPersistValue (PersistList [PersistValue]
x)) = do
        Word8 -> Put
forall t. Binary t => t -> Put
put (Word8
10 :: Word8)
        [BinPersistValue] -> Put
forall t. Binary t => t -> Put
put ((PersistValue -> BinPersistValue)
-> [PersistValue] -> [BinPersistValue]
forall a b. (a -> b) -> [a] -> [b]
map PersistValue -> BinPersistValue
BinPersistValue [PersistValue]
x)

    put (BinPersistValue (PersistMap [(Text, PersistValue)]
x)) = do
        Word8 -> Put
forall t. Binary t => t -> Put
put (Word8
11 :: Word8)
        [(BinText, BinPersistValue)] -> Put
forall t. Binary t => t -> Put
put (((Text, PersistValue) -> (BinText, BinPersistValue))
-> [(Text, PersistValue)] -> [(BinText, BinPersistValue)]
forall a b. (a -> b) -> [a] -> [b]
map (Text -> BinText
BinText (Text -> BinText)
-> (PersistValue -> BinPersistValue)
-> (Text, PersistValue)
-> (BinText, BinPersistValue)
forall b c b' c'. (b -> c) -> (b' -> c') -> (b, b') -> (c, c')
forall (a :: * -> * -> *) b c b' c'.
Arrow a =>
a b c -> a b' c' -> a (b, b') (c, c')
*** PersistValue -> BinPersistValue
BinPersistValue) [(Text, PersistValue)]
x)

    put (BinPersistValue (PersistRational Rational
x)) = do
        Word8 -> Put
forall t. Binary t => t -> Put
put (Word8
12 :: Word8)
        Rational -> Put
forall t. Binary t => t -> Put
put Rational
x

    put (BinPersistValue (PersistArray [PersistValue]
_)) = RedisException -> Put
forall a e. Exception e => e -> a
throw (RedisException -> Put) -> RedisException -> Put
forall a b. (a -> b) -> a -> b
$ String -> RedisException
NotSupportedValueType String
"PersistArray"
    put (BinPersistValue (PersistLiteral_ LiteralType
_ ByteString
_)) = RedisException -> Put
forall a e. Exception e => e -> a
throw (RedisException -> Put) -> RedisException -> Put
forall a b. (a -> b) -> a -> b
$ String -> RedisException
NotSupportedValueType String
"PersistLiteral_"
    put (BinPersistValue (PersistObjectId ByteString
_)) = RedisException -> Put
forall a e. Exception e => e -> a
throw (RedisException -> Put) -> RedisException -> Put
forall a b. (a -> b) -> a -> b
$ String -> RedisException
NotSupportedValueType String
"PersistObjectId"

    get :: Get BinPersistValue
get = do
        Word8
tag <- Get Word8
getWord8
        let pv :: Get PersistValue
pv = case Word8
tag of
                Word8
1 -> (BinText -> PersistValue) -> Get BinText -> Get PersistValue
forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
liftM (Text -> PersistValue
PersistText (Text -> PersistValue)
-> (BinText -> Text) -> BinText -> PersistValue
forall b c a. (b -> c) -> (a -> b) -> a -> c
. BinText -> Text
unBinText) (Get BinText
forall t. Binary t => Get t
Q.get :: Get BinText)
                Word8
2 -> (ByteString -> PersistValue) -> Get ByteString -> Get PersistValue
forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
liftM ByteString -> PersistValue
PersistByteString (Get ByteString
forall t. Binary t => Get t
Q.get :: Get B.ByteString)
                Word8
3 -> (Int64 -> PersistValue) -> Get Int64 -> Get PersistValue
forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
liftM Int64 -> PersistValue
PersistInt64 (Get Int64
forall t. Binary t => Get t
Q.get :: Get Int64)
                Word8
4 -> (Double -> PersistValue) -> Get Double -> Get PersistValue
forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
liftM Double -> PersistValue
PersistDouble (Get Double
forall t. Binary t => Get t
Q.get :: Get Double)
                Word8
5 -> (Bool -> PersistValue) -> Get Bool -> Get PersistValue
forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
liftM Bool -> PersistValue
PersistBool (Get Bool
forall t. Binary t => Get t
Q.get :: Get Bool)
                Word8
6 -> (BinDay -> PersistValue) -> Get BinDay -> Get PersistValue
forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
liftM (Day -> PersistValue
PersistDay (Day -> PersistValue) -> (BinDay -> Day) -> BinDay -> PersistValue
forall b c a. (b -> c) -> (a -> b) -> a -> c
. BinDay -> Day
unBinDay) (Get BinDay
forall t. Binary t => Get t
Q.get :: Get BinDay)
                Word8
7 -> (BinTimeOfDay -> PersistValue)
-> Get BinTimeOfDay -> Get PersistValue
forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
liftM (TimeOfDay -> PersistValue
PersistTimeOfDay (TimeOfDay -> PersistValue)
-> (BinTimeOfDay -> TimeOfDay) -> BinTimeOfDay -> PersistValue
forall b c a. (b -> c) -> (a -> b) -> a -> c
. BinTimeOfDay -> TimeOfDay
unBinTimeOfDay) (Get BinTimeOfDay
forall t. Binary t => Get t
Q.get :: Get BinTimeOfDay)
                Word8
8 -> do
                    BinDay
d <- Get BinDay
forall t. Binary t => Get t
Q.get :: Get BinDay
                    BinDiffTime
dt <- Get BinDiffTime
forall t. Binary t => Get t
Q.get :: Get BinDiffTime
                    let utctime :: UTCTime
utctime = Day -> DiffTime -> UTCTime
UTCTime (BinDay -> Day
unBinDay BinDay
d) (BinDiffTime -> DiffTime
unBinDiffTime BinDiffTime
dt)
                    PersistValue -> Get PersistValue
forall a. a -> Get a
forall (m :: * -> *) a. Monad m => a -> m a
return (PersistValue -> Get PersistValue)
-> PersistValue -> Get PersistValue
forall a b. (a -> b) -> a -> b
$  UTCTime -> PersistValue
PersistUTCTime UTCTime
utctime
                Word8
9 -> PersistValue -> Get PersistValue
forall a. a -> Get a
forall (m :: * -> *) a. Monad m => a -> m a
return PersistValue
PersistNull
                Word8
10-> ([BinPersistValue] -> PersistValue)
-> Get [BinPersistValue] -> Get PersistValue
forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
liftM ([PersistValue] -> PersistValue
PersistList ([PersistValue] -> PersistValue)
-> ([BinPersistValue] -> [PersistValue])
-> [BinPersistValue]
-> PersistValue
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (BinPersistValue -> PersistValue)
-> [BinPersistValue] -> [PersistValue]
forall a b. (a -> b) -> [a] -> [b]
map BinPersistValue -> PersistValue
unBinPersistValue) (Get [BinPersistValue]
forall t. Binary t => Get t
Q.get :: Get [BinPersistValue])
                Word8
11-> ([(BinText, BinPersistValue)] -> PersistValue)
-> Get [(BinText, BinPersistValue)] -> Get PersistValue
forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
liftM ([(Text, PersistValue)] -> PersistValue
PersistMap ([(Text, PersistValue)] -> PersistValue)
-> ([(BinText, BinPersistValue)] -> [(Text, PersistValue)])
-> [(BinText, BinPersistValue)]
-> PersistValue
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((BinText, BinPersistValue) -> (Text, PersistValue))
-> [(BinText, BinPersistValue)] -> [(Text, PersistValue)]
forall a b. (a -> b) -> [a] -> [b]
map (BinText -> Text
unBinText (BinText -> Text)
-> (BinPersistValue -> PersistValue)
-> (BinText, BinPersistValue)
-> (Text, PersistValue)
forall b c b' c'. (b -> c) -> (b' -> c') -> (b, b') -> (c, c')
forall (a :: * -> * -> *) b c b' c'.
Arrow a =>
a b c -> a b' c' -> a (b, b') (c, c')
*** BinPersistValue -> PersistValue
unBinPersistValue)) (Get [(BinText, BinPersistValue)]
forall t. Binary t => Get t
Q.get :: Get [(BinText, BinPersistValue)])
                Word8
12-> (Rational -> PersistValue) -> Get Rational -> Get PersistValue
forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
liftM Rational -> PersistValue
PersistRational (Get Rational
forall t. Binary t => Get t
Q.get :: Get Rational)
--                13-> liftM (PersistZonedTime . unBinZT) (Q.get :: Get BinZT)
                Word8
z -> RedisException -> Get PersistValue
forall a e. Exception e => e -> a
throw (RedisException -> Get PersistValue)
-> RedisException -> Get PersistValue
forall a b. (a -> b) -> a -> b
$ String -> RedisException
ParserError (String
"Incorrect tag " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Word8 -> String
forall a. Show a => a -> String
show Word8
z String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" came to Binary deserialization")
        (PersistValue -> BinPersistValue)
-> Get PersistValue -> Get BinPersistValue
forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
liftM PersistValue -> BinPersistValue
BinPersistValue Get PersistValue
pv

toValue :: PersistValue -> B.ByteString
toValue :: PersistValue -> ByteString
toValue = ByteString -> ByteString
L.toStrict (ByteString -> ByteString)
-> (PersistValue -> ByteString) -> PersistValue -> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. BinPersistValue -> ByteString
forall a. Binary a => a -> ByteString
encode (BinPersistValue -> ByteString)
-> (PersistValue -> BinPersistValue) -> PersistValue -> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. PersistValue -> BinPersistValue
BinPersistValue

castOne :: B.ByteString -> PersistValue
castOne :: ByteString -> PersistValue
castOne = BinPersistValue -> PersistValue
unBinPersistValue (BinPersistValue -> PersistValue)
-> (ByteString -> BinPersistValue) -> ByteString -> PersistValue
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> BinPersistValue
forall a. Binary a => ByteString -> a
Q.decode (ByteString -> BinPersistValue)
-> (ByteString -> ByteString) -> ByteString -> BinPersistValue
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> ByteString
L.fromStrict

redisToPerisistValues :: [(B.ByteString, B.ByteString)] -> [PersistValue]
redisToPerisistValues :: [(ByteString, ByteString)] -> [PersistValue]
redisToPerisistValues = ((ByteString, ByteString) -> PersistValue)
-> [(ByteString, ByteString)] -> [PersistValue]
forall a b. (a -> b) -> [a] -> [b]
map (ByteString -> PersistValue
castOne (ByteString -> PersistValue)
-> ((ByteString, ByteString) -> ByteString)
-> (ByteString, ByteString)
-> PersistValue
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (ByteString, ByteString) -> ByteString
forall a b. (a, b) -> b
snd)