{-# LANGUAGE CPP #-}

{-|
Module      : Database.Memcache.Client
Description : Memcached Client
Copyright   : (c) David Terei, 2016
License     : BSD
Maintainer  : code@davidterei.com
Stability   : stable
Portability : GHC

A Memcached client. Memcached is an in-memory key-value store typically used as
a distributed and shared cache. Clients connect to a group of Memcached servers
and perform out-of-band caching for things like SQL results, rendered pages, or
third-party APIs.

A client can connect to a single Memcached server or a cluster of them. In the
later case, consistent hashing is used to route requests to the appropriate
server. The /binary/ Memcached protocol is used and /SASL authentication/ is
supported.

Expected return values (like misses) are returned as part of the return type,
while unexpected errors are thrown as exceptions. Exceptions are either of type
'MemcacheError' or an 'IO' exception thrown by the network.

We support the following logic for handling failure in operations:

* __Timeouts__: we timeout any operation that takes too long and consider it
                failed.
* __Retry__: on operation failure (timeout, network error) we close the
             connection and retry the operation, doing this up to a
             configurable maximum.

* __Failover__: when an operation against a server in a cluster fails all
                retries, we mark that server as dead and use the remaining
                servers in the cluster to handle all operations. After a
                configurable period of time has passed, we consider the server
                alive again and try to use it. This can lead to consistency
                issues (stale data), but is usually fine for caching purposes
                and is the common approach in Memcached clients.

Some of this behavior can be configured through the 'Options' data type. We
also have the following concepts exposed by Memcached:

  [@version@] Each value has a 'Version' associated with it. This is simply a
              numeric, monotonically increasing value. The version field
              allows for a primitive version of 'cas' to be implemented.

  [@expiration@] Each value pair has an 'Expiration' associated with it. Once a
                 a value expires, it will no longer be returned from the cache
                 until a new value for that key is set. Expirations come in two
                 forms, the first form interprets the expiration value as the
                 number of seconds in the future at which the value should be
                 considered expired. For example, an expiration of @3600@
                 expires the value in 1 hour. When the value of the expiration
                 is greater than 30 days however (@2592000@), the expiration
                 field is instead interpreted as a UNIX timestamp (the number
                 of seconds since epoch). The timestamp specifies the date at
                 which the value should expire.

  [@flags@] Each value can have a small amount of fixed metadata associated
            with it beyond the value itself, these are the 'Flags'.

Usage is roughly as follows:

> module Main where
>
> import qualified Database.Memcache.Client as M
>
> main = do
>     -- use default values: connects to localhost:11211
>     mc <- M.newClient [M.def] M.def
>
>     -- store and then retrieve a key-value pair
>     M.set mc "key" "value" 0 0
>     v' <- M.get mc "key"
>     case v' of
>         Nothing        -> putStrLn "Miss!"
>         Just (v, _, _) -> putStrLn $ "Hit: " + show v
-}
module Database.Memcache.Client (
        -- * Client creation
        newClient, Client, ServerSpec(..), Options(..),
        Authentication(..), Username, Password, def,
        quit,

        -- * Operations

        -- ** Get operations
        get, gat, touch,

        -- ** Set operations
        set, cas, add, replace,

        -- ** Modify operations
        increment, decrement, append, prepend,

        -- ** Delete operations
        delete, flush,

        -- ** Information operations
        StatResults, stats, version,

        -- * Errors
        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)

-- | A Memcached client, connected to a collection of Memcached servers.
type Client = Cluster

-- | Establish a new connection to a group of Memcached servers.
newClient :: [ServerSpec] -> Options -> IO Client
newClient :: [ServerSpec] -> Options -> IO Client
newClient [ServerSpec]
scs = do
  case [ServerSpec]
scs of
    [] -> [ServerSpec] -> Options -> IO Client
newCluster [ServerSpec
forall a. Default a => a
def]
    [ServerSpec]
_  -> [ServerSpec] -> Options -> IO Client
newCluster [ServerSpec]
scs

-- | Gracefully close a connection to a Memcached cluster.
quit :: Cluster -> IO ()
quit :: Client -> IO ()
quit Client
c = IO [(Server, ())] -> IO ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (IO [(Server, ())] -> IO ()) -> IO [(Server, ())] -> IO ()
forall a b. (a -> b) -> a -> b
$ Client -> (Server -> IO ()) -> IO [(Server, ())]
forall a. Client -> (Server -> IO a) -> IO [(Server, a)]
allOp' Client
c Server -> IO ()
serverQuit
  where
    serverQuit :: Server -> IO ()
    serverQuit :: Server -> IO ()
serverQuit Server
s = (SomeException -> IO ()) -> IO () -> IO ()
forall e a. Exception e => (e -> IO a) -> IO a -> IO a
handle SomeException -> IO ()
consumeError (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
        let msg :: Request
msg = Request
emptyReq { reqOp :: OpRequest
reqOp = Q -> OpRequest
ReqQuit Q
Quiet }
        Server -> (Socket -> IO ()) -> IO ()
forall a. Server -> (Socket -> IO a) -> IO a
withSocket Server
s ((Socket -> IO ()) -> IO ()) -> (Socket -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \Socket
sock -> Socket -> Request -> IO ()
send Socket
sock Request
msg
        Server -> IO ()
close Server
s

    consumeError :: SomeException -> IO ()
    consumeError :: SomeException -> IO ()
consumeError SomeException
_ = () -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()

-- | Retrieve the value for the given key from Memcached.
get :: Cluster -> Key -> IO (Maybe (Value, Flags, Version))
get :: Client -> Key -> IO (Maybe (Key, Flags, Version))
get Client
c Key
k = do
    let msg :: Request
msg = Request
emptyReq { reqOp :: OpRequest
reqOp = Q -> K -> Key -> OpRequest
ReqGet Q
Loud K
NoKey Key
k }
    Response
r <- Client -> Key -> Request -> IO Response
keyedOp Client
c Key
k Request
msg
    (Key
v, Flags
f) <- case Response -> OpResponse
resOp Response
r of
        ResGet Q
Loud Key
v Flags
f -> (Key, Flags) -> IO (Key, Flags)
forall (m :: * -> *) a. Monad m => a -> m a
return (Key
v, Flags
f)
        OpResponse
_               -> MemcacheError -> IO (Key, Flags)
forall e a. Exception e => e -> IO a
throwIO (MemcacheError -> IO (Key, Flags))
-> MemcacheError -> IO (Key, Flags)
forall a b. (a -> b) -> a -> b
$ Response -> String -> MemcacheError
wrongOp Response
r String
"GET"
    case Response -> Status
resStatus Response
r of
        Status
NoError        -> Maybe (Key, Flags, Version) -> IO (Maybe (Key, Flags, Version))
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe (Key, Flags, Version) -> IO (Maybe (Key, Flags, Version)))
-> Maybe (Key, Flags, Version) -> IO (Maybe (Key, Flags, Version))
forall a b. (a -> b) -> a -> b
$ (Key, Flags, Version) -> Maybe (Key, Flags, Version)
forall a. a -> Maybe a
Just (Key
v, Flags
f, Response -> Version
resCas Response
r)
        Status
ErrKeyNotFound -> Maybe (Key, Flags, Version) -> IO (Maybe (Key, Flags, Version))
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe (Key, Flags, Version)
forall a. Maybe a
Nothing
        Status
rs             -> Status -> IO (Maybe (Key, Flags, Version))
forall a. Status -> IO a
throwStatus Status
rs

-- | Get-and-touch: Retrieve the value for the given key from Memcached, and
-- also update the stored key-value pairs expiration time at the server. Use an
-- expiration value of @0@ to store forever.
gat :: Cluster -> Key -> Expiration -> IO (Maybe (Value, Flags, Version))
gat :: Client -> Key -> Flags -> IO (Maybe (Key, Flags, Version))
gat Client
c Key
k Flags
e = do
    let msg :: Request
msg = Request
emptyReq { reqOp :: OpRequest
reqOp = Q -> K -> Key -> SETouch -> OpRequest
ReqGAT Q
Loud K
NoKey Key
k (Flags -> SETouch
SETouch Flags
e) }
    Response
r <- Client -> Key -> Request -> IO Response
keyedOp Client
c Key
k Request
msg
    (Key
v, Flags
f) <- case Response -> OpResponse
resOp Response
r of
        ResGAT Q
Loud Key
v Flags
f -> (Key, Flags) -> IO (Key, Flags)
forall (m :: * -> *) a. Monad m => a -> m a
return (Key
v, Flags
f)
        OpResponse
_               -> MemcacheError -> IO (Key, Flags)
forall e a. Exception e => e -> IO a
throwIO (MemcacheError -> IO (Key, Flags))
-> MemcacheError -> IO (Key, Flags)
forall a b. (a -> b) -> a -> b
$ Response -> String -> MemcacheError
wrongOp Response
r String
"GAT"
    case Response -> Status
resStatus Response
r of
        Status
NoError        -> Maybe (Key, Flags, Version) -> IO (Maybe (Key, Flags, Version))
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe (Key, Flags, Version) -> IO (Maybe (Key, Flags, Version)))
-> Maybe (Key, Flags, Version) -> IO (Maybe (Key, Flags, Version))
forall a b. (a -> b) -> a -> b
$ (Key, Flags, Version) -> Maybe (Key, Flags, Version)
forall a. a -> Maybe a
Just (Key
v, Flags
f, Response -> Version
resCas Response
r)
        Status
ErrKeyNotFound -> Maybe (Key, Flags, Version) -> IO (Maybe (Key, Flags, Version))
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe (Key, Flags, Version)
forall a. Maybe a
Nothing
        Status
rs             -> Status -> IO (Maybe (Key, Flags, Version))
forall a. Status -> IO a
throwStatus Status
rs

-- | Update the expiration time of a stored key-value pair, returning its
-- version identifier. Use an expiration value of @0@ to store forever.
touch :: Cluster -> Key -> Expiration -> IO (Maybe Version)
touch :: Client -> Key -> Flags -> IO (Maybe Version)
touch Client
c Key
k Flags
e = do
    let msg :: Request
msg = Request
emptyReq { reqOp :: OpRequest
reqOp = Key -> SETouch -> OpRequest
ReqTouch Key
k (Flags -> SETouch
SETouch Flags
e) }
    Response
r <- Client -> Key -> Request -> IO Response
keyedOp Client
c Key
k Request
msg
    Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Response -> OpResponse
resOp Response
r OpResponse -> OpResponse -> Bool
forall a. Eq a => a -> a -> Bool
/= OpResponse
ResTouch) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ MemcacheError -> IO ()
forall e a. Exception e => e -> IO a
throwIO (MemcacheError -> IO ()) -> MemcacheError -> IO ()
forall a b. (a -> b) -> a -> b
$ Response -> String -> MemcacheError
wrongOp Response
r String
"TOUCH"
    case Response -> Status
