monarch 0.4.0.0 → 0.5.0.0

raw patch · 5 files changed

+95/−54 lines, 5 filesdep +tokyotyrant-haskelldep +transformers-basedep −conduitPVP ok

version bump matches the API change (PVP)

Dependencies added: tokyotyrant-haskell, transformers-base

Dependencies removed: conduit

API changes (from Hackage documentation)

Files

• Database/Monarch.hs +1/−1
• Database/Monarch/Raw.hs +33/−25
• Database/Monarch/Utils.hs +14/−25
• monarch.cabal +20/−3
• test/benchmark.hs +27/−0

@@ -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

@@ -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

@@ -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)

@@ -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

@@ -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 ()