memcache (empty) → 0.0.0
raw patch · 13 files changed
+1172/−0 lines, 13 filesdep +basedep +binarydep +blaze-buildersetup-changed
Dependencies added: base, binary, blaze-builder, bytestring, criterion, memcache, network
Files
- Database/Memcache/Client.hs +3/−0
- Database/Memcache/Errors.hs +57/−0
- Database/Memcache/Protocol.hs +243/−0
- Database/Memcache/SASL.hs +56/−0
- Database/Memcache/Server.hs +69/−0
- Database/Memcache/Types.hs +155/−0
- Database/Memcache/Wire.hs +334/−0
- LICENSE +30/−0
- README.md +55/−0
- Setup.lhs +3/−0
- bench/Parser.hs +59/−0
- memcache.cabal +71/−0
- test/Full.hs +37/−0
+ Database/Memcache/Client.hs view
@@ -0,0 +1,3 @@+-- | A memcache client.+module Database.Memcache.Client where+
+ Database/Memcache/Errors.hs view
@@ -0,0 +1,57 @@+{-# LANGUAGE DeriveDataTypeable #-}++-- | Memcache related errors and exception handling.+module Database.Memcache.Errors (+ MemcacheError(..),+ statusToError,+ throwStatus,+ throwIncorrectRes+ ) where++import Database.Memcache.Types++import Control.Exception+import Data.Typeable++-- | Exceptions that may be thrown by Memcache.+data MemcacheError+ = MemErrNoKey+ | MemErrKeyExists+ | MemErrValueTooLarge+ | MemErrInvalidArgs+ | MemErrStoreFailed+ | MemErrValueNonNumeric+ | MemErrUnknownCmd+ | MemErrOutOfMemory+ 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+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 = error "statusToError: called on SaslAuthFail"+statusToError SaslAuthContinue = error "statusToError: called on SaslAuthContinue"++-- | Convert a status to an exception. Note, not all status's are errors and so+-- this is not a complete function!+throwStatus :: Response -> IO a+throwStatus = throwIO . statusToError . resStatus++-- | Throw an IncorrectResponse exception for a wrong received response.+throwIncorrectRes :: Response -> String -> IO a+throwIncorrectRes r msg = throwIO $+ IncorrectResponse {+ increspMessage = "Expected " ++ msg ++ " response! Got: " ++ show (resOp r),+ increspActual = r+ }+
+ Database/Memcache/Protocol.hs view
@@ -0,0 +1,243 @@+-- | 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.+-- 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,+ flush, noop, version, stats, quit+ ) where++import Control.Concurrent.MVar+import Database.Memcache.Errors+import Database.Memcache.Server+import Database.Memcache.Types++import Control.Exception+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))+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+ -- XXX: Exception Vs. Either?+ _ -> throwStatus r++-- XXX: Maybe collapse data structures into single...+gat :: Connection -> 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+ _ -> throwStatus r++touch :: Connection -> 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+ _ -> throwStatus r++--++set :: Connection -> 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+ _ -> throwStatus r++set' :: Connection -> 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+ _ -> throwStatus r++add :: Connection -> 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+ _ -> throwStatus r++-- XXX: Structure Vs. Args?+replace :: Connection -> 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+ _ -> throwStatus r++--++delete :: Connection -> 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+ _ -> throwStatus r++--++increment :: Connection -> 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+ -- XXX: Exception or Nothing for nonnumeric status?+ _ -> throwStatus r++decrement :: Connection -> 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)+ -- 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 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+ ErrKeyExists -> return Nothing+ _ -> throwStatus r++prepend :: Connection -> 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+ ErrKeyExists -> return Nothing+ _ -> throwStatus r++--++flush :: Connection -> Maybe Expiration -> IO ()+flush c e = do+ let e' = maybe Nothing (\xp -> Just (SETouch xp)) 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 ()+ _ -> throwStatus r++noop :: Connection -> 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 ()+ _ -> throwStatus r++version :: Connection -> 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+ _ -> throwStatus r++stats :: Connection -> Maybe Key -> IO (Maybe [(ByteString, ByteString)])+stats c key = withMVar (conn 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+ _ -> 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+
+ Database/Memcache/SASL.hs view
@@ -0,0 +1,56 @@+{-# LANGUAGE OverloadedStrings #-}+{-# OPTIONS_GHC -fno-warn-unused-binds #-}++-- | SASL authentication support for memcached.+module Database.Memcache.SASL (+ authenticate, Username, Password+ ) where++import Database.Memcache.Errors+import Database.Memcache.Server+import Database.Memcache.Types++import Control.Monad+import Data.ByteString+import qualified Data.ByteString.Char8 as BC+import Data.Monoid++-- | Username for authentication.+type Username = ByteString++-- | Password for authentication.+type Password = ByteString++-- | Perform SASL authentication with the server.+authenticate :: Connection -> 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 c u p = do+ let credentials = singleton 0 <> u <> singleton 0 <> p+ msg = emptyReq { reqOp = ReqSASLStart (BC.pack "PLAIN") credentials }+ r <- sendRecv c msg+ when (resOp r /= ResSASLStart) $ throwIncorrectRes r "SASL_START"+ case resStatus r of+ NoError -> return True+ SaslAuthFail -> return False+ _ -> throwStatus r++-- | 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 c = do+ let msg = emptyReq { reqOp = ReqSASLList }+ r <- sendRecv c msg+ v <- case resOp r of+ ResSASLList v -> return v+ _ -> throwIncorrectRes r "SASL_LIST"+ case resStatus r of+ NoError -> return v+ _ -> throwStatus r+
+ Database/Memcache/Server.hs view
@@ -0,0 +1,69 @@+-- | Handles the connections between a memcache client and the various servers+-- that make up the cluster.+module Database.Memcache.Server (+ Connection(..), newMemcacheClient, send, sendRecv, recv+ ) where++import Control.Concurrent.MVar+import Database.Memcache.Types+import Database.Memcache.Wire++import Blaze.ByteString.Builder+import Control.Exception+import qualified Data.ByteString.Lazy as L++import Network.BSD (getProtocolNumber, getHostByName, hostAddress)+import Network.Socket hiding (send, recv)+import qualified Network.Socket.ByteString as N++-- | A Memcache connection handle.+-- XXX: Should make abstract+data Connection = Conn {+ conn :: MVar Socket+ }++-- | 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)++-- | 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)++-- | 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+ recv s++-- | Retrieve a single response from the memcache cluster.+recv :: Socket -> IO Response+recv s = do+ -- XXX: recv may return less.+ header <- N.recv s 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+
+ Database/Memcache/Types.hs view
@@ -0,0 +1,155 @@+{-# LANGUAGE DeriveDataTypeable #-}++-- | Stores the various types needed by memcache. Mostly concerned with the+-- representation of the protocol.+module Database.Memcache.Types (+ Q(..), K(..), Key, Value, Extras, Initial, Delta, Expiration, Flags, Version,+ mEMCACHE_HEADER_SIZE, Header(..),+ Request(..), OpRequest(..), SESet(..), SEIncr(..), SETouch(..), emptyReq,+ Response(..), OpResponse(..), Status(..),+ ProtocolError(..), IncorrectResponse(..)+ ) where++import Control.Exception+import Data.ByteString (ByteString)+import Data.Typeable+import Data.Word++{- MEMCACHE MESSAGE:++ header {+ magic :: Word8+ op :: Word8+ keyLen :: Word16+ extraLen :: Word8+ datatype :: Word8+ status / reserved :: Word16+ bodyLen :: Word32 (total body length)+ opaque :: Word32+ cas :: Word64+ }+ extras :: ByteString+ key :: ByteString+ value :: ByteString+ -}++mEMCACHE_HEADER_SIZE :: Int+mEMCACHE_HEADER_SIZE = 24++data Q = Loud | Quiet deriving (Eq, Show, Typeable)+data K = NoKey | IncludeKey deriving (Eq, Show, Typeable)+type Key = ByteString+type Value = ByteString+type Extras = ByteString+type Initial = Word64+type Delta = Word64+type Expiration = Word32+type Flags = Word32+type Version = Word64++-- XXX: Which ones care about version? (Encode?)+data OpRequest+ = ReqGet Q K Key+ | ReqSet Q Key Value SESet+ | ReqAdd Q Key Value SESet+ | ReqReplace Q Key Value SESet+ | ReqDelete Q Key+ | ReqIncrement Q Key SEIncr+ | ReqDecrement Q Key SEIncr+ | ReqAppend Q Key Value+ | ReqPrepend Q Key Value+ | ReqTouch Key SETouch+ | ReqGAT Q K Key SETouch+ | ReqFlush Q (Maybe SETouch)+ | ReqNoop+ | ReqVersion+ | ReqStat (Maybe Key)+ | ReqQuit Q+ | ReqSASLList+ | ReqSASLStart Key Value -- key: auth method, value: auth data+ | ReqSASLStep Key Value -- key: auth method, value: auth data (continued)+ deriving (Eq, Show, Typeable)++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 Request = Req {+ reqOp :: OpRequest,+ reqOpaque :: Word32,+ reqCas :: Version+ } deriving (Eq, Show, Typeable)++emptyReq :: Request+emptyReq = Req { reqOp = ReqNoop, reqOpaque = 0, reqCas = 0 }++data OpResponse+ = ResGet Q Value Flags+ | ResGetK Q Key Value Flags+ | ResSet Q+ | ResAdd Q+ | ResReplace Q+ | ResDelete Q+ | ResIncrement Q Word64+ | ResDecrement Q Word64+ | ResAppend Q+ | ResPrepend Q+ | ResTouch+ | ResGAT Q Value Flags+ | ResGATK Q Key Value Flags+ | ResFlush Q+ | ResNoop+ | ResVersion Value+ | ResStat Key Value+ | ResQuit Q+ | ResSASLList Value+ | ResSASLStart+ | ResSASLStep+ deriving (Eq, Show, Typeable)++data Status+ = NoError -- All+ | ErrKeyNotFound -- Get, GAT, Touch, Replace, Del, Inc, Dec, App, Pre, Set (key not there and version specified...)+ | ErrKeyExists -- Add, (version): Set, Rep, Del, Inc, Dec, App, Pre+ | ErrValueTooLarge -- Set, Add, Rep, Pre, App+ | ErrInvalidArgs -- All+ | ErrItemNotStored -- ?+ | ErrValueNonNumeric -- Incr, Decr+ | ErrUnknownCommand -- All+ | ErrOutOfMemory -- All+ | SaslAuthFail -- SASL+ | SaslAuthContinue -- SASL+ deriving (Eq, Show, Typeable)++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)++instance Exception IncorrectResponse+
+ Database/Memcache/Wire.hs view
@@ -0,0 +1,334 @@+-- | Deals with serializing and parsing memcached requests and responses.+module Database.Memcache.Wire (+ szRequest, szRequest',+ dzResponse, dzResponse', dzHeader, dzHeader', dzBody, dzBody'+ ) where++import Database.Memcache.Types++import Control.Exception+import Control.Monad+import Blaze.ByteString.Builder+import Data.Binary.Get+import qualified Data.ByteString as B+import qualified Data.ByteString.Lazy as L+import Data.Monoid+import Data.Word++-- | 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 = do+ 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]+ }+
+ LICENSE view
@@ -0,0 +1,30 @@+Copyright (c) 2012, David Terei.++All rights reserved.++Redistribution and use in source and binary forms, with or without+modification, are permitted provided that the following conditions+are met:++1. Redistributions of source code must retain the above copyright+ notice, this list of conditions and the following disclaimer.++2. Redistributions in binary form must reproduce the above copyright+ notice, this list of conditions and the following disclaimer in the+ documentation and/or other materials provided with the distribution.++3. Neither the name of the author nor the names of his contributors+ may be used to endorse or promote products derived from this software+ without specific prior written permission.++THIS SOFTWARE IS PROVIDED BY THE CONTRIBUTORS ``AS IS'' AND ANY EXPRESS+OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED+WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE+DISCLAIMED. IN NO EVENT SHALL THE AUTHORS OR CONTRIBUTORS BE LIABLE FOR+ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL+DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS+OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION)+HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT,+STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN+ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE+POSSIBILITY OF SUCH DAMAGE.
+ README.md view
@@ -0,0 +1,55 @@+# memcache: Haskell Memcache Client++This library provides a client interface to a Memcache cluster. It is+aimed at full binary protocol support, ease of use and speed.++## Licensing++This library is BSD-licensed.++## To do++* Timeouts+* Ring / CHORD support+* Thread-safe?++* mutli(-get)++* Connection drop / reconnect resiliance?+* Asynchronous support?+* Connection pooling?+* Tweaking? (e.g., drop in hash algorithm?, timeout, max connection+ retries...)+* Max value validation...?++* Optimizations? http://code.google.com/p/spymemcached/wiki/Optimizations++* Typeclass for serialization?+* Monad / Typeclass for memcache?++* UDP+* ASCII++## Other clients++* [C: libmemcached](http://libmemcached.org/libMemcached.html)+* [Java: SpyMemcached](http://code.google.com/p/spymemcached/)+* [Ruby: Dalli](https://github.com/mperham/dalli)++## Get involved!++We are happy to receive bug reports, fixes, documentation enhancements,+and other improvements.++Please report bugs via the+[github issue tracker](http://github.com/dterei/mc-hs/issues).++Master [git repository](http://github.com/dterei/mc-hs):++* `git clone git://github.com/dterei/mc-hs.git`++## Authors++This library is written and maintained by David Terei,+<code@davidterei.com>.+
+ Setup.lhs view
@@ -0,0 +1,3 @@+#!/usr/bin/env runhaskell+> import Distribution.Simple+> main = defaultMain
+ bench/Parser.hs view
@@ -0,0 +1,59 @@+{-# LANGUAGE OverloadedStrings #-}++-- | Benchmark the parsing and serialization aspects of memcache.+module Main where++import Database.Memcache.Types+import Database.Memcache.Wire++import Criterion.Main+import Data.ByteString (ByteString)+import qualified Data.ByteString as B+import qualified Data.ByteString.Lazy as L+import qualified Data.ByteString.Lazy.Char8 as LC+import Data.Monoid++main :: IO ()+main =+ defaultMain [+ bgroup "serialize" [+ bench "get" $ whnf szRequest' getReqMsg,+ bench "set" $ whnf szRequest' setReqMsg+ ],+ bgroup "deserialize" [+ bench "get" $ whnf dzResponse' getRespBytes+ ]+ ]++getReqMsg :: Request+getReqMsg = Req {+ reqOp = ReqGet Loud NoKey "key!",+ reqOpaque = 123,+ reqCas = 999+ }++setReqMsg :: Request+setReqMsg = Req {+ reqOp = ReqSet Loud "key!" "hello world" (SESet 10 0),+ reqOpaque = 123,+ reqCas = 999+ }++getRespHeaderBytes :: L.ByteString+getRespHeaderBytes =+ -- magic, op, extral, 0+ L.pack $ [0x81, 0x00] ++ keyl' ++ [0x04, 0x00] ++ status' ++ bodyl' ++ opaque' ++ cas'+ where+ keyl' = [0x00, 0x00]+ status' = [0x00, 0x00, 0x00, 0x00]+ bodyl' = [0x00, 0x00, 0x00, 0x08]+ opaque' = [0x00, 0x00, 0x00, 0x07]+ cas' = [0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x09]++getRespBytes :: L.ByteString+getRespBytes = getRespHeaderBytes <> extras' <> key' <> value'+ where+ extras' = L.pack [0x00, 0x00, 0x00, 0x01] -- BE: so 1?+ key' = L.pack []+ value' = LC.pack "12345678"+
+ memcache.cabal view
@@ -0,0 +1,71 @@+name: memcache+version: 0.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. It is aimed at full binary protocol+ support, ease of use and speed.+license: BSD3+license-file: LICENSE+author: David Terei <code@davidterei.com>+maintainer: David Terei <code@davidterei.com>+copyright: 2013 David Terei.+category: Database+build-type: Simple+cabal-version: >= 1.8+extra-source-files:+ README.md++library+ exposed-modules:+ Database.Memcache.Client+ Database.Memcache.Errors+ Database.Memcache.Protocol+ Database.Memcache.SASL+ Database.Memcache.Server+ 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,+ network >= 2.4++ ghc-options: -Wall+ if impl(ghc >= 6.8)+ ghc-options: -fwarn-tabs++test-suite full+ type: exitcode-stdio-1.0+ hs-source-dirs: test+ main-is: Full.hs++ build-depends:+ base < 5,+ bytestring >= 0.9.2.1,+ memcache++ if impl(ghc >= 6.8)+ ghc-options: -fwarn-tabs++benchmark parser+ type: exitcode-stdio-1.0+ hs-source-dirs: bench+ main-is: Parser.hs++ build-depends:+ base < 5,+ bytestring >= 0.9.2.1,+ criterion > 0.6.0.0,+ memcache++ if impl(ghc >= 6.8)+ ghc-options: -fwarn-tabs++source-repository head+ type: git+ location: http://github.com/dterei/memcache-hs+
+ test/Full.hs view
@@ -0,0 +1,37 @@+{-# LANGUAGE OverloadedStrings #-}++module Main where++import qualified Database.Memcache.Protocol as M+import Database.Memcache.Server++import Control.Monad+import qualified Data.ByteString.Char8 as BC+import System.Exit++main :: IO ()+main = do+ c <- newMemcacheClient "localhost" 11211+ getTest c+ exitSuccess++getTest :: Connection -> IO ()+getTest c = do+ v <- 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 ++deleteTest :: Connection -> IO ()+deleteTest c = do+ v1 <- M.set c "key" "world" 0 0+ v2 <- M.set c "key" "world22" 0 0+ when (v1 == v2) $ do+ putStrLn $ "bad versions! " ++ show v1 ++ ", " ++ show v2+ exitFailure+ r <- M.delete c "key" 0+ when (not r) $ do+ putStrLn "delete failed!"+ exitFailure+