resStatus Response
r of
        Status
NoError        -> Maybe Version -> IO (Maybe Version)
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe Version -> IO (Maybe Version))
-> Maybe Version -> IO (Maybe Version)
forall a b. (a -> b) -> a -> b
$ Version -> Maybe Version
forall a. a -> Maybe a
Just (Response -> Version
resCas Response
r)
        Status
ErrKeyNotFound -> Maybe Version -> IO (Maybe Version)
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe Version
forall a. Maybe a
Nothing
        Status
rs             -> Status -> IO (Maybe Version)
forall a. Status -> IO a
throwStatus Status
rs

-- | Store a new (or overwrite exisiting) key-value pair, returning its version
-- identifier. Use an expiration value of @0@ to store forever.
set :: Cluster -> Key -> Value -> Flags -> Expiration -> IO Version
set :: Client -> Key -> Key -> Flags -> Flags -> IO Version
set Client
c Key
k Key
v Flags
f Flags
e = do
    let msg :: Request
msg = Request
emptyReq { reqOp :: OpRequest
reqOp = Q -> Key -> Key -> SESet -> OpRequest
ReqSet Q
Loud Key
k Key
v (Flags -> Flags -> SESet
SESet Flags
f Flags
e) }
    Response
r <- Client -> Key -> Request -> IO Response
keyedOp Client
c Key
k Request
msg
    Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Response -> OpResponse
