memcache-conduit (empty) → 0.0.3
raw patch · 8 files changed
+557/−0 lines, 8 filesdep +attoparsecdep +attoparsec-binarydep +basesetup-changed
Dependencies added: attoparsec, attoparsec-binary, base, bytestring, conduit, conduit-extra, containers, hashtables, memcache-conduit, memcache-haskell, monad-control, mtl, network, resourcet, split, stm, transformers
Files
- ChangeLog.md +3/−0
- LICENSE +22/−0
- README.md +60/−0
- Setup.hs +2/−0
- memcache-conduit.cabal +91/−0
- sample/hemcached.hs +158/−0
- sample/proxy.hs +113/−0
- src/Data/Conduit/Memcache.hs +108/−0
+ ChangeLog.md view
@@ -0,0 +1,3 @@+## 0.0.3++* First Release
+ LICENSE view
@@ -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.
+ README.md view
@@ -0,0 +1,60 @@+memcache-conduit+================++This package provides conduit functions for memcache protocol.++For detail, please see '''hemcached''' sample code (sample/hemcached.hs).+++Installation+------------++Install with sample(hemcached)++ > cabal install -f sample memcache-haskell memcache-conduit++Install without sample(hemcached)++ > cabal install memcache-haskell memcache-conduit++Sample code+-----------++### hemcached(memcache-sample-hemcached)++hemcached(memcache-sample-hemcached) is a simple memcached server to demonstrate how to use the memcache conduit functions.+(expiration and eviction are not implemented.)++1) Launch hemcached++ > ~/.cabal/bin/memcache-sample-hemcached++2) Open another terminal window++ > telnet localhost 11211+ Trying 127.0.0.1...+ Connected to localhost.+ Escape character is '^]'.++3) Send memcache commands++ set key 0 0 5+ value+ STORED+ get key+ VALUE key 0 5+ value+ end++If you want to know further information, please see the file "sample/hemcached.hs" in this repository.++## Contributors++* Kiyoshi Ikehara+* Junji Hashimoto++## License++See [LICENSE](LICENSE).++Copyright © Gree, Inc. All Rights Reserved.
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ memcache-conduit.cabal view
@@ -0,0 +1,91 @@+Name: memcache-conduit+Version: 0.0.3+Synopsis: Conduit library for memcache procotol+License: MIT+license-file: LICENSE+Author: Kiyoshi Ikehara+Maintainer: Kiyoshi Ikehara+Copyright: (c) 2015 GREE, Inc.+Category: Network+Build-Type: Simple+Cabal-Version: >=1.8+Description: This package provides conduit functions for memcache protocol.++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+ , split+ , mtl+ , conduit+ , resourcet+ , conduit-extra+ , attoparsec+ , attoparsec-binary+ , memcache-haskell >= 0.0.6+ Hs-source-dirs: src+ Exposed-modules: Data.Conduit.Memcache+ Extensions: DeriveDataTypeable+++Executable memcache-sample-hemcached+ 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+ , conduit+ , conduit-extra+ , memcache-haskell >= 0.0.6+ , memcache-conduit+ Hs-source-dirs: sample+ Main-is: hemcached.hs+ Extensions: DeriveDataTypeable++Executable memcache-sample-proxy+ 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+ , network+ , conduit+ , conduit-extra+ , monad-control+ , memcache-haskell+ , memcache-conduit+ Hs-source-dirs: sample+ Main-is: proxy.hs+ Extensions: DeriveDataTypeable
+ sample/hemcached.hs view
@@ -0,0 +1,158 @@+-- Copyright (c) 2013, GREE, Inc. All rights reserved.+-- authors: Kiyoshi Ikehara <kiyoshi.ikehara@gree.net>++{-# LANGUAGE OverloadedStrings, BangPatterns #-}++module Main where++import Prelude hiding (lookup)+import Control.Monad.Trans+import qualified Data.ByteString.Char8 as BS+import Data.Conduit+import Data.Conduit.Network+import Data.Conduit.Memcache+import qualified Data.HashTable.IO as H+import Control.Monad+import Control.Concurrent hiding (yield)+import Data.Word+import Control.Monad.Trans.Resource++import Network.Memcache.Op+import Network.Memcache.Response++type Key = BS.ByteString+type Version = Word64+type Value = (Version, BS.ByteString)+type HashTable k v = H.BasicHashTable k v++main :: IO ()+main = do+ ht <- H.new :: IO (HashTable Key Value)+ htVar <- newMVar ht+ runTCPServer (serverSettings 11211 "*") $ \appData -> do+ runResourceT $ do+ (appSource appData)+ $$ getOpText+ =$ process htVar+ =$ putResponseText+ =$ (appSink appData)++process :: MVar (HashTable Key Value) -> ConduitM (Either BS.ByteString Op) Response (ResourceT IO) ()+process htVar = loop+ where+ loop :: ConduitM (Either t Op) Response (ResourceT IO) ()+ loop = do+ meOp <- await+ case meOp of+ Nothing -> return ()+ Just (Left _msg) -> yield Error >> loop+ Just (Right op) -> case op of+ SetOp key _flags _exptime _bytes value options -> do+ with $ \ht -> do+ mValue <- lookup ht key+ case mValue of+ Just (version', _) -> insert ht key (version' + 1, value)+ Nothing -> insert ht key (0, value)+ yield' options Stored+ loop+ CasOp key _flags _exptime _bytes version value options -> do+ with $ \ht -> do+ mValue <- lookup ht key+ case mValue of+ Nothing -> yield' options NotFound+ Just (version', _) -> case version == version' of+ True -> do+ insert ht key (version' + 1, value)+ yield' options Stored+ False -> yield' options Exists+ loop+ AddOp key _flags _exptime _bytes value options -> do+ with $ \ht -> do+ mValue <- lookup ht key+ case mValue of+ Nothing -> do+ insert ht key (1, value)+ yield' options Stored+ Just _ -> yield' options NotStored+ loop+ ReplaceOp key _flags _exptime _bytes value options -> do+ with $ \ht -> do+ mValue <- lookup ht key+ case mValue of+ Nothing -> yield' options NotStored+ Just (version', _value') -> do+ insert ht key (version' + 1, value)+ yield' options Stored+ loop+ AppendOp key flags exptime bytes value options -> append' True key flags exptime bytes value options >> loop+ PrependOp key flags exptime bytes value options -> append' False key flags exptime bytes value options >> loop+ GetOp keys -> processGet False keys >> loop+ GetsOp keys -> processGet True keys >> loop+ DeleteOp key options -> do+ with $ \ht -> do+ delete ht key+ yield' options Deleted+ loop+ IncrOp key value options -> incr' True key value options >> loop+ DecrOp key value options -> incr' False key value options >> loop+ TouchOp key _exptime options -> do+ with $ \ht -> do+ mValue <- lookup ht key+ case mValue of+ Nothing -> yield' options NotFound+ Just (_, _value) -> yield' options Touched -- XXX+ loop+ PingOp -> yield Ok >> loop+ FlushAllOp -> do+ liftIO $ takeMVar htVar >> H.new >>= putMVar htVar+ yield Ok+ loop+ VersionOp -> yield (Version "hemcached-0.0.1") >> loop+ QuitOp -> return ()+ StatsOp _args -> yield End >> loop++ incr' isIncr key value options = do+ with $ \ht -> do+ mValue <- lookup ht key+ case mValue of+ Nothing -> yield' options NotFound+ Just (version', value') -> do+ let r = if isIncr then read (BS.unpack value') + value else read (BS.unpack value') - value+ insert ht key (version' + 1, BS.pack $ show r)+ yield' options $ Code r++ append' isAppend key _flags _exptime _bytes value options = do+ with $ \ht -> do+ mValue <- lookup ht key+ case mValue of+ Nothing -> yield' options NotStored+ Just (version', value') -> do+ insert ht key (version' + 1, BS.concat $ if isAppend then [value', value] else [value, value'])+ yield' options Stored++ processGet _ [] = yield End+ processGet withVersion (key:rest) = do+ with $ \ht -> do+ mValue <- lookup ht key+ case mValue of+ Just (version, value) -> do+ yield (Value key 0 (fromIntegral $ BS.length value) value (if withVersion then Just version else Nothing))+ Nothing -> return ()+ processGet withVersion rest+++ yield' options resp = when (Noreply `notElem` options) $ yield resp+ + delete ht key = liftIO $ H.delete ht key+ + lookup ht key = liftIO $ H.lookup ht key++ insert ht key value = liftIO $ H.insert ht key value++ with act = bracketP lock unlock act++ lock = liftIO $ takeMVar htVar+ + unlock ht = liftIO $ putMVar htVar ht++
+ sample/proxy.hs view
@@ -0,0 +1,113 @@+-- Copyright (c) 2013, GREE, Inc. All rights reserved.+-- authors: Kiyoshi Ikehara <kiyoshi.ikehara@gree.net>++{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE OverloadedStrings #-}+{-# OPTIONS_GHC -fno-warn-unused-do-bind #-}++module Main where++import Control.Monad.IO.Class+import Data.Conduit+import Data.Conduit.Network+import Data.Conduit.Memcache+import Network.Socket+import qualified Data.ByteString.Char8 as BS+import Control.Concurrent hiding (yield)+import System.Console.GetOpt+import System.Environment (getArgs)++import Network.Memcache.Op+import Network.Memcache.Response++data ProgramOptions = ProgramOptions {+ optHost :: String+ , optPort :: Int+ , optListenPort :: Int+ } deriving (Show)++defaultOptions :: ProgramOptions+defaultOptions = ProgramOptions {+ optHost = "127.0.0.1"+ , optPort = 12121+ , optListenPort = 12122+ }++options :: [OptDescr (ProgramOptions -> ProgramOptions)]+options =+ [ Option ['d'] ["dest"] (ReqArg (\h opt -> opt { optHost = h }) "HOST") "destination host"+ , Option ['p'] ["dport"] (ReqArg (\h opt -> opt { optPort = read h }) "PORT") "destination port"+ , Option ['l'] ["lport"] (ReqArg (\h opt -> opt { optListenPort = read h }) "PORT") "listen port"+ ]++memcachedProxyOpts :: [String] -> IO (ProgramOptions, [String])+memcachedProxyOpts argv =+ case getOpt Permute options argv of+ (o,n,[] ) -> return (foldl (flip id) defaultOptions o, n)+ (_,_,errs) -> ioError (userError (concat errs ++ usageInfo header options))+ where header = "Usage: memcached-proxy [OPTION...]"++main :: IO ()+main = do+ args0 <- getArgs+ (opts, _args) <- memcachedProxyOpts args0+ setNumCapabilities 4+ let sSettings0 = (serverSettings (optListenPort opts) "*") :: ServerSettings+ sSettings = setAfterBind (\s -> setSocketOption s NoDelay 1) sSettings0+ runTCPServer sSettings $ \appData -> do+ let cSettings = clientSettings (optPort opts) (BS.pack $ optHost opts)+ runTCPClient cSettings (proxyLoop appData)+ +proxyLoop :: AppData -> AppData -> IO ()+proxyLoop serverData clientData = do+ (serverSource, ()) <- (appSource serverData $= getOpText) $$+ return ()+ (clientSource, ()) <- (appSource clientData $= getResponseText) $$+ return ()+ proxyLoop' serverSource (appSink serverData) clientSource (appSink clientData)++proxyLoop' :: (MonadIO m) =>+ ResumableSource m (Either BS.ByteString Op)+ -> Sink BS.ByteString m a1+ -> ResumableSource m (Either BS.ByteString Response)+ -> Sink BS.ByteString m a+ -> m ()+proxyLoop' serverSource serverSink clientSource clientSink = do+ (serverSource', mop) <- serverSource $$++ await+ case mop of+ Nothing -> return ()+ Just (Left _msg) -> do+ yield Error $$ (putResponseText =$ serverSink)+ proxyLoop' serverSource' serverSink clientSource clientSink+ Just (Right op) -> case op of+ GetOp {} -> do+ yield op $$ (putOpText =$ clientSink)+ clientSource' <- proxyGet clientSource+ proxyLoop' serverSource' serverSink clientSource' clientSink+ _ -> do+ yield op $$ (putOpText =$ clientSink)+ (clientSource', mresp) <- clientSource $$++ await+ case mresp of+ Nothing -> return ()+ Just (Left _msg) -> do+ yield Error $$ (putResponseText =$ serverSink)+ return ()+ Just (Right resp) -> do+ yield resp $$ (putResponseText =$ serverSink)+ proxyLoop' serverSource' serverSink clientSource' clientSink+ where+ proxyGet source = do+ (source', mresp) <- source $$++ await+ case mresp of+ Nothing -> return (source')+ Just (Left _msg) -> do+ yield Error $$ (putResponseText =$ serverSink)+ return (source')+ Just (Right resp) -> case resp of+ Value {} -> do+ yield resp $$ (putResponseText =$ serverSink)+ proxyGet source'+ End -> do+ yield End $$ (putResponseText =$ serverSink)+ return (source')+ _ -> do+ yield Error $$ (putResponseText =$ serverSink)+ return (source')
+ src/Data/Conduit/Memcache.hs view
@@ -0,0 +1,108 @@+-- Copyright (c) 2013, GREE, Inc. All rights reserved.+-- authors: Kiyoshi Ikehara <kiyoshi.ikehara@gree.net>++{-# LANGUAGE OverloadedStrings #-}++{- | This package provides conduit functions for memcache protocol.+ For detail, please see 'hemcached' sample code (sample/hemcached.hs).++> type Key = BS.ByteString+> type Version = Word64+> type Value = (Version, BS.ByteString)+> type HashTable k v = H.BasicHashTable k v+> +> +> main :: IO ()+> main = do+> ht <- H.new :: IO (HashTable Key Value)+> htVar <- newMVar ht+> runResourceT $ do+> runTCPServer (serverSettings 11211 HostAny) $ \appData -> do+> (appSource appData)+> $$ getOpText+> =$ process htVar+> =$ putResponseText+> =$ (appSink appData)+> +> process :: (MonadResource m, MonadIO m) => MVar (HashTable Key Value) -> ConduitM (Either BS.ByteString Op) Response m ()+> process = ...++-}+module Data.Conduit.Memcache (getOpText, getResponseText, putOpText, putResponseText) where++import Prelude hiding (takeWhile)+import Control.Monad.Trans+import Control.Monad.Trans.Resource+import Control.Applicative+import qualified Data.Attoparsec.ByteString as AB+import Data.Attoparsec.ByteString.Char8+import qualified Data.ByteString.Char8 as BS+import Data.Conduit+import Data.Conduit.Attoparsec++import Network.Memcache.Class+import Network.Memcache.Op+import Network.Memcache.Response++{- | This conduit parses command messages in text protocol and generates "Network.Memcache.Op".++ [@input@] "Data.ByteString.Char8.ByteString"++ [@output@] "Network.Memcache.Op"++-}+getOpText :: (MonadIO m, MonadThrow m) => ConduitM BS.ByteString (Either BS.ByteString Op) m ()+getOpText = conduitParser opParser' =$= removePR+ where+ opParser' :: Parser (Either BS.ByteString Op)+ opParser' = try (Right <$> opParser)+ <|> (Left <$> (AB.takeWhile (\c -> c /= 10 && c /= 13) <* endline))++{- | This conduit parses response messages in text protocol and generates "Network.Memcache.Response".++ [@input@] "Data.ByteString.Char8.ByteString"++ [@output@] "Network.Memcache.Response"++-}+getResponseText :: (MonadIO m, MonadThrow m) => ConduitM BS.ByteString (Either BS.ByteString Response) m ()+getResponseText = conduitParser responseParser' =$= removePR+ where+ responseParser' :: Parser (Either BS.ByteString Response)+ responseParser' = try (Right <$> responseParser)+ <|> (Left <$> (AB.takeWhile (\c -> c /= 10 && c /= 13) <* endline))++{- | This conduit generates command messages in text protocol from "Network.Memcache.Op" stream++ [@input@] "Network.Memcache.Op"++ [@output@] "Data.ByteString.Char8.ByteString"++-}+putOpText :: MonadIO m => ConduitM Op BS.ByteString m ()+putOpText = loop+ where+ loop = await >>= maybe (return ()) (\op -> (yield $ BS.concat $ toChunks op) >> loop)++{- | This generates response messages in text protocol from "Network.Memcache.Response" stream++ [@input@] "Network.Memcache.Response"++ [@output@] "Data.ByteString.Char8.ByteString"++-}+putResponseText :: MonadIO m => ConduitM Response BS.ByteString m ()+putResponseText = loop+ where+ loop = await >>= maybe (return ()) (\resp -> (yield $ BS.concat $ toChunks resp) >> loop)+++----------------------------------------------------------------++endline :: Parser BS.ByteString+endline = try (string "\r\n") <|> string "\n" <|> string "\r"++removePR :: (MonadIO m, MonadThrow m, Show t) => ConduitM (PositionRange, t) t m ()+removePR = loop+ where+ loop = await >>= maybe (return ()) (\(_, r) -> (yield r) >> loop)