{-# LANGUAGE OverloadedStrings, GeneralizedNewtypeDeriving, RecordWildCards,
MultiParamTypeClasses, FunctionalDependencies, FlexibleInstances, CPP,
DeriveDataTypeable, StandaloneDeriving #-}
module Database.Redis.Core (
Connection(..), ConnectError(..), connect, checkedConnect, disconnect,
withConnect, withCheckedConnect,
ConnectInfo(..), defaultConnectInfo,
Redis(), runRedis, unRedis, reRedis,
RedisCtx(..), MonadRedis(..),
send, recv, sendRequest,
auth, select, ping
) where
import Prelude
#if __GLASGOW_HASKELL__ < 710
import Control.Applicative
#endif
import Control.Exception
import Control.Monad.Reader
import qualified Control.Monad.Catch as Catch
import qualified Data.ByteString as B
import Data.IORef
import Data.Pool
import Data.Time
import Data.Typeable
import qualified Network.Socket as NS
import Network.TLS (ClientParams)
import Database.Redis.Core.Internal
import Database.Redis.Protocol
import qualified Database.Redis.ProtocolPipelining as PP
import Database.Redis.Types
class (MonadRedis m) => RedisCtx m f | m -> f where
returnDecode :: RedisResult a => Reply -> m (f 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
class (Monad m) => MonadRedis m where
liftRedis :: Redis a -> m a
instance MonadRedis Redis where
liftRedis :: Redis a -> Redis a
liftRedis = Redis a -> Redis a
forall a. a -> a
id
runRedis :: Connection -> Redis a -> IO a
runRedis :: Connection -> Redis a -> IO a
runRedis (Conn Pool Connection
pool) Redis a
redis =
Pool Connection -> (Connection -> IO a) -> IO a
forall (m :: * -> *) a b.
MonadBaseControl IO m =>
Pool a -> (a -> m b) -> m b
withResource Pool Connection
pool ((Connection -> IO a) -> IO a) -> (Connection -> IO a) -> IO a
forall a b. (a -> b) -> a -> b
$ \Connection
conn -> Connection -> Redis a -> IO a
forall a. Connection -> Redis a -> IO a
runRedisInternal Connection
conn Redis a
redis
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
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
runRedisInternal :: PP.Connection -> Redis a -> IO a
runRedisInternal :: Connection -> Redis a -> IO a
runRedisInternal Connection
conn (Redis ReaderT RedisEnv IO a
redis) = do
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
Env Connection
conn IORef Reply
ref)
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
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 :: (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
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 (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
conn ([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
Reply -> m (f a)
forall (m :: * -> *) (f :: * -> *) a.
(RedisCtx m f, RedisResult a) =>
Reply -> m (f a)
returnDecode Reply
r'
newtype Connection = Conn (Pool PP.Connection)
data ConnectInfo = ConnInfo
{ ConnectInfo -> HostName
connectHost :: NS.HostName
, ConnectInfo -> PortID
connectPort :: PP.PortID
, ConnectInfo -> Maybe ByteString
connectAuth :: Maybe B.ByteString
, ConnectInfo -> Integer
connectDatabase :: Integer
, ConnectInfo -> Int
connectMaxConnections :: Int
, ConnectInfo -> NominalDiffTime
connectMaxIdleTime :: NominalDiffTime
, ConnectInfo -> Maybe NominalDiffTime
connectTimeout :: Maybe NominalDiffTime
, ConnectInfo -> Maybe ClientParams
connectTLSParams :: Maybe ClientParams
} deriving Int -> ConnectInfo -> ShowS
[ConnectInfo] -> ShowS
ConnectInfo -> HostName
(Int -> ConnectInfo -> ShowS)
-> (ConnectInfo -> HostName)
-> ([ConnectInfo] -> ShowS)
-> Show ConnectInfo
forall a.
(Int -> a -> ShowS) -> (a -> HostName) -> ([a] -> ShowS) -> Show a
showList :: [ConnectInfo] -> ShowS
$cshowList :: [ConnectInfo] -> ShowS
show :: ConnectInfo -> HostName
$cshow :: ConnectInfo -> HostName
showsPrec :: Int -> ConnectInfo -> ShowS
$cshowsPrec :: Int -> ConnectInfo -> ShowS
Show
data ConnectError = ConnectAuthError Reply
| ConnectSelectError Reply
deriving (ConnectError -> ConnectError -> Bool
(ConnectError -> ConnectError -> Bool)
-> (ConnectError -> ConnectError -> Bool) -> Eq ConnectError
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: ConnectError -> ConnectError -> Bool
$c/= :: ConnectError -> ConnectError -> Bool
== :: ConnectError -> ConnectError -> Bool
$c== :: ConnectError -> ConnectError -> Bool
Eq, Int -> ConnectError -> ShowS
[ConnectError] -> ShowS
ConnectError -> HostName
(Int -> ConnectError -> ShowS)
-> (ConnectError -> HostName)
-> ([ConnectError] -> ShowS)
-> Show ConnectError
forall a.
(Int -> a -> ShowS) -> (a -> HostName) -> ([a] -> ShowS) -> Show a
showList :: [ConnectError] -> ShowS
$cshowList :: [ConnectError] -> ShowS
show :: ConnectError -> HostName
$cshow :: ConnectError -> HostName
showsPrec :: Int -> ConnectError -> ShowS
$cshowsPrec :: Int -> ConnectError -> ShowS
Show, Typeable)
instance Exception ConnectError
defaultConnectInfo :: ConnectInfo
defaultConnectInfo :: ConnectInfo
defaultConnectInfo = ConnInfo :: HostName
-> PortID
-> Maybe ByteString
-> Integer
-> Int
-> NominalDiffTime
-> Maybe NominalDiffTime
-> Maybe ClientParams
-> ConnectInfo
ConnInfo
{ connectHost :: HostName
connectHost = HostName
"localhost"
, connectPort :: PortID
connectPort = PortNumber -> PortID
PP.PortNumber PortNumber
6379
, connectAuth :: Maybe ByteString
connectAuth = Maybe ByteString
forall a. Maybe a
Nothing
, connectDatabase :: Integer
connectDatabase = Integer
0
, connectMaxConnections :: Int
connectMaxConnections = Int
50
, connectMaxIdleTime :: NominalDiffTime
connectMaxIdleTime = NominalDiffTime
30
, connectTimeout :: Maybe NominalDiffTime
connectTimeout = Maybe NominalDiffTime
forall a. Maybe a
Nothing
, connectTLSParams :: Maybe ClientParams
connectTLSParams = Maybe ClientParams
forall a. Maybe a
Nothing
}
connect :: ConnectInfo -> IO Connection
connect :: ConnectInfo -> IO Connection
connect ConnInfo{Int
Integer
HostName
Maybe ByteString
Maybe NominalDiffTime
Maybe ClientParams
NominalDiffTime
PortID
connectTLSParams :: Maybe ClientParams
connectTimeout :: Maybe NominalDiffTime
connectMaxIdleTime :: NominalDiffTime
connectMaxConnections :: Int
connectDatabase :: Integer
connectAuth :: Maybe ByteString
connectPort :: PortID
connectHost :: HostName
connectTLSParams :: ConnectInfo -> Maybe ClientParams
connectTimeout :: ConnectInfo -> Maybe NominalDiffTime
connectMaxIdleTime :: ConnectInfo -> NominalDiffTime
connectMaxConnections :: ConnectInfo -> Int
connectDatabase :: ConnectInfo -> Integer
connectAuth :: ConnectInfo -> Maybe ByteString
connectPort :: ConnectInfo -> PortID
connectHost :: ConnectInfo -> HostName
..} = Pool Connection -> Connection
Conn (Pool Connection -> Connection)
-> IO (Pool Connection) -> IO Connection
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$>
IO Connection
-> (Connection -> IO ())
-> Int
-> NominalDiffTime
-> Int
-> IO (Pool Connection)
forall a.
IO a
-> (a -> IO ()) -> Int -> NominalDiffTime -> Int -> IO (Pool a)
createPool IO Connection
create Connection -> IO ()
destroy Int
1 NominalDiffTime
connectMaxIdleTime Int
connectMaxConnections
where
create :: IO Connection
create = do
let timeoutOptUs :: Maybe Int
timeoutOptUs =
NominalDiffTime -> Int
forall a b. (RealFrac a, Integral b) => a -> b
round (NominalDiffTime -> Int)
-> (NominalDiffTime -> NominalDiffTime) -> NominalDiffTime -> Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (NominalDiffTime
1000000 NominalDiffTime -> NominalDiffTime -> NominalDiffTime
forall a. Num a => a -> a -> a
*) (NominalDiffTime -> Int) -> Maybe NominalDiffTime -> Maybe Int
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe NominalDiffTime
connectTimeout
Connection
conn <- HostName -> PortID -> Maybe Int -> IO Connection
PP.connect HostName
connectHost PortID
connectPort Maybe Int
timeoutOptUs
Connection
conn' <- case Maybe ClientParams
connectTLSParams of
Maybe ClientParams
Nothing -> Connection -> IO Connection
forall (m :: * -> *) a. Monad m => a -> m a
return Connection
conn
Just ClientParams
tlsParams -> ClientParams -> Connection -> IO Connection
PP.enableTLS ClientParams
tlsParams Connection
conn
Connection -> IO ()
PP.beginReceiving Connection
conn'
Connection -> Redis () -> IO ()
forall a. Connection -> Redis a -> IO a
runRedisInternal Connection
conn' (Redis () -> IO ()) -> Redis () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
case Maybe ByteString
connectAuth of
Maybe ByteString
Nothing -> () -> Redis ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
Just ByteString
pass -> do
Either Reply Status
resp <- ByteString -> Redis (Either Reply Status)
auth ByteString
pass
case Either Reply Status
resp of
Left Reply
r -> IO () -> Redis ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> Redis ()) -> IO () -> Redis ()
forall a b. (a -> b) -> a -> b
$ ConnectError -> IO ()
forall e a. Exception e => e -> IO a
throwIO (ConnectError -> IO ()) -> ConnectError -> IO ()
forall a b. (a -> b) -> a -> b
$ Reply -> ConnectError
ConnectAuthError Reply
r
Either Reply Status
_ -> () -> Redis ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
Bool -> Redis () -> Redis ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Integer
connectDatabase Integer -> Integer -> Bool
forall a. Eq a => a -> a -> Bool
/= Integer
0) (Redis () -> Redis ()) -> Redis () -> Redis ()
forall a b. (a -> b) -> a -> b
$ do
Either Reply Status
resp <- Integer -> Redis (Either Reply Status)
forall (m :: * -> *) (f :: * -> *).
RedisCtx m f =>
Integer -> m (f Status)
select Integer
connectDatabase
case Either Reply Status
resp of
Left Reply
r -> IO () -> Redis ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> Redis ()) -> IO () -> Redis ()
forall a b. (a -> b) -> a -> b
$ ConnectError -> IO ()
forall e a. Exception e => e -> IO a
throwIO (ConnectError -> IO ()) -> ConnectError -> IO ()
forall a b. (a -> b) -> a -> b
$ Reply -> ConnectError
ConnectSelectError Reply
r
Either Reply Status
_ -> () -> Redis ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
Connection -> IO Connection
forall (m :: * -> *) a. Monad m => a -> m a
return Connection
conn'
destroy :: Connection -> IO ()
destroy = Connection -> IO ()
PP.disconnect
checkedConnect :: ConnectInfo -> IO Connection
checkedConnect :: ConnectInfo -> IO Connection
checkedConnect ConnectInfo
connInfo = do
Connection
conn <- ConnectInfo -> IO Connection
connect ConnectInfo
connInfo
Connection -> Redis () -> IO ()
forall a. Connection -> Redis a -> IO a
runRedis Connection
conn (Redis () -> IO ()) -> Redis () -> IO ()
forall a b. (a -> b) -> a -> b
$ Redis (Either Reply Status) -> Redis ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void Redis (Either Reply Status)
forall (m :: * -> *) (f :: * -> *). RedisCtx m f => m (f Status)
ping
Connection -> IO Connection
forall (m :: * -> *) a. Monad m => a -> m a
return Connection
conn
disconnect :: Connection -> IO ()
disconnect :: Connection -> IO ()
disconnect (Conn Pool Connection
pool) = Pool Connection -> IO ()
forall a. Pool a -> IO ()
destroyAllResources Pool Connection
pool
withConnect :: (Catch.MonadMask m, MonadIO m) => ConnectInfo -> (Connection -> m c) -> m c
withConnect :: ConnectInfo -> (Connection -> m c) -> m c
withConnect ConnectInfo
connInfo = m Connection -> (Connection -> m ()) -> (Connection -> m c) -> m c
forall (m :: * -> *) a c b.
MonadMask m =>
m a -> (a -> m c) -> (a -> m b) -> m b
Catch.bracket (IO Connection -> m Connection
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO Connection -> m Connection) -> IO Connection -> m Connection
forall a b. (a -> b) -> a -> b
$ ConnectInfo -> IO Connection
connect ConnectInfo
connInfo) (IO () -> m ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> m ()) -> (Connection -> IO ()) -> Connection -> m ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Connection -> IO ()
disconnect)
withCheckedConnect :: (Catch.MonadMask m, MonadIO m) => ConnectInfo -> (Connection -> m c) -> m c
withCheckedConnect :: ConnectInfo -> (Connection -> m c) -> m c
withCheckedConnect ConnectInfo
connInfo = m Connection -> (Connection -> m ()) -> (Connection -> m c) -> m c
forall (m :: * -> *) a c b.
MonadMask m =>
m a -> (a -> m c) -> (a -> m b) -> m b
Catch.bracket (IO Connection -> m Connection
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO Connection -> m Connection) -> IO Connection -> m Connection
forall a b. (a -> b) -> a -> b
$ ConnectInfo -> IO Connection
checkedConnect ConnectInfo
connInfo) (IO () -> m ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> m ()) -> (Connection -> IO ()) -> Connection -> m ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Connection -> IO ()
disconnect)
auth
:: B.ByteString
-> Redis (Either Reply Status)
auth :: ByteString -> Redis (Either Reply Status)
auth ByteString
password = [ByteString] -> Redis (Either Reply Status)
forall (m :: * -> *) (f :: * -> *) a.
(RedisCtx m f, RedisResult a) =>
[ByteString] -> m (f a)
sendRequest [ByteString
"AUTH", ByteString
password]
select
:: RedisCtx m f
=> Integer
-> m (f Status)
select :: Integer -> m (f Status)
select Integer
ix = [ByteString] -> m (f Status)
forall (m :: * -> *) (f :: * -> *) a.
(RedisCtx m f, RedisResult a) =>
[ByteString] -> m (f a)
sendRequest [ByteString
"SELECT", Integer -> ByteString
forall a. RedisArg a => a -> ByteString
encode Integer
ix]
ping
:: (RedisCtx m f)
=> m (f Status)
ping :: m (f Status)
ping = [ByteString] -> m (f Status)
forall (m :: * -> *) (f :: * -> *) a.
(RedisCtx m f, RedisResult a) =>
[ByteString] -> m (f a)
sendRequest ([ByteString
"PING"] )