haskell/memcached-binary
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

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

Browse Source
This commit is contained in:
philopon 2014-08-27 05:44:56 +09:00
parent defb311789
commit 2edf80c0c5
7 changed files with 131 additions and 77 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

46
src/Database/Memcached/Binary/Common.hs
View File

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

1
src/Database/Memcached/Binary/Either.hs
View File

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

8
src/Database/Memcached/Binary/Header.txt
View File

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

1
src/Database/Memcached/Binary/IO.hs
View File

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

36
src/Database/Memcached/Binary/Internal.hs
View File

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

1
src/Database/Memcached/Binary/Maybe.hs
View File

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

115
test/test.hs
View File

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