add tests, change module structure, api.
This commit is contained in:
philopon
parent
08973f15ba
commit
5696afaa75
@ -12,8 +12,12 @@ cabal-version: >=1.10
|
||||
|
||||
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.6 && <4.8
|
||||
@ -40,4 +44,6 @@ test-suite test
|
||||
, test-framework-hunit >=0.3 && <0.4
|
||||
, process >=1.2 && <1.3
|
||||
, network >=2.6 && <2.7
|
||||
, HUnit >=1.2 && <1.3
|
||||
, 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
|
||||
|
||||
116
src/Database/Memcached/Binary/Common.hs
Normal file
116
src/Database/Memcached/Binary/Common.hs
Normal file
@ -0,0 +1,116 @@
|
||||
|
||||
--------------------------------------------------------------------------------
|
||||
|
||||
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 (const $ 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.get (\c f v ->
|
||||
let (f', v', r) = fn f v
|
||||
in I.setAddReplace (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.get (\c f v ->
|
||||
let (f', v') = fn f v
|
||||
in I.setAddReplace (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 (\_ w -> successHasReturn w) 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
|
||||
|
||||
--------------------------------------------------------------------------------
|
||||
|
||||
-- | get version string.
|
||||
version :: I.Connection -> IO (HasReturn S.ByteString)
|
||||
version = 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
|
||||
28
src/Database/Memcached/Binary/Either.hs
Normal file
28
src/Database/Memcached/Binary/Either.hs
Normal file
@ -0,0 +1,28 @@
|
||||
{-# LANGUAGE FlexibleInstances #-}
|
||||
{-# 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"
|
||||
|
||||
46
src/Database/Memcached/Binary/Header.txt
Normal file
46
src/Database/Memcached/Binary/Header.txt
Normal file
@ -0,0 +1,46 @@
|
||||
( -- * 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
|
||||
-- * 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 Data.Default.Class(def)
|
||||
|
||||
import qualified Data.ByteString as S
|
||||
|
||||
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
|
||||
|
||||
|
||||
30
src/Database/Memcached/Binary/IO.hs
Normal file
30
src/Database/Memcached/Binary/IO.hs
Normal file
@ -0,0 +1,30 @@
|
||||
{-# LANGUAGE FlexibleInstances #-}
|
||||
{-# 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
|
||||
|
||||
27
src/Database/Memcached/Binary/Maybe.hs
Normal file
27
src/Database/Memcached/Binary/Maybe.hs
Normal file
@ -0,0 +1,27 @@
|
||||
{-# LANGUAGE FlexibleInstances #-}
|
||||
{-# 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
|
||||
444
test/test.hs
444
test/test.hs
@ -1,10 +1,30 @@
|
||||
{-# 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 Network
|
||||
import System.Process
|
||||
import Database.Memcached.Binary
|
||||
|
||||
import Data.Default.Class
|
||||
import Data.Maybe
|
||||
import Data.Word
|
||||
import Data.Typeable
|
||||
import qualified Data.ByteString.Char8 as S
|
||||
import qualified Data.ByteString.Lazy.Char8 as L
|
||||
|
||||
import Database.Memcached.Binary.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
|
||||
|
||||
@ -18,7 +38,423 @@ startMemcached = do
|
||||
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
|
||||
]
|
||||
]
|
||||
|
||||
testIncrDecr :: Test
|
||||
testIncrDecr = 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
|
||||
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
|
||||
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
|
||||
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
|
||||
b @?= "10"
|
||||
]
|
||||
]
|
||||
]
|
||||
|
||||
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"
|
||||
[ testMc "IO module" $ \c -> do
|
||||
v <- McIO.version c
|
||||
assertBool (show v ++ " is not version like.") $ isVersionLike v
|
||||
, testMc "Maybe module" $ \c -> do
|
||||
Just v <- McMaybe.version c
|
||||
assertBool (show v ++ " is not version like.") $ isVersionLike v
|
||||
]
|
||||
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
|
||||
]
|
||||
]
|
||||
]
|
||||
|
||||
testTouchGAT :: Test
|
||||
testTouchGAT = testGroup "touch/GAT"
|
||||
[ testGroup "IO module"
|
||||
[ testGroup "touch"
|
||||
[ testMc "foo" $ \c -> do
|
||||
a <- McMaybe.get_ "foo" c
|
||||
McIO.touch 1 "foo" c
|
||||
threadDelay 1100000
|
||||
b <- McMaybe.get_ "foo" c
|
||||
a @?= (Just "foovalue")
|
||||
b @?= Nothing
|
||||
, 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
|
||||
threadDelay 1100000
|
||||
z <- McMaybe.get "foo" c
|
||||
x @?= Just (0, "foovalue")
|
||||
y @?= (0, "foovalue")
|
||||
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
|
||||
threadDelay 1100000
|
||||
z <- McMaybe.get_ "foo" c
|
||||
x @?= Just "foovalue"
|
||||
y @?= "foovalue"
|
||||
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
|
||||
threadDelay 1100000
|
||||
b <- McMaybe.get_ "foo" c
|
||||
a @?= (Just "foovalue")
|
||||
r @?= True
|
||||
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
|
||||
threadDelay 1100000
|
||||
b <- McMaybe.get_ "foo" c
|
||||
a @?= Just (0, "foovalue")
|
||||
r @?= Just (0, "foovalue")
|
||||
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
|
||||
threadDelay 1100000
|
||||
b <- McMaybe.get_ "foo" c
|
||||
a @?= Just "foovalue"
|
||||
r @?= Just "foovalue"
|
||||
b @?= Nothing
|
||||
, testMc "notexist" $ \c -> do
|
||||
r <- McMaybe.getAndTouch_ 1 "notexist" c
|
||||
a <- McMaybe.get "notexist" c
|
||||
r @?= Nothing
|
||||
a @?= Nothing
|
||||
]
|
||||
]
|
||||
]
|
||||
|
||||
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 $ \_ -> defaultMain
|
||||
[ testCase "version" . void $ withConnection def version
|
||||
[ testGet
|
||||
, testSetAddReplace
|
||||
, testDelete
|
||||
, testIncrDecr
|
||||
, testFlush
|
||||
, testVersion
|
||||
, testNoOp
|
||||
, testAppendPrepend
|
||||
, testTouchGAT
|
||||
, testModify
|
||||
, testModify_
|
||||
]
|
||||
|
||||
Loading…
Reference in New Issue
Block a user