Merge branch 'develop'

first release.

README.md

@@ -0,0 +1,3 @@
+memcached-binary [![Build Status](https://travis-ci.org/philopon/memcached-binary.svg?branch=master)](https://travis-ci.org/philopon/memcached-binary)
+===
+memcached client using binary protocol.

memcached-binary.cabal

@@ -9,14 +9,20 @@ copyright:           (c) 2014 Hirotomo Moriwaki
 category:            Database
 build-type:          Simple
 cabal-version:       >=1.10
+extra-source-files:  src/Database/Memcached/Binary/Common.hs
+                     src/Database/Memcached/Binary/Header.txt
 
 library
   exposed-modules:     Database.Memcached.Binary
-                       Database.Memcached.Binary.Exception
+                       Database.Memcached.Binary.Maybe
+                       Database.Memcached.Binary.Either
+                       Database.Memcached.Binary.IO
+
                        Database.Memcached.Binary.Types
+                       Database.Memcached.Binary.Types.Exception
                        Database.Memcached.Binary.Internal
                        Database.Memcached.Binary.Internal.Definition
-  build-depends:       base                 >=4.7  && <4.8
+  build-depends:       base                 >=4.6  && <4.8
                      , bytestring           >=0.10 && <0.11
                      , network              >=2.6  && <2.7
                      , storable-endian      >=0.2  && <0.3
@@ -28,3 +34,19 @@ library
   ghc-options:         -Wall -O2
   hs-source-dirs:      src
   default-language:    Haskell2010
+
+test-suite test
+  type:                exitcode-stdio-1.0
+  hs-source-dirs:      test
+  main-is:             test.hs
+  ghc-options:         -Wall -O2
+  build-depends:       base                 >=4.6  && <4.8
+                     , memcached-binary
+                     , test-framework       >=0.8  && <0.9
+                     , test-framework-hunit >=0.3  && <0.4
+                     , process              >=1.2  && <1.3
+                     , network              >=2.6  && <2.7
+                     , HUnit                >=1.2  && <1.3
+                     , data-default-class   >=0.0  && <0.1
+                     , bytestring           >=0.10 && <0.11
+  default-language:    Haskell2010

src/Database/Memcached/Binary.hs

@@ -1,291 +1,5 @@
-{-# LANGUAGE FlexibleInstances #-}
+module Database.Memcached.Binary {-# WARNING "use Database.Memcached.Binary.Maybe(or Either, IO) instead." #-}
-{-# LANGUAGE NoMonomorphismRestriction #-}
+    ( module Database.Memcached.Binary.Maybe
-
-module Database.Memcached.Binary
-    ( -- * connection
-      I.Connection, I.withConnection, I.connect, I.close
-      -- * get
-    , get,  get_
-    , get', get'_
-    , getMaybe, getMaybe_
-      -- * set
-    , set,  add,  replace
-    , set', add', replace'
-      -- * delete
-    , delete, delete'
-      -- * increment/decrement
-    , increment,  decrement
-    , increment', decrement'
-      -- * flush
-    , flushAll, flushAll'
-    -- * version
-    , version, version'
-    -- * noOp
-    , noOp, noOp'
-    -- * append/prepend
-    , append,  prepend
-    , append', prepend'
-    -- * touch
-    , touch,  getAndTouch,  getAndTouch_,  getMaybeAndTouch
-    , touch', getAndTouch', getAndTouch'_, getMaybeAndTouch_
-      -- * modify
-    , modify , modify_
-      -- * reexports
-    , module Database.Memcached.Binary.Types
-    -- | def
-    , module Data.Default.Class
-    -- | PortID(..)
-    , module Network
     ) where
 
-import Control.Exception
+import Database.Memcached.Binary.Maybe
-import Network(PortID(..))
-
-import Data.Default.Class(def)
-
-import qualified Data.ByteString as S
-
-import Database.Memcached.Binary.Types
-import Database.Memcached.Binary.Exception
-import Database.Memcached.Binary.Internal.Definition
-import qualified Database.Memcached.Binary.Internal as I
-
-failureIO :: I.Failure a
-failureIO w m = throwIO $ MemcachedException w m
-
-failureMaybe :: I.Failure (Maybe a)
-failureMaybe _ _ = return Nothing
-
-failureBool :: I.Failure Bool
-failureBool _ _ = return False
-
---------------------------------------------------------------------------------
-
--- | get value and flags. if error occured, throw MemcachedException.
-get :: Key -> I.Connection -> IO (Flags, Value)
-get = I.useConnection . I.get (\_ f v -> return (f,v)) failureIO
-
--- | get value and flags. if error occured, return Nothing.
---
--- @
--- get' == getMaybe
--- @
-getMaybe, get' :: Key -> I.Connection -> IO (Maybe (Flags, Value))
-getMaybe = I.useConnection . I.get (\_ f v -> return $ Just (f,v)) failureMaybe
-get' = getMaybe
-
--- | get value. if error occured, throw MemcachedException.
-get_ :: Key -> I.Connection -> IO Value
-get_ = I.useConnection . I.get (\_ _ v -> return v) failureIO
-
--- | get value. if error occured, return Nothing.
---
--- @
--- get'_ == getMaybe_
--- @
-getMaybe_, get'_ :: Key -> I.Connection -> IO (Maybe Value)
-getMaybe_ = I.useConnection . I.get (\_ _ v -> return $ Just v) failureMaybe
-get'_ = getMaybe_
-
---------------------------------------------------------------------------------
-
-setAddReplace :: OpCode -> Flags -> Expiry
-              -> Key -> Value -> I.Connection -> IO ()
-setAddReplace op = \f e key value -> I.useConnection $
-    I.setAddReplace (const $ return ()) failureIO op (CAS 0) key value f e
-
--- | set value. if error occured, throw MemcachedException.
-set :: Flags -> Expiry -> Key -> Value -> I.Connection -> IO ()
-set = setAddReplace opSet
-
--- | add value. if error occured, throw MemcachedException.
-add :: Flags -> Expiry -> Key -> Value -> I.Connection -> IO ()
-add = setAddReplace opAdd
-
--- | replace value. if error occured, throw MemcachedException.
-replace :: Flags -> Expiry -> Key -> Value -> I.Connection -> IO ()
-replace = setAddReplace opReplace
-
-setAddReplace' :: OpCode -> Flags -> Expiry
-               -> Key -> Value -> I.Connection -> IO Bool
-setAddReplace' op = \f e key value -> I.useConnection $
-    I.setAddReplace (const $ return True) failureBool op (CAS 0) key value f e
-
-
--- | set value. if error occured, return False.
-set' :: Flags -> Expiry -> Key -> Value -> I.Connection -> IO Bool
-set' = setAddReplace' opSet
-
--- | add value. if error occured, return False.
-add' :: Flags -> Expiry -> Key -> Value -> I.Connection -> IO Bool
-add' = setAddReplace' opAdd
-
--- | replace value. if error occured, return False.
-replace' :: Flags -> Expiry -> Key -> Value -> I.Connection -> IO Bool
-replace' = setAddReplace' opReplace
-
---------------------------------------------------------------------------------
-
--- | delete value. if error occured, throw MemcachedException.
-delete :: Key -> I.Connection -> IO ()
-delete = I.useConnection . I.delete (\_ -> return ()) failureIO (CAS 0)
-
--- | delete value. if error occured, return False.
-delete' :: Key -> I.Connection -> IO Bool
-delete' = I.useConnection . I.delete (\_ -> return True) failureBool (CAS 0)
-
---------------------------------------------------------------------------------
-
--- | modify value in transaction. if error occured, throw MemcachedException.
-modify :: Expiry -> Key -> (Flags -> Value -> (Flags, Value, a))
-       -> I.Connection -> IO a
-modify e key fn = I.useConnection $ \h ->
-    I.get (\c f v -> 
-        let (f', v', r) = fn f v
-        in I.setAddReplace (const $ return r) failureIO opSet c key v' f' e h
-    ) failureIO key h
-
--- | modify value in transaction. if error occured, throw MemcachedException.
-modify_ :: Expiry
-        -> Key -> (Flags -> Value -> (Flags, Value))
-        -> I.Connection -> IO ()
-modify_ e key fn = I.useConnection $ \h ->
-    I.get (\c f v -> 
-        let (f', v') = fn f v
-        in I.setAddReplace (const $ return ()) failureIO opSet c key v' f' e h
-    ) failureIO key h
-
---------------------------------------------------------------------------------
-
-incrDecr :: OpCode -> Expiry
-         -> Key -> Delta -> Initial -> I.Connection -> IO Counter
-incrDecr op = \e k d i -> I.useConnection $
-    I.incrDecr (\_ w -> return w) failureIO op (CAS 0) k d i e
-
-incrDecr' :: OpCode -> Expiry
-          -> Key -> Delta -> Initial -> I.Connection -> IO (Maybe Counter)
-incrDecr' op e k d i = I.useConnection $
-    I.incrDecr (\_ w -> return $ Just w) failureMaybe op (CAS 0) k d i e
-
-
--- | increment value. if error occured, throw MemcachedException.
-increment :: Expiry -> Key -> Delta -> Initial -> I.Connection -> IO Counter
-increment = incrDecr opIncrement
-
--- | decrement value. if error occured, throw MemcachedException.
-decrement :: Expiry -> Key -> Delta -> Initial -> I.Connection -> IO Counter
-decrement = incrDecr opDecrement
-
--- | increment value. if error occured, return Nothing.
-increment' :: Expiry -> Key -> Delta -> Initial
-           -> I.Connection -> IO (Maybe Counter)
-increment' = incrDecr' opIncrement
-
--- | decrement value. if error occured, return Nothing.
-decrement' :: Expiry -> Key -> Delta -> Initial
-           -> I.Connection -> IO (Maybe Counter)
-decrement' = incrDecr' opDecrement
-
---------------------------------------------------------------------------------
-
--- | flush all value. if error occured, throw MemcachedException.
-flushAll :: I.Connection -> IO ()
-flushAll = I.useConnection $ I.flushAll (return ()) failureIO
-
--- | flush all value. if error occured, return False.
-flushAll' :: I.Connection -> IO Bool
-flushAll' = I.useConnection $ I.flushAll (return True) failureBool
-
---------------------------------------------------------------------------------
-
--- | get version string. if error occured, throw MemcachedException.
-version :: I.Connection -> IO S.ByteString
-version = I.useConnection $ I.version return failureIO
-
--- | get version string. if error occured, return False.
-version' :: I.Connection -> IO (Maybe S.ByteString)
-version' = I.useConnection $ I.version (return . Just) failureMaybe
-
---------------------------------------------------------------------------------
-
--- | noop(use for keepalive). if error occured, throw MemcachedException.
-noOp :: I.Connection -> IO ()
-noOp  = I.useConnection $ I.noOp (return ())   failureIO
-
--- | noop(use for keepalive). if error occured, return False.
-noOp' :: I.Connection -> IO Bool
-noOp' = I.useConnection $ I.noOp (return True) failureBool
-
---------------------------------------------------------------------------------
-
-appendPrepend :: OpCode -> Key -> Value -> I.Connection -> IO ()
-appendPrepend o = \k v -> I.useConnection $
-    I.appendPrepend (\_ -> return ()) failureIO o (CAS 0) k v
-
-appendPrepend' :: OpCode -> Key -> Value -> I.Connection -> IO Bool
-appendPrepend' o = \k v -> I.useConnection $
-    I.appendPrepend (\_ -> return False) failureBool o (CAS 0) k v
-
--- | apeend value. if error occured, throw MemcachedException.
-append :: Key -> Value -> I.Connection -> IO ()
-append  = appendPrepend opAppend
-
--- | prepend value. if error occured, throw MemcachedException.
-prepend :: Key -> Value -> I.Connection -> IO ()
-prepend = appendPrepend opPrepend
-
--- | append value. if error occured, return False.
-append' :: Key -> Value -> I.Connection -> IO Bool
-append'  = appendPrepend' opAppend
-
--- | preppend value. if error occured, return False.
-prepend' :: Key -> Value -> I.Connection -> IO Bool
-prepend' = appendPrepend' opPrepend
-
---------------------------------------------------------------------------------
-
--- | change expiry. if error occured, throw MemcachedException.
-touch :: Key -> Expiry -> I.Connection -> IO ()
-touch k e = I.useConnection $
-    I.touch (\_ _ _ -> return ()) failureIO opTouch k e
-
--- | change expiry. if error occured, return False.
-touch' :: Key -> Expiry -> I.Connection -> IO Bool
-touch' k e = I.useConnection $
-    I.touch (\_ _ _ -> return True) failureBool opTouch k e
-
--- | get value and flags, then change expiry. 
--- if error occured, throw MemcachedException.
-getAndTouch :: Key -> Expiry -> I.Connection -> IO (Flags, Value)
-getAndTouch k e = I.useConnection $
-    I.touch (\_ f v -> return (f,v)) failureIO opGAT k e
-
--- | get value and flags, then change expiry. 
--- if error occured, return Nothing.
---
--- @
--- getMaybeAndTouch == getAndTouch'
--- @
-getAndTouch', getMaybeAndTouch
-    :: Key -> Expiry -> I.Connection -> IO (Maybe (Flags, Value))
-getAndTouch' k e = I.useConnection $
-    I.touch (\_ f v -> return $ Just (f,v)) failureMaybe opGAT k e
-getMaybeAndTouch = getAndTouch'
-
--- | get value then change expiry. 
--- if error occured, throw MemcachedException.
-getAndTouch_ :: Key -> Expiry -> I.Connection -> IO Value
-getAndTouch_ k e = I.useConnection $
-    I.touch (\_ _ v -> return v) failureIO opGAT k e
-
--- | get value then change expiry. 
--- if error occured, return Nothing.
---
--- @
--- getMaybeAndTouch_ == getAndTouch'_
--- @
-getAndTouch'_, getMaybeAndTouch_
-    :: Key -> Expiry -> I.Connection -> IO (Maybe Value)
-getAndTouch'_ k e = I.useConnection $
-    I.touch (\_ _ v -> return $ Just v) failureMaybe opGAT k e
-getMaybeAndTouch_ = getAndTouch'_

src/Database/Memcached/Binary/Common.hs

@@ -0,0 +1,130 @@
+
+--------------------------------------------------------------------------------
+
+get :: Key -> I.Connection -> IO (HasReturn (Flags, Value))
+get = I.useConnection . I.get (\f v -> successHasReturn (f,v)) failureHasReturn
+
+get_ :: Key -> I.Connection -> IO (HasReturn Value)
+get_ = I.useConnection . I.get (\_ v -> successHasReturn v) failureHasReturn
+
+--------------------------------------------------------------------------------
+
+setAddReplace :: OpCode -> Flags -> Expiry
+              -> Key -> Value -> I.Connection -> IO NoReturn
+setAddReplace op = \f e key value -> I.useConnection $
+    I.setAddReplace successNoReturn failureNoReturn op (CAS 0) key value f e
+
+
+set :: Flags -> Expiry -> Key -> Value -> I.Connection -> IO NoReturn
+set = setAddReplace opSet
+
+add :: Flags -> Expiry -> Key -> Value -> I.Connection -> IO NoReturn
+add = setAddReplace opAdd
+
+replace :: Flags -> Expiry -> Key -> Value -> I.Connection -> IO NoReturn
+replace = setAddReplace opReplace
+
+--------------------------------------------------------------------------------
+
+delete :: Key -> I.Connection -> IO NoReturn
+delete = I.useConnection . I.delete successNoReturn failureNoReturn (CAS 0)
+
+--------------------------------------------------------------------------------
+
+-- | modify value in transaction.
+modify :: Expiry -> Key -> (Flags -> Value -> (Flags, Value, a))
+       -> I.Connection -> IO (HasReturn a)
+modify e key fn = I.useConnection $ \h ->
+    I.getWithCAS (\c f v -> 
+        let (f', v', r) = fn f v
+        in I.setAddReplaceWithCAS (const $ successHasReturn r)
+            failureHasReturn opSet c key v' f' e h
+    ) failureHasReturn key h
+
+-- | modify value in transaction.
+modify_ :: Expiry
+        -> Key -> (Flags -> Value -> (Flags, Value))
+        -> I.Connection -> IO NoReturn
+modify_ e key fn = I.useConnection $ \h ->
+    I.getWithCAS (\c f v -> 
+        let (f', v') = fn f v
+        in I.setAddReplaceWithCAS (const $ successNoReturn)
+            failureNoReturn opSet c key v' f' e h
+    ) failureNoReturn key h
+
+--------------------------------------------------------------------------------
+
+incrDecr :: OpCode -> Expiry
+         -> Key -> Delta -> Initial -> I.Connection -> IO (HasReturn Counter)
+incrDecr op e k d i = I.useConnection $
+    I.incrDecr successHasReturn failureHasReturn op (CAS 0) k d i e
+
+increment :: Expiry -> Key -> Delta -> Initial
+          -> I.Connection -> IO (HasReturn Counter)
+increment = incrDecr opIncrement
+
+decrement :: Expiry -> Key -> Delta -> Initial
+          -> I.Connection -> IO (HasReturn Counter)
+decrement = incrDecr opDecrement
+
+--------------------------------------------------------------------------------
+
+-- | flush all value.
+flushAll :: I.Connection -> IO NoReturn
+flushAll = I.useConnection $ I.flushAll successNoReturn failureNoReturn
+
+--------------------------------------------------------------------------------
+
+version :: I.Connection -> IO (HasReturn Version)
+version = I.useConnection $ I.version (\s -> case readVersion s of
+    Nothing -> failureHasReturn (-1) "version parse failed"
+    Just v  -> successHasReturn v) failureHasReturn
+  where
+    readVersion s0 = do
+        (x, s1) <- S8.readInt s0
+        when (S8.null s1) $ Nothing
+        (y, s2) <- S8.readInt (S8.tail s1)
+        when (S8.null s2) $ Nothing
+        (z, s3) <- S8.readInt (S8.tail s2)
+        unless (S8.null s3) $ Nothing
+        return (Version [x,y,z] [])
+
+
+-- | get version string.
+versionString :: I.Connection -> IO (HasReturn S.ByteString)
+versionString = I.useConnection $ I.version successHasReturn failureHasReturn
+
+--------------------------------------------------------------------------------
+
+-- | noop(use for keepalive).
+noOp :: I.Connection -> IO NoReturn
+noOp = I.useConnection $ I.noOp successNoReturn failureNoReturn
+
+--------------------------------------------------------------------------------
+
+appendPrepend :: OpCode -> Key -> Value -> I.Connection -> IO NoReturn
+appendPrepend o = \k v -> I.useConnection $
+    I.appendPrepend successNoReturn failureNoReturn o (CAS 0) k v
+
+append :: Key -> Value -> I.Connection -> IO NoReturn
+append  = appendPrepend opAppend
+
+prepend :: Key -> Value -> I.Connection -> IO NoReturn
+prepend = appendPrepend opPrepend
+
+--------------------------------------------------------------------------------
+
+-- | change expiry.
+touch :: Expiry -> Key -> I.Connection -> IO NoReturn
+touch e k = I.useConnection $
+    I.touch (\_ _ -> successNoReturn) failureNoReturn opTouch k e
+
+-- | get value/change expiry. 
+getAndTouch :: Expiry -> Key -> I.Connection -> IO (HasReturn (Flags, Value))
+getAndTouch e k = I.useConnection $
+    I.touch (\f v -> successHasReturn (f,v)) failureHasReturn opGAT k e
+
+-- | get value/change expiry. 
+getAndTouch_ :: Expiry -> Key -> I.Connection -> IO (HasReturn Value)
+getAndTouch_ e k = I.useConnection $
+    I.touch (\_ v -> successHasReturn v) failureHasReturn opGAT k e

src/Database/Memcached/Binary/Either.hs

@@ -0,0 +1,29 @@
+{-# LANGUAGE FlexibleInstances #-}
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE NoMonomorphismRestriction #-}
+{-# LANGUAGE CPP #-}
+
+module Database.Memcached.Binary.Either
+#include "Header.txt"
+
+#define NoReturn  (Maybe MemcachedException)
+#define HasReturn Either MemcachedException
+
+successHasReturn :: a -> IO (HasReturn a)
+successHasReturn = return . Right
+{-# INLINE successHasReturn #-}
+
+successNoReturn :: IO NoReturn
+successNoReturn  = return Nothing
+{-# INLINE successNoReturn #-}
+
+failureHasReturn :: I.Failure (HasReturn a)
+failureHasReturn i m = return . Left $ MemcachedException i m
+{-# INLINE failureHasReturn #-}
+
+failureNoReturn :: I.Failure NoReturn
+failureNoReturn i m = return . Just $ MemcachedException i m
+{-# INLINE failureNoReturn #-}
+
+#include "Common.hs"
+

src/Database/Memcached/Binary/Header.txt

@@ -0,0 +1,48 @@
+    ( -- * connection
+      I.Connection, I.withConnection, I.connect, I.close
+      -- * get
+    , get, get_
+      -- * set
+    , set, add,  replace
+      -- * delete
+    , delete
+      -- * increment/decrement
+    , increment,  decrement
+      -- * flush
+    , flushAll
+    -- * version
+    , version, versionString
+    -- * noOp
+    , noOp
+    -- * append/prepend
+    , append,  prepend
+    -- * touch
+    , touch
+    , getAndTouch
+    , getAndTouch_
+
+    -- * modify
+    , modify, modify_
+    -- * reexports
+    , module Database.Memcached.Binary.Types
+    , module Database.Memcached.Binary.Types.Exception
+    -- | def
+    , module Data.Default.Class
+    -- | PortID(..)
+    , module Network
+    ) where
+
+import Network(PortID(..))
+
+import Control.Monad
+
+import Data.Default.Class(def)
+import qualified Data.ByteString as S
+import qualified Data.ByteString.Char8 as S8
+
+import Database.Memcached.Binary.Types
+import Database.Memcached.Binary.Types.Exception
+import Database.Memcached.Binary.Internal.Definition
+import qualified Database.Memcached.Binary.Internal as I
+
+import Data.Version

src/Database/Memcached/Binary/IO.hs

@@ -0,0 +1,31 @@
+{-# LANGUAGE FlexibleInstances #-}
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE NoMonomorphismRestriction #-}
+{-# LANGUAGE CPP #-}
+
+module Database.Memcached.Binary.IO
+#include "Header.txt"
+
+import Control.Exception
+
+#define NoReturn  ()
+#define HasReturn
+
+successHasReturn :: a -> IO (HasReturn a)
+successHasReturn = return
+{-# INLINE successHasReturn #-}
+
+successNoReturn :: IO NoReturn
+successNoReturn  = return ()
+{-# INLINE successNoReturn #-}
+
+failureHasReturn :: I.Failure (HasReturn a)
+failureHasReturn i m = throwIO $ MemcachedException i m
+{-# INLINE failureHasReturn #-}
+
+failureNoReturn :: I.Failure NoReturn
+failureNoReturn i m = throwIO $ MemcachedException i m
+{-# INLINE failureNoReturn #-}
+
+#include "Common.hs"
+

src/Database/Memcached/Binary/Internal.hs

@@ -27,7 +27,7 @@ import qualified Data.ByteString.Lazy as L
 import qualified Data.ByteString.Unsafe as S
 
 import Database.Memcached.Binary.Types
-import Database.Memcached.Binary.Exception
+import Database.Memcached.Binary.Types.Exception
 import Database.Memcached.Binary.Internal.Definition
 
 data Connection
@@ -65,7 +65,7 @@ close (Connection mv) = do
     h <- swapMVar mv (error "connection already closed")
     quit h
     hClose h
-close _ = return ()
+close (ConnectionPool p) = destroyAllResources p
 
 useConnection :: (Handle -> IO a) -> Connection -> IO a
 useConnection f (Connection    mv) = withMVar mv f
@@ -186,34 +186,45 @@ inspectResponse h p = do
     v <- L.hGet h $ fromIntegral tl - fromIntegral el - fromIntegral kl
     return (e,k,v)
 
-getSuccessCallback :: (CAS -> Flags -> Value -> IO a)
+getSuccessCallback :: (Flags -> Value -> IO a)
                    -> Handle -> Ptr Header -> IO a
 getSuccessCallback success h p = do
     elen <- getExtraLength p
     tlen <- getTotalLength p
-    cas  <- getCAS p
     void $ hGetBuf h p 4
     flags <- peekWord32be p
     value <- L.hGet h (fromIntegral tlen - fromIntegral elen)
-    success cas flags value
+    success flags value
 
-get :: (CAS -> Flags -> Value -> IO a) -> Failure a
+get :: (Flags -> Value -> IO a) -> Failure a
     -> Key -> Handle -> IO a
 get success failure key = 
     withRequest opGet key 0 nop 0 nop (CAS 0)
     (getSuccessCallback success) failure
 
-setAddReplace :: (CAS -> IO a) -> Failure a -> OpCode -> CAS
+getWithCAS :: (CAS -> Flags -> Value -> IO a) -> Failure a
+           -> Key -> Handle -> IO a
+getWithCAS success failure key =
+    withRequest opGet key 0 nop 0 nop (CAS 0)
+    (\h p -> getCAS p >>= \c -> getSuccessCallback (success c) h p) failure
+
+setAddReplace :: IO a -> Failure a -> OpCode -> CAS
               -> Key -> Value -> Flags -> Expiry -> Handle -> IO a
 setAddReplace success failure o cas key value flags expiry = withRequest o key
+        8 (\p -> pokeWord32be p flags >> pokeWord32be (plusPtr p 4) expiry) 
+        (fromIntegral $ L.length value) (flip pokeLazyByteString value) cas (\_ _ -> success) failure
+
+setAddReplaceWithCAS :: (CAS -> IO a) -> Failure a -> OpCode -> CAS
+                     -> Key -> Value -> Flags -> Expiry -> Handle -> IO a
+setAddReplaceWithCAS success failure o cas key value flags expiry = withRequest o key
         8 (\p -> pokeWord32be p flags >> pokeWord32be (plusPtr p 4) expiry) 
         (fromIntegral $ L.length value) (flip pokeLazyByteString value) cas (\_ p -> getCAS p >>= success) failure
 
-delete :: (CAS -> IO a) -> Failure a -> CAS -> Key -> Handle -> IO a
+delete :: IO a -> Failure a -> CAS -> Key -> Handle -> IO a
 delete success failure cas key =
-    withRequest opDelete key 0 nop 0 nop cas (\_ p -> getCAS p >>= success) failure
+    withRequest opDelete key 0 nop 0 nop cas (\_ _ -> success) failure
 
-incrDecr :: (CAS -> Word64 -> IO a) -> Failure a -> OpCode -> CAS
+incrDecr :: (Word64 -> IO a) -> Failure a -> OpCode -> CAS
          -> Key -> Delta -> Initial -> Expiry -> Handle -> IO a
 incrDecr success failure op cas key delta initial expiry =
     withRequest op key 20 extra 0 nop cas success' failure
@@ -224,9 +235,8 @@ incrDecr success failure op cas key delta initial expiry =
         pokeWord32be (plusPtr p 16) expiry
 
     success' h p = do
-        c <- getCAS p
         void $ hGetBuf h p 8
-        peekWord64be p >>= success c
+        peekWord64be p >>= success
 
 quit :: Handle -> IO ()
 quit h = do
@@ -251,11 +261,11 @@ version success =
     withRequest opVersion "" 0 nop 0 nop (CAS 0)
     (\h p -> getTotalLength p >>= S.hGet h . fromIntegral >>= success)
 
-appendPrepend :: (CAS -> IO a) -> Failure a -> OpCode -> CAS
+appendPrepend :: IO a -> Failure a -> OpCode -> CAS
               -> Key -> Value -> Handle -> IO a
 appendPrepend success failure op cas key value = withRequest op key 0 nop
     (fromIntegral $ L.length value) (flip pokeLazyByteString value)
-    cas (\_ -> getCAS >=> success) failure
+    cas (\_ _ -> success) failure
 
 stats :: Handle -> IO (H.HashMap S.ByteString S.ByteString)
 stats h = loop H.empty
@@ -277,7 +287,7 @@ verbosity :: IO a -> Failure a -> Word32 -> Handle -> IO a
 verbosity success failure v = withRequest opVerbosity ""
     4 (flip pokeWord32be v) 0 nop (CAS 0) (\_ _ -> success) failure
 
-touch :: (CAS -> Flags -> Value -> IO a) -> Failure a -> OpCode
+touch :: (Flags -> Value -> IO a) -> Failure a -> OpCode
       -> Key -> Expiry -> Handle -> IO a
 touch success failure op key e =
     withRequest op key 4 (flip pokeWord32be e) 0 nop (CAS 0)

src/Database/Memcached/Binary/Maybe.hs

@@ -0,0 +1,28 @@
+{-# LANGUAGE FlexibleInstances #-}
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE NoMonomorphismRestriction #-}
+{-# LANGUAGE CPP #-}
+
+module Database.Memcached.Binary.Maybe
+#include "Header.txt"
+
+#define NoReturn  Bool
+#define HasReturn Maybe
+
+successHasReturn :: a -> IO (HasReturn a)
+successHasReturn = return . Just
+{-# INLINE successHasReturn #-}
+
+successNoReturn :: IO NoReturn
+successNoReturn  = return True
+{-# INLINE successNoReturn #-}
+
+failureHasReturn :: I.Failure (HasReturn a)
+failureHasReturn _ _ = return Nothing
+{-# INLINE failureHasReturn #-}
+
+failureNoReturn :: I.Failure NoReturn
+failureNoReturn _ _ = return False
+{-# INLINE failureNoReturn #-}
+
+#include "Common.hs"

src/Database/Memcached/Binary/Types.hs

@@ -23,6 +23,10 @@ data ConnectInfo = ConnectInfo
     , connectionIdleTime :: NominalDiffTime
     } deriving Show
 
+-- | 
+-- @
+-- def = ConnectInfo "localhost" (PortNumber 11211) [] 1 20
+-- @
 instance Default ConnectInfo where
     def = ConnectInfo "localhost" (PortNumber 11211) [] 1 20
 

src/Database/Memcached/Binary/Types/Exception.hs

@@ -1,7 +1,7 @@
 {-# LANGUAGE DeriveDataTypeable #-}
 {-# LANGUAGE CPP #-}
 
-module Database.Memcached.Binary.Exception where
+module Database.Memcached.Binary.Types.Exception where
 
 import Control.Exception
 import Data.Word

test/test.hs

@@ -0,0 +1,485 @@
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE ScopedTypeVariables #-}
+{-# LANGUAGE DeriveDataTypeable #-}
+{-# LANGUAGE LambdaCase #-}
+
+module Main (main) where
+
+import Network
+import System.Process
+
+import Control.Exception
+import Control.Concurrent
+import Control.Monad
+
+import Data.Default.Class
+import Data.Maybe
+import Data.Word
+import Data.Typeable
+import Data.Version
+import qualified Data.ByteString.Char8 as S
+import qualified Data.ByteString.Lazy.Char8 as L
+
+import Database.Memcached.Binary.Types.Exception
+import Database.Memcached.Binary.IO (Connection, withConnection)
+import qualified Database.Memcached.Binary.IO    as McIO
+import qualified Database.Memcached.Binary.Maybe as McMaybe
+
+import Test.HUnit hiding (Test)
+import Test.Framework
+import Test.Framework.Providers.HUnit
+
+startMemcached :: IO ProcessHandle
+startMemcached = do
+    h <- spawnProcess "memcached" []
+    wait (100 :: Int)
+    return h
+  where
+    wait 0 = fail "cannot start server"
+    wait i = handle (\(_ ::SomeException) -> threadDelay 100000 >> wait (i-1)) $
+        void $ connectTo "localhost" $ PortNumber 11211
+
+precond :: Connection -> IO ()
+precond c = do
+    McIO.flushAll c
+    void $ McIO.set 0 0 "foo" "foovalue"   c
+    void $ McIO.set 1 0 "bar" "1234567890" c
+
+testMc :: TestName -> (Connection -> IO ()) -> Test
+testMc title m = testCase title $ withConnection def (\c -> precond c >> m c)
+
+newtype ByPassException = ByPassException String deriving (Typeable)
+instance Show ByPassException where
+    show (ByPassException s) = s
+
+instance Exception ByPassException
+
+assertException :: Word16 -> S.ByteString -> IO a -> IO ()
+assertException ex msg m =
+    (m >> throwIO (ByPassException "exception not occured.")) `catch`
+    (\e -> case fromException e :: Maybe MemcachedException of
+        Nothing -> assertFn e
+        Just e'@(MemcachedException i _) -> unless (i == ex) (assertFn e'))
+  where
+    assertFn e = assertFailure $ unlines
+        [ "not expected exception occured:"
+        , "expected: " ++ show (MemcachedException ex msg)
+        , "occured:  " ++ show e
+        ]
+
+testGet :: Test
+testGet = testGroup "get"
+    [ testGroup "IO module"
+        [ testGroup "get"
+            [ doTest "foo" (0, "foovalue")   McIO.get
+            , doTest "bar" (1, "1234567890") McIO.get
+            , doTestException "notexist"     McIO.get
+            ]
+        , testGroup "get_"
+            [ doTest "foo" "foovalue"    McIO.get_
+            , doTest "bar" "1234567890"  McIO.get_
+            , doTestException "notexist" McIO.get_
+            ]
+        ]
+    , testGroup "Maybe module"
+        [ testGroup "get"
+            [ doTest "foo"      (Just (0, "foovalue"))   McMaybe.get
+            , doTest "bar"      (Just (1, "1234567890")) McMaybe.get
+            , doTest "notexist" Nothing                  McMaybe.get
+            ]
+         , testGroup "get_"
+            [ doTest "foo"      (Just "foovalue")   McMaybe.get_
+            , doTest "bar"      (Just "1234567890") McMaybe.get_
+            , doTest "notexist" Nothing             McMaybe.get_
+            ]
+        ]
+    ]
+  where
+    doTest key ex fn = testMc (S.unpack key) $ \c -> do
+        v <- fn key c
+        v @?= ex
+    doTestException key fn = testMc (S.unpack key) $ \c ->
+        assertException 1 "Not found" $ fn key c
+
+testSetAddReplace :: Test
+testSetAddReplace = testGroup "set/add/replace"
+    [ testGroup "set"
+        [ testMc "set foo to foomod" $ \c -> do
+            McIO.set 100 0 "foo" "foomod" c
+            v <- McIO.get "foo" c
+            v @?= (100, "foomod")
+        , testMc "set notexist to exist" $ \c -> do
+            McIO.set 100 0 "notexist" "exist" c
+            v <- McIO.get "notexist" c
+            v @?= (100, "exist")
+        ]
+    , testGroup "add"
+        [ testMc "add foo to foomod" $ \c ->
+            assertException 2 "Data exists for key." $
+                McIO.add 100 0 "foo" "foomod" c
+        , testMc "add notexist to exist" $ \c -> do
+            McIO.add 100 0 "notexist" "exist" c
+            v <- McIO.get "notexist" c
+            v @?= (100, "exist")
+        ]
+    , testGroup "replace"
+        [ testMc "set foo to foomod" $ \c -> do
+            McIO.replace 100 0 "foo" "foomod" c
+            v <- McIO.get "foo" c
+            v @?= (100, "foomod")
+        , testMc "set notexist to exist" $ \c ->
+            assertException 1 "Not found" $
+                McIO.replace 100 0 "notexist" "exist" c
+        ]
+    ]
+
+testDelete :: Test
+testDelete = testGroup "delete"
+    [ testGroup "IO module"
+        [ testMc "foo" $ \c -> do
+            McIO.delete "foo" c
+            r <- McMaybe.get "foo" c
+            r @?= Nothing
+        , testMc "notexist" $ \c ->
+            assertException 1 "Not found" $ McIO.delete "notexist" c
+        ]
+    , testGroup "Maybe module"
+        [ testMc "foo" $ \c -> do
+            b <- McMaybe.delete "foo" c
+            r <- McMaybe.get "foo" c
+            b @?= True
+            r @?= Nothing
+        , testMc "notexist" $ \c -> do
+            b <- McMaybe.delete "notexist" c
+            r <- McMaybe.get    "notexist" c
+            b @?= False
+            r @?= Nothing
+        ]
+    ]
+
+-- https://code.google.com/p/memcached/wiki/ReleaseNotes1417
+testIncrDecr :: Version -> Test
+testIncrDecr v = testGroup "increment/decrement"
+    [ testGroup "IO module"
+        [ testGroup "increment"
+            [ testMc "foo" $ \c ->
+                assertException 6 "Non-numeric server-side value for incr or decr" $
+                    McIO.increment 0 "foo" 10 10 c
+            , testMc "bar" $ \c -> do
+                a <- McIO.increment 0 "bar" 10 10 c
+                b <- McIO.get_ "bar" c
+                a @?= 1234567900
+                b @?= "1234567900"
+            , testMc "notexist" $ \c -> do
+                a <- McIO.increment 0 "notexist" 10 10 c
+                b <- McIO.get_ "notexist" c
+                a @?= 10
+                when (v >= ev) $ b @?= "10"
+            ]
+        , testGroup "decrement"
+            [ testMc "foo" $ \c ->
+                assertException 6 "Non-numeric server-side value for incr or decr" $
+                    McIO.decrement 0 "foo" 10 10 c
+            , testMc "bar" $ \c -> do
+                a <- McIO.decrement 0 "bar" 10 10 c
+                b <- McIO.get_ "bar" c
+                a @?= 1234567880
+                b @?= "1234567880"
+            , testMc "notexist" $ \c -> do
+                a <- McIO.decrement 0 "notexist" 10 10 c
+                b <- McIO.get_ "notexist" c
+                a @?= 10
+                when (v >= ev) $ b @?= "10"
+            ]
+        ]
+    , testGroup "Maybe module"
+        [ testGroup "increment"
+            [ testMc "foo" $ \c -> do
+                r <- McMaybe.increment 0 "foo" 10 10 c
+                b <- McIO.get_ "foo" c
+                r @?= Nothing
+                b @?= "foovalue"
+            , testMc "bar" $ \c -> do
+                a <- McMaybe.increment 0 "bar" 10 10 c
+                b <- McIO.get_ "bar" c
+                a @?= Just 1234567900
+                b @?= "1234567900"
+            , testMc "notexist" $ \c -> do
+                a <- McMaybe.increment 0 "notexist" 10 10 c
+                b <- McIO.get_ "notexist" c
+                a @?= Just 10
+                when (v >= ev) $ b @?= "10"
+            ]
+        , testGroup "decrement'"
+            [ testMc "foo" $ \c -> do
+                r <- McMaybe.decrement 0 "foo" 10 10 c
+                b <- McIO.get_ "foo" c
+                r @?= Nothing
+                b @?= "foovalue"
+            , testMc "bar" $ \c -> do
+                a <- McMaybe.decrement 0 "bar" 10 10 c
+                b <- McIO.get_ "bar" c
+                a @?= Just 1234567880
+                b @?= "1234567880"
+            , testMc "notexist" $ \c -> do
+                a <- McMaybe.decrement 0 "notexist" 10 10 c
+                b <- McIO.get_ "notexist" c
+                a @?= Just 10
+                when (v >= ev) $ b @?= "10"
+            ]
+        ]
+    ]
+  where
+    ev = Version [1,4,17] []
+
+testFlush :: Test
+testFlush = testGroup "flush"
+    [ testGroup "IO module"
+        [ testMc "flushAll" $ \c -> do
+            McIO.flushAll c
+            a <- McMaybe.get "foo" c
+            a @?= Nothing
+        ]
+    , testGroup "Maybe module"
+        [ testMc "flushAll" $ \c -> do
+            r <- McMaybe.flushAll c
+            a <- McMaybe.get "foo" c
+            r @?= True
+            a @?= Nothing
+        ]
+    ]
+
+testVersion :: Test
+testVersion = testGroup "version"
+    [ testGroup "versionString"
+        [ testMc "IO module" $ \c -> do
+            v <- McIO.versionString c
+            assertBool (show v ++ " is not version like.") $ isVersionLike v
+        , testMc "Maybe module" $ \c -> do
+            Just v <- McMaybe.versionString c
+            assertBool (show v ++ " is not version like.") $ isVersionLike v
+        ]
+    , testGroup "version"
+        [ testMc "IO module" $ \c -> do
+            v <- McIO.version c
+            assertEqual "version branch length" 3 (length $ versionBranch v)
+        ]
+    ]
+  where
+    isVersionLike s0 = isJust $ do
+        (_, s1) <- S.readInt s0
+        unless (S.head s1 == '.') Nothing
+        (_, s2) <- S.readInt (S.tail s1)
+        unless (S.head s2 == '.') Nothing
+        (_, s3) <- S.readInt (S.tail s2)
+        unless (S.null s3) Nothing
+
+testNoOp :: Test
+testNoOp = testGroup "noOp"
+    [ testMc "IO module" McIO.noOp
+    , testMc "Maybe module" $ \c -> do
+        b <- McMaybe.noOp c
+        b @?= True
+    ]
+
+testAppendPrepend :: Test
+testAppendPrepend = testGroup "append/prepend"
+    [ testGroup "IO module"
+        [ testGroup "append"
+            [ testMc "foo" $ \c -> do
+                McIO.append "foo" "!!" c
+                a <- McIO.get_ "foo" c
+                a @?= "foovalue!!"
+            , testMc "bar" $ \c -> do
+                McIO.append "bar" "!!" c
+                a <- McIO.get_ "bar" c
+                a @?= "1234567890!!"
+            , testMc "notexist" $ \c ->
+                assertException 5 "Not stored." $ McIO.append "notexist" "!!" c
+            ]
+        , testGroup "prepend"
+            [ testMc "foo" $ \c -> do
+                McIO.prepend "foo" "!!" c
+                a <- McIO.get_ "foo" c
+                a @?= "!!foovalue"
+            , testMc "bar" $ \c -> do
+                McIO.prepend "bar" "!!" c
+                a <- McIO.get_ "bar" c
+                a @?= "!!1234567890"
+            , testMc "notexist" $ \c ->
+                assertException 5 "Not stored." $ McIO.prepend "notexist" "!!" c
+            ]
+        ]
+    , testGroup "maybe module"
+        [ testGroup "append'"
+            [ testMc "foo" $ \c -> do
+                b <- McMaybe.append "foo" "!!" c
+                a <- McIO.get_ "foo" c
+                b @?= True
+                a @?= "foovalue!!"
+            , testMc "bar" $ \c -> do
+                b <- McMaybe.append "bar" "!!" c
+                a <- McIO.get_ "bar" c
+                b @?= True
+                a @?= "1234567890!!"
+            , testMc "notexist" $ \c -> do
+                b <- McMaybe.append "notexist" "!!" c
+                b @?= False
+            ]
+        , testGroup "prepend'"
+            [ testMc "foo" $ \c -> do
+                b <- McMaybe.prepend "foo" "!!" c
+                a <- McIO.get_ "foo" c
+                b @?= True
+                a @?= "!!foovalue"
+            , testMc "bar" $ \c -> do
+                b <- McMaybe.prepend "bar" "!!" c
+                a <- McIO.get_ "bar" c
+                b @?= True
+                a @?= "!!1234567890"
+            , testMc "notexist" $ \c -> do
+                b <- McMaybe.prepend "notexist" "!!" c
+                b @?= False
+            ]
+        ]
+    ]
+
+-- https://code.google.com/p/memcached/wiki/ReleaseNotes1414
+-- https://code.google.com/p/memcached/issues/detail?id=275
+testTouchGAT :: Version -> Test
+testTouchGAT v = testGroup "touch/GAT"
+    [ testGroup "IO module"
+        [ testGroup "touch"
+            [ testMc "foo" $ \c -> do
+                a <- McMaybe.get_ "foo" c
+                McIO.touch 1 "foo" c
+                a @?= (Just "foovalue")
+                when (v >= ev) $ do
+                    threadDelay 1100000
+                    b <- McMaybe.get_ "foo" c
+                    b @?= Nothing
+            , testMc "notexist" $ \c ->
+                assertException 1 "Not found" $ McIO.touch 1 "notexist" c
+            ]
+        , testGroup "getAndTouch"
+            [ testMc "foo" $ \c -> do
+                x <- McMaybe.get "foo" c
+                y <- McIO.getAndTouch 1 "foo" c
+                x @?= Just (0, "foovalue")
+                y @?= (0, "foovalue")
+                when (v >= ev) $ do
+                    threadDelay 1100000
+                    z <- McMaybe.get "foo" c
+                    z @?= Nothing
+            , testMc "notexist" $ \c ->
+                assertException 1 "Not found" $ McIO.getAndTouch 1 "notexist" c
+            ]
+        , testGroup "getAndTouch_"
+            [ testMc "foo" $ \c -> do
+                x <- McMaybe.get_ "foo" c
+                y <- McIO.getAndTouch_ 1 "foo" c
+                x @?= Just "foovalue"
+                y @?=      "foovalue"
+                when (v >= ev) $ do
+                    threadDelay 1100000
+                    z <- McMaybe.get_ "foo" c
+                    z @?= Nothing
+            , testMc "notexist" $ \c ->
+                assertException 1 "Not found" $ McIO.getAndTouch_ 1 "notexist" c
+            ]
+        ]
+    , testGroup "Maybe module"
+        [ testGroup "touch"
+            [ testMc "foo" $ \c -> do
+                a <- McMaybe.get_ "foo" c
+                r <- McMaybe.touch 1 "foo" c
+                a @?= (Just "foovalue")
+                r @?= True
+                when (v >= ev) $ do
+                    threadDelay 1100000
+                    b <- McMaybe.get_ "foo" c
+                    b @?= Nothing
+            , testMc "notexist" $ \c -> do
+                r <- McMaybe.touch 1 "notexist" c
+                a <- McMaybe.get "notexist" c
+                r @?= False
+                a @?= Nothing
+            ]
+        , testGroup "getAndTouch'/getMaybeAndTouch"
+            [ testMc "foo" $ \c -> do
+                a <- McMaybe.get "foo" c
+                r <- McMaybe.getAndTouch 1 "foo" c
+                a @?= Just (0, "foovalue")
+                r @?= Just (0, "foovalue")
+                when (v >= ev) $ do
+                    threadDelay 1100000
+                    b <- McMaybe.get_ "foo" c
+                    b @?= Nothing
+            , testMc "notexist" $ \c -> do
+                r <- McMaybe.getAndTouch 1 "notexist" c
+                a <- McMaybe.get "notexist" c
+                r @?= Nothing
+                a @?= Nothing
+            ]
+        , testGroup "getAndTouch'_/getMaybeAndTouch_"
+            [ testMc "foo" $ \c -> do
+                a <- McMaybe.get_ "foo" c
+                r <- McMaybe.getAndTouch_ 1 "foo" c
+                a @?= Just "foovalue"
+                r @?= Just "foovalue"
+                when (v >= ev) $ do
+                    threadDelay 1100000
+                    b <- McMaybe.get_ "foo" c
+                    b @?= Nothing
+            , testMc "notexist" $ \c -> do
+                r <- McMaybe.getAndTouch_ 1 "notexist" c
+                a <- McMaybe.get "notexist" c
+                r @?= Nothing
+                a @?= Nothing
+            ]
+        ]
+    ]
+  where
+    ev = Version [1,4,14] []
+
+testModify :: Test
+testModify = testGroup "modify"
+    [ testMc "reverse foo" $ \c -> do
+        r <- McIO.modify 0 "foo" (\f v -> (f + 100, L.reverse v, v)) c
+        a <- McMaybe.get "foo" c
+        r @?= "foovalue"
+        a @?= Just (100, "eulavoof")
+    , testMc "notexist" $ \c ->
+        assertException 1 "Not found" $
+            McIO.modify 0 "notexist" (\f v -> (f,v,())) c
+    ]
+
+testModify_ :: Test
+testModify_ = testGroup "modify_"
+    [ testMc "reverse foo" $ \c -> do
+        McIO.modify_ 0 "foo" (\f v -> (f + 100, L.reverse v)) c
+        a <- McMaybe.get "foo" c
+        a @?= Just (100, "eulavoof")
+    , testMc "notexist" $ \c ->
+        assertException 1 "Not found" $
+            McIO.modify_ 0 "notexist" (\f v -> (f,v)) c
+    ]
+
+
+
+main :: IO ()
+main = bracket startMemcached terminateProcess $ \_ -> do
+    v <- McIO.withConnection def McIO.version
+    defaultMain
+        [ testGet
+        , testSetAddReplace
+        , testDelete
+        , testIncrDecr v
+        , testFlush
+        , testVersion
+        , testNoOp
+        , testAppendPrepend
+        , testTouchGAT v
+        , testModify
+        , testModify_
+        ]