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

Compare commits

base: haskell:master
Branches Tags
haskell:master
haskell:uni2work
haskell:version-bumps
haskell:develop
haskell:hspec-2.2
haskell:v0.1.2
haskell:v0.1.1
haskell:v0.1.0.1
haskell:v0.1.0
..
compare: haskell:v0.1.0.1
Branches Tags
haskell:uni2work
haskell:version-bumps
haskell:develop
haskell:master
haskell:hspec-2.2
haskell:v0.1.2
haskell:v0.1.1
haskell:v0.1.0.1
haskell:v0.1.0

No commits in common. "master" and "v0.1.0.1" have entirely different histories.
master ... v0.1.0.1

9 changed files with 323 additions and 335 deletions
Show Stats Expand all files Collapse all files

22
.travis.yml
View File

@ -1,18 +1,4 @@
language: c language: haskell
ghc:
sudo: false - 7.8
- 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

23
memcached-binary.cabal
View File

@ -1,5 +1,5 @@
name: memcached-binary name: memcached-binary
version: 0.2.0 version: 0.1.0.1
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-2015 Hirotomo Moriwaki copyright: (c) 2014 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.9 build-depends: base >=4.6 && <4.8
, bytestring >=0.10 && <0.11 , bytestring >=0.10 && <0.11
, network >=2.5 && <2.7 , network >=2.6 && <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.6 , time >=1.4 && <1.5
ghc-options: -Wall -O2 ghc-options: -Wall -O2
hs-source-dirs: src hs-source-dirs: src
default-language: Haskell2010 default-language: Haskell2010
@ -42,12 +42,13 @@ 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 build-depends: base >=4.6 && <4.8
, 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.5 && <2.7 , network >=2.6 && <2.7
, HUnit >=1.2 && <1.4 , HUnit >=1.2 && <1.3
, data-default-class , data-default-class >=0.0 && <0.1
, bytestring , bytestring >=0.10 && <0.11
default-language: Haskell2010 default-language: Haskell2010

2
src/Database/Memcached/Binary/Common.hs
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 VersionParseFailed Nothing -> failureHasReturn (-1) "version parse failed"
Just v -> successHasReturn v) failureHasReturn Just v -> successHasReturn v) failureHasReturn
where where
readVersion s0 = do readVersion s0 = do

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

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

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

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

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

