{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE CPP, FlexibleInstances, TypeSynonymInstances,
    OverloadedStrings #-}

#if __GLASGOW_HASKELL__ < 710
{-# LANGUAGE OverlappingInstances #-}
#endif

module Database.Redis.Types where

#if __GLASGOW_HASKELL__ < 710
import Control.Applicative
#endif
import Control.DeepSeq
import Data.ByteString.Char8 (ByteString, pack)
import qualified Data.ByteString.Lex.Fractional as F (readSigned, readExponential)
import qualified Data.ByteString.Lex.Integral as I (readSigned, readDecimal)
import GHC.Generics

import Database.Redis.Protocol


------------------------------------------------------------------------------
-- Classes of types Redis understands
--
class RedisArg a where
    encode :: a -> ByteString

class RedisResult a where
    decode :: Reply -> Either Reply a

------------------------------------------------------------------------------
-- RedisArg instances
--
instance RedisArg ByteString where
    encode :: ByteString -> ByteString
encode = ByteString -> ByteString
forall a. a -> a
id

instance RedisArg Integer where
    encode :: Integer -> ByteString
encode = String -> ByteString
pack (String -> ByteString)
-> (Integer -> String) -> Integer -> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Integer -> String
forall a. Show a => a -> String
show

instance RedisArg Double where
    encode :: Double -> ByteString
encode Double
a
        | Double -> Bool
forall a. RealFloat a => a -> Bool
isInfinite Double
a Bool -> Bool -> Bool
&& Double
a Double -> Double -> Bool
forall a. Ord a => a -> a -> Bool
> Double
0 = ByteString
"+inf"
        | Double -> Bool
forall a. RealFloat a => a -> Bool
isInfinite Double
a Bool -> Bool -> Bool
&& Double
a Double -> Double -> Bool
forall a. Ord a => a -> a -> Bool
< Double
0 = ByteString
"-inf"
        | Bool
otherwise = String -> ByteString
pack (String -> ByteString)
-> (Double -> String) -> Double -> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Double -> String
forall a. Show a => a -> String
show (Double -> ByteString) -> Double -> ByteString
forall a b. (a -> b) -> a -> b
$ Double
a

------------------------------------------------------------------------------
-- RedisResult instances
--
data Status = Ok | Pong | Status ByteString
    deriving (Int -> Status -> ShowS
[Status] -> ShowS
Status -> String
(Int -> Status -> ShowS)
-> (Status -> String) -> ([Status] -> ShowS) -> Show Status
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Status] -> ShowS
$cshowList :: [Status] -> ShowS
show :: Status -> String
$cshow :: Status -> String
showsPrec :: Int -> Status -> ShowS
$cshowsPrec :: Int -> Status -> ShowS
Show, Status -> Status -> Bool
(Status -> Status -> Bool)
-> (Status -> Status -> Bool) -> Eq Status
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Status -> Status -> Bool
$c/= :: Status -> Status -> Bool
== :: Status -> Status -> Bool
$c== :: Status -> Status -> Bool
Eq, (forall x. Status -> Rep Status x)
-> (forall x. Rep Status x -> Status) -> Generic Status
forall x. Rep Status x -> Status
forall x. Status -> Rep Status x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cto :: forall x. Rep Status x -> Status
$cfrom :: forall x. Status -> Rep Status x
Generic)

instance NFData Status

data RedisType = None | String | Hash | List | Set | ZSet
    deriving (Int -> RedisType -> ShowS
[RedisType] -> ShowS
RedisType -> String
(Int -> RedisType -> ShowS)
-> (RedisType -> String)
-> ([RedisType] -> ShowS)
-> Show RedisType
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [RedisType] -> ShowS
$cshowList :: [RedisType] -> ShowS
show :: RedisType -> String
$cshow :: RedisType -> String
showsPrec :: Int -> RedisType -> ShowS
$cshowsPrec :: Int -> RedisType -> ShowS
Show, RedisType -> RedisType -> Bool
(RedisType -> RedisType -> Bool)
-> (RedisType -> RedisType -> Bool) -> Eq RedisType
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: RedisType -> RedisType -> Bool
$c/= :: RedisType -> RedisType -> Bool
== :: RedisType -> RedisType -> Bool
$c== :: RedisType -> RedisType -> Bool
Eq)

instance RedisResult Reply where
    decode :: Reply -> Either Reply Reply
decode = Reply -> Either Reply Reply
forall a b. b -> Either a b
Right

instance RedisResult ByteString where
    decode :: Reply -> Either Reply ByteString
decode (SingleLine ByteString
s)  = ByteString -> Either Reply ByteString
forall a b. b -> Either a b
Right ByteString
s
    decode (Bulk (Just ByteString
s)) = ByteString -> Either Reply ByteString
forall a b. b -> Either a b
Right ByteString
s
    decode Reply
r               = Reply -> Either Reply ByteString
forall a b. a -> Either a b
Left Reply
r

instance RedisResult Integer where
    decode :: Reply -> Either Reply Integer
decode (Integer Integer
n) = Integer -> Either Reply Integer
forall a b. b -> Either a b
Right Integer
n
    decode Reply
r           =
        Either Reply Integer
-> ((Integer, ByteString) -> Either Reply Integer)
-> Maybe (Integer, ByteString)
-> Either Reply Integer
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (Reply -> Either Reply Integer
forall a b. a -> Either a b
Left Reply
r) (Integer -> Either Reply Integer
forall a b. b -> Either a b
Right (Integer -> Either Reply Integer)
-> ((Integer, ByteString) -> Integer)
-> (Integer, ByteString)
-> Either Reply Integer
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Integer, ByteString) -> Integer
forall a b. (a, b) -> a
fst) (Maybe (Integer, ByteString) -> Either Reply Integer)
-> (ByteString -> Maybe (Integer, ByteString))
-> ByteString
-> Either Reply Integer
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (ByteString -> Maybe (Integer, ByteString))
-> ByteString -> Maybe (Integer, ByteString)
forall a.
Num a =>
(ByteString -> Maybe (a, ByteString))
-> ByteString -> Maybe (a, ByteString)
I.readSigned ByteString -> Maybe (Integer, ByteString)
forall a. Integral a => ByteString -> Maybe (a, ByteString)
I.readDecimal (ByteString -> Either Reply Integer)
-> Either Reply ByteString -> Either Reply Integer
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< Reply -> Either Reply ByteString
forall a. RedisResult a => Reply -> Either Reply a
decode Reply
r