resOp Response
r OpResponse -> OpResponse -> Bool
forall a. Eq a => a -> a -> Bool
/= Q -> OpResponse
ResSet Q
Loud) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ MemcacheError -> IO ()
forall e a. Exception e => e -> IO a
throwIO (MemcacheError -> IO ()) -> MemcacheError -> IO ()
forall a b. (a -> b) -> a -> b
$ Response -> String -> MemcacheError
wrongOp Response
r String
"SET"
    case Response -> Status
resStatus Response
r of
        Status
NoError -> Version -> IO Version
forall (m :: * -> *) a. Monad m => a -> m a
return (Version -> IO Version) -> Version -> IO Version
forall a b. (a -> b) -> a -> b
$ Response -> Version
resCas Response
r
        Status
rs      -> Status -> IO Version
forall a. Status -> IO a
throwStatus Status
rs

-- | Store a key-value pair, but only if the version specified by the client
-- matches the Version of the key-value pair at the server. The version
-- identifier of the stored key-value pair is returned, or if the version match
-- fails, @Nothing@ is returned. Use an expiration value of @0@ to store
-- forever.
cas :: Cluster -> Key -> Value -> Flags -> Expiration -> Version -> IO (Maybe Version)
cas :: Client
-> Key -> Key -> Flags -> Flags -> Version -> IO (Maybe Version)
cas Client
c Key
k Key
v Flags
f Flags
e Version
ver = do
    let msg :: Request
