monarch 0.3.0.0 → 0.4.0.0

raw patch · 8 files changed

+162/−88 lines, 8 filesdep +lifted-basedep +monad-controldep +networkPVP ok

version bump matches the API change (PVP)

Dependencies added: lifted-base, monad-control, network, pool-conduit, transformers

API changes (from Hackage documentation)

Files

• Database/Monarch.hs +2/−2
• Database/Monarch/Binary.hs +3/−3
• Database/Monarch/MessagePack.hs +1/−1
• Database/Monarch/Raw.hs +128/−0
• Database/Monarch/Types.hs +0/−71
• Database/Monarch/Utils.hs +2/−1
• monarch.cabal +11/−2
• test/test.hs +15/−8

@@ -3,9 +3,9 @@ -- module Database.Monarch     (-      module Database.Monarch.Types+      module Database.Monarch.Raw     , module Database.Monarch.Binary     ) where -import Database.Monarch.Types hiding (liftMonarch)+import Database.Monarch.Raw hiding (liftMonarch) import Database.Monarch.Binary

@@ -23,7 +23,7 @@ import Control.Applicative import Control.Monad.Error -import Database.Monarch.Types+import Database.Monarch.Raw import Database.Monarch.Utils  -- | Store a record.@@ -184,14 +184,14 @@  -- | Get forward matching keys. forwardMatchingKeys :: ByteString -- ^ key prefix-                    -> Int -- ^ maximum number of keys to be fetched+                    -> Maybe Int -- ^ maximum number of keys to be fetched. 'Nothing' means unlimited.                     -> Monarch [ByteString] forwardMatchingKeys prefix n = communicate request response     where       request = do         putMagic 0x58         putWord32be $ lengthBS32 prefix-        putWord32be $ fromIntegral n+        putWord32be $ fromIntegral (maybe (-1) id n)         putByteString prefix       response Success = do         siz <- fromIntegral <$> parseWord32

@@ -12,7 +12,7 @@ import Control.Applicative import Control.Monad.Error -import Database.Monarch.Types+import Database.Monarch.Raw import Database.Monarch.Utils  -- | Store a record.

@@ -0,0 +1,128 @@+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE FlexibleContexts #-}+-- | Raw definitions.+module Database.Monarch.Raw+    (+      Monarch+    , Connection, ConnectionPool+    , withMonarchConn+    , withMonarchPool+    , runMonarchConn+    , runMonarchPool+    , ExtOption(..), RestoreOption(..), MiscOption(..)+    , Code(..)+    , liftMonarch+    ) where++import Data.IORef+import Data.ByteString+import Data.Conduit+import Data.Conduit.Network+import Data.Conduit.Pool+import Control.Exception.Lifted (bracket)+import Control.Monad.Error+import Control.Applicative+import Control.Monad.Trans.Control+import Network.Socket++-- | Connection with TokyoTyrant+data Connection = Connection { connection :: Socket }++-- | Connection pool with TokyoTyrant+type ConnectionPool = Pool Connection++-- | Error code+data Code = Success+          | InvalidOperation+          | HostNotFound+          | ConnectionRefused+          | SendError+          | ReceiveError+          | ExistingRecord+          | NoRecordFound+          | MiscellaneousError+            deriving (Eq, Show)++instance Error Code++-- | Options for scripting extension+data ExtOption = RecordLocking -- ^ record locking+               | GlobalLocking -- ^ global locking++-- | Options for restore+data RestoreOption = ConsistencyChecking -- ^ consistency checking++-- | Options for miscellaneous operation+data MiscOption = NoUpdateLog -- ^ omission of update log++-- | A monad supporting TokyoTyrant access.+newtype Monarch a =+    Monarch { unMonarch :: ErrorT Code (Pipe ByteString ByteString ByteString () IO) a }+    deriving ( Functor, Applicative, Monad, MonadIO+             , MonadError Code )++-- | 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++-- | Create a TokyoTyrant connection and run the given action.+-- Don't use the given 'Connection' outside the action.+withMonarchConn :: (MonadBaseControl IO m, MonadIO m) =>+                   String+                -> Int+                -> (Connection -> m a)+                -> m a+withMonarchConn host port f =+    bracket open' close' f+    where+      open' = liftIO (Connection <$> getSocket host port)+      close' = liftIO . sClose . connection++-- | Create a TokyoTyrant connection pool and run the given action.+-- Don't use the given 'ConnectionPool' outside the action.+withMonarchPool :: (MonadBaseControl IO m, MonadIO m) =>+                   String+                -> Int+                -> Int+                -> (ConnectionPool -> m a)+                -> m a+withMonarchPool host port size f =+    liftIO (createPool open' close' 1 20 size) >>= f+    where+      open' = Connection <$> getSocket host port+      close' = sClose . connection++-- | Run action with a connection.+runMonarchConn :: (MonadBaseControl IO m, MonadIO m) =>+                  Monarch a+               -> Connection+               -> m (Either Code a)+runMonarchConn action conn = runMonarch conn action++-- | Run action with a unused connection from the pool.+runMonarchPool :: (MonadBaseControl IO m, MonadIO m) =>+                  Monarch a+               -> ConnectionPool+               -> 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

