diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -1,23 +1,41 @@ -# 0.1.X.X +# 0.2.0.0 - May 27th, 2016 +* Big design change to reduce code duplication (`Protocol` module gone). +* Remove `Options` type - just fixed configuration for now. +* Design change also allows proper retry handling on operation failure - we + retry an operation against the same server, but after N consecutive failures, + we mark the server as dead and don't try using it again until M seconds has + passed. +* Simplify exception hierachy - just one type `MemcacheError` now for +* Remove `defaultOptions` and `defaultServerSpec`, will revist usefulness. + exceptions. +* Remove many `Typeable` instances. +* Support better testing with a mock Memcached server. +* Fix bug in socket handling - detected EOF properly. +* Greatly improve documentation. +* Use `data-default-class` for defaults of servers and options. + +# 0.1.0.1 - February 26th, 2016 + * Consistent usage of 'memcached' instead of 'memcache'. -* Document `Database.Memcache.Client` +* Document `Database.Memcache.Client`. * Add inline pragmas in appropriate places. +* Fix bug handling fragmented IP packets (Alfredo Di Napoli). -# 0.1.0.0 +# 0.1.0.0 - May 18th, 2015 -* First proper release (although still lots of rough edges!) +* First proper release (although still lots of rough edges!). * Filled out `Data.Memcache.Client` to a complete API. * Integrated cluster and authentication handling. * Better error and exception handling. * Fix compilation under GHC 7.10. -# 0.0.1 +# 0.0.1 - May 5th, 2015 * Initial (incomplete) support for a cluster of memcached servers. * Fixed compilation under GHC 7.4. -# 0.0.0 +# 0.0.0 - August 23rd, 2013 * Initial release. Support for a single server. diff --git a/Database/Memcache/Client.hs b/Database/Memcache/Client.hs --- a/Database/Memcache/Client.hs +++ b/Database/Memcache/Client.hs @@ -1,147 +1,376 @@ --- | A memcached client. Supports the binary protocol (only) and SASL --- authentication. --- --- 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. --- --- Expected return values (like misses) are returned as part of the return --- type, while unexpected errors are thrown as exceptions. +{-# 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 operatins: + +* __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 rety 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 as 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, monontonically 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 interpretted as a UNIX timestamp (the number + of seconds since epoch). + + [@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 ( - -- * Cluster and connection handling - newClient, Client, ServerSpec(..), defaultServerSpec, Options(..), - defaultOptions, Authentication(..), Username, Password, quit, + -- * Client creation + newClient, Client, ServerSpec(..), Options(..), + Authentication(..), Username, Password, def, + quit, - -- * Get operations + -- * Operations + + -- ** Get operations get, gat, touch, - -- * Set operations - set, set', add, replace, - - -- * Delete operations - delete, flush, - - -- * Modify operations + -- ** Set operations + set, cas, add, replace, + + -- ** Modify operations increment, decrement, append, prepend, - -- * Information operations - version, stats, P.StatResults, + -- ** Delete operations + delete, flush, - -- * Error handling - MemcacheError(..), ClientError(..) + -- ** Information operations + StatResults, stats, version, + + -- * Errors + MemcacheError(..), Status(..), ClientError(..), ProtocolError(..) ) where import Database.Memcache.Cluster import Database.Memcache.Errors -import qualified Database.Memcache.Protocol as P import Database.Memcache.Server -import Database.Memcache.Types +import Database.Memcache.Socket +import Database.Memcache.Types hiding (cas) -import Control.Monad +#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. +-- | A Memcached client, connected to a collection of Memcached servers. type Client = Cluster --- | Establish a new connection to a group of memcached servers. +-- | Establish a new connection to a group of Memcached servers. newClient :: [ServerSpec] -> Options -> IO Client newClient = newCluster --- | Gracefully close a connection to a memcached cluster. +-- | Gracefully close a connection to a Memcached cluster. quit :: Cluster -> IO () -quit c = void $ allOp (Just ()) c $ \s -> P.quit s +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 -keyedOp' :: Cluster -> Key -> (Server -> IO (Maybe a)) -> IO (Maybe a) -keyedOp' = keyedOp (Just Nothing) -{-# INLINE keyedOp' #-} + consumeError :: SomeException -> IO () + consumeError _ = return () --- | Retrieve the value for the given key from memcache. +-- | Retrieve the value for the given key from Memcached. get :: Cluster -> Key -> IO (Maybe (Value, Flags, Version)) -get c k = keyedOp' c k $ \s -> P.get s k -{-# INLINE get #-} +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 --- | Get-and-touch: Retrieve the value for the given key from memcache, and --- also update the stored key-value pairs expiration time at the server. +-- | 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 c k e = keyedOp' c k $ \s -> P.gat s k e -{-# INLINE gat #-} +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 -- | Update the expiration time of a stored key-value pair, returning its --- version identifier. +-- version identifier. Use an expiration value of @0@ to store forever. touch :: Cluster -> Key -> Expiration -> IO (Maybe Version) -touch c k e = keyedOp' c k $ \s -> P.touch s k e -{-# INLINE touch #-} +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 -- | Store a new (or overwrite exisiting) key-value pair, returning its version --- identifier. +-- identifier. Use an expiration value of @0@ to store forever. set :: Cluster -> Key -> Value -> Flags -> Expiration -> IO Version -set c k v f e = keyedOp (Just 0) c k $ \s -> P.set s k v f e -{-# INLINE set #-} +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 -- | 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 +-- 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. -set' :: Cluster -> Key -> Value -> Flags -> Expiration -> Version -> IO (Maybe Version) -set' c k v f e ver = keyedOp' c k $ \s -> P.set' s k v f e ver -{-# INLINE set' #-} +-- fails, @Nothing@ is returned. Use an expiration value of @0@ to store +-- forever. +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 -- CAS: key doesn't exist + ErrKeyExists -> return Nothing -- CAS: version doesn't match + rs -> throwStatus rs -- | Store a new key-value pair, returning it's version identifier. If the --- key-value pair already exists, then fail (return 'Nothing'). +-- 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 c k v f e = keyedOp' c k $ \s -> P.add s k v f e -{-# INLINE add #-} +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 -- | 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 c k v f e ver = keyedOp' c k $ \s -> P.replace s k v f e ver -{-# INLINE replace #-} - --- | Delete a key-value pair at the server, returning true if successful. -delete :: Cluster -> Key -> Version -> IO Bool -delete c k ver = keyedOp (Just False) c k $ \s -> P.delete s k ver -{-# INLINE delete #-} +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) + -- replace only applies to an existing key... + ErrKeyNotFound -> return Nothing + -- version specified and doesn't match key... + ErrKeyExists -> return Nothing + rs -> throwStatus rs -- | Increment a numeric value stored against a key, returning the incremented --- value and the version identifier of the key-value pair. +-- 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 c k i d e ver = keyedOp' c k $ \s -> P.increment s k i d e ver -{-# INLINE increment #-} +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 a numeric value stored against a key, returning the decremented --- value and the version identifier of the key-value pair. +-- 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 c k i d e ver = keyedOp' c k $ \s -> P.decrement s k i d e ver -{-# INLINE decrement #-} +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 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 c k v ver = keyedOp' c k $ \s -> P.append s k v ver -{-# INLINE append #-} +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 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 c k v ver = keyedOp' c k $ \s -> P.prepend s k v ver -{-# INLINE prepend #-} +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 --- | Remove (delete) all currently stored key-value pairs from the cluster. +-- | Delete a key-value pair at the server, returning true if successful. +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 + -- delete only applies to an existing key... + ErrKeyNotFound -> return False + -- version specified and doesn't match key... + ErrKeyExists -> return False + rs -> throwStatus 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 c e = void $ allOp (Just ()) c $ \s -> P.flush s e -{-# INLINE flush #-} +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 +-- | 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. -stats :: Cluster -> Maybe Key -> IO [(Server, Maybe P.StatResults)] -stats c key = allOp Nothing c $ \s -> P.stats s key -{-# INLINE stats #-} +-- 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 c key = allOp' c serverStats + where + msg :: Request + msg = emptyReq { reqOp = ReqStat key } --- | Version returns the version string of the memcached cluster. We just query + 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 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 c = anyOp Nothing c $ \s -> P.version s -{-# INLINE version #-} +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 + +-- | 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 diff --git a/Database/Memcache/Cluster.hs b/Database/Memcache/Cluster.hs --- a/Database/Memcache/Cluster.hs +++ b/Database/Memcache/Cluster.hs @@ -1,154 +1,236 @@ -{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE CPP #-} +{-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE ScopedTypeVariables #-} --- | Handles a group of connections to different memcached servers. +{-| +Module : Database.Memcache.Cluster +Description : Cluster Handling +Copyright : (c) David Terei, 2016 +License : BSD +Maintainer : code@davidterei.com +Stability : stable +Portability : GHC + +Handles a group of connections to different Memcached servers. + +We use consistent hashing to choose which server to route a request to. On an +error, we mark the server as failed and remove it temporarialy from the set of +servers available. +-} module Database.Memcache.Cluster ( - Cluster, newCluster, - ServerSpec(..), defaultServerSpec, - Options(..), defaultOptions, - keyedOp, anyOp, allOp + -- * Cluster + Cluster, ServerSpec(..), Options(..), newCluster, + + -- * Operations + Retries, keyedOp, anyOp, allOp, 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 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 qualified Data.Vector.Mutable as MV - import Network.Socket (HostName, PortNumber) +import System.Timeout --- | ServerSpec specifies a server configuration to connect to. +-- | Number of times to retry an operation before considering it failed. +type Retries = Int + +-- | ServerSpec specifies a server configuration for connection. data ServerSpec = ServerSpec { + -- | Hostname of server to connect to. ssHost :: HostName, + -- | Port number server is running on. ssPort :: PortNumber, + -- | Authentication values to use for SASL authentication with this + -- server. ssAuth :: Authentication - } + } deriving (Eq, Show) --- | Provides a default value for a server cconnection config. -defaultServerSpec :: ServerSpec -defaultServerSpec = ServerSpec { - ssHost = "localhost", - ssPort = 11211, - ssAuth = NoAuth - } +instance Default ServerSpec where + def = ServerSpec "localhost" 11211 NoAuth --- | Options specifies how a memcached cluster should be configured. +instance Default [ServerSpec] where + def = [def] + +-- | Options specifies how a Memcached cluster should be configured. data Options = Options { - optsCmdFailure :: !FailureMode, - optsServerFailure :: !FailureMode, - optsServerRetries :: !Int - } + -- | Number of times to retry an operation on failure. If consecutive + -- failures exceed this value for a server, we mark it as down and + -- failover to a different server for the next operation. + -- + -- Default is 2. + optsServerRetries :: Retries, + -- | After an operation has failed, how long to wait before retrying it + -- while still within the 'optsServerRetries' count? + -- + -- Default is 200ms. + optsFailRetryDelay :: Milli, + -- | How long to wait after a server has been marked down, before + -- trying to use it again. + -- + -- Default is 1500ms. + optsDeadRetryDelay :: Milli, + -- | How long to wait for an operation to complete before considering + -- it failed. + -- + -- Default is 750ms. + optsServerTimeout :: Milli + -- TODO: socket_timeout + -- TODO: failover + -- TODO: expires_in + -- TODO: namespace + -- TODO: compress + -- TODO: compress_min_size + -- TODO: compress_max_size + -- TODO: value_max_bytes + } deriving (Eq, Show) --- | Provides recommended default for a cluster Options. -defaultOptions :: Options -defaultOptions = Options { - optsCmdFailure = FailToError, - optsServerFailure = FailToError, - optsServerRetries = 2 - } +instance Default Options where + def = Options { + optsServerRetries = 2, + optsFailRetryDelay = 200, + optsDeadRetryDelay = 1500, + optsServerTimeout = 750 + } --- | A memcached cluster client. +-- | Memcached cluster. data Cluster = Cluster { - servers :: V.Vector Server, - cmdFailureMode :: !FailureMode, - _serverFailureMode :: !FailureMode, - serverRetries :: {-# UNPACK #-} !Int - } deriving Show + cServers :: V.Vector Server, --- | Establish a new connection to a group of memcached servers. + -- See 'Options' for description of these values. + + cRetries :: {-# UNPACK #-} !Int, + cFailDelay :: {-# UNPACK #-} !Int, -- ^ microseconds + cDeadDelay :: !NominalDiffTime, + cTimeout :: {-# UNPACK #-} !Int -- ^ microseconds + } deriving (Eq, Show) + +-- | Establish a new connection to a group of Memcached servers. newCluster :: [ServerSpec] -> Options -> IO Cluster +newCluster [] _ = throwIO $ ClientError NoServersReady newCluster hosts Options{..} = do s <- mapM (\ServerSpec{..} -> newServer ssHost ssPort ssAuth) hosts - return $ Cluster (V.fromList $ sort s) optsCmdFailure optsServerFailure - optsServerRetries + return $ + Cluster { + cServers = (V.fromList $ sort s), + cRetries = optsServerRetries , + cFailDelay = fromEnum optsFailRetryDelay, + cDeadDelay = fromRational $ toRational optsDeadRetryDelay / 1000, + cTimeout = fromEnum optsServerTimeout + } +-- | Check if server is alive. +serverAlive :: NominalDiffTime -> Server -> IO Bool +{-# INLINE serverAlive #-} +serverAlive deadDelay s = do + t <- readIORef (failed s) + if t == 0 + then return True + else do + t' <- getPOSIXTime + if (t' - t) < deadDelay + then return False + else do + writeIORef (failed s) 0 + return True + -- | Figure out which server to talk to for this key. I.e., the distribution -- method. We use consistent hashing based on the CHORD approach. -getServerForKey :: Cluster -> Key -> Server -getServerForKey c k = +getServerForKey :: Cluster -> Key -> IO (Maybe Server) +{-# INLINE getServerForKey #-} +getServerForKey c k = do let hashedKey = hash k - searchFun svr = sid svr < hashedKey - in fromMaybe (V.last $ servers c) $ V.find searchFun (servers c) - --- | Run a memcached operation against a server that maps to the key given in --- the cluster. -keyedOp :: forall a. Maybe a -> Cluster -> Key -> (Server -> IO a) -> IO a -keyedOp def c k = serverOp def c (getServerForKey c k) + searchF s = sid s < hashedKey + servers' <- V.filterM (serverAlive $ cDeadDelay c) $ cServers c + return $ if V.null servers' + then Nothing + else Just $ fromMaybe (V.last servers') (V.find searchF servers') --- | Run a memcached operation against any single server in the cluster. -anyOp :: forall a. Maybe a -> Cluster -> (Server -> IO a) -> IO a -anyOp def c = serverOp def c (V.head . servers $ c) +-- | Run a Memcached operation against a particular server, handling any +-- failures that occur, retrying the specified number of times. +serverOp :: Cluster -> Server -> Request -> IO Response +{-# INLINE serverOp #-} +serverOp c s req = retryOp c s $ sendRecv s req --- | Run a memcached operation against all servers in the cluster. -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 +-- | Run a Memcached operation against a particular server, handling any +-- failures that occur, retrying the specified number of times. +keyedOp :: Cluster -> Key -> Request -> IO Response +{-# INLINE keyedOp #-} +keyedOp c k req = do + s' <- getServerForKey c k + case s' of + Just s -> serverOp c s req + Nothing -> throwIO $ ClientError NoServersReady --- Server down handling modes: --- * Failover to next server -- this command + all others to failed server --- * Failover to next server -- fail current command but all future to failed --- server are moved over --- * Throw error -- on this command + all subsequent ones to this server --- * Throw error -- on this command but silently ignore future commands to --- this server --- --- Failure Matrix: When command fails: --- * S = server commands are meant to go to. --- * S' = failover server for S (i.e., next in ring) --- --- Mode | Current Command | Future Commands | Makes Sense? --- ------------------------------------------------------- --- 1 | exception | silently drop | Yes --- 2 | exception | failover | Yes --- 3 | exception | exception | Yes --- 4 | silently drop | silently drop | Yes --- 5 | failover | failover | Yes --- 6 | failover | exception | No --- 7 | failover | silently drop | No --- --- Other option here is, is this recursive or a one-hop failover? --- -data FailureMode = FailSilent | FailToBackup | FailToError - deriving (Eq, Show) +-- | Run a Memcached operation against any single server in the cluster, +-- handling any failures that occur, retrying the specified number of times. +anyOp :: Cluster -> Request -> IO Response +{-# INLINE anyOp #-} +anyOp c req = do + servers' <- V.filterM (serverAlive $ cDeadDelay c) $ cServers c + if V.null servers' + then throwIO $ ClientError NoServersReady + else serverOp c (V.head servers') req --- | Run a memcached operation against a particular server, handling any --- failures that occur. -serverOp :: forall a. Maybe a -> Cluster -> Server -> (Server -> IO a) -> IO a -serverOp def c s m = go $ serverRetries c - where +-- | Run a Memcached operation against all servers in the cluster, handling any +-- failures that occur, retrying the specified number of times. +allOp :: Cluster -> Request -> IO [(Server, Response)] +{-# INLINE allOp #-} +allOp c req = do + servers' <- V.filterM (serverAlive $ cDeadDelay c) $ cServers c + if V.null servers' + then throwIO $ ClientError NoServersReady + else do + res <- V.forM servers' $ \s -> serverOp c s req + return $ V.toList $ V.zip servers' res - go attempt = - m s `E.catches` - [ E.Handler $ handleMemErrors (attempt - 1) - , E.Handler $ handleAllErrors (attempt - 1) - ] +-- | Run a Memcached operation against all servers in the cluster, handling any +-- failures that occur, retrying the specified number of times. Similar to +-- 'anyOp' but allows more flexible interaction with the 'Server' than a single +-- request and response. +allOp' :: Cluster -> (Server -> IO a) -> IO [(Server, a)] +{-# INLINE allOp' #-} +allOp' c op = do + servers' <- V.filterM (serverAlive $ cDeadDelay c) $ cServers c + if V.null servers' + then throwIO $ ClientError NoServersReady + else do + res <- V.forM servers' $ \s -> retryOp c s (op s) + return $ V.toList $ V.zip servers' res - cmdError err | cmdFailureMode c == FailSilent - = maybe (E.throwIO err) return def - | cmdFailureMode c == FailToBackup - = undefined -- XXX: Implement - | otherwise -- FailToError - = E.throwIO err - - -- These errors are thrown outside the resource-pool and so don't destroy - -- the connection. This is desired as the connection should still be fine. - handleMemErrors :: Int -> MemcacheError -> IO a - handleMemErrors 0 err = cmdError err -- XXX: Mark as failed! - handleMemErrors atmp MemErrStoreFailed = go atmp - handleMemErrors atmp MemErrUnknownCmd = go atmp - handleMemErrors _ err = E.throwIO err +-- | Run an IO operation multiple times if an exception is thrown, marking the +-- server as dead if it fails more than the allowed number of retries. +retryOp :: forall a. Cluster -> Server -> IO a -> IO a +{-# INLINE retryOp #-} +retryOp Cluster{..} s op = go cRetries + where + go :: Int -> IO a + {-# INLINE go #-} + go !n = handle (handleErrs $ n - 1) $ do + mr <- timeout cTimeout op + case mr of + Just r -> return r + Nothing -> close s >> throwIO (ClientError Timeout) - -- All other exception types are thrown inside the resource-pool and so - -- cause it to destroy the connection, which is desired as we've had some - -- wire-level error occur. - handleAllErrors :: Int -> E.SomeException -> IO a - handleAllErrors 0 err = cmdError err -- XXX: Mark as failed! - handleAllErrors atmp _ = go atmp + handleErrs :: Int -> SomeException -> IO a + {-# INLINE handleErrs #-} + handleErrs 0 err = do t <- getPOSIXTime + writeIORef (failed s) t + throwIO err + handleErrs n _ = do + threadDelay cFailDelay + go n diff --git a/Database/Memcache/Errors.hs b/Database/Memcache/Errors.hs --- a/Database/Memcache/Errors.hs +++ b/Database/Memcache/Errors.hs @@ -1,12 +1,26 @@ {-# LANGUAGE DeriveDataTypeable #-} --- | Memcached related errors and exception handling. +{-| +Module : Database.Memcache.Errors +Description : Errors Handling +Copyright : (c) David Terei, 2016 +License : BSD +Maintainer : code@davidterei.com +Stability : stable +Portability : GHC + +Memcached related errors and exception handling. +-} module Database.Memcache.Errors ( + -- * Error types MemcacheError(..), - statusToError, + Status(..), + ClientError(..), + ProtocolError(..), + + -- * Error creation throwStatus, - throwIncorrectRes, - ClientError(..) + wrongOp ) where import Database.Memcache.Types @@ -14,61 +28,50 @@ import Control.Exception import Data.Typeable --- XXX: What to do about ProtocolError and IncorrectResponse exceptions? Should --- we expose these types to user or map them to ClientError? - --- | Exceptions that may be thrown by Memcache. These are expected error codes --- returned by a memcached server. +-- | All exceptions that a Memcached client may throw. data MemcacheError - = MemErrNoKey - | MemErrKeyExists - | MemErrValueTooLarge - | MemErrInvalidArgs - | MemErrStoreFailed - | MemErrValueNonNumeric - | MemErrUnknownCmd - | MemErrOutOfMemory - | MemErrAuthFail + -- | Memcached operation error. + = OpError Status + -- | Error occuring on client side. + | ClientError ClientError + -- | Errors occurring communicating with Memcached server. + | ProtocolError ProtocolError deriving (Eq, Show, Typeable) instance Exception MemcacheError --- | Convert a status to an error. Note, not all status's are errors and so --- this is a partial function! -statusToError :: Status -> MemcacheError -{-# INLINE statusToError #-} -statusToError NoError = error "statusToError: called on NoError" -statusToError ErrKeyNotFound = MemErrNoKey -statusToError ErrKeyExists = MemErrKeyExists -statusToError ErrValueTooLarge = MemErrValueTooLarge -statusToError ErrInvalidArgs = MemErrInvalidArgs -statusToError ErrItemNotStored = MemErrStoreFailed -statusToError ErrValueNonNumeric = MemErrValueNonNumeric -statusToError ErrUnknownCommand = MemErrUnknownCmd -statusToError ErrOutOfMemory = MemErrOutOfMemory -statusToError SaslAuthFail = MemErrAuthFail -statusToError SaslAuthContinue = error "statusToError: called on SaslAuthContinue" +-- | Errors that occur on the client. +data ClientError + -- | All servers are currently marked failed. + = NoServersReady + -- | Timeout occurred sending request to server. + | Timeout + deriving (Eq, Show, Typeable) --- | Convert a status to an exception. Note, not all status's are errors and so --- this is not a complete function! +-- | Errors related to Memcached protocol and bytes on the wire. +data ProtocolError + -- | Received an unknown response packet. + = UnknownPkt { protocolError :: String } + -- | Unknown Memcached operation. + | UnknownOp { protocolError :: String } + -- | Unknown Memcached status field value. + | UnknownStatus { protocolError :: String } + -- | Unexpected length of a Memcached field (extras, key, or value). + | BadLength { protocolError :: String } + -- | Response packet is for a different operation than expected. + | WrongOp { protocolError :: String } + -- | Network socket closed without receiving enough bytes. + | UnexpectedEOF { protocolError :: String } + deriving (Eq, Show, Typeable) + +-- | Convert a status to 'MemcacheError' exception. throwStatus :: Status -> IO a -{-# INLINE throwStatus #-} -throwStatus = throwIO . statusToError +throwStatus s = throwIO $ OpError s --- | Throw an IncorrectResponse exception for a wrong received response. -throwIncorrectRes :: Response -> String -> IO a -{-# INLINE throwIncorrectRes #-} -throwIncorrectRes r msg = throwIO - IncorrectResponse { - increspMessage = "Expected " ++ msg ++ " response! Got: " ++ show (resOp r), - increspActual = r +-- | Create a properly formatted 'WrongOp' protocol error. +wrongOp :: Response -> String -> MemcacheError +wrongOp r msg = ProtocolError $ + WrongOp { + protocolError = "Expected " ++ msg ++ "! Got: " ++ show (resOp r) } - --- | Errors that occur between the client and server in communicating. These --- are unexpected exceptions, such as network failures or garbage data. -data ClientError - = NotEnoughBytes - deriving (Eq, Show, Typeable) - -instance Exception ClientError diff --git a/Database/Memcache/Protocol.hs b/Database/Memcache/Protocol.hs deleted file mode 100644 --- a/Database/Memcache/Protocol.hs +++ /dev/null @@ -1,256 +0,0 @@ -{-# LANGUAGE ScopedTypeVariables #-} - --- | A raw, low level interface to the memcached protocol. --- --- The various operations are represented in full as they appear at the --- protocol level and so aren't generally well suited for application use. --- Instead, applications should use Database.Memcache.Client which presents a --- higher level API suited for application use. -module Database.Memcache.Protocol ( - get, gat, touch, - set, set', add, replace, - delete, - increment, decrement, - append, prepend, - StatResults, stats, - flush, - noop, version, quit - ) where - -import Database.Memcache.Errors -import Database.Memcache.Server -import Database.Memcache.Types -import Database.Memcache.Wire - -import qualified Control.Exception as E -import Control.Monad -import Data.ByteString (ByteString) -import qualified Data.ByteString as B -import Data.Word -import qualified Network.Socket as N - --- XXX: Structure Vs. Args? --- i.e., --- replace :: Server -> Key -> Value -> Flags -> Expiration -> Version -> IO (Maybe Version) --- vs. --- replace :: Server -> Request -> IO (Maybe Version) --- --- Request --- { key :: Key --- , value :: Value --- , flags :: Flags --- , exp :: Expiration --- , ver :: Version --- } --- --- Using a structure would allow easy defaults... --- - -get :: Server -> Key -> IO (Maybe (Value, Flags, Version)) -get c k = do - let msg = emptyReq { reqOp = ReqGet Loud NoKey k } - r <- sendRecv c msg - (v, f) <- case resOp r of - ResGet Loud v f -> return (v, f) - _ -> throwIncorrectRes r "GET" - case resStatus r of - NoError -> return $ Just (v, f, resCas r) - ErrKeyNotFound -> return Nothing - rs -> throwStatus rs - -gat :: Server -> Key -> Expiration -> IO (Maybe (Value, Flags, Version)) -gat c k e = do - let msg = emptyReq { reqOp = ReqGAT Loud NoKey k (SETouch e) } - r <- sendRecv c msg - (v, f) <- case resOp r of - ResGAT Loud v f -> return (v, f) - _ -> throwIncorrectRes r "GAT" - case resStatus r of - NoError -> return $ Just (v, f, resCas r) - ErrKeyNotFound -> return Nothing - rs -> throwStatus rs - -touch :: Server -> Key -> Expiration -> IO (Maybe Version) -touch c k e = do - let msg = emptyReq { reqOp = ReqTouch k (SETouch e) } - r <- sendRecv c msg - when (resOp r /= ResTouch) $ throwIncorrectRes r "TOUCH" - case resStatus r of - NoError -> return $ Just (resCas r) - ErrKeyNotFound -> return Nothing - rs -> throwStatus rs - -set :: Server -> 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 <- sendRecv c msg - when (resOp r /= ResSet Loud) $ throwIncorrectRes r "SET" - case resStatus r of - NoError -> return $ resCas r - rs -> throwStatus rs - --- XXX: Use a return type like: Return = OK Version | NotFound | NotVersion? -set' :: Server -> Key -> Value -> Flags -> Expiration -> Version -> IO (Maybe Version) -set' c k v f e ver = do - let msg = emptyReq { reqOp = ReqSet Loud k v (SESet f e), reqCas = ver } - r <- sendRecv c msg - when (resOp r /= ResSet Loud) $ throwIncorrectRes r "SET" - case resStatus r of - NoError -> return $ Just (resCas r) - -- version specified and key doesn't exist... - ErrKeyNotFound -> return Nothing - -- version specified and doesn't match key... - ErrKeyExists -> return Nothing - rs -> throwStatus rs - -add :: Server -> 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 <- sendRecv c msg - when (resOp r /= ResAdd Loud) $ throwIncorrectRes r "ADD" - case resStatus r of - NoError -> return $ Just (resCas r) - ErrKeyExists -> return Nothing - rs -> throwStatus rs - -replace :: Server -> 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 <- sendRecv c msg - when (resOp r /= ResReplace Loud) $ throwIncorrectRes r "REPLACE" - case resStatus r of - NoError -> return $ Just (resCas r) - -- replace only applies to an existing key... - ErrKeyNotFound -> return Nothing - -- version specified and doesn't match key... - ErrKeyExists -> return Nothing - rs -> throwStatus rs - -delete :: Server -> Key -> Version -> IO Bool -delete c k ver = do - let msg = emptyReq { reqOp = ReqDelete Loud k, reqCas = ver } - r <- sendRecv c msg - when (resOp r /= ResDelete Loud) $ throwIncorrectRes r "DELETE" - case resStatus r of - NoError -> return True - -- delete only applies to an existing key... - ErrKeyNotFound -> return False - -- version specified and doesn't match key... - ErrKeyExists -> return False - rs -> throwStatus rs - -increment :: Server -> 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 <- sendRecv c msg - n <- case resOp r of - ResIncrement Loud n -> return n - _ -> throwIncorrectRes r "INCREMENT" - case resStatus r of - NoError -> return $ Just (n, resCas r) - ErrKeyNotFound -> return Nothing - ErrKeyExists -> return Nothing - rs -> throwStatus rs - -decrement :: Server -> 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 <- sendRecv c msg - n <- case resOp r of - ResDecrement Loud n -> return n - _ -> throwIncorrectRes r "DECREMENT" - case resStatus r of - NoError -> return $ Just (n, resCas r) - ErrKeyNotFound -> return Nothing - ErrKeyExists -> return Nothing - rs -> throwStatus rs - -append :: Server -> Key -> Value -> Version -> IO (Maybe Version) -append c k v ver = do - let msg = emptyReq { reqOp = ReqAppend Loud k v, reqCas = ver } - r <- sendRecv c msg - when (resOp r /= ResAppend Loud) $ throwIncorrectRes r "APPEND" - case resStatus r of - NoError -> return $ Just (resCas r) - ErrKeyNotFound -> return Nothing - rs -> throwStatus rs - -prepend :: Server -> Key -> Value -> Version -> IO (Maybe Version) -prepend c k v ver = do - let msg = emptyReq { reqOp = ReqPrepend Loud k v, reqCas = ver } - r <- sendRecv c msg - when (resOp r /= ResPrepend Loud) $ throwIncorrectRes r "PREPEND" - case resStatus r of - NoError -> return $ Just (resCas r) - ErrKeyNotFound -> return Nothing - rs -> throwStatus rs - -flush :: Server -> Maybe Expiration -> IO () -flush c e = do - let e' = SETouch `fmap` e - msg = emptyReq { reqOp = ReqFlush Loud e' } - r <- sendRecv c msg - when (resOp r /= ResFlush Loud) $ throwIncorrectRes r "FLUSH" - case resStatus r of - NoError -> return () - rs -> throwStatus rs - -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 - -version :: Server -> IO ByteString -version c = do - let msg = emptyReq { reqOp = ReqVersion } - r <- sendRecv c msg - v <- case resOp r of - ResVersion v -> return v - _ -> throwIncorrectRes r "VERSION" - case resStatus r of - NoError -> return v - rs -> throwStatus rs - --- | StatResults are a list of key-value pairs. -type StatResults = [(ByteString, ByteString)] - --- XXX: Should this be Maybe? Does wrong key return error or just empty --- results? -stats :: Server -> Maybe Key -> IO (Maybe StatResults) -stats c key = withSocket c $ \s -> do - let msg = emptyReq { reqOp = ReqStat key } - send s msg - getAllStats s [] - where - getAllStats s xs = do - r <- recv s - (k, v) <- case resOp r of - ResStat k v -> return (k, v) - _ -> throwIncorrectRes r "STATS" - case resStatus r of - NoError | B.null k && B.null v -> return $ Just xs - | otherwise -> getAllStats s $ (k, v):xs - ErrKeyNotFound -> return Nothing - rs -> throwStatus rs - -quit :: Server -> IO () -quit c = do - -- TODO: not clear if waiting for a reply matters - withSocket c $ \s -> sendClose s `E.catch` consumeError - close c - where - consumeError (_ ::E.SomeException) = return () - sendClose s = do - let msg = emptyReq { reqOp = ReqQuit Loud } - send s msg - N.shutdown s N.ShutdownSend - r <- recv s - when (resOp r /= ResQuit Loud) $ throwIncorrectRes r "QUIT" - case resStatus r of - NoError -> return () - rs -> throwStatus rs - diff --git a/Database/Memcache/SASL.hs b/Database/Memcache/SASL.hs --- a/Database/Memcache/SASL.hs +++ b/Database/Memcache/SASL.hs @@ -1,53 +1,69 @@ {-# OPTIONS_GHC -fno-warn-unused-binds #-} --- | SASL authentication support for memcache. +{-| +Module : Database.Memcache.SASL +Description : SASL Authentication +Copyright : (c) David Terei, 2016 +License : BSD +Maintainer : code@davidterei.com +Stability : stable +Portability : GHC + +SASL authentication support for Memcached. +-} module Database.Memcache.SASL ( - authenticate, Authentication(..), Username, Password + -- * Types + Authentication(..), Username, Password, + + -- * Operations + authenticate ) where import Database.Memcache.Errors +import Database.Memcache.Socket import Database.Memcache.Types -import Database.Memcache.Wire -import qualified Control.Exception as E (onException) +import Control.Exception (throwIO) import Control.Monad import Data.ByteString.Char8 as B8 (ByteString, pack, singleton) import Data.Monoid -import Network.Socket (Socket) -- | Perform SASL authentication with the server. authenticate :: Socket -> Authentication -> IO () +{-# INLINE authenticate #-} +authenticate _ NoAuth = return () +authenticate s (Auth u p) = saslAuthPlain s u p -- NOTE: For correctness really should check that PLAIN auth is supported first -- but we'll just assume it is as that's all mainline and other implementations -- support and one exception is nearly as good as another. -authenticate _ NoAuth = return () -authenticate s (Auth u p) = saslAuthPlain s u p - -- | Perform SASL PLAIN authentication. saslAuthPlain :: Socket -> Username -> Password -> IO () +{-# INLINE saslAuthPlain #-} saslAuthPlain s u p = do let credentials = singleton '\0' <> u <> singleton '\0' <> p msg = emptyReq { reqOp = ReqSASLStart (B8.pack "PLAIN") credentials } send s msg - r <- recv s `E.onException` throwStatus SaslAuthFail - when (resOp r /= ResSASLStart) $ throwIncorrectRes r "SASL_START" + r <- recv s + when (resOp r /= ResSASLStart) $ + throwIO $ wrongOp r "SASL_START" case resStatus r of NoError -> return () - rs -> throwStatus rs + rs -> throwIO $ OpError rs -- | List available SASL authentication methods. We could call this but as we --- only support PLAIN as does the memcached server, we simply assume PLAIN +-- only support PLAIN as does the Memcached server, we simply assume PLAIN -- authentication is supprted and try that. saslListMechs :: Socket -> IO B8.ByteString +{-# INLINE saslListMechs #-} saslListMechs s = do let msg = emptyReq { reqOp = ReqSASLList } send s msg r <- recv s v <- case resOp r of ResSASLList v -> return v - _ -> throwIncorrectRes r "SASL_LIST" + _ -> throwIO $ wrongOp r "SASL_LIST" case resStatus r of - NoError -> return v - rs -> throwStatus rs + NoError -> return v + rs -> throwIO $ OpError rs diff --git a/Database/Memcache/Server.hs b/Database/Memcache/Server.hs --- a/Database/Memcache/Server.hs +++ b/Database/Memcache/Server.hs @@ -1,19 +1,38 @@ --- | Handles the connections between a memcached client and a single server. +{-# LANGUAGE RecordWildCards #-} + +{-| +Module : Database.Memcache.Server +Description : Server Handling +Copyright : (c) David Terei, 2016 +License : BSD +Maintainer : code@davidterei.com +Stability : stable +Portability : GHC + +Handles the connections between a Memcached client and a single server. + +Memcached expected errors (part of protocol) are returned in the Response, +unexpected errors (e.g., network failure) are thrown as exceptions. While +the Server datatype supports a `failed` and `failedAt` flag for managing +retries, it's up to consumers to use this. +-} module Database.Memcache.Server ( - Server(sid), newServer, sendRecv, withSocket, close + -- * Server + Server(sid, failed), newServer, sendRecv, withSocket, close ) where import Database.Memcache.SASL -import Database.Memcache.Types -import Database.Memcache.Wire +import Database.Memcache.Socket import Control.Exception import Data.Hashable +import Data.IORef import Data.Pool import Data.Time.Clock (NominalDiffTime) +import Data.Time.Clock.POSIX (POSIXTime) import Network.BSD (getProtocolNumber, getHostByName, hostAddress) -import Network.Socket (HostName, PortNumber(..), Socket) +import Network.Socket (HostName, PortNumber(..)) import qualified Network.Socket as S -- Connection pool constants. @@ -24,40 +43,51 @@ sCONNECTIONS = 1 sKEEPALIVE = 300 --- | A memcached server connection. +-- | Memcached server connection. data Server = Server { - sid :: {-# UNPACK #-} !Int, - pool :: Pool Socket, - _addr :: !HostName, - _port :: !PortNumber, - _auth :: !Authentication, - failed :: !Bool + -- | ID of server for consistent hashing. + sid :: {-# UNPACK #-} !Int, + -- | Connection pool to server. + pool :: Pool Socket, + -- | Hostname of server. + addr :: !HostName, + -- | Port number of server. + port :: !PortNumber, + -- | Credentials for server. + auth :: !Authentication, + -- | When did the server fail? 0 if it is alive. + failed :: IORef POSIXTime -- TODO: -- weight :: Double -- tansport :: Transport (UDP vs. TCP) -- poolLim :: Int (pooled connection limit) -- cnxnBuf :: IORef ByteString - } deriving Show + } +instance Show Server where + show Server{..} = + "Server [" ++ show sid ++ "] " ++ addr ++ ":" ++ show port + instance Eq Server where (==) x y = sid x == sid y instance Ord Server where compare x y = compare (sid x) (sid y) --- | Create a new memcached connection. +-- | Create a new Memcached server connection. newServer :: HostName -> PortNumber -> Authentication -> IO Server newServer host port auth = do + fat <- newIORef 0 pSock <- createPool connectSocket releaseSocket sSTRIPES sKEEPALIVE sCONNECTIONS return Server - { sid = serverHash - , pool = pSock - , _addr = host - , _port = port - , _auth = auth - , failed = False + { sid = serverHash + , pool = pSock + , addr = host + , port = port + , auth = auth + , failed = fat } where serverHash = hash (host, fromEnum port) @@ -78,19 +108,22 @@ releaseSocket = S.close --- | Send and receive a single request/response pair to the memcached server. +-- | Send and receive a single request/response pair to the Memcached server. sendRecv :: Server -> Request -> IO Response -sendRecv svr msg = withResource (pool svr) $ \s -> do +{-# INLINE sendRecv #-} +sendRecv svr msg = withSocket svr $ \s -> do send s msg recv s -- | Run a function with access to an server socket for using 'send' and -- 'recv'. withSocket :: Server -> (Socket -> IO a) -> IO a +{-# INLINE withSocket #-} withSocket svr = withResource $ pool svr -- | Close the server connection. If you perform another operation after this, -- the connection will be re-established. close :: Server -> IO () +{-# INLINE close #-} close srv = destroyAllResources $ pool srv diff --git a/Database/Memcache/Socket.hs b/Database/Memcache/Socket.hs new file mode 100644 --- /dev/null +++ b/Database/Memcache/Socket.hs @@ -0,0 +1,423 @@ +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE CPP #-} + +{-| +Module : Database.Memcache.Socket +Description : Connection Handling +Copyright : (c) David Terei, 2016 +License : BSD +Maintainer : code@davidterei.com +Stability : stable +Portability : GHC + +Handles a single Memcached connection, sending and receiving requests. +-} +module Database.Memcache.Socket ( + -- * Types + Socket, Request(..), Response(..), + + -- * Operations + send, recv, + + -- * Serialization / Deserialization + szRequest, szResponse, dzHeader, dzResponse + ) where + +-- FIXME: Wire works with lazy bytestrings but we receive strict bytestrings +-- from the network... + +import Database.Memcache.Errors +import Database.Memcache.Types + +import Blaze.ByteString.Builder +#if __GLASGOW_HASKELL__ < 710 +import Control.Applicative +#endif +import Control.Exception (throw, throwIO) +import Control.Monad +import Data.Binary.Get +import qualified Data.ByteString as B +import qualified Data.ByteString.Lazy as L +import Data.Monoid +import Data.Word +import Network.Socket (Socket, isConnected, isReadable) +import qualified Network.Socket.ByteString as N + +-- | Send a request to the Memcached server. +send :: Socket -> Request -> IO () +{-# INLINE send #-} +send s m = N.sendAll s (toByteString $ szRequest m) + +-- | Retrieve a single response from the Memcached server. +-- FIXME: read into buffer to minimize read syscalls +recv :: Socket -> IO Response +{-# INLINE recv #-} +recv s = do + header <- recvAll mEMCACHE_HEADER_SIZE mempty + let h = runGet (dzHeader PktResponse) (L.fromChunks [header]) + if bodyLen h > 0 + then do + let bytesToRead = fromIntegral $ bodyLen h + body <- recvAll bytesToRead mempty + return $ dzResponse h (L.fromChunks [body]) + else return $ dzResponse h L.empty + where + recvAll :: Int -> Builder -> IO B.ByteString + recvAll 0 !acc = return $! toByteString acc + recvAll !n !acc = do + canRead <- isSocketActive s + if canRead + then do + buf <- N.recv s n + case B.length buf of + 0 -> throwIO errEOF + bl | bl == n -> + return $! (toByteString $! acc <> fromByteString buf) + bl -> recvAll (n - bl) (acc <> fromByteString buf) + else throwIO errEOF + + errEOF :: MemcacheError + errEOF = ProtocolError UnexpectedEOF { protocolError = "" } + +-- | Check whether we can still operate on this socket or not. +isSocketActive :: Socket -> IO Bool +{-# INLINE isSocketActive #-} +isSocketActive s = (&&) <$> isConnected s <*> isReadable s + +-- | Serialize a response to a ByteString Builder. +szResponse :: Response -> Builder +szResponse res = + fromWord8 0x81 + <> fromWord8 c + <> fromWord16be (fromIntegral keyl) + <> fromWord8 (fromIntegral extl) + <> fromWord8 0 + <> fromWord16be 0 + <> fromWord32be (fromIntegral $ extl + keyl + vall) + <> fromWord32be (resOpaque res) + <> fromWord64be (resCas res) + <> ext' + <> key' + <> val' + where + (c, k', v', ext', extl) = szOpResponse (resOp res) + (keyl, key') = case k' of + Just k -> (B.length k, fromByteString k) + Nothing -> (0, mempty) + (vall, val') = case v' of + Just v -> (B.length v, fromByteString v) + Nothing -> (0, mempty) + +szOpResponse :: OpResponse -> (Word8, Maybe Key, Maybe Value, Builder, Int) +szOpResponse o = case o of + ResGet Loud v f -> (0x00, Nothing, Just v, fromWord32be f, 4) + ResGet Quiet v f -> (0x09, Nothing, Just v, fromWord32be f, 4) + ResGetK Loud k v f -> (0x0C, Just k, Just v, fromWord32be f, 4) + ResGetK Quiet k v f -> (0x0D, Just k, Just v, fromWord32be f, 4) + ResSet Loud -> (0x01, Nothing, Nothing, mempty, 0) + ResSet Quiet -> (0x11, Nothing, Nothing, mempty, 0) + ResAdd Loud -> (0x02, Nothing, Nothing, mempty, 0) + ResAdd Quiet -> (0x12, Nothing, Nothing, mempty, 0) + ResReplace Loud -> (0x03, Nothing, Nothing, mempty, 0) + ResReplace Quiet -> (0x13, Nothing, Nothing, mempty, 0) + ResDelete Loud -> (0x04, Nothing, Nothing, mempty, 0) + ResDelete Quiet -> (0x14, Nothing, Nothing, mempty, 0) + ResIncrement Loud f -> (0x05, Nothing, Nothing, fromWord64be f, 8) + ResIncrement Quiet f -> (0x15, Nothing, Nothing, fromWord64be f, 8) + ResDecrement Loud f -> (0x06, Nothing, Nothing, fromWord64be f, 8) + ResDecrement Quiet f -> (0x16, Nothing, Nothing, fromWord64be f, 8) + ResAppend Loud -> (0x0E, Nothing, Nothing, mempty, 0) + ResAppend Quiet -> (0x19, Nothing, Nothing, mempty, 0) + ResPrepend Loud -> (0x0F, Nothing, Nothing, mempty, 0) + ResPrepend Quiet -> (0x1A, Nothing, Nothing, mempty, 0) + ResTouch -> (0x1C, Nothing, Nothing, mempty, 0) + ResGAT Loud v f -> (0x1D, Nothing, Just v, fromWord32be f, 4) + ResGAT Quiet v f -> (0x1E, Nothing, Just v, fromWord32be f, 4) + ResGATK Loud k v f -> (0x23, Just k, Just v, fromWord32be f, 4) + ResGATK Quiet k v f -> (0x24, Just k, Just v, fromWord32be f, 4) + ResFlush Loud -> (0x08, Nothing, Nothing, mempty, 0) + ResFlush Quiet -> (0x18, Nothing, Nothing, mempty, 0) + ResNoop -> (0x0A, Nothing, Nothing, mempty, 0) + ResVersion v -> (0x0B, Nothing, Just v, mempty, 0) + ResStat k v -> (0x10, Just k, Just v, mempty, 0) + ResQuit Loud -> (0x07, Nothing, Nothing, mempty, 0) + ResQuit Quiet -> (0x17, Nothing, Nothing, mempty, 0) + ResSASLList v -> (0x20, Nothing, Just v, mempty, 0) + ResSASLStart -> (0x21, Nothing, Nothing, mempty, 0) + ResSASLStep -> (0x22, Nothing, Nothing, mempty, 0) + +-- | Serialize a request to a ByteString Builder. +szRequest :: Request -> Builder +szRequest req = + fromWord8 0x80 + <> fromWord8 c + <> fromWord16be (fromIntegral keyl) + <> fromWord8 (fromIntegral extl) + <> fromWord8 0 + <> fromWord16be 0 + <> fromWord32be (fromIntegral $ extl + keyl + vall) + <> fromWord32be (reqOpaque req) + <> fromWord64be (reqCas req) + <> ext' + <> key' + <> val' + where + (c, k', v', ext', extl) = szOpRequest (reqOp req) + (keyl, key') = case k' of + Just k -> (B.length k, fromByteString k) + Nothing -> (0, mempty) + (vall, val') = case v' of + Just v -> (B.length v, fromByteString v) + Nothing -> (0, mempty) + +-- Extract needed info from an OpRequest for serialization. +-- FIXME: Make sure this is optimized well (no tuple, boxing, unboxing, inlined) +szOpRequest :: OpRequest -> (Word8, Maybe Key, Maybe Value, Builder, Int) +szOpRequest o = case o of + -- FIXME: make sure this isn't a thunk! (c) + ReqGet q k key -> let c | q == Loud && k == NoKey = 0x00 + | q == Loud && k == IncludeKey = 0x0C + | k == NoKey = 0x09 -- Quiet + | otherwise = 0x0D -- Quiet && IncludeKey + in (c, Just key, Nothing, mempty, 0) + + ReqSet Loud key v e -> (0x01, Just key, Just v, szSESet e, 8) + ReqSet Quiet key v e -> (0x11, Just key, Just v, szSESet e, 8) + ReqAdd Loud key v e -> (0x02, Just key, Just v, szSESet e, 8) + ReqAdd Quiet key v e -> (0x12, Just key, Just v, szSESet e, 8) + ReqReplace Loud key v e -> (0x03, Just key, Just v, szSESet e, 8) + ReqReplace Quiet key v e -> (0x13, Just key, Just v, szSESet e, 8) + ReqDelete Loud key -> (0x04, Just key, Nothing, mempty, 0) + ReqDelete Quiet key -> (0x14, Just key, Nothing, mempty, 0) + ReqIncrement Loud key e -> (0x05, Just key, Nothing, szSEIncr e, 20) + ReqIncrement Quiet key e -> (0x15, Just key, Nothing, szSEIncr e, 20) + ReqDecrement Loud key e -> (0x06, Just key, Nothing, szSEIncr e, 20) + ReqDecrement Quiet key e -> (0x16, Just key, Nothing, szSEIncr e, 20) + ReqAppend Loud key v -> (0x0E, Just key, Just v, mempty, 0) + ReqAppend Quiet key v -> (0x19, Just key, Just v, mempty, 0) + ReqPrepend Loud key v -> (0x0F, Just key, Just v, mempty, 0) + ReqPrepend Quiet key v -> (0x1A, Just key, Just v, mempty, 0) + ReqTouch key e -> (0x1C, Just key, Nothing, szSETouch e, 4) + -- FIXME: beware allocation. + ReqGAT q k key e -> let c | q == Quiet && k == IncludeKey = 0x24 + | q == Quiet && k == NoKey = 0x1E + | k == IncludeKey = 0x23 + | otherwise = 0x1D + in (c, Just key, Nothing, szSETouch e, 4) + ReqFlush Loud (Just e) -> (0x08, Nothing, Nothing, szSETouch e, 4) + ReqFlush Quiet (Just e) -> (0x18, Nothing, Nothing, szSETouch e, 4) + ReqFlush Loud Nothing -> (0x08, Nothing, Nothing, mempty, 0) + ReqFlush Quiet Nothing -> (0x18, Nothing, Nothing, mempty, 0) + ReqNoop -> (0x0A, Nothing, Nothing, mempty, 0) + ReqVersion -> (0x0B, Nothing, Nothing, mempty, 0) + ReqStat key -> (0x10, key, Nothing, mempty, 0) + ReqQuit Loud -> (0x07, Nothing, Nothing, mempty, 0) + ReqQuit Quiet -> (0x17, Nothing, Nothing, mempty, 0) + ReqSASLList -> (0x20, Nothing, Nothing, mempty, 0) + ReqSASLStart key v -> (0x21, Just key, Just v, mempty, 0) + ReqSASLStep key v -> (0x22, Just key, Just v, mempty, 0) + + where + szSESet (SESet f e) = fromWord32be f <> fromWord32be e + szSEIncr (SEIncr i d e) = fromWord64be i <> fromWord64be d <> fromWord32be e + szSETouch (SETouch e) = fromWord32be e + +-- | Deserialize a Header from a ByteString. +dzHeader :: PktType -> Get Header +{-# INLINE dzHeader #-} +dzHeader pkt = do + m <- getWord8 + case pkt of + PktResponse -> when (m /= 0x81) $ + throw $ ProtocolError UnknownPkt { protocolError = show m } + PktRequest -> when (m /= 0x80) $ + throw $ ProtocolError UnknownPkt { protocolError = show m } + o <- getWord8 + kl <- getWord16be + el <- getWord8 + skip 1 -- unused data type field + st <- dzStatus + bl <- getWord32be + opq <- getWord32be + ver <- getWord64be + return Header { + op = o, + keyLen = kl, + extraLen = el, + status = st, + bodyLen = bl, + opaque = opq, + cas = ver + } + +-- | Deserialize a Response body. +dzResponse :: Header -> L.ByteString -> Response +dzResponse h = runGet $ + case op h of + 0x00 -> dzGetResponse h $ ResGet Loud + 0x09 -> dzGetResponse h $ ResGet Quiet + 0x1D -> dzGetResponse h $ ResGAT Loud + 0x1E -> dzGetResponse h $ ResGAT Quiet + 0x0C -> dzGetKResponse h $ ResGetK Loud + 0x0D -> dzGetKResponse h $ ResGetK Quiet + 0x23 -> dzGetKResponse h $ ResGATK Loud + 0x24 -> dzGetKResponse h $ ResGATK Quiet + 0x05 -> dzNumericResponse h $ ResIncrement Loud + 0x15 -> dzNumericResponse h $ ResIncrement Quiet + 0x06 -> dzNumericResponse h $ ResDecrement Loud + 0x16 -> dzNumericResponse h $ ResDecrement Quiet + 0x01 -> dzGenericResponse h $ ResSet Loud + 0x11 -> dzGenericResponse h $ ResSet Quiet + 0x02 -> dzGenericResponse h $ ResAdd Loud + 0x12 -> dzGenericResponse h $ ResAdd Quiet + 0x03 -> dzGenericResponse h $ ResReplace Loud + 0x13 -> dzGenericResponse h $ ResReplace Quiet + 0x04 -> dzGenericResponse h $ ResDelete Loud + 0x14 -> dzGenericResponse h $ ResDelete Quiet + 0x0E -> dzGenericResponse h $ ResAppend Loud + 0x19 -> dzGenericResponse h $ ResAppend Quiet + 0x0F -> dzGenericResponse h $ ResPrepend Loud + 0x1A -> dzGenericResponse h $ ResPrepend Quiet + 0x1C -> dzGenericResponse h ResTouch + 0x07 -> dzGenericResponse h $ ResQuit Loud + 0x17 -> dzGenericResponse h $ ResQuit Quiet + 0x08 -> dzGenericResponse h $ ResFlush Loud + 0x18 -> dzGenericResponse h $ ResFlush Quiet + 0x0A -> dzGenericResponse h ResNoop + 0x10 -> dzKeyValueResponse h ResStat + 0x0B -> dzValueResponse h ResVersion + -- SASL + 0x20 -> dzValueResponse h ResSASLList + 0x21 -> dzGenericResponse h ResSASLStart + 0x22 -> dzGenericResponse h ResSASLStep + + _ -> throw $ ProtocolError UnknownOp { protocolError = show (op h) } + +-- | Deserialize the body of a Response that contains nothing. +dzGenericResponse :: Header -> OpResponse -> Get Response +dzGenericResponse h o = do + skip (fromIntegral $ bodyLen h) + chkLength 0 (extraLen h) "Extra" + chkLength 0 (keyLen h) "Key" + chkLength 0 (bodyLen h) "Body" + return Res { + resOp = o, + resStatus = status h, + resOpaque = opaque h, + resCas = cas h + } + +-- | Deserialize the body of a Get Response (Extras [flags] & Value). +dzGetResponse :: Header -> (Value -> Flags -> OpResponse) -> Get Response +dzGetResponse h o = do + e <- if status h == NoError && el == 4 + then getWord32be + else skip el >> return 0 + v <- getByteString vl + chkLength 4 el "Extra" + chkLength 0 (keyLen h) "Key" + return Res { + resOp = o v e, + resStatus = status h, + resOpaque = opaque h, + resCas = cas h + } + where + el = fromIntegral $ extraLen h + vl = fromIntegral (bodyLen h) - el + +-- | Deserialize the body of a GetK Response (Extras [flags] & Key & Value). +dzGetKResponse :: Header -> (Key -> Value -> Flags -> OpResponse) -> Get Response +dzGetKResponse h o = do + e <- if status h == NoError && el == 4 + then getWord32be + else skip el >> return 0 + k <- getByteString kl + v <- getByteString vl + chkLength 4 el "Extra" + -- FIXME: check strictness ($!) + return Res { + resOp = o k v e, + resStatus = status h, + resOpaque = opaque h, + resCas = cas h + } + where + el = fromIntegral $ extraLen h + kl = fromIntegral $ keyLen h + vl = fromIntegral (bodyLen h) - el - kl + +-- | Deserialize the body of a Incr/Decr Response (Value [Word64]). +dzNumericResponse :: Header -> (Word64 -> OpResponse) -> Get Response +dzNumericResponse h o = do + v <- if status h == NoError && bodyLen h == 8 + then getWord64be + else skip (fromIntegral $ bodyLen h) >> return 0 + chkLength 0 (extraLen h) "Extra" + chkLength 0 (keyLen h) "Key" + chkLength 8 (bodyLen h) "Body" + return Res { + resOp = o v, + resStatus = status h, + resOpaque = opaque h, + resCas = cas h + } + +-- | Deserialize the body of a general response that just has a value (no key +-- or extras). +dzValueResponse :: Header -> (Value -> OpResponse) -> Get Response +dzValueResponse h o = do + v <- getByteString (fromIntegral $ bodyLen h) + chkLength 0 (extraLen h) "Extra" + chkLength 0 (keyLen h) "Key" + return Res { + resOp = o v, + resStatus = status h, + resOpaque = opaque h, + resCas = cas h + } + +-- | Deserialize the body of a general response that just has a key and value +-- (no extras). +dzKeyValueResponse :: Header -> (Key -> Value -> OpResponse) -> Get Response +dzKeyValueResponse h o = do + k <- getByteString kl + v <- getByteString vl + chkLength 0 (extraLen h) "Extra" + return Res { + resOp = o k v, + resStatus = status h, + resOpaque = opaque h, + resCas = cas h + } + where + kl = fromIntegral $ keyLen h + vl = fromIntegral (bodyLen h) - kl + +-- | Deserialize a Response status code. +dzStatus :: Get Status +dzStatus = do + st <- getWord16be + return $ case st of + 0x00 -> NoError + 0x01 -> ErrKeyNotFound + 0x02 -> ErrKeyExists + 0x03 -> ErrValueTooLarge + 0x04 -> ErrInvalidArgs + 0x05 -> ErrItemNotStored + 0x06 -> ErrValueNonNumeric + 0x81 -> ErrUnknownCommand + 0x82 -> ErrOutOfMemory + 0x20 -> SaslAuthFail + 0x21 -> SaslAuthContinue + _ -> throw $ ProtocolError UnknownStatus { protocolError = show st } + +-- | Check the length of a header field is as expected, throwing a +-- ProtocolError exception if it is not. +chkLength :: (Eq a, Show a) => a -> a -> String -> Get () +{-# INLINE chkLength #-} +chkLength expected l msg = when (l /= expected) $ + return $ throw $ ProtocolError BadLength { protocolError = + msg ++ " length expected " ++ show expected ++ " got " ++ show l + } + diff --git a/Database/Memcache/Types.hs b/Database/Memcache/Types.hs --- a/Database/Memcache/Types.hs +++ b/Database/Memcache/Types.hs @@ -1,26 +1,41 @@ -{-# LANGUAGE DeriveDataTypeable #-} +{-| +Module : Database.Memcache.Types +Description : Memcached Types +Copyright : (c) David Terei, 2016 +License : BSD +Maintainer : code@davidterei.com +Stability : stable +Portability : GHC --- | Stores the various types needed by memcache. Mostly concerned with the --- representation of the protocol. +Stores the various types needed by Memcached. Mostly concerned with the +representation of the protocol. +-} module Database.Memcache.Types ( + -- * SASL Authentication Authentication(..), Username, Password, - Q(..), K(..), Key, Value, Extras, Initial, Delta, Expiration, Flags, Version, - mEMCACHE_HEADER_SIZE, Header(..), + + -- * Fields & Values + Q(..), K(..), Key, Value, Extras, Initial, Delta, Expiration, Flags, + Version, Status(..), + + -- * Header + Header(..), mEMCACHE_HEADER_SIZE, PktType(..), + + -- * Requests Request(..), OpRequest(..), SESet(..), SEIncr(..), SETouch(..), emptyReq, - Response(..), OpResponse(..), Status(..), - ProtocolError(..), IncorrectResponse(..) + + -- * Responses + Response(..), OpResponse(..), emptyRes ) where -import Control.Exception import Data.ByteString (ByteString) -import Data.Typeable import Data.Word -- | SASL Authentication information for a server. data Authentication = Auth { username :: !Username, password :: !Password } | NoAuth - deriving (Show, Eq) + deriving (Eq, Show) -- | Username for authentication. type Username = ByteString @@ -49,8 +64,22 @@ mEMCACHE_HEADER_SIZE :: Int mEMCACHE_HEADER_SIZE = 24 -data Q = Loud | Quiet deriving (Eq, Show, Typeable) -data K = NoKey | IncludeKey deriving (Eq, Show, Typeable) +-- | Memcached packet header (for both 'Request' and 'Response'). +data Header = Header { + op :: Word8, + keyLen :: Word16, + extraLen :: Word8, + status :: Status, + bodyLen :: Word32, + opaque :: Word32, + cas :: Version + } deriving (Eq, Show) + +data PktType = PktRequest | PktResponse + deriving (Eq, Show) + +data Q = Loud | Quiet deriving (Eq, Show) +data K = NoKey | IncludeKey deriving (Eq, Show) type Key = ByteString type Value = ByteString type Extras = ByteString @@ -60,7 +89,6 @@ type Flags = Word32 type Version = Word64 --- XXX: Which ones care about version? (Encode?) data OpRequest = ReqGet Q K Key | ReqSet Q Key Value SESet @@ -81,18 +109,19 @@ | ReqSASLList | ReqSASLStart Key Value -- key: auth method, value: auth data | ReqSASLStep Key Value -- key: auth method, value: auth data (continued) - deriving (Eq, Show, Typeable) + deriving (Eq, Show) -data SESet = SESet Flags Expiration deriving (Eq, Show, Typeable) -data SEIncr = SEIncr Initial Delta Expiration deriving (Eq, Show, Typeable) -data SETouch = SETouch Expiration deriving (Eq, Show, Typeable) +data SESet = SESet Flags Expiration deriving (Eq, Show) +data SEIncr = SEIncr Initial Delta Expiration deriving (Eq, Show) +data SETouch = SETouch Expiration deriving (Eq, Show) data Request = Req { reqOp :: OpRequest, reqOpaque :: Word32, reqCas :: Version - } deriving (Eq, Show, Typeable) + } deriving (Eq, Show) +-- | Noop request. emptyReq :: Request emptyReq = Req { reqOp = ReqNoop, reqOpaque = 0, reqCas = 0 } @@ -115,54 +144,47 @@ | ResVersion Value | ResStat Key Value | ResQuit Q - | ResSASLList Value + | ResSASLList Value | ResSASLStart | ResSASLStep - deriving (Eq, Show, Typeable) + deriving (Eq, Show) +-- | The status (success or error) of a Memcached operation returned in a +-- 'Response'. data Status + -- | Operation successful. = NoError -- All + -- | Key not found. | ErrKeyNotFound -- Get, GAT, Touch, Replace, Del, Inc, Dec, App, Pre, Set (key not there and version specified...) + -- | Key exists when not expected. | ErrKeyExists -- Add, (version): Set, Rep, Del, Inc, Dec, App, Pre + -- | Value too large to store at server. | ErrValueTooLarge -- Set, Add, Rep, Pre, App + -- | Invalid arguments for operation. | ErrInvalidArgs -- All + -- | Key-Value pair not stored at server (internal error). | ErrItemNotStored -- ? + -- | Value not numeric when increment or decrement requested. | ErrValueNonNumeric -- Incr, Decr + -- | Server doesn't know requested command. | ErrUnknownCommand -- All + -- | Server out of memory. | ErrOutOfMemory -- All + -- | SASL authentication failed. | SaslAuthFail -- SASL + -- | SASL authentication requires more steps. | SaslAuthContinue -- SASL - deriving (Eq, Show, Typeable) + deriving (Eq, Show) +-- | Memcached response packet. data Response = Res { resOp :: OpResponse, resStatus :: Status, resOpaque :: Word32, resCas :: Version - } deriving (Eq, Show, Typeable) - -data Header = Header { - op :: Word8, - keyLen :: Word16, - extraLen :: Word8, - status :: Status, - bodyLen :: Word32, - opaque :: Word32, - cas :: Version - } deriving (Eq, Show, Typeable) - -data ProtocolError = ProtocolError { - protocolMessage :: String, - protocolHeader :: Maybe Header, - protocolParams :: [String] - } deriving (Eq, Show, Typeable) - -instance Exception ProtocolError - -data IncorrectResponse = IncorrectResponse { - increspMessage :: String, - increspActual :: Response - } deriving (Eq, Show, Typeable) + } deriving (Eq, Show) -instance Exception IncorrectResponse +-- | Noop response. +emptyRes :: Response +emptyRes = Res { resOp = ResNoop, resStatus = NoError, resOpaque = 0, resCas = 0 } diff --git a/Database/Memcache/Wire.hs b/Database/Memcache/Wire.hs deleted file mode 100644 --- a/Database/Memcache/Wire.hs +++ /dev/null @@ -1,381 +0,0 @@ -{-# LANGUAGE CPP #-} -{-# LANGUAGE BangPatterns #-} - --- | Deals with serializing and parsing memcached requests and responses. -module Database.Memcache.Wire ( - send, recv, - szRequest, szRequest', - dzResponse, dzResponse', dzHeader, dzHeader', dzBody, dzBody' - ) where - --- XXX: Wire works with lazy bytestrings but we receive strict bytestrings from --- the network... - -import Database.Memcache.Errors -import Database.Memcache.Types - -import Blaze.ByteString.Builder -#if __GLASGOW_HASKELL__ < 710 -import Control.Applicative -#endif -import Control.Exception -import Control.Monad -import Data.Binary.Get -import qualified Data.ByteString as B -import qualified Data.ByteString.Lazy as L -import Data.Monoid -import Data.Word -import Network.Socket (Socket, isConnected, isReadable) -import qualified Network.Socket.ByteString as N - --- | Send a request to the memcached server. -send :: Socket -> Request -> IO () -send s m = N.sendAll s (toByteString $ szRequest m) - --- | Retrieve a single response from the memcached server. --- TODO: read into buffer to minimize read syscalls -recv :: Socket -> IO Response -recv s = do - header <- recvAll mEMCACHE_HEADER_SIZE mempty - let h = dzHeader' (L.fromChunks [header]) - if bodyLen h > 0 - then do - let bytesToRead = fromIntegral $ bodyLen h - body <- recvAll bytesToRead mempty - return $ dzBody' h (L.fromChunks [body]) - else return $ dzBody' h L.empty - where - recvAll :: Int -> Builder -> IO B.ByteString - recvAll 0 !acc = return $! toByteString acc - recvAll !n !acc = do - canRead <- isSocketActive s - if canRead - then do - buf <- N.recv s n - let bufLen = B.length buf - if bufLen == n - then return $! (toByteString $! acc <> fromByteString buf) - else recvAll (max 0 (n - bufLen)) (acc <> fromByteString buf) - else throwIO NotEnoughBytes - --- | Check whether we can still operate on this socket or not. -isSocketActive :: Socket -> IO Bool -isSocketActive s = (&&) <$> isConnected s <*> isReadable s - --- | Serialize a request to a ByteString. -szRequest' :: Request -> L.ByteString -szRequest' = toLazyByteString . szRequest - --- | Serialize a request to a ByteString Builder. -szRequest :: Request -> Builder -szRequest req = - fromWord8 0x80 - <> fromWord8 c - <> fromWord16be (fromIntegral keyl) - <> fromWord8 (fromIntegral extl) - <> fromWord8 0 - <> fromWord16be 0 - <> fromWord32be (fromIntegral $ extl + keyl + vall) - <> fromWord32be (reqOpaque req) - <> fromWord64be (reqCas req) - <> ext' - <> key' - <> val' - where - (c, k', v', ext', extl) = getCodeKeyValue (reqOp req) - (keyl, key') = case k' of - Just k -> (B.length k, fromByteString k) - Nothing -> (0, mempty) - (vall, val') = case v' of - Just v -> (B.length v, fromByteString v) - Nothing -> (0, mempty) - --- Extract needed info from an OpRequest for serialization. --- XXX: Make sure this is optimized well (no tuple, boxing, unboxing, inlined) -getCodeKeyValue :: OpRequest -> (Word8, Maybe Key, Maybe Value, Builder, Int) -getCodeKeyValue o = case o of - -- XXX: make sure this isn't a thunk! (c) - ReqGet q k key -> let c | q == Loud && k == NoKey = 0x00 - | q == Loud && k == IncludeKey = 0x0C - | k == NoKey = 0x09 -- Quiet - | otherwise = 0x0D -- Quiet && IncludeKey - in (c, Just key, Nothing, mempty, 0) - - ReqSet Loud key v e -> (0x01, Just key, Just v, szSESet e, 8) - ReqSet Quiet key v e -> (0x11, Just key, Just v, szSESet e, 8) - - ReqAdd Loud key v e -> (0x02, Just key, Just v, szSESet e, 8) - ReqAdd Quiet key v e -> (0x12, Just key, Just v, szSESet e, 8) - - ReqReplace Loud key v e -> (0x03, Just key, Just v, szSESet e, 8) - ReqReplace Quiet key v e -> (0x13, Just key, Just v, szSESet e, 8) - - ReqDelete Loud key -> (0x04, Just key, Nothing, mempty, 0) - ReqDelete Quiet key -> (0x14, Just key, Nothing, mempty, 0) - - ReqIncrement Loud key e -> (0x05, Just key, Nothing, szSEIncr e, 20) - ReqIncrement Quiet key e -> (0x15, Just key, Nothing, szSEIncr e, 20) - - ReqDecrement Loud key e -> (0x06, Just key, Nothing, szSEIncr e, 20) - ReqDecrement Quiet key e -> (0x16, Just key, Nothing, szSEIncr e, 20) - - ReqAppend Loud key v -> (0x0E, Just key, Just v, mempty, 0) - ReqAppend Quiet key v -> (0x19, Just key, Just v, mempty, 0) - - ReqPrepend Loud key v -> (0x0F, Just key, Just v, mempty, 0) - ReqPrepend Quiet key v -> (0x1A, Just key, Just v, mempty, 0) - - ReqTouch key e -> (0x1C, Just key, Nothing, szSETouch e, 4) - - -- XXX: beware allocation. - ReqGAT q k key e -> let c | q == Quiet && k == IncludeKey = 0x24 - | q == Quiet && k == NoKey = 0x1E - | k == IncludeKey = 0x23 - | otherwise = 0x1D - in (c, Just key, Nothing, szSETouch e, 4) - - ReqFlush Loud (Just e) -> (0x08, Nothing, Nothing, szSETouch e, 4) - ReqFlush Quiet (Just e) -> (0x18, Nothing, Nothing, szSETouch e, 4) - ReqFlush Loud Nothing -> (0x08, Nothing, Nothing, mempty, 0) - ReqFlush Quiet Nothing -> (0x18, Nothing, Nothing, mempty, 0) - ReqNoop -> (0x0A, Nothing, Nothing, mempty, 0) - ReqVersion -> (0x0B, Nothing, Nothing, mempty, 0) - ReqStat key -> (0x10, key, Nothing, mempty, 0) - ReqQuit Loud -> (0x07, Nothing, Nothing, mempty, 0) - ReqQuit Quiet -> (0x17, Nothing, Nothing, mempty, 0) - - ReqSASLList -> (0x20, Nothing, Nothing, mempty, 0) - ReqSASLStart key v -> (0x21, Just key, Just v, mempty, 0) - ReqSASLStep key v -> (0x22, Just key, Just v, mempty, 0) - - where - szSESet (SESet f e) = fromWord32be f <> fromWord32be e - szSEIncr (SEIncr i d e) = fromWord64be i <> fromWord64be d <> fromWord32be e - szSETouch (SETouch e) = fromWord32be e - --- | Deserialize a Response from a ByteString. -dzResponse' :: L.ByteString -> Response -dzResponse' = runGet dzResponse - --- | Deserialize a Response. -dzResponse :: Get Response -dzResponse = do - h <- dzHeader - dzBody h - --- | Deserialize a Header from a ByteString. -dzHeader' :: L.ByteString -> Header -dzHeader' = runGet dzHeader - --- | Deserialize a Header. -dzHeader :: Get Header -dzHeader = do - m <- getWord8 - when (m /= 0x81) $ throw - ProtocolError { - protocolMessage = "Bad magic value for a response packet", - protocolHeader = Nothing, - protocolParams = [show m] - } - o <- getWord8 - kl <- getWord16be - el <- getWord8 - skip 1 -- unused data type field - st <- dzStatus - bl <- getWord32be - opq <- getWord32be - ver <- getWord64be - return Header { - op = o, - keyLen = kl, - extraLen = el, - status = st, - bodyLen = bl, - opaque = opq, - cas = ver - } - --- | Deserialize a Response body from a ByteString. -dzBody' :: Header -> L.ByteString -> Response -dzBody' h = runGet (dzBody h) - --- | Deserialize a Response body. -dzBody :: Header -> Get Response -dzBody h = - case op h of - 0x00 -> dzGetResponse h $ ResGet Loud - 0x09 -> dzGetResponse h $ ResGet Quiet - 0x1D -> dzGetResponse h $ ResGAT Loud - 0x1E -> dzGetResponse h $ ResGAT Quiet - 0x0C -> dzGetKResponse h $ ResGetK Loud - 0x0D -> dzGetKResponse h $ ResGetK Quiet - 0x23 -> dzGetKResponse h $ ResGATK Loud - 0x24 -> dzGetKResponse h $ ResGATK Quiet - 0x05 -> dzNumericResponse h $ ResIncrement Loud - 0x15 -> dzNumericResponse h $ ResIncrement Quiet - 0x06 -> dzNumericResponse h $ ResDecrement Loud - 0x16 -> dzNumericResponse h $ ResDecrement Quiet - 0x01 -> dzGenericResponse h $ ResSet Loud - 0x11 -> dzGenericResponse h $ ResSet Quiet - 0x02 -> dzGenericResponse h $ ResAdd Loud - 0x12 -> dzGenericResponse h $ ResAdd Quiet - 0x03 -> dzGenericResponse h $ ResReplace Loud - 0x13 -> dzGenericResponse h $ ResReplace Quiet - 0x04 -> dzGenericResponse h $ ResDelete Loud - 0x14 -> dzGenericResponse h $ ResDelete Quiet - 0x0E -> dzGenericResponse h $ ResAppend Loud - 0x19 -> dzGenericResponse h $ ResAppend Quiet - 0x0F -> dzGenericResponse h $ ResPrepend Loud - 0x1A -> dzGenericResponse h $ ResPrepend Quiet - 0x1C -> dzGenericResponse h ResTouch - 0x07 -> dzGenericResponse h $ ResQuit Loud - 0x17 -> dzGenericResponse h $ ResQuit Quiet - 0x08 -> dzGenericResponse h $ ResFlush Loud - 0x18 -> dzGenericResponse h $ ResFlush Quiet - 0x0A -> dzGenericResponse h ResNoop - 0x10 -> dzKeyValueResponse h ResStat - 0x0B -> dzValueResponse h ResVersion - -- SASL - 0x20 -> dzValueResponse h ResSASLList - 0x21 -> dzGenericResponse h ResSASLStart - 0x22 -> dzGenericResponse h ResSASLStep - - _ -> throw ProtocolError { - protocolMessage = "Unknown operation type", - protocolHeader = Just h, - protocolParams = [show $ op h] - } - --- | Deserialize the body of a Response that contains nothing. -dzGenericResponse :: Header -> OpResponse -> Get Response -dzGenericResponse h o = do - skip (fromIntegral $ bodyLen h) - chkLength h 0 (extraLen h) "Extra length expected to be zero" - chkLength h 0 (keyLen h) "Key length expected to be zero" - chkLength h 0 (bodyLen h) "Body length expected to be zero" - return Res { - resOp = o, - resStatus = status h, - resOpaque = opaque h, - resCas = cas h - } - --- | Deserialize the body of a Get Response (Extras [flags] & Value). -dzGetResponse :: Header -> (Value -> Flags -> OpResponse) -> Get Response -dzGetResponse h o = do - e <- if status h == NoError && el == 4 - then getWord32be - else skip el >> return 0 - v <- getByteString vl - chkLength h 4 el "Extra length expected to be four" - chkLength h 0 (keyLen h) "Key length expected to be zero" - return Res { - resOp = o v e, - resStatus = status h, - resOpaque = opaque h, - resCas = cas h - } - where - el = fromIntegral $ extraLen h - vl = fromIntegral (bodyLen h) - el - --- | Deserialize the body of a GetK Response (Extras [flags] & Key & Value). -dzGetKResponse :: Header -> (Key -> Value -> Flags -> OpResponse) -> Get Response -dzGetKResponse h o = do - e <- if status h == NoError && el == 4 - then getWord32be - else skip el >> return 0 - k <- getByteString kl - v <- getByteString vl - chkLength h 4 el "Extra length expected to be four" - -- XXX: check strictness ($!) - return Res { - resOp = o k v e, - resStatus = status h, - resOpaque = opaque h, - resCas = cas h - } - where - el = fromIntegral $ extraLen h - kl = fromIntegral $ keyLen h - vl = fromIntegral (bodyLen h) - el - kl - --- | Deserialize the body of a Incr/Decr Response (Value [Word64]). -dzNumericResponse :: Header -> (Word64 -> OpResponse) -> Get Response -dzNumericResponse h o = do - v <- if status h == NoError && bodyLen h == 8 - then getWord64be - else skip (fromIntegral $ bodyLen h) >> return 0 - chkLength h 0 (extraLen h) "Extra length expected to be zero" - chkLength h 0 (keyLen h) "Key length expected to be zero" - chkLength h 8 (bodyLen h) "body length expected to be eight" - return Res { - resOp = o v, - resStatus = status h, - resOpaque = opaque h, - resCas = cas h - } - --- | Deserialize the body of a general response that just has a value (no key --- or extras). -dzValueResponse :: Header -> (Value -> OpResponse) -> Get Response -dzValueResponse h o = do - v <- getByteString (fromIntegral $ bodyLen h) - chkLength h 0 (extraLen h) "Extra length expected to be zero" - chkLength h 0 (keyLen h) "Key length expected to be zero" - return Res { - resOp = o v, - resStatus = status h, - resOpaque = opaque h, - resCas = cas h - } - --- | Deserialize the body of a general response that just has a key and value --- (no extras). -dzKeyValueResponse :: Header -> (Key -> Value -> OpResponse) -> Get Response -dzKeyValueResponse h o = do - k <- getByteString kl - v <- getByteString vl - chkLength h 0 (extraLen h) "Extra length expected to be zero" - return Res { - resOp = o k v, - resStatus = status h, - resOpaque = opaque h, - resCas = cas h - } - where - kl = fromIntegral $ keyLen h - vl = fromIntegral (bodyLen h) - kl - --- | Deserialize a Response status code. -dzStatus :: Get Status -dzStatus = do - st <- getWord16be - return $ case st of - 0x00 -> NoError - 0x01 -> ErrKeyNotFound - 0x02 -> ErrKeyExists - 0x03 -> ErrValueTooLarge - 0x04 -> ErrInvalidArgs - 0x05 -> ErrItemNotStored - 0x06 -> ErrValueNonNumeric - 0x81 -> ErrUnknownCommand - 0x82 -> ErrOutOfMemory - 0x20 -> SaslAuthFail - 0x21 -> SaslAuthContinue - _ -> throw ProtocolError { - protocolMessage = "Unknown status type", - protocolHeader = Nothing, - protocolParams = [show st] - } - --- | Check the length of a header field is as expected, throwing a --- ProtocolError exception if it is not. -chkLength :: (Eq a, Show a) => Header -> a -> a -> String -> Get () -chkLength h expected l msg = - when (l /= expected) $ return $ throw ProtocolError { - protocolMessage = msg, - protocolHeader = Just h, - protocolParams = [show l] - } - diff --git a/TODO.md b/TODO.md --- a/TODO.md +++ b/TODO.md @@ -1,15 +1,18 @@ ## ToDo -Required: -* Connection error handling -* Timeouts - Optional: +* Differentiate between two expiration modes? +* Simpler interface? +* Is System.Timeout still slow? Switch to Warp/Snap timeout handler? +* Is NominalDiffTime slow? Switch to unix epoch time? +* Configurable fail-over mode * Multi-get * Generic multi operation support * Customizable server sharding -- mod & virtual servers Nice-to-have: +* Smarter connection handling to minimize system calls (buffered) +* Server weights * Asynchronous support * Customizable -- timeout, max connection retries, hash algorithm * Max value validation @@ -21,4 +24,5 @@ Maybe: * Typeclass for serialization * Monad / Typeclass for memcache +* Automatic serialization / deserialization diff --git a/memcache.cabal b/memcache.cabal --- a/memcache.cabal +++ b/memcache.cabal @@ -1,15 +1,19 @@ name: memcache -version: 0.1.0.1 +version: 0.2.0.0 homepage: https://github.com/dterei/memcache-hs bug-reports: https://github.com/dterei/memcache-hs/issues synopsis: A memcached client library. description: - A client library for a memcached cluster. + A client library for a memcached cluster. 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. . It supports the binary memcached protocol and SASL authentication. No support for the ASCII protocol is provided. It supports connecting to a single, or a cluster of memcached servers. When connecting to a cluser, consistent hashing - is used for routing requests to the appropriate server. + is used for routing requests to the appropriate server. Timeouts, retrying + failed operations, and failover to a different server are all supported. . Complete coverage of the memcached protocol is provided except for multi-get and other pipelined operations. @@ -18,7 +22,7 @@ . > import qualified Database.Memcache.Client as M > - > mc <- M.newClient [M.ServerSpec "localhost" 11211 M.NoAuth] M.defaultOptions + > mc <- M.newClient [M.ServerSpec "localhost" 11211 M.NoAuth] M.def > M.set mc "key" "value" 0 0 > v <- M.get mc "key" . @@ -49,29 +53,27 @@ Database.Memcache.Client Database.Memcache.Cluster Database.Memcache.Errors - Database.Memcache.Protocol Database.Memcache.SASL Database.Memcache.Server + Database.Memcache.Socket Database.Memcache.Types - Database.Memcache.Wire build-depends: - base < 5, - binary >= 0.6.2.0, - blaze-builder >= 0.3.1.0, - bytestring >= 0.9.2.1, - hashable >= 1.2.0.3, - network >= 2.4, - resource-pool >= 0.2.1.0, - vector >= 0.7, - vector-algorithms >= 0.5, - time >= 1.4 + base < 5, + binary >= 0.6.2.0, + blaze-builder >= 0.3.1.0, + bytestring >= 0.9.2.1, + data-default-class >= 0.1.0, + hashable >= 1.2.0.3, + network >= 2.4, + resource-pool >= 0.2.1.0, + vector >= 0.7, + time >= 1.4 default-language: Haskell2010 other-extensions: BangPatterns, CPP, DeriveDataTypeable, FlexibleInstances, - OverloadedStrings, RecordWildCards, ScopedTypeVariables ghc-options: -Wall -fwarn-tabs @@ -103,11 +105,16 @@ hs-source-dirs: test main-is: Full.hs build-depends: - base < 5, - bytestring >= 0.9.2.1, - memcache + base < 5, + binary >= 0.6.2.0, + blaze-builder >= 0.3.1.0, + bytestring >= 0.9.2.1, + memcache, + network >= 2.4 default-language: Haskell2010 other-extensions: + BangPatterns, + CPP, OverloadedStrings ghc-options: -fwarn-tabs diff --git a/test/Full.hs b/test/Full.hs --- a/test/Full.hs +++ b/test/Full.hs @@ -1,33 +1,64 @@ {-# LANGUAGE OverloadedStrings #-} --- | Our testsuite, which we run expecting there to be a local memcache server +-- | Our testsuite, which we run expecting there to be a local Memcached server -- running on `localhost:11211`. module Main where +import MockServer + import qualified Database.Memcache.Client as M +import Database.Memcache.Errors +import Database.Memcache.Socket +import Database.Memcache.Types -import Control.Monad +import Blaze.ByteString.Builder +import Control.Concurrent +import Control.Exception +import Control.Monad +import Data.Binary.Get import qualified Data.ByteString.Char8 as BC -import System.Exit +import qualified Network.Socket as N +import qualified Network.Socket.ByteString as N +import System.Exit +import System.IO main :: IO () main = do - c <- M.newClient [M.ServerSpec "localhost" 11211 M.NoAuth] M.defaultOptions - getTest c + putStr "GET: " + getTest + putStrLn "PASSED" + putStr "DELETE: " + deleteTest + putStrLn "PASSED" + putStr "RETRY: " + retryTest + putStrLn "PASSED" + putStr "TIMEOUT1: " + timeoutTest + putStrLn "PASSED" + putStr "TIMEOUT2: " + timeoutRetryTest + putStrLn "PASSED" exitSuccess -getTest :: M.Client -> IO () -getTest c = do +getTest :: IO () +getTest = withMCServer False res $ do + c <- M.newClient M.def M.def void $ M.set c (BC.pack "key") (BC.pack "world") 0 0 Just (v', _, _) <- M.get c "key" when (v' /= "world") $ do putStrLn $ "bad value returned! " ++ show v' exitFailure + where + res = [ MR $ emptyRes { resOp = ResSet Loud } + , MR $ emptyRes { resOp = ResGet Loud "world" 0 } + ] -deleteTest :: M.Client -> IO () -deleteTest c = do - v1 <- M.set c "key" "world" 0 0 - v2 <- M.set c "key" "world22" 0 0 +deleteTest :: IO () +deleteTest = withMCServer False res $ do + c <- M.newClient M.def M.def + v1 <- M.set c "key" "world" 0 0 + v2 <- M.set c "key" "world2" 0 0 when (v1 == v2) $ do putStrLn $ "bad versions! " ++ show v1 ++ ", " ++ show v2 exitFailure @@ -35,4 +66,39 @@ unless r $ do putStrLn "delete failed!" exitFailure + where + res = [ MR $ emptyRes { resOp = ResSet Loud, resCas = 1 } + , MR $ emptyRes { resOp = ResSet Loud, resCas = 2 } + , MR $ emptyRes { resOp = ResDelete Loud } + ] + +retryTest :: IO () +retryTest = withMCServer False res $ do + c <- M.newClient M.def M.def + void $ M.set c (BC.pack "key") (BC.pack "world") 0 0 + where + res = [ CloseConnection + , MR $ emptyRes { resOp = ResSet Loud } + ] + +timeoutTest :: IO () +timeoutTest = withMCServer True res $ do + c <- M.newClient M.def M.def + void $ M.set c (BC.pack "key") (BC.pack "world") 0 0 + r <- try $ M.get c "key" + case r of + Left (ClientError Timeout) -> return () + Left _ -> putStrLn "unexpected exception!" >> exitFailure + Right _ -> putStrLn "no timeout occured!" >> exitFailure + where + res = [ MR $ emptyRes { resOp = ResSet Loud } ] + +timeoutRetryTest :: IO () +timeoutRetryTest = withMCServer False res $ do + c <- M.newClient M.def M.def + void $ M.set c (BC.pack "key") (BC.pack "world") 0 0 + where + res = [ DelayMS 800 Noop + , MR $ emptyRes { resOp = ResSet Loud } + ]