memcache 0.3.0.2 → 0.4.0.0

raw patch · 23 files changed

+2009/−1391 lines, 23 filesdep +base64-bytestringdep +data-defaultdep +directorydep −binarydep −blaze-builderdep −data-default-classdep ~basedep ~bytestringdep ~criterionsetup-changedPVP ok

version bump matches the API change (PVP)

Dependencies added: base64-bytestring, data-default, directory, errors, hspec, network-uri, process, text, unliftio

Dependencies removed: binary, blaze-builder, data-default-class

Dependency ranges changed: base, bytestring, criterion, hashable, network, resource-pool, time, vector

API changes (from Hackage documentation)

Files

• CHANGELOG.md +75/−29
• Database/Memcache/Auth.hs +62/−0
• Database/Memcache/Client.hs +194/−209
• Database/Memcache/Cluster.hs +155/−72
• Database/Memcache/ElastiCacheClient.hs +190/−0
• Database/Memcache/Errors.hs +13/−17
• Database/Memcache/SASL.hs +0/−68
• Database/Memcache/Server.hs +102/−70
• Database/Memcache/Socket.hs +302/−368
• Database/Memcache/Types.hs +31/−175
• Database/Memcache/Types/Authentication.hs +32/−0
• Database/Memcache/Types/ServerSpec.hs +89/−0
• LICENSE +1/−1
• README.md +39/−29
• Setup.hs +1/−2
• TODO.md +22/−21
• bench/Parser.hs +7/−54
• memcache.cabal +115/−115
• package.yaml +100/−0
• test-integration/Integration.hs +212/−0
• test/Full.hs +0/−104
• test/MockServer.hs +52/−57
• test/Spec.hs +215/−0

@@ -1,61 +1,107 @@+# 0.4.0.0 - October 19th, 2026++- Replace the deprecated binary protocol with buffered Meta Text requests.+- Add base64 binary-key support, `getMany`, hspec tests, and `Auth`.+- Remove binary protocol and builder dependencies.+- Replace request/response wrapper types with direct Meta Text encoders and `Response`.+- Authentication now uses the server's experimental `-Y authfile` mode+  (introduced in memcached 1.5.15) instead of binary `-S` SASL.+- `encodeKey` now returns a validated `WireKey`; request builders and the+  low-level `keyedOp` APIs accept encoded keys to avoid partial validation and+  repeated encoding.+- Requires memcached 1.6.0 or newer for the meta commands.+- `stats` returns `[(Server, StatResults)]` rather than+  `[(Server, Maybe StatResults)]`; the `Nothing` case was unreachable. Stat+  values containing spaces are no longer truncated, and stats arguments may+  now contain spaces (`stats cachedump 1 100`).+- `Status` loses `ErrInvalidArgs` and `ErrUnknownCommand`, which have no Meta+  Text equivalent and now surface as `ProtocolError`. `ErrValueTooLarge`,+  `ErrOutOfMemory` and `ErrValueNonNumeric` are recovered from the server's+  error text so they keep being reported as `OpError`.+- A command the server rejects (`ERROR`, `CLIENT_ERROR`) or answers with an+  operation status is no longer retried, and no longer counts towards marking+  a server dead.+- `getMany` writes each batch in a single bounded send, so a large key list+  cannot deadlock against the server's replies.+- Response lines are capped at 8KiB, bounding memory use on a desynchronised+  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.+- 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+  `OpError ErrItemNotStored`.+- `stats` accepts replies made of lines other than `STAT`, such as those from+  `stats reset` and `stats cachedump`.+- `Database.Memcache.Socket` sends and receives on a buffered `Connection`+  with `sendRaw` and `recvResponse`, replacing `send` and `recv`.+- ElastiCache auto discovery no longer holds the server list lock while+  waiting for the next refresh.+- Exception helpers now come from `unliftio`, which is a new dependency.+- Library dependencies declare lower bounds, set to the oldest versions CI+  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.+ # 0.3.0.2 - March 27th, 2024 -* Make the key hashing algorithm configurable by clients -- that is, let+- Make the key hashing algorithm configurable by clients -- that is, let   clients provide a function mapping a key to a server.  # 0.3.0.1 - January 17th, 2021 -* No changes, needed a new release to fix a Hackage upload issue.+- No changes, needed a new release to fix a Hackage upload issue.  # 0.3.0.0 - January 17th, 2021 -* Bump package dependencies for newer GHC/back/network.-* Update code to work with newer dependencies.+- Bump package dependencies for newer GHC/back/network.+- Update code to work with newer dependencies.  # 0.2.0.1 - November 2nd, 2016 -* Fix compatability with latest `data-default-class`-* Add new ReqRaw type for external clients to implement custom requests. Quite+- Fix compatability 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.  # 0.2.0.0 - May 27th, 2016 -* Big design change to reduce code duplication (`Protocol` module gone).-* Remove `Options` type - just fixed configuration for now.-* Design change also allows proper retry handling on operation failure - we+- Big design change to reduce code duplication (`Protocol` module gone).+- Remove `Options` type - just fixed configuration for now.+- Design change also allows proper retry handling on operation failure - we   retry an operation against the same server, but after N consecutive failures,   we mark the server as dead and don't try using it again until M seconds has   passed.-* Simplify exception hierachy - just one type `MemcacheError` now for-* Remove `defaultOptions` and `defaultServerSpec`, will revist usefulness.+- Simplify exception hierachy - just one type `MemcacheError` now for+- Remove `defaultOptions` and `defaultServerSpec`, will revist usefulness.   exceptions.-* Remove many `Typeable` instances.-* Support better testing with a mock Memcached server.-* Fix bug in socket handling - detected EOF properly.-* Greatly improve documentation.-* Use `data-default-class` for defaults of servers and options.+- Remove many `Typeable` instances.+- Support better testing with a mock Memcached server.+- Fix bug in socket handling - detected EOF properly.+- Greatly improve documentation.+- Use `data-default-class` for defaults of servers and options.  # 0.1.0.1 - February 26th, 2016 -* Consistent usage of 'memcached' instead of 'memcache'.-* Document `Database.Memcache.Client`.-* Add inline pragmas in appropriate places.-* Fix bug handling fragmented IP packets (Alfredo Di Napoli).+- Consistent usage of 'memcached' instead of 'memcache'.+- Document `Database.Memcache.Client`.+- Add inline pragmas in appropriate places.+- Fix bug handling fragmented IP packets (Alfredo Di Napoli).  # 0.1.0.0 - May 18th, 2015 -* First proper release (although still lots of rough edges!).-* Filled out `Data.Memcache.Client` to a complete API.-* Integrated cluster and authentication handling.-* Better error and exception handling.-* Fix compilation under GHC 7.10.+- First proper release (although still lots of rough edges!).+- Filled out `Data.Memcache.Client` to a complete API.+- Integrated cluster and authentication handling.+- Better error and exception handling.+- Fix compilation under GHC 7.10.  # 0.0.1 - May 5th, 2015 -* Initial (incomplete) support for a cluster of memcached servers.-* Fixed compilation under GHC 7.4.+- Initial (incomplete) support for a cluster of memcached servers.+- Fixed compilation under GHC 7.4.  # 0.0.0 - August 23rd, 2013 -* Initial release. Support for a single server.-+- Initial release. Support for a single server.

