{-# 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 :: forall a. RedisResult a => Reply -> Redis (Either Reply a)
returnDecode = Either Reply a -> Redis (Either Reply a)
forall a. a -> Redis 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 :: forall a. 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 :: forall a. 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 :: forall a. 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 :: forall a. Connection -> Redis a -> IO a
runRedisInternal Connection
conn (Redis ReaderT RedisEnv IO a
redis) = do
  -- Dummy reply in case no request is sent.
  ref <- Reply -> IO (IORef Reply)
forall a. a -> IO (IORef a)
newIORef (ByteString -> Reply
SingleLine ByteString
"nobody will ever see this")
  r <- runReaderT redis (NonClusteredEnv conn ref)
  -- Evaluate last reply to keep lazy IO inside runRedis.
  readIORef ref >>= (`seq` return ())
  return r

runRedisClusteredInternal :: Cluster.Connection -> IO ShardMap -> Redis a -> IO a
runRedisClusteredInternal :: forall a. Connection -> IO ShardMap -> Redis a -> IO a
runRedisClusteredInternal Connection
connection IO ShardMap
refreshShardmapAction (Redis ReaderT RedisEnv IO a
redis) = do
    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)
    r `seq` return ()
    return r

setLastReply :: Reply -> ReaderT RedisEnv IO ()
setLastReply :: Reply -> ReaderT RedisEnv IO ()
setLastReply Reply
r = do
  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
  lift (writeIORef ref r)

recv :: (MonadRedis m) => m Reply
recv :: forall (m :: * -> *). MonadRedis m => m Reply
recv = Redis Reply -> m Reply
forall a. Redis a -> m a
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
  conn <- (RedisEnv -> Connection) -> ReaderT RedisEnv IO Connection
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks RedisEnv -> Connection
envConn
  r <- liftIO (PP.recv conn)
  setLastReply r
  return r

send :: (MonadRedis m) => [B.ByteString] -> m ()
send :: forall (m :: * -> *). MonadRedis m => [ByteString] -> m ()
send [ByteString]
req = Redis () -> m ()
forall a. Redis a -> m a
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
    conn <- (RedisEnv -> Connection) -> ReaderT RedisEnv IO Connection
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks RedisEnv -> Connection
envConn
    liftIO $ PP.send conn (renderRequest 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 :: forall (m :: * -> *) (f :: * -> *) a.
(RedisCtx m f, RedisResult a) =>
[ByteString] -> m (f a)
sendRequest [ByteString]
req = do
    r' <- Redis Reply -> m Reply
forall a. Redis a -> m a
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
        env <- ReaderT RedisEnv IO RedisEnv
forall r (m :: * -> *). MonadReader r m => m r
ask
        case env of
            NonClusteredEnv{IORef Reply
Connection
envLastReply :: RedisEnv -> IORef Reply
envConn :: RedisEnv -> Connection
envConn :: Connection
envLastReply :: IORef Reply
..} -> do
                r <- IO Reply -> ReaderT RedisEnv IO Reply
forall a. IO a -> ReaderT RedisEnv IO a
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)
                setLastReply r
                return r
            ClusteredEnv{IO ShardMap
Connection
refreshAction :: IO ShardMap
connection :: Connection
connection :: RedisEnv -> Connection
refreshAction :: RedisEnv -> IO ShardMap
..} -> IO Reply -> ReaderT RedisEnv IO Reply
forall a. IO a -> ReaderT RedisEnv IO a
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
    returnDecode r'