msg = Request
emptyReq { reqOp :: OpRequest
reqOp = Q -> Key -> Key -> SESet -> OpRequest
ReqSet Q
Loud Key
k Key
v (Flags -> Flags -> SESet
SESet Flags
f Flags
e), reqCas :: Version
reqCas = Version
ver }
    Response
r <- Client -> Key -> Request -> IO Response
keyedOp Client
c Key
k Request
msg
    Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Response -> OpResponse
resOp Response
r OpResponse -> OpResponse -> Bool
forall a. Eq a => a -> a -> Bool
/= Q -> OpResponse
ResSet Q
Loud) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ MemcacheError -> IO ()
forall e a. Exception e => e -> IO a
throwIO (MemcacheError -> IO ()) -> MemcacheError -> IO ()
forall a b. (a -> b) -> a -> b
$ Response -> String -> MemcacheError
wrongOp Response
r String
"SET"
    case Response -> Status
resStatus Response
r of
        Status
NoError        -> Maybe Version -> IO (Maybe Version)
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe Version -> IO (Maybe Version))
-> Maybe Version -> IO (Maybe Version)
forall a b. (a -> b) -> a -> b
$ Version -> Maybe Version
forall a. a -> Maybe a
Just (Response -> Version
resCas Response
r)
        Status
ErrKeyNotFound -> Maybe Version -> IO (Maybe Version)
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe Version
forall a. Maybe a
Nothing -- CAS: key doesn't exist
        Status
ErrKeyExists   -> Maybe Version -> IO (Maybe Version)
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe Version
forall a. Maybe a
Nothing -- CAS: version doesn't match
        Status
rs             -> Status -> IO (Maybe Version)
forall a. Status -> IO a
throwStatus Status
rs

-- | Store a new key-value pair, returning it's version identifier. If the
-- key-value pair already exists, then fail (return 'Nothing'). Use an
-- expiration value of @0@ to store forever.
add :: Cluster -> Key -> Value -> Flags -> Expiration -> IO (Maybe Version)
add :: Client -> Key -> Key -> Flags -> Flags -> IO (Maybe Version)
add Client
c Key
k Key
v Flags
f Flags
e = do
    let msg :: Request
msg = Request
emptyReq { reqOp :: OpRequest
reqOp = Q -> Key -> Key -> SESet -> OpRequest
ReqAdd Q
Loud Key
k Key
v (Flags -> Flags -> SESet
SESet Flags
f Flags
e) }
    Response
r <- Client -> Key -> Request -> IO Response
keyedOp Client
c Key
k Request
msg
    Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Response -> OpResponse
resOp Response
r OpResponse -> OpResponse -> Bool
forall a. Eq a => a -> a -> Bool
/= Q -> OpResponse
ResAdd Q
Loud) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ MemcacheError -> IO ()
forall e a. Exception e => e -> IO a
throwIO (MemcacheError -> IO ()) -> MemcacheError -> IO ()
forall a b. (a -> b) -> a -> b
$ Response -> String -> MemcacheError
wrongOp Response
r String
"ADD"
    case Response -> Status
resStatus Response
r of
        Status
NoError      -> Maybe Version -> IO (Maybe Version)
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe Version -> IO (Maybe Version))
-> Maybe Version -> IO (Maybe Version)
forall a b. (a -> b) -> a -> b
$ Version -> Maybe Version
forall a. a -> Maybe a
Just (Response -> Version
resCas Response
r)
        Status
ErrKeyExists -> Maybe Version -> IO (Maybe Version)
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe Version
forall a. Maybe a
Nothing
        Status
rs           -> Status -> IO (Maybe Version)
forall a. Status -> IO a
throwStatus Status
rs

-- | Update the value of an existing key-value pair, returning it's new version
-- identifier. If the key doesn't already exist, the fail and return Nothing.
-- Use an expiration value of @0@ to store forever.
replace :: Cluster -> Key -> Value -> Flags -> Expiration -> Version -> IO (Maybe Version)
replace :: Client
-> Key -> Key -> Flags -> Flags -> Version -> IO (Maybe Version)
replace Client
c Key
k Key
v Flags
f Flags
e Version
ver = do
    let msg :: Request
msg = Request
emptyReq { reqOp :: OpRequest
reqOp = Q -> Key -> Key -> SESet -> OpRequest
ReqReplace Q
Loud Key
k Key
v (Flags -> Flags -> SESet
SESet Flags
f Flags
e), reqCas :: Version
reqCas = Version
ver }
    Response
r <- Client -> Key -> Request -> IO Response
keyedOp Client
c Key
k Request
msg
    Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Response -> OpResponse
