Compare commits

...

9 Commits

Author SHA1 Message Date
philopon
42295c38b9 container travis 2015-08-31 00:50:44 +09:00
philopon
09ecd54191 relax version restriction for hspec-2.2(fpco/stackage#765) and HUnit-1.3(fpco/stackage#768) 2015-08-27 01:56:22 +09:00
philopon
fe7a32cb2b hspec-2.2/HUnit-1.3 2015-08-27 01:41:49 +09:00
philopon
f7dc96c415 multi-ghc-travis 2015-06-09 16:23:53 +09:00
philopon
44c6d2e0c6 ghc-7.10 2015-03-25 03:26:06 +09:00
philopon
62bab4edc8 split client exception. 2014-09-11 22:58:26 +09:00
philopon
a03a17e483 relax network version. 2014-09-08 02:57:24 +09:00
philopon
53b5a31b8b change testframework to hspec. 2014-09-06 03:17:01 +09:00
philopon
d2ae2c6c17 remove debug print. 2014-08-27 14:36:04 +09:00
9 changed files with 330 additions and 307 deletions

View File

@ -1,4 +1,18 @@
language: haskell language: c
ghc:
- 7.8 sudo: false
- 7.6
matrix:
include:
- env: CABALVER=1.18 GHCVER=7.6.3
addons: {apt: {packages: [cabal-install-1.18,ghc-7.6.3], sources: [hvr-ghc]}}
- env: CABALVER=1.18 GHCVER=7.8.4
addons: {apt: {packages: [cabal-install-1.18,ghc-7.8.4], sources: [hvr-ghc]}}
- env: CABALVER=1.22 GHCVER=7.10.2
addons: {apt: {packages: [cabal-install-1.22,ghc-7.10.2], sources: [hvr-ghc]}}
before_install:
- export PATH=/opt/ghc/$GHCVER/bin:/opt/cabal/$CABALVER/bin:$PATH
install: cabal update && cabal install --only-dependencies --enable-tests
script: cabal configure --enable-tests && cabal build && cabal test

View File

@ -1,5 +1,5 @@
name: memcached-binary name: memcached-binary
version: 0.1.1 version: 0.2.0
synopsis: memcached client using binary protocol. synopsis: memcached client using binary protocol.
description: memcached client using binary protocol. description: memcached client using binary protocol.
license: MIT license: MIT
@ -8,7 +8,7 @@ author: HirotomoMoriwaki<philopon.dependence@gmail.com>
maintainer: HirotomoMoriwaki<philopon.dependence@gmail.com> maintainer: HirotomoMoriwaki<philopon.dependence@gmail.com>
Homepage: https://github.com/philopon/memcached-binary Homepage: https://github.com/philopon/memcached-binary
Bug-reports: https://github.com/philopon/memcached-binary/issues Bug-reports: https://github.com/philopon/memcached-binary/issues
copyright: (c) 2014 Hirotomo Moriwaki copyright: (c) 2014-2015 Hirotomo Moriwaki
category: Database category: Database
build-type: Simple build-type: Simple
cabal-version: >=1.10 cabal-version: >=1.10
@ -25,14 +25,14 @@ library
Database.Memcached.Binary.Types.Exception Database.Memcached.Binary.Types.Exception
other-modules: Database.Memcached.Binary.Internal other-modules: Database.Memcached.Binary.Internal
Database.Memcached.Binary.Internal.Definition Database.Memcached.Binary.Internal.Definition
build-depends: base >=4.6 && <4.8 build-depends: base >=4.6 && <4.9
, bytestring >=0.10 && <0.11 , bytestring >=0.10 && <0.11
, network >=2.6 && <2.7 , network >=2.5 && <2.7
, storable-endian >=0.2 && <0.3 , storable-endian >=0.2 && <0.3
, data-default-class >=0.0 && <0.1 , data-default-class >=0.0 && <0.1
, resource-pool >=0.2 && <0.3 , resource-pool >=0.2 && <0.3
, unordered-containers >=0.2 && <0.3 , unordered-containers >=0.2 && <0.3
, time >=1.4 && <1.5 , time >=1.4 && <1.6
ghc-options: -Wall -O2 ghc-options: -Wall -O2
hs-source-dirs: src hs-source-dirs: src
default-language: Haskell2010 default-language: Haskell2010
@ -42,13 +42,12 @@ test-suite test
hs-source-dirs: test hs-source-dirs: test
main-is: test.hs main-is: test.hs
ghc-options: -Wall -O2 ghc-options: -Wall -O2
build-depends: base >=4.6 && <4.8 build-depends: base
, hspec >=2.1 && <2.3
, memcached-binary , memcached-binary
, test-framework >=0.8 && <0.9
, test-framework-hunit >=0.3 && <0.4
, process >=1.2 && <1.3 , process >=1.2 && <1.3
, network >=2.6 && <2.7 , network >=2.5 && <2.7
, HUnit >=1.2 && <1.3 , HUnit >=1.2 && <1.4
, data-default-class >=0.0 && <0.1 , data-default-class
, bytestring >=0.10 && <0.11 , bytestring
default-language: Haskell2010 default-language: Haskell2010

View File

@ -77,7 +77,7 @@ flushAll = I.useConnection $ I.flushAll successNoReturn failureNoReturn
version :: I.Connection -> IO (HasReturn Version) version :: I.Connection -> IO (HasReturn Version)
version = I.useConnection $ I.version (\s -> case readVersion s of version = I.useConnection $ I.version (\s -> case readVersion s of
Nothing -> failureHasReturn (-1) "version parse failed" Nothing -> failureHasReturn VersionParseFailed
Just v -> successHasReturn v) failureHasReturn Just v -> successHasReturn v) failureHasReturn
where where
readVersion s0 = do readVersion s0 = do

View File

@ -18,12 +18,11 @@ successNoReturn = return Nothing
{-# INLINE successNoReturn #-} {-# INLINE successNoReturn #-}
failureHasReturn :: I.Failure (HasReturn a) failureHasReturn :: I.Failure (HasReturn a)
failureHasReturn i m = return . Left $ MemcachedException i m failureHasReturn = return . Left
{-# INLINE failureHasReturn #-} {-# INLINE failureHasReturn #-}
failureNoReturn :: I.Failure NoReturn failureNoReturn :: I.Failure NoReturn
failureNoReturn i m = return . Just $ MemcachedException i m failureNoReturn = return . Just
{-# INLINE failureNoReturn #-} {-# INLINE failureNoReturn #-}
#include "Common.hs" #include "Common.hs"

View File

@ -20,11 +20,11 @@ successNoReturn = return ()
{-# INLINE successNoReturn #-} {-# INLINE successNoReturn #-}
failureHasReturn :: I.Failure (HasReturn a) failureHasReturn :: I.Failure (HasReturn a)
failureHasReturn i m = throwIO $ MemcachedException i m failureHasReturn = throwIO
{-# INLINE failureHasReturn #-} {-# INLINE failureHasReturn #-}
failureNoReturn :: I.Failure NoReturn failureNoReturn :: I.Failure NoReturn
failureNoReturn i m = throwIO $ MemcachedException i m failureNoReturn = throwIO
{-# INLINE failureNoReturn #-} {-# INLINE failureNoReturn #-}
#include "Common.hs" #include "Common.hs"

View File

@ -36,7 +36,7 @@ withConnection i m = withSocketsDo $ bracket (connect i) close m
connect :: ConnectInfo -> IO Connection connect :: ConnectInfo -> IO Connection
connect i = fmap Connection $ connect i = fmap Connection $
createPool (putStrLn "open" >> connect' i) (\h -> putStrLn "closed" >> quit h >> hClose h) 1 createPool (connect' i) (\h -> quit h >> hClose h) 1
(connectionIdleTime i) (numConnection i) (connectionIdleTime i) (numConnection i)
connect' :: ConnectInfo -> IO Handle connect' :: ConnectInfo -> IO Handle
@ -47,12 +47,12 @@ connect' i = loop (connectAuth i)
loop [a] = do loop [a] = do
h <- connectTo (connectHost i) (connectPort i) h <- connectTo (connectHost i) (connectPort i)
auth a (\_ -> return h) (\w m -> throwIO $ MemcachedException w m) h auth a (\_ -> return h) throwIO h
loop (a:as) = do loop (a:as) = do
h <- connectTo (connectHost i) (connectPort i) h <- connectTo (connectHost i) (connectPort i)
handle (\(_::IOError) -> loop as) $ handle (\(_::IOError) -> loop as) $
auth a (\_ -> return h) (\_ _ -> loop as) h auth a (\_ -> return h) (\_ -> loop as) h
close :: Connection -> IO () close :: Connection -> IO ()
close (Connection p) = destroyAllResources p close (Connection p) = destroyAllResources p
@ -127,16 +127,20 @@ sendRequest op key elen epoke vlen vpoke opaque cas h =
hFlush h hFlush h
{-# INLINE sendRequest #-} {-# INLINE sendRequest #-}
type Failure a = Word16 -> S.ByteString -> IO a type Failure a = MemcachedException -> IO a
peekResponse :: (Ptr Header -> IO a) -> Failure a -> Handle -> IO a peekResponse :: (Ptr Header -> IO a) -> Failure a -> Handle -> IO a
peekResponse success failure h = allocaBytes 24 $ \p -> peekResponse success failure h = allocaBytes 24 $ \p -> do
hGetBuf h p 24 >> peekWord16be (plusPtr p 6) >>= \st -> len <- hGetBuf h p 24
if st == 0 if len /= 24
then success p then failure DataReadFailed
else do else do
bl <- peekWord32be (plusPtr p 8) peekWord16be (plusPtr p 6) >>= \st ->
failure st =<< S.hGet h (fromIntegral bl) if st == 0
then success p
else do
bl <- peekWord32be (plusPtr p 8)
failure . MemcachedException st =<< S.hGet h (fromIntegral bl)
{-# INLINE peekResponse #-} {-# INLINE peekResponse #-}
withRequest :: OpCode -> Key -> Word8 -> (Ptr Request -> IO ()) withRequest :: OpCode -> Key -> Word8 -> (Ptr Request -> IO ())
@ -175,27 +179,30 @@ inspectResponse h p = do
v <- L.hGet h $ fromIntegral tl - fromIntegral el - fromIntegral kl v <- L.hGet h $ fromIntegral tl - fromIntegral el - fromIntegral kl
return (e,k,v) return (e,k,v)
getSuccessCallback :: (Flags -> Value -> IO a) getSuccessCallback :: (Flags -> Value -> IO a) -> Failure a
-> Handle -> Ptr Header -> IO a -> Handle -> Ptr Header -> IO a
getSuccessCallback success h p = do getSuccessCallback success failure h p = do
elen <- getExtraLength p elen <- getExtraLength p
tlen <- getTotalLength p tlen <- getTotalLength p
void $ hGetBuf h p 4 len <- hGetBuf h p 4
flags <- peekWord32be p if len /= 4
value <- L.hGet h (fromIntegral tlen - fromIntegral elen) then failure DataReadFailed
success flags value else do
flags <- peekWord32be p
value <- L.hGet h (fromIntegral tlen - fromIntegral elen)
success flags value
get :: (Flags -> Value -> IO a) -> Failure a get :: (Flags -> Value -> IO a) -> Failure a
-> Key -> Handle -> IO a -> Key -> Handle -> IO a
get success failure key = get success failure key =
withRequest opGet key 0 nop 0 nop (CAS 0) withRequest opGet key 0 nop 0 nop (CAS 0)
(getSuccessCallback success) failure (getSuccessCallback success failure) failure
getWithCAS :: (CAS -> Flags -> Value -> IO a) -> Failure a getWithCAS :: (CAS -> Flags -> Value -> IO a) -> Failure a
-> Key -> Handle -> IO a -> Key -> Handle -> IO a
getWithCAS success failure key = getWithCAS success failure key =
withRequest opGet key 0 nop 0 nop (CAS 0) withRequest opGet key 0 nop 0 nop (CAS 0)
(\h p -> getCAS p >>= \c -> getSuccessCallback (success c) h p) failure (\h p -> getCAS p >>= \c -> getSuccessCallback (success c) failure h p) failure
setAddReplace :: IO a -> Failure a -> OpCode -> CAS setAddReplace :: IO a -> Failure a -> OpCode -> CAS
-> Key -> Value -> Flags -> Expiry -> Handle -> IO a -> Key -> Value -> Flags -> Expiry -> Handle -> IO a
@ -224,13 +231,15 @@ incrDecr success failure op cas key delta initial expiry =
pokeWord32be (plusPtr p 16) expiry pokeWord32be (plusPtr p 16) expiry
success' h p = do success' h p = do
void $ hGetBuf h p 8 len <- hGetBuf h p 8
peekWord64be p >>= success if len /= 8
then failure DataReadFailed
else peekWord64be p >>= success
quit :: Handle -> IO () quit :: Handle -> IO ()
quit h = do quit h = do
sendRequest opQuit "" 0 nop 0 nop 0 (CAS 0) h sendRequest opQuit "" 0 nop 0 nop 0 (CAS 0) h
peekResponse (\_ -> return ()) (\_ _ -> return ()) h peekResponse (\_ -> return ()) (\_ -> return ()) h
flushAll :: IO a -> Failure a -> Handle -> IO a flushAll :: IO a -> Failure a -> Handle -> IO a
flushAll success = flushAll success =
@ -261,7 +270,7 @@ stats h = loop H.empty
where where
loop m = do loop m = do
sendRequest opStat "" 0 nop 0 nop 0 (CAS 0) h sendRequest opStat "" 0 nop 0 nop 0 (CAS 0) h
peekResponse (success m) (\w s -> throwIO $ MemcachedException w s) h peekResponse (success m) throwIO h
success m p = getTotalLength p >>= \tl -> success m p = getTotalLength p >>= \tl ->
if tl == 0 if tl == 0
@ -280,7 +289,7 @@ touch :: (Flags -> Value -> IO a) -> Failure a -> OpCode
-> Key -> Expiry -> Handle -> IO a -> Key -> Expiry -> Handle -> IO a
touch success failure op key e = touch success failure op key e =
withRequest op key 4 (flip pokeWord32be e) 0 nop (CAS 0) withRequest op key 4 (flip pokeWord32be e) 0 nop (CAS 0)
(getSuccessCallback success) failure (getSuccessCallback success failure) failure
saslListMechs :: (S.ByteString -> IO a) -> Failure a saslListMechs :: (S.ByteString -> IO a) -> Failure a
-> Handle -> IO a -> Handle -> IO a

View File

@ -18,11 +18,11 @@ successNoReturn = return True
{-# INLINE successNoReturn #-} {-# INLINE successNoReturn #-}
failureHasReturn :: I.Failure (HasReturn a) failureHasReturn :: I.Failure (HasReturn a)
failureHasReturn _ _ = return Nothing failureHasReturn _ = return Nothing
{-# INLINE failureHasReturn #-} {-# INLINE failureHasReturn #-}
failureNoReturn :: I.Failure NoReturn failureNoReturn :: I.Failure NoReturn
failureNoReturn _ _ = return False failureNoReturn _ = return False
{-# INLINE failureNoReturn #-} {-# INLINE failureNoReturn #-}
#include "Common.hs" #include "Common.hs"

View File

@ -8,14 +8,17 @@ import Data.Word
import Data.Typeable import Data.Typeable
import qualified Data.ByteString as S import qualified Data.ByteString as S
data MemcachedException = MemcachedException data MemcachedException
{-# UNPACK #-} !Word16 {-# UNPACK #-} !S.ByteString = MemcachedException {-# UNPACK #-} !Word16 {-# UNPACK #-} !S.ByteString
| DataReadFailed
| VersionParseFailed
deriving (Show, Typeable) deriving (Show, Typeable)
instance Exception MemcachedException instance Exception MemcachedException
#define defExceptionP(n,w) n :: MemcachedException -> Bool;\ #define defExceptionP(n,w) n :: MemcachedException -> Bool;\
n (MemcachedException i _) = i == w n (MemcachedException i _) = i == w;\
n _ = False
defExceptionP(isKeyNotFound , 0x01) defExceptionP(isKeyNotFound , 0x01)
defExceptionP(isKeyExists , 0x02) defExceptionP(isKeyExists , 0x02)

View File

@ -25,9 +25,8 @@ import Database.Memcached.Binary.IO (Connection, withConnection)
import qualified Database.Memcached.Binary.IO as McIO import qualified Database.Memcached.Binary.IO as McIO
import qualified Database.Memcached.Binary.Maybe as McMaybe import qualified Database.Memcached.Binary.Maybe as McMaybe
import Test.Hspec
import Test.HUnit hiding (Test) import Test.HUnit hiding (Test)
import Test.Framework
import Test.Framework.Providers.HUnit
startMemcached :: IO ProcessHandle startMemcached :: IO ProcessHandle
startMemcached = do startMemcached = do
@ -45,9 +44,6 @@ precond c = do
void $ McIO.set 0 0 "foo" "foovalue" c void $ McIO.set 0 0 "foo" "foovalue" c
void $ McIO.set 1 0 "bar" "1234567890" 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) newtype ByPassException = ByPassException String deriving (Typeable)
instance Show ByPassException where instance Show ByPassException where
show (ByPassException s) = s show (ByPassException s) = s
@ -59,7 +55,9 @@ assertException ex msg m =
(m >> throwIO (ByPassException "exception not occured.")) `catch` (m >> throwIO (ByPassException "exception not occured.")) `catch`
(\e -> case fromException e :: Maybe MemcachedException of (\e -> case fromException e :: Maybe MemcachedException of
Nothing -> assertFn e Nothing -> assertFn e
Just e'@(MemcachedException i _) -> unless (i == ex) (assertFn e')) Just e'@(MemcachedException i _) -> unless (i == ex) (assertFn e')
Just e' -> assertFn e'
)
where where
assertFn e = assertFailure $ unlines assertFn e = assertFailure $ unlines
[ "not expected exception occured:" [ "not expected exception occured:"
@ -67,204 +65,219 @@ assertException ex msg m =
, "occured: " ++ show e , "occured: " ++ show e
] ]
testGet :: Test withConn :: (Connection -> IO a) -> IO a
testGet = testGroup "get" withConn m = withConnection def $ \c -> precond c >> m c
[ testGroup "IO module"
[ testGroup "get" main :: IO ()
[ doTest "foo" (0, "foovalue") McIO.get main = bracket startMemcached terminateProcess $ \_ -> hspec $ do
, doTest "bar" (1, "1234567890") McIO.get v <- runIO $ withConn McIO.version
, doTestException "notexist" McIO.get testGet
] testSetAddReplace
, testGroup "get_" testDelete
[ doTest "foo" "foovalue" McIO.get_ testIncrDecr v
, doTest "bar" "1234567890" McIO.get_ testFlush
, doTestException "notexist" McIO.get_ testVersion
] testNoOp
] testAppendPrepend
, testGroup "Maybe module" testTouchGAT v
[ testGroup "get" testModify
[ doTest "foo" (Just (0, "foovalue")) McMaybe.get
, doTest "bar" (Just (1, "1234567890")) McMaybe.get testGet :: Spec
, doTest "notexist" Nothing McMaybe.get testGet = context "get" $ do
] context "IO module" $ do
, testGroup "get_" describe "get" $ do
[ doTest "foo" (Just "foovalue") McMaybe.get_ doTest "foo" (0, "foovalue") "get" McIO.get
, doTest "bar" (Just "1234567890") McMaybe.get_ doTest "bar" (1, "1234567890") "get" McIO.get
, doTest "notexist" Nothing McMaybe.get_ doTestException "get" McIO.get
] describe "get_" $ do
] doTest "foo" "foovalue" "get_" McIO.get_
] doTest "bar" "1234567890" "get_" McIO.get_
doTestException "get_" McIO.get_
context "Maybe module" $ do
describe "get" $ do
doTest "foo" (Just (0, "foovalue")) "get" McMaybe.get
doTest "bar" (Just (1, "1234567890")) "get" McMaybe.get
doTest "notexist" Nothing "get" McMaybe.get
describe "get_" $ do
doTest "foo" (Just "foovalue") "get_" McMaybe.get_
doTest "bar" (Just "1234567890") "get_" McMaybe.get_
doTest "notexist" Nothing "get_" McMaybe.get_
where where
doTest key ex fn = testMc (S.unpack key) $ \c -> do doTest key ex meth fn = it ("return " ++ show ex ++ " when " ++ meth ++ ' ': show key) $ withConn $ \c -> do
v <- fn key c v <- fn key c
v @?= ex v @?= ex
doTestException key fn = testMc (S.unpack key) $ \c -> doTestException meth fn = it ("throw exception(1) when " ++ meth ++ " notexist") $ withConn $ \c ->
assertException 1 "Not found" $ fn key c assertException 1 "Not found" $ fn "notexist" c
testSetAddReplace :: Test testSetAddReplace :: Spec
testSetAddReplace = testGroup "set/add/replace" testSetAddReplace = context "set/add/replace" $ do
[ testGroup "set" describe "set" $ do
[ testMc "set foo to foomod" $ \c -> do it "set foo = (100, foomod)" $ withConn $ \c -> do
McIO.set 100 0 "foo" "foomod" c McIO.set 100 0 "foo" "foomod" c
v <- McIO.get "foo" c v <- McIO.get "foo" c
v @?= (100, "foomod") v @?= (100, "foomod")
, testMc "set notexist to exist" $ \c -> do it "set notexist = exist" $ withConn $ \c -> do
McIO.set 100 0 "notexist" "exist" c McIO.set 100 0 "notexist" "exist" c
v <- McIO.get "notexist" c v <- McIO.get "notexist" c
v @?= (100, "exist") v @?= (100, "exist")
]
, testGroup "add" describe "add" $ do
[ testMc "add foo to foomod" $ \c -> it "throw exception(2) when add exist key" $ withConn $ \c -> do
assertException 2 "Data exists for key." $ assertException 2 "Data exists for key." $
McIO.add 100 0 "foo" "foomod" c McIO.add 100 0 "foo" "foomod" c
, testMc "add notexist to exist" $ \c -> do it "add notexist = exist" $ withConn $ \c -> do
McIO.add 100 0 "notexist" "exist" c McIO.add 100 0 "notexist" "exist" c
v <- McIO.get "notexist" c v <- McIO.get "notexist" c
v @?= (100, "exist") v @?= (100, "exist")
]
, testGroup "replace" describe "replace" $ do
[ testMc "set foo to foomod" $ \c -> do it "replace foo = foomod" $ withConn $ \c -> do
McIO.replace 100 0 "foo" "foomod" c McIO.replace 100 0 "foo" "foomod" c
v <- McIO.get "foo" c v <- McIO.get "foo" c
v @?= (100, "foomod") v @?= (100, "foomod")
, testMc "set notexist to exist" $ \c -> it "throw exception(1) when replace not exist key" $ withConn $ \c -> do
assertException 1 "Not found" $ assertException 1 "Not found" $
McIO.replace 100 0 "notexist" "exist" c McIO.replace 100 0 "notexist" "exist" c
]
]
testDelete :: Test
testDelete = testGroup "delete" testDelete :: Spec
[ testGroup "IO module" testDelete = context "delete" $ do
[ testMc "foo" $ \c -> do context "IO module" $ do
it "delete foo" $ withConn $ \c -> do
McIO.delete "foo" c McIO.delete "foo" c
r <- McMaybe.get "foo" c r <- McMaybe.get "foo" c
r @?= Nothing r @?= Nothing
, testMc "notexist" $ \c -> it "throw exception(1) when delete notexist" $ withConn $
assertException 1 "Not found" $ McIO.delete "notexist" c assertException 1 "Not found" . McIO.delete "notexist"
]
, testGroup "Maybe module" context "Maybe module" $ do
[ testMc "foo" $ \c -> do it "delete foo" $ withConn $ \c -> do
b <- McMaybe.delete "foo" c b <- McMaybe.delete "foo" c
r <- McMaybe.get "foo" c r <- McMaybe.get "foo" c
b @?= True b @?= True
r @?= Nothing r @?= Nothing
, testMc "notexist" $ \c -> do it "delete notexist" $ withConn $ \c -> do
b <- McMaybe.delete "notexist" c b <- McMaybe.delete "notexist" c
r <- McMaybe.get "notexist" c r <- McMaybe.get "notexist" c
b @?= False b @?= False
r @?= Nothing r @?= Nothing
]
]
-- https://code.google.com/p/memcached/wiki/ReleaseNotes1417 -- https://code.google.com/p/memcached/wiki/ReleaseNotes1417
testIncrDecr :: Version -> Test testIncrDecr :: Version -> Spec
testIncrDecr v = testGroup "increment/decrement" testIncrDecr v = context "increment/decrement" $ do
[ testGroup "IO module" context "IO module" $ do
[ testGroup "increment" describe "increment" $ do
[ testMc "foo" $ \c -> it "throw exception(6) when increment non numeric value" $ withConn $ \c ->
assertException 6 "Non-numeric server-side value for incr or decr" $ assertException 6 "Non-numeric server-side value for incr or decr" $
McIO.increment 0 "foo" 10 10 c McIO.increment 0 "foo" 10 10 c
, testMc "bar" $ \c -> do
it "increment bar" $ withConn $ \c -> do
a <- McIO.increment 0 "bar" 10 10 c a <- McIO.increment 0 "bar" 10 10 c
b <- McIO.get_ "bar" c b <- McIO.get_ "bar" c
a @?= 1234567900 a @?= 1234567900
b @?= "1234567900" b @?= "1234567900"
, testMc "notexist" $ \c -> do
it "set initial value notexist" $ withConn $ \c -> do
when (v < ev) $ pendingWith msg
a <- McIO.increment 0 "notexist" 10 10 c a <- McIO.increment 0 "notexist" 10 10 c
b <- McIO.get_ "notexist" c b <- McIO.get_ "notexist" c
a @?= 10 a @?= 10
when (v >= ev) $ b @?= "10" b @?= "10"
]
, testGroup "decrement" describe "decrement" $ do
[ testMc "foo" $ \c -> it "throw exception(6) when increment non numeric value" $ withConn $ \c ->
assertException 6 "Non-numeric server-side value for incr or decr" $ assertException 6 "Non-numeric server-side value for incr or decr" $
McIO.decrement 0 "foo" 10 10 c McIO.decrement 0 "foo" 10 10 c
, testMc "bar" $ \c -> do
it "decrement bar" $ withConn $ \c -> do
a <- McIO.decrement 0 "bar" 10 10 c a <- McIO.decrement 0 "bar" 10 10 c
b <- McIO.get_ "bar" c b <- McIO.get_ "bar" c
a @?= 1234567880 a @?= 1234567880
b @?= "1234567880" b @?= "1234567880"
, testMc "notexist" $ \c -> do
it "set initial value notexist" $ withConn $ \c -> do
when (v < ev) $ pendingWith msg
a <- McIO.decrement 0 "notexist" 10 10 c a <- McIO.decrement 0 "notexist" 10 10 c
b <- McIO.get_ "notexist" c b <- McIO.get_ "notexist" c
a @?= 10 a @?= 10
when (v >= ev) $ b @?= "10" b @?= "10"
]
] context "Maybe module" $ do
, testGroup "Maybe module" describe "increment" $ do
[ testGroup "increment" it "return Nothing when increment non numeric value" $ withConn $ \c -> do
[ testMc "foo" $ \c -> do
r <- McMaybe.increment 0 "foo" 10 10 c r <- McMaybe.increment 0 "foo" 10 10 c
b <- McIO.get_ "foo" c b <- McIO.get_ "foo" c
r @?= Nothing r @?= Nothing
b @?= "foovalue" b @?= "foovalue"
, testMc "bar" $ \c -> do it "increment bar" $ withConn $ \c -> do
a <- McMaybe.increment 0 "bar" 10 10 c a <- McMaybe.increment 0 "bar" 10 10 c
b <- McIO.get_ "bar" c b <- McIO.get_ "bar" c
a @?= Just 1234567900 a @?= Just 1234567900
b @?= "1234567900" b @?= "1234567900"
, testMc "notexist" $ \c -> do it "set initial value notexist" $ withConn $ \c -> do
when (v < ev) $ pendingWith msg
a <- McMaybe.increment 0 "notexist" 10 10 c a <- McMaybe.increment 0 "notexist" 10 10 c
b <- McIO.get_ "notexist" c b <- McIO.get_ "notexist" c
a @?= Just 10 a @?= Just 10
when (v >= ev) $ b @?= "10" b @?= "10"
]
, testGroup "decrement'" describe "decrement" $ do
[ testMc "foo" $ \c -> do it "return Nothing when decrement non numeric value" $ withConn $ \c -> do
r <- McMaybe.decrement 0 "foo" 10 10 c r <- McMaybe.decrement 0 "foo" 10 10 c
b <- McIO.get_ "foo" c b <- McIO.get_ "foo" c
r @?= Nothing r @?= Nothing
b @?= "foovalue" b @?= "foovalue"
, testMc "bar" $ \c -> do it "decrement bar" $ withConn $ \c -> do
a <- McMaybe.decrement 0 "bar" 10 10 c a <- McMaybe.decrement 0 "bar" 10 10 c
b <- McIO.get_ "bar" c b <- McIO.get_ "bar" c
a @?= Just 1234567880 a @?= Just 1234567880
b @?= "1234567880" b @?= "1234567880"
, testMc "notexist" $ \c -> do it "set initial value notexist" $ withConn $ \c -> do
when (v < ev) $ pendingWith msg
a <- McMaybe.decrement 0 "notexist" 10 10 c a <- McMaybe.decrement 0 "notexist" 10 10 c
b <- McIO.get_ "notexist" c b <- McIO.get_ "notexist" c
a @?= Just 10 a @?= Just 10
when (v >= ev) $ b @?= "10" b @?= "10"
]
]
]
where where
ev = Version [1,4,17] [] ev = Version [1,4,17] []
msg = "memcached(< 1.4.17) bug. see: https://code.google.com/p/memcached/wiki/ReleaseNotes1417"
testFlush :: Test testFlush :: Spec
testFlush = testGroup "flush" testFlush = context "flush" $ do
[ testGroup "IO module" context "IO module" $ do
[ testMc "flushAll" $ \c -> do describe "flushAll" $ do
McIO.flushAll c it "flush all data" $ withConn $ \c -> do
a <- McMaybe.get "foo" c McIO.flushAll c
a @?= Nothing 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 context "Maybe module" $ do
testVersion = testGroup "version" describe "flushAll" $ do
[ testGroup "versionString" it "flush all data and return True" $ withConn $ \c -> do
[ testMc "IO module" $ \c -> do r <- McMaybe.flushAll c
v <- McIO.versionString c a <- McMaybe.get "foo" c
assertBool (show v ++ " is not version like.") $ isVersionLike v r @?= True
, testMc "Maybe module" $ \c -> do a @?= Nothing
Just v <- McMaybe.versionString c
assertBool (show v ++ " is not version like.") $ isVersionLike v testVersion :: Spec
] testVersion = context "version" $ do
, testGroup "version" context "IO module" $ do
[ testMc "IO module" $ \c -> do describe "versionString" $
v <- McIO.version c it "return version bytestring" $ withConn $ \c -> do
assertEqual "version branch length" 3 (length $ versionBranch v) v <- McIO.versionString c
] assertBool (show v ++ " is not version like.") $ isVersionLike v
]
describe "version" $
it "return Version" $ withConn $ \c -> do
v <- McIO.version c
assertEqual "version branch length" 3 (length $ versionBranch v)
context "Maybe module" $ do
describe "versionString" $
it "returns version bytestring" $ withConn $ \c -> do
Just v <- McMaybe.versionString c
assertBool (show v ++ " is not version like.") $ isVersionLike v
where where
isVersionLike s0 = isJust $ do isVersionLike s0 = isJust $ do
(_, s1) <- S.readInt s0 (_, s1) <- S.readInt s0
@ -274,212 +287,198 @@ testVersion = testGroup "version"
(_, s3) <- S.readInt (S.tail s2) (_, s3) <- S.readInt (S.tail s2)
unless (S.null s3) Nothing unless (S.null s3) Nothing
testNoOp :: Test testNoOp :: Spec
testNoOp = testGroup "noOp" testNoOp = context "noOp" $ do
[ testMc "IO module" McIO.noOp context "IO module" $
, testMc "Maybe module" $ \c -> do it "is noop" $ withConn McIO.noOp
b <- McMaybe.noOp c context "Maybe module" $
b @?= True it "is noop and returns True" $ withConn $ \c -> do
] b <- McMaybe.noOp c
b @?= True
testAppendPrepend :: Test testAppendPrepend :: Spec
testAppendPrepend = testGroup "append/prepend" testAppendPrepend = context "append/prepend" $ do
[ testGroup "IO module" context "IO module" $ do
[ testGroup "append" describe "append" $ do
[ testMc "foo" $ \c -> do it "append !! to foo" $ withConn $ \c -> do
McIO.append "foo" "!!" c McIO.append "foo" "!!" c
a <- McIO.get_ "foo" c a <- McIO.get_ "foo" c
a @?= "foovalue!!" a @?= "foovalue!!"
, testMc "bar" $ \c -> do it "append !! to bar" $ withConn $ \c -> do
McIO.append "bar" "!!" c McIO.append "bar" "!!" c
a <- McIO.get_ "bar" c a <- McIO.get_ "bar" c
a @?= "1234567890!!" a @?= "1234567890!!"
, testMc "notexist" $ \c -> it "throws exception(5) when not exist." $ withConn $ \c ->
assertException 5 "Not stored." $ McIO.append "notexist" "!!" c assertException 5 "Not stored." $ McIO.append "notexist" "!!" c
]
, testGroup "prepend" describe "prepend" $ do
[ testMc "foo" $ \c -> do it "prepend !! to foo" $ withConn $ \c -> do
McIO.prepend "foo" "!!" c McIO.prepend "foo" "!!" c
a <- McIO.get_ "foo" c a <- McIO.get_ "foo" c
a @?= "!!foovalue" a @?= "!!foovalue"
, testMc "bar" $ \c -> do
it "prepend !! to bar" $ withConn $ \c -> do
McIO.prepend "bar" "!!" c McIO.prepend "bar" "!!" c
a <- McIO.get_ "bar" c a <- McIO.get_ "bar" c
a @?= "!!1234567890" a @?= "!!1234567890"
, testMc "notexist" $ \c ->
it "throws exception(5) when not exist" $ withConn $ \c ->
assertException 5 "Not stored." $ McIO.prepend "notexist" "!!" c assertException 5 "Not stored." $ McIO.prepend "notexist" "!!" c
]
] context "Maybe module" $ do
, testGroup "maybe module" describe "append" $ do
[ testGroup "append'" it "append !! to foo and return True" $ withConn $ \c -> do
[ testMc "foo" $ \c -> do
b <- McMaybe.append "foo" "!!" c b <- McMaybe.append "foo" "!!" c
a <- McIO.get_ "foo" c a <- McIO.get_ "foo" c
b @?= True b @?= True
a @?= "foovalue!!" a @?= "foovalue!!"
, testMc "bar" $ \c -> do
it "append !! to bar and return True" $ withConn $ \c -> do
b <- McMaybe.append "bar" "!!" c b <- McMaybe.append "bar" "!!" c
a <- McIO.get_ "bar" c a <- McIO.get_ "bar" c
b @?= True b @?= True
a @?= "1234567890!!" a @?= "1234567890!!"
, testMc "notexist" $ \c -> do
it "return False when not exist" $ withConn $ \c -> do
b <- McMaybe.append "notexist" "!!" c b <- McMaybe.append "notexist" "!!" c
b @?= False b @?= False
]
, testGroup "prepend'" describe "prepend" $ do
[ testMc "foo" $ \c -> do it "prepend !! to foo and return True" $ withConn $ \c -> do
b <- McMaybe.prepend "foo" "!!" c b <- McMaybe.prepend "foo" "!!" c
a <- McIO.get_ "foo" c a <- McIO.get_ "foo" c
b @?= True b @?= True
a @?= "!!foovalue" a @?= "!!foovalue"
, testMc "bar" $ \c -> do
it "prepend !! to baar and return True" $ withConn $ \c -> do
b <- McMaybe.prepend "bar" "!!" c b <- McMaybe.prepend "bar" "!!" c
a <- McIO.get_ "bar" c a <- McIO.get_ "bar" c
b @?= True b @?= True
a @?= "!!1234567890" a @?= "!!1234567890"
, testMc "notexist" $ \c -> do
it "return False when not exist" $ withConn $ \c -> do
b <- McMaybe.prepend "notexist" "!!" c b <- McMaybe.prepend "notexist" "!!" c
b @?= False b @?= False
]
]
]
-- https://code.google.com/p/memcached/wiki/ReleaseNotes1414 testTouchGAT :: Version -> Spec
-- https://code.google.com/p/memcached/issues/detail?id=275 testTouchGAT v = context "touch/GAT" $ do
testTouchGAT :: Version -> Test context "IO module" $ do
testTouchGAT v = testGroup "touch/GAT" describe "touch" $ do
[ testGroup "IO module" it "touch 1s and expire it." $ withConn $ \c -> do
[ testGroup "touch" when (v < ev) $ pendingWith msg
[ testMc "foo" $ \c -> do
a <- McMaybe.get_ "foo" c a <- McMaybe.get_ "foo" c
McIO.touch 1 "foo" c McIO.touch 1 "foo" c
a @?= (Just "foovalue") a @?= (Just "foovalue")
when (v >= ev) $ do threadDelay 1100000
threadDelay 1100000 b <- McMaybe.get_ "foo" c
b <- McMaybe.get_ "foo" c b @?= Nothing
b @?= Nothing
, testMc "notexist" $ \c -> it "throws exception(1) when not exist" $ withConn $ \c ->
assertException 1 "Not found" $ McIO.touch 1 "notexist" c assertException 1 "Not found" $ McIO.touch 1 "notexist" c
]
, testGroup "getAndTouch" describe "getAndTouch" $ do
[ testMc "foo" $ \c -> do it "touch 1s, return (flag, value), and expire it" $ withConn $ \c -> do
when (v < ev) $ pendingWith msg
x <- McMaybe.get "foo" c x <- McMaybe.get "foo" c
y <- McIO.getAndTouch 1 "foo" c y <- McIO.getAndTouch 1 "foo" c
x @?= Just (0, "foovalue") x @?= Just (0, "foovalue")
y @?= (0, "foovalue") y @?= (0, "foovalue")
when (v >= ev) $ do threadDelay 1100000
threadDelay 1100000 z <- McMaybe.get "foo" c
z <- McMaybe.get "foo" c z @?= Nothing
z @?= Nothing
, testMc "notexist" $ \c -> it "throws exception(1) when not exist" $ withConn $ \c ->
assertException 1 "Not found" $ McIO.getAndTouch 1 "notexist" c assertException 1 "Not found" $ McIO.getAndTouch 1 "notexist" c
]
, testGroup "getAndTouch_" describe "getAndTouch_" $ do
[ testMc "foo" $ \c -> do it "touch 1s, return value, and expire it" $ withConn $ \c -> do
when (v < ev) $ pendingWith msg
x <- McMaybe.get_ "foo" c x <- McMaybe.get_ "foo" c
y <- McIO.getAndTouch_ 1 "foo" c y <- McIO.getAndTouch_ 1 "foo" c
x @?= Just "foovalue" x @?= Just "foovalue"
y @?= "foovalue" y @?= "foovalue"
when (v >= ev) $ do threadDelay 1100000
threadDelay 1100000 z <- McMaybe.get_ "foo" c
z <- McMaybe.get_ "foo" c z @?= Nothing
z @?= Nothing
, testMc "notexist" $ \c -> it "throws exception(1) when not exist" $ withConn $ \c ->
assertException 1 "Not found" $ McIO.getAndTouch_ 1 "notexist" c assertException 1 "Not found" $ McIO.getAndTouch_ 1 "notexist" c
]
] context "Maybe module" $ do
, testGroup "Maybe module" describe "touch" $ do
[ testGroup "touch" it "touch 1s, return True, and expire it." $ withConn $ \c -> do
[ testMc "foo" $ \c -> do when (v < ev) $ pendingWith msg
a <- McMaybe.get_ "foo" c a <- McMaybe.get_ "foo" c
r <- McMaybe.touch 1 "foo" c r <- McMaybe.touch 1 "foo" c
a @?= (Just "foovalue") a @?= (Just "foovalue")
r @?= True r @?= True
when (v >= ev) $ do threadDelay 1100000
threadDelay 1100000 b <- McMaybe.get_ "foo" c
b <- McMaybe.get_ "foo" c b @?= Nothing
b @?= Nothing
, testMc "notexist" $ \c -> do it "return False when not exist" $ withConn $ \c -> do
r <- McMaybe.touch 1 "notexist" c r <- McMaybe.touch 1 "notexist" c
a <- McMaybe.get "notexist" c a <- McMaybe.get "notexist" c
r @?= False r @?= False
a @?= Nothing a @?= Nothing
]
, testGroup "getAndTouch'/getMaybeAndTouch" describe "getAndTouch" $ do
[ testMc "foo" $ \c -> do it "touch 1s, return (flag, value), and expire it" $ withConn $ \c -> do
when (v < ev) $ pendingWith msg
a <- McMaybe.get "foo" c a <- McMaybe.get "foo" c
r <- McMaybe.getAndTouch 1 "foo" c r <- McMaybe.getAndTouch 1 "foo" c
a @?= Just (0, "foovalue") a @?= Just (0, "foovalue")
r @?= Just (0, "foovalue") r @?= Just (0, "foovalue")
when (v >= ev) $ do threadDelay 1100000
threadDelay 1100000 b <- McMaybe.get_ "foo" c
b <- McMaybe.get_ "foo" c b @?= Nothing
b @?= Nothing
, testMc "notexist" $ \c -> do it "return Nothing when not exist" $ withConn $ \c -> do
r <- McMaybe.getAndTouch 1 "notexist" c r <- McMaybe.getAndTouch 1 "notexist" c
a <- McMaybe.get "notexist" c a <- McMaybe.get "notexist" c
r @?= Nothing r @?= Nothing
a @?= Nothing a @?= Nothing
]
, testGroup "getAndTouch'_/getMaybeAndTouch_" describe "getAndTouch_" $ do
[ testMc "foo" $ \c -> do it "touch 1s, return value, and expire it" $ withConn $ \c -> do
when (v < ev) $ pendingWith msg
a <- McMaybe.get_ "foo" c a <- McMaybe.get_ "foo" c
r <- McMaybe.getAndTouch_ 1 "foo" c r <- McMaybe.getAndTouch_ 1 "foo" c
a @?= Just "foovalue" a @?= Just "foovalue"
r @?= Just "foovalue" r @?= Just "foovalue"
when (v >= ev) $ do threadDelay 1100000
threadDelay 1100000 b <- McMaybe.get_ "foo" c
b <- McMaybe.get_ "foo" c b @?= Nothing
b @?= Nothing
, testMc "notexist" $ \c -> do it "return Nothing when not exist" $ withConn $ \c -> do
r <- McMaybe.getAndTouch_ 1 "notexist" c r <- McMaybe.getAndTouch_ 1 "notexist" c
a <- McMaybe.get "notexist" c a <- McMaybe.get "notexist" c
r @?= Nothing r @?= Nothing
a @?= Nothing a @?= Nothing
]
]
]
where where
ev = Version [1,4,14] [] ev = Version [1,4,14] []
msg = "memcached(< 1.4.14) bug. see: https://code.google.com/p/memcached/wiki/ReleaseNotes1414 & https://code.google.com/p/memcached/issues/detail?id=275"
testModify :: Test testModify :: Spec
testModify = testGroup "modify" testModify = context "modify" $ do
[ testMc "reverse foo" $ \c -> do context "IO monad" $ do
r <- McIO.modify 0 "foo" (\f v -> (f + 100, L.reverse v, v)) c describe "modify" $ do
a <- McMaybe.get "foo" c it "reverse foo value and return original" $ withConn $ \c -> do
r @?= "foovalue" r <- McIO.modify 0 "foo" (\f v -> (f + 100, L.reverse v, v)) c
a @?= Just (100, "eulavoof") a <- McMaybe.get "foo" c
, testMc "notexist" $ \c -> r @?= "foovalue"
assertException 1 "Not found" $ a @?= Just (100, "eulavoof")
McIO.modify 0 "notexist" (\f v -> (f,v,())) c
]
testModify_ :: Test it "throw exception(1) when not exist" $ withConn $ \c -> do
testModify_ = testGroup "modify_" assertException 1 "Not found" $
[ testMc "reverse foo" $ \c -> do McIO.modify 0 "notexist" (\f v -> (f,v,())) c
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
]
describe "modify_" $ do
it "reverse foo value" $ withConn $ \c -> do
McIO.modify_ 0 "foo" (\f v -> (f + 100, L.reverse v)) c
a <- McMaybe.get "foo" c
a @?= Just (100, "eulavoof")
it "throw exception(1) when not exist" $ withConn $ \c -> do
main :: IO () assertException 1 "Not found" $
main = bracket startMemcached terminateProcess $ \_ -> do McIO.modify_ 0 "notexist" (\f v -> (f,v)) c
v <- McIO.withConnection def McIO.version
defaultMain
[ testGet
, testSetAddReplace
, testDelete
, testIncrDecr v
, testFlush
, testVersion
, testNoOp
, testAppendPrepend
, testTouchGAT v
, testModify
, testModify_
]