module Database.Memcache.Cluster (
Cluster, newCluster,
ServerSpec(..), defaultServerSpec,
Options(..), defaultOptions,
keyedOp, anyOp, allOp
) where
import Database.Memcache.Errors
import Database.Memcache.Server (Server(..), newServer)
import Database.Memcache.Types (Authentication(..), Key)
import qualified Control.Exception as E
import Data.Hashable (hash)
import Data.Maybe (fromMaybe)
import Data.List (sort)
import qualified Data.Vector as V
import Network.Socket (HostName, PortNumber)
data ServerSpec = ServerSpec {
ssHost :: HostName,
ssPort :: PortNumber,
ssAuth :: Authentication
}
defaultServerSpec :: ServerSpec
defaultServerSpec = ServerSpec {
ssHost = "localhost",
ssPort = 11211,
ssAuth = NoAuth
}
data Options = Options {
optsCmdFailure :: !FailureMode,
optsServerFailure :: !FailureMode,
optsServerRetries :: !Int
}
defaultOptions :: Options
defaultOptions = Options {
optsCmdFailure = FailToError,
optsServerFailure = FailToError,
optsServerRetries = 2
}
data Cluster = Cluster {
servers :: V.Vector Server,
cmdFailureMode :: !FailureMode,
_serverFailureMode :: !FailureMode,
serverRetries :: !Int
} deriving Show
newCluster :: [ServerSpec] -> Options -> IO Cluster
newCluster hosts Options{..} = do
s <- mapM (\ServerSpec{..} -> newServer ssHost ssPort ssAuth) hosts
return $ Cluster (V.fromList $ sort s) optsCmdFailure optsServerFailure
optsServerRetries
getServerForKey :: Cluster -> Key -> Server
getServerForKey c k =
let hashedKey = hash k
searchFun svr = sid svr < hashedKey
in fromMaybe (V.last $ servers c) $ V.find searchFun (servers c)
keyedOp :: forall a. Maybe a -> Cluster -> Key -> (Server -> IO a) -> IO a
keyedOp def c k = serverOp def c (getServerForKey c k)
anyOp :: forall a. Maybe a -> Cluster -> (Server -> IO a) -> IO a
anyOp def c = serverOp def c (V.head . servers $ c)
allOp :: forall a. Maybe a -> Cluster -> (Server -> IO a) -> IO [(Server, a)]
allOp def c m = do
res <- V.forM (servers c) (\s -> serverOp def c s m)
return $ V.toList $ V.zip (servers c) res
data FailureMode = FailSilent | FailToBackup | FailToError
deriving (Eq, Show)
serverOp :: forall a. Maybe a -> Cluster -> Server -> (Server -> IO a) -> IO a
serverOp def c s m = go $ serverRetries c
where
go attempt =
m s `E.catches`
[ E.Handler $ handleMemErrors (attempt 1)
, E.Handler $ handleAllErrors (attempt 1)
]
cmdError err | cmdFailureMode c == FailSilent
= maybe (E.throwIO err) return def
| cmdFailureMode c == FailToBackup
= undefined
| otherwise
= E.throwIO err
handleMemErrors :: Int -> MemcacheError -> IO a
handleMemErrors 0 err = cmdError err
handleMemErrors atmp MemErrStoreFailed = go atmp
handleMemErrors atmp MemErrUnknownCmd = go atmp
handleMemErrors _ err = E.throwIO err
handleAllErrors :: Int -> E.SomeException -> IO a
handleAllErrors 0 err = cmdError err
handleAllErrors atmp _ = go atmp