diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,20 @@ +Copyright (c) 2014 Hirotomo Moriwaki + +Permission is hereby granted, free of charge, to any person obtaining +a copy of this software and associated documentation files (the +"Software"), to deal in the Software without restriction, including +without limitation the rights to use, copy, modify, merge, publish, +distribute, sublicense, and/or sell copies of the Software, and to +permit persons to whom the Software is furnished to do so, subject to +the following conditions: + +The above copyright notice and this permission notice shall be included +in all copies or substantial portions of the Software. + +THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, +EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF +MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. +IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY +CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT, +TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE +SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE. diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/memcached-binary.cabal b/memcached-binary.cabal new file mode 100644 --- /dev/null +++ b/memcached-binary.cabal @@ -0,0 +1,54 @@ +name: memcached-binary +version: 0.1.0 +synopsis: memcached client using binary protocol. +license: MIT +license-file: LICENSE +author: HirotomoMoriwaki +maintainer: HirotomoMoriwaki +Homepage: https://github.com/philopon/memcached-binary +Bug-reports: https://github.com/philopon/memcached-binary/issues +copyright: (c) 2014 Hirotomo Moriwaki +category: Database +build-type: Simple +cabal-version: >=1.10 +extra-source-files: src/Database/Memcached/Binary/Common.hs + src/Database/Memcached/Binary/Header.txt + +library + exposed-modules: Database.Memcached.Binary + Database.Memcached.Binary.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 + , bytestring >=0.10 && <0.11 + , network >=2.6 && <2.7 + , storable-endian >=0.2 && <0.3 + , data-default-class >=0.0 && <0.1 + , resource-pool >=0.2 && <0.3 + , containers >=0.5 && <0.6 + , unordered-containers >=0.2 && <0.3 + , time >=1.4 && <1.5 + ghc-options: -Wall -O2 + hs-source-dirs: src + default-language: Haskell2010 + +test-suite test + type: exitcode-stdio-1.0 + hs-source-dirs: test + main-is: test.hs + ghc-options: -Wall -O2 + build-depends: base >=4.6 && <4.8 + , memcached-binary + , test-framework >=0.8 && <0.9 + , test-framework-hunit >=0.3 && <0.4 + , process >=1.2 && <1.3 + , network >=2.6 && <2.7 + , HUnit >=1.2 && <1.3 + , data-default-class >=0.0 && <0.1 + , bytestring >=0.10 && <0.11 + default-language: Haskell2010 diff --git a/src/Database/Memcached/Binary.hs b/src/Database/Memcached/Binary.hs new file mode 100644 --- /dev/null +++ b/src/Database/Memcached/Binary.hs @@ -0,0 +1,5 @@ +module Database.Memcached.Binary {-# WARNING "use Database.Memcached.Binary.Maybe(or Either, IO) instead." #-} + ( module Database.Memcached.Binary.Maybe + ) where + +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 --- /dev/null +++ b/src/Database/Memcached/Binary/Common.hs @@ -0,0 +1,130 @@ + +-------------------------------------------------------------------------------- + +get :: Key -> I.Connection -> IO (HasReturn (Flags, Value)) +get = I.useConnection . I.get (\f v -> successHasReturn (f,v)) failureHasReturn + +get_ :: Key -> I.Connection -> IO (HasReturn Value) +get_ = I.useConnection . I.get (\_ v -> successHasReturn v) failureHasReturn + +-------------------------------------------------------------------------------- + +setAddReplace :: OpCode -> Flags -> Expiry + -> Key -> Value -> I.Connection -> IO NoReturn +setAddReplace op = \f e key value -> I.useConnection $ + I.setAddReplace successNoReturn failureNoReturn op (CAS 0) key value f e + + +set :: Flags -> Expiry -> Key -> Value -> I.Connection -> IO NoReturn +set = setAddReplace opSet + +add :: Flags -> Expiry -> Key -> Value -> I.Connection -> IO NoReturn +add = setAddReplace opAdd + +replace :: Flags -> Expiry -> Key -> Value -> I.Connection -> IO NoReturn +replace = setAddReplace opReplace + +-------------------------------------------------------------------------------- + +delete :: Key -> I.Connection -> IO NoReturn +delete = I.useConnection . I.delete successNoReturn failureNoReturn (CAS 0) + +-------------------------------------------------------------------------------- + +-- | modify value in transaction. +modify :: Expiry -> Key -> (Flags -> Value -> (Flags, Value, a)) + -> I.Connection -> IO (HasReturn a) +modify e key fn = I.useConnection $ \h -> + I.getWithCAS (\c f v -> + let (f', v', r) = fn f v + in I.setAddReplaceWithCAS (const $ successHasReturn r) + failureHasReturn opSet c key v' f' e h + ) failureHasReturn key h + +-- | modify value in transaction. +modify_ :: Expiry + -> Key -> (Flags -> Value -> (Flags, Value)) + -> I.Connection -> IO NoReturn +modify_ e key fn = I.useConnection $ \h -> + I.getWithCAS (\c f v -> + let (f', v') = fn f v + in I.setAddReplaceWithCAS (const $ successNoReturn) + failureNoReturn opSet c key v' f' e h + ) failureNoReturn key h + +-------------------------------------------------------------------------------- + +incrDecr :: OpCode -> Expiry + -> Key -> Delta -> Initial -> I.Connection -> IO (HasReturn Counter) +incrDecr op e k d i = I.useConnection $ + I.incrDecr successHasReturn failureHasReturn op (CAS 0) k d i e + +increment :: Expiry -> Key -> Delta -> Initial + -> I.Connection -> IO (HasReturn Counter) +increment = incrDecr opIncrement + +decrement :: Expiry -> Key -> Delta -> Initial + -> I.Connection -> IO (HasReturn Counter) +decrement = incrDecr opDecrement + +-------------------------------------------------------------------------------- + +-- | flush all value. +flushAll :: I.Connection -> IO NoReturn +flushAll = I.useConnection $ I.flushAll successNoReturn failureNoReturn + +-------------------------------------------------------------------------------- + +version :: I.Connection -> IO (HasReturn Version) +version = I.useConnection $ I.version (\s -> case readVersion s of + Nothing -> failureHasReturn (-1) "version parse failed" + Just v -> successHasReturn v) failureHasReturn + where + readVersion s0 = do + (x, s1) <- S8.readInt s0 + when (S8.null s1) $ Nothing + (y, s2) <- S8.readInt (S8.tail s1) + when (S8.null s2) $ Nothing + (z, s3) <- S8.readInt (S8.tail s2) + unless (S8.null s3) $ Nothing + return (Version [x,y,z] []) + + +-- | get version string. +versionString :: I.Connection -> IO (HasReturn S.ByteString) +versionString = I.useConnection $ I.version successHasReturn failureHasReturn + +-------------------------------------------------------------------------------- + +-- | noop(use for keepalive). +noOp :: I.Connection -> IO NoReturn +noOp = I.useConnection $ I.noOp successNoReturn failureNoReturn + +-------------------------------------------------------------------------------- + +appendPrepend :: OpCode -> Key -> Value -> I.Connection -> IO NoReturn +appendPrepend o = \k v -> I.useConnection $ + I.appendPrepend successNoReturn failureNoReturn o (CAS 0) k v + +append :: Key -> Value -> I.Connection -> IO NoReturn +append = appendPrepend opAppend + +prepend :: Key -> Value -> I.Connection -> IO NoReturn +prepend = appendPrepend opPrepend + +-------------------------------------------------------------------------------- + +-- | change expiry. +touch :: Expiry -> Key -> I.Connection -> IO NoReturn +touch e k = I.useConnection $ + I.touch (\_ _ -> successNoReturn) failureNoReturn opTouch k e + +-- | get value/change expiry. +getAndTouch :: Expiry -> Key -> I.Connection -> IO (HasReturn (Flags, Value)) +getAndTouch e k = I.useConnection $ + I.touch (\f v -> successHasReturn (f,v)) failureHasReturn opGAT k e + +-- | get value/change expiry. +getAndTouch_ :: Expiry -> Key -> I.Connection -> IO (HasReturn Value) +getAndTouch_ e k = I.useConnection $ + I.touch (\_ v -> successHasReturn v) failureHasReturn opGAT k e diff --git a/src/Database/Memcached/Binary/Either.hs b/src/Database/Memcached/Binary/Either.hs new file mode 100644 --- /dev/null +++ b/src/Database/Memcached/Binary/Either.hs @@ -0,0 +1,29 @@ +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE NoMonomorphismRestriction #-} +{-# LANGUAGE CPP #-} + +module Database.Memcached.Binary.Either +#include "Header.txt" + +#define NoReturn (Maybe MemcachedException) +#define HasReturn Either MemcachedException + +successHasReturn :: a -> IO (HasReturn a) +successHasReturn = return . Right +{-# INLINE successHasReturn #-} + +successNoReturn :: IO NoReturn +successNoReturn = return Nothing +{-# INLINE successNoReturn #-} + +failureHasReturn :: I.Failure (HasReturn a) +failureHasReturn i m = return . Left $ MemcachedException i m +{-# INLINE failureHasReturn #-} + +failureNoReturn :: I.Failure NoReturn +failureNoReturn i m = return . Just $ MemcachedException i m +{-# INLINE failureNoReturn #-} + +#include "Common.hs" + diff --git a/src/Database/Memcached/Binary/Header.txt b/src/Database/Memcached/Binary/Header.txt new file mode 100644 --- /dev/null +++ b/src/Database/Memcached/Binary/Header.txt @@ -0,0 +1,48 @@ + ( -- * connection + I.Connection, I.withConnection, I.connect, I.close + -- * get + , get, get_ + -- * set + , set, add, replace + -- * delete + , delete + -- * increment/decrement + , increment, decrement + -- * flush + , flushAll + -- * version + , version, versionString + -- * noOp + , noOp + -- * append/prepend + , append, prepend + -- * touch + , touch + , getAndTouch + , getAndTouch_ + + -- * modify + , modify, modify_ + -- * reexports + , module Database.Memcached.Binary.Types + , module Database.Memcached.Binary.Types.Exception + -- | def + , module Data.Default.Class + -- | PortID(..) + , module Network + ) where + +import Network(PortID(..)) + +import Control.Monad + +import Data.Default.Class(def) +import qualified Data.ByteString as S +import qualified Data.ByteString.Char8 as S8 + +import Database.Memcached.Binary.Types +import Database.Memcached.Binary.Types.Exception +import Database.Memcached.Binary.Internal.Definition +import qualified Database.Memcached.Binary.Internal as I + +import Data.Version diff --git a/src/Database/Memcached/Binary/IO.hs b/src/Database/Memcached/Binary/IO.hs new file mode 100644 --- /dev/null +++ b/src/Database/Memcached/Binary/IO.hs @@ -0,0 +1,31 @@ +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE NoMonomorphismRestriction #-} +{-# LANGUAGE CPP #-} + +module Database.Memcached.Binary.IO +#include "Header.txt" + +import Control.Exception + +#define NoReturn () +#define HasReturn + +successHasReturn :: a -> IO (HasReturn a) +successHasReturn = return +{-# INLINE successHasReturn #-} + +successNoReturn :: IO NoReturn +successNoReturn = return () +{-# INLINE successNoReturn #-} + +failureHasReturn :: I.Failure (HasReturn a) +failureHasReturn i m = throwIO $ MemcachedException i m +{-# INLINE failureHasReturn #-} + +failureNoReturn :: I.Failure NoReturn +failureNoReturn i m = throwIO $ MemcachedException i m +{-# INLINE failureNoReturn #-} + +#include "Common.hs" + diff --git a/src/Database/Memcached/Binary/Internal.hs b/src/Database/Memcached/Binary/Internal.hs new file mode 100644 --- /dev/null +++ b/src/Database/Memcached/Binary/Internal.hs @@ -0,0 +1,317 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE Rank2Types #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE NoMonomorphismRestriction #-} + +module Database.Memcached.Binary.Internal where + +import Network + +import Foreign.Ptr +import Foreign.Storable +import Foreign.Marshal.Utils +import Foreign.Marshal.Alloc + +import System.IO + +import Control.Monad +import Control.Exception +import Control.Concurrent.MVar + +import Data.Word +import Data.Pool +import Data.Storable.Endian +import qualified Data.HashMap.Strict as H +import qualified Data.ByteString as S +import qualified Data.ByteString.Lazy as L +import qualified Data.ByteString.Unsafe as S + +import Database.Memcached.Binary.Types +import Database.Memcached.Binary.Types.Exception +import Database.Memcached.Binary.Internal.Definition + +data Connection + = Connection (MVar Handle) + | ConnectionPool (Pool Handle) + +withConnection :: ConnectInfo -> (Connection -> IO a) -> IO a +withConnection i m = withSocketsDo $ bracket (connect i) close m + +connect :: ConnectInfo -> IO Connection +connect i = + if numConnection i == 1 + then fmap Connection $ connect' i >>= newMVar + else fmap ConnectionPool $ + createPool (connect' i) (\h -> quit h >> hClose h) 1 + (connectionIdleTime i) (numConnection i) + +connect' :: ConnectInfo -> IO Handle +connect' i = loop (connectAuth i) + where + loop [] = do + connectTo (connectHost i) (connectPort i) + + loop [a] = do + h <- connectTo (connectHost i) (connectPort i) + auth a (\_ -> return h) (\w m -> throwIO $ MemcachedException w m) h + + loop (a:as) = do + h <- connectTo (connectHost i) (connectPort i) + handle (\(_::IOError) -> loop as) $ + auth a (\_ -> return h) (\_ _ -> loop as) h + +close :: Connection -> IO () +close (Connection mv) = do + h <- swapMVar mv (error "connection already closed") + quit h + hClose h +close (ConnectionPool p) = destroyAllResources p + +useConnection :: (Handle -> IO a) -> Connection -> IO a +useConnection f (Connection mv) = withMVar mv f +useConnection f (ConnectionPool p) = withResource p f + +pokeWord8 :: Ptr a -> Word8 -> IO () +pokeWord8 = poke . castPtr + +pokeWord16be :: Ptr a -> Word16 -> IO () +pokeWord16be p w = poke (castPtr p) (BE w) + +pokeWord32be :: Ptr a -> Word32 -> IO () +pokeWord32be p w = poke (castPtr p) (BE w) + +pokeWord64be :: Ptr a -> Word64 -> IO () +pokeWord64be p w = poke (castPtr p) (BE w) + +peekWord8 :: Ptr a -> IO Word8 +peekWord8 = peek . castPtr + +peekWord16be :: Ptr a -> IO Word16 +peekWord16be p = peek (castPtr p) >>= \(BE w) -> return w + +peekWord32be :: Ptr a -> IO Word32 +peekWord32be p = peek (castPtr p) >>= \(BE w) -> return w + +peekWord64be :: Ptr a -> IO Word64 +peekWord64be p = peek (castPtr p) >>= \(BE w) -> return w + +pokeByteString :: Ptr a -> S.ByteString -> IO () +pokeByteString p v = + S.unsafeUseAsCString v $ \cstr -> + copyBytes (castPtr p) cstr (S.length v) + +pokeLazyByteString :: Ptr a -> L.ByteString -> IO () +pokeLazyByteString p v = + void $ L.foldlChunks (\mi s -> mi >>= \i -> do + pokeByteString (plusPtr p i) s + return $ i + S.length s + ) (return 0) v + +data Header +data Request + +mallocRequest :: OpCode -> Key -> Word8 -> (Ptr Request -> IO ()) + -> Int -> (Ptr Request -> IO ()) -> Word32 -> CAS -> IO (Ptr Request) +mallocRequest (OpCode o) key elen epoke vlen vpoke opaque (CAS cas) = do + let tlen = S.length key + fromIntegral elen + vlen + p <- mallocBytes (24 + fromIntegral tlen) + pokeWord8 p 0x80 + pokeWord8 (plusPtr p 1) o + pokeWord16be (plusPtr p 2) (fromIntegral $ S.length key) + pokeWord8 (plusPtr p 4) elen + pokeWord8 (plusPtr p 5) 0x00 + pokeWord16be (plusPtr p 6) 0x00 + pokeWord32be (plusPtr p 8) (fromIntegral tlen) + pokeWord32be (plusPtr p 12) opaque + pokeWord64be (plusPtr p 16) cas + epoke (plusPtr p 24) + pokeByteString (plusPtr p $ 24 + fromIntegral elen) key + vpoke (plusPtr p $ 24 + fromIntegral elen + S.length key) + return p +{-# INLINE mallocRequest #-} + +sendRequest :: OpCode -> Key -> Word8 -> (Ptr Request -> IO ()) + -> Int -> (Ptr Request -> IO ()) -> Word32 -> CAS -> Handle -> IO () +sendRequest op key elen epoke vlen vpoke opaque cas h = + bracket (mallocRequest op key elen epoke vlen vpoke opaque cas) free $ \req -> do + hPutBuf h req (24 + S.length key + fromIntegral elen + vlen) + hFlush h +{-# INLINE sendRequest #-} + +type Failure a = Word16 -> S.ByteString -> IO a + +peekResponse :: (Ptr Header -> IO a) -> Failure a -> Handle -> IO a +peekResponse success failure h = bracket (mallocBytes 24) free $ \p -> + hGetBuf h p 24 >> peekWord16be (plusPtr p 6) >>= \st -> + if st == 0 + then success p + else do + bl <- peekWord32be (plusPtr p 8) + failure st =<< S.hGet h (fromIntegral bl) +{-# INLINE peekResponse #-} + +withRequest :: OpCode -> Key -> Word8 -> (Ptr Request -> IO ()) + -> Int -> (Ptr Request -> IO ()) -> CAS + -> (Handle -> Ptr Header -> IO a) -> Failure a -> Handle -> IO a +withRequest op key elen epoke vlen vpoke cas success failure h = do + sendRequest op key elen epoke vlen vpoke 0 cas h + peekResponse (success h) failure h + +getExtraLength :: Ptr Header -> IO Word8 +getExtraLength p = peekWord8 (plusPtr p 4) + +getKeyLength :: Ptr Header -> IO Word16 +getKeyLength p = peekWord16be (plusPtr p 2) + +getTotalLength :: Ptr Header -> IO Word32 +getTotalLength p = peekWord32be (plusPtr p 8) + +getCAS :: Ptr Header -> IO CAS +getCAS p = fmap CAS $ peekWord64be (plusPtr p 16) + +getOpaque :: Ptr Header -> IO Word32 +getOpaque p = peekWord32be (plusPtr p 12) + +nop :: Ptr Request -> IO () +nop _ = return () + +inspectResponse :: Handle -> Ptr Header + -> IO (S.ByteString, S.ByteString, L.ByteString) +inspectResponse h p = do + el <- getExtraLength p + kl <- getKeyLength p + tl <- getTotalLength p + e <- S.hGet h $ fromIntegral el + k <- S.hGet h $ fromIntegral kl + v <- L.hGet h $ fromIntegral tl - fromIntegral el - fromIntegral kl + return (e,k,v) + +getSuccessCallback :: (Flags -> Value -> IO a) + -> Handle -> Ptr Header -> IO a +getSuccessCallback success h p = do + elen <- getExtraLength p + tlen <- getTotalLength p + void $ hGetBuf h p 4 + flags <- peekWord32be p + value <- L.hGet h (fromIntegral tlen - fromIntegral elen) + success flags value + +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 + +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 :: IO a -> Failure a -> CAS -> Key -> Handle -> IO a +delete success failure cas key = + withRequest opDelete key 0 nop 0 nop cas (\_ _ -> success) failure + +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 + where + extra p = do + pokeWord64be p delta + pokeWord64be (plusPtr p 8) initial + pokeWord32be (plusPtr p 16) expiry + + success' h p = do + void $ hGetBuf h p 8 + peekWord64be p >>= success + +quit :: Handle -> IO () +quit h = do + sendRequest opQuit "" 0 nop 0 nop 0 (CAS 0) h + peekResponse (\_ -> return ()) (\_ _ -> return ()) h + +flushAll :: IO a -> Failure a -> Handle -> IO a +flushAll success = + withRequest opFlush "" 0 nop 0 nop (CAS 0) (\_ _ -> success) + +flushWithin :: IO a -> Failure a -> Expiry -> Handle -> IO a +flushWithin success failure w = + withRequest opFlush "" 4 (flip pokeWord32be w) 0 nop (CAS 0) + (\_ _ -> success) failure + +noOp :: IO a -> Failure a -> Handle -> IO a +noOp success = + withRequest opNoOp "" 0 nop 0 nop (CAS 0) (\_ _ -> success) + +version :: (S.ByteString -> IO a) -> Failure a -> Handle -> IO a +version success = + withRequest opVersion "" 0 nop 0 nop (CAS 0) + (\h p -> getTotalLength p >>= S.hGet h . fromIntegral >>= success) + +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 (\_ _ -> success) failure + +stats :: Handle -> IO (H.HashMap S.ByteString S.ByteString) +stats h = loop H.empty + where + loop m = do + sendRequest opStat "" 0 nop 0 nop 0 (CAS 0) h + peekResponse (success m) (\w s -> throwIO $ MemcachedException w s) h + + success m p = getTotalLength p >>= \tl -> + if tl == 0 + then return m + else do + kl <- getKeyLength p + k <- S.hGet h (fromIntegral kl) + v <- S.hGet h (fromIntegral tl - fromIntegral kl) + loop (H.insert k v m) + +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 :: (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) + (getSuccessCallback success) failure + +saslListMechs :: (S.ByteString -> IO a) -> Failure a + -> Handle -> IO a +saslListMechs success failure = + withRequest opSaslListMechs "" 0 nop 0 nop (CAS 0) + (\h p -> getTotalLength p >>= S.hGet h . fromIntegral >>= success) + failure + +auth :: Auth -> (S.ByteString -> IO a) -> Failure a -> Handle -> IO a +auth (Plain u w) success next h = do + sendRequest opSaslAuth "PLAIN" 0 nop (S.length u + S.length w + 2) pokeCred 0 (CAS 0) h + peekResponse consumeResponse next h + where + ul = S.length u + pokeCred p = do + pokeWord8 p 0 + pokeByteString (plusPtr p 1) u + pokeWord8 (plusPtr p $ ul + 1) 0 + pokeByteString (plusPtr p $ ul + 2) w + + consumeResponse p = do + l <- getTotalLength p + success =<< S.hGet h (fromIntegral l) diff --git a/src/Database/Memcached/Binary/Internal/Definition.hs b/src/Database/Memcached/Binary/Internal/Definition.hs new file mode 100644 --- /dev/null +++ b/src/Database/Memcached/Binary/Internal/Definition.hs @@ -0,0 +1,76 @@ +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE CPP #-} + +module Database.Memcached.Binary.Internal.Definition where + +import Foreign.Storable +import Data.Word + +newtype OpCode = OpCode Word8 deriving (Storable) + +#define defOpCode(n,w) n :: OpCode; n = OpCode w + +defOpCode(opGet , 0x00) +defOpCode(opSet , 0x01) +defOpCode(opAdd , 0x02) +defOpCode(opReplace , 0x03) +defOpCode(opDelete , 0x04) +defOpCode(opIncrement , 0x05) +defOpCode(opDecrement , 0x06) +defOpCode(opQuit , 0x07) +defOpCode(opFlush , 0x08) +defOpCode(opGetQ , 0x09) +defOpCode(opNoOp , 0x0a) +defOpCode(opVersion , 0x0b) +defOpCode(opGetK , 0x0c) +defOpCode(opGetKQ , 0x0d) +defOpCode(opAppend , 0x0e) +defOpCode(opPrepend , 0x0f) + +defOpCode(opStat , 0x10) +defOpCode(opSetQ , 0x11) +defOpCode(opAddQ , 0x12) +defOpCode(opReplaceQ , 0x13) +defOpCode(opDeleteQ , 0x14) +defOpCode(opIncrementQ , 0x15) +defOpCode(opDecrementQ , 0x16) +defOpCode(opQuitQ , 0x17) +defOpCode(opFlushQ , 0x18) +defOpCode(opAppendQ , 0x19) +defOpCode(opPrependQ , 0x1a) +defOpCode(opVerbosity , 0x1b) +defOpCode(opTouch , 0x1c) +defOpCode(opGAT , 0x1d) +defOpCode(opGATQ , 0x1e) + +defOpCode(opSaslListMechs , 0x20) +defOpCode(opSaslAuth , 0x21) +defOpCode(opSaslStep , 0x22) + +defOpCode(opRGet , 0x30) +defOpCode(opRSet , 0x31) +defOpCode(opRSetQ , 0x32) +defOpCode(opRAppend , 0x33) +defOpCode(opRAppendQ , 0x34) +defOpCode(opRPrepend , 0x35) +defOpCode(opRPrependQ , 0x36) +defOpCode(opRDelete , 0x37) +defOpCode(opRDeleteQ , 0x38) +defOpCode(opRIncr , 0x39) +defOpCode(opRIncrQ , 0x3a) +defOpCode(opRDecr , 0x3b) +defOpCode(opRDecrQ , 0x3c) +defOpCode(opSetVBucket , 0x3d) +defOpCode(opGetVBucket , 0x3e) +defOpCode(opDelVBucket , 0x3f) + +defOpCode(opTAPConnect , 0x40) +defOpCode(opTAPMutation , 0x41) +defOpCode(opTAPDelete , 0x42) +defOpCode(opTAPFlush , 0x43) +defOpCode(opTAPOpaque , 0x44) +defOpCode(opTAPVBucketSet , 0x45) +defOpCode(opTAPCheckpointStart, 0x46) +defOpCode(opTAPCheckpointEnd , 0x47) + +#undef defOpCode diff --git a/src/Database/Memcached/Binary/Maybe.hs b/src/Database/Memcached/Binary/Maybe.hs new file mode 100644 --- /dev/null +++ b/src/Database/Memcached/Binary/Maybe.hs @@ -0,0 +1,28 @@ +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE NoMonomorphismRestriction #-} +{-# LANGUAGE CPP #-} + +module Database.Memcached.Binary.Maybe +#include "Header.txt" + +#define NoReturn Bool +#define HasReturn Maybe + +successHasReturn :: a -> IO (HasReturn a) +successHasReturn = return . Just +{-# INLINE successHasReturn #-} + +successNoReturn :: IO NoReturn +successNoReturn = return True +{-# INLINE successNoReturn #-} + +failureHasReturn :: I.Failure (HasReturn a) +failureHasReturn _ _ = return Nothing +{-# INLINE failureHasReturn #-} + +failureNoReturn :: I.Failure NoReturn +failureNoReturn _ _ = return False +{-# INLINE failureNoReturn #-} + +#include "Common.hs" diff --git a/src/Database/Memcached/Binary/Types.hs b/src/Database/Memcached/Binary/Types.hs new file mode 100644 --- /dev/null +++ b/src/Database/Memcached/Binary/Types.hs @@ -0,0 +1,42 @@ +module Database.Memcached.Binary.Types where + +import Network + +import Data.Time.Clock +import Data.Word +import Data.Default.Class +import qualified Data.ByteString as S +import qualified Data.ByteString.Lazy as L + +type User = S.ByteString +type Password = S.ByteString + +data Auth + = Plain User Password + deriving Show + +data ConnectInfo = ConnectInfo + { connectHost :: HostName + , connectPort :: PortID + , connectAuth :: [Auth] + , numConnection :: Int + , connectionIdleTime :: NominalDiffTime + } deriving Show + +-- | +-- @ +-- def = ConnectInfo "localhost" (PortNumber 11211) [] 1 20 +-- @ +instance Default ConnectInfo where + def = ConnectInfo "localhost" (PortNumber 11211) [] 1 20 + +type Flags = Word32 +type Key = S.ByteString +type Value = L.ByteString +type Expiry = Word32 + +newtype CAS = CAS Word64 deriving (Show) + +type Delta = Word64 +type Initial = Word64 +type Counter = Word64 diff --git a/src/Database/Memcached/Binary/Types/Exception.hs b/src/Database/Memcached/Binary/Types/Exception.hs new file mode 100644 --- /dev/null +++ b/src/Database/Memcached/Binary/Types/Exception.hs @@ -0,0 +1,36 @@ +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE CPP #-} + +module Database.Memcached.Binary.Types.Exception where + +import Control.Exception +import Data.Word +import Data.Typeable +import qualified Data.ByteString as S + +data MemcachedException = MemcachedException + {-# UNPACK #-} !Word16 {-# UNPACK #-} !S.ByteString + deriving (Show, Typeable) + +instance Exception MemcachedException + +#define defExceptionP(n,w) n :: MemcachedException -> Bool;\ +n (MemcachedException i _) = i == w + +defExceptionP(isKeyNotFound , 0x01) +defExceptionP(isKeyExists , 0x02) +defExceptionP(isValueTooLarge , 0x03) +defExceptionP(isInvalidArguments , 0x04) +defExceptionP(isItemNotStored , 0x05) +defExceptionP(isIncrDecrOnNonNumeric , 0x06) +defExceptionP(isVBucketBelongsToAnotherServer , 0x07) +defExceptionP(isAuthenticationError , 0x08) +defExceptionP(isAuthenticationContinue , 0x09) +defExceptionP(isUnknownCommand , 0x81) +defExceptionP(isOutOfMemory , 0x82) +defExceptionP(isNotSupported , 0x83) +defExceptionP(isInternalError , 0x84) +defExceptionP(isBusy , 0x85) +defExceptionP(isTemporaryFailure , 0x86) + +#undef defExceptionP diff --git a/test/test.hs b/test/test.hs new file mode 100644 --- /dev/null +++ b/test/test.hs @@ -0,0 +1,485 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE LambdaCase #-} + +module Main (main) where + +import Network +import System.Process + +import Control.Exception +import Control.Concurrent +import Control.Monad + +import Data.Default.Class +import Data.Maybe +import Data.Word +import Data.Typeable +import Data.Version +import qualified Data.ByteString.Char8 as S +import qualified Data.ByteString.Lazy.Char8 as L + +import Database.Memcached.Binary.Types.Exception +import Database.Memcached.Binary.IO (Connection, withConnection) +import qualified Database.Memcached.Binary.IO as McIO +import qualified Database.Memcached.Binary.Maybe as McMaybe + +import Test.HUnit hiding (Test) +import Test.Framework +import Test.Framework.Providers.HUnit + +startMemcached :: IO ProcessHandle +startMemcached = do + h <- spawnProcess "memcached" [] + wait (100 :: Int) + return h + where + wait 0 = fail "cannot start server" + wait i = handle (\(_ ::SomeException) -> threadDelay 100000 >> wait (i-1)) $ + void $ connectTo "localhost" $ PortNumber 11211 + +precond :: Connection -> IO () +precond c = do + McIO.flushAll c + void $ McIO.set 0 0 "foo" "foovalue" c + void $ McIO.set 1 0 "bar" "1234567890" c + +testMc :: TestName -> (Connection -> IO ()) -> Test +testMc title m = testCase title $ withConnection def (\c -> precond c >> m c) + +newtype ByPassException = ByPassException String deriving (Typeable) +instance Show ByPassException where + show (ByPassException s) = s + +instance Exception ByPassException + +assertException :: Word16 -> S.ByteString -> IO a -> IO () +assertException ex msg m = + (m >> throwIO (ByPassException "exception not occured.")) `catch` + (\e -> case fromException e :: Maybe MemcachedException of + Nothing -> assertFn e + Just e'@(MemcachedException i _) -> unless (i == ex) (assertFn e')) + where + assertFn e = assertFailure $ unlines + [ "not expected exception occured:" + , "expected: " ++ show (MemcachedException ex msg) + , "occured: " ++ show e + ] + +testGet :: Test +testGet = testGroup "get" + [ testGroup "IO module" + [ testGroup "get" + [ doTest "foo" (0, "foovalue") McIO.get + , doTest "bar" (1, "1234567890") McIO.get + , doTestException "notexist" McIO.get + ] + , testGroup "get_" + [ doTest "foo" "foovalue" McIO.get_ + , doTest "bar" "1234567890" McIO.get_ + , doTestException "notexist" McIO.get_ + ] + ] + , testGroup "Maybe module" + [ testGroup "get" + [ doTest "foo" (Just (0, "foovalue")) McMaybe.get + , doTest "bar" (Just (1, "1234567890")) McMaybe.get + , doTest "notexist" Nothing McMaybe.get + ] + , testGroup "get_" + [ doTest "foo" (Just "foovalue") McMaybe.get_ + , doTest "bar" (Just "1234567890") McMaybe.get_ + , doTest "notexist" Nothing McMaybe.get_ + ] + ] + ] + where + doTest key ex fn = testMc (S.unpack key) $ \c -> do + v <- fn key c + v @?= ex + doTestException key fn = testMc (S.unpack key) $ \c -> + assertException 1 "Not found" $ fn key c + +testSetAddReplace :: Test +testSetAddReplace = testGroup "set/add/replace" + [ testGroup "set" + [ testMc "set foo to foomod" $ \c -> do + McIO.set 100 0 "foo" "foomod" c + v <- McIO.get "foo" c + v @?= (100, "foomod") + , testMc "set notexist to exist" $ \c -> do + McIO.set 100 0 "notexist" "exist" c + v <- McIO.get "notexist" c + v @?= (100, "exist") + ] + , testGroup "add" + [ testMc "add foo to foomod" $ \c -> + assertException 2 "Data exists for key." $ + McIO.add 100 0 "foo" "foomod" c + , testMc "add notexist to exist" $ \c -> do + McIO.add 100 0 "notexist" "exist" c + v <- McIO.get "notexist" c + v @?= (100, "exist") + ] + , testGroup "replace" + [ testMc "set foo to foomod" $ \c -> do + McIO.replace 100 0 "foo" "foomod" c + v <- McIO.get "foo" c + v @?= (100, "foomod") + , testMc "set notexist to exist" $ \c -> + assertException 1 "Not found" $ + McIO.replace 100 0 "notexist" "exist" c + ] + ] + +testDelete :: Test +testDelete = testGroup "delete" + [ testGroup "IO module" + [ testMc "foo" $ \c -> do + McIO.delete "foo" c + r <- McMaybe.get "foo" c + r @?= Nothing + , testMc "notexist" $ \c -> + assertException 1 "Not found" $ McIO.delete "notexist" c + ] + , testGroup "Maybe module" + [ testMc "foo" $ \c -> do + b <- McMaybe.delete "foo" c + r <- McMaybe.get "foo" c + b @?= True + r @?= Nothing + , testMc "notexist" $ \c -> do + b <- McMaybe.delete "notexist" c + r <- McMaybe.get "notexist" c + b @?= False + r @?= Nothing + ] + ] + +-- https://code.google.com/p/memcached/wiki/ReleaseNotes1417 +testIncrDecr :: Version -> Test +testIncrDecr v = testGroup "increment/decrement" + [ testGroup "IO module" + [ testGroup "increment" + [ testMc "foo" $ \c -> + assertException 6 "Non-numeric server-side value for incr or decr" $ + McIO.increment 0 "foo" 10 10 c + , testMc "bar" $ \c -> do + a <- McIO.increment 0 "bar" 10 10 c + b <- McIO.get_ "bar" c + a @?= 1234567900 + b @?= "1234567900" + , testMc "notexist" $ \c -> do + a <- McIO.increment 0 "notexist" 10 10 c + b <- McIO.get_ "notexist" c + a @?= 10 + when (v >= ev) $ b @?= "10" + ] + , testGroup "decrement" + [ testMc "foo" $ \c -> + assertException 6 "Non-numeric server-side value for incr or decr" $ + McIO.decrement 0 "foo" 10 10 c + , testMc "bar" $ \c -> do + a <- McIO.decrement 0 "bar" 10 10 c + b <- McIO.get_ "bar" c + a @?= 1234567880 + b @?= "1234567880" + , testMc "notexist" $ \c -> do + a <- McIO.decrement 0 "notexist" 10 10 c + b <- McIO.get_ "notexist" c + a @?= 10 + when (v >= ev) $ b @?= "10" + ] + ] + , testGroup "Maybe module" + [ testGroup "increment" + [ testMc "foo" $ \c -> do + r <- McMaybe.increment 0 "foo" 10 10 c + b <- McIO.get_ "foo" c + r @?= Nothing + b @?= "foovalue" + , testMc "bar" $ \c -> do + a <- McMaybe.increment 0 "bar" 10 10 c + b <- McIO.get_ "bar" c + a @?= Just 1234567900 + b @?= "1234567900" + , testMc "notexist" $ \c -> do + a <- McMaybe.increment 0 "notexist" 10 10 c + b <- McIO.get_ "notexist" c + a @?= Just 10 + when (v >= ev) $ b @?= "10" + ] + , testGroup "decrement'" + [ testMc "foo" $ \c -> do + r <- McMaybe.decrement 0 "foo" 10 10 c + b <- McIO.get_ "foo" c + r @?= Nothing + b @?= "foovalue" + , testMc "bar" $ \c -> do + a <- McMaybe.decrement 0 "bar" 10 10 c + b <- McIO.get_ "bar" c + a @?= Just 1234567880 + b @?= "1234567880" + , testMc "notexist" $ \c -> do + a <- McMaybe.decrement 0 "notexist" 10 10 c + b <- McIO.get_ "notexist" c + a @?= Just 10 + when (v >= ev) $ b @?= "10" + ] + ] + ] + where + ev = Version [1,4,17] [] + +testFlush :: Test +testFlush = testGroup "flush" + [ testGroup "IO module" + [ testMc "flushAll" $ \c -> do + McIO.flushAll c + a <- McMaybe.get "foo" c + a @?= Nothing + ] + , testGroup "Maybe module" + [ testMc "flushAll" $ \c -> do + r <- McMaybe.flushAll c + a <- McMaybe.get "foo" c + r @?= True + a @?= Nothing + ] + ] + +testVersion :: Test +testVersion = testGroup "version" + [ testGroup "versionString" + [ testMc "IO module" $ \c -> do + v <- McIO.versionString c + assertBool (show v ++ " is not version like.") $ isVersionLike v + , testMc "Maybe module" $ \c -> do + Just v <- McMaybe.versionString c + assertBool (show v ++ " is not version like.") $ isVersionLike v + ] + , testGroup "version" + [ testMc "IO module" $ \c -> do + v <- McIO.version c + assertEqual "version branch length" 3 (length $ versionBranch v) + ] + ] + where + isVersionLike s0 = isJust $ do + (_, s1) <- S.readInt s0 + unless (S.head s1 == '.') Nothing + (_, s2) <- S.readInt (S.tail s1) + unless (S.head s2 == '.') Nothing + (_, s3) <- S.readInt (S.tail s2) + unless (S.null s3) Nothing + +testNoOp :: Test +testNoOp = testGroup "noOp" + [ testMc "IO module" McIO.noOp + , testMc "Maybe module" $ \c -> do + b <- McMaybe.noOp c + b @?= True + ] + +testAppendPrepend :: Test +testAppendPrepend = testGroup "append/prepend" + [ testGroup "IO module" + [ testGroup "append" + [ testMc "foo" $ \c -> do + McIO.append "foo" "!!" c + a <- McIO.get_ "foo" c + a @?= "foovalue!!" + , testMc "bar" $ \c -> do + McIO.append "bar" "!!" c + a <- McIO.get_ "bar" c + a @?= "1234567890!!" + , testMc "notexist" $ \c -> + assertException 5 "Not stored." $ McIO.append "notexist" "!!" c + ] + , testGroup "prepend" + [ testMc "foo" $ \c -> do + McIO.prepend "foo" "!!" c + a <- McIO.get_ "foo" c + a @?= "!!foovalue" + , testMc "bar" $ \c -> do + McIO.prepend "bar" "!!" c + a <- McIO.get_ "bar" c + a @?= "!!1234567890" + , testMc "notexist" $ \c -> + assertException 5 "Not stored." $ McIO.prepend "notexist" "!!" c + ] + ] + , testGroup "maybe module" + [ testGroup "append'" + [ testMc "foo" $ \c -> do + b <- McMaybe.append "foo" "!!" c + a <- McIO.get_ "foo" c + b @?= True + a @?= "foovalue!!" + , testMc "bar" $ \c -> do + b <- McMaybe.append "bar" "!!" c + a <- McIO.get_ "bar" c + b @?= True + a @?= "1234567890!!" + , testMc "notexist" $ \c -> do + b <- McMaybe.append "notexist" "!!" c + b @?= False + ] + , testGroup "prepend'" + [ testMc "foo" $ \c -> do + b <- McMaybe.prepend "foo" "!!" c + a <- McIO.get_ "foo" c + b @?= True + a @?= "!!foovalue" + , testMc "bar" $ \c -> do + b <- McMaybe.prepend "bar" "!!" c + a <- McIO.get_ "bar" c + b @?= True + a @?= "!!1234567890" + , testMc "notexist" $ \c -> do + b <- McMaybe.prepend "notexist" "!!" c + b @?= False + ] + ] + ] + +-- https://code.google.com/p/memcached/wiki/ReleaseNotes1414 +-- https://code.google.com/p/memcached/issues/detail?id=275 +testTouchGAT :: Version -> Test +testTouchGAT v = testGroup "touch/GAT" + [ testGroup "IO module" + [ testGroup "touch" + [ testMc "foo" $ \c -> do + a <- McMaybe.get_ "foo" c + McIO.touch 1 "foo" c + a @?= (Just "foovalue") + when (v >= ev) $ do + threadDelay 1100000 + b <- McMaybe.get_ "foo" c + b @?= Nothing + , testMc "notexist" $ \c -> + assertException 1 "Not found" $ McIO.touch 1 "notexist" c + ] + , testGroup "getAndTouch" + [ testMc "foo" $ \c -> do + x <- McMaybe.get "foo" c + y <- McIO.getAndTouch 1 "foo" c + x @?= Just (0, "foovalue") + y @?= (0, "foovalue") + when (v >= ev) $ do + threadDelay 1100000 + z <- McMaybe.get "foo" c + z @?= Nothing + , testMc "notexist" $ \c -> + assertException 1 "Not found" $ McIO.getAndTouch 1 "notexist" c + ] + , testGroup "getAndTouch_" + [ testMc "foo" $ \c -> do + x <- McMaybe.get_ "foo" c + y <- McIO.getAndTouch_ 1 "foo" c + x @?= Just "foovalue" + y @?= "foovalue" + when (v >= ev) $ do + threadDelay 1100000 + z <- McMaybe.get_ "foo" c + z @?= Nothing + , testMc "notexist" $ \c -> + assertException 1 "Not found" $ McIO.getAndTouch_ 1 "notexist" c + ] + ] + , testGroup "Maybe module" + [ testGroup "touch" + [ testMc "foo" $ \c -> do + a <- McMaybe.get_ "foo" c + r <- McMaybe.touch 1 "foo" c + a @?= (Just "foovalue") + r @?= True + when (v >= ev) $ do + threadDelay 1100000 + b <- McMaybe.get_ "foo" c + b @?= Nothing + , testMc "notexist" $ \c -> do + r <- McMaybe.touch 1 "notexist" c + a <- McMaybe.get "notexist" c + r @?= False + a @?= Nothing + ] + , testGroup "getAndTouch'/getMaybeAndTouch" + [ testMc "foo" $ \c -> do + a <- McMaybe.get "foo" c + r <- McMaybe.getAndTouch 1 "foo" c + a @?= Just (0, "foovalue") + r @?= Just (0, "foovalue") + when (v >= ev) $ do + threadDelay 1100000 + b <- McMaybe.get_ "foo" c + b @?= Nothing + , testMc "notexist" $ \c -> do + r <- McMaybe.getAndTouch 1 "notexist" c + a <- McMaybe.get "notexist" c + r @?= Nothing + a @?= Nothing + ] + , testGroup "getAndTouch'_/getMaybeAndTouch_" + [ testMc "foo" $ \c -> do + a <- McMaybe.get_ "foo" c + r <- McMaybe.getAndTouch_ 1 "foo" c + a @?= Just "foovalue" + r @?= Just "foovalue" + when (v >= ev) $ do + threadDelay 1100000 + b <- McMaybe.get_ "foo" c + b @?= Nothing + , testMc "notexist" $ \c -> do + r <- McMaybe.getAndTouch_ 1 "notexist" c + a <- McMaybe.get "notexist" c + r @?= Nothing + a @?= Nothing + ] + ] + ] + where + ev = Version [1,4,14] [] + +testModify :: Test +testModify = testGroup "modify" + [ testMc "reverse foo" $ \c -> do + r <- McIO.modify 0 "foo" (\f v -> (f + 100, L.reverse v, v)) c + a <- McMaybe.get "foo" c + r @?= "foovalue" + a @?= Just (100, "eulavoof") + , testMc "notexist" $ \c -> + assertException 1 "Not found" $ + McIO.modify 0 "notexist" (\f v -> (f,v,())) c + ] + +testModify_ :: Test +testModify_ = testGroup "modify_" + [ testMc "reverse foo" $ \c -> do + McIO.modify_ 0 "foo" (\f v -> (f + 100, L.reverse v)) c + a <- McMaybe.get "foo" c + a @?= Just (100, "eulavoof") + , testMc "notexist" $ \c -> + assertException 1 "Not found" $ + McIO.modify_ 0 "notexist" (\f v -> (f,v)) c + ] + + + +main :: IO () +main = bracket startMemcached terminateProcess $ \_ -> do + v <- McIO.withConnection def McIO.version + defaultMain + [ testGet + , testSetAddReplace + , testDelete + , testIncrDecr v + , testFlush + , testVersion + , testNoOp + , testAppendPrepend + , testTouchGAT v + , testModify + , testModify_ + ]