@ -16,6 +16,7 @@ import System.IO
import Control.Monad import Control.Monad
import Control.Exception import Control.Exception
import Control.Concurrent.MVar
import Data.Word import Data.Word
import Data.Pool import Data.Pool
@ -29,15 +30,20 @@ import Database.Memcached.Binary.Types
import Database.Memcached.Binary.Types.Exception import Database.Memcached.Binary.Types.Exception
import Database.Memcached.Binary.Internal.Definition import Database.Memcached.Binary.Internal.Definition
newtype Connection = Connection (Pool Handle) data Connection
= Connection (MVar Handle)
| ConnectionPool (Pool Handle)
withConnection :: ConnectInfo -> (Connection -> IO a) -> IO a withConnection :: ConnectInfo -> (Connection -> IO a) -> IO a
withConnection i m = withSocketsDo $ bracket (connect i) close m withConnection i m = withSocketsDo $ bracket (connect i) close m
connect :: ConnectInfo -> IO Connection connect :: ConnectInfo -> IO Connection
connect i = fmap Connection $ connect i =
createPool (connect' i) (\h -> quit h >> hClose h) 1 if numConnection i == 1
(connectionIdleTime i) (numConnection i) then fmap Connection $ connect' i >>= newMVar
else fmap ConnectionPool $
createPool (connect' i) (\h -> quit h >> hClose h) 1
(connectionIdleTime i) (numConnection i)
connect' :: ConnectInfo -> IO Handle connect' :: ConnectInfo -> IO Handle
connect' i = loop (connectAuth i) connect' i = loop (connectAuth i)
@ -47,18 +53,23 @@ 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) throwIO h auth a (\_ -> return h) (\w m -> throwIO $ MemcachedException w m) 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 mv) = do
h <- swapMVar mv (error "connection already closed")
quit h
hClose h
close (ConnectionPool p) = destroyAllResources p
useConnection :: (Handle -> IO a) -> Connection -> IO a useConnection :: (Handle -> IO a) -> Connection -> IO a
useConnection f (Connection p) = withResource p f useConnection f (Connection mv) = withMVar mv f
useConnection f (ConnectionPool p) = withResource p f
pokeWord8 :: Ptr a -> Word8 -> IO () pokeWord8 :: Ptr a -> Word8 -> IO ()
pokeWord8 = poke . castPtr pokeWord8 = poke . castPtr
@ -127,20 +138,16 @@ sendRequest op key elen epoke vlen vpoke opaque cas h =
hFlush h hFlush h
{-# INLINE sendRequest #-} {-# INLINE sendRequest #-}
type Failure a = MemcachedException -> IO a type Failure a = Word16 -> S.ByteString -> 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 -> do peekResponse success failure h = bracket (mallocBytes 24) free $ \p ->
len <- hGetBuf h p 24 hGetBuf h p 24 >> peekWord16be (plusPtr p 6) >>= \st ->
if len /= 24 if st == 0
then failure DataReadFailed then success p
else do else do
peekWord16be (plusPtr p 6) >>= \st -> bl <- peekWord32be (plusPtr p 8)
if st == 0 failure st =<< S.hGet h (fromIntegral bl)
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 ())
@ -179,30 +186,27 @@ 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) -> Failure a getSuccessCallback :: (Flags -> Value -> IO a)
-> Handle -> Ptr Header -> IO a -> Handle -> Ptr Header -> IO a
getSuccessCallback success failure h p = do getSuccessCallback success h p = do
elen <- getExtraLength p elen <- getExtraLength p
tlen <- getTotalLength p tlen <- getTotalLength p
len <- hGetBuf h p 4 void $ hGetBuf h p 4
if len /= 4 flags <- peekWord32be p
then failure DataReadFailed value <- L.hGet h (fromIntegral tlen - fromIntegral elen)
else do success flags value
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) failure (getSuccessCallback success) 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) failure h p) failure (\h p -> getCAS p >>= \c -> getSuccessCallback (success c) 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
@ -231,15 +235,13 @@ 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
len <- hGetBuf h p 8 void $ hGetBuf h p 8
if len /= 8 peekWord64be p >>= success
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 =
@ -270,7 +272,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) throwIO h peekResponse (success m) (\w s -> throwIO $ MemcachedException w s) h
success m p = getTotalLength p >>= \tl -> success m p = getTotalLength p >>= \tl ->
if tl == 0 if tl == 0
@ -289,7 +291,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) failure (getSuccessCallback success) failure
saslListMechs :: (S.ByteString -> IO a) -> Failure a saslListMechs :: (S.ByteString -> IO a) -> Failure a
-> Handle -> IO a -> Handle -> IO a

4
src/Database/Memcached/Binary/Maybe.hs
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"

9
src/Database/Memcached/Binary/Types/Exception.hs
View File