instance RedisResult Double where
    decode :: Reply -> Either Reply Double
decode Reply
r = Either Reply Double
-> ((Double, ByteString) -> Either Reply Double)
-> Maybe (Double, ByteString)
-> Either Reply Double
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (Reply -> Either Reply Double
forall a b. a -> Either a b
Left Reply
r) (Double -> Either Reply Double
forall a b. b -> Either a b
Right (Double -> Either Reply Double)
-> ((Double, ByteString) -> Double)
-> (Double, ByteString)
-> Either Reply Double
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Double, ByteString) -> Double
forall a b. (a, b) -> a
fst) (Maybe (Double, ByteString) -> Either Reply Double)
-> (ByteString -> Maybe (Double, ByteString))
-> ByteString
-> Either Reply Double
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (ByteString -> Maybe (Double, ByteString))
-> ByteString -> Maybe (Double, ByteString)
forall a.
Num a =>
(ByteString -> Maybe (a, ByteString))
-> ByteString -> Maybe (a, ByteString)
F.readSigned ByteString -> Maybe (Double, ByteString)
forall a. Fractional a => ByteString -> Maybe (a, ByteString)
F.readExponential (ByteString -> Either Reply Double)
-> Either Reply ByteString -> Either Reply Double
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< Reply -> Either Reply ByteString
forall a. RedisResult a => Reply -> Either Reply a
decode Reply
r

instance RedisResult Status where
    decode :: Reply -> Either Reply Status
decode (SingleLine ByteString
s) = Status -> Either Reply Status
forall a b. b -> Either a b
Right (Status -> Either Reply Status) -> Status -> Either Reply Status
forall a b. (a -> b) -> a -> b
$ case ByteString
s of
        ByteString
"OK"     -> Status
Ok
        ByteString
"PONG"   -> Status
Pong
        ByteString
_        -> ByteString -> Status
Status ByteString
s
    decode Reply
r = Reply -> Either Reply Status
forall a b. a -> Either a b
Left Reply
r

instance RedisResult RedisType where
    decode :: Reply -> Either Reply RedisType
decode (SingleLine ByteString
s) = RedisType -> Either Reply RedisType
forall a b. b -> Either a b
Right (RedisType -> Either Reply RedisType)
-> RedisType -> Either Reply RedisType
forall a b. (a -> b) -> a -> b
$ case ByteString
s of
        ByteString
"none"   -> RedisType
None
        ByteString
"string" -> RedisType
String
        ByteString
"hash"   -> RedisType
Hash
        ByteString
"list"   -> RedisType
List
        ByteString
"set"    -> RedisType
Set
        ByteString
"zset"   -> RedisType
ZSet
        ByteString
_        -> String -> RedisType
forall a. HasCallStack => String -> a
error (String -> RedisType) -> String -> RedisType
forall a b. (a -> b) -> a -> b
$ String
"Hedis: unhandled redis type: " String -> ShowS
forall a. [a] -> [a] -> [a]
++ ByteString -> String
forall a. Show a => a -> String
show ByteString
s
    decode Reply
