From a64557ede7260896bed08e539c54cb9a2a78be34 Mon Sep 17 00:00:00 2001 From: philopon Date: Tue, 26 Aug 2014 20:01:28 +0900 Subject: [PATCH 1/9] update .cabal. --- memcached-binary.cabal | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/memcached-binary.cabal b/memcached-binary.cabal index 7817033..e2758a5 100644 --- a/memcached-binary.cabal +++ b/memcached-binary.cabal @@ -16,7 +16,7 @@ library Database.Memcached.Binary.Types 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 From 08973f15baeae72971fb8b3c912cbd2e0b041419 Mon Sep 17 00:00:00 2001 From: philopon Date: Tue, 26 Aug 2014 21:07:57 +0900 Subject: [PATCH 2/9] update travis. --- .travis-script.sh | 7 +++++++ .travis.yml | 1 + memcached-binary.cabal | 13 +++++++++++++ test/test.hs | 24 ++++++++++++++++++++++++ 4 files changed, 45 insertions(+) create mode 100644 .travis-script.sh create mode 100644 test/test.hs diff --git a/.travis-script.sh b/.travis-script.sh new file mode 100644 index 0000000..9c9f932 --- /dev/null +++ b/.travis-script.sh @@ -0,0 +1,7 @@ +#!/bin/bash + +memcached & + +cabal configure --enable-tests +cabal build +cabal test diff --git a/.travis.yml b/.travis.yml index 5c7e760..9156e80 100644 --- a/.travis.yml +++ b/.travis.yml @@ -2,3 +2,4 @@ language: haskell ghc: - 7.8 - 7.6 +script: bash -eu .travis-script.sh diff --git a/memcached-binary.cabal b/memcached-binary.cabal index e2758a5..9b825a7 100644 --- a/memcached-binary.cabal +++ b/memcached-binary.cabal @@ -28,3 +28,16 @@ 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 + default-language: Haskell2010 diff --git a/test/test.hs b/test/test.hs new file mode 100644 index 0000000..43b2250 --- /dev/null +++ b/test/test.hs @@ -0,0 +1,24 @@ +{-# LANGUAGE ScopedTypeVariables #-} +import Control.Exception +import Control.Concurrent +import Control.Monad +import Network +import System.Process +import Database.Memcached.Binary +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 + +main :: IO () +main = bracket startMemcached terminateProcess $ \_ -> defaultMain + [ testCase "version" . void $ withConnection def version + ] From 5696afaa7546290c6ff26759ae69d92b40622683 Mon Sep 17 00:00:00 2001 From: philopon Date: Wed, 27 Aug 2014 02:41:27 +0900 Subject: [PATCH 3/9] add tests, change module structure, api. --- memcached-binary.cabal | 8 +- src/Database/Memcached/Binary.hs | 292 +----------- src/Database/Memcached/Binary/Common.hs | 116 +++++ src/Database/Memcached/Binary/Either.hs | 28 ++ src/Database/Memcached/Binary/Header.txt | 46 ++ src/Database/Memcached/Binary/IO.hs | 30 ++ src/Database/Memcached/Binary/Internal.hs | 2 +- src/Database/Memcached/Binary/Maybe.hs | 27 ++ src/Database/Memcached/Binary/Types.hs | 4 + .../Memcached/Binary/{ => Types}/Exception.hs | 2 +- test/test.hs | 444 +++++++++++++++++- 11 files changed, 703 insertions(+), 296 deletions(-) create mode 100644 src/Database/Memcached/Binary/Common.hs create mode 100644 src/Database/Memcached/Binary/Either.hs create mode 100644 src/Database/Memcached/Binary/Header.txt create mode 100644 src/Database/Memcached/Binary/IO.hs create mode 100644 src/Database/Memcached/Binary/Maybe.hs rename src/Database/Memcached/Binary/{ => Types}/Exception.hs (95%) diff --git a/memcached-binary.cabal b/memcached-binary.cabal index 9b825a7..95bd8da 100644 --- a/memcached-binary.cabal +++ b/memcached-binary.cabal @@ -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 diff --git a/src/Database/Memcached/Binary.hs b/src/Database/Memcached/Binary.hs index d26d92f..1db75f3 100644 --- a/src/Database/Memcached/Binary.hs +++ b/src/Database/Memcached/Binary.hs @@ -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 diff --git a/src/Database/Memcached/Binary/Common.hs b/src/Database/Memcached/Binary/Common.hs new file mode 100644 index 0000000..6be0744 --- /dev/null +++ b/src/Database/Memcached/Binary/Common.hs @@ -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 diff --git a/src/Database/Memcached/Binary/Either.hs b/src/Database/Memcached/Binary/Either.hs new file mode 100644 index 0000000..348d7d1 --- /dev/null +++ b/src/Database/Memcached/Binary/Either.hs @@ -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" + diff --git a/src/Database/Memcached/Binary/Header.txt b/src/Database/Memcached/Binary/Header.txt new file mode 100644 index 0000000..db25492 --- /dev/null +++ b/src/Database/Memcached/Binary/Header.txt @@ -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 + + diff --git a/src/Database/Memcached/Binary/IO.hs b/src/Database/Memcached/Binary/IO.hs new file mode 100644 index 0000000..b9055a0 --- /dev/null +++ b/src/Database/Memcached/Binary/IO.hs @@ -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" + diff --git a/src/Database/Memcached/Binary/Internal.hs b/src/Database/Memcached/Binary/Internal.hs index 752c674..2554d42 100644 --- a/src/Database/Memcached/Binary/Internal.hs +++ b/src/Database/Memcached/Binary/Internal.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 diff --git a/src/Database/Memcached/Binary/Maybe.hs b/src/Database/Memcached/Binary/Maybe.hs new file mode 100644 index 0000000..8571348 --- /dev/null +++ b/src/Database/Memcached/Binary/Maybe.hs @@ -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" diff --git a/src/Database/Memcached/Binary/Types.hs b/src/Database/Memcached/Binary/Types.hs index 7de740d..9dc0d8f 100644 --- a/src/Database/Memcached/Binary/Types.hs +++ b/src/Database/Memcached/Binary/Types.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 diff --git a/src/Database/Memcached/Binary/Exception.hs b/src/Database/Memcached/Binary/Types/Exception.hs similarity index 95% rename from src/Database/Memcached/Binary/Exception.hs rename to src/Database/Memcached/Binary/Types/Exception.hs index 25950c4..a7b5cb1 100644 --- a/src/Database/Memcached/Binary/Exception.hs +++ b/src/Database/Memcached/Binary/Types/Exception.hs @@ -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 diff --git a/test/test.hs b/test/test.hs index 43b2250..0e37130 100644 --- a/test/test.hs +++ b/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_ ] From afef13ab9d85081acbca2089d7e59fdbb09459cf Mon Sep 17 00:00:00 2001 From: philopon Date: Wed, 27 Aug 2014 02:42:11 +0900 Subject: [PATCH 4/9] add README.md. --- README.md | 3 +++ 1 file changed, 3 insertions(+) create mode 100644 README.md diff --git a/README.md b/README.md new file mode 100644 index 0000000..1a78b32 --- /dev/null +++ b/README.md @@ -0,0 +1,3 @@ +memcached-binary [![Build Status](https://travis-ci.org/philopon/memcached-binary.svg?branch=master)](https://travis-ci.org/philopon/memcached-binary) +=== +memcached client using binary protocol. From 0e145db48889fa650eba9a49e4ed1d86c8990da9 Mon Sep 17 00:00:00 2001 From: philopon Date: Wed, 27 Aug 2014 02:59:04 +0900 Subject: [PATCH 5/9] fix test. --- memcached-binary.cabal | 1 + test/test.hs | 2 +- 2 files changed, 2 insertions(+), 1 deletion(-) diff --git a/memcached-binary.cabal b/memcached-binary.cabal index 95bd8da..59d1bec 100644 --- a/memcached-binary.cabal +++ b/memcached-binary.cabal @@ -45,5 +45,6 @@ test-suite test , 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 diff --git a/test/test.hs b/test/test.hs index 0e37130..c48cc4d 100644 --- a/test/test.hs +++ b/test/test.hs @@ -19,7 +19,7 @@ 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.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 From 59c20b7aefd85e38d82f70b9cee9a6580a748d08 Mon Sep 17 00:00:00 2001 From: philopon Date: Wed, 27 Aug 2014 03:36:01 +0900 Subject: [PATCH 6/9] add extra-source-files. --- memcached-binary.cabal | 2 ++ 1 file changed, 2 insertions(+) diff --git a/memcached-binary.cabal b/memcached-binary.cabal index 59d1bec..f922b9c 100644 --- a/memcached-binary.cabal +++ b/memcached-binary.cabal @@ -9,6 +9,8 @@ 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 From defb311789a1a7985da52c655b5c56433b3a1856 Mon Sep 17 00:00:00 2001 From: philopon Date: Wed, 27 Aug 2014 04:33:45 +0900 Subject: [PATCH 7/9] update travis. --- .travis-script.sh | 7 ------- .travis.yml | 1 - 2 files changed, 8 deletions(-) delete mode 100644 .travis-script.sh diff --git a/.travis-script.sh b/.travis-script.sh deleted file mode 100644 index 9c9f932..0000000 --- a/.travis-script.sh +++ /dev/null @@ -1,7 +0,0 @@ -#!/bin/bash - -memcached & - -cabal configure --enable-tests -cabal build -cabal test diff --git a/.travis.yml b/.travis.yml index 9156e80..5c7e760 100644 --- a/.travis.yml +++ b/.travis.yml @@ -2,4 +2,3 @@ language: haskell ghc: - 7.8 - 7.6 -script: bash -eu .travis-script.sh From 2edf80c0c5fbddf8fb5eb16fdb5e3a3538de8e08 Mon Sep 17 00:00:00 2001 From: philopon Date: Wed, 27 Aug 2014 05:44:56 +0900 Subject: [PATCH 8/9] remove unused CAS read, version return Data.Version. test version restriction. --- src/Database/Memcached/Binary/Common.hs | 46 ++++++--- src/Database/Memcached/Binary/Either.hs | 1 + src/Database/Memcached/Binary/Header.txt | 8 +- src/Database/Memcached/Binary/IO.hs | 1 + src/Database/Memcached/Binary/Internal.hs | 36 ++++--- src/Database/Memcached/Binary/Maybe.hs | 1 + test/test.hs | 115 +++++++++++++--------- 7 files changed, 131 insertions(+), 77 deletions(-) diff --git a/src/Database/Memcached/Binary/Common.hs b/src/Database/Memcached/Binary/Common.hs index 6be0744..b7f6c1d 100644 --- a/src/Database/Memcached/Binary/Common.hs +++ b/src/Database/Memcached/Binary/Common.hs @@ -2,17 +2,17 @@ -------------------------------------------------------------------------------- get :: Key -> I.Connection -> IO (HasReturn (Flags, Value)) -get = I.useConnection . I.get (\_ f v -> successHasReturn (f,v)) failureHasReturn +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 +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 + I.setAddReplace successNoReturn failureNoReturn op (CAS 0) key value f e set :: Flags -> Expiry -> Key -> Value -> I.Connection -> IO NoReturn @@ -27,7 +27,7 @@ replace = setAddReplace opReplace -------------------------------------------------------------------------------- delete :: Key -> I.Connection -> IO NoReturn -delete = I.useConnection . I.delete (\_ -> successNoReturn) failureNoReturn (CAS 0) +delete = I.useConnection . I.delete successNoReturn failureNoReturn (CAS 0) -------------------------------------------------------------------------------- @@ -35,9 +35,9 @@ delete = I.useConnection . I.delete (\_ -> successNoReturn) failureNoReturn (CAS 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 -> + I.getWithCAS (\c f v -> let (f', v', r) = fn f v - in I.setAddReplace (const $ successHasReturn r) + in I.setAddReplaceWithCAS (const $ successHasReturn r) failureHasReturn opSet c key v' f' e h ) failureHasReturn key h @@ -46,9 +46,9 @@ modify_ :: Expiry -> Key -> (Flags -> Value -> (Flags, Value)) -> I.Connection -> IO NoReturn modify_ e key fn = I.useConnection $ \h -> - I.get (\c f v -> + I.getWithCAS (\c f v -> let (f', v') = fn f v - in I.setAddReplace (const $ successNoReturn) + in I.setAddReplaceWithCAS (const $ successNoReturn) failureNoReturn opSet c key v' f' e h ) failureNoReturn key h @@ -57,8 +57,7 @@ modify_ e key fn = I.useConnection $ \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 - + I.incrDecr successHasReturn failureHasReturn op (CAS 0) k d i e increment :: Expiry -> Key -> Delta -> Initial -> I.Connection -> IO (HasReturn Counter) @@ -76,9 +75,24 @@ 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. -version :: I.Connection -> IO (HasReturn S.ByteString) -version = I.useConnection $ I.version successHasReturn failureHasReturn +versionString :: I.Connection -> IO (HasReturn S.ByteString) +versionString = I.useConnection $ I.version successHasReturn failureHasReturn -------------------------------------------------------------------------------- @@ -90,7 +104,7 @@ 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 + I.appendPrepend successNoReturn failureNoReturn o (CAS 0) k v append :: Key -> Value -> I.Connection -> IO NoReturn append = appendPrepend opAppend @@ -103,14 +117,14 @@ prepend = appendPrepend opPrepend -- | change expiry. touch :: Expiry -> Key -> I.Connection -> IO NoReturn touch e k = I.useConnection $ - I.touch (\_ _ _ -> successNoReturn) failureNoReturn opTouch k e + 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 + 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 + I.touch (\_ v -> successHasReturn v) failureHasReturn opGAT k e diff --git a/src/Database/Memcached/Binary/Either.hs b/src/Database/Memcached/Binary/Either.hs index 348d7d1..12e0eea 100644 --- a/src/Database/Memcached/Binary/Either.hs +++ b/src/Database/Memcached/Binary/Either.hs @@ -1,4 +1,5 @@ {-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE NoMonomorphismRestriction #-} {-# LANGUAGE CPP #-} diff --git a/src/Database/Memcached/Binary/Header.txt b/src/Database/Memcached/Binary/Header.txt index db25492..d105824 100644 --- a/src/Database/Memcached/Binary/Header.txt +++ b/src/Database/Memcached/Binary/Header.txt @@ -11,7 +11,7 @@ -- * flush , flushAll -- * version - , version + , version, versionString -- * noOp , noOp -- * append/prepend @@ -34,13 +34,15 @@ import Network(PortID(..)) -import Data.Default.Class(def) +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 diff --git a/src/Database/Memcached/Binary/IO.hs b/src/Database/Memcached/Binary/IO.hs index b9055a0..451ca18 100644 --- a/src/Database/Memcached/Binary/IO.hs +++ b/src/Database/Memcached/Binary/IO.hs @@ -1,4 +1,5 @@ {-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE NoMonomorphismRestriction #-} {-# LANGUAGE CPP #-} diff --git a/src/Database/Memcached/Binary/Internal.hs b/src/Database/Memcached/Binary/Internal.hs index 2554d42..4741e31 100644 --- a/src/Database/Memcached/Binary/Internal.hs +++ b/src/Database/Memcached/Binary/Internal.hs @@ -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) diff --git a/src/Database/Memcached/Binary/Maybe.hs b/src/Database/Memcached/Binary/Maybe.hs index 8571348..f9b2856 100644 --- a/src/Database/Memcached/Binary/Maybe.hs +++ b/src/Database/Memcached/Binary/Maybe.hs @@ -1,4 +1,5 @@ {-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE NoMonomorphismRestriction #-} {-# LANGUAGE CPP #-} diff --git a/test/test.hs b/test/test.hs index c48cc4d..8e154cd 100644 --- a/test/test.hs +++ b/test/test.hs @@ -16,6 +16,7 @@ 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 @@ -156,8 +157,9 @@ testDelete = testGroup "delete" ] ] -testIncrDecr :: Test -testIncrDecr = testGroup "increment/decrement" +-- https://code.google.com/p/memcached/wiki/ReleaseNotes1417 +testIncrDecr :: Version -> Test +testIncrDecr v = testGroup "increment/decrement" [ testGroup "IO module" [ testGroup "increment" [ testMc "foo" $ \c -> @@ -172,7 +174,7 @@ testIncrDecr = testGroup "increment/decrement" a <- McIO.increment 0 "notexist" 10 10 c b <- McIO.get_ "notexist" c a @?= 10 - b @?= "10" + when (v >= ev) $ b @?= "10" ] , testGroup "decrement" [ testMc "foo" $ \c -> @@ -187,7 +189,7 @@ testIncrDecr = testGroup "increment/decrement" a <- McIO.decrement 0 "notexist" 10 10 c b <- McIO.get_ "notexist" c a @?= 10 - b @?= "10" + when (v >= ev) $ b @?= "10" ] ] , testGroup "Maybe module" @@ -206,7 +208,7 @@ testIncrDecr = testGroup "increment/decrement" a <- McMaybe.increment 0 "notexist" 10 10 c b <- McIO.get_ "notexist" c a @?= Just 10 - b @?= "10" + when (v >= ev) $ b @?= "10" ] , testGroup "decrement'" [ testMc "foo" $ \c -> do @@ -223,10 +225,12 @@ testIncrDecr = testGroup "increment/decrement" a <- McMaybe.decrement 0 "notexist" 10 10 c b <- McIO.get_ "notexist" c a @?= Just 10 - b @?= "10" + when (v >= ev) $ b @?= "10" ] ] ] + where + ev = Version [1,4,17] [] testFlush :: Test testFlush = testGroup "flush" @@ -247,12 +251,19 @@ testFlush = testGroup "flush" 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 + [ 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 @@ -333,17 +344,20 @@ testAppendPrepend = testGroup "append/prepend" ] ] -testTouchGAT :: Test -testTouchGAT = testGroup "touch/GAT" +-- 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 - threadDelay 1100000 - b <- McMaybe.get_ "foo" c a @?= (Just "foovalue") - b @?= Nothing + 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 ] @@ -351,11 +365,12 @@ testTouchGAT = testGroup "touch/GAT" [ 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 + 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 ] @@ -363,11 +378,12 @@ testTouchGAT = testGroup "touch/GAT" [ 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 + 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 ] @@ -377,11 +393,12 @@ testTouchGAT = testGroup "touch/GAT" [ 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 + 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 @@ -392,11 +409,12 @@ testTouchGAT = testGroup "touch/GAT" [ 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 + 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 @@ -407,11 +425,12 @@ testTouchGAT = testGroup "touch/GAT" [ 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 + 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 @@ -420,6 +439,8 @@ testTouchGAT = testGroup "touch/GAT" ] ] ] + where + ev = Version [1,4,14] [] testModify :: Test testModify = testGroup "modify" @@ -444,17 +465,21 @@ testModify_ = testGroup "modify_" McIO.modify_ 0 "notexist" (\f v -> (f,v)) c ] + + main :: IO () -main = bracket startMemcached terminateProcess $ \_ -> defaultMain - [ testGet - , testSetAddReplace - , testDelete - , testIncrDecr - , testFlush - , testVersion - , testNoOp - , testAppendPrepend - , testTouchGAT - , testModify - , testModify_ - ] +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_ + ] From a54f764761a053958d7f171f8debe64341f09349 Mon Sep 17 00:00:00 2001 From: philopon Date: Wed, 27 Aug 2014 05:51:30 +0900 Subject: [PATCH 9/9] fix close function of connection pool. --- src/Database/Memcached/Binary/Internal.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/Database/Memcached/Binary/Internal.hs b/src/Database/Memcached/Binary/Internal.hs index 4741e31..e0c34ba 100644 --- a/src/Database/Memcached/Binary/Internal.hs +++ b/src/Database/Memcached/Binary/Internal.hs @@ -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