diff --git a/ChangeLog.md b/ChangeLog.md new file mode 100644 --- /dev/null +++ b/ChangeLog.md @@ -0,0 +1,3 @@ +## 0.0.10 + +* Add exptime-support to Network.Memcache.Client diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,22 @@ +Copyright (c) 2015 GREE, Inc. + +MIT License + +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. diff --git a/README.md b/README.md new file mode 100644 --- /dev/null +++ b/README.md @@ -0,0 +1,47 @@ +memcache-haskell +================ + +[![Hackage version](https://img.shields.io/hackage/v/memcache-haskell.svg?style=flat)](https://hackage.haskell.org/package/memcache-haskell) [![Build Status](https://travis-ci.org/gree/memcache-haskell.png?branch=master)](https://travis-ci.org/gree/memcache-haskell) [![Coverage Status](https://coveralls.io/repos/gree/memcache-haskell/badge.png)](https://coveralls.io/r/gree/memcache-haskell) + +This package is a memcache protocol library for server and client applications. + +Main purpose of this library is making a server itself. + +This does not support consistent hashing and any other functions like ["libmemcached"](http://libmemcached.org/libMemcached.html). + +## Getting started + +Install from Hackage. + + cabal update && cabal install memcache-haskell + +## Usage + +1. Call `openClient` with `ip-address:port` of memcache-server to obtain a handle. +2. To set or get a data on the memcache server, call `set` or `get` with the handle. +3. Finally call `closeClient` after you are done. + +Example: + +``` +main :: IO () +main = do + client <- openClient "127.0.0.0:11211" + ret <- set client "key" "foo" + print ret + ret' <- get client "key" :: IO (Maybe String) + print ret' + closeClient client +``` + +## Contributors + +* Kiyoshi Ikehara +* Yuji Kamiya +* Junji Hashimoto + +## License + +See [LICENSE](LICENSE). + +Copyright © Gree, Inc. All Rights Reserved. diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/memcache-haskell.cabal b/memcache-haskell.cabal new file mode 100644 --- /dev/null +++ b/memcache-haskell.cabal @@ -0,0 +1,107 @@ +Name: memcache-haskell +Version: 0.0.10 +Description: Memcache procotol library +License: MIT +license-file: LICENSE +Author: Kiyoshi Ikehara +Maintainer: Kiyoshi Ikehara +Copyright: (c) 2015 GREE, Inc. +Build-Type: Simple +Cabal-Version: >=1.8 +Description: + A memcache protocol library for client and server applications. + + +bug-reports: https://github.com/gree/memcache-haskell/issues + +extra-source-files: + ChangeLog.md + README.md + +source-repository head + type: git + location: https://github.com/gree/memcache-haskell.git + +Flag sample + Description: Build sample programs + Default: False + +Library + Ghc-Options: -O2 -Wall + Build-Depends: base >=4 && <5 + , bytestring + , network >= 2.3.2 + , attoparsec + , transformers + , split + , hashable + Hs-source-dirs: src + Exposed-modules: Network.Memcache + , Network.Memcache.Response + , Network.Memcache.Op + , Network.Memcache.Class + , Network.Memcache.Client + , Network.Memcache.Stats + , Network.Memcache.Types + , Network.Memcache.IO + Other-modules: Network.Memcache.IO.Internal + Extensions: DeriveDataTypeable + +Executable memcache-sample-client + if flag(sample) + Buildable: True + else + Buildable: False + Ghc-Options: -threaded -O2 -Wall -rtsopts + Extra-Libraries: + Build-Depends: base >= 4 && < 5 + , bytestring >= 0.9 + , stm >= 2.4 + , containers + , transformers + , resourcet + , mtl + , hashtables + , network-conduit + , memcache-haskell + Hs-source-dirs: sample + Main-is: sample-client.hs + Extensions: DeriveDataTypeable + +Executable memcache-sample-retrieval + if flag(sample) + Buildable: True + else + Buildable: False + Ghc-Options: -threaded -O2 -Wall -rtsopts + Extra-Libraries: + Build-Depends: base >= 4 && < 5 + , bytestring >= 0.9 + , stm >= 2.4 + , containers + , transformers + , resourcet + , mtl + , hashtables + , network-conduit + , memcache-haskell + Hs-source-dirs: sample + Main-is: sample-retrieval.hs + Extensions: DeriveDataTypeable + +Test-Suite test-memcache + Ghc-Options: -threaded -O2 -Wall + Build-depends: base + , bytestring + , network >= 2.3.2 + , split + , QuickCheck == 2.5.1.1 + , HUnit + , test-framework + , test-framework-th + , test-framework-hunit + , test-framework-quickcheck2 + , memcache-haskell + Type: exitcode-stdio-1.0 + Hs-source-dirs: test + Main-is: test-memcache.hs diff --git a/sample/sample-client.hs b/sample/sample-client.hs new file mode 100644 --- /dev/null +++ b/sample/sample-client.hs @@ -0,0 +1,29 @@ + +import Control.Exception +import Control.Monad.Trans.Resource (allocate, release, runResourceT) +import Control.Monad.IO.Class +import Network.Memcache +import System.Environment + + +main :: IO () +main = do + args <- getArgs + case args of + [] -> main' "127.0.0.1:11211" + (nk:_) -> main' nk + +main' :: Nodekey -> IO () +main' nodekey = runResourceT $ do + (rkeyClient , client) <- flip allocate closeClient $ do + c <- openClient nodekey + case c of + Just client -> return (client) + Nothing -> liftIO $ do + throwIO (userError "could not open.") + liftIO $ do + ret <- set client "key" "foo" + print ret + ret' <- get client "key" :: IO (Maybe String) + print ret' + release rkeyClient diff --git a/sample/sample-retrieval.hs b/sample/sample-retrieval.hs new file mode 100644 --- /dev/null +++ b/sample/sample-retrieval.hs @@ -0,0 +1,9 @@ + +import Network.Memcache + +main = do + mValue <- withClient "127.0.0.1:11211" $ \client -> get client "key" + case mValue of + Nothing -> putStrLn "(no value)" + Just value -> putStrLn value + diff --git a/src/Network/Memcache.hs b/src/Network/Memcache.hs new file mode 100644 --- /dev/null +++ b/src/Network/Memcache.hs @@ -0,0 +1,81 @@ +-- Copyright (c) 2013, GREE, Inc. All rights reserved. +-- authors: Kiyoshi Ikehara + +{- | +Module: Network.Memcache +Maintainer: Kiyoshi Ikehara + +memcache-haskell is a memcache protocol library for server and client application. + +If you want to implement a simple memcache client, just import "Network.Memcache" module and use withClient function. + +> import Network.Memcache +> +> main = do +> mValue <- withClient "127.0.0.1:11211" $ \client -> get client "key" +> case mValue of +> Nothing -> putStrLn "(no value)" +> Just value -> putStrLn value + +Or, use openClient and closeClient pair for more complex cases. + +> import Control.Exception +> import Control.Monad.Trans.Resource (allocate, release, runResourceT) +> import Control.Monad.IO.Class +> import Network.Memcache +> import System.Environment +> +> main :: IO () +> main = do +> args <- getArgs +> case args of +> [] -> main' "127.0.0.1:11211" +> (nk:_) -> main' nk +> +> main' :: Nodekey -> IO () +> main' nodekey = runResourceT $ do +> (rkeyClient , client) <- flip allocate closeClient $ do +> c <- openClient nodekey +> case c of +> Just client -> return (client) +> Nothing -> liftIO $ do +> throwIO (userError "could not open.") +> liftIO $ do +> ret <- set client "key" "foo" +> print ret +> ret' <- get client "key" :: IO (Maybe String) +> print ret' +> release rkeyClient + +If your application is more complex and should recognize memcache command and response directly, +you have to import more and use low-level functions. + +For server application, please use "Network.Memcache.Op" and "Network.Memcache.Response" directly to parse and process each command. + +If you are familiar with conduit library, please take a look at memcache-conduit library and you will +find that you can write a memcache protocol server very quickly. + +> main :: IO () +> main = do +> runResourceT $ do +> runTCPServer (serverSettings 13301 HostAny) $ \appData -> do +> (appSource appData) +> $$ getOpText +> =$ process htVar +> =$ putResponseText +> =$ (appSink appData) +> +> process = ... + +-} + +module Network.Memcache ( + module Network.Memcache.Client + , module Network.Memcache.Stats + , module Network.Memcache.Class + ) where + +import Network.Memcache.Class +import Network.Memcache.Client +import Network.Memcache.Stats + diff --git a/src/Network/Memcache/Class.hs b/src/Network/Memcache/Class.hs new file mode 100644 --- /dev/null +++ b/src/Network/Memcache/Class.hs @@ -0,0 +1,28 @@ +-- Copyright (c) 2013, GREE, Inc. All rights reserved. +-- authors: Kiyoshi Ikehara + +{- | Class definitions + +This module is mainly for internal use. + +-} +module Network.Memcache.Class (Message(..)) where + +import Control.Monad.IO.Class +import System.IO +import qualified Data.ByteString.Char8 as BS + +class Message a where + -- parse message header + parseHeader :: BS.ByteString -> Maybe a + + -- convert a message to chunks + toChunks :: a -> [BS.ByteString] + + -- receive content of a message after receiving its header + recvContent :: (MonadIO m) => Handle -> a -> m (Maybe a) + + -- no content (default impl.) + recvContent _h msg = return $ Just msg + + diff --git a/src/Network/Memcache/Client.hs b/src/Network/Memcache/Client.hs new file mode 100644 --- /dev/null +++ b/src/Network/Memcache/Client.hs @@ -0,0 +1,429 @@ +-- Copyright (c) 2013, GREE, Inc. All rights reserved. +-- authors: Kiyoshi Ikehara + +{-# LANGUAGE TypeSynonymInstances, FlexibleInstances #-} + +{- | This is a utility module for client application. +-} +module Network.Memcache.Client ( + Client + , StatsList + , Nodekey + , Key(..) + , Value(..) + , openClient + , closeClient + , clientNodekey + , clientSocket + -- Utility + , withClient + , withClients + , forEachClient + -- Query Operations + , set + , setEx + , cas + , casEx + , add + , addEx + , replace + , replaceEx + , get + , gets + , delete + , incr + , decr + -- Other Operations + , 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 + +{- | Client is a handler corresponding to a memcached session. +-} +data Client = MemcachedClient { + -- | Get the hostname and port pair from a handler + clientNodekey :: String + -- | Get the socket from a handler + , clientSocket :: Handle + } + +{- | Key class +-} +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 + +{- | Value class +-} +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 + +{- | Open a client session and return a client handler. +-} +openClient :: (MonadIO m) + => Nodekey -- ^ node key (eg. \"127.0.0.1:11211\") + -> m (Maybe Client) -- ^ client handler +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 + +{- | Close a client session. +-} +closeClient :: (MonadIO m) + => Client -- ^ a client handler + -> 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 + +{- | Connect and execute an action. +-} +withClient :: Nodekey -- ^ a node + -> (Client -> IO (Maybe a)) -- ^ an action to be executed with a memcache session + -> IO (Maybe a) -- ^ the result of the given action +withClient nodekey = withClients [nodekey] + +{- | Connect to one of given hosts and execute an action. + +> import Network.Memcache +> +> main = do +> mValue <- withClient "127.0.0.1:11211" $ \client -> get client "key" +> case mValue of +> Nothing -> putStrLn "(no value)" +> Just value -> putStrLn value + +Note that this function doesn't retry the action when it fails. + +-} +withClients :: [Nodekey] -- ^ a node list + -> (Client -> IO (Maybe a)) -- ^ an action to be executed with a memcache session + -> IO (Maybe a) -- ^ the result of the given action +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 + +{- | Connect to the given hosts one by one and execute the action for each client. + +If you'd like to clear all the data in your cluster, you can use this function to issue \"flush_all\" command to each memcache node. + +> main = do +> ret <- forEachClient ["192.168.0.1:11211", "192.168.0.2:11211"] $ flushAll +> print ret + +-} +forEachClient :: [Nodekey] -- ^ a node list + -> (Client -> IO (Maybe a)) -- ^ an action to be executed with a memcache session + -> IO ([Maybe a]) -- ^ the result of the given action +forEachClient clients act = do + mapM (\c -> withClient c act) clients + + +-------------------------------- Query Operations + +{- | Set an item +-} +set :: (MonadIO m, Key k, Value v) + => Client -- ^ a client handler + -> k -- ^ a key + -> v -- ^ a value + -> m Bool -- ^ true if the value has been stored +set = set' SetOp + +{- | Set an item with exptime +-} +setEx :: (MonadIO m, Key k, Value v) + => Client -- ^ a client handler + -> k -- ^ a key + -> v -- ^ a value + -> Word64 -- ^ exptime + -> m Bool -- ^ true if the value has been stored +setEx = opEx SetOp + +-- a helper function without exptime +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 + + +-- a helper function with exptime +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 an item +-} +cas :: (MonadIO m, Key k, Value v) + => Client -- ^ a client handler + -> k -- ^ a key + -> v -- ^ a value + -> Word64 -- ^ a version number got by gets command + -> m Bool -- ^ true if the value has been stored +cas client key value version = set' (\k f e b v o -> CasOp k f e b version v o) client key value + +{- | Cas an item with exptime +-} +casEx :: (MonadIO m, Key k, Value v) + => Client -- ^ a client handler + -> k -- ^ a key + -> v -- ^ a value + -> Word64 -- ^ a version number got by gets command + -> Word64 -- ^ exptime + -> m Bool -- ^ true if the value has been stored +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 an item +-} +add :: (MonadIO m, Key k, Value v) + => Client -- ^ a client handler + -> k -- ^ a key + -> v -- ^ a value + -> m Bool +add = set' AddOp + +{- | Add an item with exptime +-} +addEx :: (MonadIO m, Key k, Value v) + => Client -- ^ a client handler + -> k -- ^ a key + -> v -- ^ a value + -> Word64 -- ^ exptime + -> m Bool +addEx = opEx AddOp + +{- | Replace an item +-} +replace :: (MonadIO m, Key k, Value v) + => Client -- ^ a client handler + -> k -- ^ a key + -> v -- ^ a value + -> m Bool -- ^ true if the value has been stored +replace = set' ReplaceOp + +{- | Replace an item with exptime +-} +replaceEx :: (MonadIO m, Key k, Value v) + => Client -- ^ a client handler + -> k -- ^ a key + -> v -- ^ a value + -> Word64 -- ^ exptime + -> m Bool -- ^ true if the value has been stored +replaceEx = opEx ReplaceOp + +{- | Get an item +-} +get :: (MonadIO m, Key k, Value v) + => Client -- ^ a client handler + -> k -- ^ a key + -> m (Maybe v) -- ^ the value corresponding to the given key +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) + +-- a helper function +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 ([]) + +{- | Get an item and its version +-} +gets :: (MonadIO m, Key k, Value v) + => Client -- ^ a client handler + -> k -- ^ a key + -> m (Maybe (v, Word64)) -- ^ the value and version pair corresponding to the key +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 an item +-} +delete :: (MonadIO m, Key k) + => Client -- ^ a client handler + -> k -- ^ a key + -> m Bool -- ^ true if the item has been deleted +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) + +{- | Increment an item +-} +incr :: (MonadIO m, Key k) + => Client -- ^ a client handler + -> k -- ^ a key + -> Int -- ^ delta + -> m (Maybe Int) -- ^ a resulted value +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) + +{- | Decrement an item +-} +decr :: (MonadIO m, Key k) + => Client -- ^ a client handler + -> k -- ^ a key + -> Int -- ^ delta + -> m (Maybe Int) -- ^ a resulted value +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) + +-- Other Operations + +{- | Flush all items +-} +flushAll :: (MonadIO m) + => Client -- ^ a client handler + -> m (Maybe Response) -- ^ OK if all items has been removed +flushAll client = do + let socket = clientSocket client + op = FlushAllOp + liftIO $ send socket op + resp <- liftIO $ do + recv socket :: IO (Maybe Response) + return (resp) + +{- | Acquire statistic information + +To get each statistic value from the resulted list, use "Network.Memcache.Stats" module. + +-} +stats :: (MonadIO m) + => Client -- ^ a client handler + -> m (StatsList) -- ^ a property list +stats client = statsWithArgs client [] + +{- | Acquire statistic information with arguments + +To get each statistic value from the resulted list, use "Network.Memcache.Stats" module. + +-} +statsWithArgs :: (MonadIO m) + => Client -- ^ a client handler + -> [String] -- ^ arguments + -> m (StatsList) -- ^ a property list +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 + diff --git a/src/Network/Memcache/IO.hs b/src/Network/Memcache/IO.hs new file mode 100644 --- /dev/null +++ b/src/Network/Memcache/IO.hs @@ -0,0 +1,38 @@ +-- Copyright (c) 2013, GREE, Inc. All rights reserved. +-- authors: Kiyoshi Ikehara + +{- | This is a utility module for handle-based IO opearations +-} +module Network.Memcache.IO (send, recv) where + +import Control.Monad.IO.Class +import System.IO +import qualified Data.ByteString.Char8 as BS + +import Network.Memcache.Class + +{- | Send a message + +> send socket FlushAllOp + +-} +send :: (MonadIO m, Message a) => Handle -> a -> m () +send handle msg = liftIO $ do + -- TODO: this should be done by writev() system call (vector I/O). + BS.hPutStr handle $ BS.concat (toChunks msg) + hFlush handle + +{- | Receive a message + +You may need to specify the return type when you call this function like the code shown below. + +> mresp <- recv socket :: IO (Maybe Response) + +-} +recv :: (MonadIO m, Message a) => Handle -> m (Maybe a) +recv handle = liftIO $ do + l <- BS.hGetLine handle + case parseHeader l of + Just msg -> recvContent handle msg + Nothing -> return Nothing + diff --git a/src/Network/Memcache/IO/Internal.hs b/src/Network/Memcache/IO/Internal.hs new file mode 100644 --- /dev/null +++ b/src/Network/Memcache/IO/Internal.hs @@ -0,0 +1,16 @@ +-- Copyright (c) 2013, GREE, Inc. All rights reserved. +-- authors: Kiyoshi Ikehara + +module Network.Memcache.IO.Internal where + +import System.IO +import qualified Data.ByteString.Char8 as BS +import Data.Word + +{- | Read data from a handle +-} +readBytes :: Handle -- ^ a I/O handler + -> Word64 -- ^ data length + -> IO (BS.ByteString) +readBytes handle len = BS.hGet handle (fromIntegral len) + diff --git a/src/Network/Memcache/Op.hs b/src/Network/Memcache/Op.hs new file mode 100644 --- /dev/null +++ b/src/Network/Memcache/Op.hs @@ -0,0 +1,382 @@ +-- Copyright (c) 2013, GREE, Inc. All rights reserved. +-- authors: Kiyoshi Ikehara + +{-# LANGUAGE OverloadedStrings #-} +{-# OPTIONS_GHC -fno-warn-unused-binds -fno-warn-name-shadowing #-} + +{- | + For farther information, please see + +* storage - 'set', 'add', 'replace', 'append' or 'prepend' + +* retrieval - 'get' and 'gets' + +* deletion - 'delete' + +* increment decrement - 'incr' and 'decr' + +* touch - 'touch' + +* stats + +* other commands - 'flush_all', 'version', 'quit' +-} +module Network.Memcache.Op ( + Option(..) + , Op(PingOp + , SetOp + , CasOp + , AddOp + , ReplaceOp + , AppendOp + , PrependOp + , GetOp + , GetsOp + , DeleteOp + , IncrOp + , DecrOp + , TouchOp + , FlushAllOp + , VersionOp + , QuitOp + , StatsOp) + , isWriteOp + , isReadOp + , isNoreplyOp + , isStorageOp + , toOption + , toOptions + , keyOf + , bytesOf + , parseOp + , parseOpHeader + , opParser + , opHeaderParser + , updateOpValue + ) where + +import Prelude hiding (take, takeWhile) +import qualified Data.ByteString.Char8 as BS +import Data.Word +import Data.Maybe +import qualified Data.Attoparsec.ByteString as AB +import Data.Attoparsec.ByteString.Char8 +import Control.Applicative +import Control.Monad.IO.Class + +import Network.Memcache.Class +import Network.Memcache.IO.Internal + +type ValueT = BS.ByteString +type BytesT = Word64 +data Option = Noreply deriving (Eq) + +instance Show Option where + show Noreply = "noreply" + +instance Read Option where + readsPrec _d r = case r of + "noreply" -> [(Noreply, "")] + _ -> error "no parse" + +instance Message Op where + parseHeader = parseOpHeader + + toChunks = Network.Memcache.Op.toChunks + + recvContent handle op + | isStorageOp op = liftIO $ case bytesOf op of + Just bytes -> do + content <- readBytes handle bytes + _term <- BS.hGetLine handle + return $ Just $ updateOpValue op content + Nothing -> return $ Just op + | otherwise = return $ Just op + +data Op = + -- storage commands + SetOp { + key :: !BS.ByteString + , flags :: !Word32 + , exptime :: !Word64 + , bytes :: !BytesT + , value :: ValueT + , options :: ![Option] } + | CasOp { + key :: !BS.ByteString + , flags :: !Word32 + , exptime :: !Word64 + , bytes :: !BytesT + , version :: !Word64 + , value :: ValueT + , options :: ![Option] } + | AddOp { + key :: !BS.ByteString + , flags :: !Word32 + , exptime :: !Word64 + , bytes :: !BytesT + , value :: ValueT + , options :: ![Option] } + | ReplaceOp { + key :: !BS.ByteString + , flags :: !Word32 + , exptime :: !Word64 + , bytes :: !BytesT + , value :: ValueT + , options :: ![Option] } + | AppendOp { + key :: !BS.ByteString + , flags :: !Word32 + , exptime :: !Word64 + , bytes :: !BytesT + , value :: ValueT + , options :: ![Option] } + | PrependOp { + key :: !BS.ByteString + , flags :: !Word32 + , exptime :: !Word64 + , bytes :: !BytesT + , value :: ValueT + , options :: ![Option] } + -- retrieval commands + | GetOp { keys :: ![BS.ByteString] } + | GetsOp { keys :: ![BS.ByteString] } + -- deletion commands + | DeleteOp { key :: !BS.ByteString, options :: ![Option] } + -- increment and decrement commands + | IncrOp { key :: !BS.ByteString, value' :: !Word64, options :: ![Option] } + | DecrOp { key :: !BS.ByteString, value' :: !Word64, options :: ![Option] } + -- touch commands + | TouchOp { key :: !BS.ByteString, exptime :: !Word64, options :: ![Option] } + -- stats commands + -- other commands + | PingOp + | FlushAllOp + | VersionOp + | QuitOp + | StatsOp { args :: ![BS.ByteString] } + deriving (Show, Read, Eq) + +-- | parse option strings +toOptions :: [BS.ByteString] -> Maybe [Option] +toOptions opts = if elem Nothing converted + then Nothing + else Just $ concat $ map maybeToList converted + where + converted = map toOption opts + +-- | parse a option string +toOption :: BS.ByteString -> Maybe Option +toOption option = case option of + "noreply" -> Just Noreply + _ -> Nothing + +-- | update the value of an operation +updateOpValue :: Op -> ValueT -> Op +updateOpValue op val + | isStorageOp op = op { value = val } + | otherwise = op + +-- | get the value size of an operation +bytesOf :: Op -> Maybe BytesT +bytesOf op + | isStorageOp op = Just $ bytes op + | otherwise = Nothing + +-- | get the key of an operation +keyOf :: Op -> Maybe BS.ByteString +keyOf op = case op of + PingOp -> Nothing + FlushAllOp -> Nothing + VersionOp -> Nothing + QuitOp -> Nothing + StatsOp _ -> Nothing + GetOp [] -> Nothing + GetOp (k:_) -> Just k + GetsOp [] -> Nothing + GetsOp (k:_) -> Just k + _ -> Just $ key op + +-- | true if an operation is an update command +isWriteOp :: Op -> Bool +isWriteOp op = case op of + SetOp {} -> True + CasOp {} -> True + AddOp {} -> True + ReplaceOp {} -> True + AppendOp {} -> True + PrependOp {} -> True + DeleteOp {} -> True + IncrOp {} -> True + DecrOp {} -> True + TouchOp {} -> True + _ -> False + +-- | true if an operation is a storage command +isStorageOp :: Op -> Bool +isStorageOp op = case op of + SetOp {} -> True + CasOp {} -> True + AddOp {} -> True + ReplaceOp {} -> True + AppendOp {} -> True + PrependOp {} -> True + _ -> False + +-- | true if an operation is a retrieval command +isReadOp :: Op -> Bool +isReadOp op = case op of + GetOp {} -> True + GetsOp {} -> True + _ -> False + +-- | true if an operation has noreply option +isNoreplyOp :: Op -> Bool +isNoreplyOp op = case op of + SetOp { options = os } -> elem Noreply os + CasOp { options = os } -> elem Noreply os + AddOp { options = os } -> elem Noreply os + ReplaceOp { options = os } -> elem Noreply os + AppendOp { options = os } -> elem Noreply os + PrependOp { options = os } -> elem Noreply os + DeleteOp { options = os } -> elem Noreply os + IncrOp { options = os } -> elem Noreply os + DecrOp { options = os } -> elem Noreply os + TouchOp { options = os } -> elem Noreply os + _ -> False + + +{-| Parse an operation. +-} +parseOp :: BS.ByteString -> Maybe Op +parseOp = parseOp' False + +{-| Parse an operation but only its header. +-} +parseOpHeader :: BS.ByteString -> Maybe Op +parseOpHeader = parseOp' True + +parseOp' :: Bool -> BS.ByteString -> Maybe Op +parseOp' onlyHeader input = let r = parse (opParser' onlyHeader) input in case r of + Fail {} -> Nothing + Partial parse' -> let r' = parse' "\r\n" in case r' of + Done _ result -> Just result + Fail {} -> Nothing + Partial {} -> Nothing + Done _ result -> Just result + +{-| command parser by attoparsec +-} +opParser :: Parser Op +opParser = opParser' False + +{-| command header parser by attoparsec +-} +opHeaderParser :: Parser Op +opHeaderParser = opParser' True + +opParser' :: Bool -> Parser Op +opParser' onlyHeader = parser + where + parser :: Parser Op + parser = do + cmd <- ws *> word <* ws + case cmd of + "get" -> GetOp <$> (keys <* endline) + "gets" -> GetsOp <$> (keys <* endline) + "set" -> op_set' SetOp + "add" -> op_set' AddOp + "replace" -> op_set' ReplaceOp + "append" -> op_set' AppendOp + "prepend" -> op_set' PrependOp + "cas" -> op_cas + "incr" -> IncrOp <$> (key <* ws) <*> (decimal <* ws) <*> (options <* endline) + "decr" -> DecrOp <$> (key <* ws) <*> (decimal <* ws) <*> (options <* endline) + "delete" -> DeleteOp <$> (key <* ws) <*> (options <* endline) + "touch" -> TouchOp <$> (key <* ws) <*> (decimal <* ws) <*> (options <* endline) + "flush_all" -> pure FlushAllOp <* endline + "version" -> pure VersionOp <* endline + "quit" -> pure QuitOp <* endline + "ping" -> pure PingOp <* endline + "stats" -> StatsOp <$> (words <* endline) + _ -> fail "" + + keys = many1 (key <* ws) + + key = word + + words = many (word <* ws) + + word = AB.takeWhile1 (\c -> c /= 32 && c /= 10 && c /= 13) + + ws = AB.skipWhile (== 32) + + endline :: Parser BS.ByteString + endline = try (string "\r\n") <|> string "\n" <|> string "\r" + + options = do + mopts <- toOptions <$> words + case mopts of + Just opts -> return (opts) + Nothing -> fail "invalid options" + + -- set [] -> STORED + op_set' op = do + op' <- op <$> (key <* ws) <*> (decimal <* ws) <*> (decimal <* ws) + size <- decimal <* ws :: Parser Word64 + opts <- options <* endline + value <- if onlyHeader then pure BS.empty else (take (fromIntegral size) <* ws <* endline) + return (op' size value opts) + + -- cas [