{-# LANGUAGE BangPatterns #-}
{-# LANGUAGE CPP #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE ScopedTypeVariables #-}
module Database.Memcache.Cluster (
Cluster, ServerSpec(..), Options(..), newCluster,
Retries, keyedOp, anyOp, allOp, allOp'
) where
import Database.Memcache.Errors
import Database.Memcache.Server
import Database.Memcache.Types
import Control.Concurrent (threadDelay)
import Control.Exception (handle, throwIO, SomeException)
import Data.Default.Class
import Data.Fixed (Milli)
import Data.Hashable (hash)
import Data.IORef
import Data.Maybe (fromMaybe)
import Data.List (sort)
import Data.Time.Clock (NominalDiffTime)
import Data.Time.Clock.POSIX (getPOSIXTime)
import qualified Data.Vector as V
import Network.Socket (HostName, ServiceName)
import System.Timeout
type Retries = Int
data ServerSpec = ServerSpec {
ServerSpec -> HostName
ssHost :: HostName,
ServerSpec -> HostName
ssPort :: ServiceName,
ServerSpec -> Authentication
ssAuth :: Authentication
} deriving (ServerSpec -> ServerSpec -> Bool
(ServerSpec -> ServerSpec -> Bool)
-> (ServerSpec -> ServerSpec -> Bool) -> Eq ServerSpec
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: ServerSpec -> ServerSpec -> Bool
$c/= :: ServerSpec -> ServerSpec -> Bool
== :: ServerSpec -> ServerSpec -> Bool
$c== :: ServerSpec -> ServerSpec -> Bool
Eq, Int -> ServerSpec -> ShowS
[ServerSpec] -> ShowS
ServerSpec -> HostName
(Int -> ServerSpec -> ShowS)
-> (ServerSpec -> HostName)
-> ([ServerSpec] -> ShowS)
-> Show ServerSpec
forall a.
(Int -> a -> ShowS) -> (a -> HostName) -> ([a] -> ShowS) -> Show a
showList :: [ServerSpec] -> ShowS
$cshowList :: [ServerSpec] -> ShowS
show :: ServerSpec -> HostName
$cshow :: ServerSpec -> HostName
showsPrec :: Int -> ServerSpec -> ShowS
$cshowsPrec :: Int -> ServerSpec -> ShowS
Show)
instance Default ServerSpec where
def :: ServerSpec
def = HostName -> HostName -> Authentication -> ServerSpec
ServerSpec HostName
"127.0.0.1" HostName
"11211" Authentication
NoAuth
data Options = Options {
Options -> Int
optsServerRetries :: Retries,
Options -> Milli
optsFailRetryDelay :: Milli,
Options -> Milli
optsDeadRetryDelay :: Milli,
Options -> Milli
optsServerTimeout :: Milli
} deriving (Options -> Options -> Bool
(Options -> Options -> Bool)
-> (Options -> Options -> Bool) -> Eq Options
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Options -> Options -> Bool
$c/= :: Options -> Options -> Bool
== :: Options -> Options -> Bool
$c== :: Options -> Options -> Bool
Eq, Int -> Options -> ShowS
[Options] -> ShowS
Options -> HostName
(Int -> Options -> ShowS)
-> (Options -> HostName) -> ([Options] -> ShowS) -> Show Options
forall a.
(Int -> a -> ShowS) -> (a -> HostName) -> ([a] -> ShowS) -> Show a
showList :: [Options] -> ShowS
$cshowList :: [Options] -> ShowS
show :: Options -> HostName
$cshow :: Options -> HostName
showsPrec :: Int -> Options -> ShowS
$cshowsPrec :: Int -> Options -> ShowS
Show)
instance Default Options where
def :: Options
def = Options :: Int -> Milli -> Milli -> Milli -> Options
Options {
optsServerRetries :: Int
optsServerRetries = Int
2,
optsFailRetryDelay :: Milli
optsFailRetryDelay = Milli
200,
optsDeadRetryDelay :: Milli
optsDeadRetryDelay = Milli
1500,
optsServerTimeout :: Milli
optsServerTimeout = Milli
750
}
data Cluster = Cluster {
Cluster -> Vector Server
cServers :: V.Vector Server,
Cluster -> Int
cRetries :: {-# UNPACK #-} !Int,
Cluster -> Int
cFailDelay :: {-# UNPACK #-} !Int,
Cluster -> NominalDiffTime
cDeadDelay :: !NominalDiffTime,
Cluster -> Int
cTimeout :: {-# UNPACK #-} !Int
} deriving (Cluster -> Cluster -> Bool
(Cluster -> Cluster -> Bool)
-> (Cluster -> Cluster -> Bool) -> Eq Cluster
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Cluster -> Cluster -> Bool
$c/= :: Cluster -> Cluster -> Bool
== :: Cluster -> Cluster -> Bool
$c== :: Cluster -> Cluster -> Bool
Eq, Int -> Cluster -> ShowS
[Cluster] -> ShowS
Cluster -> HostName
(Int -> Cluster -> ShowS)
-> (Cluster -> HostName) -> ([Cluster] -> ShowS) -> Show Cluster
forall a.
(Int -> a -> ShowS) -> (a -> HostName) -> ([a] -> ShowS) -> Show a
showList :: [Cluster] -> ShowS
$cshowList :: [Cluster] -> ShowS
show :: Cluster -> HostName
$cshow :: Cluster -> HostName
showsPrec :: Int -> Cluster -> ShowS
$cshowsPrec :: Int -> Cluster -> ShowS
Show)
newCluster :: [ServerSpec] -> Options -> IO Cluster
newCluster :: [ServerSpec] -> Options -> IO Cluster
newCluster [] Options
_ = MemcacheError -> IO Cluster
forall e a. Exception e => e -> IO a
throwIO (MemcacheError -> IO Cluster) -> MemcacheError -> IO Cluster
forall a b. (a -> b) -> a -> b
$ ClientError -> MemcacheError
ClientError ClientError
NoServersReady
newCluster [ServerSpec]
hosts Options{Int
Milli
optsServerTimeout :: Milli
optsDeadRetryDelay :: Milli
optsFailRetryDelay :: Milli
optsServerRetries :: Int
optsServerTimeout :: Options -> Milli
optsDeadRetryDelay :: Options -> Milli
optsFailRetryDelay :: Options -> Milli
optsServerRetries :: Options -> Int
..} = do
[Server]
s <- (ServerSpec -> IO Server) -> [ServerSpec] -> IO [Server]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (\ServerSpec{HostName
Authentication
ssAuth :: Authentication
ssPort :: HostName
ssHost :: HostName
ssAuth :: ServerSpec -> Authentication
ssPort :: ServerSpec -> HostName
ssHost :: ServerSpec -> HostName
..} -> HostName -> HostName -> Authentication -> IO Server
newServer HostName
ssHost HostName
ssPort Authentication
ssAuth) [ServerSpec]
hosts
Cluster -> IO Cluster
forall (m :: * -> *) a. Monad m => a -> m a
return (Cluster -> IO Cluster) -> Cluster -> IO Cluster
forall a b. (a -> b) -> a -> b
$
Cluster :: Vector Server -> Int -> Int -> NominalDiffTime -> Int -> Cluster
Cluster {
cServers :: Vector Server
cServers = ([Server] -> Vector Server
forall a. [a] -> Vector a
V.fromList ([Server] -> Vector Server) -> [Server] -> Vector Server
forall a b. (a -> b) -> a -> b
$ [Server] -> [Server]
forall a. Ord a => [a] -> [a]
sort [Server]
s),
cRetries :: Int
cRetries = Int
optsServerRetries ,
cFailDelay :: Int
cFailDelay = Milli -> Int
forall a. Enum a => a -> Int
fromEnum Milli
optsFailRetryDelay,
cDeadDelay :: NominalDiffTime
cDeadDelay = Rational -> NominalDiffTime
forall a. Fractional a => Rational -> a
fromRational (Rational -> NominalDiffTime) -> Rational -> NominalDiffTime
forall a b. (a -> b) -> a -> b
$ Milli -> Rational
forall a. Real a => a -> Rational
toRational Milli
optsDeadRetryDelay Rational -> Rational -> Rational
forall a. Fractional a => a -> a -> a
/ Rational
1000,
cTimeout :: Int
cTimeout = Milli -> Int
forall a. Enum a => a -> Int
fromEnum Milli
optsServerTimeout
}
serverAlive :: NominalDiffTime -> Server -> IO Bool
{-# INLINE serverAlive #-}
serverAlive :: NominalDiffTime -> Server -> IO Bool
serverAlive NominalDiffTime
deadDelay Server
s = do
NominalDiffTime
t <- IORef NominalDiffTime -> IO NominalDiffTime
forall a. IORef a -> IO a
readIORef (Server -> IORef NominalDiffTime
failed Server
s)
if NominalDiffTime
t NominalDiffTime -> NominalDiffTime -> Bool
forall a. Eq a => a -> a -> Bool
== NominalDiffTime
0
then Bool -> IO Bool
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
True
else do
NominalDiffTime
t' <- IO NominalDiffTime
getPOSIXTime
if (NominalDiffTime
t' NominalDiffTime -> NominalDiffTime -> NominalDiffTime
forall a. Num a => a -> a -> a
- NominalDiffTime
t) NominalDiffTime -> NominalDiffTime -> Bool
forall a. Ord a => a -> a -> Bool
< NominalDiffTime
deadDelay
then Bool -> IO Bool
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
False
else do
IORef NominalDiffTime -> NominalDiffTime -> IO ()
forall a. IORef a -> a -> IO ()
writeIORef (Server -> IORef NominalDiffTime
failed Server
s) NominalDiffTime
0
Bool -> IO Bool
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
True
getServerForKey :: Cluster -> Key -> IO (Maybe Server)
{-# INLINE getServerForKey #-}
getServerForKey :: Cluster -> Key -> IO (Maybe Server)
getServerForKey Cluster
c Key
k = do
let hashedKey :: Int
hashedKey = Key -> Int
forall a. Hashable a => a -> Int
hash Key
k
searchF :: Server -> Bool
searchF Server
s = Server -> Int
sid Server
s Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
hashedKey
Vector Server
servers' <- (Server -> IO Bool) -> Vector Server -> IO (Vector Server)
forall (m :: * -> *) a.
Monad m =>
(a -> m Bool) -> Vector a -> m (Vector a)
V.filterM (NominalDiffTime -> Server -> IO Bool
serverAlive (NominalDiffTime -> Server -> IO Bool)
-> NominalDiffTime -> Server -> IO Bool
forall a b. (a -> b) -> a -> b
$ Cluster -> NominalDiffTime
cDeadDelay Cluster
c) (Vector Server -> IO (Vector Server))
-> Vector Server -> IO (Vector Server)
forall a b. (a -> b) -> a -> b
$ Cluster -> Vector Server
cServers Cluster
c
Maybe Server -> IO (Maybe Server)
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe Server -> IO (Maybe Server))
-> Maybe Server -> IO (Maybe Server)
forall a b. (a -> b) -> a -> b
$ if Vector Server -> Bool
forall a. Vector a -> Bool
V.null Vector Server
servers'
then Maybe Server
forall a. Maybe a
Nothing
else Server -> Maybe Server
forall a. a -> Maybe a
Just (Server -> Maybe Server) -> Server -> Maybe Server
forall a b. (a -> b) -> a -> b
$ Server -> Maybe Server -> Server
forall a. a -> Maybe a -> a
fromMaybe (Vector Server -> Server
forall a. Vector a -> a
V.last Vector Server
servers') ((Server -> Bool) -> Vector Server -> Maybe Server
forall a. (a -> Bool) -> Vector a -> Maybe a
V.find Server -> Bool
searchF Vector Server
servers')
serverOp :: Cluster -> Server -> Request -> IO Response
{-# INLINE serverOp #-}
serverOp :: Cluster -> Server -> Request -> IO Response
serverOp Cluster
c Server
s Request
req = Cluster -> Server -> IO Response -> IO Response
forall a. Cluster -> Server -> IO a -> IO a
retryOp Cluster
c Server
s (IO Response -> IO Response) -> IO Response -> IO Response
forall a b. (a -> b) -> a -> b
$ Server -> Request -> IO Response
sendRecv Server
s Request
req
keyedOp :: Cluster -> Key -> Request -> IO Response
{-# INLINE keyedOp #-}
keyedOp :: Cluster -> Key -> Request -> IO Response
keyedOp Cluster
c Key
k Request
req = do
Maybe Server
s' <- Cluster -> Key -> IO (Maybe Server)
getServerForKey Cluster
c Key
k
case Maybe Server
s' of
Just Server
s -> Cluster -> Server -> Request -> IO Response
serverOp Cluster
c Server
s Request
req
Maybe Server
Nothing -> MemcacheError -> IO Response
forall e a. Exception e => e -> IO a
throwIO (MemcacheError -> IO Response) -> MemcacheError -> IO Response
forall a b. (a -> b) -> a -> b
$ ClientError -> MemcacheError
ClientError ClientError
NoServersReady
anyOp :: Cluster -> Request -> IO Response
{-# INLINE anyOp #-}
anyOp :: Cluster -> Request -> IO Response
anyOp Cluster
c Request
req = do
Vector Server
servers' <- (Server -> IO Bool) -> Vector Server -> IO (Vector Server)
forall (m :: * -> *) a.
Monad m =>
(a -> m Bool) -> Vector a -> m (Vector a)
V.filterM (NominalDiffTime -> Server -> IO Bool
serverAlive (NominalDiffTime -> Server -> IO Bool)
-> NominalDiffTime -> Server -> IO Bool
forall a b. (a -> b) -> a -> b
$ Cluster -> NominalDiffTime
cDeadDelay Cluster
c) (Vector Server -> IO (Vector Server))
-> Vector Server -> IO (Vector Server)
forall a b. (a -> b) -> a -> b
$ Cluster -> Vector Server
cServers Cluster
c
if Vector Server -> Bool
forall a. Vector a -> Bool
V.null Vector Server
servers'
then MemcacheError -> IO Response
forall e a. Exception e => e -> IO a
throwIO (MemcacheError -> IO Response) -> MemcacheError -> IO Response
forall a b. (a -> b) -> a -> b
$ ClientError -> MemcacheError
ClientError ClientError
NoServersReady
else Cluster -> Server -> Request -> IO Response
serverOp Cluster
c (Vector Server -> Server
forall a. Vector a -> a
V.head Vector Server
servers') Request
req
allOp :: Cluster -> Request -> IO [(Server, Response)]
{-# INLINE allOp #-}
allOp :: Cluster -> Request -> IO [(Server, Response)]
allOp Cluster
c Request
req = do
Vector Server
servers' <- (Server -> IO Bool) -> Vector Server -> IO (Vector Server)
forall (m :: * -> *) a.
Monad m =>
(a -> m Bool) -> Vector a -> m (Vector a)
V.filterM (NominalDiffTime -> Server -> IO Bool
serverAlive (NominalDiffTime -> Server -> IO Bool)
-> NominalDiffTime -> Server -> IO Bool
forall a b. (a -> b) -> a -> b
$ Cluster -> NominalDiffTime
cDeadDelay Cluster
c) (Vector Server -> IO (Vector Server))
-> Vector Server -> IO (Vector Server)
forall a b. (a -> b) -> a -> b
$ Cluster -> Vector Server
cServers Cluster
c
if Vector Server -> Bool
forall a. Vector a -> Bool
V.null Vector Server
servers'
then MemcacheError -> IO [(Server, Response)]
forall e a. Exception e => e -> IO a
throwIO (MemcacheError -> IO [(Server, Response)])
-> MemcacheError -> IO [(Server, Response)]
forall a b. (a -> b) -> a -> b
$ ClientError -> MemcacheError
ClientError ClientError
NoServersReady
else do
Vector Response
res <- Vector Server -> (Server -> IO Response) -> IO (Vector Response)
forall (m :: * -> *) a b.
Monad m =>
Vector a -> (a -> m b) -> m (Vector b)
V.forM Vector Server
servers' ((Server -> IO Response) -> IO (Vector Response))
-> (Server -> IO Response) -> IO (Vector Response)
forall a b. (a -> b) -> a -> b
$ \Server
s -> Cluster -> Server -> Request -> IO Response
serverOp Cluster
c Server
s Request
req
[(Server, Response)] -> IO [(Server, Response)]
forall (m :: * -> *) a. Monad m => a -> m a
return ([(Server, Response)] -> IO [(Server, Response)])
-> [(Server, Response)] -> IO [(Server, Response)]
forall a b. (a -> b) -> a -> b
$ Vector (Server, Response) -> [(Server, Response)]
forall a. Vector a -> [a]
V.toList (Vector (Server, Response) -> [(Server, Response)])
-> Vector (Server, Response) -> [(Server, Response)]
forall a b. (a -> b) -> a -> b
$ Vector Server -> Vector Response -> Vector (Server, Response)
forall a b. Vector a -> Vector b -> Vector (a, b)
V.zip Vector Server
servers' Vector Response
res
allOp' :: Cluster -> (Server -> IO a) -> IO [(Server, a)]
{-# INLINE allOp' #-}
allOp' :: Cluster -> (Server -> IO a) -> IO [(Server, a)]
allOp' Cluster
c Server -> IO a
op = do
Vector Server
servers' <- (Server -> IO Bool) -> Vector Server -> IO (Vector Server)
forall (m :: * -> *) a.
Monad m =>
(a -> m Bool) -> Vector a -> m (Vector a)
V.filterM (NominalDiffTime -> Server -> IO Bool
serverAlive (NominalDiffTime -> Server -> IO Bool)
-> NominalDiffTime -> Server -> IO Bool
forall a b. (a -> b) -> a -> b
$ Cluster -> NominalDiffTime
cDeadDelay Cluster
c) (Vector Server -> IO (Vector Server))
-> Vector Server -> IO (Vector Server)
forall a b. (a -> b) -> a -> b
$ Cluster -> Vector Server
cServers Cluster
c
if Vector Server -> Bool
forall a. Vector a -> Bool
V.null Vector Server
servers'
then MemcacheError -> IO [(Server, a)]
forall e a. Exception e => e -> IO a
throwIO (MemcacheError -> IO [(Server, a)])
-> MemcacheError -> IO [(Server, a)]
forall a b. (a -> b) -> a -> b
$ ClientError -> MemcacheError
ClientError ClientError
NoServersReady
else do
Vector a
res <- Vector Server -> (Server -> IO a) -> IO (Vector a)
forall (m :: * -> *) a b.
Monad m =>
Vector a -> (a -> m b) -> m (Vector b)
V.forM Vector Server
servers' ((Server -> IO a) -> IO (Vector a))
-> (Server -> IO a) -> IO (Vector a)
forall a b. (a -> b) -> a -> b
$ \Server
s -> Cluster -> Server -> IO a -> IO a
forall a. Cluster -> Server -> IO a -> IO a
retryOp Cluster
c Server
s (Server -> IO a
op Server
s)
[(Server, a)] -> IO [(Server, a)]
forall (m :: * -> *) a. Monad m => a -> m a
return ([(Server, a)] -> IO [(Server, a)])
-> [(Server, a)] -> IO [(Server, a)]
forall a b. (a -> b) -> a -> b
$ Vector (Server, a) -> [(Server, a)]
forall a. Vector a -> [a]
V.toList (Vector (Server, a) -> [(Server, a)])
-> Vector (Server, a) -> [(Server, a)]
forall a b. (a -> b) -> a -> b
$ Vector Server -> Vector a -> Vector (Server, a)
forall a b. Vector a -> Vector b -> Vector (a, b)
V.zip Vector Server
servers' Vector a
res
retryOp :: forall a. Cluster -> Server -> IO a -> IO a
{-# INLINE retryOp #-}
retryOp :: Cluster -> Server -> IO a -> IO a
retryOp Cluster{Int
NominalDiffTime
Vector Server
cTimeout :: Int
cDeadDelay :: NominalDiffTime
cFailDelay :: Int
cRetries :: Int
cServers :: Vector Server
cTimeout :: Cluster -> Int
cDeadDelay :: Cluster -> NominalDiffTime
cFailDelay :: Cluster -> Int
cRetries :: Cluster -> Int
cServers :: Cluster -> Vector Server
..} Server
s IO a
op = Int -> IO a
go Int
cRetries
where
go :: Int -> IO a
{-# INLINE go #-}
go :: Int -> IO a
go !Int
n = (SomeException -> IO a) -> IO a -> IO a
forall e a. Exception e => (e -> IO a) -> IO a -> IO a
handle (Int -> SomeException -> IO a
handleErrs (Int -> SomeException -> IO a) -> Int -> SomeException -> IO a
forall a b. (a -> b) -> a -> b
$ Int
n Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1) (IO a -> IO a) -> IO a -> IO a
forall a b. (a -> b) -> a -> b
$ do
Maybe a
mr <- Int -> IO a -> IO (Maybe a)
forall a. Int -> IO a -> IO (Maybe a)
timeout Int
cTimeout IO a
op
case Maybe a
mr of
Just a
r -> a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return a
r
Maybe a
Nothing -> Server -> IO ()
close Server
s IO () -> IO a -> IO a
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> MemcacheError -> IO a
forall e a. Exception e => e -> IO a
throwIO (ClientError -> MemcacheError
ClientError ClientError
Timeout)
handleErrs :: Int -> SomeException -> IO a
{-# INLINE handleErrs #-}
handleErrs :: Int -> SomeException -> IO a
handleErrs Int
0 SomeException
err = do NominalDiffTime
t <- IO NominalDiffTime
getPOSIXTime
IORef NominalDiffTime -> NominalDiffTime -> IO ()
forall a. IORef a -> a -> IO ()
writeIORef (Server -> IORef NominalDiffTime
failed Server
s) NominalDiffTime
t
SomeException -> IO a
forall e a. Exception e => e -> IO a
throwIO SomeException
err
handleErrs Int
n SomeException
_ = do
Int -> IO ()
threadDelay Int
cFailDelay
Int -> IO a
go Int
n