haskell/memcached-binary
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

about done.

Browse Source
This commit is contained in:
philopon 2014-08-26 19:59:23 +09:00
parent 2e0469483a
commit 6b682aa965
10 changed files with 807 additions and 0 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

3
.gitignore vendored Normal file
View File

@ -0,0 +1,3 @@
.cabal-sandbox
cabal.sandbox.config
dist

4
.travis.yml Normal file
View File

@ -0,0 +1,4 @@
language: haskell
ghc:
- 7.8
- 7.6

20
LICENSE Normal file
View File

@ -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.

2
Setup.hs Normal file
View File

@ -0,0 +1,2 @@
import Distribution.Simple
main = defaultMain

30
memcached-binary.cabal Normal file
View File

@ -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

291
src/Database/Memcached/Binary.hs Normal file
View File

@ -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'_

36
src/Database/Memcached/Binary/Exception.hs Normal file
View File

@ -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

307
src/Database/Memcached/Binary/Internal.hs Normal file
View File

@ -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)

76
src/Database/Memcached/Binary/Internal/Definition.hs Normal file
View File

@ -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

38
src/Database/Memcached/Binary/Types.hs Normal file
View File

@ -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