@@ -0,0 +1,62 @@+{-# LANGUAGE OverloadedStrings #-}++{-|+Module      : Database.Memcache.Auth+Description : Meta Text auth-file authentication+Copyright   : (c) David Terei, 2016+License     : BSD+Maintainer  : code@davidterei.com+Stability   : stable+Portability : GHC++Authentication for Memcached's experimental text-protocol auth-file mode.+-}+module Database.Memcache.Auth+  ( Authentication(..)+  , Username+  , Password+  , authenticate+  , validateCredentials+  ) where++import Database.Memcache.Errors+import Database.Memcache.Socket+import Database.Memcache.Types++import Control.Monad (unless)+import qualified Data.ByteString.Char8 as B8+import UnliftIO.Exception (catch, throwIO)++-- | Authenticate a connection using text-protocol credentials.+authenticate :: Connection -> Authentication -> IO ()+authenticate _ NoAuth = return ()+authenticate socket (Auth user pass) = do+  case validateCredentials user pass of+    Left message -> throwIO $ ClientError (InvalidAuthentication message)+    Right () -> return ()+  -- Without -Y authfile, "set auth ..." is just a normal store, so credentials+  -- would be readable via "get auth"; probe with a real command first so we+  -- never send them to a server that isn't gating on auth-file mode.+  sendRaw socket versionRequest+  probe <- recvResponse socket+  unless (responseCode probe == "CLIENT_ERROR") $ throwIO $ ClientError+    (InvalidAuthentication "server is not in auth-file mode; refusing to send credentials")+  let credentials = user <> B8.singleton ' ' <> pass+  sendRaw socket (authRequest credentials)+  response <- recvResponse socket+  result <- responseStatus response `catch` handleAuthFailure+  case result of+    NoError -> return ()+    status -> throwIO $ OpError status+  where+    handleAuthFailure (ProtocolError BadCommand{}) = throwIO $ OpError TextAuthFail+    handleAuthFailure err = throwIO (err :: MemcacheError)++-- | Validate that credentials contain no delimiters used by the auth command.+validateCredentials :: Username -> Password -> Either String ()+validateCredentials user pass+  | B8.any forbidden user = Left "username contains a forbidden delimiter"+  | B8.any forbidden pass = Left "password contains a forbidden delimiter"+  | otherwise = Right ()+  where+    forbidden c = c == ' ' || c == '\t' || c == '\r' || c == '\n' || c == ':'

@@ -1,4 +1,5 @@ {-# LANGUAGE CPP #-}+{-# LANGUAGE OverloadedStrings #-}  {-| Module      : Database.Memcache.Client@@ -9,16 +10,18 @@ Stability   : stable Portability : GHC -A Memcached client. Memcached is an in-memory key-value store typically used as-a distributed and shared cache. Clients connect to a group of Memcached servers-and perform out-of-band caching for things like SQL results, rendered pages, or-third-party APIs.+A Memcached client using the Meta (text) protocol. Memcached is an in-memory+key-value store typically used as a distributed and shared cache. Clients can+connect to a single Memcached server or a cluster of servers; clusters use+consistent hashing to route requests to the appropriate server. -A client can connect to a single Memcached server or a cluster of them. In the-later case, consistent hashing is used to route requests to the appropriate-server. The /binary/ Memcached protocol is used and /SASL authentication/ is-supported.+This requires memcached 1.6.0 or newer, the first release with the meta+commands; older servers reject every operation with @ERROR@. +Authentication uses Memcached's experimental text-protocol auth-file mechanism+(@-Y authfile@), introduced in memcached 1.5.15. Enabling @-Y@ also disables+binary and UDP protocols on the server.+ Expected return values (like misses) are returned as part of the return type, while unexpected errors are thrown as exceptions. Exceptions are either of type 'MemcacheError' or an 'IO' exception thrown by the network.@@ -27,6 +30,7 @@  * __Timeouts__: we timeout any operation that takes too long and consider it                 failed.+ * __Retry__: on operation failure (timeout, network error) we close the              connection and retry the operation, doing this up to a              configurable maximum.@@ -76,7 +80,7 @@ >     v' <- M.get mc "key" >     case v' of >         Nothing        -> putStrLn "Miss!"->         Just (v, _, _) -> putStrLn $ "Hit: " + show v+>         Just (v, _, _) -> putStrLn $ "Hit: " <> show v -} module Database.Memcache.Client (         -- * Client creation@@ -87,7 +91,7 @@         -- * Operations          -- ** Get operations-        get, gat, touch,+        get, getMany, gat, touch,          -- ** Set operations         set, cas, add, replace,@@ -105,276 +109,257 @@         MemcacheError(..), Status(..), ClientError(..), ProtocolError(..)     ) where -import Database.Memcache.Cluster-import Database.Memcache.Errors-import Database.Memcache.Server-import Database.Memcache.Socket-import Database.Memcache.Types hiding (cas)+import           Database.Memcache.Cluster+import           Database.Memcache.Errors+import           Database.Memcache.Server+import           Database.Memcache.Socket+import           Database.Memcache.Types  #if __GLASGOW_HASKELL__ < 710-import Control.Applicative+import           Control.Applicative #endif-import Control.Exception (handle, throwIO, SomeException)-import Control.Monad (forM_, void, when)-import Data.Default.Class-import Data.Word-import Data.ByteString (ByteString)-import qualified Data.ByteString as B (null)+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.Word+import           UnliftIO.Exception        (SomeException, handle, throwIO) --- | A Memcached client, connected to a collection of Memcached servers.+-- | A Memcached cluster client. type Client = Cluster+-- | Key/value pairs returned by 'stats'.+type StatResults = [(ByteString, ByteString)] --- | Establish a new connection to a group of Memcached servers.+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-newClient scs = do-  case scs of-    [] -> newCluster [def]-    _  -> newCluster scs+newClient scs = newCluster $ if null scs then [def] else scs --- | Gracefully close a connection to a Memcached cluster.+-- | Close all client connections, ignoring individual shutdown failures. quit :: Cluster -> IO ()-quit c = void $ allOp' c serverQuit-  where-    serverQuit :: Server -> IO ()-    serverQuit s = handle consumeError $ do-        let msg = emptyReq { reqOp = ReqQuit Quiet }-        withSocket s $ \sock -> send sock msg-        close s--    consumeError :: SomeException -> IO ()-    consumeError _ = return ()+quit c = void $ allOp' c $ \server -> handle ignore $ do+  withSocket server $ \socket -> sendRaw socket quitRequest+  close server+  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. get :: Cluster -> Key -> IO (Maybe (Value, Flags, Version)) get c k = do-    let msg = emptyReq { reqOp = ReqGet Loud NoKey k }-    r <- keyedOp c k msg-    (v, f) <- case resOp r of-        ResGet Loud v f -> return (v, f)-        _               -> throwIO $ wrongOp r "GET"-    case resStatus r of-        NoError        -> return $ Just (v, f, resCas r)-        ErrKeyNotFound -> return Nothing-        rs             -> throwStatus rs+  response <- keyedOp c k getRequest+  status <- responseStatus response+  case (responseCode response, status) of+    ("VA", NoError) -> return $ Just (responseValue response, responseFlags response, responseCas response)+    (_, ErrKeyNotFound) -> return Nothing+    _ -> failResponse response "GET" +-- | Fetch many keys. Missing keys are omitted from the result.+getMany :: Cluster -> [Key] -> IO [(Key, (Value, Flags, Version))]+getMany c keys = do+  replies <- keyedBatchOp c [(key, getManyRequest) | key <- keys]+  reverse <$> foldM collect [] replies+  where+    collect values (key, response) = do+      status <- responseStatus response+      case (responseCode response, status) of+        ("VA", NoError) ->+          return ((key, (responseValue response, responseFlags response, responseCas response)) : values)+        (_, ErrKeyNotFound) -> return values+        _ -> failResponse response "GETMANY"+ -- | Get-and-touch: Retrieve the value for the given key from Memcached, and -- also update the stored key-value pairs expiration time at the server. Use an -- expiration value of @0@ to store forever. gat :: Cluster -> Key -> Expiration -> IO (Maybe (Value, Flags, Version)) gat c k e = do-    let msg = emptyReq { reqOp = ReqGAT Loud NoKey k (SETouch e) }-    r <- keyedOp c k msg-    (v, f) <- case resOp r of-        ResGAT Loud v f -> return (v, f)-        _               -> throwIO $ wrongOp r "GAT"-    case resStatus r of-        NoError        -> return $ Just (v, f, resCas r)-        ErrKeyNotFound -> return Nothing-        rs             -> throwStatus rs+  response <- keyedOp c k (`gatRequest` e)+  status <- responseStatus response+  case (responseCode response, status) of+    ("VA", NoError) ->+      return $ Just (responseValue response, responseFlags response, responseCas response)+    (_, ErrKeyNotFound) -> return Nothing+    _ -> failResponse response "GAT"  -- | Update the expiration time of a stored key-value pair, returning its--- version identifier. Use an expiration value of @0@ to store forever.+-- new CAS version or 'Nothing'.+-- Use an expiration value of @0@ to store forever. touch :: Cluster -> Key -> Expiration -> IO (Maybe Version) touch c k e = do-    let msg = emptyReq { reqOp = ReqTouch k (SETouch e) }-    r <- keyedOp c k msg-    when (resOp r /= ResTouch) $ throwIO $ wrongOp r "TOUCH"-    case resStatus r of-        NoError        -> return $ Just (resCas r)-        ErrKeyNotFound -> return Nothing-        rs             -> throwStatus rs+  response <- keyedOp c k (`touchRequest` e)+  status <- responseStatus response+  case status of+    NoError | responseCode response == "HD" -> return $ Just (responseCas response)+    ErrKeyNotFound -> return Nothing+    _ -> failResponse response "TOUCH" --- | Store a new (or overwrite exisiting) key-value pair, returning its version+-- | Store a new (or overwrite exisiting) 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 = do-    let msg = emptyReq { reqOp = ReqSet Loud k v (SESet f e) }-    r <- keyedOp c k msg-    when (resOp r /= ResSet Loud) $ throwIO $ wrongOp r "SET"-    case resStatus r of-        NoError -> return $ resCas r-        rs      -> throwStatus rs+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+-- 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. cas :: Cluster -> Key -> Value -> Flags -> Expiration -> Version -> IO (Maybe Version) cas c k v f e ver = do-    let msg = emptyReq { reqOp = ReqSet Loud k v (SESet f e), reqCas = ver }-    r <- keyedOp c k msg-    when (resOp r /= ResSet Loud) $ throwIO $ wrongOp r "SET"-    case resStatus r of-        NoError        -> return $ Just (resCas r)-        ErrKeyNotFound -> return Nothing -- CAS: key doesn't exist-        ErrKeyExists   -> return Nothing -- CAS: version doesn't match-        rs             -> throwStatus rs+  response <- keyedOp c k (\wire -> storeRequest Set wire v f e ver)+  status <- responseStatus response+  case status of+    NoError -> return $ Just (responseCas response)+    ErrKeyNotFound -> return Nothing+    ErrKeyExists -> return Nothing+    _ -> failResponse response "SET" --- | Store a new key-value pair, returning it's version identifier. If the+-- | Store a new key-value pair, returning its @Version@ identifier. If the -- key-value pair already exists, then fail (return 'Nothing'). Use an -- expiration value of @0@ to store forever. add :: Cluster -> Key -> Value -> Flags -> Expiration -> IO (Maybe Version) add c k v f e = do-    let msg = emptyReq { reqOp = ReqAdd Loud k v (SESet f e) }-    r <- keyedOp c k msg-    when (resOp r /= ResAdd Loud) $ throwIO $ wrongOp r "ADD"-    case resStatus r of-        NoError      -> return $ Just (resCas r)-        ErrKeyExists -> return Nothing-        rs           -> throwStatus rs+  response <- keyedOp c k (\wire -> storeRequest Add wire v f e 0)+  status <- responseStatus response+  case status of+    NoError -> return $ Just (responseCas response)+    ErrItemNotStored -> return Nothing+    _ -> failResponse response "ADD" --- | Update the value of an existing key-value pair, returning it's new version--- identifier. If the key doesn't already exist, the fail and return Nothing.+-- | 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'. -- Use an expiration value of @0@ to store forever. replace :: Cluster -> Key -> Value -> Flags -> Expiration -> Version -> IO (Maybe Version) replace c k v f e ver = do-    let msg = emptyReq { reqOp = ReqReplace Loud k v (SESet f e), reqCas = ver }-    r <- keyedOp c k msg-    when (resOp r /= ResReplace Loud) $ throwIO $ wrongOp r "REPLACE"-    case resStatus r of-        NoError        -> return $ Just (resCas r)-        -- replace only applies to an existing key...-        ErrKeyNotFound -> return Nothing-        -- version specified and doesn't match key...-        ErrKeyExists   -> return Nothing-        rs             -> throwStatus rs+  response <- keyedOp c k (\wire -> storeRequest Replace wire v f e ver)+  status <- responseStatus response+  case status of+    NoError -> return $ Just (responseCas response)+    ErrKeyNotFound -> return Nothing+    ErrKeyExists -> return Nothing+    ErrItemNotStored -> return Nothing+    _ -> failResponse response "REPLACE" +store :: Cluster -> Key -> Value -> Flags -> Expiration -> Version -> StoreMode -> String -> IO Version+store c k v f e ver mode operation = do+  response <- keyedOp c k (\wire -> storeRequest mode wire v f e ver)+  status <- responseStatus response+  case status of+    NoError -> return $ responseCas response+    _ -> 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 and the @Version@ identifier of the key-value pair. Use an expiration -- value of @0@ to store forever. increment :: Cluster -> Key -> Initial -> Delta -> Expiration -> Version -> IO (Maybe (Word64, Version))-increment c k i d e ver = do-    let msg = emptyReq { reqOp = ReqIncrement Loud k (SEIncr i d e), reqCas = ver }-    r <- keyedOp c k msg-    n <- case resOp r of-        ResIncrement Loud n -> return n-        _                   -> throwIO $ wrongOp r "INCREMENT"-    case resStatus r of-        NoError        -> return $ Just (n, resCas r)-        ErrKeyNotFound -> return Nothing-        ErrKeyExists   -> return Nothing-        rs             -> throwStatus rs+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 and the @Version@ identifier of the key-value pair. Use an expiration -- value of @0@ to store forever. decrement :: Cluster -> Key -> Initial -> Delta -> Expiration -> Version -> IO (Maybe (Word64, Version))-decrement c k i d e ver = do-    let msg = emptyReq { reqOp = ReqDecrement Loud k (SEIncr i d e), reqCas = ver }-    r <- keyedOp c k msg-    n <- case resOp r of-        ResDecrement Loud n -> return n-        _                   -> throwIO $ wrongOp r "DECREMENT"-    case resStatus r of-        NoError        -> return $ Just (n, resCas r)-        ErrKeyNotFound -> return Nothing-        ErrKeyExists   -> return Nothing-        rs             -> throwStatus rs+decrement c k i d e ver = arithmetic c k i d e ver Decr "DECREMENT" --- | Append a value to an existing key-value pair, returning the new version+arithmetic :: Cluster -> Key -> Initial -> Delta -> Expiration -> Version -> ArithMode -> String -> IO (Maybe (Word64, Version))+arithmetic c k i d e ver mode operation = do+  response <- keyedOp c k (\wire -> arithmeticRequest mode wire i d e ver)+  status <- responseStatus response+  case status of+    NoError -> return $ Just (responseNumber response, responseCas response)+    ErrKeyNotFound -> return Nothing+    ErrKeyExists -> return Nothing+    ErrItemNotStored -> return Nothing+    _ -> failResponse response operation++-- | Append a value to an existing key-value pair, returning the new @Version@ -- identifier of the key-value pair when successful. append :: Cluster -> Key -> Value -> Version -> IO (Maybe Version)-append c k v ver = do-    let msg = emptyReq { reqOp = ReqAppend Loud k v, reqCas = ver }-    r <- keyedOp c k msg-    when (resOp r /= ResAppend Loud) $ throwIO $ wrongOp r "APPEND"-    case resStatus r of-        NoError        -> return $ Just (resCas r)-        ErrKeyNotFound -> return Nothing-        rs             -> throwStatus rs+append c k v ver = modify c k v ver Append "APPEND" --- | Prepend a value to an existing key-value pair, returning the new version--- identifier of the key-value pair when successful.+-- | Prepend to an existing value using CAS. prepend :: Cluster -> Key -> Value -> Version -> IO (Maybe Version)-prepend c k v ver = do-    let msg = emptyReq { reqOp = ReqPrepend Loud k v, reqCas = ver }-    r <- keyedOp c k msg-    when (resOp r /= ResPrepend Loud) $ throwIO $ wrongOp r "PREPEND"-    case resStatus r of-        NoError        -> return $ Just (resCas r)-        ErrKeyNotFound -> return Nothing-        rs             -> throwStatus rs+prepend c k v ver = modify c k v ver Prepend "PREPEND" --- | Delete a key-value pair at the server, returning true if successful.+modify :: Cluster -> Key -> Value -> Version -> StoreMode -> String -> IO (Maybe Version)+modify c k v ver mode operation = do+  response <- keyedOp c k (\wire -> modifyRequest mode wire v ver)+  status <- responseStatus response+  case status of+    NoError -> return $ Just (responseCas response)+    ErrKeyNotFound -> return Nothing+    ErrItemNotStored -> return Nothing+    _ -> failResponse response operation++-- | Delete a key, returning whether it was deleted. delete :: Cluster -> Key -> Version -> IO Bool delete c k ver = do-    let msg = emptyReq { reqOp = ReqDelete Loud k, reqCas = ver }-    r <- keyedOp c k msg-    when (resOp r /= ResDelete Loud) $ throwIO $ wrongOp r "DELETE"-    case resStatus r of-        NoError        -> return True-        -- delete only applies to an existing key...-        ErrKeyNotFound -> return False-        -- version specified and doesn't match key...-        ErrKeyExists   -> return False-        rs             -> throwStatus rs+  response <- keyedOp c k (`deleteRequest` ver)+  status <- responseStatus response+  case status of+    NoError -> return True+    ErrKeyNotFound -> return False+    ErrKeyExists -> return False+    _ -> failResponse response "DELETE"  -- | Remove (delete) all currently stored key-value pairs from the cluster. The -- expiration value can be used to cause this flush to occur in the future -- rather than immediately. flush :: Cluster -> Maybe Expiration -> IO () flush c e = do-    let msg = emptyReq { reqOp = ReqFlush Loud (SETouch <$> e) }-    results <- allOp c msg-    forM_ results $ \(_, r) -> do-        when (resOp r /= ResFlush Loud) $ throwIO $ wrongOp r "FLUSH"-        case resStatus r of-            NoError -> return ()-            rs      -> throwStatus rs---- | StatResults are a list of key-value pairs.-type StatResults = [(ByteString, ByteString)]+  results <- allOp c (flushRequest e)+  forM_ results $ \(_, response) -> do+    status <- responseStatus response+    when (status /= NoError) $ failResponse response "FLUSH" --- | Return statistics on the stored key-value pairs at each server in the--- cluster. The optional key can be used to select a different set of+-- | Return statistics on the stored key-value pairs at every available server+-- in the cluster. The optional key can be used to select a different set of -- statistics from the server than the default. Most Memcached servers support -- @"items"@, @"slabs"@ or @"settings"@.-stats :: Cluster -> Maybe Key -> IO [(Server, Maybe StatResults)]-stats c key = allOp' c serverStats+stats :: Cluster -> Maybe Key -> IO [(Server, StatResults)]+stats c key = validateStatsArgs key >> allOp' c (runStats key)   where-    msg :: Request-    msg = emptyReq { reqOp = ReqStat key }+    runStats statsArgs server = withSocket server $ \socket -> do+      sendRaw socket (statsRequest statsArgs)+      collect socket [] -    serverStats :: Server -> IO (Maybe StatResults)-    serverStats s = withSocket s $ \sock -> do-        send sock msg-        recvAllStats sock []+    -- Arguments may contain spaces (@stats cachedump 1 100@), but control+    -- bytes would let a caller inject a second command line.+    validateStatsArgs Nothing = return ()+    validateStatsArgs (Just args)+      | B.null args ||+        B.length args > 250 ||+        B.any (\byte -> byte < 0x20 || byte == 0x7f) args =+          throwIO $ ClientError (KeyTooLong "invalid stats argument")+      | otherwise = return () -    recvAllStats :: Socket -> StatResults -> IO (Maybe StatResults)-    recvAllStats s xs = do-        r <- recv s-        (k, v) <- case resOp r of-            ResStat k v -> return (k, v)-            _           -> throwIO $ wrongOp r "STATS"-        case resStatus r of-            NoError | B.null k && B.null v -> return $ Just xs-                    | otherwise            -> recvAllStats s $ (k, v):xs-            ErrKeyNotFound                 -> return Nothing-            rs                             -> throwStatus rs+    collect socket values = do+      response <- recvResponse socket+      case (responseCode response, responseTokens response) of+        (code, _) | code `elem` ["ERROR", "CLIENT_ERROR", "SERVER_ERROR"] ->+          responseStatus response >> failResponse response "STATS"+        (code, _) | code `elem` ["END", "RESET", "OK"] -> return (reverse values)+        ("STAT", field:value) -> collect socket ((field, C.unwords value) : values)+        (code, tokens) -> collect socket ((code, C.unwords tokens) : values) --- | Version returns the version string of the Memcached cluster. We just query--- one server and assume all servers in the cluster are the same version.+-- | Return the version string of the Memcached cluster. Only queries+-- one server and assumes all servers in the cluster run the same version. version :: Cluster -> IO ByteString version c = do-    let msg = emptyReq { reqOp = ReqVersion }-    r <- anyOp c msg-    v <- case resOp r of-        ResVersion v -> return v-        _            -> throwIO $ wrongOp r "VERSION"-    case resStatus r of-        NoError -> return v-        rs      -> throwStatus rs---- | Noop sends a Non-operation command to the specified Memcached server.  We--- leave it blanked out, but here for documentation purposes of the full--- protocol.--- noop :: Server -> IO ()--- noop c = do---     let msg = emptyReq { reqOp = ReqNoop }---     r <- sendRecv c msg---     when (resOp r /= ResNoop) $ throwIncorrectRes r "NOOP"---     case resStatus r of---         NoError -> return ()---         rs      -> throwStatus rs+  response <- anyOp c versionRequest+  status <- responseStatus response+  if responseCode response == "VERSION" && status == NoError+    then return $ fromMaybe B.empty (safeHead (responseTokens response))+    else failResponse response "VERSION" +failResponse :: Response -> String -> IO a+failResponse response operation = do+  status <- responseStatus response+  throwIO $ if status /= NoError+    then OpError status+    else ProtocolError UnexpectedResponse+      { protocolError = "Expected " <> operation <> ", got: " <> show (responseCode response) }

@@ -1,8 +1,9 @@-{-# LANGUAGE BangPatterns #-}-{-# LANGUAGE CPP #-}-{-# LANGUAGE FlexibleInstances #-}-{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE BangPatterns        #-}+{-# LANGUAGE CPP                 #-}+{-# LANGUAGE FlexibleInstances   #-}+{-# LANGUAGE RecordWildCards     #-} {-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE OverloadedStrings   #-}  {-| Module      : Database.Memcache.Cluster@@ -16,52 +17,43 @@ Handles a group of connections to different Memcached servers.  We use consistent hashing to choose which server to route a request to. On an-error, we mark the server as failed and remove it temporarialy from the set of+error, we mark the server as failed and remove it temporarily from the set of servers available. -} module Database.Memcache.Cluster (         -- * Cluster-        Cluster, ServerSpec(..), Options(..), newCluster,+        -- | A collection of Memcached servers with retry and routing state.+        Cluster, ServerSpec(..), Options(..), newCluster, getServers, setServers,          -- * Operations-        Retries, keyedOp, anyOp, allOp, allOp'+        Retries, keyedOp, keyedBatchOp, anyOp, allOp, allOp'     ) where -import Database.Memcache.Errors-import Database.Memcache.Server-import Database.Memcache.Types+import           Database.Memcache.Errors+import           Database.Memcache.Server+import           Database.Memcache.Types -import Control.Concurrent (threadDelay)-import Control.Exception (handle, throwIO, SomeException)-import Data.Default.Class-import Data.Fixed (Milli)-import Data.Hashable (hash)-import Data.IORef-import Data.Maybe (fromMaybe)-import Data.List (sort)-import Data.Time.Clock (NominalDiffTime)-import Data.Time.Clock.POSIX (getPOSIXTime)-import qualified Data.Vector as V-import Network.Socket (HostName, ServiceName)-import System.Timeout+import           Control.Concurrent       (threadDelay)+import           Control.Concurrent.MVar  (MVar, readMVar)+import           Control.Monad            (foldM, void)+import           Data.ByteString          (ByteString)+import qualified Data.ByteString          as B+import           Data.Default+import           Data.Fixed               (Milli)+import           Data.Hashable            (hash)+import           Data.IORef+import           Data.List                (find, sort)+import           Data.Maybe               (fromMaybe)+import           Data.Time.Clock          (NominalDiffTime)+import           Data.Time.Clock.POSIX    (getPOSIXTime)+import qualified Data.Vector              as V+import           System.Timeout+import           UnliftIO.Exception       (SomeException, fromException, handle, throwIO)+import           Database.Memcache.Socket (Response(..), WireKey(..), encodeKey, noOpRequest, recvResponse, responseStatus, sendRaw)  -- | Number of times to retry an operation before considering it failed. type Retries = Int --- | ServerSpec specifies a server configuration for connection.-data ServerSpec = ServerSpec {-        -- | Hostname of server to connect to.-        ssHost :: HostName,-        -- | Port number server is running on.-        ssPort :: ServiceName,-        -- | Authentication values to use for SASL authentication with this-        -- server.-        ssAuth :: Authentication-    } deriving (Eq, Show)--instance Default ServerSpec where-  def = ServerSpec "127.0.0.1" "11211" NoAuth- -- | Options specifies how a Memcached cluster should be configured. data Options = Options {         -- | Number of times to retry an operation on failure. If consecutive@@ -69,27 +61,35 @@         -- failover to a different server for the next operation.         --         -- Default is 2.-        optsServerRetries :: Retries,+        optsServerRetries        :: Retries,         -- | After an operation has failed, how long to wait before retrying it         -- while still within the 'optsServerRetries' count?         --         -- Default is 200ms.-        optsFailRetryDelay :: Milli,+        optsFailRetryDelay       :: Milli,         -- | How long to wait after a server has been marked down, before         -- trying to use it again.         --         -- Default is 1500ms.-        optsDeadRetryDelay :: Milli,+        optsDeadRetryDelay       :: Milli,         -- | How long to wait for an operation to complete before considering         -- it failed.         --         -- Default is 750ms.-        optsServerTimeout :: Milli,+        optsServerTimeout        :: Milli,         --         -- | Figure out which server to talk to for a given key.         ---        -- Default is 'getServerForKeyDefault'.-        optsGetServerForKey :: Cluster -> Key -> IO (Maybe Server)+        -- Default is @getServerForKeyDefault@.+        optsGetServerForKey      :: Cluster -> Key -> IO (Maybe Server),+        --+        -- | Convert server specifications into servers.+        --+        -- Default uses 'newServerDefault'.+        optsServerSpecsToServers :: ServerOptions -> [ServerSpec] -> IO [Server],++        -- | Connection-pool options for each server.+        optsServerOptions :: ServerOptions         -- TODO: socket_timeout         -- TODO: failover         -- TODO: expires_in@@ -106,30 +106,40 @@             optsFailRetryDelay = 200,             optsDeadRetryDelay = 1500,             optsServerTimeout  = 750,-            optsGetServerForKey = getServerForKeyDefault+            optsGetServerForKey = getServerForKeyDefault,+            optsServerSpecsToServers = mapM . newServerDefault,+            optsServerOptions = def         }  -- | Memcached cluster. data Cluster = Cluster {-        cServers   :: V.Vector Server,+        cServers         :: Either (MVar (V.Vector Server)) (V.Vector Server), -        -- See 'Options' for description of these values.+        -- See @Options@ for description of these values. -        cRetries   :: {-# UNPACK #-} !Int,-        cFailDelay :: {-# UNPACK #-} !Int, -- ^ microseconds-        cDeadDelay :: !NominalDiffTime,-        cTimeout   :: {-# UNPACK #-} !Int, -- ^ microseconds-        cGetServerForKey  :: Cluster -> Key -> IO (Maybe Server)+        cRetries         :: {-# UNPACK #-} !Int,+        cFailDelay       :: {-# UNPACK #-} !Int, -- ^ microseconds+        cDeadDelay       :: !NominalDiffTime,+        cTimeout         :: {-# UNPACK #-} !Int, -- ^ microseconds+        cGetServerForKey :: Cluster -> Key -> IO (Maybe Server)     } +-- | Get the currently configured servers.+getServers :: Cluster -> IO (V.Vector Server)+getServers = either readMVar pure . cServers++-- | Replace the cluster's server set, preserving its routing and retry options.+setServers :: Cluster -> Either (MVar (V.Vector Server)) (V.Vector Server) -> Cluster+setServers c servers = c { cServers = servers }+ -- | Establish a new connection to a group of Memcached servers. newCluster :: [ServerSpec] -> Options -> IO Cluster newCluster []    _ = throwIO $ ClientError NoServersReady newCluster hosts Options{..} = do-    s <- mapM (\ServerSpec{..} -> newServer ssHost ssPort ssAuth) hosts+    s <- optsServerSpecsToServers optsServerOptions hosts     return $         Cluster {-            cServers   = (V.fromList $ sort s),+            cServers   = Right $ V.fromList $ sort s,             cRetries   = optsServerRetries ,             cFailDelay = fromEnum optsFailRetryDelay,             cDeadDelay = fromRational $ toRational optsDeadRetryDelay / 1000,@@ -159,43 +169,105 @@ getServerForKeyDefault  c k = do     let hashedKey = hash k         searchF s = sid s < hashedKey-    servers' <- V.filterM (serverAlive $ cDeadDelay c) $ cServers c+    servers <- getServers c+    servers' <- V.filterM (serverAlive $ cDeadDelay c) servers     return $ if V.null servers'         then Nothing         else Just $ fromMaybe (V.last servers') (V.find searchF servers')  -- | Run a Memcached operation against a particular server, handling any -- failures that occur, retrying the specified number of times.-serverOp :: Cluster -> Server -> Request -> IO Response+serverOp :: Cluster -> Server -> ByteString -> IO Response {-# INLINE serverOp #-}-serverOp c s req = retryOp c s $ sendRecv s req+serverOp c s req = retryOp c s $ withSocket s $ \connection -> do+  sendRaw connection req+  response <- recvResponse connection+  rejectProtocolError response+  return response --- | Run a Memcached operation against a particular server, handling any--- failures that occur, retrying the specified number of times.-keyedOp :: Cluster -> Key -> Request -> IO Response+rejectProtocolError :: Response -> IO ()+rejectProtocolError response+  | responseCode response `elem` ["ERROR", "CLIENT_ERROR", "SERVER_ERROR"] =+    void (responseStatus response)+  | otherwise = return ()++-- | Run a keyed request against the server selected for the key.+keyedOp :: Cluster -> Key -> (WireKey -> ByteString) -> IO Response {-# INLINE keyedOp #-}-keyedOp c k req = do+keyedOp c k makeReq = do+    wire <- either (throwIO . ClientError) return (encodeKey k)     s' <- cGetServerForKey c c k     case s' of-        Just s  -> serverOp c s req+        Just s  -> serverOp c s (makeReq wire)         Nothing -> throwIO $ ClientError NoServersReady +-- | Run keyed requests grouped by their selected server.+keyedBatchOp :: Cluster -> [(Key, WireKey -> ByteString)] -> IO [(Key, Response)]+keyedBatchOp c requests = do+    groups <- foldM add [] requests+    concat <$> mapM run groups+  where+    add groups (key, makeRequest) = do+      wire <- either (throwIO . ClientError) return (encodeKey key)+      server <- cGetServerForKey c c key+      case server of+        Nothing -> throwIO $ ClientError NoServersReady+        Just s -> return (insertGroup s (key, wire, makeRequest) groups)++    insertGroup s item [] = [(s, [item])]+    insertGroup s item ((s', items):rest)+      | s == s' = (s', item:items) : rest+      | otherwise = (s', items) : insertGroup s item rest++    run (server, items) = concat <$> mapM (runBatch server) (chunksOf batchSize (reverse items))++    -- Write the whole batch in one go, then read it back. Batches are bounded+    -- so the server's replies cannot fill the socket buffers while we are+    -- still writing, which would deadlock both ends until the op times out.+    runBatch server items = retryOp c server $ withSocket server $ \connection -> do+      sendRaw connection (B.concat (map request items) <> noOpRequest)+      replies <- recvUntilMN connection []+      return [(key, response) | response <- replies, Just key <- [responseKey response items]]++    recvUntilMN connection acc = do+      response <- recvResponse connection+      rejectProtocolError response+      if responseCode response == "MN"+        then return (reverse acc)+        else recvUntilMN connection (response : acc)++    responseKey response items = do+      echoed <- find (B.isPrefixOf "k") (responseTokens response)+      (key, _, _) <- find ((== B.drop 1 echoed) . wireKey . snd3) items+      return key++    request (_, wire, makeRequest) = makeRequest wire+    snd3 (_, wire, _) = wire++    batchSize = 256 :: Int++    chunksOf n xs = case splitAt n xs of+      (chunk, []) -> [chunk]+      (chunk, rest) -> chunk : chunksOf n rest+ -- | Run a Memcached operation against any single server in the cluster, -- handling any failures that occur, retrying the specified number of times.-anyOp :: Cluster -> Request -> IO Response+anyOp :: Cluster -> ByteString -> IO Response {-# INLINE anyOp #-} anyOp c req = do-    servers' <- V.filterM (serverAlive $ cDeadDelay c) $ cServers c+    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  -- | Run a Memcached operation against all servers in the cluster, handling any -- failures that occur, retrying the specified number of times.-allOp :: Cluster -> Request -> IO [(Server, Response)]+allOp :: Cluster -> ByteString -> IO [(Server, Response)] {-# INLINE allOp #-} allOp c req = do-    servers' <- V.filterM (serverAlive $ cDeadDelay c) $ cServers c+    servers <- getServers c+    servers' <- V.filterM (serverAlive $ cDeadDelay c) servers     if V.null servers'         then throwIO $ ClientError NoServersReady         else do@@ -209,7 +281,8 @@ allOp' :: Cluster -> (Server -> IO a) -> IO [(Server, a)] {-# INLINE allOp' #-} allOp' c op = do-    servers' <- V.filterM (serverAlive $ cDeadDelay c) $ cServers c+    servers <- getServers c+    servers' <- V.filterM (serverAlive $ cDeadDelay c) servers     if V.null servers'         then throwIO $ ClientError NoServersReady         else do@@ -232,10 +305,20 @@      handleErrs :: Int -> SomeException -> IO a     {-# INLINE handleErrs #-}-    handleErrs 0 err = do t <- getPOSIXTime-                          writeIORef (failed s) t-                          throwIO err-    handleErrs n _ = do-        threadDelay cFailDelay-        go n+    handleErrs n err+        | clientFault err = throwIO err+        | n <= 0 = do+            writeIORef (failed s) =<< getPOSIXTime+            throwIO err+        | otherwise = threadDelay cFailDelay >> go n +-- | A rejected command or a reported operation status is an answer, not a+-- server failure: retrying it will fail identically and must not count towards+-- marking the server dead.+clientFault :: SomeException -> Bool+clientFault err = case fromException err of+    Just (ProtocolError BadCommand{}) -> True+    Just (ProtocolError UnknownOp{})  -> True+    Just (OpError _)                  -> True+    Just (ClientError InvalidAuthentication{}) -> True+    _                                 -> False

@@ -0,0 +1,190 @@+{-# LANGUAGE OverloadedStrings #-}++{-|+Module      : Database.Memcache.ElastiCacheClient+Description : Amazon ElastiCache service discovery+Copyright   : (c) David Terei, 2016+License     : BSD+Maintainer  : code@davidterei.com+Stability   : stable+Portability : GHC++Client creation and automatic node discovery for Amazon ElastiCache clusters.+-}+module Database.Memcache.ElastiCacheClient+  ( ConfigurationEndpoint+  , parseConfigurationEndpoint,+    newClient,+  )+where++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)+import qualified Data.ByteString.Char8 as C+import Data.List (sort)+import qualified Data.List.NonEmpty as NE+import Data.Text (Text)+import qualified Data.Text as T+import qualified Data.Text.Encoding as T+import qualified Data.Vector as V+import Data.Version (Version, makeVersion)+import qualified Data.Version as Version+import Database.Memcache.Client (Client, optsServerSpecsToServers, optsServerOptions)+import qualified Database.Memcache.Client as Client+import Database.Memcache.Cluster (Options, getServers, setServers)+import Database.Memcache.Server (Server, withSocket)+import Database.Memcache.Socket (Connection, crlf, recvRawUntil, sendRaw, versionRequest)+import Database.Memcache.Types.ServerSpec (ServerSpec, parseServerSpec)+import Text.ParserCombinators.ReadP (readP_to_S)+import UnliftIO.Exception (bracket, throwString)++-- | Parse an ElastiCache configuration endpoint.+--+-- A /Configuration Endpoint/ will always contain /.cfg/ in its address:+--+-- https://docs.aws.amazon.com/AmazonElastiCache/latest/mem-ug/AutoDiscovery.Using.html+--+parseConfigurationEndpoint :: String -> Either String ConfigurationEndpoint+parseConfigurationEndpoint url = do+  note "URI does not contain '.cfg'" $ guard $ ".cfg" `T.isInfixOf` T.pack url+  ConfigurationEndpoint <$> parseServerSpec url++-- Please see:+-- https://github.com/memcached/memcached/blob/77709d04dd4fc7d59f59425802cb9645b2cfe0f8/doc/protocol.txt#L1805-L1812+-- ByteString format: "VERSION <version>\r\n"+parseVersion :: ByteString -> Either String Version+parseVersion = interpretParseResults . delegateParse . C.unpack . C.dropEnd (C.length crlf) . C.drop (C.length "VERSION ")+  where+    delegateParse = readP_to_S Version.parseVersion+    interpretParseResults parseResults = do+      results <- note "Unable to parse input" $ NE.nonEmpty parseResults+      let tail' = NE.last results+      case tail' of+        (version, "") -> pure version+        (_, rest) -> Left $ "eof expected. Got: " <> rest++-- | A validated ElastiCache configuration endpoint.+--+-- Use the smart constructor @parseConfigurationEndpoint@ to create one.+newtype ConfigurationEndpoint+  = ConfigurationEndpoint+  { unConfigurationEndpoint :: ServerSpec+  }++-- | Create a new client using service discovery.+--+-- This function discovers all the nodes in a cluster and sets up a new thread to run autodiscovery on an interval.+--+-- N.B. The interval is in the same units as 'threadDelay'.+newClient :: Options -> Int -> ConfigurationEndpoint -> IO Client+newClient options interval cfgEndpoint = bracket acquireCfgClient releaseCfgClient resolveCluster'+  where+    acquireCfgClient = Client.newClient [unConfigurationEndpoint cfgEndpoint] options+    releaseCfgClient = Client.quit+    resolveCluster' cfgClient = do+      serverSpecs <- resolveCluster cfgClient++      -- Create client where cServers = Right <Vector Server>+      client <- Client.newClient serverSpecs options++      -- Prepare MVar+      serversMVar <- newMVar =<< getServers client+      _ <- forkIO $ repeatAutoDiscover options interval cfgEndpoint serversMVar++      -- Update client where cServers = Left <MVar <Vector Server>>+      pure $ setServers client $ Left serversMVar++repeatAutoDiscover :: Options -> Int -> ConfigurationEndpoint -> MVar (V.Vector Server) -> IO ()+repeatAutoDiscover opts interval cfgEndpoint mVar = do+  cfgClient <- Client.newClient [unConfigurationEndpoint cfgEndpoint] opts+  forever $ do+    threadDelay interval+    serverSpecs <- resolveCluster cfgClient+    servers <- optsServerSpecsToServers opts (optsServerOptions opts) serverSpecs+    modifyMVar_ mVar $ \_curServers -> pure $ V.fromList $ sort servers++resolveCluster :: Client -> IO [ServerSpec]+resolveCluster cfgClient = do+  servers <- getServers cfgClient++  server <-+    case V.uncons servers of+      Nothing -> throwString "No servers were found"+      Just (s, _) -> pure s++  withSocket server $ \socket -> do+    -- Get version+    sendRaw socket versionRequest+    rawVersion <- recvRawUntil crlf socket+    version <- unTry $ parseVersion rawVersion++    -- Get nodes+    rawResponse <-+      if version >= firstCfgCmdVersion+        then resolveViaConfigCmd socket+        else resolveViaAutoDiscoveryKey socket++    rawNodeInfo <- unTry $ handleConfigGetClusterResponse rawResponse++    unTry $ handleRawNodeInfo rawNodeInfo++-- Handle the raw response from /memcached/.+--+-- See: https://docs.aws.amazon.com/AmazonElastiCache/latest/mem-ug/AutoDiscovery.AddingToYourClientLibrary.html#AutoDiscovery.AddingToYourClientLibrary.OutputFormat+handleConfigGetClusterResponse :: ByteString -> Either String Text+handleConfigGetClusterResponse bs = do+  text <- first show $ T.decodeUtf8' bs++  case T.lines text of+    [_, _, nodeInfo, _, _] -> pure $ T.strip nodeInfo+    xs -> Left $ "Unrecognized number of lines: " <> show (length xs)++-- Handle node information+--+-- Note that we chose to use the CNAME rather than the IP. The IP /may/ be missing. The CNAME will always be present.+--+-- See: https://docs.aws.amazon.com/AmazonElastiCache/latest/mem-ug/AutoDiscovery.AddingToYourClientLibrary.html#AutoDiscovery.AddingToYourClientLibrary.OutputFormat+handleRawNodeInfo :: Text -> Either String [ServerSpec]+handleRawNodeInfo = mapM (parseServerSpec <=< pure . T.unpack <=< convertToUri) . T.splitOn " "+  where+    convertToUri :: Text -> Either String Text+    convertToUri t =+      case T.splitOn "|" t of+        [host, _ip, port] -> pure $ "memcached://" <> host <> ":" <> port+        xs -> Left $ "Unrecognized components in node info: " <> show xs++-- This is the first version within which the /memcache/ engine on /ElastiCache/ uses the custom /config/ command.+--+-- https://docs.aws.amazon.com/AmazonElastiCache/latest/mem-ug/AutoDiscovery.AddingToYourClientLibrary.html+--+firstCfgCmdVersion :: Version+firstCfgCmdVersion = makeVersion [1, 4, 14]++-- Pre-1.4.14 engines don't support meta commands, so use a plain text get.+resolveViaAutoDiscoveryKey :: Connection -> IO ByteString+resolveViaAutoDiscoveryKey socket = do+  sendRaw socket ("get " <> autoDiscoveryKey <> crlf)+  recvRawUntil ("END" <> crlf) socket++-- Before 'firstCfgCmdVersion', /ElastiCache/ stored configuration in a special-purpose key within the /Configuration Endpoint/.+--+-- https://docs.aws.amazon.com/AmazonElastiCache/latest/mem-ug/AutoDiscovery.AddingToYourClientLibrary.html+--+autoDiscoveryKey :: ByteString+autoDiscoveryKey = "AmazonElastiCache:cluster"++-- See: https://docs.aws.amazon.com/AmazonElastiCache/latest/mem-ug/AutoDiscovery.AddingToYourClientLibrary.html#AutoDiscovery.AddingToYourClientLibrary.OutputFormat+resolveViaConfigCmd :: Connection -> IO ByteString+resolveViaConfigCmd socket = do+  sendRaw socket (configGetCluster <> crlf)+  recvRawUntil ("END" <> crlf) socket++configGetCluster :: ByteString+configGetCluster = "config get cluster"++unTry :: Either String a -> IO a+unTry = either throwString pure

@@ -19,14 +19,12 @@         ProtocolError(..),          -- * Error creation-        throwStatus,-        wrongOp+        throwStatus     ) where -import Database.Memcache.Types+import           Database.Memcache.Types -import Control.Exception-import Data.Typeable+import           UnliftIO.Exception  -- | All exceptions that a Memcached client may throw. data MemcacheError@@ -46,20 +44,26 @@     = NoServersReady     -- | Timeout occurred sending request to server.     | Timeout+    | InvalidAuthentication String+    | KeyTooLong String     deriving (Eq, Show, Typeable)  -- | Errors related to Memcached protocol and bytes on the wire. data ProtocolError-    -- | Received an unknown response packet.+    -- | Received an unknown response line.     = UnknownPkt    { protocolError :: String }     -- | Unknown Memcached operation.     | UnknownOp     { protocolError :: String }     -- | Unknown Memcached status field value.     | UnknownStatus { protocolError :: String }-    -- | Unexpected length of a Memcached field (extras, key, or value).+    -- | Unexpected length of a Meta Text value or other field.     | BadLength     { protocolError :: String }-    -- | Response packet is for a different operation than expected.-    | WrongOp       { protocolError :: String }+    -- | Response is for a different operation than expected.+    | UnexpectedResponse { protocolError :: String }+    -- | Memcached reported a server failure.+    | ServerError   { protocolError :: String }+    -- | Memcached rejected the command.+    | BadCommand    { protocolError :: String }     -- | Network socket closed without receiving enough bytes.     | UnexpectedEOF { protocolError :: String }     deriving (Eq, Show, Typeable)@@ -67,11 +71,3 @@ -- | Convert a status to 'MemcacheError' exception. throwStatus :: Status -> IO a throwStatus s = throwIO $ OpError s---- | Create a properly formatted 'WrongOp' protocol error.-wrongOp :: Response -> String -> MemcacheError-wrongOp r msg = ProtocolError $-    WrongOp {-        protocolError  = "Expected " ++ msg ++ "! Got: " ++ show (resOp r)-    }-

@@ -1,68 +0,0 @@-{-# OPTIONS_GHC -fno-warn-unused-binds #-}--{-|-Module      : Database.Memcache.SASL-Description : SASL Authentication-Copyright   : (c) David Terei, 2016-License     : BSD-Maintainer  : code@davidterei.com-Stability   : stable-Portability : GHC--SASL authentication support for Memcached.--}-module Database.Memcache.SASL (-        -- * Types-        Authentication(..), Username, Password,--        -- * Operations-        authenticate-    ) where--import Database.Memcache.Errors-import Database.Memcache.Socket-import Database.Memcache.Types--import Control.Exception (throwIO)-import Control.Monad-import Data.ByteString.Char8 as B8 (ByteString, pack, singleton)---- | Perform SASL authentication with the server.-authenticate :: Socket -> Authentication -> IO ()-{-# INLINE authenticate #-}-authenticate _ NoAuth     = return ()-authenticate s (Auth u p) = saslAuthPlain s u p--- NOTE: For correctness really should check that PLAIN auth is supported first--- but we'll just assume it is as that's all mainline and other implementations--- support and one exception is nearly as good as another.---- | Perform SASL PLAIN authentication.-saslAuthPlain :: Socket -> Username -> Password -> IO ()-{-# INLINE saslAuthPlain #-}-saslAuthPlain s u p = do-    let credentials = singleton '\0' <> u <> singleton '\0' <> p-        msg = emptyReq { reqOp = ReqSASLStart (B8.pack "PLAIN") credentials }-    send s msg-    r <- recv s-    when (resOp r /= ResSASLStart) $-        throwIO $ wrongOp r "SASL_START"-    case resStatus r of-        NoError -> return ()-        rs      -> throwIO $ OpError rs---- | List available SASL authentication methods. We could call this but as we--- only support PLAIN as does the Memcached server, we simply assume PLAIN--- authentication is supprted and try that.-saslListMechs :: Socket -> IO B8.ByteString-{-# INLINE saslListMechs #-}-saslListMechs s = do-    let msg = emptyReq { reqOp = ReqSASLList }-    send s msg-    r <- recv s-    v <- case resOp r of-        ResSASLList v -> return v-        _             -> throwIO $ wrongOp r "SASL_LIST"-    case resStatus r of-        NoError -> return v-        rs      -> throwIO $ OpError rs-

@@ -1,4 +1,5 @@ {-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE CPP             #-}  {-| Module      : Database.Memcache.Server@@ -11,53 +12,53 @@  Handles the connections between a Memcached client and a single server. -Memcached expected errors (part of protocol) are returned in the Response,-unexpected errors (e.g., network failure) are thrown as exceptions. While-the Server datatype supports a `failed` and `failedAt` flag for managing-retries, it's up to consumers to use this.+Memcached expected errors (part of the protocol) are returned in the Response;+unexpected errors, such as network failures, are thrown as exceptions. The+server's 'failed' timestamp is used by cluster retry handling. -} module Database.Memcache.Server (       -- * Server-        Server(sid, failed), newServer, sendRecv, withSocket, close-    ) where+        Server(sid, failed), newServerDefault, withSocket, close, -import Database.Memcache.SASL-import Database.Memcache.Socket+      -- * ServerOptions+        ServerOptions(..)+    ) where -import Control.Exception-import Data.Hashable-import Data.IORef-import Data.Pool-import Data.Time.Clock (NominalDiffTime)-import Data.Time.Clock.POSIX (POSIXTime)+import           Database.Memcache.Auth+import           Database.Memcache.Socket -import Network.Socket (getAddrInfo, HostName, ServiceName)-import qualified Network.Socket as S+import           Data.Default+import           Data.Hashable+import           Data.IORef+import qualified Data.Pool as P+import           Data.Pool (Pool)+import           Data.Time.Clock.POSIX    (POSIXTime)+import           Database.Memcache.Types  (ServerSpec (..))+import           UnliftIO.Exception --- Connection pool constants.--- TODO: make configurable-sSTRIPES, sCONNECTIONS :: Int-sKEEPALIVE :: NominalDiffTime-sSTRIPES     = 1-sCONNECTIONS = 1-sKEEPALIVE = 300+import           Network.Socket           (HostName, ServiceName, getAddrInfo)+import qualified Network.Socket           as S+#if MIN_VERSION_resource_pool(0,4,0)+#else+import           Data.Time.Clock          (NominalDiffTime)+#endif  -- | Memcached server connection. data Server = Server {         -- | ID of server for consistent hashing.-        sid      :: {-# UNPACK #-} !Int,+        sid    :: {-# UNPACK #-} !Int,         -- | Connection pool to server.-        pool     :: Pool Socket,+        pool   :: Pool Connection,         -- | Hostname of server.-        addr     :: !HostName,+        addr   :: !HostName,         -- | Port number of server.-        port     :: !ServiceName,+        port   :: !ServiceName,         -- | Credentials for server.-        auth     :: !Authentication,+        auth   :: !Authentication,         -- | When did the server fail? 0 if it is alive.-        failed   :: IORef POSIXTime+        failed :: IORef POSIXTime -        -- TODO: +        -- TODO:         -- weight   :: Double         -- tansport :: Transport (UDP vs. TCP)         -- poolLim  :: Int (pooled connection limit)@@ -74,57 +75,88 @@ instance Ord Server where     compare x y = compare (sid x) (sid y) --- | Create a new Memcached server connection.-newServer :: HostName -> ServiceName -> Authentication -> IO Server-newServer host port auth = do+-- | Configurable options when creating a @Server@.+--+-- At the moment, this only applies to the @Pool@ information. This can be expanded in the future.+--+data ServerOptions+  = ServerOptions+  -- | Maximum number of pooled connections per stripe.+  { soNumResources :: Int+  -- | Number of pool stripes.+  , soNumStripes :: Int+#if MIN_VERSION_resource_pool(0,4,0)+  -- | Connection keep-alive duration.+  , soKeepAlive :: Double+#else+  -- | Connection keep-alive duration.+  , soKeepAlive :: NominalDiffTime+#endif+  }++instance Default ServerOptions where+  def = ServerOptions+      { soNumResources = 1+      , soNumStripes = 1+      , soKeepAlive = 300+      }++-- | Create a server using the default socket-pool implementation.+newServerDefault :: ServerOptions -> ServerSpec -> IO Server+newServerDefault serverOptions ss@ServerSpec{..} = do     fat <- newIORef 0-    pSock <- createPool connectSocket releaseSocket-                sSTRIPES sKEEPALIVE sCONNECTIONS+    pSock <- getNewPool serverOptions ss     return Server         { sid      = serverHash         , pool     = pSock-        , addr     = host-        , port     = port-        , auth     = auth+        , addr     = ssHost+        , port     = ssPort+        , auth     = ssAuth         , failed   = fat         }   where-    serverHash = hash (host, port)+    serverHash = hash (ssHost, ssPort) -    connectSocket = do-        let hints = S.defaultHints {-          S.addrSocketType = S.Stream-        }-        addr:_ <- getAddrInfo (Just hints) (Just host) (Just port)-        bracketOnError-            (S.socket (S.addrFamily addr) (S.addrSocketType addr) (S.addrProtocol addr))-            releaseSocket-            (\s -> do-                S.connect s $ S.addrAddress addr-                S.setSocketOption s S.KeepAlive 1-                S.setSocketOption s S.NoDelay 1-                authenticate s auth-                return s-            ) -    releaseSocket = S.close---- | Send and receive a single request/response pair to the Memcached server.-sendRecv :: Server -> Request -> IO Response-{-# INLINE sendRecv #-}-sendRecv svr msg = withSocket svr $ \s -> do-    send s msg-    recv s---- | Run a function with access to an server socket for using 'send' and--- 'recv'.-withSocket :: Server -> (Socket -> IO a) -> IO a+-- | Run a function with access to a pooled server connection.+withSocket :: Server -> (Connection -> IO a) -> IO a {-# INLINE withSocket #-}-withSocket svr = withResource $ pool svr+withSocket svr = P.withResource $ pool svr --- | Close the server connection. If you perform another operation after this,--- the connection will be re-established.+-- | Close all pooled connections. A later operation re-establishes them. close :: Server -> IO () {-# INLINE close #-}-close srv = destroyAllResources $ pool srv+close srv = P.destroyAllResources $ pool srv +#if MIN_VERSION_resource_pool(0,4,0)+getNewPool :: ServerOptions -> ServerSpec -> IO (Pool Connection)+getNewPool serverOptions ss =+  P.newPool+    $ P.setNumStripes (Just $ soNumStripes serverOptions)+    $ P.defaultPoolConfig (connectSocket ss) releaseSocket (soKeepAlive serverOptions) (soNumResources serverOptions)+#else+getNewPool :: ServerOptions -> ServerSpec -> IO (Pool Connection)+getNewPool serverOptions ss =+  P.createPool (connectSocket ss) releaseSocket (soNumStripes serverOptions) (soKeepAlive serverOptions) (soNumResources serverOptions)+#endif++connectSocket :: ServerSpec -> IO Connection+connectSocket ServerSpec{..} = do+    let hints = S.defaultHints {+      S.addrSocketType = S.Stream+    }+    addr:_ <- getAddrInfo (Just hints) (Just ssHost) (Just ssPort)+    bracketOnError+        (S.socket (S.addrFamily addr) (S.addrSocketType addr) (S.addrProtocol addr))+        S.close+        (\s -> do+            S.connect s $ S.addrAddress addr+            S.setSocketOption s S.KeepAlive 1+            S.setSocketOption s S.NoDelay 1+            buffered <- newConnection s+            authenticate buffered ssAuth+            return buffered+        )++releaseSocket :: Connection -> IO ()+releaseSocket = closeConnection

@@ -1,417 +1,351 @@-{-# LANGUAGE BangPatterns #-} {-# LANGUAGE CPP #-}-{-# OPTIONS_GHC -fno-warn-warnings-deprecations #-}+{-# LANGUAGE OverloadedStrings #-}  {-| Module      : Database.Memcache.Socket-Description : Connection Handling+Description : Meta Text protocol socket handling Copyright   : (c) David Terei, 2016 License     : BSD Maintainer  : code@davidterei.com Stability   : stable Portability : GHC -Handles a single Memcached connection, sending and receiving requests.+Low-level connections, replies, and request encoders for Memcached's Meta Text+protocol. Authentication uses the text auth-file command. -} module Database.Memcache.Socket (         -- * Types-        Socket, Request(..), Response(..),+        ArithMode(..), Connection, Response(..), StoreMode(..), WireKey(..),+        crlf,          -- * Operations-        send, recv,+        newConnection, closeConnection,+        sendRaw,+        recvExact, recvLine, recvRawUntil, recvResponse, -        -- * Serialization / Deserialization-        szRequest, szResponse, dzHeader, dzResponse-    ) where+        -- * Response readers+        responseStatus, responseCas, responseFlags, responseNumber, --- FIXME: Wire works with lazy bytestrings but we receive strict bytestrings--- from the network...+        -- * Constructors+        encodeKey, getRequest, getManyRequest, gatRequest, touchRequest,+        storeRequest, arithmeticRequest, deleteRequest, flushRequest,+        versionRequest, modifyRequest, statsRequest, quitRequest, authRequest,+        noOpRequest+    ) where  import           Database.Memcache.Errors import           Database.Memcache.Types -import           Blaze.ByteString.Builder #if __GLASGOW_HASKELL__ < 710 import           Control.Applicative #endif-import           Control.Exception (throw, throwIO)-import           Control.Monad-import           Data.Binary.Get-import qualified Data.ByteString as B-import qualified Data.ByteString.Lazy as L-import           Data.Word-import           Network.Socket (Socket)+import           Control.Monad             (unless)+import           Data.ByteString           (ByteString)+import qualified Data.ByteString           as B+import qualified Data.ByteString.Base64    as Base64+import qualified Data.ByteString.Char8     as C+import           Data.IORef+import           Data.List                 (find, isInfixOf)+import           Data.Maybe                (fromMaybe)+import           Data.Word                 (Word64)+import qualified Network.Socket            as N import qualified Network.Socket.ByteString as N+import           Text.Read                 (readMaybe)+import           UnliftIO.Exception        (throwIO) --- | Send a request to the Memcached server.-send :: Socket -> Request -> IO ()-{-# INLINE send #-}-send s m = N.sendAll s (toByteString $ szRequest m)+-- | A connected Memcached socket and its receive buffer.+data Connection = Connection N.Socket (IORef ByteString) --- | Retrieve a single response from the Memcached server.--- FIXME: read into buffer to minimize read syscalls-recv :: Socket -> IO Response-{-# INLINE recv #-}-recv s = do-    header <- recvAll mEMCACHE_HEADER_SIZE mempty-    let h = runGet (dzHeader PktResponse) (L.fromChunks [header])-    if bodyLen h > 0-        then do-            let bytesToRead = fromIntegral $ bodyLen h-            body <- recvAll bytesToRead mempty-            return $ dzResponse h (L.fromChunks [body])-        else return $ dzResponse h L.empty-  where-    recvAll :: Int -> Builder -> IO B.ByteString-    recvAll 0 !acc = return $! toByteString acc-    recvAll !n !acc = do-        buf <- N.recv s n-        case B.length buf of-            0  -> throwIO errEOF-            bl | bl == n ->-                return $! (toByteString $! acc <> fromByteString buf)-            bl -> recvAll (n - bl) (acc <> fromByteString buf)-    -    errEOF :: MemcacheError-    errEOF = ProtocolError UnexpectedEOF { protocolError = "" }+-- | A decoded Meta Text response.+data Response = Response+  -- | The response code, such as @VA@ or @HD@.+  { responseCode :: ByteString+  -- | Tokens following the response code.+  , responseTokens :: [ByteString]+  -- | The response value, when the response contains one.+  , responseValue :: ByteString+  } deriving (Eq, Show) --- | Serialize a response to a ByteString Builder.-szResponse :: Response -> Builder-szResponse res =-       fromWord8 0x81-    <> fromWord8 c-    <> fromWord16be (fromIntegral keyl)-    <> fromWord8 (fromIntegral extl)-    <> fromWord8 0-    <> fromWord16be 0-    <> fromWord32be (fromIntegral $ extl + keyl + vall)-    <> fromWord32be (resOpaque res)-    <> fromWord64be (resCas res)-    <> ext'-    <> key'-    <> val'-  where-    (c, k', v', ext', extl) = szOpResponse (resOp res)-    (keyl, key') = case k' of-        Just k  -> (B.length k, fromByteString k)-        Nothing -> (0, mempty)-    (vall, val') = case v' of-        Just v  -> (B.length v, fromByteString v)-        Nothing -> (0, mempty)+-- | Create a connection wrapper around a socket.+newConnection :: N.Socket -> IO Connection+newConnection s = Connection s <$> newIORef B.empty -szOpResponse :: OpResponse -> (Word8, Maybe Key, Maybe Value, Builder, Int)-szOpResponse o = case o of-    ResGet       Loud    v f -> (0x00, Nothing, Just v, fromWord32be f, 4)-    ResGet       Quiet   v f -> (0x09, Nothing, Just v, fromWord32be f, 4)-    ResGetK      Loud  k v f -> (0x0C, Just k,  Just v, fromWord32be f, 4)-    ResGetK      Quiet k v f -> (0x0D, Just k,  Just v, fromWord32be f, 4)-    ResSet       Loud        -> (0x01, Nothing, Nothing, mempty, 0)-    ResSet       Quiet       -> (0x11, Nothing, Nothing, mempty, 0)-    ResAdd       Loud        -> (0x02, Nothing, Nothing, mempty, 0)-    ResAdd       Quiet       -> (0x12, Nothing, Nothing, mempty, 0)-    ResReplace   Loud        -> (0x03, Nothing, Nothing, mempty, 0)-    ResReplace   Quiet       -> (0x13, Nothing, Nothing, mempty, 0)-    ResDelete    Loud        -> (0x04, Nothing, Nothing, mempty, 0)-    ResDelete    Quiet       -> (0x14, Nothing, Nothing, mempty, 0)-    ResIncrement Loud      f -> (0x05, Nothing, Nothing, fromWord64be f, 8)-    ResIncrement Quiet     f -> (0x15, Nothing, Nothing, fromWord64be f, 8)-    ResDecrement Loud      f -> (0x06, Nothing, Nothing, fromWord64be f, 8)-    ResDecrement Quiet     f -> (0x16, Nothing, Nothing, fromWord64be f, 8)-    ResAppend    Loud        -> (0x0E, Nothing, Nothing, mempty, 0)-    ResAppend    Quiet       -> (0x19, Nothing, Nothing, mempty, 0)-    ResPrepend   Loud        -> (0x0F, Nothing, Nothing, mempty, 0)-    ResPrepend   Quiet       -> (0x1A, Nothing, Nothing, mempty, 0)-    ResTouch                 -> (0x1C, Nothing, Nothing, mempty, 0)-    ResGAT       Loud    v f -> (0x1D, Nothing,  Just v, fromWord32be f, 4)-    ResGAT       Quiet   v f -> (0x1E, Nothing,  Just v, fromWord32be f, 4)-    ResGATK      Loud  k v f -> (0x23,  Just k,  Just v, fromWord32be f, 4)-    ResGATK      Quiet k v f -> (0x24,  Just k,  Just v, fromWord32be f, 4)-    ResFlush     Loud        -> (0x08, Nothing, Nothing, mempty, 0)-    ResFlush     Quiet       -> (0x18, Nothing, Nothing, mempty, 0)-    ResNoop                  -> (0x0A, Nothing, Nothing, mempty, 0)-    ResVersion           v   -> (0x0B, Nothing,  Just v, mempty, 0)-    ResStat            k v   -> (0x10,  Just k,  Just v, mempty, 0)-    ResQuit      Loud        -> (0x07, Nothing, Nothing, mempty, 0)-    ResQuit      Quiet       -> (0x17, Nothing, Nothing, mempty, 0)-    ResSASLList          v   -> (0x20, Nothing,  Just v, mempty, 0)-    ResSASLStart             -> (0x21, Nothing, Nothing, mempty, 0)-    ResSASLStep              -> (0x22, Nothing, Nothing, mempty, 0)+-- | Close the underlying socket.+closeConnection :: Connection -> IO ()+closeConnection (Connection s _) = N.close s --- | Serialize a request to a ByteString Builder.-szRequest :: Request -> Builder-szRequest req =-       fromWord8 0x80-    <> fromWord8 c-    <> fromWord16be (fromIntegral keyl)-    <> fromWord8 (fromIntegral extl)-    <> fromWord8 0-    <> fromWord16be 0-    <> fromWord32be (fromIntegral $ extl + keyl + vall)-    <> fromWord32be (reqOpaque req)-    <> fromWord64be (reqCas req)-    <> ext'-    <> key'-    <> val'+-- | Send raw bytes on the underlying socket.+sendRaw :: Connection -> ByteString -> IO ()+sendRaw (Connection s _) = N.sendAll s++-- | Receive and decode one Meta Text response.+recvResponse :: Connection -> IO Response+recvResponse s = do+  line <- recvLine s+  case C.words line of+    [] -> throwIO $ ProtocolError UnknownPkt { protocolError = "" }+    code:tokens -> case tokens of+      n:_ | code == "VA" -> do+        value <- recvExact s =<< parseLength n+        trailer <- recvLine s+        unless (trailer == "\r") $ throwIO $ ProtocolError BadLength+          { protocolError = "value is not followed by an empty line" }+        return $ Response code tokens value+      _ -> return $ Response code tokens B.empty   where-    (c, k', v', ext', extl) = szOpRequest (reqOp req)-    (keyl, key') = case k' of-        Just k  -> (B.length k, fromByteString k)-        Nothing -> (0, mempty)-    (vall, val') = case v' of-        Just v  -> (B.length v, fromByteString v)-        Nothing -> (0, mempty)+    parseLength x = case readMaybe (C.unpack x) of+      Just n | n >= 0 && n <= 128 * 1024 * 1024 -> return n+      _ -> throwIO $ ProtocolError BadLength { protocolError = "invalid value length" } --- Extract needed info from an OpRequest for serialization.--- FIXME: Make sure this is optimized well (no tuple, boxing, unboxing, inlined)-szOpRequest :: OpRequest -> (Word8, Maybe Key, Maybe Value, Builder, Int)-szOpRequest o = case o of-    -- FIXME: make sure this isn't a thunk! (c)-    ReqGet      q k key   -> let c | q == Loud && k == NoKey      = 0x00-                                   | q == Loud && k == IncludeKey = 0x0C-                                   |              k == NoKey      = 0x09 -- Quiet-                                   | otherwise                    = 0x0D -- Quiet && IncludeKey-                             in (c, Just key, Nothing, mempty, 0)+-- | Convert a response code and tokens to the corresponding status.+responseStatus :: Response -> IO Status+responseStatus (Response code tokens _) = case code of+  "VA"           -> return NoError+  "HD"           -> return NoError+  "EN"           -> return ErrKeyNotFound+  "NF"           -> return ErrKeyNotFound+  "EX"           -> return ErrKeyExists+  "NS"           -> return ErrItemNotStored+  "ST"           -> return NoError+  "STORED"       -> return NoError+  "VERSION"      -> return NoError+  "STAT"         -> return NoError+  "OK"           -> return NoError+  "END"          -> return NoError+  "MN"           -> return NoError+  "SERVER_ERROR" -> serverFailure+  "CLIENT_ERROR" -> clientFailure+  "ERROR"        -> throwIO $ ProtocolError UnknownOp { protocolError = "ERROR" }+  _              -> throwIO $ ProtocolError UnknownStatus { protocolError = C.unpack code }+  where+    message = C.unpack $ C.unwords tokens -    ReqSet       Loud  key v e -> (0x01, Just key, Just v, szSESet e, 8)-    ReqSet       Quiet key v e -> (0x11, Just key, Just v, szSESet e, 8)-    ReqAdd       Loud  key v e -> (0x02, Just key, Just v, szSESet e, 8)-    ReqAdd       Quiet key v e -> (0x12, Just key, Just v, szSESet e, 8)-    ReqReplace   Loud  key v e -> (0x03, Just key, Just v, szSESet e, 8)-    ReqReplace   Quiet key v e -> (0x13, Just key, Just v, szSESet e, 8)-    ReqDelete    Loud  key     -> (0x04, Just key, Nothing, mempty, 0)-    ReqDelete    Quiet key     -> (0x14, Just key, Nothing, mempty, 0)-    ReqIncrement Loud  key   e -> (0x05, Just key, Nothing, szSEIncr e, 20)-    ReqIncrement Quiet key   e -> (0x15, Just key, Nothing, szSEIncr e, 20)-    ReqDecrement Loud  key   e -> (0x06, Just key, Nothing, szSEIncr e, 20)-    ReqDecrement Quiet key   e -> (0x16, Just key, Nothing, szSEIncr e, 20)-    ReqAppend    Loud  key v   -> (0x0E, Just key, Just v, mempty, 0)-    ReqAppend    Quiet key v   -> (0x19, Just key, Just v, mempty, 0)-    ReqPrepend   Loud  key v   -> (0x0F, Just key, Just v, mempty, 0)-    ReqPrepend   Quiet key v   -> (0x1A, Just key, Just v, mempty, 0)-    ReqTouch           key   e -> (0x1C, Just key, Nothing, szSETouch e, 4)-    -- FIXME: beware allocation.-    ReqGAT       q k   key   e -> let c | q == Quiet && k == IncludeKey = 0x24-                                        | q == Quiet && k == NoKey      = 0x1E-                                        | k == IncludeKey               = 0x23-                                        | otherwise                     = 0x1D-                                  in (c, Just key, Nothing, szSETouch e, 4)-    ReqFlush    Loud  (Just e) -> (0x08, Nothing, Nothing, szSETouch e, 4)-    ReqFlush    Quiet (Just e) -> (0x18, Nothing, Nothing, szSETouch e, 4)-    ReqFlush    Loud  Nothing  -> (0x08, Nothing, Nothing, mempty, 0)-    ReqFlush    Quiet Nothing  -> (0x18, Nothing, Nothing, mempty, 0)-    ReqNoop                    -> (0x0A, Nothing, Nothing, mempty, 0)-    ReqVersion                 -> (0x0B, Nothing, Nothing, mempty, 0)-    ReqStat           key      -> (0x10, key, Nothing, mempty, 0)-    ReqQuit     Loud           -> (0x07, Nothing, Nothing, mempty, 0)-    ReqQuit     Quiet          -> (0x17, Nothing, Nothing, mempty, 0)-    ReqSASLList                -> (0x20, Nothing, Nothing, mempty, 0)-    ReqSASLStart      key v    -> (0x21, Just key, Just v, mempty, 0)-    ReqSASLStep       key v    -> (0x22, Just key, Just v, mempty, 0)+    -- Meta Text reports these as free-form error text where the binary+    -- protocol had dedicated status codes; match them back so callers keep+    -- seeing 'OpError' rather than an opaque protocol failure.+    serverFailure+      | "object too large" `isInfixOf` message = throwStatus ErrValueTooLarge+      | "out of memory"    `isInfixOf` message = throwStatus ErrOutOfMemory+      | otherwise = throwIO $ ProtocolError ServerError { protocolError = message } -    -- XXX: Should kill in future, ugly-    ReqRaw c k v (SERaw e n)   -> (c, k, v, e, n)+    clientFailure+      | "non-numeric" `isInfixOf` message = throwStatus ErrValueNonNumeric+      | otherwise = throwIO $ ProtocolError BadCommand { protocolError = message } -  where-    szSESet   (SESet    f e) = fromWord32be f <> fromWord32be e-    szSEIncr  (SEIncr i d e) = fromWord64be i <> fromWord64be d <> fromWord32be e-    szSETouch (SETouch    e) = fromWord32be e+-- | Extract the CAS version from a response, or zero when absent or invalid.+responseCas :: Response -> Version+responseCas = token64 "c" . responseTokens --- | Deserialize a Header from a ByteString.-dzHeader :: PktType -> Get Header-{-# INLINE dzHeader #-}-dzHeader pkt = do-    m   <- getWord8-    case pkt of-      PktResponse -> when (m /= 0x81) $-          throw $ ProtocolError UnknownPkt { protocolError = show m }-      PktRequest -> when (m /= 0x80) $-          throw $ ProtocolError UnknownPkt { protocolError = show m }-    o   <- getWord8-    kl  <- getWord16be-    el  <- getWord8-    skip 1 -- unused data type field-    st  <- dzStatus-    bl  <- getWord32be-    opq <- getWord32be-    ver <- getWord64be-    return Header {-            op       = o,-            keyLen   = kl,-            extraLen = el,-            status   = st,-            bodyLen  = bl,-            opaque   = opq,-            cas      = ver-        }+-- | Extract the flags from a response, or zero when absent or invalid.+responseFlags :: Response -> Flags+responseFlags = fromIntegral . token64 "f" . responseTokens --- | Deserialize a Response body.-dzResponse :: Header -> L.ByteString -> Response-dzResponse h = runGet $-    case op h of-        0x00 -> dzGetResponse h $ ResGet Loud-        0x09 -> dzGetResponse h $ ResGet Quiet-        0x1D -> dzGetResponse h $ ResGAT Loud-        0x1E -> dzGetResponse h $ ResGAT Quiet-        0x0C -> dzGetKResponse h $ ResGetK Loud-        0x0D -> dzGetKResponse h $ ResGetK Quiet-        0x23 -> dzGetKResponse h $ ResGATK Loud-        0x24 -> dzGetKResponse h $ ResGATK Quiet-        0x05 -> dzNumericResponse h $ ResIncrement Loud-        0x15 -> dzNumericResponse h $ ResIncrement Quiet-        0x06 -> dzNumericResponse h $ ResDecrement Loud-        0x16 -> dzNumericResponse h $ ResDecrement Quiet-        0x01 -> dzGenericResponse h $ ResSet Loud-        0x11 -> dzGenericResponse h $ ResSet Quiet-        0x02 -> dzGenericResponse h $ ResAdd Loud-        0x12 -> dzGenericResponse h $ ResAdd Quiet-        0x03 -> dzGenericResponse h $ ResReplace Loud-        0x13 -> dzGenericResponse h $ ResReplace Quiet-        0x04 -> dzGenericResponse h $ ResDelete Loud-        0x14 -> dzGenericResponse h $ ResDelete Quiet-        0x0E -> dzGenericResponse h $ ResAppend Loud-        0x19 -> dzGenericResponse h $ ResAppend Quiet-        0x0F -> dzGenericResponse h $ ResPrepend Loud-        0x1A -> dzGenericResponse h $ ResPrepend Quiet-        0x1C -> dzGenericResponse h ResTouch-        0x07 -> dzGenericResponse h $ ResQuit Loud-        0x17 -> dzGenericResponse h $ ResQuit Quiet-        0x08 -> dzGenericResponse h $ ResFlush Loud-        0x18 -> dzGenericResponse h $ ResFlush Quiet-        0x0A -> dzGenericResponse h ResNoop-        0x10 -> dzKeyValueResponse h ResStat-        0x0B -> dzValueResponse h ResVersion-        -- SASL-        0x20 -> dzValueResponse h ResSASLList-        0x21 -> dzGenericResponse h ResSASLStart-        0x22 -> dzGenericResponse h ResSASLStep+-- | Parse the numeric value in a response, or zero when it is absent or invalid.+responseNumber :: Response -> Word64+responseNumber = fromMaybe 0 . readMaybe . C.unpack . responseValue -        _    -> throw $ ProtocolError UnknownOp { protocolError = show (op h) }+token64 :: ByteString -> [ByteString] -> Word64+token64 prefix xs = fromMaybe 0 $ do+  token <- find (B.isPrefixOf prefix) xs+  readMaybe (C.unpack (B.drop (B.length prefix) token)) --- | Deserialize the body of a Response that contains nothing.-dzGenericResponse :: Header -> OpResponse -> Get Response-dzGenericResponse h o = do-    skip (fromIntegral $ bodyLen h)-    chkLength 0 (extraLen h) "Extra"-    chkLength 0 (keyLen   h) "Key"-    chkLength 0 (bodyLen  h) "Body"-    return Res {-            resOp     = o,-            resStatus = status h,-            resOpaque = opaque h,-            resCas    = cas h-        }+-- | Longest response line accepted before assuming the stream is desynchronised.+maxLineLength :: Int+maxLineLength = 8 * 1024 --- | Deserialize the body of a Get Response (Extras [flags] & Value).-dzGetResponse :: Header -> (Value -> Flags -> OpResponse) -> Get Response-dzGetResponse h o = do-    e <- if status h == NoError && el == 4-            then getWord32be-            else skip el >> return 0-    v <- getByteString vl-    chkLength 4 el "Extra"-    chkLength 0 (keyLen h) "Key"-    return Res {-            resOp     = o v e,-            resStatus = status h,-            resOpaque = opaque h,-            resCas    = cas h-        }+-- | Receive one CRLF-terminated line, without the line-feed byte.+recvLine :: Connection -> IO ByteString+recvLine s = do+  buffer <- readBuffer s+  case B.elemIndex 10 buffer of+    Just i -> writeBuffer s (B.drop (i + 1) buffer) >> return (B.take i buffer)+    Nothing+      | B.length buffer > maxLineLength ->+        throwIO $ ProtocolError BadLength { protocolError = "response line too long" }+      | otherwise -> readChunk 0 s >> recvLine s++-- | Receive exactly the requested number of bytes.+recvExact :: Connection -> Int -> IO ByteString+recvExact s n+  | n < 0 = throwIO $ ProtocolError BadLength { protocolError = "negative length" }+  | otherwise = B.concat <$> go n []   where-    el = fromIntegral $ extraLen h-    vl = fromIntegral (bodyLen h) - el-    --- | Deserialize the body of a GetK Response (Extras [flags] & Key & Value).-dzGetKResponse :: Header -> (Key -> Value -> Flags -> OpResponse) -> Get Response-dzGetKResponse h o = do-    e <- if status h == NoError && el == 4-            then getWord32be-            else skip el >> return 0-    k <- getByteString kl-    v <- getByteString vl-    chkLength 4 el "Extra"-    -- FIXME: check strictness ($!)-    return Res {-            resOp     = o k v e,-            resStatus = status h,-            resOpaque = opaque h,-            resCas    = cas h-        }+    go 0 acc = return (reverse acc)+    go wanted acc = do+      buffer <- readBuffer s+      let takeN = min wanted (B.length buffer)+      if takeN > 0+        then writeBuffer s (B.drop takeN buffer) >> go (wanted - takeN) (B.take takeN buffer : acc)+        else readChunk wanted s >> go wanted acc++-- | Receive through the first occurrence of a delimiter, including it.+recvRawUntil :: ByteString -> Connection -> IO ByteString+recvRawUntil end s = go B.empty   where-    el = fromIntegral $ extraLen h-    kl = fromIntegral $ keyLen h-    vl = fromIntegral (bodyLen h) - el - kl+    go acc = do+      buffer <- readBuffer s+      let combined = acc <> buffer+      case B.breakSubstring end combined of+        (before, rest) | not (B.null rest) -> do+          writeBuffer s (B.drop (B.length end) rest)+          return (before <> end)+        _ -> writeBuffer s B.empty >> readChunk 0 s >> go combined --- | Deserialize the body of a Incr/Decr Response (Value [Word64]).-dzNumericResponse :: Header -> (Word64 -> OpResponse) -> Get Response-dzNumericResponse h o = do-    v <- if status h == NoError && bodyLen h == 8-            then getWord64be-            else skip (fromIntegral $ bodyLen h) >> return 0-    chkLength 0 (extraLen h) "Extra"-    chkLength 0 (keyLen   h) "Key"-    chkLength 8 (bodyLen  h) "Body"-    return Res {-            resOp     = o v,-            resStatus = status h,-            resOpaque = opaque h,-            resCas    = cas h-        }+readChunk :: Int -> Connection -> IO ()+readChunk n (Connection s ref) = do+  chunk <- N.recv s (max 4096 n)+  if B.null chunk then throwIO eofError else modifyIORef' ref (<> chunk) --- | Deserialize the body of a general response that just has a value (no key--- or extras).-dzValueResponse :: Header -> (Value -> OpResponse) -> Get Response-dzValueResponse h o = do-    v <- getByteString (fromIntegral $ bodyLen h)-    chkLength 0 (extraLen h) "Extra"-    chkLength 0 (keyLen   h) "Key"-    return Res {-            resOp     = o v,-            resStatus = status h,-            resOpaque = opaque h,-            resCas    = cas h-        }+readBuffer :: Connection -> IO ByteString+readBuffer (Connection _ ref) = readIORef ref --- | Deserialize the body of a general response that just has a key and value--- (no extras).-dzKeyValueResponse :: Header -> (Key -> Value -> OpResponse) -> Get Response-dzKeyValueResponse h o = do-    k <- getByteString kl-    v <- getByteString vl-    chkLength 0 (extraLen h) "Extra"-    return Res {-            resOp     = o k v,-            resStatus = status h,-            resOpaque = opaque h,-            resCas    = cas h-        }+writeBuffer :: Connection -> ByteString -> IO ()+writeBuffer (Connection _ ref) = writeIORef ref++eofError :: MemcacheError+eofError = ProtocolError UnexpectedEOF { protocolError = "" }++-- | A key encoded for the Meta Text wire protocol.+data WireKey = WireKey+  -- | The bytes sent as the key.+  { wireKey :: !ByteString+  -- | Whether the key uses the protocol's base64 binary-key mode.+  , wireB64 :: !Bool+  } deriving (Eq, Show)++-- | Encode a key, using base64 when it contains protocol-invalid bytes.+encodeKey :: Key -> Either ClientError WireKey+encodeKey key+  | B.null key = Left (KeyTooLong "empty key")+  | B.length key > 250 = Left (KeyTooLong "key exceeds 250 bytes")+  | B.length wire > 250 = Left (KeyTooLong "encoded key exceeds 250 bytes")+  | otherwise = Right (WireKey wire b64)   where-    kl = fromIntegral $ keyLen h-    vl = fromIntegral (bodyLen h) - kl+    b64 = B.any (\c -> c <= 0x20 || c == 0x7f) key+    wire = if b64 then Base64.encode key else key --- | Deserialize a Response status code.-dzStatus :: Get Status-dzStatus = do-    st <- getWord16be-    return $ case st of-        0x00 -> NoError-        0x01 -> ErrKeyNotFound-        0x02 -> ErrKeyExists-        0x03 -> ErrValueTooLarge-        0x04 -> ErrInvalidArgs-        0x05 -> ErrItemNotStored-        0x06 -> ErrValueNonNumeric-        0x81 -> ErrUnknownCommand-        0x82 -> ErrOutOfMemory-        0x20 -> SaslAuthFail-        0x21 -> SaslAuthContinue-        _    -> throw $ ProtocolError UnknownStatus { protocolError = show st }+keyArgs :: WireKey -> ByteString+keyArgs (WireKey wire b64) = wire <> if b64 then " b" else B.empty --- | Check the length of a header field is as expected, throwing a--- ProtocolError exception if it is not.-chkLength :: (Eq a, Show a) => a -> a -> String -> Get ()-{-# INLINE chkLength #-}-chkLength expected l msg = when (l /= expected) $-  return $ throw $ ProtocolError BadLength { protocolError =-      msg ++ " length expected " ++ show expected ++ " got " ++ show l-  }+keyFlag :: WireKey -> ByteString+keyFlag (WireKey _ b64) = if b64 then " b" else B.empty +dec :: Show a => a -> ByteString+dec = C.pack . show++-- | CRLF used to terminate Meta Text requests.+crlf :: ByteString+crlf = "\r\n"++-- | Meta Text storage operation.+data StoreMode+  -- | Store whether or not the key exists.+  = Set+  -- | Store only when the key does not exist.+  | Add+  -- | Store only when the key exists.+  | Replace+  -- | Add bytes to the end of an existing value.+  | Append+  -- | Add bytes to the beginning of an existing value.+  | Prepend+  deriving (Eq, Show)++-- | Meta Text arithmetic operation.+data ArithMode+  -- | Increment a numeric value.+  = Incr+  -- | Decrement a numeric value.+  | Decr+  deriving (Eq, Show)++storeMode :: StoreMode -> ByteString+storeMode Set = "S"+storeMode Add = "E"+storeMode Replace = "R"+storeMode Append = "A"+storeMode Prepend = "P"++arithMode :: ArithMode -> ByteString+arithMode Incr = "I"+arithMode Decr = "D"++cmdMetaGet, cmdMetaSet, cmdMetaDelete, cmdMetaArith, cmdMetaNoOp :: ByteString+cmdMetaGet = "mg"+cmdMetaSet = "ms"+cmdMetaDelete = "md"+cmdMetaArith = "ma"+cmdMetaNoOp = "mn"++cmdFlush, cmdVersion, cmdQuit, cmdStats, cmdSet :: ByteString+cmdFlush = "flush_all"+cmdVersion = "version"+cmdQuit = "quit"+cmdStats = "stats"+cmdSet = "set"++cas :: Version -> ByteString+cas n = if n == 0 then B.empty else " C" <> dec n++-- | Encode a get request for one key.+getRequest :: WireKey -> ByteString+getRequest key = cmdMetaGet <> " " <> keyArgs key <> " v f c" <> crlf++-- | Encode a quiet multi-get request for one key.+getManyRequest :: WireKey -> ByteString+getManyRequest key = cmdMetaGet <> " " <> keyArgs key <> " v f c k q" <> crlf++-- | Encode a get-and-touch request.+gatRequest :: WireKey -> Expiration -> ByteString+gatRequest key expiry = cmdMetaGet <> " " <> keyArgs key <> " v f c T" <> dec expiry <> crlf++-- | Encode a touch request.+touchRequest :: WireKey -> Expiration -> ByteString+touchRequest key expiry = cmdMetaGet <> " " <> keyArgs key <> " T" <> dec expiry <> " c" <> 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++-- | Encode an increment or decrement request.+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++-- | 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++-- | Encode a delete request.+deleteRequest :: WireKey -> Version -> ByteString+deleteRequest key version = cmdMetaDelete <> " " <> keyArgs key <> cas version <> 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++-- | Encode a version request.+versionRequest, quitRequest :: ByteString+versionRequest = cmdVersion <> crlf+quitRequest = cmdQuit <> crlf++-- | Encode a stats request, optionally scoped to a key.+statsRequest :: Maybe Key -> ByteString+statsRequest Nothing = cmdStats <> crlf+statsRequest (Just key) = cmdStats <> " " <> key <> crlf++-- | 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++-- | Encode a Meta Text no-op request.+noOpRequest :: ByteString+noOpRequest = cmdMetaNoOp <> crlf

@@ -11,195 +11,51 @@ representation of the protocol. -} module Database.Memcache.Types (-        -- * SASL Authentication+        -- * Authentication         Authentication(..), Username, Password,          -- * Fields & Values-        Q(..), K(..), Key, Value, Extras, Initial, Delta, Expiration, Flags,+        Key, Value, Initial, Delta, Expiration, Flags,         Version, Status(..),--        -- * Header-        Header(..), mEMCACHE_HEADER_SIZE, PktType(..),--        -- * Requests-        Request(..), OpRequest(..), SESet(..), SEIncr(..), SETouch(..),-        SERaw(..), emptyReq,--        -- * Responses-        Response(..), OpResponse(..), emptyRes+        ServerSpec(..), parseServerSpec     ) where -import Blaze.ByteString.Builder (Builder)-import Data.ByteString (ByteString)-import Data.Word---- | SASL Authentication information for a server.-data Authentication-    = Auth { username :: !Username, password :: !Password }-    | NoAuth-    deriving (Eq, Show)---- | Username for authentication.-type Username = ByteString---- | Password for authentication.-type Password = ByteString--{- MEMCACHED MESSAGE:--    header {-        magic    :: Word8-        op       :: Word8-        keyLen   :: Word16-        extraLen :: Word8-        datatype :: Word8-        status / reserved :: Word16-        bodyLen  :: Word32 (total body length)-        opaque   :: Word32-        cas      :: Word64-    }-    extras :: ByteString-    key    :: ByteString-    value  :: ByteString- -}--mEMCACHE_HEADER_SIZE :: Int-mEMCACHE_HEADER_SIZE = 24---- | Memcached packet header (for both 'Request' and 'Response').-data Header = Header {-        op       :: Word8,-        keyLen   :: Word16,-        extraLen :: Word8,-        status   :: Status,-        bodyLen  :: Word32,-        opaque   :: Word32,-        cas      :: Version-    } deriving (Eq, Show)--data PktType = PktRequest | PktResponse-    deriving (Eq, Show)+import           Data.ByteString (ByteString)+import           Data.Word+import           Database.Memcache.Types.Authentication (Authentication(..), Username, Password)+import           Database.Memcache.Types.ServerSpec (ServerSpec(..), parseServerSpec) -data Q          = Loud  | Quiet      deriving (Eq, Show)-data K          = NoKey | IncludeKey deriving (Eq, Show)+-- | Memcached key bytes. type Key        = ByteString+-- | Memcached value bytes. type Value      = ByteString-type Extras     = ByteString+-- | Initial value used when creating an arithmetic counter. type Initial    = Word64+-- | Arithmetic increment or decrement amount. type Delta      = Word64+-- | Expiration in protocol time units. type Expiration = Word32+-- | Application-defined value flags. type Flags      = Word32+-- | CAS version associated with a value. type Version    = Word64 -data OpRequest-    = ReqGet       Q K Key-    | ReqSet       Q   Key Value SESet-    | ReqAdd       Q   Key Value SESet-    | ReqReplace   Q   Key Value SESet-    | ReqDelete    Q   Key-    | ReqIncrement Q   Key       SEIncr-    | ReqDecrement Q   Key       SEIncr-    | ReqAppend    Q   Key Value-    | ReqPrepend   Q   Key Value-    | ReqTouch         Key       SETouch-    | ReqGAT       Q K Key       SETouch-    | ReqFlush     Q             (Maybe SETouch)-    | ReqNoop-    | ReqVersion-    | ReqStat          (Maybe Key)-    | ReqQuit      Q-    | ReqSASLList-    | ReqSASLStart     Key Value -- key: auth method, value: auth data-    | ReqSASLStep      Key Value -- key: auth method, value: auth data (continued)--    -- | Raw request is custom requests, dangerous as no corresponding raw-    -- response...-    | ReqRaw       Word8 (Maybe Key) (Maybe Value) SERaw-    deriving (Eq, Show)--{-# WARNING ReqRaw "This is dangerous; no future compatability guaranteed" #-}--data SESet   = SESet   Flags Expiration         deriving (Eq, Show)-data SEIncr  = SEIncr  Initial Delta Expiration deriving (Eq, Show)-data SETouch = SETouch Expiration               deriving (Eq, Show)-data SERaw   = SERaw   Builder Int--instance Show SERaw where-    show _ = "SERaw _"--instance Eq SERaw where-    (==) _ _ = False--data Request = Req {-        reqOp     :: OpRequest,-        reqOpaque :: Word32,-        reqCas    :: Version-    } deriving (Eq, Show)---- | Noop request.-emptyReq :: Request-emptyReq = Req { reqOp = ReqNoop, reqOpaque = 0, reqCas = 0 }--data OpResponse-    = ResGet       Q     Value Flags-    | ResGetK      Q Key Value Flags-    | ResSet       Q-    | ResAdd       Q-    | ResReplace   Q-    | ResDelete    Q-    | ResIncrement Q     Word64-    | ResDecrement Q     Word64-    | ResAppend    Q-    | ResPrepend   Q-    | ResTouch-    | ResGAT       Q     Value Flags-    | ResGATK      Q Key Value Flags-    | ResFlush     Q-    | ResNoop-    | ResVersion         Value-    | ResStat        Key Value-    | ResQuit      Q-    | ResSASLList        Value-    | ResSASLStart-    | ResSASLStep-    deriving (Eq, Show)---- | The status (success or error) of a Memcached operation returned in a--- 'Response'.+-- | Status reported by a Memcached operation. data Status-    -- | Operation successful.-    = NoError             -- All-    -- | Key not found.-    | ErrKeyNotFound      -- Get, GAT, Touch, Replace, Del, Inc, Dec, App, Pre, Set (key not there and version specified...)-    -- | Key exists when not expected.-    | ErrKeyExists        -- Add, (version): Set, Rep, Del, Inc, Dec, App, Pre-    -- | Value too large to store at server.-    | ErrValueTooLarge    -- Set, Add, Rep, Pre, App-    -- | Invalid arguments for operation.-    | ErrInvalidArgs      -- All-    -- | Key-Value pair not stored at server (internal error).-    | ErrItemNotStored    -- ?-    -- | Value not numeric when increment or decrement requested.-    | ErrValueNonNumeric  -- Incr, Decr-    -- | Server doesn't know requested command.-    | ErrUnknownCommand   -- All-    -- | Server out of memory.-    | ErrOutOfMemory      -- All-    -- | SASL authentication failed.-    | SaslAuthFail        -- SASL-    -- | SASL authentication requires more steps.-    | SaslAuthContinue    -- SASL+    -- | The operation succeeded.+    = NoError+    -- | The key was not found.+    | ErrKeyNotFound+    -- | The key already exists.+    | ErrKeyExists+    -- | The value exceeds the server limit.+    | ErrValueTooLarge+    -- | The item was not stored.+    | ErrItemNotStored+    -- | The value is not numeric.+    | ErrValueNonNumeric+    -- | The server is out of memory.+    | ErrOutOfMemory+    -- | Text authentication failed.+    | TextAuthFail     deriving (Eq, Show)---- | Memcached response packet.-data Response = Res {-        resOp     :: OpResponse,-        resStatus :: Status,-        resOpaque :: Word32,-        resCas    :: Version-    } deriving (Eq, Show)---- | Noop response.-emptyRes :: Response-emptyRes = Res { resOp = ResNoop, resStatus = NoError, resOpaque = 0, resCas = 0 }-

@@ -0,0 +1,32 @@+{-|+Module      : Database.Memcache.Types.Authentication+Description : Meta Text authentication types+Copyright   : (c) David Terei, 2016+License     : BSD+Maintainer  : code@davidterei.com+Stability   : stable+Portability : GHC+-}+module Database.Memcache.Types.Authentication (+        -- * Text authentication+        Authentication(..), Username, Password,+    ) where++import           Data.ByteString          (ByteString)+-- | Username and password information for text auth-file authentication.+data Authentication+    = Auth+        { -- | Username to send to the server.+          username :: !Username+          -- | Password to send to the server.+        , password :: !Password+        }+    -- | Do not authenticate the connection.+    | NoAuth+    deriving (Eq, Show)++-- | Username for text authentication.+type Username = ByteString++-- | Password for text authentication.+type Password = ByteString

@@ -0,0 +1,89 @@+{-# LANGUAGE OverloadedStrings #-}++{-|+Module      : Database.Memcache.Types.ServerSpec+Description : Memcached server specifications+Copyright   : (c) David Terei, 2016+License     : BSD+Maintainer  : code@davidterei.com+Stability   : stable+Portability : GHC++Server connection settings, including optional Meta Text auth-file+credentials.+-}+module Database.Memcache.Types.ServerSpec+  ( ServerSpec (..),+    parseServerSpec,+  )+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 Network.Socket (HostName, ServiceName)+import Network.URI (URI (..), URIAuth (..), parseAbsoluteURI)+import Data.Bifunctor (second)++-- | A Memcached server connection configuration.+data ServerSpec = ServerSpec+  { -- | Hostname of server to connect to.+    ssHost :: HostName,+    -- | Port number server is running on.+    ssPort :: ServiceName,+    -- | Credentials to use for text auth-file authentication with this server.+    ssAuth :: Authentication+  }+  deriving (Eq, Show)++-- | Parse a @memcached://@ URI into a @ServerSpec@.+parseServerSpec :: String -> Either String ServerSpec+parseServerSpec s = do+  uri <- note ("Not a valid URI: " <> s) $ parseAbsoluteURI s+  note "Must begin memcached://" $ guard $ uriScheme uri == "memcached:"++  let mAuth = uriAuthority uri++  pure+    . maybe id setHost mAuth+    . maybe id setPort mAuth+    . maybe id setAuth (readAuthentication . uriUserInfo =<< mAuth)+    $ def++readAuthentication :: String -> Maybe Authentication+readAuthentication = go . T.pack+  where+    go a = do+      (u, p) <- second (T.drop 1) . T.breakOn ":" <$> T.stripSuffix "@" a++      guard $ not $ T.null u+      guard $ not $ T.null p++      pure+        Auth+          { username = encodeUtf8 u,+            password = encodeUtf8 p+          }++setHost :: URIAuth -> ServerSpec -> ServerSpec+setHost auth ss = case uriRegName auth of+  "" -> ss+  rn -> ss {ssHost = rn}++setPort :: URIAuth -> ServerSpec -> ServerSpec+setPort auth ss = fromMaybe ss $ do+  p <- case uriPort auth of+    "" -> Nothing+    (':' : p) -> Just p+    p -> Just p+  pure $ ss {ssPort = p}++setAuth :: Authentication -> ServerSpec -> ServerSpec+setAuth auth ss = ss {ssAuth = auth}++instance Default ServerSpec where+  def = ServerSpec "127.0.0.1" "11211" NoAuth

@@ -1,4 +1,4 @@-Copyright (c) 2012, David Terei.+Copyright (c) 2012-2026, David Terei.  All rights reserved. 

@@ -1,26 +1,35 @@ # memcache: Haskell Memcached Client - [![Hackage](https://img.shields.io/hackage/v/memcache.svg?style=flat)](https://hackage.haskell.org/package/memcache) [![Hackage Dependencies](https://img.shields.io/hackage-deps/v/memcache.svg?style=flat)](http://packdeps.haskellers.com/reverse/memcache) [![BSD3 License](http://img.shields.io/badge/license-BSD3-brightgreen.svg?style=flat)][tl;dr Legal: BSD3]-[![Build](https://img.shields.io/travis/dterei/memcache-hs.svg?style=flat)](https://travis-ci.org/dterei/memcache-hs)+[![CI](https://github.com/dterei/memcache-hs/actions/workflows/ci.yml/badge.svg)](https://github.com/dterei/memcache-hs/actions/workflows/ci.yml) [![Gitter](https://badges.gitter.im/dterei/memcache-hs.svg)](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"+[tl;dr Legal: BSD3]: https://tldrlegal.com/license/bsd-3-clause-license-(revised) "BSD3 License"  A client library for a memcached cluster. -It supports the binary memcached protocol and SASL authentication. No support-for the ASCII protocol is provided. It supports connecting to a single, or a-cluster of memcached servers. When connecting to a cluser, consistent hashing-is used for routing requests to the appropriate server.+It supports the Meta Text memcached protocol and username/password+authentication. Keys containing whitespace or control bytes are sent using its+base64 binary-key mode. The encoded key must still fit within 250 bytes. 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. -Complete coverage of the memcached protocol is provided except for multi-get-and other pipelined operations.+**This library requires memcached 1.6.0 or newer**, the first release with the+meta commands. Against older servers every operation is rejected with `ERROR`. +Authentication uses a memcached auth file with `-Y authfile`, an experimental+ASCII-protocol auth mode added in memcached 1.5.15; the old binary protocol+`-S` SASL mode is not supported. Enabling `-Y` also disables binary and UDP+protocols on the server. `getMany` uses quiet misses, so a server connection+failure can be indistinguishable from a cache miss.++The client operations, including `getMany`, use direct Meta Text encoders and+the `Response` type; the former request and response wrapper types are no longer+provided.+ ## Licensing  This library is BSD-licensed.@@ -30,31 +39,30 @@ This library also includes a few tools for manipulating and experimenting with memcached servers. -* `OpGen` -- A load generator for memcached. Doesn't collect timing statistics,+- `OpGen` -- A load generator for memcached. Doesn't collect timing statistics,   other tools like [mutilate](https://github.com/leverich/mutilate) already do   that very well. This tool is useful in conjunction with mutilate.-* `Loader` -- A tool to load random data of a certain size into a memcached+- `Loader` -- A tool to load random data of a certain size into a memcached   server. Useful for priming a server for testing.  ## Architecture Notes -We're relying on `Data.Pool` for thread safety right now, which is fine but is-a blocking API in that when we grab a socket (`withResource`) we are blocking-any other requests being sent over that connection until we get a response.-That is, we can't pipeline.+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. -Now, use of multiple connections through the pool abstraction is an easy way to-solve this and perhaps the right approach. But, could also implement own pool-abstraction that allowed pipelining. This wouldn't be a pool abstraction so-much as just round-robbining over multiple connections for performance.+Multiple connections through the pool abstraction allow concurrent operations+and provide a simple performance path without requiring a separate pool+implementation.  Either way, a pool is fine for now.  ## Other clients -* [C: libmemcached](http://libmemcached.org/libMemcached.html)-* [Java: SpyMemcached](http://code.google.com/p/spymemcached/)-* [Ruby: Dalli](https://github.com/mperham/dalli)+- [C: libmemcached](http://libmemcached.org/libMemcached.html)+- [Java: SpyMemcached](http://code.google.com/p/spymemcached/)+- [Ruby: Dalli](https://github.com/mperham/dalli)  ## Get involved! @@ -66,7 +74,7 @@  Master [git repository](http://github.com/dterei/memcache-hs): -* `git clone https://github.com/dterei/memcache-hs.git`+- `git clone https://github.com/dterei/memcache-hs.git`  ## Authors @@ -74,7 +82,9 @@  Contributions have been made by the following great people: -* Alfredo Di Napoli (<alfredo.dinapoli@gmail.com>)-* Amit Levy-* Steven Leiva-+- Alfredo Di Napoli (<alfredo.dinapoli@gmail.com>)+- Amit Levy+- Chris Martin+- drlkf+- Joel McCracken+- Steven Leiva

@@ -1,7 +1,6 @@ module Main (main) where -import Distribution.Simple+import           Distribution.Simple  main :: IO () main = defaultMain-

@@ -1,33 +1,34 @@ ## ToDo  Optional:-* Typeclass abstracting key and values-* MonadIO?-* Safe Haskell-* Differentiate between two expiration modes?-* Simpler interface?-* Configurable fail-over mode +- Typeclass abstracting key and values+- MonadIO?+- Safe Haskell+- Differentiate between two expiration modes?+- Simpler interface?+- Configurable fail-over mode+ Protocol:-* Multi-get-* Generic multi operation support +- Review quiet multi-get behavior when a server closes before `mn`.+ Performance:-* Is System.Timeout still slow? Switch to Warp/Snap timeout handler?-* Is NominalDiffTime slow? Switch to unix epoch time? +- Is System.Timeout still slow? Switch to Warp/Snap timeout handler?+- Is NominalDiffTime slow? Switch to unix epoch time?+ Nice-to-have:-* Smarter connection handling to minimize system calls (buffered)-* Customizable server sharding -- mod & virtual servers-* Server weights-* Asynchronous support?-* Customizable -- timeout, max connection retries, hash algorithm-* Max value validation-* Optimizations --  http://code.google.com/p/spymemcached/wiki/Optimizations-* UDP-* ASCII-* Server error handling mode where we return misses and ignore sets +- Customizable server sharding -- mod & virtual servers+- Server weights+- Asynchronous support?+- Customizable -- timeout, max connection retries, hash algorithm+- Max value validation+- Optimizations -- http://code.google.com/p/spymemcached/wiki/Optimizations+- UDP+- Server error handling mode where we return misses and ignore sets+ Maybe:-* Automatic encoding and decoding of Haskell data types (using flags?) +- Automatic encoding and decoding of Haskell data types (using flags?)

@@ -1,59 +1,12 @@ {-# LANGUAGE OverloadedStrings #-} --- | Benchmark the parsing and serialization aspects of memcache.-module Main where--import Database.Memcache.Types-import Database.Memcache.Wire--import Criterion.Main-import Data.ByteString (ByteString)-import qualified Data.ByteString as B-import qualified Data.ByteString.Lazy as L-import qualified Data.ByteString.Lazy.Char8 as LC-import Data.Monoid+import           Criterion.Main+import           Database.Memcache.Socket  main :: IO ()-main =-    defaultMain [-        bgroup "serialize" [-            bench "get" $ whnf szRequest' getReqMsg,-            bench "set" $ whnf szRequest' setReqMsg-        ],-        bgroup "deserialize" [-            bench "get" $ whnf dzResponse' getRespBytes-        ]+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     ]--getReqMsg :: Request-getReqMsg = Req {-        reqOp     = ReqGet Loud NoKey "key!",-        reqOpaque = 123,-        reqCas    = 999-    }--setReqMsg :: Request-setReqMsg = Req {-        reqOp     = ReqSet Loud "key!" "hello world" (SESet 10 0),-        reqOpaque = 123,-        reqCas    = 999-    }--getRespHeaderBytes :: L.ByteString-getRespHeaderBytes =-    --        magic, op,               extral, 0-    L.pack $ [0x81, 0x00] ++ keyl' ++ [0x04, 0x00] ++ status' ++ bodyl' ++ opaque' ++ cas'-  where-    keyl'   = [0x00, 0x00]-    status' = [0x00, 0x00, 0x00, 0x00]-    bodyl'  = [0x00, 0x00, 0x00, 0x08]-    opaque' = [0x00, 0x00, 0x00, 0x07]-    cas'    = [0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x09]--getRespBytes :: L.ByteString-getRespBytes = getRespHeaderBytes <> extras' <> key' <> value'-  where-    extras' = L.pack  [0x00, 0x00, 0x00, 0x01] -- BE: so 1?-    key'    = L.pack  []-    value'  = LC.pack "12345678"-

@@ -1,136 +1,136 @@+cabal-version: 1.18++-- This file has been generated from package.yaml by hpack version 0.39.6.+--+-- see: https://github.com/sol/hpack+ name:           memcache-version:        0.3.0.2-homepage:       https://github.com/dterei/memcache-hs-bug-reports:    https://github.com/dterei/memcache-hs/issues+version:        0.4.0.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.-  .-  It supports the binary Memcached protocol and SASL authentication. No support-  for the ASCII protocol is provided. It supports connecting to a single, or a-  cluster of Memcached servers. When connecting to a cluser, consistent hashing-  is used for routing requests to the appropriate server. Timeouts, retrying-  failed operations, and failover to a different server are all supported.-  .-  Complete coverage of the Memcached protocol is provided except for multi-get-  and other pipelined operations.-  .-  Basic usage is:-  .-  > import qualified Database.Memcache.Client as M-  > -  > mc <- M.newClient [M.ServerSpec "localhost" "11211" M.NoAuth] M.def-  > M.set mc "key" "value" 0 0-  > v <- M.get mc "key"-  .-  You should only need to import 'Database.Memcache.Client', but for now other-  modules are exposed.-license:        BSD3-license-file:   LICENSE+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:      2016 David Terei.-category:       Database+copyright:      2012-2026 David Terei.+license:        BSD3+license-file:   LICENSE build-type:     Simple-cabal-version:  >= 1.10 extra-source-files:-  README.md, CHANGELOG.md, TODO.md--Source-repository this-  type: git-  location: https://github.com/dterei/memcache-hs.git-  tag: 0.3.0.2+    package.yaml+extra-doc-files:+    README.md+    CHANGELOG.md+    TODO.md  source-repository head-  type:     git-  location: https://github.com/dterei/memcache-hs.git+  type: git+  location: https://github.com/dterei/memcache-hs  library   exposed-modules:-    Database.Memcache.Client-    Database.Memcache.Cluster-    Database.Memcache.Errors-    Database.Memcache.SASL-    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:+      ./+  other-extensions:+      BangPatterns+      CPP+      DeriveDataTypeable+      FlexibleInstances+      RecordWildCards+      ScopedTypeVariables+  ghc-options: -Wall -Wextra -fwarn-tabs   build-depends:-    base               <  5,-    binary             >= 0.6.2.0,-    blaze-builder      >= 0.3.1.0,-    bytestring         >= 0.9.2.1,-    data-default-class >= 0.1.0,-    hashable           >= 1.2.0.3,-    network            >= 3.1.0.0,-    resource-pool      >= 0.2.1.0,-    vector             >= 0.7,-    time               >= 1.4+      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-  other-extensions:-    BangPatterns,-    CPP,-    DeriveDataTypeable,-    FlexibleInstances,-    RecordWildCards,-    ScopedTypeVariables-  ghc-options: -Wall -fwarn-tabs --- executable opgen---   hs-source-dirs: tools---   main-is: OpGen.hs---   ghc-options: -threaded---   build-depends:---     async,---     base < 5,---     bytestring,---     memcache,---     network------ executable load---   hs-source-dirs: tools---   main-is: Loader.hs---   ghc-options: -threaded---   build-depends:---     async,---     base < 5,---     bytestring,---     memcache,---     network--test-suite full-  type:           exitcode-stdio-1.0-  hs-source-dirs: test-  main-is:        Full.hs-  build-depends:-    base          <  5,-    binary        >= 0.6.2.0,-    blaze-builder >= 0.3.1.0,-    bytestring    >= 0.9.2.1,-    memcache,-    network       >= 2.4+test-suite integration+  type: exitcode-stdio-1.0+  main-is: Integration.hs   other-modules:-    MockServer+      Paths_memcache+  hs-source-dirs:+      test-integration+  other-extensions:+      BangPatterns+      CPP+      OverloadedStrings+  ghc-options: -Wall -Wextra -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+    , process+    , time   default-language: Haskell2010++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: -fwarn-tabs+      BangPatterns+      CPP+      OverloadedStrings+  ghc-options: -Wall -Wextra -threaded -rtsopts "-with-rtsopts=-N"+  build-depends:+      base >=4.16 && <5+    , base64-bytestring >=1.2.1.0+    , bytestring >=0.11.4.0+    , hspec+    , memcache+    , network+    , time >=1.11.1.1+    , unliftio+  default-language: Haskell2010  benchmark parser-  type:           exitcode-stdio-1.0-  hs-source-dirs: bench-  main-is:        Parser.hs+  type: exitcode-stdio-1.0+  main-is: Parser.hs+  other-modules:+      Paths_memcache+  hs-source-dirs:+      bench+  other-extensions:+      BangPatterns+      CPP+      OverloadedStrings   build-depends:-    base       <  5,-    bytestring >= 0.9.2.1,-    criterion  >  0.6.0.0,-    memcache+      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-  other-extensions:-    OverloadedStrings-  ghc-options: -fwarn-tabs-

@@ -0,0 +1,100 @@+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

@@ -0,0 +1,212 @@+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE TypeApplications #-}++module Main where++import           Control.Concurrent       (threadDelay)+import           Control.Exception        (SomeException, bracket, try)+import           Control.Monad            (void)+import qualified Data.ByteString.Char8    as B+import           Data.Either              (isRight)+import           Data.Maybe               (isJust)+import           Data.Time.Clock.POSIX    (getPOSIXTime)+import qualified Database.Memcache.Client as M+import           Database.Memcache.Types  (ServerSpec (..))+import           Network.Socket           (Family (AF_INET), SocketOption (ReuseAddr),+                                           SocketType (Stream), addrAddress, addrFamily,+                                           addrSocketType, bind, close, connect,+                                           defaultHints, defaultProtocol, getAddrInfo,+                                           setSocketOption, socket, socketPort,+                                           tupleToHostAddress)+import qualified Network.Socket           as N+import           System.Directory         (findExecutable)+import           System.Process           (ProcessHandle, createProcess, proc,+                                           getProcessExitCode, terminateProcess,+                                           waitForProcess)+import           Test.Hspec++main :: IO ()+main = do+  executable <- findExecutable "memcached"+  case executable of+    Nothing ->+      hspec $+        it "requires memcached" $+          pendingWith "memcached command not found"+    Just path -> withMemcached path $ \port ->+      hspec (integrationSpecs port)++integrationSpecs :: Int -> Spec+integrationSpecs port = beforeAll (newClient port) $ do+  it "reports its version" $ \client -> do+    version <- M.version client+    version `shouldSatisfy` (not . B.null)++  it "sets and gets values with flags and CAS" $ \client -> do+    cas <- M.set client "integration-set" "value" 7 0+    M.get client "integration-set" `shouldReturn` Just ("value", 7, cas)++  it "returns misses" $ \client ->+    M.get client "integration-missing" `shouldReturn` Nothing++  it "adds and replaces values" $ \client -> do+    stamp <- round . (* 1000000) <$> getPOSIXTime :: IO Integer+    let key = B.pack ("integration-add-" <> show port <> "-" <> show stamp)+    _ <- M.set client key "one" 0 0++    M.add client key "two" 0 0 `shouldReturn` Nothing++    M.replace client "integration-no-replace" "two" 0 0 0 `shouldReturn` Nothing++  it "updates values with CAS" $ \client -> do+    old <- M.set client "integration-cas" "old" 0 0+    new <- M.cas client "integration-cas" "new" 0 0 old++    new `shouldSatisfy` isJust++    M.cas client "integration-cas" "stale" 0 0 old `shouldReturn` Nothing++  it "deletes values" $ \client -> do+    _ <- M.set client "integration-delete" "value" 0 0++    M.delete client "integration-delete" 0 `shouldReturn` True+    M.delete client "integration-delete" 0 `shouldReturn` False++  it "touches and gets with expiry" $ \client -> do+    _ <- M.set client "integration-touch" "value" 0 0+    touched <- M.touch client "integration-touch" 60+    touched `shouldSatisfy` isJust++    gated <- M.gat client "integration-touch" 60+    gated `shouldSatisfy` isJust++    M.touch client "integration-no-touch" 60 `shouldReturn` Nothing++  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++    values <-+      M.getMany+        client+        [ "integration-many"+        , "integration key"+        , "integration-no-many"+        ]+    lookup "integration-many" values `shouldSatisfy` isJust+    lookup "integration key" values `shouldSatisfy` isJust++  it "increments and decrements counters" $ \client -> do+    _ <- M.delete client "integration-counter" 0+    incremented <- M.increment client "integration-counter" 10 2 0 0+    incremented `shouldSatisfy` maybe False ((== 10) . fst)++    decremented <- M.decrement client "integration-counter" 0 3 0 0+    decremented `shouldSatisfy` isJust++  it "appends and prepends" $ \client -> do+    cas <- M.set client "integration-modify" "middle" 0 0+    appended <- M.append client "integration-modify" "-end" cas+    appended `shouldSatisfy` isJust++    prepended <- M.prepend client "integration-modify" "start-" 0+    prepended `shouldSatisfy` isJust++    result <- M.get client "integration-modify"+    fmap first result `shouldBe` Just "start-middle-end"++  it "modifies encoded keys" $ \client -> do+    _ <- M.set client "integration modify key" "middle" 0 0+    _ <- M.append client "integration modify key" "-end" 0+    result <- M.get client "integration modify key"+    fmap first result `shouldBe` Just "middle-end"++  it "flushes values" $ \client -> do+    _ <- M.set client "integration-flush" "value" 0 0+    M.flush client Nothing+    M.get client "integration-flush" `shouldReturn` Nothing++  it "reads stats" $ \client -> do+    stats <- M.stats client Nothing+    stats `shouldSatisfy` not . all (null . snd)++  it "roundtrips a large value" $ \client -> do+    let value = B.replicate 100000 'x'+    _ <- M.set client "integration-large" value 0 0+    result <- M.get client "integration-large"++    fmap first result `shouldBe` Just value++  it "roundtrips an encoded key" $ \client -> do+    _ <- M.set client "integration unsafe key" "value" 0 0+    result <- M.get client "integration unsafe key"++    fmap first result `shouldBe` Just "value"++  it "supports quit" M.quit++newClient :: Int -> IO M.Client+newClient port = do+  client <- M.newClient [ServerSpec "127.0.0.1" (show port) M.NoAuth] M.def+  M.flush client Nothing+  return client++first :: (a, b, c) -> a+first (value, _, _) = value++withMemcached+  :: FilePath+  -> (Int -> IO ())+  -> IO ()+withMemcached executable 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"])+    waitForPort port process+    return (port, process)+  release (_, process) = do+    terminateProcess process+    void (waitForProcess process)++freePort :: IO Int+freePort = bracket (socket AF_INET Stream defaultProtocol) close $ \sock -> do+  setSocketOption sock ReuseAddr 1+  bind sock (N.SockAddrInet 0 (tupleToHostAddress (127, 0, 0, 1)))+  fromIntegral <$> socketPort sock++waitForPort+  :: Int+  -> ProcessHandle+  -> IO ()+waitForPort port process = go 50+ where+  go :: Int -> IO ()+  go 0 = do+    status <- waitForProcess process+    fail $ "memcached exited before becoming ready: " <> show status+  go attempts = do+    ready <- tryConnect port+    if ready+      then return ()+      else do+        exited <- getProcessExitCode process+        case exited of+          Just status -> fail $ "memcached exited before becoming ready: " <> show status+          Nothing -> threadDelay 100000 >> go (attempts - 1)++tryConnect+  :: Int+  -> IO Bool+tryConnect port = do+  result <- try $ do+    addr : _ <-+      getAddrInfo+        (Just defaultHints{addrSocketType = Stream})+        (Just "127.0.0.1")+        (Just (show port))+    sock <- socket (addrFamily addr) Stream defaultProtocol+    connect sock (addrAddress addr)+    close sock+  return (isRight @SomeException @() result)

@@ -1,104 +0,0 @@-{-# LANGUAGE OverloadedStrings #-}---- | Our testsuite, which we run expecting there to be a local Memcached server--- running on `localhost:11211`.-module Main where--import           MockServer--import qualified Database.Memcache.Client as M-import           Database.Memcache.Errors-import           Database.Memcache.Socket-import           Database.Memcache.Types--import           Blaze.ByteString.Builder-import           Control.Concurrent-import           Control.Exception-import           Control.Monad-import           Data.Binary.Get-import qualified Data.ByteString.Char8 as BC-import qualified Network.Socket as N-import qualified Network.Socket.ByteString as N-import           System.Exit-import           System.IO--main :: IO ()-main = do-    putStr "GET:      "-    getTest-    putStrLn "PASSED"-    putStr "DELETE:   "-    deleteTest-    putStrLn "PASSED"-    putStr "RETRY:    "-    retryTest-    putStrLn "PASSED"-    putStr "TIMEOUT1: "-    timeoutTest-    putStrLn "PASSED"-    putStr "TIMEOUT2: "-    timeoutRetryTest-    putStrLn "PASSED"-    exitSuccess--getTest :: IO ()-getTest = withMCServer False res $ do-    c <- M.newClient [M.def] M.def-    void $ M.set c (BC.pack "key") (BC.pack "world") 0 0-    Just (v', _, _) <- M.get c "key"-    when (v' /= "world") $ do-        putStrLn $ "bad value returned! " ++ show v'-        exitFailure -  where-    res = [ MR $ emptyRes { resOp = ResSet Loud }-          , MR $ emptyRes { resOp = ResGet Loud "world" 0 }-          ]--deleteTest :: IO ()-deleteTest = withMCServer False res $ do-    c <- M.newClient [M.def] M.def-    v1 <- M.set c "key" "world"  0 0-    v2 <- M.set c "key" "world2" 0 0-    when (v1 == v2) $ do-        putStrLn $ "bad versions! " ++ show v1 ++ ", " ++ show v2-        exitFailure-    r <- M.delete c "key" 0-    unless r $ do-        putStrLn "delete failed!"-        exitFailure-  where-    res = [ MR $ emptyRes { resOp = ResSet Loud, resCas = 1 }-          , MR $ emptyRes { resOp = ResSet Loud, resCas = 2 }-          , MR $ emptyRes { resOp = ResDelete Loud }-          ]--retryTest :: IO ()-retryTest = withMCServer False res $ do-    c <- M.newClient [M.def] M.def-    void $ M.set c (BC.pack "key") (BC.pack "world") 0 0-  where-    res = [ CloseConnection-          , MR $ emptyRes { resOp = ResSet Loud }-          ]--timeoutTest :: IO ()-timeoutTest = withMCServer True res $ do-    c <- M.newClient [M.def] M.def-    void $ M.set c (BC.pack "key") (BC.pack "world") 0 0-    r <- try $ M.get c "key" -    case r of-        Left (ClientError Timeout) -> return ()-        Left  _ -> putStrLn "unexpected exception!" >> exitFailure-        Right _ -> putStrLn "no timeout occured!" >> exitFailure-  where-    res = [ MR $ emptyRes { resOp = ResSet Loud } ]--timeoutRetryTest :: IO ()-timeoutRetryTest = withMCServer False res $ do-    c <- M.newClient [M.def] M.def-    void $ M.set c (BC.pack "key") (BC.pack "world") 0 0-  where-    res = [ DelayMS 800 Noop-          , MR $ emptyRes { resOp = ResSet Loud }-          ]-

@@ -1,5 +1,4 @@-{-# LANGUAGE BangPatterns #-}-{-# LANGUAGE CPP #-}+{-# LANGUAGE CPP               #-} {-# LANGUAGE OverloadedStrings #-}  -- | Mock Memcached server - just enough for testing client.@@ -7,36 +6,23 @@         MockResponse(..), mockMCServer, withMCServer     ) where -import qualified Database.Memcache.Client as M-import           Database.Memcache.Socket-import           Database.Memcache.Types--import           Blaze.ByteString.Builder #if __GLASGOW_HASKELL__ < 710 import           Control.Applicative #endif import           Control.Concurrent-import           Control.Exception (bracket, handle, throwIO, SomeException) import           Control.Monad-import           Data.Binary.Get-import qualified Data.ByteString as B-import qualified Data.ByteString.Char8 as BC-import qualified Data.ByteString.Lazy as L+import qualified Data.ByteString           as B+import qualified Data.ByteString.Char8     as C import           Data.IORef-import           Data.Monoid-import           Data.Word-import qualified Network.Socket as N hiding (recv)+import qualified Network.Socket            as N import qualified Network.Socket.ByteString as N-import           System.Exit-import           System.IO--import           Database.Memcache.Errors-import           Database.Memcache.Types-+import           Text.Read                  (readMaybe)+import           UnliftIO.Exception         (SomeException, bracket, handle,+                                            throwIO)  -- | Actions the mock server can take to a request. data MockResponse-    = MR Response+    = MR B.ByteString     | CloseConnection     | DelayMS Int MockResponse     | Noop@@ -44,50 +30,58 @@ -- | 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 = bracket-    (mockMCServer loop res)+withMCServer loop res m = do+  sem <- newEmptyMVar++  let waitForInitialization = takeMVar sem++  bracket+    (mockMCServer loop res sem)     (\tid -> killThread tid >> threadDelay 100000)-    (const m)+    (const $ waitForInitialization >> m)  -- | New mock Memcached server that responds to each request with the specified -- list of responses.-mockMCServer :: Bool -> [MockResponse] -> IO ThreadId-mockMCServer loop resp' = forkIO $ bracket +mockMCServer :: Bool -> [MockResponse] -> MVar () -> IO ThreadId+mockMCServer loop resp' sem = forkIO $ bracket     (N.socket N.AF_INET N.Stream N.defaultProtocol)-    (N.close)+    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.listen sock 10         ref <- newIORef resp'++        -- Publish that initialization is done+        putMVar sem ()+         acceptHandler sock ref         when loop $ forever $ threadDelay 1000000-  +   where     acceptHandler sock ref = do         client <- fst <$> N.accept sock         resp <- readIORef ref         cont <- handle allErrors $ clientHandler client ref resp-        if cont-            then acceptHandler sock ref-            else return ()+        when cont $  acceptHandler sock ref      allErrors :: SomeException -> IO Bool     allErrors = const $ return True -    clientHandler client ref []       = N.close client >> return False+    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)         -> sendRes client mr >> 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)@@ -97,30 +91,31 @@                 writeIORef ref resp                 return $ not $ null resp ---sendRes :: N.Socket -> Response -> IO ()-sendRes s m = N.sendAll s (toByteString $ szResponse m)- recvReq :: N.Socket -> IO () recvReq s = do-    header <- recvAll s mEMCACHE_HEADER_SIZE mempty-    let h = runGet (dzHeader PktRequest) (L.fromChunks [header])-        bytesToRead = fromIntegral $ bodyLen h-    when (bytesToRead > 0) $-        void $ recvAll s bytesToRead mempty--recvAll :: N.Socket -> Int -> Builder -> IO B.ByteString-recvAll s 0 !acc = return $! toByteString acc-recvAll s !n !acc = do-    buf <- N.recv s n-    case B.length buf of-        0  -> throwIO errEOF-        bl | bl == n ->-            return $! (toByteString $! acc <> fromByteString buf)-        bl -> recvAll s (n - bl) (acc <> fromByteString buf)-  +  line <- recvLine s []+  case payloadLen (C.words line) of+    Just n  -> void (recvAll s n >> recvLine s [])+    Nothing -> return ()   where-    errEOF :: MemcacheError-    errEOF = ProtocolError UnexpectedEOF { protocolError = "" }+    -- Only these carry a data block; guessing by token position instead sees+    -- a payload in commands like @stats cachedump 1 100@ and then hangs.+    payloadLen ("ms":_:size:_)      = readMaybe (C.unpack size)+    payloadLen ("set":_:_:_:size:_) = readMaybe (C.unpack size)+    payloadLen _                    = Nothing +recvAll :: N.Socket -> Int -> IO B.ByteString+recvAll _ 0 = return B.empty+recvAll socket n = do+  chunk <- N.recv socket n+  if B.null chunk+    then throwIO eof+    else (chunk <>) <$> recvAll socket (n - B.length chunk)+  where eof = userError "mock server EOF"++recvLine :: N.Socket -> [B.ByteString] -> IO B.ByteString+recvLine socket acc = do+  chunk <- N.recv socket 1+  if B.null chunk then throwIO (userError "mock server EOF")+  else if chunk == "\n" then return (B.concat (reverse acc))+       else recvLine socket (chunk:acc)

@@ -0,0 +1,215 @@+{-# LANGUAGE OverloadedStrings #-}++module Main where++import           MockServer+import qualified Database.Memcache.Auth    as Auth+import qualified Database.Memcache.Client  as Client+import           Database.Memcache.Errors+import qualified Database.Memcache.Errors  as E+import           Database.Memcache.Socket+import           Test.Hspec+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.Exception         (bracket)+import           Data.Either               (isLeft)++main :: IO ()+main = hspec $ do+  describe "meta command encoding" $ do+    it "leaves safe keys unchanged and encodes unsafe keys" $ do+      fmap wireKey (encodeKey "safe-key") `shouldBe` Right "safe-key"+      fmap wireKey (encodeKey "a b") `shouldBe` Right (Base64.encode "a b")++    it "terminates arithmetic commands" $+      arithmeticRequest Incr (wire "counter") 0 1 maxBound 0 `shouldSatisfy` C.isSuffixOf "\r\n"++    it "validates encoded key length" $+      encodeKey (C.replicate 251 'a') `shouldSatisfy` isLeft++    it "rejects empty keys" $+      encodeKey "" `shouldSatisfy` isLeft++    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+        Client.get client (C.replicate 251 'a') `shouldThrow` isKeyTooLong+        Client.get client "key" `shouldReturn` Just ("foo", 2, 7)++    it "rejects unsafe stats keys before sending them" $ do+      client <- Client.newClient [Client.def] Client.def+      Client.stats client (Just "items\r\nset injected 0 0 1\r\nx")+        `shouldThrow` isKeyTooLong++    it "encodes all core request forms" $ do+      getRequest (wire "key") `shouldBe` "mg key v f c\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"+      flushRequest Nothing `shouldBe` "flush_all\r\n"+      flushRequest (Just 30) `shouldBe` "flush_all 30\r\n"+      versionRequest `shouldBe` "version\r\n"+      statsRequest Nothing `shouldBe` "stats\r\n"+      statsRequest (Just "key") `shouldBe` "stats key\r\n"+      quitRequest `shouldBe` "quit\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 "omits arithmetic defaults at the maximum expiration" $+      arithmeticRequest Incr (wire "key") 0 1 maxBound 0+      `shouldBe` "ma key D1 MI v c\r\n"++    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"++  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"+      (recvResponseFrom "SERVER_ERROR broken\r\n" >>= responseStatus) `shouldThrow` isServerError+      (recvResponseFrom "CLIENT_ERROR bad\r\n" >>= responseStatus) `shouldThrow` isBadCommand++    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 "HD\r\n" >>= responseStatus) `shouldReturn` NoError+      (recvResponseFrom "EX\r\n" >>= responseStatus) `shouldReturn` ErrKeyExists+      (recvResponseFrom "NS\r\n" >>= responseStatus) `shouldReturn` ErrItemNotStored+      (recvResponseFrom "MN\r\n" >>= responseStatus) `shouldReturn` NoError+      (recvResponseFrom "VERSION 1.6.0\r\n" >>= responseStatus) `shouldReturn` NoError+      (recvResponseFrom "STAT curr_items 2\r\n" >>= responseStatus) `shouldReturn` NoError++  describe "connection buffering" $ do+    it "keeps bytes after a parsed response" $+      bracket+      (N.socketPair N.AF_UNIX N.Stream 0)+      (\(left, right) -> N.close left >> N.close right) $ \(left, right) -> do+        connection <- newConnection left+        _ <- forkIO $ N.sendAll right "VA 3 f1 c2\r\nabc\r\nMN\r\n"+        recvResponse connection `shouldReturn` Response "VA" ["3", "f1", "c2"] "abc"+        recvResponse connection `shouldReturn` Response "MN" [] ""++    it "handles a value split across packets" $+      bracket (N.socketPair N.AF_UNIX N.Stream 0) closePair $ \(left, right) -> do+        connection <- newConnection left+        _ <- 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"++    it "reports EOF in a value" $+      bracket (N.socketPair N.AF_UNIX N.Stream 0) closePair $ \(left, right) -> do+        connection <- newConnection left+        _ <- forkIO $ N.sendAll right "VA 5\r\nhe" >> N.close right+        recvResponse connection `shouldThrow` isUnexpectedEOF++    it "rejects unreasonably large value lengths" $+      recvResponseFrom "VA 134217729\r\n" `shouldThrow` isBadLength++    it "rejects an unterminated response line" $+      recvResponseFrom (C.replicate (16 * 1024) 'x') `shouldThrow` isBadLength++  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))]++  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+        Client.get client "key" `shouldReturn` Just ("foo", 2, 7)++    it "returns Nothing for a miss" $+      withMCServer False [MR "EN\r\n"] $ do+        client <- Client.newClient [Client.def] Client.def+        Client.get client "key" `shouldReturn` Nothing++    it "stores and returns the server CAS" $+      withMCServer False [MR "HD c9\r\n"] $ do+        client <- Client.newClient [Client.def] Client.def+        Client.set client "key" "foo" 2 30 `shouldReturn` 9++    it "deletes a present key" $+      withMCServer False [MR "HD\r\n"] $ do+        client <- Client.newClient [Client.def] Client.def+        Client.delete client "key" 0 `shouldReturn` True++    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+        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+        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+        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+        result <- Client.stats client (Just "cachedump 1 100")+        map snd result `shouldBe` [[]]++    it "returns Nothing when arithmetic cannot create the item" $+      withMCServer False [MR "NS\r\n"] $ do+        client <- Client.newClient [Client.def] Client.def+        Client.increment client "counter" 0 1 30 0 `shouldReturn` Nothing++    it "returns Nothing appending to a missing key" $+      withMCServer False [MR "NS\r\n"] $ do+        client <- Client.newClient [Client.def] Client.def+        Client.append client "key" "more" 0 `shouldReturn` Nothing++    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+        Client.set client "key" "foo" 0 0 `shouldThrow` (== OpError ErrValueTooLarge)++    it "returns no stats on a reset reply" $+      withMCServer False [MR "RESET\r\n"] $ do+        client <- Client.newClient [Client.def] Client.def+        result <- Client.stats client Nothing+        map snd result `shouldBe` [[]]++  describe "authenticate" $+    it "refuses to send credentials when the server is not auth-gated" $+      bracket+      (N.socketPair N.AF_UNIX N.Stream 0)+      (\(left, right) -> N.close left >> N.close right) $ \(left, right) -> do+        connection <- newConnection left+        _ <- forkIO $ N.sendAll right "VERSION 1.6\r\n"+        Auth.authenticate connection (Auth.Auth "user" "pass") `shouldThrow` isInvalidAuthentication+  where+    recvResponseFrom bytes =+      bracket+      (N.socketPair N.AF_UNIX N.Stream 0)+      (\(left, right) -> N.close left >> N.close right) $ \(left, right) -> do+      connection <- newConnection left+      _ <- forkIO $ N.sendAll right bytes+      recvResponse connection+    wire key = either (error . show) id (encodeKey key)+    isKeyTooLong (ClientError (KeyTooLong _)) = True+    isKeyTooLong _ = False+    isInvalidAuthentication (ClientError (InvalidAuthentication _)) = True+    isInvalidAuthentication _ = False+    isServerError (ProtocolError (E.ServerError _)) = True+    isServerError _ = False+    isBadCommand (ProtocolError (E.BadCommand _)) = True+    isBadCommand _ = False+    isUnexpectedEOF (ProtocolError (UnexpectedEOF _)) = True+    isUnexpectedEOF _ = False+    isBadLength (ProtocolError (BadLength _)) = True+    isBadLength _ = False+    closePair (left, right) = N.close left >> N.close right+    allStats [(_, [ ("curr_items", "2"), ("rusage_user", "0.1 0.2") ])] = True+    allStats _ = False