module Network.Starling
( open
, close
, Connection
, Key
, Value
, StarlingError(..)
, ResponseStatus(..)
, set
, get
, delete
, add
, replace
, update
, increment
, decrement
, flush
, stats
, version
, listAuthMechanisms
, auth
, AuthMechanism
, AuthData
, AuthCallback(..)
) where
import Network.Starling.Connection
import Network.Starling.Core hiding
( get
, set
, delete
, add
, replace
, increment
, decrement
, flush
, 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)
import Control.Failure
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 :: (MonadIO m, MonadFailure StarlingError m)
=> Connection -> Key -> Value -> m ()
set con key value = simpleRequest con (Core.set key value) (const ())
add :: (MonadIO m, MonadFailure StarlingError m) =>
Connection -> Key -> Value -> m ()
add con key value = simpleRequest con (Core.add key value) (const ())
replace :: (MonadIO m, MonadFailure StarlingError m) =>
Connection -> Key -> Value -> m ()
replace con key value = simpleRequest con (Core.replace key value) (const ())
get :: (MonadIO m, MonadFailure StarlingError m) =>
Connection -> Key -> m ByteString
get con key = simpleRequest con (Core.get key) rsBody
delete :: (MonadIO m, MonadFailure StarlingError m) =>
Connection -> Key -> m ()
delete con key = simpleRequest con (Core.delete key) (const ())
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)
case rsStatus response of
NoError -> do
let oldVal = rsBody response
cas = rsCas response
res <- f oldVal
let baseRequest = case res of
Nothing -> Core.delete key
Just newVal -> Core.replace key newVal
request = addCAS cas $ baseRequest
simpleRequest con request (const ())
_ -> errorResult response
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)
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)
flush :: (MonadIO m, MonadFailure StarlingError m) =>
Connection -> m ()
flush con = simpleRequest con Core.flush (const ())
simpleRequest :: (MonadIO m, MonadFailure StarlingError m) =>
Connection -> Request -> (Response -> a) -> m a
simpleRequest con req f
= do
response <- liftIO $ synchRequest con req
if rsStatus response == NoError
then return . f $ response
else errorResult response
errorResult response = failure $ StarlingError (rsStatus response) (rsBody response)
stats :: (MonadIO m, MonadFailure StarlingError m) =>
Connection -> m [(ByteString,ByteString)]
stats con
= do
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 . unpackStats $ resps
else errorResult resp
where
unpackStats
= filter (\(x,y) -> not (BS.null x && BS.null y)) .
map (\response -> (rsKey response, rsBody response))
oneStat :: (MonadIO m, MonadFailure StarlingError m) =>
Connection -> Key -> m ByteString
oneStat con key = simpleRequest con (Core.stat $ Just key) rsBody
listAuthMechanisms :: (MonadIO m, MonadFailure StarlingError m) =>
Connection -> m [AuthMechanism]
listAuthMechanisms con
= simpleRequest con Core.listAuthMechanisms (BS8.words . rsBody)
data AuthCallback m = AuthCallback (ByteString -> m (AuthData, Maybe (AuthCallback m)))
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
version :: (MonadIO m, MonadFailure StarlingError m) =>
Connection -> m ByteString
version con = simpleRequest con Core.version rsBody