packages feed

memcache 0.1.0.1 → 0.2.0.0

raw patch · 13 files changed

+1276/−1010 lines, 13 filesdep +data-default-classdep −vector-algorithms

Dependencies added: data-default-class

Dependencies removed: vector-algorithms

Files

CHANGELOG.md view
@@ -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.
Database/Memcache/Client.hs view
@@ -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
Database/Memcache/Cluster.hs view
@@ -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
Database/Memcache/Errors.hs view
@@ -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
− Database/Memcache/Protocol.hs 
@@ -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-
Database/Memcache/SASL.hs view
@@ -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
Database/Memcache/Server.hs view
@@ -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
+ Database/Memcache/Socket.hs view
@@ -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+  }+
Database/Memcache/Types.hs view
@@ -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 }
− Database/Memcache/Wire.hs 
@@ -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]-        }-
TODO.md view
@@ -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
memcache.cabal view
@@ -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
test/Full.hs view
@@ -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 }+          ]