remove unused CAS read, version return Data.Version. test version restriction.

src/Database/Memcached/Binary/Common.hs

@@ -2,17 +2,17 @@
 --------------------------------------------------------------------------------
 
 get :: Key -> I.Connection -> IO (HasReturn (Flags, Value))
-get = I.useConnection . I.get (\_ f v -> successHasReturn (f,v)) failureHasReturn
+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
+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 (const $ successNoReturn) failureNoReturn op (CAS 0) key value f e
+    I.setAddReplace successNoReturn failureNoReturn op (CAS 0) key value f e
 
 
 set :: Flags -> Expiry -> Key -> Value -> I.Connection -> IO NoReturn
@@ -27,7 +27,7 @@ replace = setAddReplace opReplace
 --------------------------------------------------------------------------------
 
 delete :: Key -> I.Connection -> IO NoReturn
-delete = I.useConnection . I.delete (\_ -> successNoReturn) failureNoReturn (CAS 0)
+delete = I.useConnection . I.delete successNoReturn failureNoReturn (CAS 0)
 
 --------------------------------------------------------------------------------
 
@@ -35,9 +35,9 @@ delete = I.useConnection . I.delete (\_ -> successNoReturn) failureNoReturn (CAS
 modify :: Expiry -> Key -> (Flags -> Value -> (Flags, Value, a))
        -> I.Connection -> IO (HasReturn a)
 modify e key fn = I.useConnection $ \h ->
-    I.get (\c f v -> 
+    I.getWithCAS (\c f v -> 
         let (f', v', r) = fn f v
-        in I.setAddReplace (const $ successHasReturn r)
+        in I.setAddReplaceWithCAS (const $ successHasReturn r)
             failureHasReturn opSet c key v' f' e h
     ) failureHasReturn key h
 
@@ -46,9 +46,9 @@ modify_ :: Expiry
         -> Key -> (Flags -> Value -> (Flags, Value))
         -> I.Connection -> IO NoReturn
 modify_ e key fn = I.useConnection $ \h ->
-    I.get (\c f v -> 
+    I.getWithCAS (\c f v -> 
         let (f', v') = fn f v
-        in I.setAddReplace (const $ successNoReturn)
+        in I.setAddReplaceWithCAS (const $ successNoReturn)
             failureNoReturn opSet c key v' f' e h
     ) failureNoReturn key h
 
@@ -57,8 +57,7 @@ modify_ e key fn = I.useConnection $ \h ->
 incrDecr :: OpCode -> Expiry
          -> Key -> Delta -> Initial -> I.Connection -> IO (HasReturn Counter)
 incrDecr op e k d i = I.useConnection $
-    I.incrDecr (\_ w -> successHasReturn w) failureHasReturn op (CAS 0) k d i e
+    I.incrDecr successHasReturn failureHasReturn op (CAS 0) k d i e
-
 
 increment :: Expiry -> Key -> Delta -> Initial
           -> I.Connection -> IO (HasReturn Counter)
@@ -76,9 +75,24 @@ 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.
-version :: I.Connection -> IO (HasReturn S.ByteString)
+versionString :: I.Connection -> IO (HasReturn S.ByteString)
-version = I.useConnection $ I.version successHasReturn failureHasReturn
+versionString = I.useConnection $ I.version successHasReturn failureHasReturn
 
 --------------------------------------------------------------------------------
 
@@ -90,7 +104,7 @@ 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
+    I.appendPrepend successNoReturn failureNoReturn o (CAS 0) k v
 
 append :: Key -> Value -> I.Connection -> IO NoReturn
 append  = appendPrepend opAppend
@@ -103,14 +117,14 @@ prepend = appendPrepend opPrepend
 -- | change expiry.
 touch :: Expiry -> Key -> I.Connection -> IO NoReturn
 touch e k = I.useConnection $
-    I.touch (\_ _ _ -> successNoReturn) failureNoReturn opTouch k e
+    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
+    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
+    I.touch (\_ v -> successHasReturn v) failureHasReturn opGAT k e

src/Database/Memcached/Binary/Either.hs

@@ -1,4 +1,5 @@
 {-# LANGUAGE FlexibleInstances #-}
+{-# LANGUAGE OverloadedStrings #-}
 {-# LANGUAGE NoMonomorphismRestriction #-}
 {-# LANGUAGE CPP #-}
 

src/Database/Memcached/Binary/Header.txt

@@ -11,7 +11,7 @@
       -- * flush
     , flushAll
     -- * version
-    , version
+    , version, versionString
     -- * noOp
     , noOp
     -- * append/prepend
@@ -34,13 +34,15 @@
 
 import Network(PortID(..))
 
-import Data.Default.Class(def)
+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

@@ -1,4 +1,5 @@
 {-# LANGUAGE FlexibleInstances #-}
+{-# LANGUAGE OverloadedStrings #-}
 {-# LANGUAGE NoMonomorphismRestriction #-}
 {-# LANGUAGE CPP #-}
 

src/Database/Memcached/Binary/Internal.hs

@@ -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

@@ -1,4 +1,5 @@
 {-# LANGUAGE FlexibleInstances #-}
+{-# LANGUAGE OverloadedStrings #-}
 {-# LANGUAGE NoMonomorphismRestriction #-}
 {-# LANGUAGE CPP #-}
 

test/test.hs

@@ -16,6 +16,7 @@ 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
 
@@ -156,8 +157,9 @@ testDelete = testGroup "delete"
         ]
     ]
 
-testIncrDecr :: Test
+-- https://code.google.com/p/memcached/wiki/ReleaseNotes1417
-testIncrDecr = testGroup "increment/decrement"
+testIncrDecr :: Version -> Test
+testIncrDecr v = testGroup "increment/decrement"
     [ testGroup "IO module"
         [ testGroup "increment"
             [ testMc "foo" $ \c ->
@@ -172,7 +174,7 @@ testIncrDecr = testGroup "increment/decrement"
                 a <- McIO.increment 0 "notexist" 10 10 c
                 b <- McIO.get_ "notexist" c
                 a @?= 10
-                b @?= "10"
+                when (v >= ev) $ b @?= "10"
             ]
         , testGroup "decrement"
             [ testMc "foo" $ \c ->
@@ -187,7 +189,7 @@ testIncrDecr = testGroup "increment/decrement"
                 a <- McIO.decrement 0 "notexist" 10 10 c
                 b <- McIO.get_ "notexist" c
                 a @?= 10
-                b @?= "10"
+                when (v >= ev) $ b @?= "10"
             ]
         ]
     , testGroup "Maybe module"
@@ -206,7 +208,7 @@ testIncrDecr = testGroup "increment/decrement"
                 a <- McMaybe.increment 0 "notexist" 10 10 c
                 b <- McIO.get_ "notexist" c
                 a @?= Just 10
-                b @?= "10"
+                when (v >= ev) $ b @?= "10"
             ]
         , testGroup "decrement'"
             [ testMc "foo" $ \c -> do
@@ -223,10 +225,12 @@ testIncrDecr = testGroup "increment/decrement"
                 a <- McMaybe.decrement 0 "notexist" 10 10 c
                 b <- McIO.get_ "notexist" c
                 a @?= Just 10
-                b @?= "10"
+                when (v >= ev) $ b @?= "10"
             ]
         ]
     ]
+  where
+    ev = Version [1,4,17] []
 
 testFlush :: Test
 testFlush = testGroup "flush"
@@ -247,12 +251,19 @@ testFlush = testGroup "flush"
 
 testVersion :: Test
 testVersion = testGroup "version"
-    [ testMc "IO module" $ \c -> do
+    [ testGroup "versionString"
-        v <- McIO.version c
+        [ testMc "IO module" $ \c -> do
-        assertBool (show v ++ " is not version like.") $ isVersionLike v
+            v <- McIO.versionString c
-    , testMc "Maybe module" $ \c -> do
+            assertBool (show v ++ " is not version like.") $ isVersionLike v
-        Just v <- McMaybe.version c
+        , testMc "Maybe module" $ \c -> do
-        assertBool (show v ++ " is not version like.") $ isVersionLike v
+            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
@@ -333,17 +344,20 @@ testAppendPrepend = testGroup "append/prepend"
         ]
     ]
 
-testTouchGAT :: Test
+-- https://code.google.com/p/memcached/wiki/ReleaseNotes1414
-testTouchGAT = testGroup "touch/GAT"
+-- 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
-                threadDelay 1100000
-                b <- McMaybe.get_ "foo" c
                 a @?= (Just "foovalue")
-                b @?= Nothing
+                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
             ]
@@ -351,11 +365,12 @@ testTouchGAT = testGroup "touch/GAT"
             [ testMc "foo" $ \c -> do
                 x <- McMaybe.get "foo" c
                 y <- McIO.getAndTouch 1 "foo" c
-                threadDelay 1100000
-                z <- McMaybe.get "foo" c
                 x @?= Just (0, "foovalue")
                 y @?= (0, "foovalue")
-                z @?= Nothing
+                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
             ]
@@ -363,11 +378,12 @@ testTouchGAT = testGroup "touch/GAT"
             [ testMc "foo" $ \c -> do
                 x <- McMaybe.get_ "foo" c
                 y <- McIO.getAndTouch_ 1 "foo" c
-                threadDelay 1100000
-                z <- McMaybe.get_ "foo" c
                 x @?= Just "foovalue"
                 y @?=      "foovalue"
-                z @?= Nothing
+                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
             ]
@@ -377,11 +393,12 @@ testTouchGAT = testGroup "touch/GAT"
             [ testMc "foo" $ \c -> do
                 a <- McMaybe.get_ "foo" c
                 r <- McMaybe.touch 1 "foo" c
-                threadDelay 1100000
-                b <- McMaybe.get_ "foo" c
                 a @?= (Just "foovalue")
                 r @?= True
-                b @?= Nothing
+                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
@@ -392,11 +409,12 @@ testTouchGAT = testGroup "touch/GAT"
             [ testMc "foo" $ \c -> do
                 a <- McMaybe.get "foo" c
                 r <- McMaybe.getAndTouch 1 "foo" c
-                threadDelay 1100000
-                b <- McMaybe.get_ "foo" c
                 a @?= Just (0, "foovalue")
                 r @?= Just (0, "foovalue")
-                b @?= Nothing
+                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
@@ -407,11 +425,12 @@ testTouchGAT = testGroup "touch/GAT"
             [ testMc "foo" $ \c -> do
                 a <- McMaybe.get_ "foo" c
                 r <- McMaybe.getAndTouch_ 1 "foo" c
-                threadDelay 1100000
-                b <- McMaybe.get_ "foo" c
                 a @?= Just "foovalue"
                 r @?= Just "foovalue"
-                b @?= Nothing
+                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
@@ -420,6 +439,8 @@ testTouchGAT = testGroup "touch/GAT"
             ]
         ]
     ]
+  where
+    ev = Version [1,4,14] []
 
 testModify :: Test
 testModify = testGroup "modify"
@@ -444,17 +465,21 @@ testModify_ = testGroup "modify_"
             McIO.modify_ 0 "notexist" (\f v -> (f,v)) c
     ]
 
+
+
 main :: IO ()
-main = bracket startMemcached terminateProcess $ \_ -> defaultMain
+main = bracket startMemcached terminateProcess $ \_ -> do
-    [ testGet
+    v <- McIO.withConnection def McIO.version
-    , testSetAddReplace
+    defaultMain
-    , testDelete
+        [ testGet
-    , testIncrDecr
+        , testSetAddReplace
-    , testFlush
+        , testDelete
-    , testVersion
+        , testIncrDecr v
-    , testNoOp
+        , testFlush
-    , testAppendPrepend
+        , testVersion
-    , testTouchGAT
+        , testNoOp
-    , testModify
+        , testAppendPrepend
-    , testModify_
+        , testTouchGAT v
-    ]
+        , testModify
+        , testModify_
+        ]