resOp Response
r OpResponse -> OpResponse -> Bool
forall a. Eq a => a -> a -> Bool
/= Q -> OpResponse
ResReplace Q
Loud) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ MemcacheError -> IO ()
forall e a. Exception e => e -> IO a
throwIO (MemcacheError -> IO ()) -> MemcacheError -> IO ()
forall a b. (a -> b) -> a -> b
$ Response -> String -> MemcacheError
wrongOp Response
r String
"REPLACE"
    case Response -> Status
resStatus Response
r of
        Status
NoError        -> Maybe Version -> IO (Maybe Version)
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe Version -> IO (Maybe Version))
-> Maybe Version -> IO (Maybe Version)
forall a b. (a -> b) -> a -> b
$ Version -> Maybe Version
forall a. a -> Maybe a
Just (Response -> Version
resCas Response
r)
        -- replace only applies to an existing key...
        Status
ErrKeyNotFound -> Maybe Version -> IO (Maybe Version)
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe Version
forall a. Maybe a
Nothing
        -- version specified and doesn't match key...
        Status
ErrKeyExists   -> Maybe Version -> IO (Maybe Version)
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe Version
forall a. Maybe a
Nothing
        Status
rs             -> Status -> IO (Maybe Version)
forall a. Status -> IO a
throwStatus Status
rs

-- | Increment a numeric value stored against a key, returning the incremented
-- value and the version identifier of the key-value pair. Use an expiration
-- value of @0@ to store forever.
increment :: Cluster -> Key -> Initial -> Delta -> Expiration -> Version -> IO (Maybe (Word64, Version))
increment :: Client
-> Key
-> Version
-> Version
-> Flags
-> Version
-> IO (Maybe (Version, Version))
increment Client
c Key
k Version
i Version
d Flags
e Version
ver = do
    let msg :: Request
msg = Request
emptyReq { reqOp :: OpRequest
reqOp = Q -> Key -> SEIncr -> OpRequest
ReqIncrement Q
Loud Key
k (Version -> Version -> Flags -> SEIncr
SEIncr Version
i Version
d Flags
e), reqCas :: Version
reqCas = Version
ver }
    Response
r <- Client -> Key -> Request -> IO Response
keyedOp Client
c Key
k Request
msg
    Version
n <- case Response -> OpResponse
resOp Response
r of
        ResIncrement Q
Loud Version
n -> Version -> IO Version
forall (m :: * -> *) a. Monad m => a -> m a
return Version
n
        OpResponse
_                   -> MemcacheError -> IO Version
forall e a. Exception e => e -> IO a
throwIO (MemcacheError -> IO Version) -> MemcacheError -> IO Version
forall a b. (a -> b) -> a -> b
$ Response -> String -> MemcacheError
wrongOp Response
r String
"INCREMENT"
    case Response -> Status
resStatus Response
r of
        Status
NoError        -> Maybe (Version, Version) -> IO (Maybe (Version, Version))
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe (Version, Version) -> IO (Maybe (Version, Version)))
-> Maybe (Version, Version) -> IO (Maybe (Version, Version))
forall a b. (a -> b) -> a -> b
$ (Version, Version) -> Maybe (Version, Version)
forall a. a -> Maybe a
Just (Version
n, Response -> Version
resCas Response
r)
        Status
ErrKeyNotFound -> Maybe (Version, Version) -> IO (Maybe (Version, Version))
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe (Version, Version)
forall a. Maybe a
Nothing
        Status
ErrKeyExists   -> Maybe (Version, Version) -> IO (Maybe (Version, Version))
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe (Version, Version)
forall a. Maybe a
Nothing
        Status
rs             -> Status -> IO (Maybe (Version, Version))
forall a. Status -> IO a
throwStatus Status
rs

-- | Decrement a numeric value stored against a key, returning the decremented
-- value and the version identifier of the key-value pair. Use an expiration
-- value of @0@ to store forever.
decrement :: Cluster -> Key -> Initial -> Delta -> Expiration -> Version -> IO (Maybe (Word64, Version))
decrement :: Client
-> Key
-> Version
-> Version
-> Flags
-> Version
-> IO (Maybe (Version, Version))
decrement Client
c Key
k Version
i Version
d Flags
e Version
ver = do
    let msg :: Request
msg = Request
emptyReq { reqOp :: OpRequest
reqOp = Q -> Key -> SEIncr -> OpRequest
ReqDecrement Q
Loud Key
k (Version -> Version -> Flags -> SEIncr
SEIncr Version
i Version
d Flags
e), reqCas :: Version
reqCas = Version
ver }
    Response
