module Database.Memcache.Client (
newClient, Client, ServerSpec(..), Options(..),
Authentication(..), Username, Password, def,
quit,
get, gat, touch,
set, cas, add, replace,
increment, decrement, append, prepend,
delete, flush,
StatResults, stats, version,
MemcacheError(..), Status(..), ClientError(..), ProtocolError(..)
) where
import Database.Memcache.Cluster
import Database.Memcache.Errors
import Database.Memcache.Server
import Database.Memcache.Socket
import Database.Memcache.Types hiding (cas)
#if __GLASGOW_HASKELL__ < 710
import Control.Applicative
#endif
import Control.Exception (handle, throwIO, SomeException)
import Control.Monad (forM_, void, when)
import Data.Default.Class
import Data.Word
import Data.ByteString (ByteString)
import qualified Data.ByteString as B (null)
type Client = Cluster
newClient :: [ServerSpec] -> Options -> IO Client
newClient = newCluster
quit :: Cluster -> IO ()
quit c = void $ allOp' c serverQuit
where
serverQuit :: Server -> IO ()
serverQuit s = handle consumeError $ do
let msg = emptyReq { reqOp = ReqQuit Quiet }
withSocket s $ \sock -> send sock msg
close s
consumeError :: SomeException -> IO ()
consumeError _ = return ()
get :: Cluster -> Key -> IO (Maybe (Value, Flags, Version))
get c k = do
let msg = emptyReq { reqOp = ReqGet Loud NoKey k }
r <- keyedOp c k msg
(v, f) <- case resOp r of
ResGet Loud v f -> return (v, f)
_ -> throwIO $ wrongOp r "GET"
case resStatus r of
NoError -> return $ Just (v, f, resCas r)
ErrKeyNotFound -> return Nothing
rs -> throwStatus rs
gat :: Cluster -> Key -> Expiration -> IO (Maybe (Value, Flags, Version))
gat c k e = do
let msg = emptyReq { reqOp = ReqGAT Loud NoKey k (SETouch e) }
r <- keyedOp c k msg
(v, f) <- case resOp r of
ResGAT Loud v f -> return (v, f)
_ -> throwIO $ wrongOp r "GAT"
case resStatus r of
NoError -> return $ Just (v, f, resCas r)
ErrKeyNotFound -> return Nothing
rs -> throwStatus rs
touch :: Cluster -> Key -> Expiration -> IO (Maybe Version)
touch c k e = do
let msg = emptyReq { reqOp = ReqTouch k (SETouch e) }
r <- keyedOp c k msg
when (resOp r /= ResTouch) $ throwIO $ wrongOp r "TOUCH"
case resStatus r of
NoError -> return $ Just (resCas r)
ErrKeyNotFound -> return Nothing
rs -> throwStatus rs
set :: Cluster -> Key -> Value -> Flags -> Expiration -> IO Version
set c k v f e = do
let msg = emptyReq { reqOp = ReqSet Loud k v (SESet f e) }
r <- keyedOp c k msg
when (resOp r /= ResSet Loud) $ throwIO $ wrongOp r "SET"
case resStatus r of
NoError -> return $ resCas r
rs -> throwStatus rs
cas :: Cluster -> Key -> Value -> Flags -> Expiration -> Version -> IO (Maybe Version)
cas c k v f e ver = do
let msg = emptyReq { reqOp = ReqSet Loud k v (SESet f e), reqCas = ver }
r <- keyedOp c k msg
when (resOp r /= ResSet Loud) $ throwIO $ wrongOp r "SET"
case resStatus r of
NoError -> return $ Just (resCas r)
ErrKeyNotFound -> return Nothing
ErrKeyExists -> return Nothing
rs -> throwStatus rs
add :: Cluster -> Key -> Value -> Flags -> Expiration -> IO (Maybe Version)
add c k v f e = do
let msg = emptyReq { reqOp = ReqAdd Loud k v (SESet f e) }
r <- keyedOp c k msg
when (resOp r /= ResAdd Loud) $ throwIO $ wrongOp r "ADD"
case resStatus r of
NoError -> return $ Just (resCas r)
ErrKeyExists -> return Nothing
rs -> throwStatus rs
replace :: Cluster -> Key -> Value -> Flags -> Expiration -> Version -> IO (Maybe Version)
replace c k v f e ver = do
let msg = emptyReq { reqOp = ReqReplace Loud k v (SESet f e), reqCas = ver }
r <- keyedOp c k msg
when (resOp r /= ResReplace Loud) $ throwIO $ wrongOp r "REPLACE"
case resStatus r of
NoError -> return $ Just (resCas r)
ErrKeyNotFound -> return Nothing
ErrKeyExists -> return Nothing
rs -> throwStatus rs
increment :: Cluster -> Key -> Initial -> Delta -> Expiration -> Version -> IO (Maybe (Word64, Version))
increment c k i d e ver = do
let msg = emptyReq { reqOp = ReqIncrement Loud k (SEIncr i d e), reqCas = ver }
r <- keyedOp c k msg
n <- case resOp r of
ResIncrement Loud n -> return n
_ -> throwIO $ wrongOp r "INCREMENT"
case resStatus r of
NoError -> return $ Just (n, resCas r)
ErrKeyNotFound -> return Nothing
ErrKeyExists -> return Nothing
rs -> throwStatus rs
decrement :: Cluster -> Key -> Initial -> Delta -> Expiration -> Version -> IO (Maybe (Word64, Version))
decrement c k i d e ver = do
let msg = emptyReq { reqOp = ReqDecrement Loud k (SEIncr i d e), reqCas = ver }
r <- keyedOp c k msg
n <- case resOp r of
ResDecrement Loud n -> return n
_ -> throwIO $ wrongOp r "DECREMENT"
case resStatus r of
NoError -> return $ Just (n, resCas r)
ErrKeyNotFound -> return Nothing
ErrKeyExists -> return Nothing
rs -> throwStatus rs
append :: Cluster -> Key -> Value -> Version -> IO (Maybe Version)
append c k v ver = do
let msg = emptyReq { reqOp = ReqAppend Loud k v, reqCas = ver }
r <- keyedOp c k msg
when (resOp r /= ResAppend Loud) $ throwIO $ wrongOp r "APPEND"
case resStatus r of
NoError -> return $ Just (resCas r)
ErrKeyNotFound -> return Nothing
rs -> throwStatus rs
prepend :: Cluster -> Key -> Value -> Version -> IO (Maybe Version)
prepend c k v ver = do
let msg = emptyReq { reqOp = ReqPrepend Loud k v, reqCas = ver }
r <- keyedOp c k msg
when (resOp r /= ResPrepend Loud) $ throwIO $ wrongOp r "PREPEND"
case resStatus r of
NoError -> return $ Just (resCas r)
ErrKeyNotFound -> return Nothing
rs -> throwStatus rs
delete :: Cluster -> Key -> Version -> IO Bool
delete c k ver = do
let msg = emptyReq { reqOp = ReqDelete Loud k, reqCas = ver }
r <- keyedOp c k msg
when (resOp r /= ResDelete Loud) $ throwIO $ wrongOp r "DELETE"
case resStatus r of
NoError -> return True
ErrKeyNotFound -> return False
ErrKeyExists -> return False
rs -> throwStatus rs
flush :: Cluster -> Maybe Expiration -> IO ()
flush c e = do
let msg = emptyReq { reqOp = ReqFlush Loud (SETouch <$> e) }
results <- allOp c msg
forM_ results $ \(_, r) -> do
when (resOp r /= ResFlush Loud) $ throwIO $ wrongOp r "FLUSH"
case resStatus r of
NoError -> return ()
rs -> throwStatus rs
type StatResults = [(ByteString, ByteString)]
stats :: Cluster -> Maybe Key -> IO [(Server, Maybe StatResults)]
stats c key = allOp' c serverStats
where
msg :: Request
msg = emptyReq { reqOp = ReqStat key }
serverStats :: Server -> IO (Maybe StatResults)
serverStats s = withSocket s $ \sock -> do
send sock msg
recvAllStats sock []
recvAllStats :: Socket -> StatResults -> IO (Maybe StatResults)
recvAllStats s xs = do
r <- recv s
(k, v) <- case resOp r of
ResStat k v -> return (k, v)
_ -> throwIO $ wrongOp r "STATS"
case resStatus r of
NoError | B.null k && B.null v -> return $ Just xs
| otherwise -> recvAllStats s $ (k, v):xs
ErrKeyNotFound -> return Nothing
rs -> throwStatus rs
version :: Cluster -> IO ByteString
version c = do
let msg = emptyReq { reqOp = ReqVersion }
r <- anyOp c msg
v <- case resOp r of
ResVersion v -> return v
_ -> throwIO $ wrongOp r "VERSION"
case resStatus r of
NoError -> return v
rs -> throwStatus rs