r = Reply -> Either Reply RedisType
forall a b. a -> Either a b
Left Reply
r

instance RedisResult Bool where
    decode :: Reply -> Either Reply Bool
decode (Integer Integer
1)    = Bool -> Either Reply Bool
forall a b. b -> Either a b
Right Bool
True
    decode (Integer Integer
0)    = Bool -> Either Reply Bool
forall a b. b -> Either a b
Right Bool
False
    decode (Bulk Maybe ByteString
Nothing) = Bool -> Either Reply Bool
forall a b. b -> Either a b
Right Bool
False -- Lua boolean false = nil bulk reply
    decode Reply
r              = Reply -> Either Reply Bool
forall a b. a -> Either a b
Left Reply
r

instance (RedisResult a) => RedisResult (Maybe a) where
    decode :: Reply -> Either Reply (Maybe a)
decode (Bulk Maybe ByteString
Nothing)      = Maybe a -> Either Reply (Maybe a)
forall a b. b -> Either a b
Right Maybe a
forall a. Maybe a
Nothing
    decode (MultiBulk Maybe [Reply]
Nothing) = Maybe a -> Either Reply (Maybe a)
forall a b. b -> Either a b
Right Maybe a
forall a. Maybe a
Nothing
    decode Reply
r                   = a -> Maybe a
forall a. a -> Maybe a
Just (a -> Maybe a) -> Either Reply a -> Either Reply (Maybe a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Reply -> Either Reply a
forall a. RedisResult a => Reply -> Either Reply a
decode Reply
r

instance
#if __GLASGOW_HASKELL__ >= 710
    {-# OVERLAPPABLE #-}
#endif
    (RedisResult a) => RedisResult [a] where
    decode :: Reply -> Either Reply [a]
decode (MultiBulk (Just [Reply]
rs)) = (Reply -> Either Reply a) -> [Reply] -> Either Reply [a]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM Reply -> Either Reply a
forall a. RedisResult a => Reply -> Either Reply a
decode [Reply]
rs
    decode Reply
r                     = Reply -> Either Reply [a]
forall a b. a -> Either a b
Left Reply
r
 
instance (RedisResult a, RedisResult b) => RedisResult (a,b) where
    decode :: Reply -> Either Reply (a, b)
decode (MultiBulk (Just [Reply
x, Reply
y])) = (,) (a -> b -> (a, b)) -> Either Reply a -> Either Reply (b -> (a, b))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Reply -> Either Reply a
forall a. RedisResult a => Reply -> Either Reply a
decode Reply
x Either Reply (b -> (a, b)) -> Either Reply b -> Either Reply (a, b)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Reply -> Either Reply b
forall a. RedisResult a => Reply -> Either Reply a
decode Reply
y
    decode Reply
r                         = Reply -> Either Reply (a, b)
forall a b. a -> Either a b
Left Reply
r

instance (RedisResult k, RedisResult v) => RedisResult [(k,v)] where
    decode :: Reply -> Either Reply [(k, v)]
decode Reply
r = case Reply
r of
                (MultiBulk (Just [Reply]
rs)) -> [Reply] -> Either Reply [(k, v)]
forall a b.
(RedisResult a, RedisResult b) =>
[Reply] -> Either Reply [(a, b)]
pairs [Reply]
rs
                Reply
_                     -> Reply -> Either Reply [(k, v)]
forall a b. a -> Either a b
Left Reply
r
      where
        pairs :: [Reply] -> Either Reply [(a, b)]
pairs []         = [(a, b)] -> Either Reply [(a, b)]
forall a b. b -> Either a b
Right []
        pairs (Reply
_:[])     = Reply -> Either Reply [(a, b)]
forall a b. a -> Either a b
Left Reply
r
        pairs (Reply
r1:Reply
r2:[Reply]
rs) = do
            a
k   <- Reply -> Either Reply a
forall a. RedisResult a => Reply -> Either Reply a
decode Reply
r1
            b
v   <- Reply -> Either Reply b
forall a. RedisResult a => Reply -> Either Reply a
decode Reply
r2
            [(a, b)]
kvs <- [Reply] -> Either Reply [(a, b)]
pairs [Reply]
rs
            [(a, b)] -> Either Reply [(a, b)]
forall (m :: * -> *) a. Monad m => a -> m a
return ([(a, b)] -> Either Reply [(a, b)])
-> [(a, b)] -> Either Reply [(a, b)]
forall a b. (a -> b) -> a -> b
$ (a
k,b
v) (a, b) -> [(a, b)] -> [(a, b)]
forall a. a -> [a] -> [a]
: [(a, b)]
kvs