r <- Client -> Key -> Request -> IO Response
keyedOp Client
c Key
k Request
msg
    Version
n <- case Response -> OpResponse
resOp Response
r of
        ResDecrement Q
Loud Version
n -> Version -> IO Version
forall (m :: * -> *) a. Monad m => a -> m a
return Version
n
        OpResponse
_                   -> MemcacheError -> IO Version
forall e a. Exception e => e -> IO a
throwIO (MemcacheError -> IO Version) -> MemcacheError -> IO Version
forall a b. (a -> b) -> a -> b
$ Response -> String -> MemcacheError
wrongOp Response
r String
"DECREMENT"
    case Response -> Status
resStatus Response
r of
        Status
NoError        -> Maybe (Version, Version) -> IO (Maybe (Version, Version))
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe (Version, Version) -> IO (Maybe (Version, Version)))
-> Maybe (Version, Version) -> IO (Maybe (Version, Version))
forall a b. (a -> b) -> a -> b
$ (Version, Version) -> Maybe (Version, Version)
forall a. a -> Maybe a
Just (Version
n, Response -> Version
resCas Response
r)
        Status
ErrKeyNotFound -> Maybe (Version, Version) -> IO (Maybe (Version, Version))
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe (Version, Version)
forall a. Maybe a
Nothing
        Status
ErrKeyExists   -> Maybe (Version, Version) -> IO (Maybe (Version, Version))
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe (Version, Version)
forall a. Maybe a
Nothing
        Status
rs             -> Status -> IO (Maybe (Version, Version))
forall a. Status -> IO a
throwStatus Status
rs

-- | Append a value to an existing key-value pair, returning the new version
-- identifier of the key-value pair when successful.
append :: Cluster -> Key -> Value -> Version -> IO (Maybe Version)
append :: Client -> Key -> Key -> Version -> IO (Maybe Version)
append Client
c Key
k Key
v Version
ver = do
    let msg :: Request
msg = Request
emptyReq { reqOp :: OpRequest
reqOp = Q -> Key -> Key -> OpRequest
ReqAppend Q
Loud Key
k Key
v, reqCas :: Version
reqCas = Version
ver }
    Response
r <- Client -> Key -> Request -> IO Response
keyedOp Client
c Key
k Request
msg
    Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Response -> OpResponse
resOp Response
r OpResponse -> OpResponse -> Bool
forall a. Eq a => a -> a -> Bool
/= Q -> OpResponse
ResAppend Q
Loud) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ MemcacheError -> IO ()
forall e a. Exception e => e -> IO a
throwIO (MemcacheError -> IO ()) -> MemcacheError -> IO ()
forall a b. (a -> b) -> a -> b
$ Response -> String -> MemcacheError
wrongOp Response
r String
"APPEND"
    case Response -> Status
resStatus Response
r of
        Status
NoError        -> Maybe Version -> IO (Maybe Version)
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe Version -> IO (Maybe Version))
-> Maybe Version -> IO (Maybe Version)
forall a b. (a -> b) -> a -> b
$ Version -> Maybe Version
forall a. a -> Maybe a
Just (Response -> Version
resCas Response
r)
        Status
ErrKeyNotFound -> Maybe Version -> IO (Maybe Version)
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe Version
forall a. Maybe a
Nothing
        Status
rs             -> Status -> IO (Maybe Version)
forall a. Status -> IO a
throwStatus Status
rs

-- | Prepend a value to an existing key-value pair, returning the new version
-- identifier of the key-value pair when successful.
prepend :: Cluster -> Key -> Value -> Version -> IO (Maybe Version)
prepend :: Client -> Key -> Key -> Version -> IO (Maybe Version)
prepend Client
c Key
k Key
v Version
ver = do
    let msg :: Request
msg = Request
emptyReq { reqOp :: OpRequest
reqOp = Q -> Key -> Key -> OpRequest
ReqPrepend Q
Loud Key
k Key
v, reqCas :: Version
reqCas = Version
ver }
    Response
r <- Client -> Key -> Request -> IO Response
keyedOp Client
c Key
k Request
msg
    Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Response -> OpResponse
resOp Response
r OpResponse -> OpResponse -> Bool
forall a. Eq a => a -> a -> Bool
/= Q -> OpResponse
ResPrepend Q
Loud) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ MemcacheError -> IO ()
forall e a. Exception e => e -> IO a
throwIO (MemcacheError -> IO ()) -> MemcacheError -> IO ()
forall a b. (a -> b) -> a -> b
$ Response -> String -> MemcacheError
wrongOp Response
r String
"PREPEND"
    case Response -> Status
resStatus Response
r of
        Status
