{-# 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
$c== :: ServerSpec -> ServerSpec -> Bool
== :: ServerSpec -> ServerSpec -> Bool
$c/= :: ServerSpec -> ServerSpec -> Bool
/= :: 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
$cshowsPrec :: Int -> ServerSpec -> ShowS
showsPrec :: Int -> ServerSpec -> ShowS
$cshow :: ServerSpec -> HostName
show :: ServerSpec -> HostName
$cshowList :: [ServerSpec] -> ShowS
showList :: [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,
Options -> Cluster -> Key -> IO (Maybe Server)
optsGetServerForKey :: Cluster -> Key -> IO (Maybe Server)
}
instance Default Options where
def :: Options
def = Options {
optsServerRetries :: Int
optsServerRetries = Int
2,
optsFailRetryDelay :: Milli
optsFailRetryDelay = Milli
200,
optsDeadRetryDelay :: Milli
optsDeadRetryDelay = Milli
1500,
optsServerTimeout :: Milli
optsServerTimeout = Milli
750,
optsGetServerForKey :: Cluster -> Key -> IO (Maybe Server)
optsGetServerForKey = Cluster -> Key -> IO (Maybe Server)
getServerForKeyDefault
}
data Cluster = Cluster {
Cluster -> Vector Server
cServers :: V.Vector Server,
Cluster -> Int
cRetries :: {-# UNPACK #-} !Int,
Cluster -> Int
cFailDelay :: {-# UNPACK #-} !Int,
Cluster -> POSIXTime
cDeadDelay :: !NominalDiffTime,
Cluster -> Int
cTimeout :: {-# UNPACK #-} !Int,
Cluster -> Cluster -> Key -> IO (Maybe Server)
cGetServerForKey :: Cluster -> Key -> IO (Maybe Server)
}
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
Cluster -> Key -> IO (Maybe Server)
optsServerRetries :: Options -> Int
optsFailRetryDelay :: Options -> Milli
optsDeadRetryDelay :: Options -> Milli
optsServerTimeout :: Options -> Milli
optsGetServerForKey :: Options -> Cluster -> Key -> IO (Maybe Server)
optsServerRetries :: Int
optsFailRetryDelay :: Milli
optsDeadRetryDelay :: Milli
optsServerTimeout :: Milli
optsGetServerForKey :: Cluster -> Key -> IO (Maybe Server)
..} = 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)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM (\ServerSpec{HostName
Authentication
ssHost :: ServerSpec -> HostName
ssPort :: ServerSpec -> HostName
ssAuth :: ServerSpec -> Authentication
ssHost :: HostName
ssPort :: HostName
ssAuth :: Authentication
..} -> HostName -> HostName -> Authentication -> IO Server
newServer HostName
ssHost HostName
ssPort Authentication
ssAuth) [ServerSpec]
hosts
Cluster -> IO Cluster
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (Cluster -> IO Cluster) -> Cluster -> IO Cluster
forall a b. (a -> b) -> a -> b
$
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 :: POSIXTime
cDeadDelay = Rational -> POSIXTime
forall a. Fractional a => Rational -> a
fromRational (Rational -> POSIXTime) -> Rational -> POSIXTime
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,
cGetServerForKey :: Cluster -> Key -> IO (Maybe Server)
cGetServerForKey = Cluster -> Key -> IO (Maybe Server)
optsGetServerForKey
}
serverAlive :: NominalDiffTime -> Server -> IO Bool
{-# INLINE serverAlive #-}
serverAlive :: POSIXTime -> Server -> IO Bool
serverAlive POSIXTime
deadDelay Server
s = do
POSIXTime
t <- IORef POSIXTime -> IO POSIXTime
forall a. IORef a -> IO a
readIORef (Server -> IORef POSIXTime
failed Server
s)
if POSIXTime
t POSIXTime -> POSIXTime -> Bool
forall a. Eq a => a -> a -> Bool
== POSIXTime
0
then Bool -> IO Bool
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
True
else do
POSIXTime
t' <- IO POSIXTime
getPOSIXTime
if (POSIXTime
t' POSIXTime -> POSIXTime -> POSIXTime
forall a. Num a => a -> a -> a
- POSIXTime
t) POSIXTime -> POSIXTime -> Bool
forall a. Ord a => a -> a -> Bool
< POSIXTime
deadDelay
then Bool -> IO Bool
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
False
else do
IORef POSIXTime -> POSIXTime -> IO ()
forall a. IORef a -> a -> IO ()
writeIORef (Server -> IORef POSIXTime
failed Server
s) POSIXTime
0
Bool -> IO Bool
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
True
getServerForKeyDefault :: Cluster -> Key -> IO (Maybe Server)
{-# INLINE getServerForKeyDefault #-}
getServerForKeyDefault :: Cluster -> Key -> IO (Maybe Server)
getServerForKeyDefault 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 (POSIXTime -> Server -> IO Bool
serverAlive (POSIXTime -> Server -> IO Bool) -> POSIXTime -> Server -> IO Bool
forall a b. (a -> b) -> a -> b
$ Cluster -> POSIXTime
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 a. a -> IO a
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 -> Cluster -> Key -> IO (Maybe Server)
cGetServerForKey Cluster
c 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 (POSIXTime -> Server -> IO Bool
serverAlive (POSIXTime -> Server -> IO Bool) -> POSIXTime -> Server -> IO Bool
forall a b. (a -> b) -> a -> b
$ Cluster -> POSIXTime
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 (POSIXTime -> Server -> IO Bool
serverAlive (POSIXTime -> Server -> IO Bool) -> POSIXTime -> Server -> IO Bool
forall a b. (a -> b) -> a -> b
$ Cluster -> POSIXTime
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 a. a -> IO a
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' :: forall a. 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 (POSIXTime -> Server -> IO Bool
serverAlive (POSIXTime -> Server -> IO Bool) -> POSIXTime -> Server -> IO Bool
forall a b. (a -> b) -> a -> b
$ Cluster -> POSIXTime
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 a. a -> IO 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 :: forall a. Cluster -> Server -> IO a -> IO a
retryOp Cluster{Int
POSIXTime
Vector Server
Cluster -> Key -> IO (Maybe Server)
cServers :: Cluster -> Vector Server
cRetries :: Cluster -> Int
cFailDelay :: Cluster -> Int
cDeadDelay :: Cluster -> POSIXTime
cTimeout :: Cluster -> Int
cGetServerForKey :: Cluster -> Cluster -> Key -> IO (Maybe Server)
cServers :: Vector Server
cRetries :: Int
cFailDelay :: Int
cDeadDelay :: POSIXTime
cTimeout :: Int
cGetServerForKey :: Cluster -> Key -> IO (Maybe 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 a. 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 a b. IO a -> IO b -> IO b
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 POSIXTime
t <- IO POSIXTime
getPOSIXTime
IORef POSIXTime -> POSIXTime -> IO ()
forall a. IORef a -> a -> IO ()
writeIORef (Server -> IORef POSIXTime
failed Server
s) POSIXTime
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