Merge branch 'develop'
first release.
This commit is contained in:
philopon
commit
e3d32d90e4
3
README.md
Normal file
3
README.md
Normal file
@ -0,0 +1,3 @@
|
||||
memcached-binary [](https://travis-ci.org/philopon/memcached-binary)
|
||||
===
|
||||
memcached client using binary protocol.
|
||||
@ -9,14 +9,20 @@ copyright: (c) 2014 Hirotomo Moriwaki
|
||||
category: Database
|
||||
build-type: Simple
|
||||
cabal-version: >=1.10
|
||||
extra-source-files: src/Database/Memcached/Binary/Common.hs
|
||||
src/Database/Memcached/Binary/Header.txt
|
||||
|
||||
library
|
||||
exposed-modules: Database.Memcached.Binary
|
||||
Database.Memcached.Binary.Exception
|
||||
Database.Memcached.Binary.Maybe
|
||||
Database.Memcached.Binary.Either
|
||||
Database.Memcached.Binary.IO
|
||||
|
||||
Database.Memcached.Binary.Types
|
||||
Database.Memcached.Binary.Types.Exception
|
||||
Database.Memcached.Binary.Internal
|
||||
Database.Memcached.Binary.Internal.Definition
|
||||
build-depends: base >=4.7 && <4.8
|
||||
build-depends: base >=4.6 && <4.8
|
||||
, bytestring >=0.10 && <0.11
|
||||
, network >=2.6 && <2.7
|
||||
, storable-endian >=0.2 && <0.3
|
||||
@ -28,3 +34,19 @@ library
|
||||
ghc-options: -Wall -O2
|
||||
hs-source-dirs: src
|
||||
default-language: Haskell2010
|
||||
|
||||
test-suite test
|
||||
type: exitcode-stdio-1.0
|
||||
hs-source-dirs: test
|
||||
main-is: test.hs
|
||||
ghc-options: -Wall -O2
|
||||
build-depends: base >=4.6 && <4.8
|
||||
, memcached-binary
|
||||
, test-framework >=0.8 && <0.9
|
||||
, test-framework-hunit >=0.3 && <0.4
|
||||
, process >=1.2 && <1.3
|
||||
, network >=2.6 && <2.7
|
||||
, HUnit >=1.2 && <1.3
|
||||
, data-default-class >=0.0 && <0.1
|
||||
, bytestring >=0.10 && <0.11
|
||||
default-language: Haskell2010
|
||||
|
||||
@ -1,291 +1,5 @@
|
||||
{-# LANGUAGE FlexibleInstances #-}
|
||||
{-# LANGUAGE NoMonomorphismRestriction #-}
|
||||
|
||||
module Database.Memcached.Binary
|
||||
( -- * connection
|
||||
I.Connection, I.withConnection, I.connect, I.close
|
||||
-- * get
|
||||
, get, get_
|
||||
, get', get'_
|
||||
, getMaybe, getMaybe_
|
||||
-- * set
|
||||
, set, add, replace
|
||||
, set', add', replace'
|
||||
-- * delete
|
||||
, delete, delete'
|
||||
-- * increment/decrement
|
||||
, increment, decrement
|
||||
, increment', decrement'
|
||||
-- * flush
|
||||
, flushAll, flushAll'
|
||||
-- * version
|
||||
, version, version'
|
||||
-- * noOp
|
||||
, noOp, noOp'
|
||||
-- * append/prepend
|
||||
, append, prepend
|
||||
, append', prepend'
|
||||
-- * touch
|
||||
, touch, getAndTouch, getAndTouch_, getMaybeAndTouch
|
||||
, touch', getAndTouch', getAndTouch'_, getMaybeAndTouch_
|
||||
-- * modify
|
||||
, modify , modify_
|
||||
-- * reexports
|
||||
, module Database.Memcached.Binary.Types
|
||||
-- | def
|
||||
, module Data.Default.Class
|
||||
-- | PortID(..)
|
||||
, module Network
|
||||
module Database.Memcached.Binary {-# WARNING "use Database.Memcached.Binary.Maybe(or Either, IO) instead." #-}
|
||||
( module Database.Memcached.Binary.Maybe
|
||||
) where
|
||||
|
||||
import Control.Exception
|
||||
import Network(PortID(..))
|
||||
|
||||
import Data.Default.Class(def)
|
||||
|
||||
import qualified Data.ByteString as S
|
||||
|
||||
import Database.Memcached.Binary.Types
|
||||
import Database.Memcached.Binary.Exception
|
||||
import Database.Memcached.Binary.Internal.Definition
|
||||
import qualified Database.Memcached.Binary.Internal as I
|
||||
|
||||
failureIO :: I.Failure a
|
||||
failureIO w m = throwIO $ MemcachedException w m
|
||||
|
||||
failureMaybe :: I.Failure (Maybe a)
|
||||
failureMaybe _ _ = return Nothing
|
||||
|
||||
failureBool :: I.Failure Bool
|
||||
failureBool _ _ = return False
|
||||
|
||||
--------------------------------------------------------------------------------
|
||||
|
||||
-- | get value and flags. if error occured, throw MemcachedException.
|
||||
get :: Key -> I.Connection -> IO (Flags, Value)
|
||||
get = I.useConnection . I.get (\_ f v -> return (f,v)) failureIO
|
||||
|
||||
-- | get value and flags. if error occured, return Nothing.
|
||||
--
|
||||
-- @
|
||||
-- get' == getMaybe
|
||||
-- @
|
||||
getMaybe, get' :: Key -> I.Connection -> IO (Maybe (Flags, Value))
|
||||
getMaybe = I.useConnection . I.get (\_ f v -> return $ Just (f,v)) failureMaybe
|
||||
get' = getMaybe
|
||||
|
||||
-- | get value. if error occured, throw MemcachedException.
|
||||
get_ :: Key -> I.Connection -> IO Value
|
||||
get_ = I.useConnection . I.get (\_ _ v -> return v) failureIO
|
||||
|
||||
-- | get value. if error occured, return Nothing.
|
||||
--
|
||||
-- @
|
||||
-- get'_ == getMaybe_
|
||||
-- @
|
||||
getMaybe_, get'_ :: Key -> I.Connection -> IO (Maybe Value)
|
||||
getMaybe_ = I.useConnection . I.get (\_ _ v -> return $ Just v) failureMaybe
|
||||
get'_ = getMaybe_
|
||||
|
||||
--------------------------------------------------------------------------------
|
||||
|
||||
setAddReplace :: OpCode -> Flags -> Expiry
|
||||
-> Key -> Value -> I.Connection -> IO ()
|
||||
setAddReplace op = \f e key value -> I.useConnection $
|
||||
I.setAddReplace (const $ return ()) failureIO op (CAS 0) key value f e
|
||||
|
||||
-- | set value. if error occured, throw MemcachedException.
|
||||
set :: Flags -> Expiry -> Key -> Value -> I.Connection -> IO ()
|
||||
set = setAddReplace opSet
|
||||
|
||||
-- | add value. if error occured, throw MemcachedException.
|
||||
add :: Flags -> Expiry -> Key -> Value -> I.Connection -> IO ()
|
||||
add = setAddReplace opAdd
|
||||
|
||||
-- | replace value. if error occured, throw MemcachedException.
|
||||
replace :: Flags -> Expiry -> Key -> Value -> I.Connection -> IO ()
|
||||
replace = setAddReplace opReplace
|
||||
|
||||
setAddReplace' :: OpCode -> Flags -> Expiry
|
||||
-> Key -> Value -> I.Connection -> IO Bool
|
||||
setAddReplace' op = \f e key value -> I.useConnection $
|
||||
I.setAddReplace (const $ return True) failureBool op (CAS 0) key value f e
|
||||
|
||||
|
||||
-- | set value. if error occured, return False.
|
||||
set' :: Flags -> Expiry -> Key -> Value -> I.Connection -> IO Bool
|
||||
set' = setAddReplace' opSet
|
||||
|
||||
-- | add value. if error occured, return False.
|
||||
add' :: Flags -> Expiry -> Key -> Value -> I.Connection -> IO Bool
|
||||
add' = setAddReplace' opAdd
|
||||
|
||||
-- | replace value. if error occured, return False.
|
||||
replace' :: Flags -> Expiry -> Key -> Value -> I.Connection -> IO Bool
|
||||
replace' = setAddReplace' opReplace
|
||||
|
||||
--------------------------------------------------------------------------------
|
||||
|
||||
-- | delete value. if error occured, throw MemcachedException.
|
||||
delete :: Key -> I.Connection -> IO ()
|
||||
delete = I.useConnection . I.delete (\_ -> return ()) failureIO (CAS 0)
|
||||
|
||||
-- | delete value. if error occured, return False.
|
||||
delete' :: Key -> I.Connection -> IO Bool
|
||||
delete' = I.useConnection . I.delete (\_ -> return True) failureBool (CAS 0)
|
||||
|
||||
--------------------------------------------------------------------------------
|
||||
|
||||
-- | modify value in transaction. if error occured, throw MemcachedException.
|
||||
modify :: Expiry -> Key -> (Flags -> Value -> (Flags, Value, a))
|
||||
-> I.Connection -> IO a
|
||||
modify e key fn = I.useConnection $ \h ->
|
||||
I.get (\c f v ->
|
||||
let (f', v', r) = fn f v
|
||||
in I.setAddReplace (const $ return r) failureIO opSet c key v' f' e h
|
||||
) failureIO key h
|
||||
|
||||
-- | modify value in transaction. if error occured, throw MemcachedException.
|
||||
modify_ :: Expiry
|
||||
-> Key -> (Flags -> Value -> (Flags, Value))
|
||||
-> I.Connection -> IO ()
|
||||
modify_ e key fn = I.useConnection $ \h ->
|
||||
I.get (\c f v ->
|
||||
let (f', v') = fn f v
|
||||
in I.setAddReplace (const $ return ()) failureIO opSet c key v' f' e h
|
||||
) failureIO key h
|
||||
|
||||
--------------------------------------------------------------------------------
|
||||
|
||||
incrDecr :: OpCode -> Expiry
|
||||
-> Key -> Delta -> Initial -> I.Connection -> IO Counter
|
||||
incrDecr op = \e k d i -> I.useConnection $
|
||||
I.incrDecr (\_ w -> return w) failureIO op (CAS 0) k d i e
|
||||
|
||||
incrDecr' :: OpCode -> Expiry
|
||||
-> Key -> Delta -> Initial -> I.Connection -> IO (Maybe Counter)
|
||||
incrDecr' op e k d i = I.useConnection $
|
||||
I.incrDecr (\_ w -> return $ Just w) failureMaybe op (CAS 0) k d i e
|
||||
|
||||
|
||||
-- | increment value. if error occured, throw MemcachedException.
|
||||
increment :: Expiry -> Key -> Delta -> Initial -> I.Connection -> IO Counter
|
||||
increment = incrDecr opIncrement
|
||||
|
||||
-- | decrement value. if error occured, throw MemcachedException.
|
||||
decrement :: Expiry -> Key -> Delta -> Initial -> I.Connection -> IO Counter
|
||||
decrement = incrDecr opDecrement
|
||||
|
||||
-- | increment value. if error occured, return Nothing.
|
||||
increment' :: Expiry -> Key -> Delta -> Initial
|
||||
-> I.Connection -> IO (Maybe Counter)
|
||||
increment' = incrDecr' opIncrement
|
||||
|
||||
-- | decrement value. if error occured, return Nothing.
|
||||
decrement' :: Expiry -> Key -> Delta -> Initial
|
||||
-> I.Connection -> IO (Maybe Counter)
|
||||
decrement' = incrDecr' opDecrement
|
||||
|
||||
--------------------------------------------------------------------------------
|
||||
|
||||
-- | flush all value. if error occured, throw MemcachedException.
|
||||
flushAll :: I.Connection -> IO ()
|
||||
flushAll = I.useConnection $ I.flushAll (return ()) failureIO
|
||||
|
||||
-- | flush all value. if error occured, return False.
|
||||
flushAll' :: I.Connection -> IO Bool
|
||||
flushAll' = I.useConnection $ I.flushAll (return True) failureBool
|
||||
|
||||
--------------------------------------------------------------------------------
|
||||
|
||||
-- | get version string. if error occured, throw MemcachedException.
|
||||
version :: I.Connection -> IO S.ByteString
|
||||
version = I.useConnection $ I.version return failureIO
|
||||
|
||||
-- | get version string. if error occured, return False.
|
||||
version' :: I.Connection -> IO (Maybe S.ByteString)
|
||||
version' = I.useConnection $ I.version (return . Just) failureMaybe
|
||||
|
||||
--------------------------------------------------------------------------------
|
||||
|
||||
-- | noop(use for keepalive). if error occured, throw MemcachedException.
|
||||
noOp :: I.Connection -> IO ()
|
||||
noOp = I.useConnection $ I.noOp (return ()) failureIO
|
||||
|
||||
-- | noop(use for keepalive). if error occured, return False.
|
||||
noOp' :: I.Connection -> IO Bool
|
||||
noOp' = I.useConnection $ I.noOp (return True) failureBool
|
||||
|
||||
--------------------------------------------------------------------------------
|
||||
|
||||
appendPrepend :: OpCode -> Key -> Value -> I.Connection -> IO ()
|
||||
appendPrepend o = \k v -> I.useConnection $
|
||||
I.appendPrepend (\_ -> return ()) failureIO o (CAS 0) k v
|
||||
|
||||
appendPrepend' :: OpCode -> Key -> Value -> I.Connection -> IO Bool
|
||||
appendPrepend' o = \k v -> I.useConnection $
|
||||
I.appendPrepend (\_ -> return False) failureBool o (CAS 0) k v
|
||||
|
||||
-- | apeend value. if error occured, throw MemcachedException.
|
||||
append :: Key -> Value -> I.Connection -> IO ()
|
||||
append = appendPrepend opAppend
|
||||
|
||||
-- | prepend value. if error occured, throw MemcachedException.
|
||||
prepend :: Key -> Value -> I.Connection -> IO ()
|
||||
prepend = appendPrepend opPrepend
|
||||
|
||||
-- | append value. if error occured, return False.
|
||||
append' :: Key -> Value -> I.Connection -> IO Bool
|
||||
append' = appendPrepend' opAppend
|
||||
|
||||
-- | preppend value. if error occured, return False.
|
||||
prepend' :: Key -> Value -> I.Connection -> IO Bool
|
||||
prepend' = appendPrepend' opPrepend
|
||||
|
||||
--------------------------------------------------------------------------------
|
||||
|
||||
-- | change expiry. if error occured, throw MemcachedException.
|
||||
touch :: Key -> Expiry -> I.Connection -> IO ()
|
||||
touch k e = I.useConnection $
|
||||
I.touch (\_ _ _ -> return ()) failureIO opTouch k e
|
||||
|
||||
-- | change expiry. if error occured, return False.
|
||||
touch' :: Key -> Expiry -> I.Connection -> IO Bool
|
||||
touch' k e = I.useConnection $
|
||||
I.touch (\_ _ _ -> return True) failureBool opTouch k e
|
||||
|
||||
-- | get value and flags, then change expiry.
|
||||
-- if error occured, throw MemcachedException.
|
||||
getAndTouch :: Key -> Expiry -> I.Connection -> IO (Flags, Value)
|
||||
getAndTouch k e = I.useConnection $
|
||||
I.touch (\_ f v -> return (f,v)) failureIO opGAT k e
|
||||
|
||||
-- | get value and flags, then change expiry.
|
||||
-- if error occured, return Nothing.
|
||||
--
|
||||
-- @
|
||||
-- getMaybeAndTouch == getAndTouch'
|
||||
-- @
|
||||
getAndTouch', getMaybeAndTouch
|
||||
:: Key -> Expiry -> I.Connection -> IO (Maybe (Flags, Value))
|
||||
getAndTouch' k e = I.useConnection $
|
||||
I.touch (\_ f v -> return $ Just (f,v)) failureMaybe opGAT k e
|
||||
getMaybeAndTouch = getAndTouch'
|
||||
|
||||
-- | get value then change expiry.
|
||||
-- if error occured, throw MemcachedException.
|
||||
getAndTouch_ :: Key -> Expiry -> I.Connection -> IO Value
|
||||
getAndTouch_ k e = I.useConnection $
|
||||
I.touch (\_ _ v -> return v) failureIO opGAT k e
|
||||
|
||||
-- | get value then change expiry.
|
||||
-- if error occured, return Nothing.
|
||||
--
|
||||
-- @
|
||||
-- getMaybeAndTouch_ == getAndTouch'_
|
||||
-- @
|
||||
getAndTouch'_, getMaybeAndTouch_
|
||||
:: Key -> Expiry -> I.Connection -> IO (Maybe Value)
|
||||
getAndTouch'_ k e = I.useConnection $
|
||||
I.touch (\_ _ v -> return $ Just v) failureMaybe opGAT k e
|
||||
getMaybeAndTouch_ = getAndTouch'_
|
||||
import Database.Memcached.Binary.Maybe
|
||||
|
||||
130
src/Database/Memcached/Binary/Common.hs
Normal file
130
src/Database/Memcached/Binary/Common.hs
Normal file
@ -0,0 +1,130 @@
|
||||
|
||||
--------------------------------------------------------------------------------
|
||||
|
||||
get :: Key -> I.Connection -> IO (HasReturn (Flags, Value))
|
||||
get = I.useConnection . I.get (\f v -> successHasReturn (f,v)) failureHasReturn
|
||||
|
||||
get_ :: Key -> I.Connection -> IO (HasReturn Value)
|
||||
get_ = I.useConnection . I.get (\_ v -> successHasReturn v) failureHasReturn
|
||||
|
||||
--------------------------------------------------------------------------------
|
||||
|
||||
setAddReplace :: OpCode -> Flags -> Expiry
|
||||
-> Key -> Value -> I.Connection -> IO NoReturn
|
||||
setAddReplace op = \f e key value -> I.useConnection $
|
||||
I.setAddReplace successNoReturn failureNoReturn op (CAS 0) key value f e
|
||||
|
||||
|
||||
set :: Flags -> Expiry -> Key -> Value -> I.Connection -> IO NoReturn
|
||||
set = setAddReplace opSet
|
||||
|
||||
add :: Flags -> Expiry -> Key -> Value -> I.Connection -> IO NoReturn
|
||||
add = setAddReplace opAdd
|
||||
|
||||
replace :: Flags -> Expiry -> Key -> Value -> I.Connection -> IO NoReturn
|
||||
replace = setAddReplace opReplace
|
||||
|
||||
--------------------------------------------------------------------------------
|
||||
|
||||
delete :: Key -> I.Connection -> IO NoReturn
|
||||
delete = I.useConnection . I.delete successNoReturn failureNoReturn (CAS 0)
|
||||
|
||||
--------------------------------------------------------------------------------
|
||||
|
||||
-- | modify value in transaction.
|
||||
modify :: Expiry -> Key -> (Flags -> Value -> (Flags, Value, a))
|
||||
-> I.Connection -> IO (HasReturn a)
|
||||
modify e key fn = I.useConnection $ \h ->
|
||||
I.getWithCAS (\c f v ->
|
||||
let (f', v', r) = fn f v
|
||||
in I.setAddReplaceWithCAS (const $ successHasReturn r)
|
||||
failureHasReturn opSet c key v' f' e h
|
||||
) failureHasReturn key h
|
||||
|
||||
-- | modify value in transaction.
|
||||
modify_ :: Expiry
|
||||
-> Key -> (Flags -> Value -> (Flags, Value))
|
||||
-> I.Connection -> IO NoReturn
|
||||
modify_ e key fn = I.useConnection $ \h ->
|
||||
I.getWithCAS (\c f v ->
|
||||
let (f', v') = fn f v
|
||||
in I.setAddReplaceWithCAS (const $ successNoReturn)
|
||||
failureNoReturn opSet c key v' f' e h
|
||||
) failureNoReturn key h
|
||||
|
||||
--------------------------------------------------------------------------------
|
||||
|
||||
incrDecr :: OpCode -> Expiry
|
||||
-> Key -> Delta -> Initial -> I.Connection -> IO (HasReturn Counter)
|
||||
incrDecr op e k d i = I.useConnection $
|
||||
I.incrDecr successHasReturn failureHasReturn op (CAS 0) k d i e
|
||||
|
||||
increment :: Expiry -> Key -> Delta -> Initial
|
||||
-> I.Connection -> IO (HasReturn Counter)
|
||||
increment = incrDecr opIncrement
|
||||
|
||||
decrement :: Expiry -> Key -> Delta -> Initial
|
||||
-> I.Connection -> IO (HasReturn Counter)
|
||||
decrement = incrDecr opDecrement
|
||||
|
||||
--------------------------------------------------------------------------------
|
||||
|
||||
-- | flush all value.
|
||||
flushAll :: I.Connection -> IO NoReturn
|
||||
flushAll = I.useConnection $ I.flushAll successNoReturn failureNoReturn
|
||||
|
||||
--------------------------------------------------------------------------------
|
||||
|
||||
version :: I.Connection -> IO (HasReturn Version)
|
||||
version = I.useConnection $ I.version (\s -> case readVersion s of
|
||||
Nothing -> failureHasReturn (-1) "version parse failed"
|
||||
Just v -> successHasReturn v) failureHasReturn
|
||||
where
|
||||
readVersion s0 = do
|
||||
(x, s1) <- S8.readInt s0
|
||||
when (S8.null s1) $ Nothing
|
||||
(y, s2) <- S8.readInt (S8.tail s1)
|
||||
when (S8.null s2) $ Nothing
|
||||
(z, s3) <- S8.readInt (S8.tail s2)
|
||||
unless (S8.null s3) $ Nothing
|
||||
return (Version [x,y,z] [])
|
||||
|
||||
|
||||
-- | get version string.
|
||||
versionString :: I.Connection -> IO (HasReturn S.ByteString)
|
||||
versionString = I.useConnection $ I.version successHasReturn failureHasReturn
|
||||
|
||||
--------------------------------------------------------------------------------
|
||||
|
||||
-- | noop(use for keepalive).
|
||||
noOp :: I.Connection -> IO NoReturn
|
||||
noOp = I.useConnection $ I.noOp successNoReturn failureNoReturn
|
||||
|
||||
--------------------------------------------------------------------------------
|
||||
|
||||
appendPrepend :: OpCode -> Key -> Value -> I.Connection -> IO NoReturn
|
||||
appendPrepend o = \k v -> I.useConnection $
|
||||
I.appendPrepend successNoReturn failureNoReturn o (CAS 0) k v
|
||||
|
||||
append :: Key -> Value -> I.Connection -> IO NoReturn
|
||||
append = appendPrepend opAppend
|
||||
|
||||
prepend :: Key -> Value -> I.Connection -> IO NoReturn
|
||||
prepend = appendPrepend opPrepend
|
||||
|
||||
--------------------------------------------------------------------------------
|
||||
|
||||
-- | change expiry.
|
||||
touch :: Expiry -> Key -> I.Connection -> IO NoReturn
|
||||
touch e k = I.useConnection $
|
||||
I.touch (\_ _ -> successNoReturn) failureNoReturn opTouch k e
|
||||
|
||||
-- | get value/change expiry.
|
||||
getAndTouch :: Expiry -> Key -> I.Connection -> IO (HasReturn (Flags, Value))
|
||||
getAndTouch e k = I.useConnection $
|
||||
I.touch (\f v -> successHasReturn (f,v)) failureHasReturn opGAT k e
|
||||
|
||||
-- | get value/change expiry.
|
||||
getAndTouch_ :: Expiry -> Key -> I.Connection -> IO (HasReturn Value)
|
||||
getAndTouch_ e k = I.useConnection $
|
||||
I.touch (\_ v -> successHasReturn v) failureHasReturn opGAT k e
|
||||
29
src/Database/Memcached/Binary/Either.hs
Normal file
29
src/Database/Memcached/Binary/Either.hs
Normal file
@ -0,0 +1,29 @@
|
||||
{-# LANGUAGE FlexibleInstances #-}
|
||||
{-# LANGUAGE OverloadedStrings #-}
|
||||
{-# LANGUAGE NoMonomorphismRestriction #-}
|
||||
{-# LANGUAGE CPP #-}
|
||||
|
||||
module Database.Memcached.Binary.Either
|
||||
#include "Header.txt"
|
||||
|
||||
#define NoReturn (Maybe MemcachedException)
|
||||
#define HasReturn Either MemcachedException
|
||||
|
||||
successHasReturn :: a -> IO (HasReturn a)
|
||||
successHasReturn = return . Right
|
||||
{-# INLINE successHasReturn #-}
|
||||
|
||||
successNoReturn :: IO NoReturn
|
||||
successNoReturn = return Nothing
|
||||
{-# INLINE successNoReturn #-}
|
||||
|
||||
failureHasReturn :: I.Failure (HasReturn a)
|
||||
failureHasReturn i m = return . Left $ MemcachedException i m
|
||||
{-# INLINE failureHasReturn #-}
|
||||
|
||||
failureNoReturn :: I.Failure NoReturn
|
||||
failureNoReturn i m = return . Just $ MemcachedException i m
|
||||
{-# INLINE failureNoReturn #-}
|
||||
|
||||
#include "Common.hs"
|
||||
|
||||
48
src/Database/Memcached/Binary/Header.txt
Normal file
48
src/Database/Memcached/Binary/Header.txt
Normal file
@ -0,0 +1,48 @@
|
||||
( -- * connection
|
||||
I.Connection, I.withConnection, I.connect, I.close
|
||||
-- * get
|
||||
, get, get_
|
||||
-- * set
|
||||
, set, add, replace
|
||||
-- * delete
|
||||
, delete
|
||||
-- * increment/decrement
|
||||
, increment, decrement
|
||||
-- * flush
|
||||
, flushAll
|
||||
-- * version
|
||||
, version, versionString
|
||||
-- * noOp
|
||||
, noOp
|
||||
-- * append/prepend
|
||||
, append, prepend
|
||||
-- * touch
|
||||
, touch
|
||||
, getAndTouch
|
||||
, getAndTouch_
|
||||
|
||||
-- * modify
|
||||
, modify, modify_
|
||||
-- * reexports
|
||||
, module Database.Memcached.Binary.Types
|
||||
, module Database.Memcached.Binary.Types.Exception
|
||||
-- | def
|
||||
, module Data.Default.Class
|
||||
-- | PortID(..)
|
||||
, module Network
|
||||
) where
|
||||
|
||||
import Network(PortID(..))
|
||||
|
||||
import Control.Monad
|
||||
|
||||
import Data.Default.Class(def)
|
||||
import qualified Data.ByteString as S
|
||||
import qualified Data.ByteString.Char8 as S8
|
||||
|
||||
import Database.Memcached.Binary.Types
|
||||
import Database.Memcached.Binary.Types.Exception
|
||||
import Database.Memcached.Binary.Internal.Definition
|
||||
import qualified Database.Memcached.Binary.Internal as I
|
||||
|
||||
import Data.Version
|
||||
31
src/Database/Memcached/Binary/IO.hs
Normal file
31
src/Database/Memcached/Binary/IO.hs
Normal file
@ -0,0 +1,31 @@
|
||||
{-# LANGUAGE FlexibleInstances #-}
|
||||
{-# LANGUAGE OverloadedStrings #-}
|
||||
{-# LANGUAGE NoMonomorphismRestriction #-}
|
||||
{-# LANGUAGE CPP #-}
|
||||
|
||||
module Database.Memcached.Binary.IO
|
||||
#include "Header.txt"
|
||||
|
||||
import Control.Exception
|
||||
|
||||
#define NoReturn ()
|
||||
#define HasReturn
|
||||
|
||||
successHasReturn :: a -> IO (HasReturn a)
|
||||
successHasReturn = return
|
||||
{-# INLINE successHasReturn #-}
|
||||
|
||||
successNoReturn :: IO NoReturn
|
||||
successNoReturn = return ()
|
||||
{-# INLINE successNoReturn #-}
|
||||
|
||||
failureHasReturn :: I.Failure (HasReturn a)
|
||||
failureHasReturn i m = throwIO $ MemcachedException i m
|
||||
{-# INLINE failureHasReturn #-}
|
||||
|
||||
failureNoReturn :: I.Failure NoReturn
|
||||
failureNoReturn i m = throwIO $ MemcachedException i m
|
||||
{-# INLINE failureNoReturn #-}
|
||||
|
||||
#include "Common.hs"
|
||||
|
||||
@ -27,7 +27,7 @@ import qualified Data.ByteString.Lazy as L
|
||||
import qualified Data.ByteString.Unsafe as S
|
||||
|
||||
import Database.Memcached.Binary.Types
|
||||
import Database.Memcached.Binary.Exception
|
||||
import Database.Memcached.Binary.Types.Exception
|
||||
import Database.Memcached.Binary.Internal.Definition
|
||||
|
||||
data Connection
|
||||
@ -65,7 +65,7 @@ close (Connection mv) = do
|
||||
h <- swapMVar mv (error "connection already closed")
|
||||
quit h
|
||||
hClose h
|
||||
close _ = return ()
|
||||
close (ConnectionPool p) = destroyAllResources p
|
||||
|
||||
useConnection :: (Handle -> IO a) -> Connection -> IO a
|
||||
useConnection f (Connection mv) = withMVar mv f
|
||||
@ -186,34 +186,45 @@ inspectResponse h p = do
|
||||
v <- L.hGet h $ fromIntegral tl - fromIntegral el - fromIntegral kl
|
||||
return (e,k,v)
|
||||
|
||||
getSuccessCallback :: (CAS -> Flags -> Value -> IO a)
|
||||
getSuccessCallback :: (Flags -> Value -> IO a)
|
||||
-> Handle -> Ptr Header -> IO a
|
||||
getSuccessCallback success h p = do
|
||||
elen <- getExtraLength p
|
||||
tlen <- getTotalLength p
|
||||
cas <- getCAS p
|
||||
void $ hGetBuf h p 4
|
||||
flags <- peekWord32be p
|
||||
value <- L.hGet h (fromIntegral tlen - fromIntegral elen)
|
||||
success cas flags value
|
||||
success flags value
|
||||
|
||||
get :: (CAS -> Flags -> Value -> IO a) -> Failure a
|
||||
get :: (Flags -> Value -> IO a) -> Failure a
|
||||
-> Key -> Handle -> IO a
|
||||
get success failure key =
|
||||
withRequest opGet key 0 nop 0 nop (CAS 0)
|
||||
(getSuccessCallback success) failure
|
||||
|
||||
setAddReplace :: (CAS -> IO a) -> Failure a -> OpCode -> CAS
|
||||
getWithCAS :: (CAS -> Flags -> Value -> IO a) -> Failure a
|
||||
-> Key -> Handle -> IO a
|
||||
getWithCAS success failure key =
|
||||
withRequest opGet key 0 nop 0 nop (CAS 0)
|
||||
(\h p -> getCAS p >>= \c -> getSuccessCallback (success c) h p) failure
|
||||
|
||||
setAddReplace :: IO a -> Failure a -> OpCode -> CAS
|
||||
-> Key -> Value -> Flags -> Expiry -> Handle -> IO a
|
||||
setAddReplace success failure o cas key value flags expiry = withRequest o key
|
||||
8 (\p -> pokeWord32be p flags >> pokeWord32be (plusPtr p 4) expiry)
|
||||
(fromIntegral $ L.length value) (flip pokeLazyByteString value) cas (\_ _ -> success) failure
|
||||
|
||||
setAddReplaceWithCAS :: (CAS -> IO a) -> Failure a -> OpCode -> CAS
|
||||
-> Key -> Value -> Flags -> Expiry -> Handle -> IO a
|
||||
setAddReplaceWithCAS success failure o cas key value flags expiry = withRequest o key
|
||||
8 (\p -> pokeWord32be p flags >> pokeWord32be (plusPtr p 4) expiry)
|
||||
(fromIntegral $ L.length value) (flip pokeLazyByteString value) cas (\_ p -> getCAS p >>= success) failure
|
||||
|
||||
delete :: (CAS -> IO a) -> Failure a -> CAS -> Key -> Handle -> IO a
|
||||
delete :: IO a -> Failure a -> CAS -> Key -> Handle -> IO a
|
||||
delete success failure cas key =
|
||||
withRequest opDelete key 0 nop 0 nop cas (\_ p -> getCAS p >>= success) failure
|
||||
withRequest opDelete key 0 nop 0 nop cas (\_ _ -> success) failure
|
||||
|
||||
incrDecr :: (CAS -> Word64 -> IO a) -> Failure a -> OpCode -> CAS
|
||||
incrDecr :: (Word64 -> IO a) -> Failure a -> OpCode -> CAS
|
||||
-> Key -> Delta -> Initial -> Expiry -> Handle -> IO a
|
||||
incrDecr success failure op cas key delta initial expiry =
|
||||
withRequest op key 20 extra 0 nop cas success' failure
|
||||
@ -224,9 +235,8 @@ incrDecr success failure op cas key delta initial expiry =
|
||||
pokeWord32be (plusPtr p 16) expiry
|
||||
|
||||
success' h p = do
|
||||
c <- getCAS p
|
||||
void $ hGetBuf h p 8
|
||||
peekWord64be p >>= success c
|
||||
peekWord64be p >>= success
|
||||
|
||||
quit :: Handle -> IO ()
|
||||
quit h = do
|
||||
@ -251,11 +261,11 @@ version success =
|
||||
withRequest opVersion "" 0 nop 0 nop (CAS 0)
|
||||
(\h p -> getTotalLength p >>= S.hGet h . fromIntegral >>= success)
|
||||
|
||||
appendPrepend :: (CAS -> IO a) -> Failure a -> OpCode -> CAS
|
||||
appendPrepend :: IO a -> Failure a -> OpCode -> CAS
|
||||
-> Key -> Value -> Handle -> IO a
|
||||
appendPrepend success failure op cas key value = withRequest op key 0 nop
|
||||
(fromIntegral $ L.length value) (flip pokeLazyByteString value)
|
||||
cas (\_ -> getCAS >=> success) failure
|
||||
cas (\_ _ -> success) failure
|
||||
|
||||
stats :: Handle -> IO (H.HashMap S.ByteString S.ByteString)
|
||||
stats h = loop H.empty
|
||||
@ -277,7 +287,7 @@ verbosity :: IO a -> Failure a -> Word32 -> Handle -> IO a
|
||||
verbosity success failure v = withRequest opVerbosity ""
|
||||
4 (flip pokeWord32be v) 0 nop (CAS 0) (\_ _ -> success) failure
|
||||
|
||||
touch :: (CAS -> Flags -> Value -> IO a) -> Failure a -> OpCode
|
||||
touch :: (Flags -> Value -> IO a) -> Failure a -> OpCode
|
||||
-> Key -> Expiry -> Handle -> IO a
|
||||
touch success failure op key e =
|
||||
withRequest op key 4 (flip pokeWord32be e) 0 nop (CAS 0)
|
||||
|
||||
28
src/Database/Memcached/Binary/Maybe.hs
Normal file
28
src/Database/Memcached/Binary/Maybe.hs
Normal file
@ -0,0 +1,28 @@
|
||||
{-# LANGUAGE FlexibleInstances #-}
|
||||
{-# LANGUAGE OverloadedStrings #-}
|
||||
{-# LANGUAGE NoMonomorphismRestriction #-}
|
||||
{-# LANGUAGE CPP #-}
|
||||
|
||||
module Database.Memcached.Binary.Maybe
|
||||
#include "Header.txt"
|
||||
|
||||
#define NoReturn Bool
|
||||
#define HasReturn Maybe
|
||||
|
||||
successHasReturn :: a -> IO (HasReturn a)
|
||||
successHasReturn = return . Just
|
||||
{-# INLINE successHasReturn #-}
|
||||
|
||||
successNoReturn :: IO NoReturn
|
||||
successNoReturn = return True
|
||||
{-# INLINE successNoReturn #-}
|
||||
|
||||
failureHasReturn :: I.Failure (HasReturn a)
|
||||
failureHasReturn _ _ = return Nothing
|
||||
{-# INLINE failureHasReturn #-}
|
||||
|
||||
failureNoReturn :: I.Failure NoReturn
|
||||
failureNoReturn _ _ = return False
|
||||
{-# INLINE failureNoReturn #-}
|
||||
|
||||
#include "Common.hs"
|
||||
@ -23,6 +23,10 @@ data ConnectInfo = ConnectInfo
|
||||
, connectionIdleTime :: NominalDiffTime
|
||||
} deriving Show
|
||||
|
||||
-- |
|
||||
-- @
|
||||
-- def = ConnectInfo "localhost" (PortNumber 11211) [] 1 20
|
||||
-- @
|
||||
instance Default ConnectInfo where
|
||||
def = ConnectInfo "localhost" (PortNumber 11211) [] 1 20
|
||||
|
||||
|
||||
@ -1,7 +1,7 @@
|
||||
{-# LANGUAGE DeriveDataTypeable #-}
|
||||
{-# LANGUAGE CPP #-}
|
||||
|
||||
module Database.Memcached.Binary.Exception where
|
||||
module Database.Memcached.Binary.Types.Exception where
|
||||
|
||||
import Control.Exception
|
||||
import Data.Word
|
||||
485
test/test.hs
Normal file
485
test/test.hs
Normal file
@ -0,0 +1,485 @@
|
||||
{-# LANGUAGE OverloadedStrings #-}
|
||||
{-# LANGUAGE ScopedTypeVariables #-}
|
||||
{-# LANGUAGE DeriveDataTypeable #-}
|
||||
{-# LANGUAGE LambdaCase #-}
|
||||
|
||||
module Main (main) where
|
||||
|
||||
import Network
|
||||
import System.Process
|
||||
|
||||
import Control.Exception
|
||||
import Control.Concurrent
|
||||
import Control.Monad
|
||||
|
||||
import Data.Default.Class
|
||||
import Data.Maybe
|
||||
import Data.Word
|
||||
import Data.Typeable
|
||||
import Data.Version
|
||||
import qualified Data.ByteString.Char8 as S
|
||||
import qualified Data.ByteString.Lazy.Char8 as L
|
||||
|
||||
import Database.Memcached.Binary.Types.Exception
|
||||
import Database.Memcached.Binary.IO (Connection, withConnection)
|
||||
import qualified Database.Memcached.Binary.IO as McIO
|
||||
import qualified Database.Memcached.Binary.Maybe as McMaybe
|
||||
|
||||
import Test.HUnit hiding (Test)
|
||||
import Test.Framework
|
||||
import Test.Framework.Providers.HUnit
|
||||
|
||||
startMemcached :: IO ProcessHandle
|
||||
startMemcached = do
|
||||
h <- spawnProcess "memcached" []
|
||||
wait (100 :: Int)
|
||||
return h
|
||||
where
|
||||
wait 0 = fail "cannot start server"
|
||||
wait i = handle (\(_ ::SomeException) -> threadDelay 100000 >> wait (i-1)) $
|
||||
void $ connectTo "localhost" $ PortNumber 11211
|
||||
|
||||
precond :: Connection -> IO ()
|
||||
precond c = do
|
||||
McIO.flushAll c
|
||||
void $ McIO.set 0 0 "foo" "foovalue" 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)
|
||||
instance Show ByPassException where
|
||||
show (ByPassException s) = s
|
||||
|
||||
instance Exception ByPassException
|
||||
|
||||
assertException :: Word16 -> S.ByteString -> IO a -> IO ()
|
||||
assertException ex msg m =
|
||||
(m >> throwIO (ByPassException "exception not occured.")) `catch`
|
||||
(\e -> case fromException e :: Maybe MemcachedException of
|
||||
Nothing -> assertFn e
|
||||
Just e'@(MemcachedException i _) -> unless (i == ex) (assertFn e'))
|
||||
where
|
||||
assertFn e = assertFailure $ unlines
|
||||
[ "not expected exception occured:"
|
||||
, "expected: " ++ show (MemcachedException ex msg)
|
||||
, "occured: " ++ show e
|
||||
]
|
||||
|
||||
testGet :: Test
|
||||
testGet = testGroup "get"
|
||||
[ testGroup "IO module"
|
||||
[ testGroup "get"
|
||||
[ doTest "foo" (0, "foovalue") McIO.get
|
||||
, doTest "bar" (1, "1234567890") McIO.get
|
||||
, doTestException "notexist" McIO.get
|
||||
]
|
||||
, testGroup "get_"
|
||||
[ doTest "foo" "foovalue" McIO.get_
|
||||
, doTest "bar" "1234567890" McIO.get_
|
||||
, doTestException "notexist" McIO.get_
|
||||
]
|
||||
]
|
||||
, testGroup "Maybe module"
|
||||
[ testGroup "get"
|
||||
[ doTest "foo" (Just (0, "foovalue")) McMaybe.get
|
||||
, doTest "bar" (Just (1, "1234567890")) McMaybe.get
|
||||
, doTest "notexist" Nothing McMaybe.get
|
||||
]
|
||||
, testGroup "get_"
|
||||
[ doTest "foo" (Just "foovalue") McMaybe.get_
|
||||
, doTest "bar" (Just "1234567890") McMaybe.get_
|
||||
, doTest "notexist" Nothing McMaybe.get_
|
||||
]
|
||||
]
|
||||
]
|
||||
where
|
||||
doTest key ex fn = testMc (S.unpack key) $ \c -> do
|
||||
v <- fn key c
|
||||
v @?= ex
|
||||
doTestException key fn = testMc (S.unpack key) $ \c ->
|
||||
assertException 1 "Not found" $ fn key c
|
||||
|
||||
testSetAddReplace :: Test
|
||||
testSetAddReplace = testGroup "set/add/replace"
|
||||
[ testGroup "set"
|
||||
[ testMc "set foo to foomod" $ \c -> do
|
||||
McIO.set 100 0 "foo" "foomod" c
|
||||
v <- McIO.get "foo" c
|
||||
v @?= (100, "foomod")
|
||||
, testMc "set notexist to exist" $ \c -> do
|
||||
McIO.set 100 0 "notexist" "exist" c
|
||||
v <- McIO.get "notexist" c
|
||||
v @?= (100, "exist")
|
||||
]
|
||||
, testGroup "add"
|
||||
[ testMc "add foo to foomod" $ \c ->
|
||||
assertException 2 "Data exists for key." $
|
||||
McIO.add 100 0 "foo" "foomod" c
|
||||
, testMc "add notexist to exist" $ \c -> do
|
||||
McIO.add 100 0 "notexist" "exist" c
|
||||
v <- McIO.get "notexist" c
|
||||
v @?= (100, "exist")
|
||||
]
|
||||
, testGroup "replace"
|
||||
[ testMc "set foo to foomod" $ \c -> do
|
||||
McIO.replace 100 0 "foo" "foomod" c
|
||||
v <- McIO.get "foo" c
|
||||
v @?= (100, "foomod")
|
||||
, testMc "set notexist to exist" $ \c ->
|
||||
assertException 1 "Not found" $
|
||||
McIO.replace 100 0 "notexist" "exist" c
|
||||
]
|
||||
]
|
||||
|
||||
testDelete :: Test
|
||||
testDelete = testGroup "delete"
|
||||
[ testGroup "IO module"
|
||||
[ testMc "foo" $ \c -> do
|
||||
McIO.delete "foo" c
|
||||
r <- McMaybe.get "foo" c
|
||||
r @?= Nothing
|
||||
, testMc "notexist" $ \c ->
|
||||
assertException 1 "Not found" $ McIO.delete "notexist" c
|
||||
]
|
||||
, testGroup "Maybe module"
|
||||
[ testMc "foo" $ \c -> do
|
||||
b <- McMaybe.delete "foo" c
|
||||
r <- McMaybe.get "foo" c
|
||||
b @?= True
|
||||
r @?= Nothing
|
||||
, testMc "notexist" $ \c -> do
|
||||
b <- McMaybe.delete "notexist" c
|
||||
r <- McMaybe.get "notexist" c
|
||||
b @?= False
|
||||
r @?= Nothing
|
||||
]
|
||||
]
|
||||
|
||||
-- https://code.google.com/p/memcached/wiki/ReleaseNotes1417
|
||||
testIncrDecr :: Version -> Test
|
||||
testIncrDecr v = testGroup "increment/decrement"
|
||||
[ testGroup "IO module"
|
||||
[ testGroup "increment"
|
||||
[ testMc "foo" $ \c ->
|
||||
assertException 6 "Non-numeric server-side value for incr or decr" $
|
||||
McIO.increment 0 "foo" 10 10 c
|
||||
, testMc "bar" $ \c -> do
|
||||
a <- McIO.increment 0 "bar" 10 10 c
|
||||
b <- McIO.get_ "bar" c
|
||||
a @?= 1234567900
|
||||
b @?= "1234567900"
|
||||
, testMc "notexist" $ \c -> do
|
||||
a <- McIO.increment 0 "notexist" 10 10 c
|
||||
b <- McIO.get_ "notexist" c
|
||||
a @?= 10
|
||||
when (v >= ev) $ b @?= "10"
|
||||
]
|
||||
, testGroup "decrement"
|
||||
[ testMc "foo" $ \c ->
|
||||
assertException 6 "Non-numeric server-side value for incr or decr" $
|
||||
McIO.decrement 0 "foo" 10 10 c
|
||||
, testMc "bar" $ \c -> do
|
||||
a <- McIO.decrement 0 "bar" 10 10 c
|
||||
b <- McIO.get_ "bar" c
|
||||
a @?= 1234567880
|
||||
b @?= "1234567880"
|
||||
, testMc "notexist" $ \c -> do
|
||||
a <- McIO.decrement 0 "notexist" 10 10 c
|
||||
b <- McIO.get_ "notexist" c
|
||||
a @?= 10
|
||||
when (v >= ev) $ b @?= "10"
|
||||
]
|
||||
]
|
||||
, testGroup "Maybe module"
|
||||
[ testGroup "increment"
|
||||
[ testMc "foo" $ \c -> do
|
||||
r <- McMaybe.increment 0 "foo" 10 10 c
|
||||
b <- McIO.get_ "foo" c
|
||||
r @?= Nothing
|
||||
b @?= "foovalue"
|
||||
, testMc "bar" $ \c -> do
|
||||
a <- McMaybe.increment 0 "bar" 10 10 c
|
||||
b <- McIO.get_ "bar" c
|
||||
a @?= Just 1234567900
|
||||
b @?= "1234567900"
|
||||
, testMc "notexist" $ \c -> do
|
||||
a <- McMaybe.increment 0 "notexist" 10 10 c
|
||||
b <- McIO.get_ "notexist" c
|
||||
a @?= Just 10
|
||||
when (v >= ev) $ b @?= "10"
|
||||
]
|
||||
, testGroup "decrement'"
|
||||
[ testMc "foo" $ \c -> do
|
||||
r <- McMaybe.decrement 0 "foo" 10 10 c
|
||||
b <- McIO.get_ "foo" c
|
||||
r @?= Nothing
|
||||
b @?= "foovalue"
|
||||
, testMc "bar" $ \c -> do
|
||||
a <- McMaybe.decrement 0 "bar" 10 10 c
|
||||
b <- McIO.get_ "bar" c
|
||||
a @?= Just 1234567880
|
||||
b @?= "1234567880"
|
||||
, testMc "notexist" $ \c -> do
|
||||
a <- McMaybe.decrement 0 "notexist" 10 10 c
|
||||
b <- McIO.get_ "notexist" c
|
||||
a @?= Just 10
|
||||
when (v >= ev) $ b @?= "10"
|
||||
]
|
||||
]
|
||||
]
|
||||
where
|
||||
ev = Version [1,4,17] []
|
||||
|
||||
testFlush :: Test
|
||||
testFlush = testGroup "flush"
|
||||
[ testGroup "IO module"
|
||||
[ testMc "flushAll" $ \c -> do
|
||||
McIO.flushAll c
|
||||
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
|
||||
testVersion = testGroup "version"
|
||||
[ testGroup "versionString"
|
||||
[ testMc "IO module" $ \c -> do
|
||||
v <- McIO.versionString c
|
||||
assertBool (show v ++ " is not version like.") $ isVersionLike v
|
||||
, testMc "Maybe module" $ \c -> do
|
||||
Just v <- McMaybe.versionString c
|
||||
assertBool (show v ++ " is not version like.") $ isVersionLike v
|
||||
]
|
||||
, testGroup "version"
|
||||
[ testMc "IO module" $ \c -> do
|
||||
v <- McIO.version c
|
||||
assertEqual "version branch length" 3 (length $ versionBranch v)
|
||||
]
|
||||
]
|
||||
where
|
||||
isVersionLike s0 = isJust $ do
|
||||
(_, s1) <- S.readInt s0
|
||||
unless (S.head s1 == '.') Nothing
|
||||
(_, s2) <- S.readInt (S.tail s1)
|
||||
unless (S.head s2 == '.') Nothing
|
||||
(_, s3) <- S.readInt (S.tail s2)
|
||||
unless (S.null s3) Nothing
|
||||
|
||||
testNoOp :: Test
|
||||
testNoOp = testGroup "noOp"
|
||||
[ testMc "IO module" McIO.noOp
|
||||
, testMc "Maybe module" $ \c -> do
|
||||
b <- McMaybe.noOp c
|
||||
b @?= True
|
||||
]
|
||||
|
||||
testAppendPrepend :: Test
|
||||
testAppendPrepend = testGroup "append/prepend"
|
||||
[ testGroup "IO module"
|
||||
[ testGroup "append"
|
||||
[ testMc "foo" $ \c -> do
|
||||
McIO.append "foo" "!!" c
|
||||
a <- McIO.get_ "foo" c
|
||||
a @?= "foovalue!!"
|
||||
, testMc "bar" $ \c -> do
|
||||
McIO.append "bar" "!!" c
|
||||
a <- McIO.get_ "bar" c
|
||||
a @?= "1234567890!!"
|
||||
, testMc "notexist" $ \c ->
|
||||
assertException 5 "Not stored." $ McIO.append "notexist" "!!" c
|
||||
]
|
||||
, testGroup "prepend"
|
||||
[ testMc "foo" $ \c -> do
|
||||
McIO.prepend "foo" "!!" c
|
||||
a <- McIO.get_ "foo" c
|
||||
a @?= "!!foovalue"
|
||||
, testMc "bar" $ \c -> do
|
||||
McIO.prepend "bar" "!!" c
|
||||
a <- McIO.get_ "bar" c
|
||||
a @?= "!!1234567890"
|
||||
, testMc "notexist" $ \c ->
|
||||
assertException 5 "Not stored." $ McIO.prepend "notexist" "!!" c
|
||||
]
|
||||
]
|
||||
, testGroup "maybe module"
|
||||
[ testGroup "append'"
|
||||
[ testMc "foo" $ \c -> do
|
||||
b <- McMaybe.append "foo" "!!" c
|
||||
a <- McIO.get_ "foo" c
|
||||
b @?= True
|
||||
a @?= "foovalue!!"
|
||||
, testMc "bar" $ \c -> do
|
||||
b <- McMaybe.append "bar" "!!" c
|
||||
a <- McIO.get_ "bar" c
|
||||
b @?= True
|
||||
a @?= "1234567890!!"
|
||||
, testMc "notexist" $ \c -> do
|
||||
b <- McMaybe.append "notexist" "!!" c
|
||||
b @?= False
|
||||
]
|
||||
, testGroup "prepend'"
|
||||
[ testMc "foo" $ \c -> do
|
||||
b <- McMaybe.prepend "foo" "!!" c
|
||||
a <- McIO.get_ "foo" c
|
||||
b @?= True
|
||||
a @?= "!!foovalue"
|
||||
, testMc "bar" $ \c -> do
|
||||
b <- McMaybe.prepend "bar" "!!" c
|
||||
a <- McIO.get_ "bar" c
|
||||
b @?= True
|
||||
a @?= "!!1234567890"
|
||||
, testMc "notexist" $ \c -> do
|
||||
b <- McMaybe.prepend "notexist" "!!" c
|
||||
b @?= False
|
||||
]
|
||||
]
|
||||
]
|
||||
|
||||
-- https://code.google.com/p/memcached/wiki/ReleaseNotes1414
|
||||
-- https://code.google.com/p/memcached/issues/detail?id=275
|
||||
testTouchGAT :: Version -> Test
|
||||
testTouchGAT v = testGroup "touch/GAT"
|
||||
[ testGroup "IO module"
|
||||
[ testGroup "touch"
|
||||
[ testMc "foo" $ \c -> do
|
||||
a <- McMaybe.get_ "foo" c
|
||||
McIO.touch 1 "foo" c
|
||||
a @?= (Just "foovalue")
|
||||
when (v >= ev) $ do
|
||||
threadDelay 1100000
|
||||
b <- McMaybe.get_ "foo" c
|
||||
b @?= Nothing
|
||||
, testMc "notexist" $ \c ->
|
||||
assertException 1 "Not found" $ McIO.touch 1 "notexist" c
|
||||
]
|
||||
, testGroup "getAndTouch"
|
||||
[ testMc "foo" $ \c -> do
|
||||
x <- McMaybe.get "foo" c
|
||||
y <- McIO.getAndTouch 1 "foo" c
|
||||
x @?= Just (0, "foovalue")
|
||||
y @?= (0, "foovalue")
|
||||
when (v >= ev) $ do
|
||||
threadDelay 1100000
|
||||
z <- McMaybe.get "foo" c
|
||||
z @?= Nothing
|
||||
, testMc "notexist" $ \c ->
|
||||
assertException 1 "Not found" $ McIO.getAndTouch 1 "notexist" c
|
||||
]
|
||||
, testGroup "getAndTouch_"
|
||||
[ testMc "foo" $ \c -> do
|
||||
x <- McMaybe.get_ "foo" c
|
||||
y <- McIO.getAndTouch_ 1 "foo" c
|
||||
x @?= Just "foovalue"
|
||||
y @?= "foovalue"
|
||||
when (v >= ev) $ do
|
||||
threadDelay 1100000
|
||||
z <- McMaybe.get_ "foo" c
|
||||
z @?= Nothing
|
||||
, testMc "notexist" $ \c ->
|
||||
assertException 1 "Not found" $ McIO.getAndTouch_ 1 "notexist" c
|
||||
]
|
||||
]
|
||||
, testGroup "Maybe module"
|
||||
[ testGroup "touch"
|
||||
[ testMc "foo" $ \c -> do
|
||||
a <- McMaybe.get_ "foo" c
|
||||
r <- McMaybe.touch 1 "foo" c
|
||||
a @?= (Just "foovalue")
|
||||
r @?= True
|
||||
when (v >= ev) $ do
|
||||
threadDelay 1100000
|
||||
b <- McMaybe.get_ "foo" c
|
||||
b @?= Nothing
|
||||
, testMc "notexist" $ \c -> do
|
||||
r <- McMaybe.touch 1 "notexist" c
|
||||
a <- McMaybe.get "notexist" c
|
||||
r @?= False
|
||||
a @?= Nothing
|
||||
]
|
||||
, testGroup "getAndTouch'/getMaybeAndTouch"
|
||||
[ testMc "foo" $ \c -> do
|
||||
a <- McMaybe.get "foo" c
|
||||
r <- McMaybe.getAndTouch 1 "foo" c
|
||||
a @?= Just (0, "foovalue")
|
||||
r @?= Just (0, "foovalue")
|
||||
when (v >= ev) $ do
|
||||
threadDelay 1100000
|
||||
b <- McMaybe.get_ "foo" c
|
||||
b @?= Nothing
|
||||
, testMc "notexist" $ \c -> do
|
||||
r <- McMaybe.getAndTouch 1 "notexist" c
|
||||
a <- McMaybe.get "notexist" c
|
||||
r @?= Nothing
|
||||
a @?= Nothing
|
||||
]
|
||||
, testGroup "getAndTouch'_/getMaybeAndTouch_"
|
||||
[ testMc "foo" $ \c -> do
|
||||
a <- McMaybe.get_ "foo" c
|
||||
r <- McMaybe.getAndTouch_ 1 "foo" c
|
||||
a @?= Just "foovalue"
|
||||
r @?= Just "foovalue"
|
||||
when (v >= ev) $ do
|
||||
threadDelay 1100000
|
||||
b <- McMaybe.get_ "foo" c
|
||||
b @?= Nothing
|
||||
, testMc "notexist" $ \c -> do
|
||||
r <- McMaybe.getAndTouch_ 1 "notexist" c
|
||||
a <- McMaybe.get "notexist" c
|
||||
r @?= Nothing
|
||||
a @?= Nothing
|
||||
]
|
||||
]
|
||||
]
|
||||
where
|
||||
ev = Version [1,4,14] []
|
||||
|
||||
testModify :: Test
|
||||
testModify = testGroup "modify"
|
||||
[ testMc "reverse foo" $ \c -> do
|
||||
r <- McIO.modify 0 "foo" (\f v -> (f + 100, L.reverse v, v)) c
|
||||
a <- McMaybe.get "foo" c
|
||||
r @?= "foovalue"
|
||||
a @?= Just (100, "eulavoof")
|
||||
, testMc "notexist" $ \c ->
|
||||
assertException 1 "Not found" $
|
||||
McIO.modify 0 "notexist" (\f v -> (f,v,())) c
|
||||
]
|
||||
|
||||
testModify_ :: Test
|
||||
testModify_ = testGroup "modify_"
|
||||
[ 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
|
||||
]
|
||||
|
||||
|
||||
|
||||
main :: IO ()
|
||||
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_
|
||||
]
|
||||
Loading…
Reference in New Issue
Block a user