NoError        -> Maybe Version -> IO (Maybe Version)
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe Version -> IO (Maybe Version))
-> Maybe Version -> IO (Maybe Version)
forall a b. (a -> b) -> a -> b
$ Version -> Maybe Version
forall a. a -> Maybe a
Just (Response -> Version
resCas Response
r)
        Status
ErrKeyNotFound -> Maybe Version -> IO (Maybe Version)
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe Version
forall a. Maybe a
Nothing
        Status
rs             -> Status -> IO (Maybe Version)
forall a. Status -> IO a
throwStatus Status
rs

-- | Delete a key-value pair at the server, returning true if successful.
delete :: Cluster -> Key -> Version -> IO Bool
delete :: Client -> Key -> Version -> IO Bool
delete Client
c Key
k Version
ver = do
    let msg :: Request
msg = Request
emptyReq { reqOp :: OpRequest
reqOp = Q -> Key -> OpRequest
ReqDelete Q
Loud Key
k, reqCas :: Version
reqCas = Version
ver }
    Response
r <- Client -> Key -> Request -> IO Response
keyedOp Client
c Key
k Request
msg
    Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Response -> OpResponse
resOp Response
r OpResponse -> OpResponse -> Bool
forall a. Eq a => a -> a -> Bool
/= Q -> OpResponse
ResDelete Q
Loud) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ MemcacheError -> IO ()
forall e a. Exception e => e -> IO a
throwIO (MemcacheError -> IO ()) -> MemcacheError -> IO ()
forall a b. (a -> b) -> a -> b
$ Response -> String -> MemcacheError
wrongOp Response
r String
"DELETE"
    case Response -> Status
resStatus Response
r of
        Status
NoError        -> Bool -> IO Bool
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
True
        -- delete only applies to an existing key...
        Status
ErrKeyNotFound -> Bool -> IO Bool
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
False
        -- version specified and doesn't match key...
        Status
ErrKeyExists   -> Bool -> IO Bool
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
False
        Status
rs             -> Status -> IO Bool
forall a. Status -> IO a
throwStatus Status
rs

-- | Remove (delete) all currently stored key-value pairs from the cluster. The
-- expiration value can be used to cause this flush to occur in the future
-- rather than immediately.
flush :: Cluster -> Maybe Expiration -> IO ()
flush :: Client -> Maybe Flags -> IO ()
flush Client
c Maybe Flags
e = do
    let msg :: Request
msg = Request
emptyReq { reqOp :: OpRequest
reqOp = Q -> Maybe SETouch -> OpRequest
ReqFlush Q
Loud (Flags -> SETouch
SETouch (Flags -> SETouch) -> Maybe Flags -> Maybe SETouch
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe Flags
e) }
    [(Server, Response)]
results <- Client -> Request -> IO [(Server, Response)]
allOp Client
c Request
msg
    [(Server, Response)] -> ((Server, Response) -> IO ()) -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ [(Server, Response)]
results (((Server, Response) -> IO ()) -> IO ())
-> ((Server, Response) -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \(Server
_, Response
r) -> do
        Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Response -> OpResponse
resOp Response
r OpResponse -> OpResponse -> Bool
forall a. Eq a => a -> a -> Bool
/= Q -> OpResponse
ResFlush Q
Loud) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ MemcacheError -> IO ()
forall e a. Exception e => e -> IO a
throwIO (MemcacheError -> IO ()) -> MemcacheError -> IO ()
forall a b. (a -> b) -> a -> b
$ Response -> String -> MemcacheError
wrongOp Response
r String
"FLUSH"
        case Response -> Status
resStatus Response
r of
            Status
NoError -> () -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
            Status
rs      -> Status -> IO ()
forall a. Status -> IO a
throwStatus Status
rs

-- | StatResults are a list of key-value pairs.
type StatResults = [(ByteString, ByteString)]

-- | Return statistics on the stored key-value pairs at each server in the
-- cluster. The optional key can be used to select a different set of
-- statistics from the server than the default. Most Memcached servers support
-- @"items"@, @"slabs"@ or @"settings"@.
stats :: Cluster -> Maybe Key -> IO [(Server, Maybe StatResults)]
stats :: Client -> Maybe Key -> IO [(Server, Maybe StatResults)]
stats Client
c Maybe Key
key = Client
-> (Server -> IO (Maybe StatResults))
-> IO [(Server, Maybe StatResults)]
forall a. Client -> (Server -> IO a) -> IO [(Server, a)]
allOp' Client
c Server -> IO (Maybe StatResults)
serverStats
  where
    msg :: Request
    msg :: Request