@@ -1,71 +0,0 @@-{-# LANGUAGE GeneralizedNewtypeDeriving #-}--- | Types.-module Database.Monarch.Types-    (-      Monarch, runMonarch, liftMonarch-    , ExtOption(..), RestoreOption(..), MiscOption(..)-    , Code(..)-    ) where--import Data.IORef-import Data.ByteString-import Data.Conduit-import Data.Conduit.Network-import Control.Monad.Error-import Control.Applicative---- | Error code-data Code = Success-          | InvalidOperation-          | HostNotFound-          | ConnectionRefused-          | SendError-          | ReceiveError-          | ExistingRecord-          | NoRecordFound-          | MiscellaneousError-            deriving (Eq, Show)--instance Error Code---- | Options for scripting extension-data ExtOption = RecordLocking -- ^ record locking-               | GlobalLocking -- ^ global locking---- | Options for restore-data RestoreOption = ConsistencyChecking -- ^ consistency checking---- | Options for miscellaneous operation-data MiscOption = NoUpdateLog -- ^ omission of update log---- | A monad supporting TokyoTyrant access.-newtype Monarch a =-    Monarch { unMonarch :: ErrorT Code (Pipe ByteString ByteString ByteString () IO) a }-    deriving ( Functor, Applicative, Monad, MonadIO-             , MonadError Code )---- | Run Monarch with TokyoTyrant at target host and port.-runMonarch :: MonadIO m =>-              String-           -> Int-           -> Monarch a-           -> m (Either Code a)-runMonarch host port action =-    liftIO $ do-      result <- liftIO $ newIORef $ Left Success-      let remote = ClientSettings port host-      runTCPClient remote $ client action result-      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---- | Lift-liftMonarch :: Pipe ByteString ByteString ByteString () IO a-            -> Monarch a-liftMonarch = Monarch . lift

@@ -23,7 +23,8 @@ import Data.Binary.Get (runGet, getWord32be) import Control.Applicative import Control.Monad.Error-import Database.Monarch.Types++import Database.Monarch.Raw  class BitFlag32 a where     fromOption :: a -> Int32

@@ -1,5 +1,5 @@ name:                monarch-version:             0.3.0.0+version:             0.4.0.0 synopsis:            Monadic interface for TokyoTyrant. description:         This package provides simple monadic interface for TokyoTyrant. license:             BSD3@@ -13,7 +13,7 @@  library   exposed-modules:     Database.Monarch-                     , Database.Monarch.Types+                     , Database.Monarch.Raw                      , Database.Monarch.Binary                      , Database.Monarch.MessagePack   other-modules:       Database.Monarch.Utils@@ -25,6 +25,11 @@                      , network-conduit ==0.5.*                      , binary ==0.5.*                      , msgpack ==0.7.*+                     , transformers ==0.3.*+                     , network ==2.3.*+                     , pool-conduit ==0.1.*+                     , monad-control ==0.3.*+                     , lifted-base ==0.1.*  test-suite specs   hs-source-dirs:      test, .@@ -37,6 +42,10 @@                      , network-conduit ==0.5.*                      , binary ==0.5.*                      , msgpack ==0.7.*+                     , network ==2.3.*+                     , pool-conduit ==0.1.*+                     , monad-control ==0.3.*+                     , lifted-base ==0.1.*                      , hspec ==1.3.*                      , HUnit ==1.2.* 

@@ -53,13 +53,20 @@            Monarch a         -> Either Code a         -> IO ()-action `returns` expected = do-  result <- runMonarch "localhost" 1978 $ do-              vanish-              result <- action-              vanish-              return result-  result @?= expected+action `returns` expected = connTest >> poolTest+  where+  connTest = do result <- withMonarchConn "localhost" 1978 $ runMonarchConn $ do+                            vanish+                            result <- action+                            vanish+                            return result+                result @?= expected+  poolTest = do result <- withMonarchPool "localhost" 1978 20 $ runMonarchPool $ do+                            vanish+                            result <- action+                            vanish+                            return result+                result @?= expected  casePutRecord :: Assertion casePutRecord =@@ -247,7 +254,7 @@         put "abra" "cadabra"         put "abrac" "adabra"         put "abraca" "dabra"-        sort <$> forwardMatchingKeys "abra" 2+        sort <$> forwardMatchingKeys "abra" (Just 2)  casePutMsgPackRecord :: Assertion casePutMsgPackRecord =