@ -8,17 +8,14 @@ import Data.Word
import Data.Typeable import Data.Typeable
import qualified Data.ByteString as S import qualified Data.ByteString as S
data MemcachedException data MemcachedException = MemcachedException
= MemcachedException {-# UNPACK #-} !Word16 {-# UNPACK #-} !S.ByteString {-# 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
View File

@ -25,8 +25,9 @@ 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
@ -44,6 +45,9 @@ 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
@ -55,9 +59,7 @@ 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:"
@ -65,219 +67,204 @@ assertException ex msg m =
, "occured: " ++ show e , "occured: " ++ show e
] ]
withConn :: (Connection -> IO a) -> IO a testGet :: Test
withConn m = withConnection def $ \c -> precond c >> m c testGet = testGroup "get"
[ testGroup "IO module"
main :: IO () [ testGroup "get"
main = bracket startMemcached terminateProcess $ \_ -> hspec $ do [ doTest "foo" (0, "foovalue") McIO.get
v <- runIO $ withConn McIO.version , doTest "bar" (1, "1234567890") McIO.get
testGet , doTestException "notexist" McIO.get
testSetAddReplace ]
testDelete , testGroup "get_"
testIncrDecr v [ doTest "foo" "foovalue" McIO.get_
testFlush , doTest "bar" "1234567890" McIO.get_
testVersion , doTestException "notexist" McIO.get_
testNoOp ]
testAppendPrepend ]
testTouchGAT v , testGroup "Maybe module"
testModify [ testGroup "get"
[ doTest "foo" (Just (0, "foovalue")) McMaybe.get
testGet :: Spec , doTest "bar" (Just (1, "1234567890")) McMaybe.get
testGet = context "get" $ do , doTest "notexist" Nothing McMaybe.get
context "IO module" $ do ]
describe "get" $ do , testGroup "get_"
doTest "foo" (0, "foovalue") "get" McIO.get [ doTest "foo" (Just "foovalue") McMaybe.get_
doTest "bar" (1, "1234567890") "get" McIO.get , doTest "bar" (Just "1234567890") McMaybe.get_
doTestException "get" McIO.get , doTest "notexist" Nothing McMaybe.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 meth fn = it ("return " ++ show ex ++ " when " ++ meth ++ ' ': show key) $ withConn $ \c -> do doTest key ex fn = testMc (S.unpack key) $ \c -> do
v <- fn key c v <- fn key c
v @?= ex v @?= ex
doTestException meth fn = it ("throw exception(1) when " ++ meth ++ " notexist") $ withConn $ \c -> doTestException key fn = testMc (S.unpack key) $ \c ->
assertException 1 "Not found" $ fn "notexist" c assertException 1 "Not found" $ fn key c
testSetAddReplace :: Spec testSetAddReplace :: Test
testSetAddReplace = context "set/add/replace" $ do testSetAddReplace = testGroup "set/add/replace"
describe "set" $ do [ testGroup "set"
it "set foo = (100, foomod)" $ withConn $ \c -> do [ testMc "set foo to foomod" $ \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")
it "set notexist = exist" $ withConn $ \c -> do , testMc "set notexist to exist" $ \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")
]
describe "add" $ do , testGroup "add"
it "throw exception(2) when add exist key" $ withConn $ \c -> do [ testMc "add foo to foomod" $ \c ->
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
it "add notexist = exist" $ withConn $ \c -> do , testMc "add notexist to exist" $ \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")
]
describe "replace" $ do , testGroup "replace"
it "replace foo = foomod" $ withConn $ \c -> do [ testMc "set foo to foomod" $ \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")
it "throw exception(1) when replace not exist key" $ withConn $ \c -> do , testMc "set notexist to exist" $ \c ->
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 :: Spec testDelete = testGroup "delete"
testDelete = context "delete" $ do [ testGroup "IO module"
context "IO module" $ do [ testMc "foo" $ \c -> 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
it "throw exception(1) when delete notexist" $ withConn $ , testMc "notexist" $ \c ->
assertException 1 "Not found" . McIO.delete "notexist" assertException 1 "Not found" $ McIO.delete "notexist" c
]
context "Maybe module" $ do , testGroup "Maybe module"
it "delete foo" $ withConn $ \c -> do [ testMc "foo" $ \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
it "delete notexist" $ withConn $ \c -> do , testMc "notexist" $ \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 -> Spec testIncrDecr :: Version -> Test
testIncrDecr v = context "increment/decrement" $ do testIncrDecr v = testGroup "increment/decrement"
context "IO module" $ do [ testGroup "IO module"
describe "increment" $ do [ testGroup "increment"
it "throw exception(6) when increment non numeric value" $ withConn $ \c -> [ testMc "foo" $ \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
b @?= "10" when (v >= ev) $ b @?= "10"
]
describe "decrement" $ do , testGroup "decrement"
it "throw exception(6) when increment non numeric value" $ withConn $ \c -> [ testMc "foo" $ \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
b @?= "10" when (v >= ev) $ b @?= "10"
]
context "Maybe module" $ do ]
describe "increment" $ do , testGroup "Maybe module"
it "return Nothing when increment non numeric value" $ withConn $ \c -> do [ testGroup "increment"
[ 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"
it "increment bar" $ withConn $ \c -> do , testMc "bar" $ \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"
it "set initial value notexist" $ withConn $ \c -> do , testMc "notexist" $ \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
b @?= "10" when (v >= ev) $ b @?= "10"
]
describe "decrement" $ do , testGroup "decrement'"
it "return Nothing when decrement non numeric value" $ withConn $ \c -> do [ testMc "foo" $ \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"
it "decrement bar" $ withConn $ \c -> do , testMc "bar" $ \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"
it "set initial value notexist" $ withConn $ \c -> do , testMc "notexist" $ \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
b @?= "10" when (v >= ev) $ 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 :: Spec testFlush :: Test
testFlush = context "flush" $ do testFlush = testGroup "flush"
context "IO module" $ do [ testGroup "IO module"
describe "flushAll" $ do [ testMc "flushAll" $ \c -> do
it "flush all data" $ withConn $ \c -> do McIO.flushAll c
McIO.flushAll c a <- McMaybe.get "foo" c
a <- McMaybe.get "foo" c a @?= Nothing
a @?= Nothing ]
, testGroup "Maybe module"
[ testMc "flushAll" $ \c -> do
r <- McMaybe.flushAll c
a <- McMaybe.get "foo" c
r @?= True
a @?= Nothing
]
]
context "Maybe module" $ do testVersion :: Test
describe "flushAll" $ do testVersion = testGroup "version"
it "flush all data and return True" $ withConn $ \c -> do [ testGroup "versionString"
r <- McMaybe.flushAll c [ testMc "IO module" $ \c -> do
a <- McMaybe.get "foo" c v <- McIO.versionString c
r @?= True assertBool (show v ++ " is not version like.") $ isVersionLike v
a @?= Nothing , testMc "Maybe module" $ \c -> do
Just v <- McMaybe.versionString c
testVersion :: Spec assertBool (show v ++ " is not version like.") $ isVersionLike v
testVersion = context "version" $ do ]
context "IO module" $ do , testGroup "version"
describe "versionString" $ [ testMc "IO module" $ \c -> do
it "return version bytestring" $ withConn $ \c -> do v <- McIO.version c
v <- McIO.versionString c assertEqual "version branch length" 3 (length $ versionBranch v)
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
@ -287,198 +274,212 @@ testVersion = context "version" $ do
(_, s3) <- S.readInt (S.tail s2) (_, s3) <- S.readInt (S.tail s2)
unless (S.null s3) Nothing unless (S.null s3) Nothing
testNoOp :: Spec testNoOp :: Test
testNoOp = context "noOp" $ do testNoOp = testGroup "noOp"
context "IO module" $ [ testMc "IO module" McIO.noOp
it "is noop" $ withConn McIO.noOp , testMc "Maybe module" $ \c -> do
context "Maybe module" $ b <- McMaybe.noOp c
it "is noop and returns True" $ withConn $ \c -> do b @?= True
b <- McMaybe.noOp c ]
b @?= True
testAppendPrepend :: Spec testAppendPrepend :: Test
testAppendPrepend = context "append/prepend" $ do testAppendPrepend = testGroup "append/prepend"
context "IO module" $ do [ testGroup "IO module"
describe "append" $ do [ testGroup "append"
it "append !! to foo" $ withConn $ \c -> do [ testMc "foo" $ \c -> do
McIO.append "foo" "!!" c McIO.append "foo" "!!" c
a <- McIO.get_ "foo" c a <- McIO.get_ "foo" c
a @?= "foovalue!!" a @?= "foovalue!!"
it "append !! to bar" $ withConn $ \c -> do , testMc "bar" $ \c -> do
McIO.append "bar" "!!" c McIO.append "bar" "!!" c
a <- McIO.get_ "bar" c a <- McIO.get_ "bar" c
a @?= "1234567890!!" a @?= "1234567890!!"
it "throws exception(5) when not exist." $ withConn $ \c -> , testMc "notexist" $ \c ->
assertException 5 "Not stored." $ McIO.append "notexist" "!!" c assertException 5 "Not stored." $ McIO.append "notexist" "!!" c
]
describe "prepend" $ do , testGroup "prepend"
it "prepend !! to foo" $ withConn $ \c -> do [ testMc "foo" $ \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 ]
describe "append" $ do , testGroup "maybe module"
it "append !! to foo and return True" $ withConn $ \c -> do [ testGroup "append'"
[ 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
]
describe "prepend" $ do , testGroup "prepend'"
it "prepend !! to foo and return True" $ withConn $ \c -> do [ testMc "foo" $ \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
]
]
]
testTouchGAT :: Version -> Spec -- https://code.google.com/p/memcached/wiki/ReleaseNotes1414
testTouchGAT v = context "touch/GAT" $ do -- https://code.google.com/p/memcached/issues/detail?id=275
context "IO module" $ do testTouchGAT :: Version -> Test
describe "touch" $ do testTouchGAT v = testGroup "touch/GAT"
it "touch 1s and expire it." $ withConn $ \c -> do [ testGroup "IO module"
when (v < ev) $ pendingWith msg [ testGroup "touch"
[ 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")
threadDelay 1100000 when (v >= ev) $ do
b <- McMaybe.get_ "foo" c threadDelay 1100000
b @?= Nothing b <- McMaybe.get_ "foo" c
b @?= Nothing
it "throws exception(1) when not exist" $ withConn $ \c -> , testMc "notexist" $ \c ->
assertException 1 "Not found" $ McIO.touch 1 "notexist" c assertException 1 "Not found" $ McIO.touch 1 "notexist" c
]
describe "getAndTouch" $ do , testGroup "getAndTouch"
it "touch 1s, return (flag, value), and expire it" $ withConn $ \c -> do [ testMc "foo" $ \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")
threadDelay 1100000 when (v >= ev) $ do
z <- McMaybe.get "foo" c threadDelay 1100000
z @?= Nothing z <- McMaybe.get "foo" c
z @?= Nothing
it "throws exception(1) when not exist" $ withConn $ \c -> , testMc "notexist" $ \c ->
assertException 1 "Not found" $ McIO.getAndTouch 1 "notexist" c assertException 1 "Not found" $ McIO.getAndTouch 1 "notexist" c
]
describe "getAndTouch_" $ do , testGroup "getAndTouch_"
it "touch 1s, return value, and expire it" $ withConn $ \c -> do [ testMc "foo" $ \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"
threadDelay 1100000 when (v >= ev) $ do
z <- McMaybe.get_ "foo" c threadDelay 1100000
z @?= Nothing z <- McMaybe.get_ "foo" c
z @?= Nothing
it "throws exception(1) when not exist" $ withConn $ \c -> , testMc "notexist" $ \c ->
assertException 1 "Not found" $ McIO.getAndTouch_ 1 "notexist" c assertException 1 "Not found" $ McIO.getAndTouch_ 1 "notexist" c
]
context "Maybe module" $ do ]
describe "touch" $ do , testGroup "Maybe module"
it "touch 1s, return True, 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
r <- McMaybe.touch 1 "foo" c r <- McMaybe.touch 1 "foo" c
a @?= (Just "foovalue") a @?= (Just "foovalue")
r @?= True r @?= True
threadDelay 1100000 when (v >= ev) $ do
b <- McMaybe.get_ "foo" c threadDelay 1100000
b @?= Nothing b <- McMaybe.get_ "foo" c
b @?= Nothing
it "return False when not exist" $ withConn $ \c -> do , testMc "notexist" $ \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
]
describe "getAndTouch" $ do , testGroup "getAndTouch'/getMaybeAndTouch"
it "touch 1s, return (flag, value), 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.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")
threadDelay 1100000 when (v >= ev) $ do
b <- McMaybe.get_ "foo" c threadDelay 1100000
b @?= Nothing b <- McMaybe.get_ "foo" c
b @?= Nothing
it "return Nothing when not exist" $ withConn $ \c -> do , testMc "notexist" $ \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
]
describe "getAndTouch_" $ do , testGroup "getAndTouch'_/getMaybeAndTouch_"
it "touch 1s, return value, 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.getAndTouch_ 1 "foo" c r <- McMaybe.getAndTouch_ 1 "foo" c
a @?= Just "foovalue" a @?= Just "foovalue"
r @?= Just "foovalue" r @?= Just "foovalue"
threadDelay 1100000 when (v >= ev) $ do
b <- McMaybe.get_ "foo" c threadDelay 1100000
b @?= Nothing b <- McMaybe.get_ "foo" c
b @?= Nothing
it "return Nothing when not exist" $ withConn $ \c -> do , testMc "notexist" $ \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 :: Spec testModify :: Test
testModify = context "modify" $ do testModify = testGroup "modify"
context "IO monad" $ do [ testMc "reverse foo" $ \c -> do
describe "modify" $ do r <- McIO.modify 0 "foo" (\f v -> (f + 100, L.reverse v, v)) c
it "reverse foo value and return original" $ withConn $ \c -> do a <- McMaybe.get "foo" c
r <- McIO.modify 0 "foo" (\f v -> (f + 100, L.reverse v, v)) c r @?= "foovalue"
a <- McMaybe.get "foo" c a @?= Just (100, "eulavoof")
r @?= "foovalue" , testMc "notexist" $ \c ->
a @?= Just (100, "eulavoof") assertException 1 "Not found" $
McIO.modify 0 "notexist" (\f v -> (f,v,())) c
]
it "throw exception(1) when not exist" $ withConn $ \c -> do testModify_ :: Test
assertException 1 "Not found" $ testModify_ = testGroup "modify_"
McIO.modify 0 "notexist" (\f v -> (f,v,())) c [ testMc "reverse foo" $ \c -> do
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
assertException 1 "Not found" $ main :: IO ()
McIO.modify_ 0 "notexist" (\f v -> (f,v)) c 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_
]