packages feed

memcache-haskell (empty) → 0.0.10

raw patch · 17 files changed

+1884/−0 lines, 17 filesdep +HUnitdep +QuickCheckdep +attoparsecsetup-changed

Dependencies added: HUnit, QuickCheck, attoparsec, base, bytestring, containers, hashable, hashtables, memcache-haskell, mtl, network, network-conduit, resourcet, split, stm, test-framework, test-framework-hunit, test-framework-quickcheck2, test-framework-th, transformers

Files

+ ChangeLog.md view
@@ -0,0 +1,3 @@+## 0.0.10++* Add exptime-support to Network.Memcache.Client
+ LICENSE view
@@ -0,0 +1,22 @@+Copyright (c) 2015 GREE, Inc.++MIT License++Permission is hereby granted, free of charge, to any person obtaining+a copy of this software and associated documentation files (the+"Software"), to deal in the Software without restriction, including+without limitation the rights to use, copy, modify, merge, publish,+distribute, sublicense, and/or sell copies of the Software, and to+permit persons to whom the Software is furnished to do so, subject to+the following conditions:++The above copyright notice and this permission notice shall be+included in all copies or substantial portions of the Software.++THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,+EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF+MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND+NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE+LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION+OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION+WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE.
+ README.md view
@@ -0,0 +1,47 @@+memcache-haskell+================++[![Hackage version](https://img.shields.io/hackage/v/memcache-haskell.svg?style=flat)](https://hackage.haskell.org/package/memcache-haskell)  [![Build Status](https://travis-ci.org/gree/memcache-haskell.png?branch=master)](https://travis-ci.org/gree/memcache-haskell) [![Coverage Status](https://coveralls.io/repos/gree/memcache-haskell/badge.png)](https://coveralls.io/r/gree/memcache-haskell)++This package is a memcache protocol library for server and client applications.++Main purpose of this library is making a server itself.++This does not support consistent hashing  and any other functions like ["libmemcached"](http://libmemcached.org/libMemcached.html).++## Getting started++Install from Hackage.++    cabal update && cabal install memcache-haskell++## Usage++1. Call `openClient` with `ip-address:port` of memcache-server to obtain a handle.+2. To set or get a data on the memcache server, call `set` or `get` with the handle.+3. Finally call `closeClient` after you are done.++Example:++```+main :: IO ()+main = do+  client <- openClient "127.0.0.0:11211"+  ret <- set client "key" "foo"+  print ret+  ret' <- get client "key" :: IO (Maybe String)+  print ret'+  closeClient client+```++## Contributors++* Kiyoshi Ikehara+* Yuji Kamiya+* Junji Hashimoto++## License++See [LICENSE](LICENSE).++Copyright © Gree, Inc. All Rights Reserved.
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ memcache-haskell.cabal view
@@ -0,0 +1,107 @@+Name:           memcache-haskell+Version:        0.0.10+Description:    Memcache procotol library+License:        MIT+license-file:   LICENSE+Author:         Kiyoshi Ikehara+Maintainer:     Kiyoshi Ikehara+Copyright:      (c) 2015 GREE, Inc.+Build-Type:     Simple+Cabal-Version:  >=1.8+Description:+    A memcache protocol library for client and server applications.+++bug-reports:      https://github.com/gree/memcache-haskell/issues++extra-source-files:+  ChangeLog.md+  README.md++source-repository head+  type:           git+  location:       https://github.com/gree/memcache-haskell.git++Flag sample+  Description: Build sample programs+  Default: False++Library+  Ghc-Options:     -O2 -Wall+  Build-Depends:   base         >=4 && <5+                 , bytestring+                 , network      >= 2.3.2+                 , attoparsec+                 , transformers+                 , split+                 , hashable+  Hs-source-dirs:  src+  Exposed-modules: Network.Memcache+                 , Network.Memcache.Response+                 , Network.Memcache.Op+                 , Network.Memcache.Class+                 , Network.Memcache.Client+                 , Network.Memcache.Stats+                 , Network.Memcache.Types+                 , Network.Memcache.IO+  Other-modules:   Network.Memcache.IO.Internal+  Extensions:      DeriveDataTypeable++Executable memcache-sample-client+  if flag(sample)+    Buildable: True+  else+    Buildable: False+  Ghc-Options:     -threaded -O2 -Wall -rtsopts+  Extra-Libraries: +  Build-Depends:   base       >= 4 && < 5+                 , bytestring >= 0.9+                 , stm        >= 2.4+                 , containers+                 , transformers+                 , resourcet+                 , mtl+                 , hashtables+                 , network-conduit+                 , memcache-haskell+  Hs-source-dirs:  sample+  Main-is:         sample-client.hs+  Extensions:      DeriveDataTypeable++Executable memcache-sample-retrieval+  if flag(sample)+    Buildable: True+  else+    Buildable: False+  Ghc-Options:     -threaded -O2 -Wall -rtsopts+  Extra-Libraries: +  Build-Depends:   base       >= 4 && < 5+                 , bytestring >= 0.9+                 , stm        >= 2.4+                 , containers+                 , transformers+                 , resourcet+                 , mtl+                 , hashtables+                 , network-conduit+                 , memcache-haskell+  Hs-source-dirs:  sample+  Main-is:         sample-retrieval.hs+  Extensions:      DeriveDataTypeable++Test-Suite test-memcache+  Ghc-Options:     -threaded -O2 -Wall+  Build-depends:   base+                 , bytestring+                 , network >= 2.3.2+                 , split+                 , QuickCheck == 2.5.1.1+                 , HUnit+                 , test-framework+                 , test-framework-th+                 , test-framework-hunit+                 , test-framework-quickcheck2+                 , memcache-haskell+  Type:            exitcode-stdio-1.0+  Hs-source-dirs:  test+  Main-is:         test-memcache.hs
+ sample/sample-client.hs view
@@ -0,0 +1,29 @@++import Control.Exception+import Control.Monad.Trans.Resource (allocate, release, runResourceT)+import Control.Monad.IO.Class+import Network.Memcache+import System.Environment+++main :: IO ()+main = do+  args <- getArgs+  case args of+    [] -> main' "127.0.0.1:11211"+    (nk:_) -> main' nk++main' :: Nodekey -> IO ()+main' nodekey = runResourceT $ do+  (rkeyClient , client) <- flip allocate closeClient $ do+    c <- openClient nodekey+    case c of+      Just client -> return (client)+      Nothing -> liftIO $ do+        throwIO (userError "could not open.")+  liftIO $ do+    ret <- set client "key" "foo"+    print ret+    ret' <- get client "key" :: IO (Maybe String)+    print ret'+  release rkeyClient
+ sample/sample-retrieval.hs view
@@ -0,0 +1,9 @@++import Network.Memcache+  +main = do+  mValue <- withClient "127.0.0.1:11211" $ \client -> get client "key"+  case mValue of+    Nothing -> putStrLn "(no value)"+    Just value -> putStrLn value+
+ src/Network/Memcache.hs view
@@ -0,0 +1,81 @@+-- Copyright (c) 2013, GREE, Inc. All rights reserved.+-- authors: Kiyoshi Ikehara <kiyoshi.ikehara@gree.net>++{- |+Module: Network.Memcache+Maintainer: Kiyoshi Ikehara <kiyoshi.ikehara@gree.net>++memcache-haskell is a memcache protocol library for server and client application.++If you want to implement a simple memcache client, just import "Network.Memcache" module and use withClient function.++> import Network.Memcache+>   +> main = do+>   mValue <- withClient "127.0.0.1:11211" $ \client -> get client "key"+>   case mValue of+>     Nothing -> putStrLn "(no value)"+>     Just value -> putStrLn value++Or, use openClient and closeClient pair for more complex cases.++> import Control.Exception+> import Control.Monad.Trans.Resource (allocate, release, runResourceT)+> import Control.Monad.IO.Class+> import Network.Memcache+> import System.Environment+> +> main :: IO ()+> main = do+>   args <- getArgs+>   case args of+>     [] -> main' "127.0.0.1:11211"+>     (nk:_) -> main' nk+> +> main' :: Nodekey -> IO ()+> main' nodekey = runResourceT $ do+>   (rkeyClient , client) <- flip allocate closeClient $ do+>     c <- openClient nodekey+>     case c of+>       Just client -> return (client)+>       Nothing -> liftIO $ do+>         throwIO (userError "could not open.")+>   liftIO $ do+>     ret <- set client "key" "foo"+>     print ret+>     ret' <- get client "key" :: IO (Maybe String)+>     print ret'+>   release rkeyClient++If your application is more complex and should recognize memcache command and response directly,+you have to import more and use low-level functions.++For server application, please use "Network.Memcache.Op" and "Network.Memcache.Response" directly to parse and process each command.++If you are familiar with conduit library, please take a look at memcache-conduit library and you will+find that you can write a memcache protocol server very quickly.++> main :: IO ()+> main = do+>   runResourceT $ do+>     runTCPServer (serverSettings 13301 HostAny) $ \appData -> do+>       (appSource appData)+>         $$ getOpText+>         =$ process htVar+>         =$ putResponseText+>         =$ (appSink appData)+>+> process = ...++-}++module Network.Memcache (+    module Network.Memcache.Client+  , module Network.Memcache.Stats+  , module Network.Memcache.Class+  ) where++import Network.Memcache.Class+import Network.Memcache.Client+import Network.Memcache.Stats+
+ src/Network/Memcache/Class.hs view
@@ -0,0 +1,28 @@+-- Copyright (c) 2013, GREE, Inc. All rights reserved.+-- authors: Kiyoshi Ikehara <kiyoshi.ikehara@gree.net>++{- | Class definitions++This module is mainly for internal use.++-}+module Network.Memcache.Class (Message(..)) where++import Control.Monad.IO.Class+import System.IO+import qualified Data.ByteString.Char8 as BS++class Message a where+  -- parse message header+  parseHeader :: BS.ByteString -> Maybe a++  -- convert a message to chunks+  toChunks :: a -> [BS.ByteString]++  -- receive content of a message after receiving its header+  recvContent :: (MonadIO m) => Handle -> a -> m (Maybe a)++  -- no content (default impl.)+  recvContent _h msg = return $ Just msg++
+ src/Network/Memcache/Client.hs view
@@ -0,0 +1,429 @@+-- Copyright (c) 2013, GREE, Inc. All rights reserved.+-- authors: Kiyoshi Ikehara <kiyoshi.ikehara@gree.net>++{-# LANGUAGE TypeSynonymInstances, FlexibleInstances #-}++{- | This is a utility module for client application.+-}+module Network.Memcache.Client (+    Client+  , StatsList+  , Nodekey+  , Key(..)+  , Value(..)+  , openClient+  , closeClient+  , clientNodekey+  , clientSocket+  -- Utility+  , withClient+  , withClients+  , forEachClient+  -- Query Operations+  , set+  , setEx+  , cas+  , casEx+  , add+  , addEx+  , replace+  , replaceEx+  , get+  , gets+  , delete+  , incr+  , decr+  -- Other Operations+  , flushAll+  , stats+  , statsWithArgs+  ) where++import Prelude hiding (catch)+import System.IO+import Network+import Data.List.Split+import Control.Exception+import qualified Data.ByteString.Char8 as BS+import Control.Monad.IO.Class+import Data.Word+import Data.Hashable++import Network.Memcache.Types+import Network.Memcache.Op+import Network.Memcache.Response+import Network.Memcache.IO++{- | Client is a handler corresponding to a memcached session.+-}+data Client = MemcachedClient {+    -- | Get the hostname and port pair from a handler+    clientNodekey :: String+    -- | Get the socket from a handler+  , clientSocket :: Handle+  }++{- | Key class+-}+class (Hashable a) => Key a where+  toBS :: a -> BS.ByteString++instance Key String where+  toBS = BS.pack++instance Key BS.ByteString where+  toBS k = k++{- | Value class+-}+class Value a where+  serializeValue :: a -> BS.ByteString+  deserializeValue :: BS.ByteString -> Either String a++instance Value String where+  serializeValue = BS.pack+  deserializeValue v = Right (BS.unpack v)++instance Value BS.ByteString where+  serializeValue v = v+  deserializeValue v = Right v++{- | Open a client session and return a client handler.+-}+openClient :: (MonadIO m)+              => Nodekey          -- ^ node key (eg. \"127.0.0.1:11211\")+              -> m (Maybe Client) -- ^ client handler+openClient nodekey = case hostnameAndPort nodekey of+  Just (hostname, port) -> do+    socket <- liftIO $ connectTo hostname (PortNumber (fromIntegral port))+    return $ Just $ MemcachedClient nodekey socket+  Nothing -> return Nothing++{- | Close a client session.+-}+closeClient :: (MonadIO m)+               => Client -- ^ a client handler+               -> m ()+closeClient client = liftIO $ do+    closeClient' `catch` ignoreException ()+    hClose hSocket+  where+    hSocket = clientSocket client++    closeClient' = do+      BS.hPutStr hSocket $ BS.pack "quit\r\n"+      hFlush hSocket++{- | Connect and execute an action.+-}+withClient :: Nodekey                     -- ^ a node+              -> (Client -> IO (Maybe a)) -- ^ an action to be executed with a memcache session+              -> IO (Maybe a)             -- ^ the result of the given action+withClient nodekey = withClients [nodekey]++{- | Connect to one of given hosts and execute an action.++> import Network.Memcache+>   +> main = do+>   mValue <- withClient "127.0.0.1:11211" $ \client -> get client "key"+>   case mValue of+>     Nothing -> putStrLn "(no value)"+>     Just value -> putStrLn value++Note that this function doesn't retry the action when it fails.++-}+withClients :: [Nodekey]                   -- ^ a node list+               -> (Client -> IO (Maybe a)) -- ^ an action to be executed with a memcache session+               -> IO (Maybe a)             -- ^ the result of the given action+withClients nodekeys act = bracket (allocate nodekeys) release invoke+  where+    allocate :: [Nodekey] -> IO (Maybe Client)+    allocate [] = return Nothing+    allocate (n:ns) = do+      r <- openClient n `catch` ignoreException Nothing+      case r of+        Nothing -> allocate ns+        client -> return client++    release client = case client of+      Just c -> closeClient c+      Nothing -> return ()++    invoke client = case client of+      Just c -> act c+      Nothing -> return Nothing++{- | Connect to the given hosts one by one and execute the action for each client.++If you'd like to clear all the data in your cluster, you can use this function to issue \"flush_all\" command to each memcache node.++>  main = do+>    ret <- forEachClient ["192.168.0.1:11211", "192.168.0.2:11211"] $ flushAll+>    print ret++-}+forEachClient :: [Nodekey]                   -- ^ a node list+                 -> (Client -> IO (Maybe a)) -- ^ an action to be executed with a memcache session+                 -> IO ([Maybe a])           -- ^ the result of the given action+forEachClient clients act = do+  mapM (\c -> withClient c act) clients+++-------------------------------- Query Operations++{- | Set an item+-}+set :: (MonadIO m, Key k, Value v)+       => Client -- ^ a client handler+       -> k      -- ^ a key+       -> v      -- ^ a value+       -> m Bool -- ^ true if the value has been stored+set = set' SetOp++{- | Set an item with exptime+-}+setEx :: (MonadIO m, Key k, Value v)+       => Client -- ^ a client handler+       -> k      -- ^ a key+       -> v      -- ^ a value+       -> Word64 -- ^ exptime+       -> m Bool -- ^ true if the value has been stored+setEx = opEx SetOp++-- a helper function without exptime+set' :: (MonadIO m, Key k, Value v) => (BS.ByteString -> Word32 -> Word64 -> Word64 -> BS.ByteString -> [Option] -> Op) -> Client -> k -> v -> m Bool+set' op client key0 value0 = opEx op client key0 value0 0+++-- a helper function with exptime+opEx :: (MonadIO m, Key k, Value v) => (BS.ByteString -> Word32 -> Word64 -> Word64 -> BS.ByteString -> [Option] -> Op) -> Client -> k -> v -> Word64 -> m Bool+opEx op client key0 value0 exptime = do+  let socket = clientSocket client+      key = toBS key0+      value = serializeValue value0+  resp <- liftIO $ do+    send socket $ op key 0 exptime (fromIntegral $ BS.length value) value []+    recv socket :: IO (Maybe Response)+  return (resp == Just Stored)++{- | Cas an item+-}+cas :: (MonadIO m, Key k, Value v)+       => Client -- ^ a client handler+       -> k      -- ^ a key+       -> v      -- ^ a value+       -> Word64 -- ^ a version number got by gets command+       -> m Bool -- ^ true if the value has been stored+cas client key value version = set' (\k f e b v o -> CasOp k f e b version v o) client key value++{- | Cas an item with exptime+-}+casEx :: (MonadIO m, Key k, Value v)+       => Client -- ^ a client handler+       -> k      -- ^ a key+       -> v      -- ^ a value+       -> Word64 -- ^ a version number got by gets command+       -> Word64 -- ^ exptime+       -> m Bool -- ^ true if the value has been stored+casEx client key value version exptime = opEx (\k f e b v o -> CasOp k f e b version v o) client key value exptime++{- | Add an item+-}+add :: (MonadIO m, Key k, Value v)+       => Client -- ^ a client handler+       -> k      -- ^ a key+       -> v      -- ^ a value+       -> m Bool+add = set' AddOp++{- | Add an item with exptime+-}+addEx :: (MonadIO m, Key k, Value v)+       => Client -- ^ a client handler+       -> k      -- ^ a key+       -> v      -- ^ a value+       -> Word64 -- ^ exptime+       -> m Bool+addEx = opEx AddOp++{- | Replace an item+-}+replace :: (MonadIO m, Key k, Value v)+           => Client -- ^ a client handler+           -> k      -- ^ a key+           -> v      -- ^ a value+           -> m Bool -- ^ true if the value has been stored+replace = set' ReplaceOp++{- | Replace an item with exptime+-}+replaceEx :: (MonadIO m, Key k, Value v)+           => Client -- ^ a client handler+           -> k      -- ^ a key+           -> v      -- ^ a value+           -> Word64 -- ^ exptime+           -> m Bool -- ^ true if the value has been stored+replaceEx = opEx ReplaceOp++{- | Get an item+-}+get :: (MonadIO m, Key k, Value v)+       => Client       -- ^ a client handler+       -> k            -- ^ a key+       -> m (Maybe v)  -- ^ the value corresponding to the given key+get client key0 = do+  let socket = clientSocket client+      key = toBS key0+      op = GetOp [key]+  resp <- liftIO $ do+    send socket op+    values <- retrieve socket+    case values of+      ((Value _ _ _ value _):_) -> case deserializeValue value of+        Right v -> return (Just v)+        Left _ -> return (Nothing)+      _ -> return (Nothing)+  return (resp)++-- a helper function+retrieve :: Handle -> IO ([Response])+retrieve h = do+  ret <- retrieve'+  return (reverse ret)+  where+    retrieve' = do+      resp <- recv h :: IO (Maybe Response)+      case resp of+        Just value@(Value {}) -> do+          values <- retrieve h+          return (value:values)+        Just End -> return ([])+        _ -> return ([])++{- | Get an item and its version+-}+gets :: (MonadIO m, Key k, Value v)+        => Client                -- ^ a client handler+        -> k                     -- ^ a key+        -> m (Maybe (v, Word64)) -- ^ the value and version pair corresponding to the key+gets client key0 = do+  let socket = clientSocket client+      key = toBS key0+      op = GetsOp [key]+  resp <- liftIO $ do+    send socket op+    values <- retrieve socket+    case values of+      ((Value _ _ _ value (Just version)):_) -> case deserializeValue value of+        Right v -> return (Just (v, version))+        Left _ -> return (Nothing)+      _ -> return (Nothing)+  return (resp)++{- | Delete an item+-}+delete :: (MonadIO m, Key k)+          => Client -- ^ a client handler+          -> k      -- ^ a key+          -> m Bool -- ^ true if the item has been deleted+delete client key0 = do+  let socket = clientSocket client+      key = toBS key0+  resp <- liftIO $ do+    send socket $ DeleteOp key []+    recv socket :: IO (Maybe Response)+  return (resp == Just Deleted)++{- | Increment an item+-}+incr :: (MonadIO m, Key k)+        => Client        -- ^ a client handler+        -> k             -- ^ a key+        -> Int           -- ^ delta+        -> m (Maybe Int) -- ^ a resulted value+incr client key0 value = do+  let socket = clientSocket client+      key = toBS key0+  resp <- liftIO $ do+    send socket $ IncrOp key (fromIntegral value) []+    recv socket :: IO (Maybe Response)+  case resp of+    Just (Code value') -> return (Just $ fromIntegral value')+    _ -> return (Nothing)++{- | Decrement an item+-}+decr :: (MonadIO m, Key k)+        => Client        -- ^ a client handler+        -> k             -- ^ a key+        -> Int           -- ^ delta+        -> m (Maybe Int) -- ^ a resulted value+decr client key0 value = do+  let socket = clientSocket client+      key = toBS key0+  resp <- liftIO $ do+    send socket $ DecrOp key (fromIntegral value) []+    recv socket :: IO (Maybe Response)+  case resp of+    Just (Code value') -> return (Just $ fromIntegral value')+    _ -> return (Nothing)++-- Other Operations++{- | Flush all items+-}+flushAll :: (MonadIO m)+            => Client             -- ^ a client handler+            -> m (Maybe Response) -- ^ OK if all items has been removed+flushAll client = do+  let socket = clientSocket client+      op = FlushAllOp+  liftIO $ send socket op+  resp <- liftIO $ do+    recv socket :: IO (Maybe Response)+  return (resp)++{- | Acquire statistic information++To get each statistic value from the resulted list, use "Network.Memcache.Stats" module.++-}+stats :: (MonadIO m)+         => Client        -- ^ a client handler+         -> m (StatsList) -- ^ a property list+stats client = statsWithArgs client []++{- | Acquire statistic information with arguments++To get each statistic value from the resulted list, use "Network.Memcache.Stats" module.++-}+statsWithArgs :: (MonadIO m)+                 => Client        -- ^ a client handler+                 -> [String]      -- ^ arguments+                 -> m (StatsList) -- ^ a property list+statsWithArgs client args = do+  let socket = clientSocket client+  liftIO $ send socket $ StatsOp (map BS.pack args)+  resp <- getResponse socket []    +  return (Prelude.reverse resp)+  where+    getResponse sock result = do+      resp <- liftIO $ recv sock+      case resp of+        Just (Stat statName statValue) -> getResponse sock ((BS.unpack statName, BS.unpack statValue):result)+        Just End -> return (result)+        _ -> getResponse sock result++----------------------------------------------------------------++hostnameAndPort :: String -> Maybe (String, Int)+hostnameAndPort nk = case Data.List.Split.splitOn ":" nk of+  (hostname:port:[]) -> Just (hostname, (read port :: Int))+  _ -> Nothing++ignoreException :: a -> SomeException -> IO a+ignoreException ret _e = return ret+
+ src/Network/Memcache/IO.hs view
@@ -0,0 +1,38 @@+-- Copyright (c) 2013, GREE, Inc. All rights reserved.+-- authors: Kiyoshi Ikehara <kiyoshi.ikehara@gree.net>++{- | This is a utility module for handle-based IO opearations+-}+module Network.Memcache.IO (send, recv) where++import Control.Monad.IO.Class+import System.IO+import qualified Data.ByteString.Char8 as BS++import Network.Memcache.Class++{- | Send a message++> send socket FlushAllOp++-}+send :: (MonadIO m, Message a) => Handle -> a -> m ()+send handle msg = liftIO $ do+  -- TODO: this should be done by writev() system call (vector I/O).+  BS.hPutStr handle $ BS.concat (toChunks msg)+  hFlush handle++{- | Receive a message++You may need to specify the return type when you call this function like the code shown below.++> mresp <- recv socket :: IO (Maybe Response)++-}+recv :: (MonadIO m, Message a) => Handle -> m (Maybe a)+recv handle = liftIO $ do+  l <- BS.hGetLine handle+  case parseHeader l of+    Just msg -> recvContent handle msg+    Nothing -> return Nothing+
+ src/Network/Memcache/IO/Internal.hs view
@@ -0,0 +1,16 @@+-- Copyright (c) 2013, GREE, Inc. All rights reserved.+-- authors: Kiyoshi Ikehara <kiyoshi.ikehara@gree.net>++module Network.Memcache.IO.Internal where++import System.IO+import qualified Data.ByteString.Char8 as BS+import Data.Word++{- | Read data from a handle+-}+readBytes :: Handle    -- ^ a I/O handler+             -> Word64 -- ^ data length+             -> IO (BS.ByteString)+readBytes handle len = BS.hGet handle (fromIntegral len)+
+ src/Network/Memcache/Op.hs view
@@ -0,0 +1,382 @@+-- Copyright (c) 2013, GREE, Inc. All rights reserved.+-- authors: Kiyoshi Ikehara <kiyoshi.ikehara@gree.net>++{-# LANGUAGE OverloadedStrings #-}+{-# OPTIONS_GHC -fno-warn-unused-binds -fno-warn-name-shadowing #-}++{- |+   For farther information, please see <https://github.com/memcached/memcached/blob/master/doc/protocol.txt>++* storage - 'set', 'add', 'replace', 'append' or 'prepend'++* retrieval - 'get' and 'gets'++* deletion - 'delete'++* increment decrement - 'incr' and 'decr'++* touch - 'touch'++* stats++* other commands - 'flush_all', 'version', 'quit'+-}+module Network.Memcache.Op (+    Option(..)+  , Op(PingOp+    , SetOp+    , CasOp+    , AddOp+    , ReplaceOp+    , AppendOp+    , PrependOp+    , GetOp+    , GetsOp+    , DeleteOp+    , IncrOp+    , DecrOp+    , TouchOp+    , FlushAllOp+    , VersionOp+    , QuitOp+    , StatsOp)+  , isWriteOp+  , isReadOp+  , isNoreplyOp+  , isStorageOp+  , toOption+  , toOptions+  , keyOf+  , bytesOf+  , parseOp+  , parseOpHeader+  , opParser+  , opHeaderParser+  , updateOpValue+  ) where++import Prelude hiding (take, takeWhile)+import qualified Data.ByteString.Char8 as BS+import Data.Word+import Data.Maybe+import qualified Data.Attoparsec.ByteString as AB+import Data.Attoparsec.ByteString.Char8+import Control.Applicative+import Control.Monad.IO.Class++import Network.Memcache.Class+import Network.Memcache.IO.Internal++type ValueT = BS.ByteString+type BytesT = Word64+data Option = Noreply deriving (Eq)++instance Show Option where+  show Noreply = "noreply"++instance Read Option where+  readsPrec _d r = case r of+    "noreply" -> [(Noreply, "")]+    _ -> error "no parse"++instance Message Op where+  parseHeader = parseOpHeader+  +  toChunks = Network.Memcache.Op.toChunks++  recvContent handle op+    | isStorageOp op = liftIO $ case bytesOf op of+        Just bytes -> do+          content <- readBytes handle bytes+          _term <- BS.hGetLine handle+          return $ Just $ updateOpValue op content+        Nothing -> return $ Just op+    | otherwise = return $ Just op++data Op = +  -- storage commands+    SetOp {+      key     :: !BS.ByteString+    , flags   :: !Word32+    , exptime :: !Word64+    , bytes   :: !BytesT+    , value   :: ValueT+    , options :: ![Option] }+  | CasOp {+      key     :: !BS.ByteString+    , flags   :: !Word32+    , exptime :: !Word64+    , bytes   :: !BytesT+    , version :: !Word64+    , value   :: ValueT+    , options :: ![Option] }+  | AddOp {+      key     :: !BS.ByteString+    , flags   :: !Word32+    , exptime :: !Word64+    , bytes   :: !BytesT+    , value   :: ValueT+    , options :: ![Option] }+  | ReplaceOp {+      key     :: !BS.ByteString+    , flags   :: !Word32+    , exptime :: !Word64+    , bytes   :: !BytesT+    , value   :: ValueT+    , options :: ![Option] }+  | AppendOp {+      key     :: !BS.ByteString+    , flags   :: !Word32+    , exptime :: !Word64+    , bytes   :: !BytesT+    , value   :: ValueT+    , options :: ![Option] }+  | PrependOp {+      key     :: !BS.ByteString+    , flags   :: !Word32+    , exptime :: !Word64+    , bytes   :: !BytesT+    , value   :: ValueT+    , options :: ![Option] }+  -- retrieval commands+  | GetOp { keys :: ![BS.ByteString] }+  | GetsOp { keys :: ![BS.ByteString] }+  -- deletion commands+  | DeleteOp { key :: !BS.ByteString, options :: ![Option] }+  -- increment and decrement commands+  | IncrOp { key :: !BS.ByteString, value' :: !Word64, options :: ![Option] }+  | DecrOp { key :: !BS.ByteString, value' :: !Word64, options :: ![Option] }+  -- touch commands+  | TouchOp { key :: !BS.ByteString, exptime :: !Word64, options :: ![Option] }+  -- stats commands+  -- other commands+  | PingOp+  | FlushAllOp+  | VersionOp+  | QuitOp+  | StatsOp { args :: ![BS.ByteString] }+ deriving (Show, Read, Eq)++-- | parse option strings+toOptions :: [BS.ByteString] -> Maybe [Option]+toOptions opts = if elem Nothing converted+                 then Nothing+                 else Just $ concat $ map maybeToList converted+  where+    converted = map toOption opts++-- | parse a option string+toOption :: BS.ByteString -> Maybe Option+toOption option = case option of+  "noreply" -> Just Noreply+  _ -> Nothing++-- | update the value of an operation+updateOpValue :: Op -> ValueT -> Op+updateOpValue op val+  | isStorageOp op = op { value = val }+  | otherwise = op++-- | get the value size of an operation+bytesOf :: Op -> Maybe BytesT+bytesOf op+  | isStorageOp op = Just $ bytes op+  | otherwise = Nothing++-- | get the key of an operation+keyOf :: Op -> Maybe BS.ByteString+keyOf op = case op of+  PingOp -> Nothing+  FlushAllOp -> Nothing+  VersionOp -> Nothing+  QuitOp -> Nothing+  StatsOp _ -> Nothing+  GetOp [] -> Nothing+  GetOp (k:_) -> Just k+  GetsOp [] -> Nothing+  GetsOp (k:_) -> Just k+  _ -> Just $ key op++-- | true if an operation is an update command+isWriteOp :: Op -> Bool+isWriteOp op = case op of+  SetOp {} -> True+  CasOp {} -> True+  AddOp {} -> True+  ReplaceOp {} -> True+  AppendOp {} -> True+  PrependOp {} -> True+  DeleteOp {} -> True+  IncrOp {} -> True+  DecrOp {} -> True+  TouchOp {} -> True+  _ -> False++-- | true if an operation is a storage command+isStorageOp :: Op -> Bool+isStorageOp op = case op of+  SetOp {} -> True+  CasOp {} -> True+  AddOp {} -> True+  ReplaceOp {} -> True+  AppendOp {} -> True+  PrependOp {} -> True+  _ -> False++-- | true if an operation is a retrieval command+isReadOp :: Op -> Bool+isReadOp op = case op of+  GetOp {} -> True+  GetsOp {} -> True+  _ -> False++-- | true if an operation has noreply option+isNoreplyOp :: Op -> Bool+isNoreplyOp op = case op of+  SetOp { options = os }     -> elem Noreply os+  CasOp { options = os }     -> elem Noreply os+  AddOp { options = os }     -> elem Noreply os+  ReplaceOp { options = os } -> elem Noreply os+  AppendOp { options = os }  -> elem Noreply os+  PrependOp { options = os } -> elem Noreply os+  DeleteOp { options = os }  -> elem Noreply os+  IncrOp { options = os }    -> elem Noreply os+  DecrOp { options = os }    -> elem Noreply os+  TouchOp { options = os }   -> elem Noreply os+  _ -> False+++{-| Parse an operation.+-}+parseOp :: BS.ByteString -> Maybe Op+parseOp = parseOp' False++{-| Parse an operation but only its header.+-}+parseOpHeader :: BS.ByteString -> Maybe Op+parseOpHeader = parseOp' True++parseOp' :: Bool -> BS.ByteString -> Maybe Op+parseOp' onlyHeader input = let r = parse (opParser' onlyHeader) input in case r of+  Fail {} -> Nothing+  Partial parse' -> let r' = parse' "\r\n" in case r' of+    Done _ result -> Just result+    Fail {} -> Nothing+    Partial {} -> Nothing+  Done _ result -> Just result++{-| command parser by attoparsec+-}+opParser :: Parser Op+opParser = opParser' False++{-| command header parser by attoparsec+-}+opHeaderParser :: Parser Op+opHeaderParser = opParser' True++opParser' :: Bool -> Parser Op+opParser' onlyHeader = parser+  where+    parser :: Parser Op+    parser = do+      cmd <- ws *> word <* ws+      case cmd of+        "get"       -> GetOp <$> (keys <* endline)+        "gets"      -> GetsOp <$> (keys <* endline)+        "set"       -> op_set' SetOp+        "add"       -> op_set' AddOp+        "replace"   -> op_set' ReplaceOp+        "append"    -> op_set' AppendOp+        "prepend"   -> op_set' PrependOp+        "cas"       -> op_cas+        "incr"      -> IncrOp   <$> (key <* ws) <*> (decimal <* ws) <*> (options <* endline)+        "decr"      -> DecrOp   <$> (key <* ws) <*> (decimal <* ws) <*> (options <* endline)+        "delete"    -> DeleteOp <$> (key <* ws) <*> (options <* endline)+        "touch"     -> TouchOp  <$> (key <* ws) <*> (decimal <* ws) <*> (options <* endline)+        "flush_all" -> pure FlushAllOp <* endline+        "version"   -> pure VersionOp <* endline+        "quit"      -> pure QuitOp <* endline+        "ping"      -> pure PingOp <* endline+        "stats"     -> StatsOp <$> (words <* endline)+        _           -> fail ""++    keys = many1 (key <* ws)+    +    key = word++    words = many (word <* ws)+    +    word = AB.takeWhile1 (\c -> c /= 32 && c /= 10 && c /= 13)++    ws = AB.skipWhile (== 32)++    endline :: Parser BS.ByteString+    endline = try (string "\r\n") <|> string "\n" <|> string "\r"++    options = do+      mopts <- toOptions <$> words+      case mopts of+        Just opts -> return (opts)+        Nothing -> fail "invalid options"++    -- set <key> <flags> <exptime> <size> [<options>] -> STORED+    op_set' op = do+      op'   <- op <$> (key <* ws) <*> (decimal <* ws) <*> (decimal <* ws)+      size  <- decimal <* ws :: Parser Word64+      opts  <- options <* endline+      value <- if onlyHeader then pure BS.empty else (take (fromIntegral size) <* ws <* endline)+      return (op' size value opts)++    -- cas <key> <flags> <exptime> <size> <version> [<option>] -> STORED+    op_cas = do+      op'   <- CasOp <$> (key <* ws) <*> (decimal <* ws) <*> (decimal <* ws)+      size  <- decimal <* ws :: Parser Word64+      ver   <- decimal <* ws+      opts  <- options <* endline+      value <- if onlyHeader then pure BS.empty else (take (fromIntegral size) <* ws <* endline)+      return (op' size ver value opts)++{-|+  convert a response to bytestring chunks+-}+toChunks :: Op -> [BS.ByteString]+toChunks op = case op of+  PingOp -> ["ping", ln]+  -- storage commands+  SetOp key flags exptime bytes value options -> setop "set" key flags exptime bytes value options+  CasOp key flags exptime bytes version value options ->+    [BS.concat ["cas ", key, " ", show' flags, " ", show' exptime, " ", show' bytes,+               " ", show' version, showopt options, ln], value, ln]+  AddOp key flags exptime bytes value options -> setop "add" key flags exptime bytes value options+  ReplaceOp key flags exptime bytes value options -> setop "replace" key flags exptime bytes value options+  AppendOp key flags exptime bytes value options -> setop "append" key flags exptime bytes value options+  PrependOp key flags exptime bytes value options -> setop "prepend" key flags exptime bytes value options+  -- retrieval commands+  GetOp keys -> [BS.concat ["get ", BS.intercalate " " keys, ln]]+  GetsOp keys -> [BS.concat ["gets ", BS.intercalate " " keys, ln]]+  -- deletion commands+  DeleteOp key options -> [BS.concat ["delete ", key, showopt options, ln]]+  -- increment and decrement commands+  IncrOp key value' options -> incrdecrop "incr" key value' options+  DecrOp key value' options -> incrdecrop "decr" key value' options+  -- touch commands+  TouchOp key exptime options -> [BS.concat ["touch ", key, " ", show' exptime, showopt options, ln]]+  -- stats commands+  -- other commands+  FlushAllOp -> ["flush_all", ln]+  VersionOp -> ["version", ln]+  QuitOp -> ["quit", ln]+  StatsOp args -> case args of+    [] -> ["stats", ln]+    _ -> ["stats ", BS.intercalate " " args, ln]+  where+    ln = BS.pack "\r\n"+    show' a = BS.pack $ show a+    showopt [] = ""+    showopt os = BS.concat [" ", BS.intercalate " " (map (BS.pack . show) os)]+    setop cmd key flags exptime len value options =+      [BS.concat [cmd, " ", key, " ", show' flags, " ", show' exptime, " ", show' len, showopt options, ln], value, ln]+    incrdecrop cmd key value' options =+      [BS.concat [cmd, " ", key, " ", show' value', showopt options, ln]]+
+ src/Network/Memcache/Response.hs view
@@ -0,0 +1,197 @@+-- Copyright (c) 2013, GREE, Inc. All rights reserved.+-- authors: Kiyoshi Ikehara <kiyoshi.ikehara@gree.net>++{-# LANGUAGE OverloadedStrings #-}++{-|+  This module represents memcached response messages.+-}+module Network.Memcache.Response (+    Response (+        Ok+      , Value+      , End+      , Stored+      , NotStored+      , Exists+      , NotFound+      , Deleted+      , Found+      , Touched+      , Error+      , ServerError+      , ClientError+      , Version+      , Code+      , Stat)+  , parseResponse+  , parseResponseHeader+  , responseParser+  , responseHeaderParser+  ) where++import Prelude hiding (takeWhile, take)+import qualified Data.ByteString.Char8 as BS+import Data.Word+import qualified Data.Attoparsec.ByteString as AB+import Data.Attoparsec.ByteString.Char8+import qualified Data.Attoparsec.ByteString.Lazy as AL+import Control.Applicative+import Control.Monad.IO.Class++-- import Debug.Trace++import Network.Memcache.Class+import Network.Memcache.IO.Internal++instance Message Response where+  parseHeader = parseResponseHeader++  toChunks = Network.Memcache.Response.toChunks++  recvContent handle resp = case resp of+    Value key flags len _ version -> liftIO $ do+      value <- readBytes handle len+      _term <- BS.hGetLine handle+      return $ Just $ Value key flags len value version+    _ -> return $ Just resp++{-|+  response messages from memcached server+-}+data Response =+    Ok+  | Value {+      _resKey     :: !BS.ByteString+    , _resFlag    :: !Word32+    , _resLen     :: !Word64+    , _resValue   :: BS.ByteString+    , _resVersion :: !(Maybe Word64)+    }+  | End+  | Stored+  | NotStored+  | Exists+  | NotFound+  | Deleted+  | Found+  | Touched+  | Error+  | ServerError String+  | ClientError String+  | Version BS.ByteString+  | Stat BS.ByteString BS.ByteString -- name and value pair+  | Code Word64+  deriving (Show, Eq)++{-|+  Response parser by attoparsec.+-}+responseParser :: Parser Response+responseParser = responseParser' False++{-|+  Response header parser by attoparsec.+-}+responseHeaderParser :: Parser Response+responseHeaderParser = responseParser' True++-- make a parser depending on onlyHeadler switch+responseParser' :: Bool -> Parser Response+responseParser' onlyHeader = try parser <|> codeParser+  where+    parser :: Parser Response+    parser = do+      cmd <- ws *> word <* ws+      resp <- case {- trace ("cmd: " ++ show cmd) -} cmd of+        "VALUE"        -> do+          key     <- skipWhile (== ' ') *> takeWhile1 (\c -> c /= ' ')+          flags   <- skipWhile (== ' ') *> decimal+          len     <- skipWhile (== ' ') *> decimal :: Parser Word64+          version <- skipWhile (== ' ') *> try (Just <$> decimal) <|> return (Nothing) <* skipWhile (== ' ')+          if onlyHeader+            then do+              return (Value key flags len "" version)+            else do+              value <- endline *> take (fromIntegral len) -- XXX+              return (Value key flags len value version)+        "END"          -> pure End+        "STORED"       -> pure Stored+        "NOT_STORED"   -> pure NotStored+        "EXISTS"       -> pure Exists+        "NOT_FOUND"    -> pure NotFound+        "DELETED"      -> pure Deleted+        "OK"           -> pure Ok+        "FOUND"        -> pure Found+        "TOUCHED"      -> pure Touched+        "ERROR"        -> pure Error+        "SERVER_ERROR" -> ServerError <$> (skipWhile (== ' ') *> fmap BS.unpack (AL.takeTill isEndOfLine))+        "CLIENT_ERROR" -> ClientError <$> (skipWhile (== ' ') *> fmap BS.unpack (AL.takeTill isEndOfLine))+        "STAT"         -> Stat+                          <$> (skipWhile (== ' ') *> takeWhile1 (/= ' '))+                          <*> (skipWhile (== ' ') *> AL.takeTill isEndOfLine)+        "VERSION"      -> Version <$> (skipWhile (== ' ') *> AL.takeTill isEndOfLine)+        _              -> fail $ "unknown response " ++ BS.unpack cmd+      _ <- endline+      return (resp)++    word = AB.takeWhile1 (\c -> c /= 32 && c /= 10 && c /= 13)++    ws = AB.skipWhile (== 32)++    codeParser :: Parser Response+    codeParser = Code <$> (skipWhile (== ' ') *> decimal <* skipWhile (== ' ') <* endline)+    +    endline :: Parser BS.ByteString+    endline = try (string "\r\n") <|> string "\n" <|> string "\r"++{-|+  Parse a response.+-}+parseResponse :: BS.ByteString -> Maybe Response+parseResponse = parseResponse' False++{-|+  Parse a response but only its header.+-}+parseResponseHeader :: BS.ByteString -> Maybe Response+parseResponseHeader = parseResponse' True++-- parse one response+parseResponse' :: Bool -> BS.ByteString -> Maybe Response+parseResponse' onlyHeader input = let r = parse (responseParser' onlyHeader) input in case r of+  Fail {} -> Nothing+  Partial parse' -> let r' = parse' "\r\n" in case r' of+    Done _ result -> Just result+    Fail {} -> Nothing+    Partial {} -> Nothing+  Done _ result -> Just result++{-|+  Convert a response to bytestring chunks.+-}+toChunks :: Response -> [BS.ByteString]+toChunks result = case result of+  Ok        -> ["OK\r\n"]+  Value key flag len value version ->+    let vh = maybe [] (\v -> [sp, show' v]) version+        sp = " "+        header = BS.concat $ ["VALUE", sp, key, sp, show' flag, sp, show' len] ++ vh ++ ["\r\n"]+    in [header, value, "\r\n"]+  End       -> ["END\r\n"]+  Stored    -> ["STORED\r\n"]+  NotStored -> ["NOT_STORED\r\n"]+  Exists    -> ["EXISTS\r\n"]+  NotFound  -> ["NOT_FOUND\r\n"]+  Deleted   -> ["DELETED\r\n"]+  Found     -> ["FOUND\r\n"]+  Touched   -> ["TOUCHED\r\n"]+  Error     -> ["ERROR\r\n"]+  ServerError msg -> [BS.concat ["SERVER_ERROR", BS.pack $ if null msg then "" else " " ++ msg, "\r\n"]]+  ClientError msg -> [BS.concat ["CLIENT_ERROR", BS.pack $ if null msg then "" else " " ++ msg, "\r\n"]]+  Version version -> [BS.concat $ [BS.intercalate " " ["VERSION", version], "\r\n"]]+  Code code -> [BS.pack $ show code ++ "\r\n"]+  Stat name value -> [BS.concat ["STAT", " ", name, " ", value, "\r\n"]]+  where+    show' :: (Show a) => a -> BS.ByteString+    show' = BS.pack . show
+ src/Network/Memcache/Stats.hs view
@@ -0,0 +1,195 @@+-- Copyright (c) 2013, GREE, Inc. All rights reserved.+-- authors: Kiyoshi Ikehara <kiyoshi.ikehara@gree.net>++{-| Statistic information++Please refer to <https://github.com/memcached/memcached/blob/master/doc/protocol.txt> for detail.+-}+module Network.Memcache.Stats (+    getValue+  , getPid+  , getUptime+  , getTime+  , getVersion+  , getPointerSize+  , getRusageUser+  , getRusageSystem+  , getCurrItems+  , getTotalItems+  , getBytes+  , getCurrConnections+  , getTotalConnections+  , getConnectionStructures+  , getCmdGet+  , getCmdSet+  , getGetHits+  , getGetMisses+  , getEvictions+  , getBytesRead+  , getBytesWritten+  , getLimitMaxbytes+  , getThreads+  ) where++import Data.Int+import Data.Word+import Data.List.Split++import Network.Memcache.Client++{-|+  get any stats value as a string+-}+getValue :: String -> StatsList -> Maybe String+getValue key statsList = lookup key statsList++{-|+  pid (32u)+-}+getPid :: StatsList -> Maybe Word32+getPid = getValueAs "pid"++{-|+  uptime (32u)+-}+getUptime :: StatsList -> Maybe Word32+getUptime = getValueAs "uptime"++{-|+  time (32u)+  unix time+-}+getTime :: StatsList -> Maybe Word32+getTime = getValueAs "time"++{-|+  version (string)+-}+getVersion :: StatsList -> Maybe String+getVersion = getValue "version"++{-|+  pointer_size (32)+-}+getPointerSize :: StatsList -> Maybe Int32+getPointerSize = getValueAs "pointer_size"++{-|+  rusage_user (32u.32u)+-}+getRusageUser :: StatsList -> Maybe (Word32, Word32)+getRusageUser sl = do+  ru <- getValue "rusage_user" sl+  case splitOn "." ru of+    (second:microsec:[]) -> return (read second, read microsec)+    _ -> fail "invalid rusage_user"++{-|+  rusage_system (32u.32u)+-}+getRusageSystem :: StatsList -> Maybe (Word32, Word32)+getRusageSystem sl = do+  ru <- getValue "rusage_system" sl+  case splitOn "." ru of+    (second:microsec:[]) -> return (read second, read microsec)+    _ -> fail "invalid rusage_system"++{-|+  curr_items (32u)+-}+getCurrItems :: StatsList -> Maybe Word64+getCurrItems = getValueAs "curr_items"++{-|+  total_items (32u)+-}+getTotalItems :: StatsList -> Maybe Word64+getTotalItems = getValueAs "total_items"++{-|+  bytes (64u)+-}+getBytes :: StatsList -> Maybe Word64+getBytes = getValueAs "bytes"++{-|+  curr_connections (32u)+-}+getCurrConnections :: StatsList -> Maybe Word32+getCurrConnections = getValueAs "curr_connections"++{-|+  total_connections (32u)+-}+getTotalConnections :: StatsList -> Maybe Word32+getTotalConnections = getValueAs "total_connections"++{-|+  connection_structures (32u)+-}+getConnectionStructures :: StatsList -> Maybe Word32+getConnectionStructures = getValueAs "connection_structures"++-- reserved_fds++{-|+  cmd_get (64u)+-}+getCmdGet :: StatsList -> Maybe Word64+getCmdGet = getValueAs "cmd_get"++{-|+  cmd_set (64u)+-}+getCmdSet :: StatsList -> Maybe Word64+getCmdSet = getValueAs "cmd_set"++{-|+  get_hits (64u)+-}+getGetHits :: StatsList -> Maybe Word64+getGetHits = getValueAs "get_hits"++{-|+  get_misses (64u)+-}+getGetMisses :: StatsList -> Maybe Word64+getGetMisses = getValueAs "get_misses"++{-|+  evictions (64u)+-}+getEvictions :: StatsList -> Maybe Word64+getEvictions = getValueAs "evictions"++{-|+  bytes_read (64u)+-}+getBytesRead :: StatsList -> Maybe Word64+getBytesRead = getValueAs "bytes_read"++{-|+  bytes_written (64u)+-}+getBytesWritten :: StatsList -> Maybe Word64+getBytesWritten = getValueAs "bytes_written"++{-|+  limit_maxbytes (32u)+-}+getLimitMaxbytes :: StatsList -> Maybe Word64+getLimitMaxbytes = getValueAs "limit_maxbytes"++{-|+  threads (32u)+-}+getThreads :: StatsList -> Maybe Word32+getThreads = getValueAs "threads"+++----------------------------------------------------------------++getValueAs :: (Read a) => String -> StatsList -> Maybe a+getValueAs key statsList = do+  value <- getValue key statsList+  return (read value)
+ src/Network/Memcache/Types.hs view
@@ -0,0 +1,14 @@+-- Copyright (c) 2013, GREE, Inc. All rights reserved.+-- authors: Kiyoshi Ikehara <kiyoshi.ikehara@gree.net>++-- | Types+module Network.Memcache.Types where++-- | statistic property list+type StatsList = [(String, String)]++-- | hostname and port (ex. \"localhost:11211\")+type Nodekey = String+++
+ test/test-memcache.hs view
@@ -0,0 +1,285 @@+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE FlexibleInstances #-}++module Main where++import Data.Char+import Data.Word+import qualified Data.ByteString.Char8 as BS+--import Test.Framework+import Test.Framework.TH+--import Test.Framework.Providers.HUnit+import Test.Framework.Providers.QuickCheck2+import Test.QuickCheck+--import Test.QuickCheck.Arbitrary++import Network.Memcache.Class (toChunks)+import Network.Memcache.Op+import qualified Network.Memcache.Response as R++import Debug.Trace++type ValueT = BS.ByteString+type BytesT = Word64++newtype Key = Key { getKey :: BS.ByteString } deriving Show+newtype PrintableString = PrintableString { getPrintableString :: String } deriving Show++instance Arbitrary BS.ByteString where+  arbitrary = fmap BS.pack $ arbitrary `suchThat` printableNonSpace++instance Arbitrary Key where+  arbitrary = do+    bs <- fmap BS.pack $ arbitrary `suchThat` printableNonSpace+    return (Key bs)++instance Arbitrary PrintableString where+  arbitrary = do+    bs <- arbitrary `suchThat` printableNonSpace+    return (PrintableString bs)++instance Arbitrary Option where+  arbitrary = oneof [ return Noreply ]++printableNonSpace :: String -> Bool+printableNonSpace xs = not (null xs) && (and $ map (\c -> isPrint c && c /= ' ') xs)++main :: IO ()+main = $(defaultMainGenerator)++----------------------------------------------------------------++prop_toChunks_SetOp :: Key -> Word32 -> Word64 -> [Option] -> ValueT -> Bool+prop_toChunks_SetOp key flags exptime options value = r == e+ where+   key' = getKey key+   r = chunk2string (toChunks $ SetOp key' flags exptime (fromIntegral $ BS.length value) value options)+   e = "set " ++ BS.unpack key' ++ " " ++ show flags ++ " " ++ show exptime ++ " " ++ (show $ BS.length value) ++ showOptions options ++ ln ++ BS.unpack value ++ ln++prop_toChunks_CasOp :: Key -> Word32 -> Word64 -> Word64 -> [Option] -> ValueT -> Bool+prop_toChunks_CasOp key flags exptime version options value = r == e+ where+   key' = getKey key+   r = chunk2string (toChunks $ CasOp key' flags exptime (fromIntegral $ BS.length value) version value options)+   e = "cas " ++ BS.unpack key' ++ " " ++ show flags ++ " " ++ show exptime ++ " " ++ (show $ BS.length value) ++ " " ++ show version ++ showOptions options ++ ln ++ BS.unpack value ++ ln++prop_toChunks_AddOp :: Key -> Word32 -> Word64 -> [Option] -> ValueT -> Bool+prop_toChunks_AddOp key flags exptime options value = r == e+ where+   key' = getKey key+   r = chunk2string (toChunks $ AddOp key' flags exptime (fromIntegral $ BS.length value) value options)+   e = "add " ++ BS.unpack key' ++ " " ++ show flags ++ " " ++ show exptime ++ " " ++ (show $ BS.length value) ++ showOptions options ++ ln ++ BS.unpack value ++ ln++prop_toChunks_ReplaceOp :: Key -> Word32 -> Word64 -> [Option] -> ValueT -> Bool+prop_toChunks_ReplaceOp key flags exptime options value = r == e+ where+   key' = getKey key+   r = chunk2string (toChunks $ ReplaceOp key' flags exptime (fromIntegral $ BS.length value) value options)+   e = "replace " ++ BS.unpack key' ++ " " ++ show flags ++ " " ++ show exptime ++ " " ++ (show $ BS.length value) ++ showOptions options ++ ln ++ BS.unpack value ++ ln++prop_toChunks_AppendOp :: Key -> Word32 -> Word64 -> [Option] -> ValueT -> Bool+prop_toChunks_AppendOp key flags exptime options value = r == e+ where+   key' = getKey key+   r = chunk2string (toChunks $ AppendOp key' flags exptime (fromIntegral $ BS.length value) value options)+   e = "append " ++ BS.unpack key' ++ " " ++ show flags ++ " " ++ show exptime ++ " " ++ (show $ BS.length value) ++ showOptions options ++ ln ++ BS.unpack value ++ ln++prop_toChunks_PrependOp :: Key -> Word32 -> Word64 -> [Option] -> ValueT -> Bool+prop_toChunks_PrependOp key flags exptime options value = r == e+ where+   key' = getKey key+   r = chunk2string (toChunks $ PrependOp key' flags exptime (fromIntegral $ BS.length value) value options)+   e = "prepend " ++ BS.unpack key' ++ " " ++ show flags ++ " " ++ show exptime ++ " " ++ (show $ BS.length value) ++ showOptions options ++ ln ++ BS.unpack value ++ ln++prop_toChunks_GetOp :: [Key] -> Bool+prop_toChunks_GetOp keys = r == e+ where+   keys' = map getKey keys+   r = chunk2string (toChunks $ GetOp keys')+   e = "get " ++ BS.unpack (BS.intercalate " " keys') ++ ln++prop_toChunks_GetsOp :: [Key] -> Bool+prop_toChunks_GetsOp keys = r == e+ where+   keys' = map getKey keys+   r = chunk2string (toChunks $ GetsOp keys')+   e = "gets " ++ BS.unpack (BS.intercalate " " keys') ++ ln++prop_toChunks_DeleteOp :: Key -> [Option] -> Bool+prop_toChunks_DeleteOp key options = r == e+ where+   key' = getKey key+   r = chunk2string (toChunks $ DeleteOp key' options)+   e = "delete " ++ BS.unpack key' ++ showOptions options ++ ln++prop_toChunks_IncrOp :: Key -> Word64 -> [Option] -> Bool+prop_toChunks_IncrOp key diff options = r == e+ where+   key' = getKey key+   r = chunk2string (toChunks $ IncrOp key' diff options)+   e = "incr " ++ BS.unpack key' ++ " " ++ show diff ++ showOptions options ++ ln++prop_toChunks_DecrOp :: Key -> Word64 -> [Option] -> Bool+prop_toChunks_DecrOp key diff options = r == e+ where+   key' = getKey key+   r = chunk2string (toChunks $ DecrOp key' diff options)+   e = "decr " ++ BS.unpack key' ++ " " ++ show diff ++ showOptions options ++ ln++prop_toChunks_TouchOp :: Key -> Word64 -> [Option] -> Bool+prop_toChunks_TouchOp key exptime options = r == e+ where+   key' = getKey key+   r = chunk2string (toChunks $ TouchOp key' exptime options)+   e = "touch " ++ BS.unpack key' ++ " " ++ show exptime ++ showOptions options ++ ln++prop_toChunks_PingOp :: Bool+prop_toChunks_PingOp = chunk2string (toChunks PingOp) == "ping" ++ ln++prop_toChunks_FlushAllOp :: Bool+prop_toChunks_FlushAllOp = chunk2string (toChunks FlushAllOp) == "flush_all" ++ ln++prop_toChunks_QuitOp :: Bool+prop_toChunks_QuitOp = chunk2string (toChunks QuitOp) == "quit" ++ ln++prop_toChunks_StatsOp :: [PrintableString] -> Bool+prop_toChunks_StatsOp args = chunk2string (toChunks $ StatsOp (map (BS.pack . getPrintableString) args)) == "stats" ++ concat (map (\s -> " " ++ getPrintableString s) args) ++ ln++--------------------------------++prop_parseOpHeader_SetOp :: Key -> Word32 -> Word64 -> [Option] -> ValueT -> Bool+prop_parseOpHeader_SetOp key flags exptime options value = parseOpHeader_SetOp "set" SetOp key flags exptime options value++prop_parseOpHeader_CasOp :: Key -> Word32 -> Word64 -> Word64 -> [Option] -> ValueT -> Bool+prop_parseOpHeader_CasOp key flags exptime version options value = op == Just (CasOp key' flags exptime (fromIntegral $ BS.length value) version "" options)+ where+   key' = getKey key+   op = parseOpHeader (BS.pack ("cas " ++ BS.unpack key' ++ " " ++ show flags ++ " " ++ show exptime ++ " " ++ show (BS.length value) ++ " " ++ show version ++ showOptions options))++prop_parseOpHeader_AddOp :: Key -> Word32 -> Word64 -> [Option] -> ValueT -> Bool+prop_parseOpHeader_AddOp key flags exptime options value = parseOpHeader_SetOp "add" AddOp key flags exptime options value++prop_parseOpHeader_ReplaceOp :: Key -> Word32 -> Word64 -> [Option] -> ValueT -> Bool+prop_parseOpHeader_ReplaceOp key flags exptime options value = parseOpHeader_SetOp "replace" ReplaceOp key flags exptime options value++prop_parseOpHeader_AppendOp :: Key -> Word32 -> Word64 -> [Option] -> ValueT -> Bool+prop_parseOpHeader_AppendOp key flags exptime options value = parseOpHeader_SetOp "append" AppendOp key flags exptime options value++prop_parseOpHeader_PrependOp :: Key -> Word32 -> Word64 -> [Option] -> ValueT -> Bool+prop_parseOpHeader_PrependOp key flags exptime options value = parseOpHeader_SetOp "prepend" PrependOp key flags exptime options value++prop_parseOpHeader_GetOp :: [Key] -> Bool+prop_parseOpHeader_GetOp keys = op == if null keys then Nothing else Just (GetOp keys')+  where+   keys' = map getKey keys+   op = parseOpHeader (BS.pack ("get " ++ BS.unpack (BS.intercalate " " keys')))++prop_parseOpHeader_GetsOp :: [Key] -> Bool+prop_parseOpHeader_GetsOp keys = op == if null keys then Nothing else Just (GetsOp keys')+  where+   keys' = map getKey keys+   op = parseOpHeader (BS.pack ("gets " ++ BS.unpack (BS.intercalate " " keys')))++prop_parseOpHeader_DeleteOp :: Key -> [Option] -> Bool+prop_parseOpHeader_DeleteOp key options = op == Just (DeleteOp key' options)+ where+   key' = getKey key+   op = parseOpHeader (BS.pack ("delete " ++ BS.unpack key' ++ showOptions options))++prop_parseOpHeader_IncrOp :: Key -> Word64 -> [Option] -> Bool+prop_parseOpHeader_IncrOp key value options = op == Just (IncrOp key' value options)+ where+   key' = getKey key+   op = parseOpHeader (BS.pack ("incr " ++ BS.unpack key' ++ " " ++ show value ++ showOptions options))++prop_parseOpHeader_DecrOp :: Key -> Word64 -> [Option] -> Bool+prop_parseOpHeader_DecrOp key value options = op == Just (DecrOp key' value options)+ where+   key' = getKey key+   op = parseOpHeader (BS.pack ("decr " ++ BS.unpack key' ++ " " ++ show value ++ showOptions options))++prop_parseOpHeader_TouchOp :: Key -> Word64 -> [Option] -> Bool+prop_parseOpHeader_TouchOp key exptime options = op == Just (TouchOp key' exptime options)+ where+   key' = getKey key+   op = parseOpHeader (BS.pack ("touch " ++ BS.unpack key' ++ " " ++ show exptime ++ showOptions options))++prop_parseOpHeader_PingOp :: Bool+prop_parseOpHeader_PingOp = parseOpHeader "ping" == Just (PingOp)++prop_parseOpHeader_FlushAllOp :: Bool+prop_parseOpHeader_FlushAllOp = parseOpHeader "flush_all" == Just (FlushAllOp)++prop_parseOpHeader_VersionOp :: Bool+prop_parseOpHeader_VersionOp = parseOpHeader "version" == Just (VersionOp)++prop_parseOpHeader_QuitOp :: Bool+prop_parseOpHeader_QuitOp = parseOpHeader "quit" == Just (QuitOp)++prop_parseOpHeader_StatsOp :: [PrintableString] -> Bool+prop_parseOpHeader_StatsOp stats = parseOpHeader (BS.pack $ "stats" ++ concat (map (\s -> " " ++ getPrintableString s) stats)) == Just (StatsOp (map (BS.pack . getPrintableString) stats))++--------------------------------++prop_toChunks_Value :: Key -> Word32 -> ValueT -> Maybe Word64 -> Bool+prop_toChunks_Value key flag value version = chunk2string (toChunks $ R.Value key' flag len value version) == resp+  where+    len = fromIntegral $ BS.length value+    key' = getKey key+    resp = "VALUE " ++ BS.unpack key' ++ " " ++ show flag ++ " "++ show len ++ showVersion version ++ ln ++ BS.unpack value ++ ln+    showVersion version' = case version' of+      Just v -> " " ++ show v+      Nothing -> ""++prop_toChunks_Ok :: Bool+prop_toChunks_Ok = chunk2string (toChunks R.Ok) == "OK" ++ ln++--------------------------------++prop_parseResponseHeader_Value :: Key -> Word32 -> Word64 -> Maybe Word64 -> Bool+prop_parseResponseHeader_Value key flags len version = response == Just (R.Value key' flags len "" version)+  where+    response = R.parseResponseHeader input+    input = BS.pack $ "VALUE " ++ BS.unpack key' ++ " " ++ show flags ++ " " ++ show len ++ versionPart version+    key' = getKey key+    versionPart version' = case version' of+      Just v -> " " ++ show v+      Nothing -> ""++prop_parseResponseHeader_Ok :: Bool+prop_parseResponseHeader_Ok = R.parseResponseHeader "OK" == Just (R.Ok)++prop_parseResponseHeader_ServerError :: PrintableString -> Bool+prop_parseResponseHeader_ServerError msg = R.parseResponseHeader (BS.pack $ "SERVER_ERROR " ++ msg' ++ "\r\n") == Just (R.ServerError msg')+  where+    msg' = getPrintableString msg++prop_parseResponseHeader_ClientError :: PrintableString -> Bool+prop_parseResponseHeader_ClientError msg = R.parseResponseHeader (BS.pack $ "CLIENT_ERROR " ++ msg' ++ "\r\n") == Just (R.ClientError msg')+  where+    msg' = getPrintableString msg++prop_parseResponseHeader_Code :: Word64 -> Bool+prop_parseResponseHeader_Code code = R.parseResponseHeader (BS.pack $ show code) == Just (R.Code code)++----------------------------------------------------------------++chunk2string :: [BS.ByteString] -> String+chunk2string = BS.unpack . BS.concat++ln :: String+ln = "\r\n"++showOptions :: Show a => [a] -> String+showOptions options = (concat $ map (\o -> " " ++ show o) options)++parseOpHeader_SetOp :: String -> (BS.ByteString -> Word32 -> Word64 -> BytesT -> ValueT -> [Option] -> Op) -> Key -> Word32 -> Word64 -> [Option] -> ValueT -> Bool+parseOpHeader_SetOp cmd opType key flags exptime options value = if op == expected then True else trace ("expected: " ++ show expected ++ " but: " ++ show op) False+ where+   key' = getKey key+   expected = Just (opType key' flags exptime (fromIntegral $ BS.length value) "" options)+   op = parseOpHeader (BS.pack (cmd ++ " " ++ BS.unpack key' ++ " " ++ show flags ++ " " ++ show exptime ++ " " ++ show (BS.length value) ++ showOptions options))+++