starling 0.1.1 → 0.2.0
raw patch · 4 files changed
+148/−36 lines, 4 filesdep +failure
Dependencies added: failure
Files
- CHANGES +5/−0
- Network/Starling.hs +99/−31
- Network/Starling/Core.hs +41/−3
- starling.cabal +3/−2
CHANGES view
@@ -1,3 +1,8 @@+0.2.0++ - Switch from weird error results to failure framework+ - Experimental SASL support+ 0.1.1 - Updated Cabal file to point to a real
Network/Starling.hs view
@@ -1,9 +1,11 @@-+{-# LANGUAGE DeriveDataTypeable,+ FlexibleContexts+ #-} {-| Module: Network.Starling-Copyright: Antoine Latter 2009+Copyright: Antoine Latter 2009-2010 Maintainer: Antoine Latter <aslatter@gmail.com> A haskell implementation of the memcahed@@ -38,8 +40,7 @@ , Connection , Key , Value- , Result- , ResultM+ , StarlingError(..) , ResponseStatus(..) , set , get@@ -53,6 +54,11 @@ , stats -- , oneStat -- doesn't seem to work for me , version+ , listAuthMechanisms+ , auth+ , AuthMechanism+ , AuthData+ , AuthCallback(..) ) where import Network.Starling.Connection@@ -68,43 +74,61 @@ , stat , version , quit+ , listAuthMechanisms+ , startAuth+ , stepAuth ) import qualified Network.Starling.Core as Core import Data.ByteString.Lazy (ByteString) import qualified Data.ByteString.Lazy as BS+import qualified Data.ByteString.Lazy.Char8 as BS8 import qualified Data.Binary.Get as B import Data.Word+import Data.Typeable+import Control.Exception (Exception(..)) import Control.Monad.Trans (liftIO, MonadIO) -type Result a = ResultM IO a+import Control.Failure --- | If an operation fails the result will return in 'Left'--- with the failure code and a text description of the failure-type ResultM m a = m (Either (ResponseStatus, ByteString) a)+-- | An error consists of the error code returned by the+-- server and a human-readble error string returned by the server.+data StarlingError = StarlingError ResponseStatus ByteString+ deriving Typeable +instance Show StarlingError where+ show (StarlingError err str)+ = "StarlingError: " ++ show err ++ " " ++ show (BS8.unpack str)++instance Exception StarlingError+ -- | Set a value in the cache-set :: Connection -> Key -> Value -> Result ()+set :: (MonadIO m, MonadFailure StarlingError m)+ => Connection -> Key -> Value -> m () set con key value = simpleRequest con (Core.set key value) (const ()) -- | Set a vlue in the cache. Fails if a value is already defined -- for the indicated key.-add :: Connection -> Key -> Value -> Result ()+add :: (MonadIO m, MonadFailure StarlingError m) =>+ Connection -> Key -> Value -> m () add con key value = simpleRequest con (Core.add key value) (const ()) -- | Set a value in the cache. Fails if a value is not already defined -- for the indicated key.-replace :: Connection -> Key -> Value -> Result ()+replace :: (MonadIO m, MonadFailure StarlingError m) =>+ Connection -> Key -> Value -> m () replace con key value = simpleRequest con (Core.replace key value) (const ()) -- | Retrive a value from the cache-get :: Connection -> Key -> Result ByteString+get :: (MonadIO m, MonadFailure StarlingError m) =>+ Connection -> Key -> m ByteString get con key = simpleRequest con (Core.get key) rsBody -- | Delete an entry in the cache-delete :: Connection -> Key -> Result ()+delete :: (MonadIO m, MonadFailure StarlingError m) =>+ Connection -> Key -> m () delete con key = simpleRequest con (Core.delete key) (const ()) -- | Update a value in the cache. This operation requires two round trips.@@ -115,8 +139,8 @@ -- -- Testing indicates that if we fail because we could not gaurantee -- atomicity the failure code will be 'KeyExists'.-update :: MonadIO m =>- Connection -> Key -> (Value -> m (Maybe Value)) -> ResultM m ()+update :: (MonadIO m, MonadFailure StarlingError m) =>+ Connection -> Key -> (Value -> m (Maybe Value)) -> m () update con key f = do response <- liftIO $ synchRequest con (Core.get key)@@ -129,14 +153,15 @@ Nothing -> Core.delete key Just newVal -> Core.replace key newVal request = addCAS cas $ baseRequest- liftIO $ simpleRequest con request (const ())- _ -> return . errorResult $ response+ simpleRequest con request (const ())+ _ -> errorResult response -- | Increment a value in the cache. The first 'Word64' argument is the -- amount by which to increment and the second is the intial value to -- use if the key does not yet have a value. -- The return value is the updated value in the cache.-increment :: Connection -> Key -> Word64 -> Word64 -> Result Word64+increment :: (MonadIO m, MonadFailure StarlingError m) =>+ Connection -> Key -> Word64 -> Word64 -> m Word64 increment con key amount init = simpleRequest con (Core.increment key amount init) $ \response -> B.runGet B.getWord64be (rsBody response)@@ -145,36 +170,40 @@ -- amount by which to decrement and the second is the intial value to -- use if the key does not yet have a value. -- The return value is the updated value in the cache.-decrement :: Connection -> Key -> Word64 -> Word64 -> Result Word64+decrement :: (MonadIO m, MonadFailure StarlingError m) =>+ Connection -> Key -> Word64 -> Word64 -> m Word64 decrement con key amount init = simpleRequest con (Core.decrement key amount init) $ \response -> B.runGet B.getWord64be (rsBody response) -- | Delete all entries in the cache-flush :: Connection -> Result ()+flush :: (MonadIO m, MonadFailure StarlingError m) =>+ Connection -> m () flush con = simpleRequest con Core.flush (const ()) -simpleRequest :: Connection -> Request -> (Response -> a) -> Result a+simpleRequest :: (MonadIO m, MonadFailure StarlingError m) =>+ Connection -> Request -> (Response -> a) -> m a simpleRequest con req f = do- response <- synchRequest con req+ response <- liftIO $ synchRequest con req if rsStatus response == NoError- then return . Right . f $ response- else return . errorResult $ response+ then return . f $ response+ else errorResult response -errorResult response = Left (rsStatus response, rsBody response)+errorResult response = failure $ StarlingError (rsStatus response) (rsBody response) -- | Returns a list of stats about the server in key,value pairs-stats :: Connection -> Result [(ByteString,ByteString)]+stats :: (MonadIO m, MonadFailure StarlingError m) =>+ Connection -> m [(ByteString,ByteString)] stats con = do- resps <- synchRequestMulti con $ Core.stat Nothing+ resps <- liftIO $ synchRequestMulti con $ Core.stat Nothing if null resps then error "fatal error in Network.Starling.stats" else do let resp = head resps if rsStatus resp == NoError- then return . Right . unpackStats $ resps- else return $ errorResult resp+ then return . unpackStats $ resps+ else errorResult resp where @@ -184,10 +213,49 @@ -- | Returns a single stat. Example: 'stat con "pid"' will return -- the -oneStat :: Connection -> Key -> Result ByteString+oneStat :: (MonadIO m, MonadFailure StarlingError m) =>+ Connection -> Key -> m ByteString oneStat con key = simpleRequest con (Core.stat $ Just key) rsBody +-- | List allowed SASL mechanisms. The server must support SASL+-- authentication.+listAuthMechanisms :: (MonadIO m, MonadFailure StarlingError m) =>+ Connection -> m [AuthMechanism]+listAuthMechanisms con+ = simpleRequest con Core.listAuthMechanisms (BS8.words . rsBody)++-- | Some authentications require mutliple back and forths between the+-- client and the server. This type encapsulates that.+data AuthCallback m = AuthCallback (ByteString -> m (AuthData, Maybe (AuthCallback m)))++-- | SASL authenitcation. Multi-step authentication is supported by un-folding+-- the passed-in AuthCallback. Returns 'True' if authentication is supported+-- and complete. If the supplied callback completes while there are still steps+-- remaining we throw FurtherAuthRequired.+auth :: (MonadIO m, MonadFailure StarlingError m) =>+ Connection -> AuthMechanism -> AuthData -> Maybe (AuthCallback m) -> m Bool+auth con mech auth authCallback+ = auth' Core.startAuth con mech auth authCallback++auth' req con mech auth authCallback = do+ response <- liftIO $ synchRequest con $ req mech auth+ case rsStatus response of+ NoError -> return True+ AuthRequired -> return False+ FurtherAuthRequired+ -> do+ case authCallback of+ Nothing -> errorResult response+ Just (AuthCallback f) -> do+ next <- f (rsBody response)+ case next of+ (newAuth, newCallback)+ -> auth' Core.stepAuth con mech newAuth newCallback+ _ -> errorResult response+ + -- | Returns the version of the server-version :: Connection -> Result ByteString+version :: (MonadIO m, MonadFailure StarlingError m) =>+ Connection -> m ByteString version con = simpleRequest con Core.version rsBody
Network/Starling/Core.hs view
@@ -27,6 +27,11 @@ , noop , version , stat+ , listAuthMechanisms+ , startAuth+ , stepAuth+ , AuthMechanism+ , AuthData , addOpaque , addCAS , Response(..)@@ -155,6 +160,23 @@ stat :: Maybe Key -> Request stat mkey = request Stat BS.empty (fromMaybe BS.empty mkey) BS.empty +-- | List SASL authenitication mechanisms, space delimeted+listAuthMechanisms :: Request+listAuthMechanisms = request ListAuthMechanisms BS.empty BS.empty BS.empty++-- | Begin SASL authentication. May return the further auth+-- required error if further steps are needed.+startAuth :: AuthMechanism -> AuthData -> Request+startAuth mech auth = request StartAuth BS.empty mech auth++-- | Continue SASL authentication. May return the further+-- aut required error if further steps are needed.+stepAuth :: AuthMechanism -> AuthData -> Request+stepAuth mech auth = request StepAuth BS.empty mech auth++type AuthMechanism = ByteString+type AuthData = ByteString+ -- | Add an opaque marker to a request. -- This is returned unchanged in the corresponding -- response.@@ -211,7 +233,8 @@ -- defaults. The opcode field is left undefined. baseRequest :: Request baseRequest- = Req { rqMagic = Request+ = Req { rqOp = undefined+ , rqMagic = Request , rqKey = BS.empty , rqExtras = BS.empty , rqDataType = RawData@@ -344,10 +367,14 @@ | InvalidArguments | ItemNotStored | IncrDecrOnNonNumeric+ | AuthRequired+ | FurtherAuthRequired | UnknownCommand | OutOfMemory- deriving (Eq, Ord, Read, Show)+ deriving (Eq, Ord, Read, Show, Typeable) +instance Exception ResponseStatus+ instance Deserialize ResponseStatus where deserialize = do status <- B.getWord16be@@ -359,6 +386,8 @@ 0x0004 -> InvalidArguments 0x0005 -> ItemNotStored 0x0006 -> IncrDecrOnNonNumeric+ 0x0020 -> AuthRequired+ 0x0021 -> FurtherAuthRequired 0x0081 -> UnknownCommand 0x0082 -> OutOfMemory @@ -390,6 +419,9 @@ | FlushQ | AppendQ | PrependQ+ | ListAuthMechanisms+ | StartAuth+ | StepAuth deriving (Eq, Ord, Read, Show) instance Serialize OpCode where@@ -420,6 +452,9 @@ serialize FlushQ = B.singleton 0x18 serialize AppendQ = B.singleton 0x19 serialize PrependQ = B.singleton 0x1a+ serialize ListAuthMechanisms = B.singleton 0x20+ serialize StartAuth = B.singleton 0x21+ serialize StepAuth = B.singleton 0x22 instance Deserialize OpCode where deserialize = do@@ -451,5 +486,8 @@ 0x17 -> QuitQ 0x18 -> FlushQ 0x19 -> AppendQ- 0x20 -> PrependQ+ 0x1a -> PrependQ+ 0x20 -> ListAuthMechanisms+ 0x21 -> StartAuth+ 0x22 -> StepAuth
starling.cabal view
@@ -1,5 +1,5 @@ name: starling-version: 0.1.1+version: 0.2.0 stability: Alpha synopsis: A memcached client@@ -28,7 +28,8 @@ location: http://community.haskell.org/~aslatter/code/starling library- build-depends: base == 4.*, binary, bytestring, transformers == 0.1.*+ build-depends: base == 4.*, binary, bytestring,+ transformers == 0.1.*, failure == 0.0.* exposed-modules: Network.Starling