{-# LANGUAGE OverloadedStrings, GeneralizedNewtypeDeriving, RecordWildCards,
    MultiParamTypeClasses, FunctionalDependencies, FlexibleInstances, CPP,
    DeriveDataTypeable, StandaloneDeriving #-}

module Database.Redis.Core (
    Redis(), unRedis, reRedis,
    RedisCtx(..), MonadRedis(..),
    send, recv, sendRequest,
    runRedisInternal,
    runRedisClusteredInternal,
    RedisEnv(..),
) where

import Prelude
#if __GLASGOW_HASKELL__ < 710
import Control.Applicative
#endif
import Control.Monad.Reader
import qualified Data.ByteString as B
import Data.IORef
import Database.Redis.Core.Internal
import Database.Redis.Protocol
import qualified Database.Redis.ProtocolPipelining as PP
import Database.Redis.Types
import Database.Redis.Cluster(ShardMap)
import qualified Database.Redis.Cluster as Cluster

--------------------------------------------------------------------------------
-- The Redis Monad
--

-- |This class captures the following behaviour: In a context @m@, a command
--  will return its result wrapped in a \"container\" of type @f@.
--
--  Please refer to the Command Type Signatures section of this page for more
--  information.
class (MonadRedis m) => RedisCtx m f | m -> f where
    returnDecode :: RedisResult a => Reply -> m (f a)

class (Monad m) => MonadRedis m where
    liftRedis :: Redis a -> m a


instance RedisCtx Redis (Either Reply) where
    returnDecode :: Reply -> Redis (Either Reply a)
returnDecode = Either Reply a -> Redis (Either Reply a)
forall (m :: * -> *) a. Monad m => a -> m a
return (Either Reply a -> Redis (Either Reply a))
-> (Reply -> Either Reply a) -> Reply -> Redis (Either Reply a)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Reply -> Either Reply a
forall a. RedisResult a => Reply -> Either Reply a
decode

instance MonadRedis Redis where
    liftRedis :: Redis a -> Redis a
liftRedis = Redis a -> Redis a
forall a. a -> a
id

-- |Deconstruct Redis constructor.
--
--  'unRedis' and 'reRedis' can be used to define instances for
--  arbitrary typeclasses.
--
--  WARNING! These functions are considered internal and no guarantee
--  is given at this point that they will not break in future.
unRedis :: Redis a -> ReaderT RedisEnv IO a
unRedis :: Redis a -> ReaderT RedisEnv IO a
unRedis (Redis ReaderT RedisEnv IO a
r) = ReaderT RedisEnv IO a
r

-- |Reconstruct Redis constructor.
reRedis :: ReaderT RedisEnv IO a -> Redis a
reRedis :: ReaderT RedisEnv IO a -> Redis a
reRedis ReaderT RedisEnv IO a
r = ReaderT RedisEnv IO a -> Redis a
forall a. ReaderT RedisEnv IO a -> Redis a
Redis ReaderT RedisEnv IO a
r

-- |Internal version of 'runRedis' that does not depend on the 'Connection'
--  abstraction. Used to run the AUTH command when connecting.
runRedisInternal :: PP.Connection -> Redis a -> IO a
runRedisInternal :: Connection -> Redis a -> IO a
runRedisInternal Connection
conn (Redis ReaderT RedisEnv IO a
redis) = do
  -- Dummy reply in case no request is sent.
  IORef Reply
ref <- Reply -> IO (IORef Reply)
forall a. a -> IO (IORef a)
newIORef (ByteString -> Reply
SingleLine ByteString
"nobody will ever see this")
  a
r <- ReaderT RedisEnv IO a -> RedisEnv -> IO a
forall r (m :: * -> *) a. ReaderT r m a -> r -> m a
runReaderT ReaderT RedisEnv IO a
redis (Connection -> IORef Reply -> RedisEnv
NonClusteredEnv Connection
conn IORef Reply
ref)
  -- Evaluate last reply to keep lazy IO inside runRedis.
  IORef Reply -> IO Reply
forall a. IORef a -> IO a
readIORef IORef Reply
ref IO Reply -> (Reply -> IO ()) -> IO ()
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= (Reply -> IO () -> IO ()
`seq` () -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ())
  a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return a
r

runRedisClusteredInternal :: Cluster.Connection -> IO ShardMap -> Redis a -> IO a
runRedisClusteredInternal :: Connection -> IO ShardMap -> Redis a -> IO a
runRedisClusteredInternal Connection
connection IO ShardMap
refreshShardmapAction (Redis ReaderT RedisEnv IO a
redis) = do
    a
r <- ReaderT RedisEnv IO a -> RedisEnv -> IO a
forall r (m :: * -> *) a. ReaderT r m a -> r -> m a
runReaderT ReaderT RedisEnv IO a
redis (IO ShardMap -> Connection -> RedisEnv
ClusteredEnv IO ShardMap
refreshShardmapAction Connection
connection)
    a
r a -> IO () -> IO ()
`seq` () -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
    a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return a
r

setLastReply :: Reply -> ReaderT RedisEnv IO ()
setLastReply :: Reply -> ReaderT RedisEnv IO ()
setLastReply Reply
r = do
  IORef Reply
ref <- (RedisEnv -> IORef Reply) -> ReaderT RedisEnv IO (IORef Reply)
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks RedisEnv -> IORef Reply
envLastReply
  IO () -> ReaderT RedisEnv IO ()
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (IORef Reply -> Reply -> IO ()
forall a. IORef a -> a -> IO ()
writeIORef IORef Reply
ref Reply
r)

recv :: (MonadRedis m) => m Reply
recv :: m Reply
recv = Redis Reply -> m Reply
forall (m :: * -> *) a. MonadRedis m => Redis a -> m a
liftRedis (Redis Reply -> m Reply) -> Redis Reply -> m Reply
forall a b. (a -> b) -> a -> b
$ ReaderT RedisEnv IO Reply -> Redis Reply
forall a. ReaderT RedisEnv IO a -> Redis a
Redis (ReaderT RedisEnv IO Reply -> Redis Reply)
-> ReaderT RedisEnv IO Reply -> Redis Reply
forall a b. (a -> b) -> a -> b
$ do
  Connection
conn <- (RedisEnv -> Connection) -> ReaderT RedisEnv IO Connection
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks RedisEnv -> Connection
envConn
  Reply
r <- IO Reply -> ReaderT RedisEnv IO Reply
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (Connection -> IO Reply
PP.recv Connection
conn)
  Reply -> ReaderT RedisEnv IO ()
setLastReply Reply
r
  Reply -> ReaderT RedisEnv IO Reply
forall (m :: * -> *) a. Monad m => a -> m a
return Reply
r

send :: (MonadRedis m) => [B.ByteString] -> m ()
send :: [ByteString] -> m ()
send [ByteString]
req = Redis () -> m ()
forall (m :: * -> *) a. MonadRedis m => Redis a -> m a
liftRedis (Redis () -> m ()) -> Redis () -> m ()
forall a b. (a -> b) -> a -> b
$ ReaderT RedisEnv IO () -> Redis ()
forall a. ReaderT RedisEnv IO a -> Redis a
Redis (ReaderT RedisEnv IO () -> Redis ())
-> ReaderT RedisEnv IO () -> Redis ()
forall a b. (a -> b) -> a -> b
$ do
    Connection
conn <- (RedisEnv -> Connection) -> ReaderT RedisEnv IO Connection
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks RedisEnv -> Connection
envConn
    IO () -> ReaderT RedisEnv IO ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> ReaderT RedisEnv IO ())
