memcache 0.4.0.0 → 0.4.2.0
raw patch · 19 files changed
+1302/−457 lines, 19 filesdep +QuickCheckdep −errorsdep ~networkdep ~timesetup-changedPVP ok
version bump matches the API change (PVP)
Dependencies added: QuickCheck
Dependencies removed: errors
Dependency ranges changed: network, time
API changes (from Hackage documentation)
Files
- CHANGELOG.md +66/−5
- Database/Memcache/Client.hs +66/−30
- Database/Memcache/Cluster.hs +34/−38
- Database/Memcache/ElastiCacheClient.hs +1/−1
- Database/Memcache/Errors.hs +8/−6
- Database/Memcache/Server.hs +0/−6
- Database/Memcache/Socket.hs +74/−25
- Database/Memcache/Types.hs +2/−1
- Database/Memcache/Types/ServerSpec.hs +1/−1
- Database/Memcache/Util.hs +18/−0
- README.md +142/−12
- Setup.hs +0/−6
- TODO.md +7/−7
- bench/Parser.hs +31/−5
- memcache.cabal +129/−109
- package.yaml +0/−100
- test-integration/Integration.hs +103/−11
- test/MockServer.hs +84/−63
- test/Spec.hs +536/−31
CHANGELOG.md view
@@ -1,3 +1,53 @@+# 0.4.2.0 - October 20th, 2026++No API changes from 0.4.0.0. This is the first Hackage release since 0.4.0.0,+so it also includes the 0.4.1.0 changes below.++- Fix `getMany` returning one key's value under another key's name when a+ plain key equals the other's base64 form, such as `"IA=="` and `" "`.+- Requests that carry a value or a number are now encoded into a single+ buffer instead of a chain of appends that copied the value once per piece.+ Encoding a 64KiB `set` takes about 4µs instead of about 57µs.+- Document that a `Version` of `0` skips the CAS check, what `cas`, `replace`,+ `append`, `prepend` and `delete` do for a missing key or a version mismatch,+ and when `increment` and `decrement` create a missing key. Add the missing+ `OverloadedStrings` to the usage examples in `Database.Memcache.Client` and+ the package description, add usage and development instructions to the+ README, and replace the template `SECURITY.md` with a full security policy.++# 0.4.1.0 - October 19th, 2026++Not uploaded to Hackage; these changes first ship there in 0.4.2.0. No API or+behaviour changes from 0.4.0.0.++- Reading a large value no longer allocates memory quadratic in its size. Each+ receive is now capped at 64KiB, so fetching a 32MiB value allocates about+ 67MB rather than about 1.7GB.+- Drop the dependency on `errors` (and, through it, `safe` and+ `transformers-compat`), which was only used for a one-line helper.+- Replace the hpack `package.yaml` with a hand-written `memcache.cabal`+ (`cabal-version: 3.0`) that lists the exposed modules explicitly and gives+ each component only the dependencies it uses. Remove `Setup.hs`, which only+ did what `build-type: Simple` does anyway. The license field is now the SPDX+ identifier `BSD-3-Clause`; the license itself is unchanged.+- Declare support for GHC 9.2 to 9.14 in `tested-with`.+- Fix the `parser` benchmark, which no longer compiled, and extend it to cover+ key encoding, more requests, and reading CAS, flags and numbers out of+ responses.+- Expand the package description. Hackage already shows it, as a revision of+ 0.4.0.0.+- Document the `InvalidAuthentication` and `KeyTooLong` constructors of+ `ClientError`, and fix typos in the Haddock documentation.+- Greatly expand the test suite. Unit tests against mock servers now cover+ every request encoder and client operation, retries and failover,+ authentication, `parseServerSpec` and ElastiCache discovery, and the+ integration tests also run against memcached in `-Y` auth-file mode and+ against a three-server cluster.+- CI builds and tests with cabal on GHC 9.2 to 9.14 and from the source+ distribution, builds the library against the oldest dependency versions the+ bounds allow, and runs weekly, as well as building with Stack and running+ HLint and weeder.+ # 0.4.0.0 - October 19th, 2026 - Replace the deprecated binary protocol with buffered Meta Text requests.@@ -27,8 +77,10 @@ connection. - Authentication first checks that the server is in auth-file mode and refuses to send credentials otherwise, so they are never stored as a plain- `auth` item. Invalid credentials raise `ClientError InvalidAuthentication`- without being retried or marking the server dead.+ `auth` item. Credentials with a forbidden delimiter, or a server that isn't+ in auth-file mode, raise `ClientError InvalidAuthentication`, and+ credentials the server rejects raise `OpError TextAuthFail`. Neither is+ retried or marks the server dead. - Empty keys, and keys longer than 250 bytes, are rejected with `ClientError KeyTooLong` before anything is sent. - `append` and `prepend` on a missing key return `Nothing` instead of throwing@@ -44,6 +96,15 @@ builds against (GHC 9.2, Stackage LTS 20.26). - Depend on `data-default` instead of the deprecated `data-default-class`, which is now a compatibility shim over `data-default` 0.8.+- Add `Database.Memcache.ElastiCacheClient`, which creates a client from an+ Amazon ElastiCache configuration endpoint and refreshes its node list on an+ interval.+- Add `parseServerSpec`, which reads a `ServerSpec` from a `memcached://` URI.+- `Options` gains `optsServerOptions`, whose `ServerOptions` set the size,+ stripes and keep-alive of each server's connection pool, and+ `optsServerSpecsToServers`, which controls how servers are created.+ `Database.Memcache.Server` exports `newServerDefault` in place of+ `newServer`. # 0.3.0.2 - March 27th, 2024 @@ -61,7 +122,7 @@ # 0.2.0.1 - November 2nd, 2016 -- Fix compatability with latest `data-default-class`+- Fix compatibility with latest `data-default-class` - Add new ReqRaw type for external clients to implement custom requests. Quite a hack right now, so behind a WARNING pragma. @@ -73,9 +134,9 @@ 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.+- Simplify exception hierarchy - just one type `MemcacheError` now for exceptions.+- Remove `defaultOptions` and `defaultServerSpec`, will revisit usefulness. - Remove many `Typeable` instances. - Support better testing with a mock Memcached server. - Fix bug in socket handling - detected EOF properly.
Database/Memcache/Client.hs view
@@ -1,4 +1,3 @@-{-# LANGUAGE CPP #-} {-# LANGUAGE OverloadedStrings #-} {-|@@ -49,6 +48,9 @@ [@version@] Each value has a 'Version' associated with it. This is simply a numeric, monotonically increasing value. The version field allows for a primitive version of 'cas' to be implemented.+ Operations that take a 'Version' only change a value whose+ version matches it, except that a 'Version' of @0@ skips the+ check. [@expiration@] Each value pair has an 'Expiration' associated with it. Once a a value expires, it will no longer be returned from the cache@@ -67,16 +69,19 @@ Usage is roughly as follows: -> module Main where+> {-# LANGUAGE OverloadedStrings #-} >+> module Main (main) where+> > import qualified Database.Memcache.Client as M >+> main :: IO () > main = do-> -- use default values: connects to localhost:11211+> -- use default values: connects to 127.0.0.1:11211 > mc <- M.newClient [M.def] M.def > > -- store and then retrieve a key-value pair-> M.set mc "key" "value" 0 0+> _ <- M.set mc "key" "value" 0 0 > v' <- M.get mc "key" > case v' of > Nothing -> putStrLn "Miss!"@@ -115,15 +120,12 @@ import Database.Memcache.Socket import Database.Memcache.Types -#if __GLASGOW_HASKELL__ < 710-import Control.Applicative-#endif import Control.Monad (foldM, forM_, void, when) import Data.ByteString (ByteString) import qualified Data.ByteString as B (any, empty, length, null) import qualified Data.ByteString.Char8 as C (unwords) import Data.Default-import Data.Maybe (fromMaybe)+import Data.Maybe (fromMaybe, listToMaybe) import Data.Word import UnliftIO.Exception (SomeException, handle, throwIO) @@ -132,10 +134,6 @@ -- | Key/value pairs returned by 'stats'. type StatResults = [(ByteString, ByteString)] -safeHead :: [a] -> Maybe a-safeHead [] = Nothing-safeHead (x:_) = Just x- -- | Create a client for the supplied servers. An empty list uses the default -- local server specification. newClient :: [ServerSpec] -> Options -> IO Client@@ -149,14 +147,14 @@ where ignore :: SomeException -> IO () ignore = const (pure ()) --- | Retrieve the value for the given key from Memcached.--- | Also return its flags and CAS version; return 'Nothing' on a miss.+-- | Retrieve the value for the given key from Memcached, along with its+-- flags and CAS version. Returns 'Nothing' on a miss. get :: Cluster -> Key -> IO (Maybe (Value, Flags, Version)) get c k = do response <- keyedOp c k getRequest status <- responseStatus response case (responseCode response, status) of- ("VA", NoError) -> return $ Just (responseValue response, responseFlags response, responseCas response)+ ("VA", NoError) -> return $ Just (valueResult response) (_, ErrKeyNotFound) -> return Nothing _ -> failResponse response "GET" @@ -170,7 +168,7 @@ status <- responseStatus response case (responseCode response, status) of ("VA", NoError) ->- return ((key, (responseValue response, responseFlags response, responseCas response)) : values)+ return ((key, valueResult response) : values) (_, ErrKeyNotFound) -> return values _ -> failResponse response "GETMANY" @@ -182,8 +180,7 @@ response <- keyedOp c k (`gatRequest` e) status <- responseStatus response case (responseCode response, status) of- ("VA", NoError) ->- return $ Just (responseValue response, responseFlags response, responseCas response)+ ("VA", NoError) -> return $ Just (valueResult response) (_, ErrKeyNotFound) -> return Nothing _ -> failResponse response "GAT" @@ -199,16 +196,19 @@ ErrKeyNotFound -> return Nothing _ -> failResponse response "TOUCH" --- | Store a new (or overwrite exisiting) key-value pair, returning its @Version@+-- | Store a new (or overwrite existing) key-value pair, returning its @Version@ -- identifier. Use an expiration value of @0@ to store forever. set :: Cluster -> Key -> Value -> Flags -> Expiration -> IO Version set c k v f e = store c k v f e 0 Set "SET" -- | Store a key-value pair, but only if the version specified by the client -- matches the @Version@ of the key-value pair at the server. The version--- identifier of the stored key-value pair is returned, or if the version match--- fails, @Nothing@ is returned. Use an expiration value of @0@ to store--- forever.+-- identifier of the stored key-value pair is returned, or if the key doesn't+-- exist or the version match fails, @Nothing@ is returned. Use an expiration+-- value of @0@ to store forever.+--+-- A version of @0@ skips the check, so the value is stored unconditionally, as+-- with 'set'. cas :: Cluster -> Key -> Value -> Flags -> Expiration -> Version -> IO (Maybe Version) cas c k v f e ver = do response <- keyedOp c k (\wire -> storeRequest Set wire v f e ver)@@ -232,8 +232,11 @@ _ -> failResponse response "ADD" -- | Update the value of an existing key-value pair, returning its new @Version@--- identifier. If the key doesn't already exist, the fail and return 'Nothing'.+-- identifier. If the key doesn't already exist, then fail and return 'Nothing'. -- Use an expiration value of @0@ to store forever.+--+-- A non-zero version must match the @Version@ of the key-value pair at the+-- server, otherwise 'Nothing' is returned. A version of @0@ skips the check. replace :: Cluster -> Key -> Value -> Flags -> Expiration -> Version -> IO (Maybe Version) replace c k v f e ver = do response <- keyedOp c k (\wire -> storeRequest Replace wire v f e ver)@@ -254,14 +257,28 @@ _ -> failResponse response operation -- | Increment a numeric value stored against a key, returning the incremented--- value and the @Version@ identifier of the key-value pair. Use an expiration--- value of @0@ to store forever.+-- value and the @Version@ identifier of the key-value pair. Throws+-- 'OpError' 'ErrValueNonNumeric' if the stored value isn't a number.+--+-- If the key doesn't exist, it is created with the 'Initial' value, which is+-- returned without the delta applied. The expiration is only used for a key+-- created this way, and doesn't change the expiration of an existing key; use+-- @0@ for a created key that never expires. To leave a missing key missing+-- instead, pass an expiration of 'maxBound': nothing is created and 'Nothing'+-- is returned.+--+-- A non-zero version must match the @Version@ of an existing key-value pair,+-- otherwise 'Nothing' is returned. A version of @0@ skips the check. increment :: Cluster -> Key -> Initial -> Delta -> Expiration -> Version -> IO (Maybe (Word64, Version)) increment c k i d e ver = arithmetic c k i d e ver Incr "INCREMENT" -- | Decrement a numeric value stored against a key, returning the decremented--- value and the @Version@ identifier of the key-value pair. Use an expiration--- value of @0@ to store forever.+-- value and the @Version@ identifier of the key-value pair. Memcached doesn't+-- decrement below @0@.+--+-- Otherwise this behaves like 'increment': a missing key is created with the+-- 'Initial' value unless the expiration is 'maxBound', a version of @0@ skips+-- the check, and a non-numeric value throws 'OpError' 'ErrValueNonNumeric'. decrement :: Cluster -> Key -> Initial -> Delta -> Expiration -> Version -> IO (Maybe (Word64, Version)) decrement c k i d e ver = arithmetic c k i d e ver Decr "DECREMENT" @@ -277,11 +294,22 @@ _ -> failResponse response operation -- | Append a value to an existing key-value pair, returning the new @Version@--- identifier of the key-value pair when successful.+-- identifier of the key-value pair when successful, or 'Nothing' if the key+-- doesn't exist.+--+-- A non-zero version must match the @Version@ of the key-value pair at the+-- server, otherwise 'OpError' 'ErrKeyExists' is thrown. A version of @0@ skips+-- the check. append :: Cluster -> Key -> Value -> Version -> IO (Maybe Version) append c k v ver = modify c k v ver Append "APPEND" --- | Prepend to an existing value using CAS.+-- | Prepend a value to an existing key-value pair, returning the new @Version@+-- identifier of the key-value pair when successful, or 'Nothing' if the key+-- doesn't exist.+--+-- A non-zero version must match the @Version@ of the key-value pair at the+-- server, otherwise 'OpError' 'ErrKeyExists' is thrown. A version of @0@ skips+-- the check. prepend :: Cluster -> Key -> Value -> Version -> IO (Maybe Version) prepend c k v ver = modify c k v ver Prepend "PREPEND" @@ -296,6 +324,10 @@ _ -> failResponse response operation -- | Delete a key, returning whether it was deleted.+--+-- A non-zero version must match the @Version@ of the key-value pair at the+-- server, otherwise the key isn't deleted and 'False' is returned. A version+-- of @0@ deletes the key unconditionally. delete :: Cluster -> Key -> Version -> IO Bool delete c k ver = do response <- keyedOp c k (`deleteRequest` ver)@@ -353,8 +385,12 @@ response <- anyOp c versionRequest status <- responseStatus response if responseCode response == "VERSION" && status == NoError- then return $ fromMaybe B.empty (safeHead (responseTokens response))+ then return $ fromMaybe B.empty (listToMaybe (responseTokens response)) else failResponse response "VERSION"++-- | The value, flags and CAS version carried by a @VA@ response.+valueResult :: Response -> (Value, Flags, Version)+valueResult response = (responseValue response, responseFlags response, responseCas response) failResponse :: Response -> String -> IO a failResponse response operation = do
Database/Memcache/Cluster.hs view
@@ -1,9 +1,5 @@-{-# LANGUAGE BangPatterns #-}-{-# LANGUAGE CPP #-}-{-# LANGUAGE FlexibleInstances #-}-{-# LANGUAGE RecordWildCards #-}-{-# LANGUAGE ScopedTypeVariables #-}-{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE OverloadedStrings #-} {-| Module : Database.Memcache.Cluster@@ -77,12 +73,10 @@ -- -- Default is 750ms. optsServerTimeout :: Milli,- -- -- | Figure out which server to talk to for a given key. -- -- Default is @getServerForKeyDefault@. optsGetServerForKey :: Cluster -> Key -> IO (Maybe Server),- -- -- | Convert server specifications into servers. -- -- Default uses 'newServerDefault'.@@ -90,14 +84,6 @@ -- | Connection-pool options for each server. optsServerOptions :: ServerOptions- -- TODO: socket_timeout- -- TODO: failover- -- TODO: expires_in- -- TODO: namespace- -- TODO: compress- -- TODO: compress_min_size- -- TODO: compress_max_size- -- TODO: value_max_bytes } instance Default Options where@@ -141,12 +127,18 @@ Cluster { cServers = Right $ V.fromList $ sort s, cRetries = optsServerRetries ,- cFailDelay = fromEnum optsFailRetryDelay,+ cFailDelay = toMicroseconds optsFailRetryDelay, cDeadDelay = fromRational $ toRational optsDeadRetryDelay / 1000,- cTimeout = fromEnum optsServerTimeout,+ cTimeout = toMicroseconds optsServerTimeout, cGetServerForKey = optsGetServerForKey } +-- | Convert a duration in milliseconds to the microseconds that 'threadDelay'+-- and 'timeout' take. 'Milli' has three decimal places, so the product is a+-- whole number and 'truncate' loses nothing.+toMicroseconds :: Milli -> Int+toMicroseconds ms = truncate (toRational ms * 1000)+ -- | Check if server is alive. serverAlive :: NominalDiffTime -> Server -> IO Bool {-# INLINE serverAlive #-}@@ -162,6 +154,11 @@ writeIORef (failed s) 0 return True +-- | The servers not currently marked as failed.+aliveServers :: Cluster -> IO (V.Vector Server)+{-# INLINE aliveServers #-}+aliveServers c = getServers c >>= V.filterM (serverAlive $ cDeadDelay c)+ -- | Figure out which server to talk to for this key. I.e., the distribution -- method. We use consistent hashing based on the CHORD approach. getServerForKeyDefault :: Cluster -> Key -> IO (Maybe Server)@@ -169,8 +166,7 @@ getServerForKeyDefault c k = do let hashedKey = hash k searchF s = sid s < hashedKey- servers <- getServers c- servers' <- V.filterM (serverAlive $ cDeadDelay c) servers+ servers' <- aliveServers c return $ if V.null servers' then Nothing else Just $ fromMaybe (V.last servers') (V.find searchF servers')@@ -236,9 +232,12 @@ then return (reverse acc) else recvUntilMN connection (response : acc) + -- Match the echoed key together with its base64 flag: a plain key can+ -- have the same bytes as another key's base64 form. responseKey response items = do echoed <- find (B.isPrefixOf "k") (responseTokens response)- (key, _, _) <- find ((== B.drop 1 echoed) . wireKey . snd3) items+ let wire = WireKey (B.drop 1 echoed) ("b" `elem` responseTokens response)+ (key, _, _) <- find ((== wire) . snd3) items return key request (_, wire, makeRequest) = makeRequest wire@@ -255,24 +254,16 @@ anyOp :: Cluster -> ByteString -> IO Response {-# INLINE anyOp #-} anyOp c req = do- servers <- getServers c- servers' <- V.filterM (serverAlive $ cDeadDelay c) servers- if V.null servers'- then throwIO $ ClientError NoServersReady- else serverOp c (V.head servers') req+ servers' <- aliveServers c+ case V.uncons servers' of+ Nothing -> throwIO $ ClientError NoServersReady+ Just (s, _) -> serverOp c s req -- | Run a Memcached operation against all servers in the cluster, handling any -- failures that occur, retrying the specified number of times. allOp :: Cluster -> ByteString -> IO [(Server, Response)] {-# INLINE allOp #-}-allOp c req = do- servers <- getServers c- servers' <- V.filterM (serverAlive $ cDeadDelay c) servers- 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+allOp c req = forAliveServers c $ \s -> serverOp c s req -- | Run a Memcached operation against all servers in the cluster, handling any -- failures that occur, retrying the specified number of times. Similar to@@ -280,13 +271,18 @@ -- request and response. allOp' :: Cluster -> (Server -> IO a) -> IO [(Server, a)] {-# INLINE allOp' #-}-allOp' c op = do- servers <- getServers c- servers' <- V.filterM (serverAlive $ cDeadDelay c) servers+allOp' c op = forAliveServers c $ \s -> retryOp c s (op s)++-- | Run an action against every server not marked as failed, pairing each+-- result with its server. Throws 'NoServersReady' if there are none.+forAliveServers :: Cluster -> (Server -> IO a) -> IO [(Server, a)]+{-# INLINE forAliveServers #-}+forAliveServers c f = do+ servers' <- aliveServers c if V.null servers' then throwIO $ ClientError NoServersReady else do- res <- V.forM servers' $ \s -> retryOp c s (op s)+ res <- V.mapM f servers' return $ V.toList $ V.zip servers' res -- | Run an IO operation multiple times if an exception is thrown, marking the
Database/Memcache/ElastiCacheClient.hs view
@@ -20,7 +20,6 @@ import Control.Concurrent (forkIO, threadDelay) import Control.Concurrent.MVar (MVar, modifyMVar_, newMVar)-import Control.Error.Util (note) import Control.Monad (forever, guard, (<=<)) import Data.Bifunctor (first) import Data.ByteString (ByteString)@@ -39,6 +38,7 @@ import Database.Memcache.Server (Server, withSocket) import Database.Memcache.Socket (Connection, crlf, recvRawUntil, sendRaw, versionRequest) import Database.Memcache.Types.ServerSpec (ServerSpec, parseServerSpec)+import Database.Memcache.Util (note) import Text.ParserCombinators.ReadP (readP_to_S) import UnliftIO.Exception (bracket, throwString)
Database/Memcache/Errors.hs view
@@ -1,5 +1,3 @@-{-# LANGUAGE DeriveDataTypeable #-}- {-| Module : Database.Memcache.Errors Description : Errors Handling@@ -30,11 +28,11 @@ data MemcacheError -- | Memcached operation error. = OpError Status- -- | Error occuring on client side.+ -- | Error occurring on client side. | ClientError ClientError -- | Errors occurring communicating with Memcached server. | ProtocolError ProtocolError- deriving (Eq, Show, Typeable)+ deriving (Eq, Show) instance Exception MemcacheError @@ -44,9 +42,13 @@ = NoServersReady -- | Timeout occurred sending request to server. | Timeout+ -- | Credentials were rejected before being sent: they contain a+ -- forbidden delimiter, or the server is not in auth-file mode. | InvalidAuthentication String+ -- | A key or stats argument was rejected before being sent: it is empty,+ -- too long, or contains forbidden bytes. | KeyTooLong String- deriving (Eq, Show, Typeable)+ deriving (Eq, Show) -- | Errors related to Memcached protocol and bytes on the wire. data ProtocolError@@ -66,7 +68,7 @@ | BadCommand { protocolError :: String } -- | Network socket closed without receiving enough bytes. | UnexpectedEOF { protocolError :: String }- deriving (Eq, Show, Typeable)+ deriving (Eq, Show) -- | Convert a status to 'MemcacheError' exception. throwStatus :: Status -> IO a
Database/Memcache/Server.hs view
@@ -57,12 +57,6 @@ 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 } instance Show Server where
Database/Memcache/Socket.hs view
@@ -1,4 +1,3 @@-{-# LANGUAGE CPP #-} {-# LANGUAGE OverloadedStrings #-} {-|@@ -36,14 +35,15 @@ import Database.Memcache.Errors import Database.Memcache.Types -#if __GLASGOW_HASKELL__ < 710-import Control.Applicative-#endif import Control.Monad (unless) import Data.ByteString (ByteString) import qualified Data.ByteString as B import qualified Data.ByteString.Base64 as Base64+import Data.ByteString.Builder (Builder, byteString, intDec, word32Dec, word64Dec)+import Data.ByteString.Builder.Extra (byteStringCopy, smallChunkSize, toLazyByteStringWith,+ untrimmedStrategy) import qualified Data.ByteString.Char8 as C+import qualified Data.ByteString.Lazy as BL import Data.IORef import Data.List (find, isInfixOf) import Data.Maybe (fromMaybe)@@ -193,9 +193,15 @@ readChunk :: Int -> Connection -> IO () readChunk n (Connection s ref) = do- chunk <- N.recv s (max 4096 n)+ chunk <- N.recv s (max 4096 (min maxRecvSize n)) if B.null chunk then throwIO eofError else modifyIORef' ref (<> chunk) +-- | Largest single receive. 'N.recv' allocates a buffer of the full requested+-- size on every call, so asking for the whole remainder of a large value+-- turns reading it into quadratic allocation.+maxRecvSize :: Int+maxRecvSize = 64 * 1024+ readBuffer :: Connection -> IO ByteString readBuffer (Connection _ ref) = readIORef ref @@ -230,9 +236,36 @@ keyFlag :: WireKey -> ByteString keyFlag (WireKey _ b64) = if b64 then " b" else B.empty -dec :: Show a => a -> ByteString-dec = C.pack . show+-- | Write a request that carries a value or a number into one buffer. The+-- value is copied once (each strict 'ByteString' append copies both sides, so+-- a value at the end of a chain of appends is copied once per piece before+-- it), and numbers are written in place rather than through 'show'. The size+-- is the length of the request's key and value. Values go in with+-- 'byteStringCopy', as 'byteString' would add a large one as a chunk of its+-- own for 'BL.toStrict' to copy again. Inlined so the pieces are written+-- directly instead of first being allocated as closures.+--+-- Requests with neither keep plain appends, which are cheaper for a few short+-- strings than running a 'Builder'.+render :: Int -> Builder -> ByteString+{-# INLINE render #-}+render size = BL.toStrict . toLazyByteStringWith strategy BL.empty+ where strategy = untrimmedStrategy (size + requestHeadroom) smallChunkSize +-- | Room for everything in a request besides its key and value: the command,+-- its meta flags and up to four numbers of at most 20 digits. Room left over+-- stays with the request rather than being trimmed off by another copy. A+-- request that needed more would still be encoded correctly, but copied once+-- more.+requestHeadroom :: Int+requestHeadroom = 128++-- | A piece of a request. Fixed pieces are 'ByteString' literals passed+-- through this rather than 'Builder' literals, which are encoded a character+-- at a time and measured noticeably slower.+bytes :: ByteString -> Builder+bytes = byteString+ -- | CRLF used to terminate Meta Text requests. crlf :: ByteString crlf = "\r\n"@@ -284,8 +317,8 @@ cmdStats = "stats" cmdSet = "set" -cas :: Version -> ByteString-cas n = if n == 0 then B.empty else " C" <> dec n+cas :: Version -> Builder+cas n = if n == 0 then mempty else bytes " C" <> word64Dec n -- | Encode a get request for one key. getRequest :: WireKey -> ByteString@@ -297,39 +330,53 @@ -- | Encode a get-and-touch request. gatRequest :: WireKey -> Expiration -> ByteString-gatRequest key expiry = cmdMetaGet <> " " <> keyArgs key <> " v f c T" <> dec expiry <> crlf+gatRequest key expiry = render (B.length (wireKey key)) $+ bytes cmdMetaGet <> bytes " " <> bytes (keyArgs key) <> bytes " v f c T" <> word32Dec expiry+ <> bytes crlf -- | Encode a touch request. touchRequest :: WireKey -> Expiration -> ByteString-touchRequest key expiry = cmdMetaGet <> " " <> keyArgs key <> " T" <> dec expiry <> " c" <> crlf+touchRequest key expiry = render (B.length (wireKey key)) $+ bytes cmdMetaGet <> bytes " " <> bytes (keyArgs key) <> bytes " T" <> word32Dec expiry+ <> bytes " c" <> bytes crlf -- | Encode a storage request. storeRequest :: StoreMode -> WireKey -> Value -> Flags -> Expiration -> Version -> ByteString-storeRequest mode key value flags expiry version =- cmdMetaSet <> " " <> wireKey key <> " " <> dec (B.length value) <> " F" <> dec flags <> " T" <> dec expiry- <> cas version <> " M" <> storeMode mode <> keyFlag key <> " c" <> crlf <> value <> crlf+storeRequest mode key value flags expiry version = render (B.length (wireKey key) + B.length value) $+ bytes cmdMetaSet <> bytes " " <> bytes (wireKey key) <> bytes " " <> intDec (B.length value)+ <> bytes " F" <> word32Dec flags <> bytes " T" <> word32Dec expiry <> cas version+ <> bytes " M" <> bytes (storeMode mode) <> bytes (keyFlag key) <> bytes " c"+ <> bytes crlf <> byteStringCopy value <> bytes crlf --- | Encode an increment or decrement request.+-- | Encode an increment or decrement request. Unless the expiration is+-- 'maxBound', the request asks the server to create a missing key with the+-- initial value and that expiration. arithmeticRequest :: ArithMode -> WireKey -> Initial -> Delta -> Expiration -> Version -> ByteString-arithmeticRequest mode key initial delta expiry version =- cmdMetaArith <> " " <> keyArgs key <> " D" <> dec delta <> cas version <> " M" <> arithMode mode <> " v c"- <> (if expiry == maxBound then B.empty else " N" <> dec expiry <> " J" <> dec initial)- <> crlf+arithmeticRequest mode key initial delta expiry version = render (B.length (wireKey key)) $+ bytes cmdMetaArith <> bytes " " <> bytes (keyArgs key) <> bytes " D" <> word64Dec delta+ <> cas version <> bytes " M" <> bytes (arithMode mode) <> bytes " v c"+ <> (if expiry == maxBound+ then mempty+ else bytes " N" <> word32Dec expiry <> bytes " J" <> word64Dec initial)+ <> bytes crlf -- | Encode an append or prepend request. modifyRequest :: StoreMode -> WireKey -> Value -> Version -> ByteString-modifyRequest mode key value version =- cmdMetaSet <> " " <> wireKey key <> " " <> dec (B.length value) <> " M" <> storeMode mode- <> keyFlag key <> cas version <> " c" <> crlf <> value <> crlf+modifyRequest mode key value version = render (B.length (wireKey key) + B.length value) $+ bytes cmdMetaSet <> bytes " " <> bytes (wireKey key) <> bytes " " <> intDec (B.length value)+ <> bytes " M" <> bytes (storeMode mode) <> bytes (keyFlag key) <> cas version <> bytes " c"+ <> bytes crlf <> byteStringCopy value <> bytes crlf -- | Encode a delete request. deleteRequest :: WireKey -> Version -> ByteString-deleteRequest key version = cmdMetaDelete <> " " <> keyArgs key <> cas version <> crlf+deleteRequest key 0 = cmdMetaDelete <> " " <> keyArgs key <> crlf+deleteRequest key version = render (B.length (wireKey key)) $+ bytes cmdMetaDelete <> bytes " " <> bytes (keyArgs key) <> cas version <> bytes crlf -- | Encode a flush request, optionally delayed until the given expiration. flushRequest :: Maybe Expiration -> ByteString flushRequest Nothing = cmdFlush <> crlf-flushRequest (Just expiry) = cmdFlush <> " " <> dec expiry <> crlf+flushRequest (Just expiry) = render 0 $ bytes cmdFlush <> bytes " " <> word32Dec expiry <> bytes crlf -- | Encode a version request. versionRequest, quitRequest :: ByteString@@ -344,7 +391,9 @@ -- | Encode the text auth-file request, authenticating using the value as its -- space-separated credentials. authRequest :: Value -> ByteString-authRequest value = cmdSet <> " auth 0 0 " <> dec (B.length value) <> crlf <> value <> crlf+authRequest value = render (B.length value) $+ bytes cmdSet <> bytes " auth 0 0 " <> intDec (B.length value)+ <> bytes crlf <> byteStringCopy value <> bytes crlf -- | Encode a Meta Text no-op request. noOpRequest :: ByteString
Database/Memcache/Types.hs view
@@ -37,7 +37,8 @@ type Expiration = Word32 -- | Application-defined value flags. type Flags = Word32--- | CAS version associated with a value.+-- | CAS version associated with a value. Operations that take a version skip+-- the CAS check when it is @0@. type Version = Word64 -- | Status reported by a Memcached operation.
Database/Memcache/Types/ServerSpec.hs view
@@ -18,13 +18,13 @@ ) where -import Control.Error.Util (note) import Control.Monad (guard) import Data.Default import Data.Maybe (fromMaybe) import qualified Data.Text as T import Data.Text.Encoding (encodeUtf8) import Database.Memcache.Types.Authentication (Authentication (..))+import Database.Memcache.Util (note) import Network.Socket (HostName, ServiceName) import Network.URI (URI (..), URIAuth (..), parseAbsoluteURI) import Data.Bifunctor (second)
+ Database/Memcache/Util.hs view
@@ -0,0 +1,18 @@+{-|+Module : Database.Memcache.Util+Description : Internal helpers+Copyright : (c) David Terei, 2026+License : BSD+Maintainer : code@davidterei.com+Stability : internal+Portability : GHC++Small helpers shared by the library's modules. Not exposed.+-}+module Database.Memcache.Util (+ note+ ) where++-- | Turn a 'Nothing' into an error.+note :: e -> Maybe a -> Either e a+note e = maybe (Left e) Right
README.md view
@@ -1,10 +1,8 @@ # memcache: Haskell Memcached Client [](https://hackage.haskell.org/package/memcache)-[](http://packdeps.haskellers.com/reverse/memcache)-[][tl;dr Legal: BSD3]+[][tl;dr Legal: BSD3] [](https://github.com/dterei/memcache-hs/actions/workflows/ci.yml)-[](https://gitter.im/dterei/memcache-hs?utm_source=badge&utm_medium=badge&utm_campaign=pr-badge) [tl;dr Legal: BSD3]: https://tldrlegal.com/license/bsd-3-clause-license-(revised) "BSD3 License" @@ -30,6 +28,95 @@ the `Response` type; the former request and response wrapper types are no longer provided. +## Usage++Add `memcache` to your package's `build-depends`. Everything most programs need+is exported from `Database.Memcache.Client`:++```haskell+{-# LANGUAGE OverloadedStrings #-}++module Main (main) where++import qualified Database.Memcache.Client as M++main :: IO ()+main = do+ -- Connect to memcached on 127.0.0.1:11211 with the default options.+ mc <- M.newClient [M.def] M.def++ -- Store a value with flags 0 that never expires, then read it back along+ -- with its flags and CAS version.+ _ <- M.set mc "greeting" "hello" 0 0+ hit <- M.get mc "greeting"+ case hit of+ Nothing -> putStrLn "miss"+ Just (value, _flags, version) -> do+ print value+ -- Only overwrite the value if it hasn't changed since we read it.+ updated <- M.cas mc "greeting" "hello again" 0 0 version+ putStrLn (maybe "changed by someone else" (const "updated") updated)++ -- Create the counter as 1 if it is missing, otherwise add 1 to it.+ visits <- M.increment mc "visits" 1 1 0 0+ print (fst <$> visits)++ M.quit mc+```++Keys and values are strict `ByteString`s. Misses are returned as `Nothing`,+while unexpected failures are thrown as a `MemcacheError` or a network+`IOException`. Operations that take a CAS `Version` skip the check when it is+`0`. `increment` and `decrement` create a missing key with the given initial+value, unless the expiration is `maxBound`. The+[`Database.Memcache.Client`](https://hackage.haskell.org/package/memcache/docs/Database-Memcache-Client.html)+documentation covers every operation, along with the timeouts, retries and+failover configured through `Options`.++### Servers and authentication++`newClient` takes one `ServerSpec` per server, and routes each key to one of+them. Credentials are set per server:++```haskell+ mc <- M.newClient+ [ M.ServerSpec "cache1.internal" "11211" (M.Auth "user" "secret")+ , M.ServerSpec "cache2.internal" "11211" (M.Auth "user" "secret")+ ]+ M.def+```++`parseServerSpec`, from `Database.Memcache.Types`, reads a server from a+`memcached://[user:password@]host[:port]` URI instead. The host defaults to+`127.0.0.1` and the port to `11211`:++```haskell+import Database.Memcache.Types (parseServerSpec)++ spec <- either fail pure (parseServerSpec "memcached://user:secret@cache1.internal:11211")+ mc <- M.newClient [spec] M.def+```++The server must be started with `-Y <authfile>`, where the auth file holds one+`username:password` line per user. This library connects without TLS, so+credentials and all data are sent unencrypted; only rely on them within a+trusted network.++### Amazon ElastiCache++`Database.Memcache.ElastiCacheClient` creates a client from an ElastiCache+configuration endpoint (the address containing `.cfg`). It discovers the+cluster's nodes, then refreshes the node list in a background thread on the+given interval, in microseconds as for `threadDelay`:++```haskell+import qualified Database.Memcache.ElastiCacheClient as EC++ endpoint <- either fail pure $+ EC.parseConfigurationEndpoint "memcached://mycluster.abc123.cfg.use1.cache.amazonaws.com:11211"+ mc <- EC.newClient M.def (60 * 1000000) endpoint+```+ ## Licensing This library is BSD-licensed.@@ -47,14 +134,15 @@ ## Architecture Notes -We're relying on `Data.Pool` for thread safety right now. Grabbing a connection-from the pool (`withResource`) blocks other requests using that connection-until the operation completes. `getMany` is the exception: it pipelines quiet-Meta Text requests over one pooled connection.+We're relying on `Data.Pool` for thread safety right now. Each server has its+own pool, and grabbing a connection from it (`withResource`) blocks other+requests using that connection until the operation completes. `getMany` is the+exception: it pipelines quiet Meta Text requests over one pooled connection. -Multiple connections through the pool abstraction allow concurrent operations-and provide a simple performance path without requiring a separate pool-implementation.+By default each server's pool holds a single connection (`soNumResources = 1`),+so concurrent operations against the same server wait for each other. Raising+`soNumResources` in the `ServerOptions` set through `optsServerOptions` allows+concurrent operations without requiring a separate pool implementation. Either way, a pool is fine for now. @@ -70,11 +158,53 @@ other improvements. Please report bugs via the-[github issue tracker](http://github.com/dterei/memcache-hs/issues).+[github issue tracker](https://github.com/dterei/memcache-hs/issues), and+security issues as described in the+[security policy](https://github.com/dterei/memcache-hs/security/policy). -Master [git repository](http://github.com/dterei/memcache-hs):+Master [git repository](https://github.com/dterei/memcache-hs): - `git clone https://github.com/dterei/memcache-hs.git`++## Development++The package builds with [Stack](https://docs.haskellstack.org/) or+[cabal](https://www.haskell.org/cabal/), on GHC 9.2 or newer:++```sh+stack build+stack test++cabal build+cabal test all+```++`stack.yaml` uses Stackage LTS 22.14 (GHC 9.6). The oldest and newest snapshots+CI tests against have their own files, for example+`stack --stack-yaml stack-lts-20.26.yaml test` for GHC 9.2.++There are two test suites:++- `spec` holds the unit and property tests, which run against an in-process+ mock server and need nothing installed.+- `integration` starts its own `memcached` servers on free local ports and+ tests against them, so it needs memcached 1.6 or newer on your `PATH`.+ Without it, the suite reports a single pending test instead of failing.+ memcached refuses to run as root without `-u`, so run the suite as an+ ordinary user.++CI lints with [HLint](https://github.com/ndmitchell/hlint) 3.10, so please+check that `hlint .` prints `No hints` before opening a pull request. For any+user-visible change, add a line to [CHANGELOG.md](CHANGELOG.md) under an+`Unreleased` heading at the top, adding the heading if it isn't there.++CI runs both build tools on every pull request. The `CI` workflow builds and+tests with Stack against each `stack*.yaml` snapshot, and runs HLint and+weeder. The `Cabal` workflow builds and tests with cabal on GHC 9.2 to 9.14,+builds the library against the oldest dependency versions its bounds allow,+and builds and tests the source distribution; it also runs every Monday, so a+new dependency release that breaks the build shows up without a push. Both+install memcached, so the integration suite runs in full. ## Authors
− Setup.hs
@@ -1,6 +0,0 @@-module Main (main) where--import Distribution.Simple--main :: IO ()-main = defaultMain
TODO.md view
@@ -1,5 +1,8 @@ ## ToDo +Behavior and API fixes, including routing and virtual nodes, are tracked in+[#46](https://github.com/dterei/memcache-hs/issues/46).+ Optional: - Typeclass abstracting key and values@@ -15,18 +18,15 @@ Performance: -- Is System.Timeout still slow? Switch to Warp/Snap timeout handler?-- Is NominalDiffTime slow? Switch to unix epoch time?+- System.Timeout forks a thread per server request on the non-threaded RTS and+ on Windows; consider a shared timer. Nice-to-have: -- Customizable server sharding -- mod & virtual servers+- Built-in modulo sharding (custom routing works through `optsGetServerForKey`) - Server weights - Asynchronous support?-- Customizable -- timeout, max connection retries, hash algorithm-- Max value validation-- Optimizations -- http://code.google.com/p/spymemcached/wiki/Optimizations-- UDP+- Max value validation before sending - Server error handling mode where we return misses and ignore sets Maybe:
bench/Parser.hs view
@@ -1,12 +1,38 @@ {-# LANGUAGE OverloadedStrings #-} +-- | Micro-benchmarks for the pure parts of the Meta Text protocol layer: key+-- encoding, request encoding and reading fields out of responses.+module Main (main) where+ import Criterion.Main+import qualified Data.ByteString as B+import qualified Data.ByteString.Char8 as C import Database.Memcache.Socket main :: IO ()-main = case encodeKey "key!" of- Left _ -> return ()- Right key -> defaultMain- [ bench "get" $ whnf (`getRequest` 0) key- , bench "set" $ whnf (storeRequest Set key "hello world" 10 0 0) 0+main = defaultMain+ [ bgroup "encodeKey"+ [ bench "plain" $ whnf encodedLength "user:1234:profile"+ , bench "base64" $ whnf encodedLength "a key with spaces"+ , bench "250 bytes" $ whnf encodedLength (C.replicate 250 'k') ]+ , bgroup "request"+ [ bench "get" $ whnf getRequest key+ , bench "set 100 B" $ whnf (storeRequest Set key (C.replicate 100 'v') 10 0) 0+ , bench "set 64 KiB" $ whnf (storeRequest Set key (C.replicate 65536 'v') 10 0) 0+ , bench "increment" $ whnf (arithmeticRequest Incr key 0 1 0) 0+ ]+ , bgroup "response"+ [ bench "cas" $ whnf responseCas valueResponse+ , bench "flags" $ whnf responseFlags valueResponse+ , bench "number" $ whnf responseNumber (Response "VA" ["5"] "12345")+ ]+ ]+ where+ key = either (error . show) id (encodeKey "key!")+ valueResponse = Response "VA" ["3", "f7", "c123456789", "kkey"] "abc"++-- | Force the whole encoded key by measuring it, failing if the key is+-- rejected so a benchmark can't quietly time the error path instead.+encodedLength :: B.ByteString -> Int+encodedLength = either (error . show) (B.length . wireKey) . encodeKey
memcache.cabal view
@@ -1,136 +1,156 @@-cabal-version: 1.18+cabal-version: 3.0+name: memcache+version: 0.4.2.0+synopsis: A memcached client library.+description:+ 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. --- This file has been generated from package.yaml by hpack version 0.39.6.------ see: https://github.com/sol/hpack+ It uses the Memcached Meta Text protocol and requires memcached 1.6.0 or+ newer. Username/password authentication is supported through memcached's+ @-Y authfile@ mode; the binary protocol and SASL authentication are no longer+ supported. It supports connecting to a single, or a cluster of Memcached+ servers. When connecting to a cluster, consistent hashing is used for routing+ requests to the appropriate server. Timeouts, retrying failed operations, and+ failover to a different server are all supported, as is Amazon ElastiCache+ auto discovery. -name: memcache-version: 0.4.0.0-synopsis: A memcached client library.-description: A buffered Meta Text protocol client for single servers and clusters.-category: Database-homepage: https://github.com/dterei/memcache-hs#readme-bug-reports: https://github.com/dterei/memcache-hs/issues-author: David Terei <code@davidterei.com>-maintainer: David Terei <code@davidterei.com>-copyright: 2012-2026 David Terei.-license: BSD3-license-file: LICENSE-build-type: Simple-extra-source-files:- package.yaml+ Multi-get is supported through the pipelined @getMany@. Keys containing+ whitespace or control bytes are sent using the protocol's base64 binary-key+ mode.++ Basic usage is:++ > {-# LANGUAGE OverloadedStrings #-}+ >+ > import qualified Database.Memcache.Client as M+ >+ > main :: IO ()+ > main = do+ > mc <- M.newClient [M.ServerSpec "localhost" "11211" M.NoAuth] M.def+ > _ <- M.set mc "key" "value" 0 0+ > v <- M.get mc "key"+ > print v++ You should only need to import 'Database.Memcache.Client', but other modules+ are exposed for lower-level use. Version 0.4 is a breaking change from 0.3;+ see the changelog for details.++category: Database+homepage: https://github.com/dterei/memcache-hs#readme+bug-reports: https://github.com/dterei/memcache-hs/issues+author: David Terei <code@davidterei.com>+maintainer: David Terei <code@davidterei.com>+copyright: 2012-2026 David Terei.+license: BSD-3-Clause+license-file: LICENSE+build-type: Simple+-- Keep in step with the GHC matrix in .github/workflows/cabal.yml.+tested-with:+ GHC ==9.2.*+ || ==9.4.*+ || ==9.6.*+ || ==9.8.*+ || ==9.10.*+ || ==9.12.*+ || ==9.14.*+ extra-doc-files:- README.md- CHANGELOG.md- TODO.md+ CHANGELOG.md+ README.md+ TODO.md source-repository head- type: git+ type: git location: https://github.com/dterei/memcache-hs +-- Settings shared by every component.+common shared+ default-language: GHC2021+ ghc-options: -Wall -Wextra -Wunused-packages+ build-depends:+ , base >=4.16 && <5+ , bytestring >=0.11.4.0+ library+ import: shared+ hs-source-dirs: . exposed-modules:- Database.Memcache.Auth- Database.Memcache.Client- Database.Memcache.Cluster- Database.Memcache.ElastiCacheClient- Database.Memcache.Errors- Database.Memcache.Server- Database.Memcache.Socket- Database.Memcache.Types+ Database.Memcache.Auth+ Database.Memcache.Client+ Database.Memcache.Cluster+ Database.Memcache.ElastiCacheClient+ Database.Memcache.Errors+ Database.Memcache.Server+ Database.Memcache.Socket+ Database.Memcache.Types+ other-modules:- Database.Memcache.Types.Authentication- Database.Memcache.Types.ServerSpec- hs-source-dirs:- ./+ Database.Memcache.Types.Authentication+ Database.Memcache.Types.ServerSpec+ Database.Memcache.Util+ other-extensions:- BangPatterns- CPP- DeriveDataTypeable- FlexibleInstances- RecordWildCards- ScopedTypeVariables- ghc-options: -Wall -Wextra -fwarn-tabs+ CPP+ OverloadedStrings+ RecordWildCards++ ghc-options:+ -Wcompat -Widentities -Wincomplete-record-updates -Wredundant-constraints+ -fwarn-tabs+ build-depends:- base >=4.16 && <5- , base64-bytestring >=1.2.1.0- , bytestring >=0.11.4.0- , data-default >=0.7.1.1- , errors >=2.3.0- , hashable >=1.4.2.0- , network >=3.1.4.0- , network-uri >=2.6.4.2- , resource-pool >=0.2.3.2- , text >=1.2.5.0- , time >=1.11.1.1- , unliftio >=0.2.25.0- , vector >=0.12.3.1- default-language: Haskell2010+ , base64-bytestring >=1.2.1.0+ , data-default >=0.7.1.1+ , hashable >=1.4.2.0+ , network >=3.1.4.0+ , network-uri >=2.6.4.2+ , resource-pool >=0.2.3.2+ , text >=1.2.5.0+ , time >=1.11.1.1+ , unliftio >=0.2.25.0+ , vector >=0.12.3.1 -test-suite integration- type: exitcode-stdio-1.0- main-is: Integration.hs- other-modules:- Paths_memcache- hs-source-dirs:- test-integration- other-extensions:- BangPatterns- CPP- OverloadedStrings- ghc-options: -Wall -Wextra -threaded -rtsopts "-with-rtsopts=-N"+test-suite spec+ import: shared+ type: exitcode-stdio-1.0+ hs-source-dirs: test+ main-is: Spec.hs+ other-modules: MockServer+ other-extensions: OverloadedStrings+ ghc-options: -threaded -rtsopts "-with-rtsopts=-N" build-depends:- base >=4.16 && <5- , base64-bytestring >=1.2.1.0- , bytestring >=0.11.4.0- , directory+ , base64-bytestring >=1.2.1.0 , hspec , memcache , network- , process- , time- default-language: Haskell2010+ , QuickCheck+ , unliftio -test-suite spec- type: exitcode-stdio-1.0- main-is: Spec.hs- other-modules:- MockServer- hs-source-dirs:- test- other-extensions:- BangPatterns- CPP- OverloadedStrings- ghc-options: -Wall -Wextra -threaded -rtsopts "-with-rtsopts=-N"+-- Runs against a real memcached; reports a pending test if none is on PATH.+test-suite integration+ import: shared+ type: exitcode-stdio-1.0+ hs-source-dirs: test-integration+ main-is: Integration.hs+ other-extensions: OverloadedStrings+ ghc-options: -threaded -rtsopts "-with-rtsopts=-N" build-depends:- base >=4.16 && <5- , base64-bytestring >=1.2.1.0- , bytestring >=0.11.4.0+ , directory , hspec , memcache , network- , time >=1.11.1.1- , unliftio- default-language: Haskell2010+ , process+ , time benchmark parser- type: exitcode-stdio-1.0- main-is: Parser.hs- other-modules:- Paths_memcache- hs-source-dirs:- bench- other-extensions:- BangPatterns- CPP- OverloadedStrings+ import: shared+ type: exitcode-stdio-1.0+ hs-source-dirs: bench+ main-is: Parser.hs+ other-extensions: OverloadedStrings build-depends:- base >=4.16 && <5- , base64-bytestring >=1.2.1.0- , bytestring >=0.11.4.0 , criterion , memcache- , network >=3.1.4.0- , time >=1.11.1.1- default-language: Haskell2010
− package.yaml
@@ -1,100 +0,0 @@-name: memcache-version: 0.4.0.0-github: dterei/memcache-hs-synopsis: A memcached client library.-description: A buffered Meta Text protocol client for single servers and clusters.-license: BSD3-license-file: LICENSE-author: David Terei <code@davidterei.com>-maintainer: David Terei <code@davidterei.com>-copyright: 2012-2026 David Terei.-category: Database-build-type: Simple-extra-doc-files:- - README.md- - CHANGELOG.md- - TODO.md-extra-source-files:- - package.yaml--dependencies:- - base >= 4.16 && < 5- - base64-bytestring >= 1.2.1.0- - bytestring >= 0.11.4.0- - network >= 3.1.4.0- - time >= 1.11.1.1--other-extensions:- - BangPatterns- - CPP--library:- source-dirs: .- dependencies:- - data-default >= 0.7.1.1- - errors >= 2.3.0- - hashable >= 1.4.2.0- - network-uri >= 2.6.4.2- - resource-pool >= 0.2.3.2- - text >= 1.2.5.0- - unliftio >= 0.2.25.0- - vector >= 0.12.3.1- other-modules:- - Database.Memcache.Types.Authentication- - Database.Memcache.Types.ServerSpec- other-extensions:- - DeriveDataTypeable- - FlexibleInstances- - RecordWildCards- - ScopedTypeVariables- ghc-options:- - -Wall- - -Wextra- - -fwarn-tabs--tests:- spec:- main: Spec.hs- source-dirs: test- ghc-options:- - -Wall- - -Wextra- - -threaded- - -rtsopts "-with-rtsopts=-N"- other-extensions:- - OverloadedStrings- other-modules:- - MockServer- dependencies:- - memcache- - hspec- - network- - unliftio-- integration:- main: Integration.hs- source-dirs: test-integration- ghc-options:- - -Wall- - -Wextra- - -threaded- - -rtsopts "-with-rtsopts=-N"- other-extensions:- - OverloadedStrings- dependencies:- - memcache- - directory- - hspec- - network- - process- - time--benchmarks:- parser:- main: Parser.hs- source-dirs: bench- other-extensions:- - OverloadedStrings- dependencies:- - memcache- - criterion
test-integration/Integration.hs view
@@ -1,11 +1,10 @@ {-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE TypeApplications #-} module Main where import Control.Concurrent (threadDelay) import Control.Exception (SomeException, bracket, try)-import Control.Monad (void)+import Control.Monad (forM_, void) import qualified Data.ByteString.Char8 as B import Data.Either (isRight) import Data.Maybe (isJust)@@ -19,7 +18,8 @@ setSocketOption, socket, socketPort, tupleToHostAddress) import qualified Network.Socket as N-import System.Directory (findExecutable)+import System.Directory (findExecutable, getTemporaryDirectory, removeFile)+import System.IO (hClose, hPutStr, openTempFileWithDefaultPermissions) import System.Process (ProcessHandle, createProcess, proc, getProcessExitCode, terminateProcess, waitForProcess)@@ -33,8 +33,15 @@ hspec $ it "requires memcached" $ pendingWith "memcached command not found"- Just path -> withMemcached path $ \port ->- hspec (integrationSpecs port)+ Just path ->+ withMemcached path [] $ \port ->+ withAuthfile $ \authfile ->+ withMemcached path ["-Y", authfile] $ \authPort ->+ withMemcacheds path 3 $ \clusterPorts ->+ hspec $ do+ describe "single server" $ integrationSpecs port+ describe "auth-file authentication" $ authSpecs authPort+ describe "three-server cluster" $ clusterSpecs clusterPorts integrationSpecs :: Int -> Spec integrationSpecs port = beforeAll (newClient port) $ do@@ -82,6 +89,14 @@ M.touch client "integration-no-touch" 60 `shouldReturn` Nothing + it "tells a plain key from another key's base64 form" $ \client -> do+ -- " " is sent, and echoed, as IA== with the b flag.+ _ <- M.set client "IA==" "plain" 0 0+ _ <- M.set client " " "space" 0 0+ values <- M.getMany client ["IA==", " "]+ map (\(key, (value, _, _)) -> (key, value)) values+ `shouldMatchList` [("IA==", "plain"), (" ", "space")]+ it "gets many keys, including encoded keys" $ \client -> do _ <- M.set client "integration-many" "one" 0 0 _ <- M.set client "integration key" "two" 0 0@@ -145,6 +160,60 @@ it "supports quit" M.quit +authSpecs :: Int -> Spec+authSpecs port = do+ it "serves a client with the right credentials" $ do+ client <- M.newClient [server (M.Auth "user" "secret")] M.def+ _ <- M.set client "integration-auth" "value" 0 0+ fmap first <$> M.get client "integration-auth" `shouldReturn` Just "value"++ it "rejects a wrong password" $ do+ client <- M.newClient [server (M.Auth "user" "wrong")] M.def+ M.get client "integration-auth" `shouldThrow` (== M.OpError M.TextAuthFail)++ it "rejects a client without credentials" $ do+ client <- M.newClient [server M.NoAuth] M.def+ M.get client "integration-auth" `shouldThrow` isBadCommand+ where+ server = ServerSpec "127.0.0.1" (show port)+ isBadCommand (M.ProtocolError (M.BadCommand _)) = True+ isBadCommand _ = False++-- | Tests against several servers. Key routing currently leaves at least one+-- server without keys (#46), so these don't assume keys reach every server.+clusterSpecs :: [Int] -> Spec+clusterSpecs ports = beforeAll newClusterClient $ do+ it "stores and reads back keys" $ \client -> do+ storeKeys client+ forM_ keys $ \key -> fmap first <$> M.get client key `shouldReturn` Just key++ it "gets many keys" $ \client -> do+ storeKeys client+ values <- M.getMany client keys+ map fst values `shouldMatchList` keys++ it "reads stats from every server" $ \client -> do+ stats <- M.stats client Nothing+ length stats `shouldBe` length ports++ it "flushes every server" $ \client -> do+ storeKeys client+ counts <- flushCounts client+ M.flush client Nothing+ flushCounts client `shouldReturn` map (+ 1) counts+ M.getMany client keys `shouldReturn` []+ where+ keys = [B.pack ("integration-cluster-" <> show n) | n <- [1 .. 300 :: Int]]+ storeKeys client = forM_ keys $ \key -> M.set client key key 0 0+ -- How many times each server has run flush_all, in server order.+ flushCounts client = do+ stats <- M.stats client Nothing+ return [maybe 0 (read @Int . B.unpack) (lookup "cmd_flush" s) | (_, s) <- stats]+ newClusterClient = do+ client <- M.newClient [ServerSpec "127.0.0.1" (show port) M.NoAuth | port <- ports] M.def+ M.flush client Nothing+ return client+ newClient :: Int -> IO M.Client newClient port = do client <- M.newClient [ServerSpec "127.0.0.1" (show port) M.NoAuth] M.def@@ -154,22 +223,43 @@ first :: (a, b, c) -> a first (value, _, _) = value +-- | Run an action against a memcached started with the given extra+-- arguments on a free port. withMemcached :: FilePath- -> (Int -> IO ())- -> IO ()-withMemcached executable action = bracket acquire release (action . fst)+ -> [String]+ -> (Int -> IO a)+ -> IO a+withMemcached executable args action = bracket acquire release (action . fst) where acquire = do port <- freePort (_, _, _, process) <-- createProcess (proc executable ["-l", "127.0.0.1", "-p", show port, "-U", "0"])+ createProcess (proc executable (["-l", "127.0.0.1", "-p", show port, "-U", "0"] ++ args)) waitForPort port process return (port, process) release (_, process) = do terminateProcess process void (waitForProcess process) +-- | Run an action against @n@ memcached servers.+withMemcacheds :: FilePath -> Int -> ([Int] -> IO a) -> IO a+withMemcacheds _ 0 action = action []+withMemcacheds executable n action =+ withMemcached executable [] $ \port ->+ withMemcacheds executable (n - 1) $ \ports -> action (port : ports)++-- | Run an action with an auth file allowing @user@ / @secret@.+withAuthfile :: (FilePath -> IO a) -> IO a+withAuthfile action = do+ tmp <- getTemporaryDirectory+ -- Default permissions, so a memcached that drops privileges (e.g. when+ -- started as root with -u) can still read it.+ bracket (openTempFileWithDefaultPermissions tmp "memcached-auth") (removeFile . fst) $ \(path, handle) -> do+ hPutStr handle "user:secret\n"+ hClose handle+ action path+ freePort :: IO Int freePort = bracket (socket AF_INET Stream defaultProtocol) close $ \sock -> do setSocketOption sock ReuseAddr 1@@ -184,8 +274,10 @@ where go :: Int -> IO () go 0 = do- status <- waitForProcess process- fail $ "memcached exited before becoming ready: " <> show status+ -- Still running but never listening: stop it rather than waiting on it.+ terminateProcess process+ void (waitForProcess process)+ fail $ "memcached did not start listening on port " <> show port go attempts = do ready <- tryConnect port if ready
test/MockServer.hs view
@@ -1,102 +1,121 @@-{-# LANGUAGE CPP #-} {-# LANGUAGE OverloadedStrings #-} -- | Mock Memcached server - just enough for testing client.+--+-- Each mock listens on its own ephemeral port on 127.0.0.1, so tests can run+-- several at once and never clash with a real memcached on the default port. module MockServer (- MockResponse(..), mockMCServer, withMCServer+ MockResponse(..), MockServer(..), withMockServer, mockServerSpec ) where -#if __GLASGOW_HASKELL__ < 710-import Control.Applicative-#endif import Control.Concurrent import Control.Monad import qualified Data.ByteString as B import qualified Data.ByteString.Char8 as C import Data.IORef+import Database.Memcache.Types (Authentication (NoAuth), ServerSpec (..)) import qualified Network.Socket as N import qualified Network.Socket.ByteString as N import Text.Read (readMaybe)-import UnliftIO.Exception (SomeException, bracket, handle,+import UnliftIO.Exception (SomeException, bracket, finally, handle, throwIO) -- | Actions the mock server can take to a request. data MockResponse+ -- | Reply with these bytes. = MR B.ByteString+ -- | Close the client connection instead of replying. | CloseConnection+ -- | Wait this many milliseconds, then take the given action. | DelayMS Int MockResponse+ -- | Read the request but send nothing back. | Noop --- | Run an IO action with a mock Memcached server running in the background,--- killing it once done.-withMCServer :: Bool -> [MockResponse] -> IO () -> IO ()-withMCServer loop res m = do- sem <- newEmptyMVar+-- | A running mock server.+data MockServer = MockServer+ { -- | The port the mock is listening on.+ mockPort :: N.PortNumber+ -- | Every request received so far, oldest first, including any data+ -- block that followed the command line.+ , mockRequests :: IO [B.ByteString]+ } - let waitForInitialization = takeMVar sem+-- | A server specification for connecting to the mock without authentication.+mockServerSpec :: MockServer -> ServerSpec+mockServerSpec server = ServerSpec "127.0.0.1" (show (mockPort server)) NoAuth +-- | Run an action with a mock Memcached server running in the background,+-- killing it once done. The server answers requests with the given responses+-- in order, one per request, across however many connections the client+-- makes; once they run out it closes the connection and stops listening.+withMockServer :: [MockResponse] -> (MockServer -> IO a) -> IO a+withMockServer responses action = do+ ready <- newEmptyMVar+ received <- newIORef [] bracket- (mockMCServer loop res sem)- (\tid -> killThread tid >> threadDelay 100000)- (const $ waitForInitialization >> m)---- | New mock Memcached server that responds to each request with the specified--- list of responses.-mockMCServer :: Bool -> [MockResponse] -> MVar () -> IO ThreadId-mockMCServer loop resp' sem = forkIO $ bracket- (N.socket N.AF_INET N.Stream N.defaultProtocol)- N.close- $ \sock -> do+ (forkIO (serve ready received))+ killThread+ (const $ do+ port <- takeMVar ready+ action MockServer+ { mockPort = port+ , mockRequests = reverse <$> readIORef received+ })+ where+ serve ready received = bracket+ (N.socket N.AF_INET N.Stream N.defaultProtocol)+ N.close+ $ \sock -> do N.setSocketOption sock N.ReuseAddr 1- let hints = N.defaultHints {- N.addrFlags = [N.AI_PASSIVE]- , N.addrSocketType = N.Stream- , N.addrFamily = N.AF_INET- }- addr:_ <- N.getAddrInfo (Just hints) Nothing (Just "11211")- N.bind sock $ N.addrAddress addr+ N.bind sock (N.SockAddrInet 0 (N.tupleToHostAddress (127, 0, 0, 1))) N.listen sock 10- ref <- newIORef resp'-- -- Publish that initialization is done- putMVar sem ()+ N.socketPort sock >>= putMVar ready+ remaining <- newIORef responses+ -- Once the responses run out the listening socket closes, so later+ -- connection attempts are refused straight away.+ acceptLoop sock remaining received - acceptHandler sock ref- when loop $ forever $ threadDelay 1000000+ acceptLoop sock remaining received = do+ pending <- readIORef remaining+ unless (null pending) $ do+ (client, _) <- N.accept sock+ handle ignore (clientHandler client remaining received)+ `finally` N.close client+ acceptLoop sock remaining received - where- acceptHandler sock ref = do- client <- fst <$> N.accept sock- resp <- readIORef ref- cont <- handle allErrors $ clientHandler client ref resp- when cont $ acceptHandler sock ref+ ignore :: SomeException -> IO ()+ ignore = const (return ()) - allErrors :: SomeException -> IO Bool- allErrors = const $ return True+ -- Answer requests on one connection until the responses run out or the+ -- script closes it.+ clientHandler client remaining received = do+ pending <- readIORef remaining+ case pending of+ [] -> return ()+ (r:rest) -> do+ request <- recvReq client+ modifyIORef' received (request :)+ writeIORef remaining rest+ continue <- respond client r+ when continue $ clientHandler client remaining received - clientHandler client _ [] = N.close client >> return False- clientHandler client ref (r':resp) = do- void $ recvReq client- mrHandler r'- where- mrHandler r = case r of- Noop -> clientHandler client ref resp- (MR mr) -> N.sendAll client mr >> clientHandler client ref resp- (DelayMS ms mr) -> do- writeIORef ref resp -- client may reset connection- threadDelay (ms * 1000)- mrHandler mr- CloseConnection -> do- N.close client- writeIORef ref resp- return $ not $ null resp+ respond client r = case r of+ Noop -> return True+ MR bytes -> N.sendAll client bytes >> return True+ DelayMS ms r' -> threadDelay (ms * 1000) >> respond client r'+ CloseConnection -> return False -recvReq :: N.Socket -> IO ()+-- | Read one request: its command line and, for storage commands, the data+-- block that follows it.+recvReq :: N.Socket -> IO B.ByteString recvReq s = do line <- recvLine s [] case payloadLen (C.words line) of- Just n -> void (recvAll s n >> recvLine s [])- Nothing -> return ()+ Just n -> do+ payload <- recvAll s n+ trailer <- recvLine s []+ return (line <> "\n" <> payload <> trailer <> "\n")+ Nothing -> return (line <> "\n") where -- Only these carry a data block; guessing by token position instead sees -- a payload in commands like @stats cachedump 1 100@ and then hangs.@@ -113,6 +132,8 @@ else (chunk <>) <$> recvAll socket (n - B.length chunk) where eof = userError "mock server EOF" +-- | Read up to and excluding the next @\\n@, one byte at a time so that+-- nothing past the line is consumed. recvLine :: N.Socket -> [B.ByteString] -> IO B.ByteString recvLine socket acc = do chunk <- N.recv socket 1
test/Spec.hs view
@@ -5,17 +5,23 @@ import MockServer import qualified Database.Memcache.Auth as Auth import qualified Database.Memcache.Client as Client+import qualified Database.Memcache.ElastiCacheClient as EC import Database.Memcache.Errors import qualified Database.Memcache.Errors as E import Database.Memcache.Socket+import Database.Memcache.Types (ServerSpec (..), parseServerSpec) import Test.Hspec+import Test.Hspec.QuickCheck (modifyMaxSuccess, prop)+import Test.QuickCheck+import qualified Data.ByteString as B import qualified Data.ByteString.Base64 as Base64 import qualified Data.ByteString.Char8 as C import qualified Network.Socket as N import qualified Network.Socket.ByteString as N-import Control.Concurrent (forkIO)+import Control.Concurrent (forkIO, threadDelay) import Control.Exception (bracket) import Data.Either (isLeft)+import System.Timeout (timeout) main :: IO () main = hspec $ do@@ -33,9 +39,50 @@ it "rejects empty keys" $ encodeKey "" `shouldSatisfy` isLeft + it "accepts a key of exactly 250 bytes unchanged" $+ encodeKey (C.replicate 250 'a') `shouldBe` Right (WireKey (C.replicate 250 'a') False)++ it "base64-encodes keys containing control bytes or DEL" $ do+ fmap wireB64 (encodeKey "tab\tkey") `shouldBe` Right True+ fmap wireB64 (encodeKey "line\nkey") `shouldBe` Right True+ fmap wireB64 (encodeKey "del\DELkey") `shouldBe` Right True++ it "sends bytes above 0x7f unencoded" $+ encodeKey "caf\xc3\xa9" `shouldBe` Right (WireKey "caf\xc3\xa9" False)++ it "rejects a key whose base64 form exceeds 250 bytes" $ do+ -- 186 bytes encode to 248 base64 bytes; 187 bytes encode to 252.+ fmap (B.length . wireKey) (encodeKey (C.replicate 186 ' ')) `shouldBe` Right 248+ encodeKey (C.replicate 187 ' ') `shouldSatisfy` isLeft++ prop "round-trips every key it accepts" $+ forAll keyGen $ \key -> case encodeKey key of+ Right (WireKey bytes True) ->+ Base64.decode bytes === Right key .&&. B.length bytes <= 250+ Right (WireKey bytes False) ->+ bytes === key .&&. not (B.any unsafeByte key)+ Left _ ->+ property (B.length key > 250 || (B.any unsafeByte key && base64Length key > 250))++ prop "only ever sends safe bytes as a key" $+ forAll keyGen $ \key -> case encodeKey key of+ Right (WireKey bytes _) -> not (B.any unsafeByte bytes)+ Left _ -> True++ prop "encodes each non-storage request as exactly one line" $+ forAll keyGen $ \key -> case encodeKey key of+ Left _ -> property True+ Right w -> conjoin+ [ oneLine (getRequest w)+ , oneLine (getManyRequest w)+ , oneLine (gatRequest w 30)+ , oneLine (touchRequest w 30)+ , oneLine (deleteRequest w 7)+ , oneLine (arithmeticRequest Incr w 1 2 30 7)+ ]+ it "rejects over-long keys without contacting the server" $- withMCServer False [MR "VA 3 f2 c7\r\nfoo\r\n"] $ do- client <- Client.newClient [Client.def] Client.def+ withClient [MR "VA 3 f2 c7\r\nfoo\r\n"] $ \client -> do Client.get client (C.replicate 251 'a') `shouldThrow` isKeyTooLong Client.get client "key" `shouldReturn` Just ("foo", 2, 7) @@ -46,6 +93,7 @@ it "encodes all core request forms" $ do getRequest (wire "key") `shouldBe` "mg key v f c\r\n"+ getManyRequest (wire "key") `shouldBe` "mg key v f c k q\r\n" gatRequest (wire "key") 30 `shouldBe` "mg key v f c T30\r\n" touchRequest (wire "key") 30 `shouldBe` "mg key T30 c\r\n" deleteRequest (wire "key") 9 `shouldBe` "md key C9\r\n"@@ -55,11 +103,28 @@ statsRequest Nothing `shouldBe` "stats\r\n" statsRequest (Just "key") `shouldBe` "stats key\r\n" quitRequest `shouldBe` "quit\r\n"+ noOpRequest `shouldBe` "mn\r\n"+ authRequest "user pass" `shouldBe` "set auth 0 0 9\r\nuser pass\r\n" + it "flags encoded keys on every keyed request" $ do+ let encoded = Base64.encode "a b"+ getRequest (wire "a b") `shouldBe` "mg " <> encoded <> " b v f c\r\n"+ deleteRequest (wire "a b") 0 `shouldBe` "md " <> encoded <> " b\r\n"+ modifyRequest Append (wire "a b") "x" 0 `shouldBe` "ms " <> encoded <> " 1 MA b c\r\nx\r\n"+ it "places the binary-key flag after the data length" $ storeRequest Set (wire "a b") "value" 3 20 0 `shouldBe` "ms " <> Base64.encode "a b" <> " 5 F3 T20 MS b c\r\nvalue\r\n" + it "encodes store modes and CAS" $ do+ storeRequest Add (wire "key") "v" 1 2 0 `shouldBe` "ms key 1 F1 T2 ME c\r\nv\r\n"+ storeRequest Replace (wire "key") "v" 1 2 5 `shouldBe` "ms key 1 F1 T2 C5 MR c\r\nv\r\n"+ modifyRequest Append (wire "key") "xyz" 5 `shouldBe` "ms key 3 MA C5 c\r\nxyz\r\n"+ modifyRequest Prepend (wire "key") "xyz" 0 `shouldBe` "ms key 3 MP c\r\nxyz\r\n"++ it "encodes arithmetic with auto-creation" $+ arithmeticRequest Decr (wire "n") 10 2 60 7 `shouldBe` "ma n D2 C7 MD v c N60 J10\r\n"+ it "omits arithmetic defaults at the maximum expiration" $ arithmeticRequest Incr (wire "key") 0 1 maxBound 0 `shouldBe` "ma key D1 MI v c\r\n"@@ -67,6 +132,55 @@ it "omits zero CAS values" $ storeRequest Set (wire "key") "v" 0 0 0 `shouldBe` "ms key 1 F0 T0 MS c\r\nv\r\n" + -- Most encoders write into a single buffer for speed; check them all+ -- against the plainest possible spelling of each request.+ prop "encodes every request as the concatenation of its pieces" $+ forAll wireKeyGen $ \key ->+ forAll requestValueGen $ \value ->+ forAll ((,,) <$> numberGen <*> numberGen <*> numberGen) $ \(flags, expiry, version) ->+ forAll ((,) <$> numberGen <*> numberGen) $ \(initial, delta) ->+ forAll ((,) <$> elements [Set, Add, Replace, Append, Prepend] <*> elements [Incr, Decr]) $ \(mode, arith) ->+ let keyArgs = wireKey key <> binaryFlag key+ binaryFlag k = if wireB64 k then " b" else ""+ casArg n = if n == 0 then "" else " C" <> decimal n+ decimal :: Show a => a -> B.ByteString+ decimal = C.pack . show+ modeLetter m = case m of+ Set -> "S"+ Add -> "E"+ Replace -> "R"+ Append -> "A"+ Prepend -> "P"+ arithLetter m = case m of+ Incr -> "I"+ Decr -> "D"+ in conjoin+ [ getRequest key === B.concat ["mg ", keyArgs, " v f c\r\n"]+ , getManyRequest key === B.concat ["mg ", keyArgs, " v f c k q\r\n"]+ , gatRequest key expiry === B.concat ["mg ", keyArgs, " v f c T", decimal expiry, "\r\n"]+ , touchRequest key expiry === B.concat ["mg ", keyArgs, " T", decimal expiry, " c\r\n"]+ , storeRequest mode key value flags expiry version === B.concat+ [ "ms ", wireKey key, " ", decimal (B.length value), " F", decimal flags+ , " T", decimal expiry, casArg version, " M", modeLetter mode, binaryFlag key+ , " c\r\n", value, "\r\n" ]+ , modifyRequest mode key value version === B.concat+ [ "ms ", wireKey key, " ", decimal (B.length value), " M", modeLetter mode+ , binaryFlag key, casArg version, " c\r\n", value, "\r\n" ]+ , arithmeticRequest arith key initial delta expiry version === B.concat+ [ "ma ", keyArgs, " D", decimal delta, casArg version, " M", arithLetter arith, " v c"+ , if expiry == maxBound then "" else " N" <> decimal expiry <> " J" <> decimal initial+ , "\r\n" ]+ , deleteRequest key version === B.concat ["md ", keyArgs, casArg version, "\r\n"]+ , flushRequest (Just expiry) === B.concat ["flush_all ", decimal expiry, "\r\n"]+ , flushRequest Nothing === "flush_all\r\n"+ , statsRequest Nothing === "stats\r\n"+ , statsRequest (Just (wireKey key)) === B.concat ["stats ", wireKey key, "\r\n"]+ , versionRequest === "version\r\n"+ , quitRequest === "quit\r\n"+ , noOpRequest === "mn\r\n"+ , authRequest value === B.concat ["set auth 0 0 ", decimal (B.length value), "\r\n", value, "\r\n"]+ ]+ describe "response parsing" $ do it "parses values and protocol errors" $ do recvResponseFrom "VA 3 f7 c9 O2\r\nabc\r\n" `shouldReturn` Response "VA" ["3", "f7", "c9", "O2"] "abc"@@ -76,6 +190,7 @@ it "maps protocol statuses" $ do (recvResponseFrom "VA 0 f1 c2\r\n\r\n" >>= responseStatus) `shouldReturn` NoError (recvResponseFrom "EN\r\n" >>= responseStatus) `shouldReturn` ErrKeyNotFound+ (recvResponseFrom "NF\r\n" >>= responseStatus) `shouldReturn` ErrKeyNotFound (recvResponseFrom "HD\r\n" >>= responseStatus) `shouldReturn` NoError (recvResponseFrom "EX\r\n" >>= responseStatus) `shouldReturn` ErrKeyExists (recvResponseFrom "NS\r\n" >>= responseStatus) `shouldReturn` ErrItemNotStored@@ -83,6 +198,31 @@ (recvResponseFrom "VERSION 1.6.0\r\n" >>= responseStatus) `shouldReturn` NoError (recvResponseFrom "STAT curr_items 2\r\n" >>= responseStatus) `shouldReturn` NoError + it "maps server error text back to operation statuses" $ do+ (recvResponseFrom "SERVER_ERROR object too large for cache\r\n" >>= responseStatus)+ `shouldThrow` (== OpError ErrValueTooLarge)+ (recvResponseFrom "SERVER_ERROR out of memory storing object\r\n" >>= responseStatus)+ `shouldThrow` (== OpError ErrOutOfMemory)+ (recvResponseFrom "CLIENT_ERROR cannot increment or decrement non-numeric value\r\n" >>= responseStatus)+ `shouldThrow` (== OpError ErrValueNonNumeric)++ it "rejects unknown and empty response lines" $ do+ (recvResponseFrom "ERROR\r\n" >>= responseStatus) `shouldThrow` isUnknownOp+ (recvResponseFrom "XX\r\n" >>= responseStatus) `shouldThrow` isUnknownStatus+ recvResponseFrom "\r\n" `shouldThrow` isUnknownPkt++ it "rejects a value without its trailing line break" $+ recvResponseFrom "VA 3\r\nabcX\r\n" `shouldThrow` isBadLength++ it "reads flags, CAS and numbers from responses" $ do+ responseCas (Response "HD" ["c42"] "") `shouldBe` 42+ responseCas (Response "HD" [] "") `shouldBe` 0+ responseCas (Response "HD" ["cxyz"] "") `shouldBe` 0+ responseFlags (Response "VA" ["5", "f7", "c9"] "") `shouldBe` 7+ responseFlags (Response "VA" ["5"] "") `shouldBe` 0+ responseNumber (Response "VA" ["2"] "42") `shouldBe` 42+ responseNumber (Response "VA" ["3"] "abc") `shouldBe` 0+ describe "connection buffering" $ do it "keeps bytes after a parsed response" $ bracket@@ -99,6 +239,28 @@ _ <- forkIO $ N.sendAll right "VA 5 f1 c2\r\nhe" >> N.sendAll right "llo\r\n" recvResponse connection `shouldReturn` Response "VA" ["5", "f1", "c2"] "hello" + modifyMaxSuccess (const 50) $+ prop "parses responses however they are split across packets" $+ forAll ((,) <$> valueGen <*> listOf (choose (0, 1.0 :: Double))) $ \(value, cuts) ->+ ioProperty $ do+ let bytes = "VA " <> C.pack (show (B.length value)) <> " f1 c2\r\n"+ <> value <> "\r\nHD c3\r\n"+ pieces = splitAtFractions cuts bytes+ bracket (N.socketPair N.AF_UNIX N.Stream 0) closePair $ \(left, right) -> do+ connection <- newConnection left+ _ <- forkIO $ mapM_ (\piece -> N.sendAll right piece >> threadDelay 200) pieces+ first <- recvResponse connection+ second <- recvResponse connection+ return $ first === Response "VA" [C.pack (show (B.length value)), "f1", "c2"] value+ .&&. second === Response "HD" ["c3"] ""++ it "reads through a delimiter split across packets" $+ bracket (N.socketPair N.AF_UNIX N.Stream 0) closePair $ \(left, right) -> do+ connection <- newConnection left+ _ <- forkIO $ N.sendAll right "CONFIG x\r\nEN" >> threadDelay 1000 >> N.sendAll right "D\r\nrest"+ recvRawUntil "END\r\n" connection `shouldReturn` "CONFIG x\r\nEND\r\n"+ recvExact connection 4 `shouldReturn` "rest"+ it "reports EOF in a value" $ bracket (N.socketPair N.AF_UNIX N.Stream 0) closePair $ \(left, right) -> do connection <- newConnection left@@ -113,75 +275,197 @@ describe "getMany" $ do it "matches echoed keys and skips misses" $- withMCServer False [MR "VA 5 f1 c11 kone\r\nfirst\r\n", MR "MN\r\n"] $ do- client <- Client.newClient [Client.def] Client.def- Client.getMany client ["one", "two"] `shouldReturn` [("one", ("first", 1, 11))]+ withServerAndClient [MR "VA 5 f1 c11 kone\r\nfirst\r\n", Noop, MR "MN\r\n"] $ \server client -> do+ Client.getMany client ["one", "two"] `shouldReturn` [("one", ("first", 1, 11))]+ mockRequests server `shouldReturn`+ ["mg one v f c k q\r\n", "mg two v f c k q\r\n", "mn\r\n"] + it "maps encoded keys back to the caller's key" $ do+ let encoded = Base64.encode "a b"+ withClient [MR ("VA 3 f0 c4 k" <> encoded <> " b\r\nabc\r\n"), MR "MN\r\n"] $ \client ->+ Client.getMany client ["a b"] `shouldReturn` [("a b", ("abc", 0, 4))]++ it "tells a plain key from another key's base64 form" $+ -- " " is sent, and echoed, as IA== with the b flag.+ withClient [MR "VA 1 f0 c1 kIA==\r\na\r\n", MR "VA 1 f0 c2 kIA== b\r\nb\r\n", MR "MN\r\n"] $ \client ->+ Client.getMany client ["IA==", " "] `shouldReturn` [("IA==", ("a", 0, 1)), (" ", ("b", 0, 2))]+ describe "client operations" $ do it "gets a hit" $- withMCServer False [MR "VA 3 f2 c7\r\nfoo\r\n"] $ do- client <- Client.newClient [Client.def] Client.def+ withServerAndClient [MR "VA 3 f2 c7\r\nfoo\r\n"] $ \server client -> do Client.get client "key" `shouldReturn` Just ("foo", 2, 7)+ mockRequests server `shouldReturn` ["mg key v f c\r\n"] it "returns Nothing for a miss" $- withMCServer False [MR "EN\r\n"] $ do- client <- Client.newClient [Client.def] Client.def+ withClient [MR "EN\r\n"] $ \client -> Client.get client "key" `shouldReturn` Nothing + it "rejects a reply meant for a different command" $+ withClient [MR "HD\r\n"] $ \client ->+ Client.get client "key" `shouldThrow` isUnexpectedResponse++ it "rejects an unknown reply" $+ withClient [MR "XX\r\n"] $ \client ->+ Client.get client "key" `shouldThrow` isUnknownStatus++ it "gets and touches a value" $+ withServerAndClient [MR "VA 3 f2 c7\r\nfoo\r\n", MR "EN\r\n"] $ \server client -> do+ Client.gat client "key" 60 `shouldReturn` Just ("foo", 2, 7)+ Client.gat client "key" 60 `shouldReturn` Nothing+ mockRequests server `shouldReturn` ["mg key v f c T60\r\n", "mg key v f c T60\r\n"]++ it "touches a value" $+ withClient [MR "HD c3\r\n", MR "EN\r\n"] $ \client -> do+ Client.touch client "key" 60 `shouldReturn` Just 3+ Client.touch client "key" 60 `shouldReturn` Nothing+ it "stores and returns the server CAS" $- withMCServer False [MR "HD c9\r\n"] $ do- client <- Client.newClient [Client.def] Client.def+ withServerAndClient [MR "HD c9\r\n"] $ \server client -> do Client.set client "key" "foo" 2 30 `shouldReturn` 9+ mockRequests server `shouldReturn` ["ms key 3 F2 T30 MS c\r\nfoo\r\n"] + it "reports a set the server did not store" $+ withClient [MR "NS\r\n"] $ \client ->+ Client.set client "key" "foo" 0 0 `shouldThrow` (== OpError ErrItemNotStored)++ it "adds only when the key is new" $+ withClient [MR "HD c5\r\n", MR "NS\r\n"] $ \client -> do+ Client.add client "key" "v" 0 0 `shouldReturn` Just 5+ Client.add client "key" "v" 0 0 `shouldReturn` Nothing++ it "replaces only when the key exists and the CAS matches" $+ withClient [MR "HD c8\r\n", MR "NS\r\n", MR "NF\r\n", MR "EX\r\n"] $ \client -> do+ Client.replace client "key" "v" 0 0 0 `shouldReturn` Just 8+ Client.replace client "key" "v" 0 0 0 `shouldReturn` Nothing+ Client.replace client "key" "v" 0 0 4 `shouldReturn` Nothing+ Client.replace client "key" "v" 0 0 4 `shouldReturn` Nothing++ it "compares and swaps" $+ withServerAndClient [MR "HD c3\r\n", MR "EX\r\n", MR "NF\r\n"] $ \server client -> do+ Client.cas client "key" "v" 0 0 2 `shouldReturn` Just 3+ Client.cas client "key" "v" 0 0 2 `shouldReturn` Nothing+ Client.cas client "key" "v" 0 0 2 `shouldReturn` Nothing+ requests <- mockRequests server+ requests `shouldSatisfy` all (== "ms key 1 F0 T0 C2 MS c\r\nv\r\n")+ it "deletes a present key" $- withMCServer False [MR "HD\r\n"] $ do- client <- Client.newClient [Client.def] Client.def+ withClient [MR "HD\r\n"] $ \client -> Client.delete client "key" 0 `shouldReturn` True + it "reports a delete of a missing key or with a stale CAS" $+ withClient [MR "NF\r\n", MR "EX\r\n"] $ \client -> do+ Client.delete client "key" 0 `shouldReturn` False+ Client.delete client "key" 5 `shouldReturn` False+ it "does not retry a command the server rejected" $- withMCServer False [MR "CLIENT_ERROR bad\r\n", MR "VA 3 f2 c7\r\nfoo\r\n"] $ do- client <- Client.newClient [Client.def] Client.def+ withClient [MR "CLIENT_ERROR bad\r\n", MR "VA 3 f2 c7\r\nfoo\r\n"] $ \client -> Client.get client "key" `shouldThrow` isBadCommand it "reads version" $- withMCServer False [MR "VERSION 1.6.0\r\n"] $ do- client <- Client.newClient [Client.def] Client.def+ withClient [MR "VERSION 1.6.0\r\n"] $ \client -> Client.version client `shouldReturn` "1.6.0" it "collects stats until END, keeping values that contain spaces" $- withMCServer False [MR "STAT curr_items 2\r\nSTAT rusage_user 0.1 0.2\r\nEND\r\n"] $ do- client <- Client.newClient [Client.def] Client.def+ withClient [MR "STAT curr_items 2\r\nSTAT rusage_user 0.1 0.2\r\nEND\r\n"] $ \client -> do result <- Client.stats client Nothing result `shouldSatisfy` allStats it "allows stats arguments containing spaces" $- withMCServer False [MR "END\r\n"] $ do- client <- Client.newClient [Client.def] Client.def+ withServerAndClient [MR "END\r\n"] $ \server client -> do result <- Client.stats client (Just "cachedump 1 100") map snd result `shouldBe` [[]]+ mockRequests server `shouldReturn` ["stats cachedump 1 100\r\n"] + it "keeps non-STAT stats lines" $+ withClient [MR "ITEM key [3 b; 0 s]\r\nEND\r\n"] $ \client -> do+ result <- Client.stats client (Just "cachedump 1 1")+ map snd result `shouldBe` [[("ITEM", "key [3 b; 0 s]")]]+ it "returns Nothing when arithmetic cannot create the item" $- withMCServer False [MR "NS\r\n"] $ do- client <- Client.newClient [Client.def] Client.def+ withClient [MR "NS\r\n"] $ \client -> Client.increment client "counter" 0 1 30 0 `shouldReturn` Nothing + it "returns the new counter value and CAS" $+ withServerAndClient [MR "VA 1 c2\r\n0\r\n"] $ \server client -> do+ Client.decrement client "counter" 10 1 60 0 `shouldReturn` Just (0, 2)+ mockRequests server `shouldReturn` ["ma counter D1 MD v c N60 J10\r\n"]++ it "reports arithmetic on a non-numeric value" $+ withClient [MR "CLIENT_ERROR cannot increment or decrement non-numeric value\r\n"] $ \client ->+ Client.increment client "key" 0 1 0 0 `shouldThrow` (== OpError ErrValueNonNumeric)+ it "returns Nothing appending to a missing key" $- withMCServer False [MR "NS\r\n"] $ do- client <- Client.newClient [Client.def] Client.def+ withClient [MR "NS\r\n"] $ \client -> Client.append client "key" "more" 0 `shouldReturn` Nothing + it "prepends to an existing key" $+ withServerAndClient [MR "HD c4\r\n"] $ \server client -> do+ Client.prepend client "key" "pre" 0 `shouldReturn` Just 4+ mockRequests server `shouldReturn` ["ms key 3 MP c\r\npre\r\n"]++ it "flushes" $+ withServerAndClient [MR "OK\r\n"] $ \server client -> do+ Client.flush client (Just 10) `shouldReturn` ()+ mockRequests server `shouldReturn` ["flush_all 10\r\n"]+ it "reports an oversized value as a status, not a protocol failure" $- withMCServer False [MR "SERVER_ERROR object too large for cache\r\n"] $ do- client <- Client.newClient [Client.def] Client.def+ withClient [MR "SERVER_ERROR object too large for cache\r\n"] $ \client -> Client.set client "key" "foo" 0 0 `shouldThrow` (== OpError ErrValueTooLarge) + it "reports a server out of memory as a status" $+ withClient [MR "SERVER_ERROR out of memory storing object\r\n"] $ \client ->+ Client.set client "key" "foo" 0 0 `shouldThrow` (== OpError ErrOutOfMemory)+ it "returns no stats on a reset reply" $- withMCServer False [MR "RESET\r\n"] $ do- client <- Client.newClient [Client.def] Client.def+ withClient [MR "RESET\r\n"] $ \client -> do result <- Client.stats client Nothing map snd result `shouldBe` [[]] - describe "authenticate" $+ it "sends quit" $+ withServerAndClient [Noop] $ \server client -> do+ Client.quit client+ requests <- waitForRequests server 1+ requests `shouldBe` ["quit\r\n"]++ describe "retries and failover" $ do+ let fast = Client.def+ { Client.optsServerTimeout = 300+ , Client.optsFailRetryDelay = 10+ , Client.optsDeadRetryDelay = 300+ }++ it "retries after the server drops the connection" $+ withServerAndClientOpts fast [CloseConnection, MR "VA 3 f2 c7\r\nfoo\r\n"] $ \server client -> do+ Client.get client "key" `shouldReturn` Just ("foo", 2, 7)+ length <$> mockRequests server `shouldReturn` 2++ it "retries after an operation times out" $+ withServerAndClientOpts fast [DelayMS 350 Noop, MR "VA 3 f2 c7\r\nfoo\r\n"] $ \_ client ->+ Client.get client "key" `shouldReturn` Just ("foo", 2, 7)++ it "marks a server dead once its retries run out, then revives it" $+ withServerAndClientOpts fast [CloseConnection, CloseConnection, MR "VA 3 f2 c7\r\nfoo\r\n"] $ \server client -> do+ -- The default of two retries means two attempts in total.+ Client.get client "key" `shouldThrow` isUnexpectedEOF+ length <$> mockRequests server `shouldReturn` 2+ Client.get client "key" `shouldThrow` (== ClientError NoServersReady)+ threadDelay 400000+ Client.get client "key" `shouldReturn` Just ("foo", 2, 7)++ describe "authenticate" $ do+ it "accepts credentials once the server confirms auth-file mode" $+ bracket (N.socketPair N.AF_UNIX N.Stream 0) closePair $ \(left, right) -> do+ connection <- newConnection left+ _ <- forkIO $ N.sendAll right "CLIENT_ERROR unauthenticated\r\nSTORED\r\n"+ Auth.authenticate connection (Auth.Auth "user" "pass") `shouldReturn` ()+ recvExactly right (B.length expectedAuthRequests) `shouldReturn` expectedAuthRequests++ it "reports rejected credentials" $+ bracket (N.socketPair N.AF_UNIX N.Stream 0) closePair $ \(left, right) -> do+ connection <- newConnection left+ _ <- forkIO $ N.sendAll right "CLIENT_ERROR unauthenticated\r\nCLIENT_ERROR authentication failure\r\n"+ Auth.authenticate connection (Auth.Auth "user" "pass") `shouldThrow` (== OpError TextAuthFail)+ it "refuses to send credentials when the server is not auth-gated" $ bracket (N.socketPair N.AF_UNIX N.Stream 0)@@ -189,6 +473,123 @@ connection <- newConnection left _ <- forkIO $ N.sendAll right "VERSION 1.6\r\n" Auth.authenticate connection (Auth.Auth "user" "pass") `shouldThrow` isInvalidAuthentication++ it "rejects credentials containing delimiters before contacting the server" $+ bracket (N.socketPair N.AF_UNIX N.Stream 0) closePair $ \(left, _) -> do+ connection <- newConnection left+ Auth.authenticate connection (Auth.Auth "us er" "pass") `shouldThrow` isInvalidAuthentication++ it "does nothing without credentials" $+ bracket (N.socketPair N.AF_UNIX N.Stream 0) closePair $ \(left, _) -> do+ connection <- newConnection left+ Auth.authenticate connection Auth.NoAuth `shouldReturn` ()++ it "validates credential delimiters" $ do+ Auth.validateCredentials "user" "pass" `shouldBe` Right ()+ mapM_ (\c -> Auth.validateCredentials ("us" <> c <> "er") "pass" `shouldSatisfy` isLeft)+ [" ", "\t", "\r", "\n", ":"]+ mapM_ (\c -> Auth.validateCredentials "user" ("pa" <> c <> "ss") `shouldSatisfy` isLeft)+ [" ", "\t", "\r", "\n"]++ it "authenticates each new client connection" $+ withMockServer [MR "CLIENT_ERROR unauthenticated\r\n", MR "STORED\r\n", MR "VA 3 f2 c7\r\nfoo\r\n"] $ \server -> do+ let spec = (mockServerSpec server) { ssAuth = Auth.Auth "user" "pass" }+ client <- Client.newClient [spec] Client.def+ Client.get client "key" `shouldReturn` Just ("foo", 2, 7)+ mockRequests server `shouldReturn`+ ["version\r\n", "set auth 0 0 9\r\nuser pass\r\n", "mg key v f c\r\n"]++ describe "server URIs" $ do+ it "parses host and port" $+ parseServerSpec "memcached://cache.example:1234" `shouldBe`+ Right (ServerSpec "cache.example" "1234" Auth.NoAuth)++ it "defaults the port and host" $ do+ parseServerSpec "memcached://cache.example" `shouldBe`+ Right (ServerSpec "cache.example" "11211" Auth.NoAuth)+ parseServerSpec "memcached://" `shouldBe`+ Right (ServerSpec "127.0.0.1" "11211" Auth.NoAuth)++ it "parses credentials" $+ parseServerSpec "memcached://user:secret@cache.example:1234" `shouldBe`+ Right (ServerSpec "cache.example" "1234" (Auth.Auth "user" "secret"))++ it "ignores incomplete credentials" $ do+ parseServerSpec "memcached://user@cache.example" `shouldBe`+ Right (ServerSpec "cache.example" "11211" Auth.NoAuth)+ parseServerSpec "memcached://:secret@cache.example" `shouldBe`+ Right (ServerSpec "cache.example" "11211" Auth.NoAuth)++ it "rejects other schemes and invalid URIs" $ do+ parseServerSpec "http://cache.example" `shouldSatisfy` isLeft+ parseServerSpec "not a uri" `shouldSatisfy` isLeft++ describe "clusters" $ do+ it "fails over to another server once one is marked dead" $+ withMockServer [MR "VA 1 f0 c1\r\nA\r\n", CloseConnection, CloseConnection] $ \a ->+ withMockServer [MR "VA 1 f0 c1\r\nB\r\n", CloseConnection, CloseConnection] $ \b -> do+ client <- Client.newClient [mockServerSpec a, mockServerSpec b] fastFailover+ first <- Client.get client "key"+ -- The server that answered now drops two connections in a row, which+ -- uses up its retries and marks it dead...+ Client.get client "key" `shouldThrow` isUnexpectedEOF+ -- ...so the same key is now served by the other server.+ second <- Client.get client "key"+ map (fmap fst3) [first, second] `shouldSatisfy` (`elem` [[Just "A", Just "B"], [Just "B", Just "A"]])++ it "throws NoServersReady once every server is dead" $+ withMockServer [CloseConnection, CloseConnection] $ \a -> do+ client <- Client.newClient [mockServerSpec a] fastFailover+ Client.get client "key" `shouldThrow` isUnexpectedEOF+ Client.get client "key" `shouldThrow` (== ClientError NoServersReady)+ Client.flush client Nothing `shouldThrow` (== ClientError NoServersReady)+ Client.version client `shouldThrow` (== ClientError NoServersReady)++ it "flushes every server" $+ withMockServer [MR "OK\r\n"] $ \a ->+ withMockServer [MR "OK\r\n"] $ \b -> do+ client <- Client.newClient [mockServerSpec a, mockServerSpec b] Client.def+ Client.flush client Nothing+ mockRequests a `shouldReturn` ["flush_all\r\n"]+ mockRequests b `shouldReturn` ["flush_all\r\n"]++ it "collects stats from every server" $+ withMockServer [MR "STAT pid 1\r\nEND\r\n"] $ \a ->+ withMockServer [MR "STAT pid 2\r\nEND\r\n"] $ \b -> do+ client <- Client.newClient [mockServerSpec a, mockServerSpec b] Client.def+ results <- Client.stats client Nothing+ concatMap snd results `shouldMatchList` [("pid", "1"), ("pid", "2")]++ it "asks a single server for the version" $+ withMockServer [MR "VERSION 1.6.1\r\n"] $ \a ->+ withMockServer [MR "VERSION 1.6.1\r\n"] $ \b -> do+ client <- Client.newClient [mockServerSpec a, mockServerSpec b] Client.def+ Client.version client `shouldReturn` "1.6.1"+ requests <- (++) <$> mockRequests a <*> mockRequests b+ requests `shouldBe` ["version\r\n"]++ describe "ElastiCache discovery" $ do+ it "rejects an endpoint that is not a configuration endpoint" $+ isLeft (EC.parseConfigurationEndpoint "memcached://cache.example:11211") `shouldBe` True++ it "discovers nodes with the config command" $+ withMockServer [MR "VA 3 f0 c1\r\nfoo\r\n"] $ \node -> do+ let config = "CONFIG cluster 0 " <> nodeList node <> "END\r\n"+ withMockServer [MR "VERSION 1.6.12\r\n", MR config, Noop] $ \cfg -> do+ client <- EC.newClient Client.def hour (endpoint cfg)+ Client.get client "key" `shouldReturn` Just ("foo", 0, 1)+ waitForRequests cfg 3 `shouldReturn`+ ["version\r\n", "config get cluster\r\n", "quit\r\n"]++ it "discovers nodes from the cluster key on engines before 1.4.14" $+ withMockServer [MR "VA 3 f0 c1\r\nfoo\r\n"] $ \node -> do+ let value = "VALUE AmazonElastiCache:cluster 0 " <> nodeList node <> "END\r\n"+ withMockServer [MR "VERSION 1.4.5\r\n", MR value, Noop] $ \cfg -> do+ client <- EC.newClient Client.def hour (endpoint cfg)+ Client.get client "key" `shouldReturn` Just ("foo", 0, 1)+ waitForRequests cfg 3 `shouldReturn`+ ["version\r\n", "get AmazonElastiCache:cluster\r\n", "quit\r\n"]+ where recvResponseFrom bytes = bracket@@ -210,6 +611,110 @@ isUnexpectedEOF _ = False isBadLength (ProtocolError (BadLength _)) = True isBadLength _ = False+ isUnknownOp (ProtocolError (UnknownOp _)) = True+ isUnknownOp _ = False+ isUnknownStatus (ProtocolError (UnknownStatus _)) = True+ isUnknownStatus _ = False+ isUnknownPkt (ProtocolError (UnknownPkt _)) = True+ isUnknownPkt _ = False+ isUnexpectedResponse (ProtocolError (UnexpectedResponse _)) = True+ isUnexpectedResponse _ = False closePair (left, right) = N.close left >> N.close right allStats [(_, [ ("curr_items", "2"), ("rusage_user", "0.1 0.2") ])] = True allStats _ = False+ expectedAuthRequests = "version\r\nset auth 0 0 9\r\nuser pass\r\n"+ fastFailover = Client.def { Client.optsFailRetryDelay = 10, Client.optsDeadRetryDelay = 60000 }+ fst3 (value, _, _) = value+ hour = 3600 * 1000000+ -- The endpoint check only looks for ".cfg" somewhere in the URI, so put it+ -- in the path and keep the host a plain loopback address.+ endpoint cfg = either error id $+ EC.parseConfigurationEndpoint ("memcached://127.0.0.1:" <> show (mockPort cfg) <> "/x.cfg")+ -- A config reply body listing one node, from its length line onwards.+ nodeList node =+ let body = "1\n127.0.0.1|127.0.0.1|" <> C.pack (show (mockPort node)) <> "\n"+ in C.pack (show (B.length body)) <> "\r\n" <> body <> "\r\n"++-- | Run an action with a client connected to a fresh mock server.+withClient :: [MockResponse] -> (Client.Client -> IO a) -> IO a+withClient responses action = withServerAndClient responses (const action)++withServerAndClient :: [MockResponse] -> (MockServer -> Client.Client -> IO a) -> IO a+withServerAndClient = withServerAndClientOpts Client.def++withServerAndClientOpts+ :: Client.Options -> [MockResponse] -> (MockServer -> Client.Client -> IO a) -> IO a+withServerAndClientOpts opts responses action = withMockServer responses $ \server -> do+ client <- Client.newClient [mockServerSpec server] opts+ action server client++-- | Wait (up to a second) for the mock to have received at least @n@ requests.+waitForRequests :: MockServer -> Int -> IO [B.ByteString]+waitForRequests server n = do+ result <- timeout 1000000 go+ maybe (mockRequests server) return result+ where+ go = do+ requests <- mockRequests server+ if length requests >= n then return requests else threadDelay 1000 >> go++-- | Receive exactly @n@ bytes from a socket.+recvExactly :: N.Socket -> Int -> IO B.ByteString+recvExactly _ 0 = return B.empty+recvExactly socket n = do+ chunk <- N.recv socket n+ if B.null chunk+ then return B.empty+ else (chunk <>) <$> recvExactly socket (n - B.length chunk)++-- | Keys of up to 260 arbitrary bytes, biased towards safe ones.+keyGen :: Gen B.ByteString+keyGen = B.pack <$> do+ len <- frequency [(4, choose (1, 64)), (1, choose (180, 260))]+ vectorOf len (frequency [(8, choose (0x21, 0x7e)), (1, arbitrary)])++valueGen :: Gen B.ByteString+valueGen = B.pack <$> do+ len <- choose (0, 3000)+ vectorOf len arbitrary++-- | Keys the encoder accepts, plain and base64.+wireKeyGen :: Gen WireKey+wireKeyGen = keyGen `suchThatMap` (either (const Nothing) Just . encodeKey)++-- | Request values, sometimes over the size above which+-- 'Data.ByteString.Builder.byteString' stops copying.+requestValueGen :: Gen B.ByteString+requestValueGen = frequency+ [ (4, valueGen)+ , (1, B.replicate <$> choose (8 * 1024, 20 * 1024) <*> arbitrary)+ ]++-- | Numbers of any size, with the edges of their range picked often.+numberGen :: (Arbitrary a, Bounded a, Num a) => Gen a+numberGen = frequency [(1, elements [0, 1, maxBound]), (4, arbitrary)]++unsafeByte :: (Ord a, Num a) => a -> Bool+unsafeByte c = c <= 0x20 || c == 0x7f++base64Length :: B.ByteString -> Int+base64Length key = 4 * ((B.length key + 2) `div` 3)++-- | A request line: ends in CRLF and contains no other line break.+oneLine :: B.ByteString -> Property+oneLine request =+ counterexample (show request) $+ C.count '\n' request === 1 .&&. C.count '\r' request === 1 .&&.+ property ("\r\n" `B.isSuffixOf` request)++-- | Split bytes at the given fractions of their length.+splitAtFractions :: [Double] -> B.ByteString -> [B.ByteString]+splitAtFractions cuts bytes = go 0 (map toIndex cuts) bytes+ where+ toIndex f = floor (f * fromIntegral (B.length bytes))+ go _ [] rest = [rest]+ go offset (i:is) rest+ | i <= offset = go offset is rest+ | otherwise =+ let (now, later) = B.splitAt (i - offset) rest+ in now : go i is later