diff --git a/Database/Monarch.hs b/Database/Monarch.hs --- a/Database/Monarch.hs +++ b/Database/Monarch.hs @@ -7,5 +7,5 @@ , module Database.Monarch.Binary ) where -import Database.Monarch.Raw hiding (liftMonarch) +import Database.Monarch.Raw hiding (sendLBS, recvLBS) import Database.Monarch.Binary diff --git a/Database/Monarch/Raw.hs b/Database/Monarch/Raw.hs --- a/Database/Monarch/Raw.hs +++ b/Database/Monarch/Raw.hs @@ -1,5 +1,7 @@ {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE TypeFamilies #-} -- | Raw definitions. module Database.Monarch.Raw ( @@ -11,19 +13,21 @@ , runMonarchPool , ExtOption(..), RestoreOption(..), MiscOption(..) , Code(..) - , liftMonarch + , sendLBS, recvLBS ) where -import Data.IORef -import Data.ByteString -import Data.Conduit +import Data.Int import Data.Conduit.Network import Data.Conduit.Pool -import Control.Exception.Lifted (bracket) +import Control.Exception.Lifted as E import Control.Monad.Error +import Control.Monad.Reader +import Control.Monad.Base import Control.Applicative import Control.Monad.Trans.Control import Network.Socket +import qualified Network.Socket.ByteString.Lazy as NSLBS +import qualified Data.ByteString.Lazy as LBS -- | Connection with TokyoTyrant data Connection = Connection { connection :: Socket } @@ -57,29 +61,22 @@ -- | A monad supporting TokyoTyrant access. newtype Monarch a = - Monarch { unMonarch :: ErrorT Code (Pipe ByteString ByteString ByteString () IO) a } + Monarch { unMonarch :: ErrorT Code (ReaderT Connection IO) a } deriving ( Functor, Applicative, Monad, MonadIO - , MonadError Code ) + , MonadReader Connection, MonadError Code, MonadBase IO ) +instance MonadBaseControl IO Monarch where + newtype StM Monarch a = StMM { unStMM :: StM (ErrorT Code (ReaderT Connection IO)) a } + liftBaseWith f = Monarch . liftBaseWith $ \runInBase -> f $ liftM StMM . runInBase . unMonarch + restoreM = Monarch . restoreM . unStMM + -- | Run Monarch with TokyoTyrant at target host and port. runMonarch :: MonadIO m => Connection -> Monarch a -> m (Either Code a) runMonarch conn action = - liftIO $ do - let c = connection conn - result <- newIORef (Left Success) - client action result (sourceSocket c) (sinkSocket c) - readIORef result - -client :: Monarch a - -> IORef (Either Code a) - -> Application IO -client action result src sink = src $$ conduit =$ sink - where - conduit = runErrorT (unMonarch action) >>= - liftIO . writeIORef result + liftIO $ runReaderT (runErrorT $ unMonarch action) conn -- | Create a TokyoTyrant connection and run the given action. -- Don't use the given 'Connection' outside the action. @@ -89,7 +86,7 @@ -> (Connection -> m a) -> m a withMonarchConn host port f = - bracket open' close' f + E.bracket open' close' f where open' = liftIO (Connection <$> getSocket host port) close' = liftIO . sClose . connection @@ -122,7 +119,18 @@ -> m (Either Code a) runMonarchPool action pool = withResource pool (\conn -> runMonarch conn action) --- | Lift -liftMonarch :: Pipe ByteString ByteString ByteString () IO a - -> Monarch a -liftMonarch = Monarch . lift +throwError' :: Code -> SomeException -> Monarch a +throwError' e _ = throwError e + +sendLBS :: LBS.ByteString -> Monarch () +sendLBS lbs = do + conn <- connection <$> ask + liftIO (NSLBS.sendAll conn lbs) `E.catch` throwError' SendError + +recvLBS :: Int64 -> Monarch LBS.ByteString +recvLBS n = do + conn <- connection <$> ask + lbs <- liftIO (NSLBS.recv conn n) `E.catch` throwError' SendError + if n /= LBS.length lbs + then throwError ReceiveError + else return lbs diff --git a/Database/Monarch/Utils.hs b/Database/Monarch/Utils.hs --- a/Database/Monarch/Utils.hs +++ b/Database/Monarch/Utils.hs @@ -14,15 +14,12 @@ import Data.Int import Data.Bits -import Data.Conduit -import qualified Data.Conduit.Binary as CB import qualified Data.ByteString as BS import qualified Data.ByteString.Lazy as LBS import qualified Data.Binary as B import Data.Binary.Put (runPut, putWord32be) import Data.Binary.Get (runGet, getWord32be) import Control.Applicative -import Control.Monad.Error import Database.Monarch.Raw @@ -71,30 +68,23 @@ fromLBS = BS.pack . LBS.unpack yieldRequest :: B.Put -> Monarch () -yieldRequest = - liftMonarch . mapM_ yield . LBS.toChunks . runPut +yieldRequest = sendLBS . runPut responseCode :: Monarch Code -responseCode = - liftMonarch CB.head >>= - maybe (throwError MiscellaneousError) - (return . toCode . fromIntegral) +responseCode = toCode . fromIntegral . runGet B.getWord8 <$> recvLBS 1 parseLBS :: Monarch LBS.ByteString -parseLBS = liftMonarch $ - CB.take 4 >>= - CB.take . fromIntegral . runGet getWord32be +parseLBS = recvLBS 4 >>= + recvLBS . fromIntegral . runGet getWord32be parseBS :: Monarch BS.ByteString parseBS = fromLBS <$> parseLBS parseWord32 :: Monarch B.Word32 -parseWord32 = liftMonarch (CB.take 4) >>= - return . runGet getWord32be +parseWord32 = runGet getWord32be <$> recvLBS 4 parseInt64 :: Monarch Int64 -parseInt64 = liftMonarch (CB.take 8) >>= - return . runGet (B.get :: B.Get Int64) +parseInt64 = runGet (B.get :: B.Get Int64) <$> recvLBS 8 parseDouble :: Monarch Double parseDouble = do @@ -103,15 +93,14 @@ return $ integ + fract * 1e-12 parseKeyValue :: Monarch (BS.ByteString, BS.ByteString) -parseKeyValue = - liftMonarch $ do - ksiz <- CB.take 4 - vsiz <- CB.take 4 - key <- CB.take . fromIntegral $ - runGet getWord32be ksiz - value <- CB.take . fromIntegral $ - runGet getWord32be vsiz - return (fromLBS key, fromLBS value) +parseKeyValue = do + ksiz <- recvLBS 4 + vsiz <- recvLBS 4 + key <- recvLBS . fromIntegral $ + runGet getWord32be ksiz + value <- recvLBS . fromIntegral $ + runGet getWord32be vsiz + return (fromLBS key, fromLBS value) communicate :: B.Put -> (Code -> Monarch a) diff --git a/monarch.cabal b/monarch.cabal --- a/monarch.cabal +++ b/monarch.cabal @@ -1,5 +1,5 @@ name: monarch -version: 0.4.0.0 +version: 0.5.0.0 synopsis: Monadic interface for TokyoTyrant. description: This package provides simple monadic interface for TokyoTyrant. license: BSD3 @@ -21,7 +21,6 @@ build-depends: base ==4.* , mtl ==2.1.* , bytestring ==0.9.* - , conduit ==0.5.* , network-conduit ==0.5.* , binary ==0.5.* , msgpack ==0.7.* @@ -30,6 +29,7 @@ , pool-conduit ==0.1.* , monad-control ==0.3.* , lifted-base ==0.1.* + , transformers-base ==0.4.* test-suite specs hs-source-dirs: test, . @@ -38,7 +38,6 @@ build-depends: base ==4.* , mtl ==2.1.* , bytestring ==0.9.* - , conduit ==0.5.* , network-conduit ==0.5.* , binary ==0.5.* , msgpack ==0.7.* @@ -46,8 +45,26 @@ , pool-conduit ==0.1.* , monad-control ==0.3.* , lifted-base ==0.1.* + , transformers-base ==0.4.* , hspec ==1.3.* , HUnit ==1.2.* + +test-suite benchmark + hs-source-dirs: test, . + type: exitcode-stdio-1.0 + main-is: benchmark.hs + build-depends: base ==4.* + , mtl ==2.1.* + , bytestring ==0.9.* + , binary ==0.5.* + , network ==2.3.* + , network-conduit ==0.5.* + , pool-conduit ==0.1.* + , monad-control ==0.3.* + , lifted-base ==0.1.* + , tokyotyrant-haskell ==1.0.* + , transformers ==0.3.* + , transformers-base ==0.4.* source-repository head type: git diff --git a/test/benchmark.hs b/test/benchmark.hs new file mode 100644 --- /dev/null +++ b/test/benchmark.hs @@ -0,0 +1,27 @@ +{-# LANGUAGE OverloadedStrings #-} +import Database.Monarch + +import qualified Database.TokyoTyrant.FFI as FFI +import Control.Monad +import Data.ByteString.Char8 () + +main :: IO () +main = monarch + +ffi :: IO () +ffi = do + Right conn <- FFI.open "localhost" 1978 + forM_ [1..1000::Int] $ \_ -> do + FFI.put conn "foo" "bar" + FFI.get conn "foo" + return () + FFI.close conn + +monarch :: IO () +monarch = do + withMonarchConn "localhost" 1978 $ runMonarchConn $ do + forM_ [1..1000::Int] $ \_ -> do + put "foo" "bar" + get "foo" + return () + return ()