-> IO () -> ReaderT RedisEnv IO ()
forall a b. (a -> b) -> a -> b
$ Connection -> ByteString -> IO ()
PP.send Connection
conn ([ByteString] -> ByteString
renderRequest [ByteString]
req)

-- |'sendRequest' can be used to implement commands from experimental
--  versions of Redis. An example of how to implement a command is given
--  below.
--
-- @
-- -- |Redis DEBUG OBJECT command
-- debugObject :: ByteString -> 'Redis' (Either 'Reply' ByteString)
-- debugObject key = 'sendRequest' [\"DEBUG\", \"OBJECT\", key]
-- @
--
sendRequest :: (RedisCtx m f, RedisResult a)
    => [B.ByteString] -> m (f a)
sendRequest :: [ByteString] -> m (f a)
sendRequest [ByteString]
req = do
    Reply
r' <- Redis Reply -> m Reply
forall (m :: * -> *) a. MonadRedis m => Redis a -> m a
liftRedis (Redis Reply -> m Reply) -> Redis Reply -> m Reply
forall a b. (a -> b) -> a -> b
$ ReaderT RedisEnv IO Reply -> Redis Reply
forall a. ReaderT RedisEnv IO a -> Redis a
Redis (ReaderT RedisEnv IO Reply -> Redis Reply)
-> ReaderT RedisEnv IO Reply -> Redis Reply
forall a b. (a -> b) -> a -> b
$ do
        RedisEnv
env <- ReaderT RedisEnv IO RedisEnv
forall r (m :: * -> *). MonadReader r m => m r
ask
        case RedisEnv
env of
            NonClusteredEnv{IORef Reply
Connection
envLastReply :: IORef Reply
envConn :: Connection
envConn :: RedisEnv -> Connection
envLastReply :: RedisEnv -> IORef Reply
..} -> do
                Reply
r <- IO Reply -> ReaderT RedisEnv IO Reply
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO Reply -> ReaderT RedisEnv IO Reply)
-> IO Reply -> ReaderT RedisEnv IO Reply
forall a b. (a -> b) -> a -> b
$ Connection -> ByteString -> IO Reply
PP.request Connection
envConn ([ByteString] -> ByteString
renderRequest [ByteString]
req)
                Reply -> ReaderT RedisEnv IO ()
setLastReply Reply
r
                Reply -> ReaderT RedisEnv IO Reply
forall (m :: * -> *) a. Monad m => a -> m a
return Reply
r
            ClusteredEnv{IO ShardMap
Connection
connection :: RedisEnv -> Connection
refreshAction :: RedisEnv -> IO ShardMap
connection :: Connection
refreshAction :: IO ShardMap
..} -> IO Reply -> ReaderT RedisEnv IO Reply
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO Reply -> ReaderT RedisEnv IO Reply)
-> IO Reply -> ReaderT RedisEnv IO Reply
forall a b. (a -> b) -> a -> b
$ IO ShardMap -> Connection -> [ByteString] -> IO Reply
Cluster.requestPipelined IO ShardMap
refreshAction Connection
connection [ByteString]
req
    Reply -> m (f a)
forall (m :: * -> *) (f :: * -> *) a.
(RedisCtx m f, RedisResult a) =>
Reply -> m (f a)
returnDecode Reply
r'