packages feed

memcache 0.0.0 → 0.0.1

raw patch · 12 files changed

+484/−134 lines, 12 filesdep +hashabledep +resource-pooldep +timesetup-changed

Dependencies added: hashable, resource-pool, time, vector, vector-algorithms

Files

Database/Memcache/Client.hs view
@@ -1,3 +1,73 @@ -- | A memcache client.-module Database.Memcache.Client where+module Database.Memcache.Client (+        get, gat, touch,+        set, set', add, replace,+        delete,+        increment, decrement,+        append, prepend,+        flush, version, stats, quit+    ) where++import Database.Memcache.Cluster+import qualified Database.Memcache.Protocol as P+import Database.Memcache.Server+import Database.Memcache.Types++import Control.Monad+import Data.Word+import Data.ByteString (ByteString)++keyedOp' :: Cluster -> Key -> (Server -> IO (Maybe a)) -> IO (Maybe a)+keyedOp' = keyedOp (Just Nothing)++get :: Cluster -> Key -> IO (Maybe (Value, Flags, Version))+get c k = keyedOp' c k $ \s -> P.get s k++gat :: Cluster -> Key -> Expiration -> IO (Maybe (Value, Flags, Version))+gat c k e = keyedOp' c k $ \s -> P.gat s k e++touch :: Cluster -> Key -> Expiration -> IO (Maybe Version)+touch c k e = keyedOp' c k $ \s -> P.touch s k e++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++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++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++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++delete :: Cluster -> Key -> Version -> IO Bool+delete c k ver = keyedOp (Just False) c k $ \s -> P.delete s k ver++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++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++append :: Cluster -> Key -> Value -> Version -> IO (Maybe Version)+append c k v ver = keyedOp' c k $ \s -> P.append s k v ver++prepend :: Cluster -> Key -> Value -> Version -> IO (Maybe Version)+prepend c k v ver = keyedOp' c k $ \s -> P.prepend s k v ver++flush :: Cluster -> Maybe Expiration -> IO ()+flush c e = void $ allOp (Just ()) c $ \s -> P.flush s e++stats :: Cluster -> Maybe Key -> IO ([(Server, Maybe P.StatResults)])+stats c key = do+    allOp Nothing c $ \s -> P.stats s key++quit :: Cluster -> IO ()+quit c = void $ allOp (Just ()) c $ \s -> P.quit s++-- | 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
+ Database/Memcache/Cluster.hs view
@@ -0,0 +1,135 @@+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE RecordWildCards #-}++-- | Handles a group of connections to different memcache servers.+module Database.Memcache.Cluster (+        Cluster, newMemcacheCluster, Options(..), defaultOptions, keyedOp,+        anyOp, allOp+    ) where++import Database.Memcache.Errors+import Database.Memcache.Server (Server(..), newServer)+import Database.Memcache.Types (Key)++import qualified Control.Exception as E++import Data.Hashable (hash)+import Data.Maybe (fromMaybe)+import Data.List (sort)+import qualified Data.Vector as V+import qualified Data.Vector.Mutable as MV++import Network.Socket (HostName, PortNumber)++data Options = Options {+        optsCmdFailure    :: !FailureMode,+        optsServerFailure :: !FailureMode,+        optsServerRetries :: !Int+    }++defaultOptions :: Options+defaultOptions = Options {+        optsCmdFailure    = FailToError,+        optsServerFailure = FailToError,+        optsServerRetries = 2+    }++-- | A memcached cluster.+data Cluster = Cluster {+        servers            :: V.Vector Server,+        cmdFailureMode     :: !FailureMode,+        _serverFailureMode :: !FailureMode,+        serverRetries      :: {-# UNPACK #-} !Int+    } deriving Show++-- | Establish a new connection to a group of memcached servers.+newMemcacheCluster :: [(HostName, PortNumber)] -> Options -> IO Cluster+newMemcacheCluster hosts Options{..} = do+    s <- mapM (uncurry newServer) hosts+    return $ Cluster (V.fromList $ sort s) optsCmdFailure optsServerFailure+      optsServerRetries++-- | 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 =+    let hashedKey = hash k+        searchFun svr = sid svr < hashedKey+    in fromMaybe (V.last $ servers c) $ V.find searchFun (servers c)++-- | Run a memcache 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)++-- | Run a memcache 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 memcache 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++-- 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 memcache 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++    go attempt =+        m s `E.catches`+            [ E.Handler $ handleMemErrors      (attempt - 1)+            , E.Handler $ handleAllErrors      (attempt - 1)+            ]++    cmdError err | cmdFailureMode c == FailSilent+                 = maybe (E.throwIO err) return def+                 | cmdFailureMode c == FailToBackup+                 = undefined -- 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++    -- 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+
Database/Memcache/Errors.hs view
@@ -5,7 +5,8 @@         MemcacheError(..),         statusToError,         throwStatus,-        throwIncorrectRes+        throwIncorrectRes,+        ClientError(..)     ) where  import Database.Memcache.Types@@ -13,7 +14,11 @@ import Control.Exception import Data.Typeable --- | Exceptions that may be thrown by Memcache.+-- 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. data MemcacheError     = MemErrNoKey     | MemErrKeyExists@@ -54,4 +59,12 @@         increspMessage = "Expected " ++ msg ++ " response! Got: " ++ show (resOp r),         increspActual  = 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 view
@@ -1,7 +1,9 @@+{-# LANGUAGE ScopedTypeVariables #-}+ -- | A raw, low level interface to the memcache protocol. -- -- The various operations are represented in full as they appear at the--- protocol level and so aren't generaly well suited for application use.+-- 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 (@@ -10,22 +12,40 @@         delete,         increment, decrement,         append, prepend,-        flush, noop, version, stats, quit+        StatResults, stats,+        flush,+        noop, version, quit     ) where -import Control.Concurrent.MVar import Database.Memcache.Errors import Database.Memcache.Server import Database.Memcache.Types -import Control.Exception+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 -get :: Connection -> Key -> IO (Maybe (Value, Flags, Version))+-- 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@@ -35,11 +55,9 @@     case resStatus r of         NoError        -> return $ Just (v, f, resCas r)         ErrKeyNotFound -> return Nothing-        -- XXX: Exception Vs. Either?         _              -> throwStatus r --- XXX: Maybe collapse data structures into single...-gat :: Connection -> Key -> Expiration -> IO (Maybe (Value, Flags, Version))+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@@ -51,7 +69,7 @@         ErrKeyNotFound -> return Nothing         _              -> throwStatus r -touch :: Connection -> Key -> Expiration -> IO (Maybe Version)+touch :: Server -> Key -> Expiration -> IO (Maybe Version) touch c k e = do     let msg = emptyReq { reqOp = ReqTouch k (SETouch e) }     r <- sendRecv c msg@@ -61,9 +79,7 @@         ErrKeyNotFound -> return Nothing         _              -> throwStatus r -----set :: Connection -> Key -> Value -> Flags -> Expiration -> IO Version+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@@ -72,7 +88,8 @@         NoError -> return $ resCas r         _       -> throwStatus r -set' :: Connection -> Key -> Value -> Flags -> Expiration -> Version -> IO (Maybe Version)+-- 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@@ -85,7 +102,7 @@         ErrKeyExists   -> return Nothing         _              -> throwStatus r -add :: Connection -> Key -> Value -> Flags -> Expiration -> IO (Maybe Version)+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@@ -95,8 +112,7 @@         ErrKeyExists -> return Nothing         _            -> throwStatus r --- XXX: Structure Vs. Args?-replace :: Connection -> Key -> Value -> Flags -> Expiration -> Version -> IO (Maybe Version)+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@@ -109,9 +125,7 @@         ErrKeyExists   -> return Nothing         _              -> throwStatus r -----delete :: Connection -> Key -> Version -> IO Bool+delete :: Server -> Key -> Version -> IO Bool delete c k ver = do     let msg = emptyReq { reqOp = ReqDelete Loud k, reqCas = ver }     r <- sendRecv c msg@@ -124,9 +138,7 @@         ErrKeyExists   -> return False         _              -> throwStatus r -----increment :: Connection -> Key -> Initial -> Delta -> Expiration -> Version -> IO (Maybe (Word64, Version))+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@@ -137,10 +149,9 @@         NoError        -> return $ Just (n, resCas r)         ErrKeyNotFound -> return Nothing         ErrKeyExists   -> return Nothing-        -- XXX: Exception or Nothing for nonnumeric status?         _              -> throwStatus r -decrement :: Connection -> Key -> Initial -> Delta -> Expiration -> Version -> IO (Maybe (Word64, Version))+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@@ -149,16 +160,11 @@         _                   -> throwIncorrectRes r "DECREMENT"     case resStatus r of         NoError        -> return $ Just (n, resCas r)-        -- XXX: Should differentiate, use custom sum, NOT either.         ErrKeyNotFound -> return Nothing         ErrKeyExists   -> return Nothing-        -- XXX: Exception or Nothing for nonnumeric status?         _              -> throwStatus r ------- XXX: Maybe? perhaps should be either so I can indicate why...-append :: Connection -> Key -> Value -> Version -> IO (Maybe Version)+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@@ -166,10 +172,9 @@     case resStatus r of         NoError        -> return $ Just (resCas r)         ErrKeyNotFound -> return Nothing-        ErrKeyExists   -> return Nothing         _              -> throwStatus r -prepend :: Connection -> Key -> Value -> Version -> IO (Maybe Version)+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@@ -177,12 +182,9 @@     case resStatus r of         NoError        -> return $ Just (resCas r)         ErrKeyNotFound -> return Nothing-        ErrKeyExists   -> return Nothing         _              -> throwStatus r -----flush :: Connection -> Maybe Expiration -> IO ()+flush :: Server -> Maybe Expiration -> IO () flush c e = do     let e'  = maybe Nothing (\xp -> Just (SETouch xp)) e         msg = emptyReq { reqOp = ReqFlush Loud e' }@@ -192,7 +194,7 @@         NoError -> return ()         _       -> throwStatus r -noop :: Connection -> IO ()+noop :: Server -> IO () noop c = do     let msg = emptyReq { reqOp = ReqNoop }     r <- sendRecv c msg@@ -201,7 +203,7 @@         NoError -> return ()         _       -> throwStatus r -version :: Connection -> IO ByteString+version :: Server -> IO ByteString version c = do     let msg = emptyReq { reqOp = ReqVersion }     r <- sendRecv c msg@@ -212,8 +214,13 @@         NoError -> return v         _       -> throwStatus r -stats :: Connection -> Maybe Key -> IO (Maybe [(ByteString, ByteString)])-stats c key = withMVar (conn c) $ \s -> do+-- | 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 []@@ -229,15 +236,20 @@             ErrKeyNotFound                 -> return Nothing             _                              -> throwStatus r -quit :: Connection -> IO ()--- XXX: close can throw, need to handle...-quit c = withMVar (conn c) $ \s -> finally (N.close 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 ()-        _       -> throwStatus r+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 ()+            _       -> throwStatus r
Database/Memcache/SASL.hs view
@@ -1,4 +1,3 @@-{-# LANGUAGE OverloadedStrings #-} {-# OPTIONS_GHC -fno-warn-unused-binds #-}  -- | SASL authentication support for memcached.@@ -11,28 +10,27 @@ import Database.Memcache.Types  import Control.Monad-import Data.ByteString-import qualified Data.ByteString.Char8 as BC+import Data.ByteString.Char8 as B8 (ByteString, pack, singleton) import Data.Monoid  -- | Username for authentication.-type Username = ByteString+type Username = B8.ByteString  -- | Password for authentication.-type Password = ByteString+type Password = B8.ByteString  -- | Perform SASL authentication with the server.-authenticate :: Connection -> Username -> Password -> IO Bool+authenticate :: Server -> Username -> Password -> IO Bool -- 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 = saslAuthPlain  -- | Perform SASL PLAIN authentication.-saslAuthPlain :: Connection -> Username -> Password -> IO Bool+saslAuthPlain :: Server -> Username -> Password -> IO Bool saslAuthPlain c u p = do-    let credentials = singleton 0 <> u <> singleton 0 <> p-        msg = emptyReq { reqOp = ReqSASLStart (BC.pack "PLAIN") credentials }+    let credentials = singleton '\0' <> u <> singleton '\0' <> p+        msg = emptyReq { reqOp = ReqSASLStart (B8.pack "PLAIN") credentials }     r <- sendRecv c msg     when (resOp r /= ResSASLStart) $ throwIncorrectRes r "SASL_START"     case resStatus r of@@ -43,7 +41,7 @@ -- | List available SASL authentication methods. We could call this but as we -- only support PLAIN as does the memcached server, we simply assume PLAIN -- authentication is supprted and try that.-saslListMechs :: Connection -> IO ByteString+saslListMechs :: Server -> IO B8.ByteString saslListMechs c = do     let msg = emptyReq { reqOp = ReqSASLList }     r <- sendRecv c msg
Database/Memcache/Server.hs view
@@ -1,69 +1,120 @@--- | Handles the connections between a memcache client and the various servers--- that make up the cluster.+-- | Handles the connections between a memcache client and a single server.+ module Database.Memcache.Server (-        Connection(..), newMemcacheClient, send, sendRecv, recv+        Server(sid, failed), newServer, sendRecv,+        withSocket, send, recv, close     ) where -import Control.Concurrent.MVar+import Database.Memcache.Errors import Database.Memcache.Types import Database.Memcache.Wire  import Blaze.ByteString.Builder import Control.Exception+import qualified Data.ByteString as B import qualified Data.ByteString.Lazy as L+import Data.Hashable+import Data.Pool+import Data.Time.Clock (NominalDiffTime)  import Network.BSD (getProtocolNumber, getHostByName, hostAddress)-import Network.Socket hiding (send, recv)+import Network.Socket (HostName, PortNumber(..), Socket)+import qualified Network.Socket as S import qualified Network.Socket.ByteString as N --- | A Memcache connection handle.--- XXX: Should make abstract-data Connection = Conn {-        conn :: MVar Socket-    }+-- Connection pool constants.+-- TODO: make configurable+sSTRIPES, sCONNECTIONS :: Int+sKEEPALIVE :: NominalDiffTime+sSTRIPES     = 1+sCONNECTIONS = 1+sKEEPALIVE = 300 --- | Establish a new connection to a memcache backend.-newMemcacheClient :: HostName -> PortNumber -> IO Connection-newMemcacheClient h p = do-    s <- connectTo h p-    m <- newMVar s-    setSocketOption s KeepAlive 1-    setSocketOption s NoDelay 1-    return (Conn m)+-- | A memcached server connection.+data Server = Server {+        sid    :: {-# UNPACK #-} !Int,+        pool   :: Pool Socket,+        _addr  :: HostName,+        _port  :: PortNumber,+        failed :: Bool+        -- TODO: +        -- weight   :: Double+        -- auth     :: Authentication+        -- tansport :: Transport (UDP vs. TCP)+        -- poolLim  :: Int (pooled connection limit)+        -- cnxnBuf   :: IORef ByteString+    } deriving Show --- | Connect to a host. (Internal, socket version of connectTo).-connectTo :: HostName -> PortNumber -> IO Socket-connectTo host port = do-    proto <- getProtocolNumber "tcp"-    bracketOnError-        (socket AF_INET Stream proto)-        (close)-        (\sock -> do-            h <- getHostByName host-            connect sock (SockAddrInet port (hostAddress h))-            return sock-        ) --- | Send a request to the memcache cluster.-send :: Socket -> Request -> IO ()--- XXX: catch errors and rethrow as MemcacheErrors?-send s m = N.sendAll s (toByteString $ szRequest m)+instance Eq Server where+    (==) x y = (sid x) == (sid y) --- | Send a receieve a single request/response pair to the memcache cluster.-sendRecv :: Connection -> Request -> IO Response-sendRecv c m = withMVar (conn c) $ \s -> do-    send s m+instance Ord Server where+    compare x y = compare (sid x) (sid y)++-- | Create a new memcached connection.+newServer :: HostName -> PortNumber -> IO Server+newServer host port = do+    pSock <- createPool connectSocket releaseSocket+                sSTRIPES sKEEPALIVE sCONNECTIONS+    return $ Server+        { sid = serverHash+        , pool = pSock+        , _addr = host+        , _port = port+        , failed = False+        }+  where+    serverHash = hash (host, let PortNum p = port in p)+    connectSocket = do+        proto <- getProtocolNumber "tcp"+        bracketOnError+            (S.socket S.AF_INET S.Stream proto)+            (releaseSocket)+            (\s -> do+                h <- getHostByName host+                S.connect s (S.SockAddrInet port $ hostAddress h)+                S.setSocketOption s S.KeepAlive 1+                S.setSocketOption s S.NoDelay 1+                return s+            )++    releaseSocket s = S.close s++-- | 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+    send s msg     recv s --- | Retrieve a single response from the memcache cluster.+-- | Run a function with access to an server socket for using 'send' and+-- 'recv'.+withSocket :: Server -> (Socket -> IO a) -> IO a+withSocket svr = withResource (pool svr)++-- | 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-    -- XXX: recv may return less.-    header <- N.recv s mEMCACHE_HEADER_SIZE+    header <- recvAll mEMCACHE_HEADER_SIZE     let h = dzHeader' (L.fromChunks [header])-    if (bodyLen h > 0) then do-      body <- N.recv s (fromIntegral $ bodyLen h)-      return $ dzBody' h (L.fromChunks [body])-      else-        return $ dzBody' h L.empty+    if (bodyLen h > 0)+        then do body <- recvAll (fromIntegral $ bodyLen h)+                return $ dzBody' h (L.fromChunks [body])+        else return $ dzBody' h L.empty+  where+    recvAll n = do+        buf <- N.recv s n+        if B.length buf == n+          then return buf+          else throwIO NotEnoughBytes++-- | Close the server connection. If you perform another operation after this,+-- the connection will be re-established.+close :: Server -> IO ()+close srv = destroyAllResources (pool srv)
Database/Memcache/Wire.hs view
@@ -4,6 +4,9 @@         dzResponse, dzResponse', dzHeader, dzHeader', dzBody, dzBody'     ) where +-- XXX: Wire works with lazy bytestrings but we receive strict bytestrings from+-- the network...+ import Database.Memcache.Types  import Control.Exception
README.md view
@@ -1,5 +1,7 @@ # memcache: Haskell Memcache Client +[![Hackage version](https://img.shields.io/hackage/v/memcache.svg?style=flat)](https://hackage.haskell.org/package/memcache) [![Build Status](https://img.shields.io/travis/dterei/memcache-hs.svg?style=flat)](https://travis-ci.org/dterei/memcache-hs)+ This library provides a client interface to a Memcache cluster. It is aimed at full binary protocol support, ease of use and speed. @@ -7,28 +9,58 @@  This library is BSD-licensed. -## To do+## Tools -* Timeouts-* Ring / CHORD support-* Thread-safe?+This library also includes a few tools for manipulating and+experimenting with memcached servers. -* mutli(-get)+* `OpGen` -- A load generator for memcached. Doesn't collect timing+  statistics, other tools like+  [mutilate](https://github.com/leverich/mutilate) already do that+  very well. This tool is useful in conjunction with mutilate.+* `Loader` -- A tool to load random data of a certain size into a+  memcache server. Useful for priming a server for testing. -* Connection drop / reconnect resiliance?-* Asynchronous support?-* Connection pooling?-* Tweaking? (e.g., drop in hash algorithm?, timeout, max connection-  retries...)-* Max value validation...?+## Architecture Notes -* Optimizations? http://code.google.com/p/spymemcached/wiki/Optimizations+We're relying on `Data.Pool` for thread safety right now, which is+fine but is a blocking API in that when we grab a socket+(`withResource`) we are blocking any other requests being sent over+that connection until we get a response. That is, we can't pipeline. -* Typeclass for serialization?-* Monad / Typeclass for memcache?+Now, use of multiple connections through the pool abstraction is an+easy way to solve this and perhaps the right approach. But, could also+implement own pool abstraction that allowed pipelining. This wouldn't+be a pool abstraction so much as just round-robbining over multiple+connections for performance. +Either way, a pool is fine for now.++## ToDo++Required:+* Connection error handling+* SASL -- tie in with cluster management+* Timeouts+* Pull cluster and server creation into client++Optional:+* Multi-get+* Generic multi operation support+* Customizable server sharding -- mod & virtual servers++Nice-to-have:+* Asynchronous support+* Customizable -- timeout, max connection retries, hash algorithm+* Max value validation+* Optimizations --  http://code.google.com/p/spymemcached/wiki/Optimizations * UDP * ASCII+* Server error handling mode where we return misses and ignore sets++Maybe:+* Typeclass for serialization+* Monad / Typeclass for memcache  ## Other clients
+ Setup.hs view
@@ -0,0 +1,7 @@+module Main (main) where++import Distribution.Simple++main :: IO ()+main = defaultMain+
− Setup.lhs 
@@ -1,3 +0,0 @@-#!/usr/bin/env runhaskell-> import Distribution.Simple-> main = defaultMain
memcache.cabal view
@@ -1,5 +1,5 @@ name:           memcache-version:        0.0.0+version:        0.0.1 homepage:       https://github.com/dterei/memcache-hs bug-reports:    https://github.com/dterei/memcache-hs/issues synopsis:       A memcached client library.@@ -10,7 +10,7 @@ license-file:   LICENSE author:         David Terei <code@davidterei.com> maintainer:     David Terei <code@davidterei.com>-copyright:      2013 David Terei.+copyright:      2015 David Terei. category:       Database build-type:     Simple cabal-version:  >= 1.8@@ -20,6 +20,7 @@ library   exposed-modules:     Database.Memcache.Client+    Database.Memcache.Cluster     Database.Memcache.Errors     Database.Memcache.Protocol     Database.Memcache.SASL@@ -32,11 +33,38 @@     binary >= 0.6.2.0,     blaze-builder >= 0.3.1.0,     bytestring >= 0.9.2.1,-    network >= 2.4+    hashable >= 1.2.0.3,+    network >= 2.4,+    resource-pool >= 0.2.1.0,+    vector >= 0.7,+    vector-algorithms >= 0.5,+    time >= 1.4    ghc-options: -Wall   if impl(ghc >= 6.8)     ghc-options: -fwarn-tabs++-- executable opgen+--   hs-source-dirs: tools+--   main-is: OpGen.hs+--   ghc-options: -threaded+--   build-depends:+--     async,+--     base < 5,+--     bytestring,+--     memcache,+--     network+--+-- executable load+--   hs-source-dirs: tools+--   main-is: Loader.hs+--   ghc-options: -threaded+--   build-depends:+--     async,+--     base < 5,+--     bytestring,+--     memcache,+--     network  test-suite full   type:           exitcode-stdio-1.0
test/Full.hs view
@@ -1,9 +1,12 @@ {-# LANGUAGE OverloadedStrings #-} +-- | Our testsuite, which we run expecting there to be a local memcache server+-- running on `localhost:11211`. module Main where  import qualified Database.Memcache.Protocol as M-import Database.Memcache.Server+import qualified Database.Memcache.Server as M+import qualified Database.Memcache.SASL as M  import Control.Monad import qualified Data.ByteString.Char8 as BC@@ -11,11 +14,12 @@  main :: IO () main = do-    c <- newMemcacheClient "localhost" 11211+    c <- M.newServer "localhost" 11211+    -- M.authenticate c "user" "pass"     getTest c     exitSuccess -getTest :: Connection -> IO ()+getTest :: M.Server -> IO () getTest c = do     v <- M.set c (BC.pack "key") (BC.pack "world") 0 0     Just (v', _, _) <- M.get c "key"@@ -23,7 +27,7 @@         putStrLn $ "bad value returned! " ++ show v'         exitFailure  -deleteTest :: Connection -> IO ()+deleteTest :: M.Server -> IO () deleteTest c = do     v1 <- M.set c "key" "world" 0 0     v2 <- M.set c "key" "world22" 0 0