diff --git a/src/Database/Memcached/Binary/Common.hs b/src/Database/Memcached/Binary/Common.hs index 6be0744..b7f6c1d 100644 --- a/src/Database/Memcached/Binary/Common.hs +++ b/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) -version = I.useConnection $ I.version successHasReturn failureHasReturn +versionString :: I.Connection -> IO (HasReturn S.ByteString) +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 diff --git a/src/Database/Memcached/Binary/Either.hs b/src/Database/Memcached/Binary/Either.hs index 348d7d1..12e0eea 100644 --- a/src/Database/Memcached/Binary/Either.hs +++ b/src/Database/Memcached/Binary/Either.hs @@ -1,4 +1,5 @@ {-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE NoMonomorphismRestriction #-} {-# LANGUAGE CPP #-} diff --git a/src/Database/Memcached/Binary/Header.txt b/src/Database/Memcached/Binary/Header.txt index db25492..d105824 100644 --- a/src/Database/Memcached/Binary/Header.txt +++ b/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 diff --git a/src/Database/Memcached/Binary/IO.hs b/src/Database/Memcached/Binary/IO.hs index b9055a0..451ca18 100644 --- a/src/Database/Memcached/Binary/IO.hs +++ b/src/Database/Memcached/Binary/IO.hs @@ -1,4 +1,5 @@ {-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE NoMonomorphismRestriction #-} {-# LANGUAGE CPP #-} diff --git a/src/Database/Memcached/Binary/Internal.hs b/src/Database/Memcached/Binary/Internal.hs index 2554d42..4741e31 100644 --- a/src/Database/Memcached/Binary/Internal.hs +++ b/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) diff --git a/src/Database/Memcached/Binary/Maybe.hs b/src/Database/Memcached/Binary/Maybe.hs index 8571348..f9b2856 100644 --- a/src/Database/Memcached/Binary/Maybe.hs +++ b/src/Database/Memcached/Binary/Maybe.hs @@ -1,4 +1,5 @@ {-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE NoMonomorphismRestriction #-} {-# LANGUAGE CPP #-} diff --git a/test/test.hs b/test/test.hs index c48cc4d..8e154cd 100644 --- a/test/test.hs +++ b/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 -testIncrDecr = testGroup "increment/decrement" +-- https://code.google.com/p/memcached/wiki/ReleaseNotes1417 +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 - v <- McIO.version c - assertBool (show v ++ " is not version like.") $ isVersionLike v - , testMc "Maybe module" $ \c -> do - Just v <- McMaybe.version c - assertBool (show v ++ " is not version like.") $ isVersionLike v + [ 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 @@ -333,17 +344,20 @@ testAppendPrepend = testGroup "append/prepend" ] ] -testTouchGAT :: Test -testTouchGAT = testGroup "touch/GAT" +-- 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 - 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 - [ testGet - , testSetAddReplace - , testDelete - , testIncrDecr - , testFlush - , testVersion - , testNoOp - , testAppendPrepend - , testTouchGAT - , testModify - , testModify_ - ] +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_ + ]