msg = Request
emptyReq { reqOp :: OpRequest
reqOp = Maybe Key -> OpRequest
ReqStat Maybe Key
key }

    serverStats :: Server -> IO (Maybe StatResults)
    serverStats :: Server -> IO (Maybe StatResults)
serverStats Server
s = Server
-> (Socket -> IO (Maybe StatResults)) -> IO (Maybe StatResults)
forall a. Server -> (Socket -> IO a) -> IO a
withSocket Server
s ((Socket -> IO (Maybe StatResults)) -> IO (Maybe StatResults))
-> (Socket -> IO (Maybe StatResults)) -> IO (Maybe StatResults)
forall a b. (a -> b) -> a -> b
$ \Socket
sock -> do
        Socket -> Request -> IO ()
send Socket
sock Request
msg
        Socket -> StatResults -> IO (Maybe StatResults)
recvAllStats Socket
sock []

    recvAllStats :: Socket -> StatResults -> IO (Maybe StatResults)
    recvAllStats :: Socket -> StatResults -> IO (Maybe StatResults)
recvAllStats Socket
s StatResults
xs = do
        Response
r <- Socket -> IO Response
recv Socket
s
        (Key
k, Key
v) <- case Response -> OpResponse
resOp Response
r of
            ResStat Key
k Key
v -> (Key, Key) -> IO (Key, Key)
forall (m :: * -> *) a. Monad m => a -> m a
return (Key
k, Key
v)
            OpResponse
_           -> MemcacheError -> IO (Key, Key)
forall e a. Exception e => e -> IO a
throwIO (MemcacheError -> IO (Key, Key)) -> MemcacheError -> IO (Key, Key)
forall a b. (a -> b) -> a -> b
$ Response -> String -> MemcacheError
wrongOp Response
r String
"STATS"
        case Response -> Status
resStatus Response
r of
            Status
NoError | Key -> Bool
B.null Key
k Bool -> Bool -> Bool
&& Key -> Bool
B.null Key
v -> Maybe StatResults -> IO (Maybe StatResults)
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe StatResults -> IO (Maybe StatResults))
-> Maybe StatResults -> IO (Maybe StatResults)
forall a b. (a -> b) -> a -> b
$ StatResults -> Maybe StatResults
forall a. a -> Maybe a
Just StatResults
xs
                    | Bool
otherwise            -> Socket -> StatResults -> IO (Maybe StatResults)
recvAllStats Socket
s (StatResults -> IO (Maybe StatResults))
-> StatResults -> IO (Maybe StatResults)
forall a b. (a -> b) -> a -> b
$ (Key
k, Key
v)(Key, Key) -> StatResults -> StatResults
forall a. a -> [a] -> [a]
:StatResults
xs
            Status
ErrKeyNotFound                 -> Maybe StatResults -> IO (Maybe StatResults)
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe StatResults
forall a. Maybe a
Nothing
            Status
rs                             -> Status -> IO (Maybe StatResults)
forall a. Status -> IO a
throwStatus Status
rs

-- | Version returns the version string of the Memcached cluster. We just query
-- one server and assume all servers in the cluster are the same version.
version :: Cluster -> IO ByteString
version :: Client -> IO Key
version Client
c = do
    let msg :: Request
msg = Request
emptyReq { reqOp :: OpRequest
reqOp = OpRequest
ReqVersion }
    Response
r <- Client -> Request -> IO Response
anyOp Client
c Request
msg
    Key
v <- case Response -> OpResponse
resOp Response
r of
        ResVersion Key
v -> Key -> IO Key
forall (m :: * -> *) a. Monad m => a -> m a
return Key
v
        OpResponse
_            -> MemcacheError -> IO Key
forall e a. Exception e => e -> IO a
throwIO (MemcacheError -> IO Key) -> MemcacheError -> IO Key
forall a b. (a -> b) -> a -> b
$ Response -> String -> MemcacheError
wrongOp Response
r String
"VERSION"
    case Response -> Status
resStatus Response
r of
        Status
NoError -> Key -> IO Key
forall (m :: * -> *) a. Monad m => a -> m a
return Key
v
        Status
rs      -> Status -> IO Key
forall a. Status -> IO a
throwStatus Status
rs

-- | Noop sends a Non-operation command to the specified Memcached server.  We
-- leave it blanked out, but here for documentation purposes of the full
-- protocol.
-- noop :: Server -> IO ()
-- noop c = do
--     let msg = emptyReq { reqOp = ReqNoop }
--     r <- sendRecv c msg
--     when (resOp r /= ResNoop) $ throwIncorrectRes r "NOOP"
--     case resStatus r of
--         NoError -> return ()
--         rs      -> throwStatus rs