module Network.Memcache.Client (
Client
, StatsList
, Nodekey
, Key(..)
, Value(..)
, openClient
, closeClient
, clientNodekey
, clientSocket
, withClient
, withClients
, forEachClient
, set
, setEx
, cas
, casEx
, add
, addEx
, replace
, replaceEx
, get
, gets
, delete
, incr
, decr
, flushAll
, stats
, statsWithArgs
) where
import Prelude hiding (catch)
import System.IO
import Network
import Data.List.Split
import Control.Exception
import qualified Data.ByteString.Char8 as BS
import Control.Monad.IO.Class
import Data.Word
import Data.Hashable
import Network.Memcache.Types
import Network.Memcache.Op
import Network.Memcache.Response
import Network.Memcache.IO
data Client = MemcachedClient {
clientNodekey :: String
, clientSocket :: Handle
}
class (Hashable a) => Key a where
toBS :: a -> BS.ByteString
instance Key String where
toBS = BS.pack
instance Key BS.ByteString where
toBS k = k
class Value a where
serializeValue :: a -> BS.ByteString
deserializeValue :: BS.ByteString -> Either String a
instance Value String where
serializeValue = BS.pack
deserializeValue v = Right (BS.unpack v)
instance Value BS.ByteString where
serializeValue v = v
deserializeValue v = Right v
openClient :: (MonadIO m)
=> Nodekey
-> m (Maybe Client)
openClient nodekey = case hostnameAndPort nodekey of
Just (hostname, port) -> do
socket <- liftIO $ connectTo hostname (PortNumber (fromIntegral port))
return $ Just $ MemcachedClient nodekey socket
Nothing -> return Nothing
closeClient :: (MonadIO m)
=> Client
-> m ()
closeClient client = liftIO $ do
closeClient' `catch` ignoreException ()
hClose hSocket
where
hSocket = clientSocket client
closeClient' = do
BS.hPutStr hSocket $ BS.pack "quit\r\n"
hFlush hSocket
withClient :: Nodekey
-> (Client -> IO (Maybe a))
-> IO (Maybe a)
withClient nodekey = withClients [nodekey]
withClients :: [Nodekey]
-> (Client -> IO (Maybe a))
-> IO (Maybe a)
withClients nodekeys act = bracket (allocate nodekeys) release invoke
where
allocate :: [Nodekey] -> IO (Maybe Client)
allocate [] = return Nothing
allocate (n:ns) = do
r <- openClient n `catch` ignoreException Nothing
case r of
Nothing -> allocate ns
client -> return client
release client = case client of
Just c -> closeClient c
Nothing -> return ()
invoke client = case client of
Just c -> act c
Nothing -> return Nothing
forEachClient :: [Nodekey]
-> (Client -> IO (Maybe a))
-> IO ([Maybe a])
forEachClient clients act = do
mapM (\c -> withClient c act) clients
set :: (MonadIO m, Key k, Value v)
=> Client
-> k
-> v
-> m Bool
set = set' SetOp
setEx :: (MonadIO m, Key k, Value v)
=> Client
-> k
-> v
-> Word64
-> m Bool
setEx = opEx SetOp
set' :: (MonadIO m, Key k, Value v) => (BS.ByteString -> Word32 -> Word64 -> Word64 -> BS.ByteString -> [Option] -> Op) -> Client -> k -> v -> m Bool
set' op client key0 value0 = opEx op client key0 value0 0
opEx :: (MonadIO m, Key k, Value v) => (BS.ByteString -> Word32 -> Word64 -> Word64 -> BS.ByteString -> [Option] -> Op) -> Client -> k -> v -> Word64 -> m Bool
opEx op client key0 value0 exptime = do
let socket = clientSocket client
key = toBS key0
value = serializeValue value0
resp <- liftIO $ do
send socket $ op key 0 exptime (fromIntegral $ BS.length value) value []
recv socket :: IO (Maybe Response)
return (resp == Just Stored)
cas :: (MonadIO m, Key k, Value v)
=> Client
-> k
-> v
-> Word64
-> m Bool
cas client key value version = set' (\k f e b v o -> CasOp k f e b version v o) client key value
casEx :: (MonadIO m, Key k, Value v)
=> Client
-> k
-> v
-> Word64
-> Word64
-> m Bool
casEx client key value version exptime = opEx (\k f e b v o -> CasOp k f e b version v o) client key value exptime
add :: (MonadIO m, Key k, Value v)
=> Client
-> k
-> v
-> m Bool
add = set' AddOp
addEx :: (MonadIO m, Key k, Value v)
=> Client
-> k
-> v
-> Word64
-> m Bool
addEx = opEx AddOp
replace :: (MonadIO m, Key k, Value v)
=> Client
-> k
-> v
-> m Bool
replace = set' ReplaceOp
replaceEx :: (MonadIO m, Key k, Value v)
=> Client
-> k
-> v
-> Word64
-> m Bool
replaceEx = opEx ReplaceOp
get :: (MonadIO m, Key k, Value v)
=> Client
-> k
-> m (Maybe v)
get client key0 = do
let socket = clientSocket client
key = toBS key0
op = GetOp [key]
resp <- liftIO $ do
send socket op
values <- retrieve socket
case values of
((Value _ _ _ value _):_) -> case deserializeValue value of
Right v -> return (Just v)
Left _ -> return (Nothing)
_ -> return (Nothing)
return (resp)
retrieve :: Handle -> IO ([Response])
retrieve h = do
ret <- retrieve'
return (reverse ret)
where
retrieve' = do
resp <- recv h :: IO (Maybe Response)
case resp of
Just value@(Value {}) -> do
values <- retrieve h
return (value:values)
Just End -> return ([])
_ -> return ([])
gets :: (MonadIO m, Key k, Value v)
=> Client
-> k
-> m (Maybe (v, Word64))
gets client key0 = do
let socket = clientSocket client
key = toBS key0
op = GetsOp [key]
resp <- liftIO $ do
send socket op
values <- retrieve socket
case values of
((Value _ _ _ value (Just version)):_) -> case deserializeValue value of
Right v -> return (Just (v, version))
Left _ -> return (Nothing)
_ -> return (Nothing)
return (resp)
delete :: (MonadIO m, Key k)
=> Client
-> k
-> m Bool
delete client key0 = do
let socket = clientSocket client
key = toBS key0
resp <- liftIO $ do
send socket $ DeleteOp key []
recv socket :: IO (Maybe Response)
return (resp == Just Deleted)
incr :: (MonadIO m, Key k)
=> Client
-> k
-> Int
-> m (Maybe Int)
incr client key0 value = do
let socket = clientSocket client
key = toBS key0
resp <- liftIO $ do
send socket $ IncrOp key (fromIntegral value) []
recv socket :: IO (Maybe Response)
case resp of
Just (Code value') -> return (Just $ fromIntegral value')
_ -> return (Nothing)
decr :: (MonadIO m, Key k)
=> Client
-> k
-> Int
-> m (Maybe Int)
decr client key0 value = do
let socket = clientSocket client
key = toBS key0
resp <- liftIO $ do
send socket $ DecrOp key (fromIntegral value) []
recv socket :: IO (Maybe Response)
case resp of
Just (Code value') -> return (Just $ fromIntegral value')
_ -> return (Nothing)
flushAll :: (MonadIO m)
=> Client
-> m (Maybe Response)
flushAll client = do
let socket = clientSocket client
op = FlushAllOp
liftIO $ send socket op
resp <- liftIO $ do
recv socket :: IO (Maybe Response)
return (resp)
stats :: (MonadIO m)
=> Client
-> m (StatsList)
stats client = statsWithArgs client []
statsWithArgs :: (MonadIO m)
=> Client
-> [String]
-> m (StatsList)
statsWithArgs client args = do
let socket = clientSocket client
liftIO $ send socket $ StatsOp (map BS.pack args)
resp <- getResponse socket []
return (Prelude.reverse resp)
where
getResponse sock result = do
resp <- liftIO $ recv sock
case resp of
Just (Stat statName statValue) -> getResponse sock ((BS.unpack statName, BS.unpack statValue):result)
Just End -> return (result)
_ -> getResponse sock result
hostnameAndPort :: String -> Maybe (String, Int)
hostnameAndPort nk = case Data.List.Split.splitOn ":" nk of
(hostname:port:[]) -> Just (hostname, (read port :: Int))
_ -> Nothing
ignoreException :: a -> SomeException -> IO a
ignoreException ret _e = return ret