diff --git a/CHANGES b/CHANGES --- a/CHANGES +++ b/CHANGES @@ -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 diff --git a/Network/Starling.hs b/Network/Starling.hs --- a/Network/Starling.hs +++ b/Network/Starling.hs @@ -1,9 +1,11 @@ - +{-# LANGUAGE DeriveDataTypeable, + FlexibleContexts + #-} {-| Module: Network.Starling -Copyright: Antoine Latter 2009 +Copyright: Antoine Latter 2009-2010 Maintainer: Antoine Latter 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 diff --git a/Network/Starling/Core.hs b/Network/Starling/Core.hs --- a/Network/Starling/Core.hs +++ b/Network/Starling/Core.hs @@ -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 diff --git a/starling.cabal b/starling.cabal --- a/starling.cabal +++ b/starling.cabal @@ -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