diff --git a/.gitignore b/.gitignore new file mode 100644 index 0000000..cef4194 --- /dev/null +++ b/.gitignore @@ -0,0 +1,3 @@ +.cabal-sandbox +cabal.sandbox.config +dist diff --git a/.travis.yml b/.travis.yml new file mode 100644 index 0000000..5c7e760 --- /dev/null +++ b/.travis.yml @@ -0,0 +1,4 @@ +language: haskell +ghc: + - 7.8 + - 7.6 diff --git a/LICENSE b/LICENSE new file mode 100644 index 0000000..5c98426 --- /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 index 0000000..9a994af --- /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 index 0000000..7817033 --- /dev/null +++ b/memcached-binary.cabal @@ -0,0 +1,30 @@ +name: memcached-binary +version: 0.1.0 +synopsis: memcached client using binary protocol. +license: MIT +license-file: LICENSE +author: Hirotomo Moriwaki +maintainer: philopon.dependence@gmail.com +copyright: (c) 2014 Hirotomo Moriwaki +category: Database +build-type: Simple +cabal-version: >=1.10 + +library + exposed-modules: Database.Memcached.Binary + Database.Memcached.Binary.Exception + Database.Memcached.Binary.Types + Database.Memcached.Binary.Internal + Database.Memcached.Binary.Internal.Definition + build-depends: base >=4.7 && <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 diff --git a/src/Database/Memcached/Binary.hs b/src/Database/Memcached/Binary.hs new file mode 100644 index 0000000..d26d92f --- /dev/null +++ b/src/Database/Memcached/Binary.hs @@ -0,0 +1,291 @@ +{-# 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 + ) 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'_ diff --git a/src/Database/Memcached/Binary/Exception.hs b/src/Database/Memcached/Binary/Exception.hs new file mode 100644 index 0000000..25950c4 --- /dev/null +++ b/src/Database/Memcached/Binary/Exception.hs @@ -0,0 +1,36 @@ +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE CPP #-} + +module Database.Memcached.Binary.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/src/Database/Memcached/Binary/Internal.hs b/src/Database/Memcached/Binary/Internal.hs new file mode 100644 index 0000000..752c674 --- /dev/null +++ b/src/Database/Memcached/Binary/Internal.hs @@ -0,0 +1,307 @@ +{-# 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.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 _ = return () + +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 :: (CAS -> 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 + +get :: (CAS -> 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 + -> 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 (\_ p -> getCAS p >>= success) failure + +delete :: (CAS -> 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 + +incrDecr :: (CAS -> 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 + c <- getCAS p + void $ hGetBuf h p 8 + peekWord64be p >>= success c + +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 :: (CAS -> 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 + +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 :: (CAS -> 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 index 0000000..c8e7a94 --- /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/Types.hs b/src/Database/Memcached/Binary/Types.hs new file mode 100644 index 0000000..7de740d --- /dev/null +++ b/src/Database/Memcached/Binary/Types.hs @@ -0,0 +1,38 @@ +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 + +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