Compare commits
9 Commits
| Author | SHA1 | Date | |
|---|---|---|---|
|
|
42295c38b9 | ||
|
|
09ecd54191 | ||
|
|
fe7a32cb2b | ||
|
|
f7dc96c415 | ||
|
|
44c6d2e0c6 | ||
|
|
62bab4edc8 | ||
|
|
a03a17e483 | ||
|
|
53b5a31b8b | ||
|
|
d2ae2c6c17 |
22
.travis.yml
22
.travis.yml
@ -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
|
||||||
|
|||||||
@ -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
|
||||||
|
|||||||
@ -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
|
||||||
|
|||||||
@ -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"
|
||||||
|
|
||||||
|
|||||||
@ -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"
|
||||||
|
|||||||
@ -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
|
||||||
|
|||||||
@ -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"
|
||||||
|
|||||||
@ -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)
|
||||||
|
|||||||
513
test/test.hs
513
test/test.hs
@ -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_
|
|
||||||
]
|
|
||||||
|
|||||||
Loading…
Reference in New Issue
Block a user