monarch 0.5.0.0 → 0.6.0.0
raw patch · 6 files changed
+126/−81 lines, 6 files
Files
- Database/Monarch/Binary.hs +68/−43
- Database/Monarch/MessagePack.hs +10/−8
- Database/Monarch/Raw.hs +28/−17
- Database/Monarch/Utils.hs +15/−11
- monarch.cabal +4/−1
- test/test.hs +1/−1
Database/Monarch/Binary.hs view
@@ -1,3 +1,4 @@+{-# LANGUAGE FlexibleContexts #-} -- | TokyoTyrant Original Binary Protocol(<http://fallabs.com/tokyotyrant/spex.html#protocol>). module Database.Monarch.Binary (@@ -22,6 +23,7 @@ import Data.ByteString hiding (length, copy) import Control.Applicative import Control.Monad.Error+import Control.Monad.Trans.Control import Database.Monarch.Raw import Database.Monarch.Utils@@ -29,9 +31,10 @@ -- | Store a record. -- If a record with the same key exists in the database, -- it is overwritten.-put :: ByteString -- ^ key+put :: (MonadBaseControl IO m, MonadIO m) =>+ ByteString -- ^ key -> ByteString -- ^ value- -> Monarch ()+ -> MonarchT m () put key value = communicate request response where request = do@@ -46,9 +49,10 @@ -- | Store a new record. -- If a record with the same key exists in the database, -- this function has no effect.-putKeep :: ByteString -- ^ key+putKeep :: (MonadBaseControl IO m, MonadIO m) =>+ ByteString -- ^ key -> ByteString -- ^ value- -> Monarch ()+ -> MonarchT m () putKeep key value = communicate request response where request = do@@ -63,9 +67,10 @@ -- | Concatenate a value at the end of the existing record. -- If there is no corresponding record, a new record is created.-putCat :: ByteString -- ^ key+putCat :: (MonadBaseControl IO m, MonadIO m) =>+ ByteString -- ^ key -> ByteString -- ^ value- -> Monarch ()+ -> MonarchT m () putCat key value = communicate request response where request = do@@ -79,10 +84,11 @@ -- | Concatenate a value at the end of the existing record and shift it to the left. -- If there is no corresponding record, a new record is created.-putShiftLeft :: ByteString -- ^ key+putShiftLeft :: (MonadBaseControl IO m, MonadIO m) =>+ ByteString -- ^ key -> ByteString -- ^ value -> Int -- ^ width- -> Monarch ()+ -> MonarchT m () putShiftLeft key value width = communicate request response where request = do@@ -97,9 +103,10 @@ -- | Store a record without response. -- If a record with the same key exists in the database, it is overwritten.-putNoResponse :: ByteString -- ^ key+putNoResponse :: (MonadBaseControl IO m, MonadIO m) =>+ ByteString -- ^ key -> ByteString -- ^ value- -> Monarch ()+ -> MonarchT m () putNoResponse key value = yieldRequest request where request = do@@ -110,8 +117,9 @@ putByteString value -- | Remove a record.-out :: ByteString -- ^ key- -> Monarch ()+out :: (MonadBaseControl IO m, MonadIO m) =>+ ByteString -- ^ key+ -> MonarchT m () out key = communicate request response where request = do@@ -123,8 +131,9 @@ response code = throwError code -- | Retrieve a record.-get :: ByteString -- ^ key- -> Monarch (Maybe ByteString)+get :: (MonadBaseControl IO m, MonadIO m) =>+ ByteString -- ^ key+ -> MonarchT m (Maybe ByteString) get key = communicate request response where request = do@@ -136,8 +145,9 @@ response code = throwError code -- | Retrieve records.-multipleGet :: [ByteString] -- ^ keys- -> Monarch [(ByteString, ByteString)]+multipleGet :: (MonadBaseControl IO m, MonadIO m) =>+ [ByteString] -- ^ keys+ -> MonarchT m [(ByteString, ByteString)] multipleGet keys = communicate request response where request = do@@ -152,8 +162,9 @@ response code = throwError code -- | Get the size of the value of a record.-valueSize :: ByteString -- ^ key- -> Monarch (Maybe Int)+valueSize :: (MonadBaseControl IO m, MonadIO m) =>+ ByteString -- ^ key+ -> MonarchT m (Maybe Int) valueSize key = communicate request response where request = do@@ -165,7 +176,8 @@ response code = throwError code -- | Initialize the iterator.-iterInit :: Monarch ()+iterInit :: (MonadBaseControl IO m, MonadIO m) =>+ MonarchT m () iterInit = communicate request response where request = putMagic 0x50@@ -174,7 +186,8 @@ -- | Get the next key of the iterator. -- The iterator can be updated by multiple connections and then it is not assured that every record is traversed.-iterNext :: Monarch (Maybe ByteString)+iterNext :: (MonadBaseControl IO m, MonadIO m) =>+ MonarchT m (Maybe ByteString) iterNext = communicate request response where request = putMagic 0x51@@ -183,9 +196,10 @@ response code = throwError code -- | Get forward matching keys.-forwardMatchingKeys :: ByteString -- ^ key prefix+forwardMatchingKeys :: (MonadBaseControl IO m, MonadIO m) =>+ ByteString -- ^ key prefix -> Maybe Int -- ^ maximum number of keys to be fetched. 'Nothing' means unlimited.- -> Monarch [ByteString]+ -> MonarchT m [ByteString] forwardMatchingKeys prefix n = communicate request response where request = do@@ -201,9 +215,10 @@ -- | Add an integer to a record. -- If the corresponding record exists, the value is treated as an integer and is added to. -- If no record corresponds, a new record of the additional value is stored.-addInt :: ByteString -- ^ key+addInt :: (MonadBaseControl IO m, MonadIO m) =>+ ByteString -- ^ key -> Int -- ^ value- -> Monarch Int+ -> MonarchT m Int addInt key n = communicate request response where request = do@@ -217,9 +232,10 @@ -- | Add a real number to a record. -- If the corresponding record exists, the value is treated as a real number and is added to. -- If no record corresponds, a new record of the additional value is stored.-addDouble :: ByteString -- ^ key+addDouble :: (MonadBaseControl IO m, MonadIO m) =>+ ByteString -- ^ key -> Double -- ^ value- -> Monarch Double+ -> MonarchT m Double addDouble key n = communicate request response where request = do@@ -232,11 +248,12 @@ response code = throwError code -- | Call a function of the script language extension.-ext :: ByteString -- ^ function+ext :: (MonadBaseControl IO m, MonadIO m) =>+ ByteString -- ^ function -> [ExtOption] -- ^ option flags -> ByteString -- ^ key -> ByteString -- ^ value- -> Monarch ByteString+ -> MonarchT m ByteString ext func opts key value = communicate request response where request = do@@ -252,7 +269,8 @@ response code = throwError code -- | Synchronize updated contents with the file and the device.-sync :: Monarch ()+sync :: (MonadBaseControl IO m, MonadIO m) =>+ MonarchT m () sync = communicate request response where request = putMagic 0x70@@ -260,8 +278,9 @@ response code = throwError code -- | Optimize the storage.-optimize :: ByteString -- ^ parameter- -> Monarch ()+optimize :: (MonadBaseControl IO m, MonadIO m) =>+ ByteString -- ^ parameter+ -> MonarchT m () optimize param = communicate request response where request = do@@ -272,7 +291,8 @@ response code = throwError code -- | Remove all records.-vanish :: Monarch ()+vanish :: (MonadBaseControl IO m, MonadIO m) =>+ MonarchT m () vanish = communicate request response where request = putMagic 0x72@@ -280,8 +300,9 @@ response code = throwError code -- | Copy the database file.-copy :: ByteString -- ^ path- -> Monarch ()+copy :: (MonadBaseControl IO m, MonadIO m) =>+ ByteString -- ^ path+ -> MonarchT m () copy path = communicate request response where request = do@@ -292,11 +313,11 @@ response code = throwError code -- | Restore the database file from the update log.-restore :: Integral a =>+restore :: (MonadBaseControl IO m, MonadIO m, Integral a) => ByteString -- ^ path -> a -- ^ beginning time stamp in microseconds -> [RestoreOption] -- ^ option flags- -> Monarch ()+ -> MonarchT m () restore path usec opts = communicate request response where request = do@@ -309,12 +330,12 @@ response code = throwError code -- | Set the replication master.-setMaster :: Integral a =>+setMaster :: (MonadBaseControl IO m, MonadIO m, Integral a) => ByteString -- ^ host -> Int -- ^ port -> a -- ^ beginning time stamp in microseconds -> [RestoreOption] -- ^ option flags- -> Monarch ()+ -> MonarchT m () setMaster host port usec opts = communicate request response where request = do@@ -328,7 +349,8 @@ response code = throwError code -- | Get the number of records.-recordNum :: Monarch Int64+recordNum :: (MonadBaseControl IO m, MonadIO m) =>+ MonarchT m Int64 recordNum = communicate request response where request = putMagic 0x80@@ -336,7 +358,8 @@ response code = throwError code -- | Get the size of the database.-size :: Monarch Int64+size :: (MonadBaseControl IO m, MonadIO m) =>+ MonarchT m Int64 size = communicate request response where request = putMagic 0x81@@ -344,7 +367,8 @@ response code = throwError code -- | Get the status string of the database.-status :: Monarch ByteString+status :: (MonadBaseControl IO m, MonadIO m) =>+ MonarchT m ByteString status = communicate request response where request = putMagic 0x88@@ -352,10 +376,11 @@ response code = throwError code -- | Call a versatile function for miscellaneous operations.-misc :: ByteString -- ^ function name+misc :: (MonadBaseControl IO m, MonadIO m) =>+ ByteString -- ^ function name -> [MiscOption] -- ^ option flags -> [ByteString] -- ^ arguments- -> Monarch [ByteString]+ -> MonarchT m [ByteString] misc func opts args = communicate request response where request = do
Database/Monarch/MessagePack.hs view
@@ -1,3 +1,4 @@+{-# LANGUAGE FlexibleContexts #-} -- | Store/Retrieve a MessagePackable record. module Database.Monarch.MessagePack (@@ -11,6 +12,7 @@ import Data.Binary.Put (putWord32be, putByteString, putLazyByteString) import Control.Applicative import Control.Monad.Error+import Control.Monad.Trans.Control import Database.Monarch.Raw import Database.Monarch.Utils@@ -18,10 +20,10 @@ -- | Store a record. -- If a record with the same key exists in the database, -- it is overwritten.-put :: MsgPack.Packable a =>+put :: (MonadBaseControl IO m, MonadIO m, MsgPack.Packable a) => ByteString -- ^ key -> a -- ^ value- -> Monarch ()+ -> MonarchT m () put key value = communicate request response where msg = MsgPack.pack value@@ -37,10 +39,10 @@ -- | Store a new record. -- If a record with the same key exists in the database, -- this function has no effect.-putKeep :: MsgPack.Packable a =>+putKeep :: (MonadBaseControl IO m, MonadIO m, MsgPack.Packable a) => ByteString -- ^ key -> a -- ^ value- -> Monarch ()+ -> MonarchT m () putKeep key value = communicate request response where msg = MsgPack.pack value@@ -56,10 +58,10 @@ -- | Store a record without response. -- If a record with the same key exists in the database, it is overwritten.-putNoResponse :: MsgPack.Packable a =>+putNoResponse :: (MonadBaseControl IO m, MonadIO m, MsgPack.Packable a) => ByteString -- ^ key -> a -- ^ value- -> Monarch ()+ -> MonarchT m () putNoResponse key value = yieldRequest request where msg = MsgPack.pack value@@ -71,9 +73,9 @@ putLazyByteString msg -- | Retrieve a record.-get :: MsgPack.Unpackable a =>+get :: (MonadBaseControl IO m, MonadIO m, MsgPack.Unpackable a) => ByteString -- ^ key- -> Monarch (Maybe a)+ -> MonarchT m (Maybe a) get key = communicate request response where request = do
Database/Monarch/Raw.hs view
@@ -1,11 +1,13 @@ {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE UndecidableInstances #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE TypeFamilies #-} -- | Raw definitions. module Database.Monarch.Raw (- Monarch+ Monarch, MonarchT , Connection, ConnectionPool , withMonarchConn , withMonarchPool@@ -59,24 +61,33 @@ -- | Options for miscellaneous operation data MiscOption = NoUpdateLog -- ^ omission of update log --- | A monad supporting TokyoTyrant access.-newtype Monarch a =- Monarch { unMonarch :: ErrorT Code (ReaderT Connection IO) a }+-- | The Monarch monad transformer to provide TokyoTyrant access.+newtype MonarchT m a =+ MonarchT { unMonarchT :: ErrorT Code (ReaderT Connection m) a } deriving ( Functor, Applicative, Monad, MonadIO- , MonadReader Connection, MonadError Code, MonadBase IO )+ , MonadReader Connection, MonadError Code, MonadBase base ) -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+instance MonadTrans MonarchT where+ lift = MonarchT . lift . lift +instance MonadTransControl MonarchT where+ newtype StT MonarchT a = StMonarch { unStMonarch :: Either Code a }+ liftWith f = MonarchT . ErrorT . ReaderT $ (\r -> liftM Right (f $ \t -> liftM StMonarch (runReaderT (runErrorT (unMonarchT t)) r)))+ restoreT = MonarchT . ErrorT . ReaderT . const .liftM unStMonarch++instance MonadBaseControl base m => MonadBaseControl base (MonarchT m) where+ newtype StM (MonarchT m) a = StMMonarchT { unStMMonarchT :: ComposeSt MonarchT m a }+ liftBaseWith = defaultLiftBaseWith StMMonarchT+ restoreM = defaultRestoreM unStMMonarchT++type Monarch = MonarchT IO+ -- | Run Monarch with TokyoTyrant at target host and port. runMonarch :: MonadIO m => Connection- -> Monarch a+ -> MonarchT m a -> m (Either Code a)-runMonarch conn action =- liftIO $ runReaderT (runErrorT $ unMonarch action) conn+runMonarch conn action = runReaderT (runErrorT $ unMonarchT action) conn -- | Create a TokyoTyrant connection and run the given action. -- Don't use the given 'Connection' outside the action.@@ -107,27 +118,27 @@ -- | Run action with a connection. runMonarchConn :: (MonadBaseControl IO m, MonadIO m) =>- Monarch a+ MonarchT m 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+ MonarchT m a -> ConnectionPool -> m (Either Code a) runMonarchPool action pool = withResource pool (\conn -> runMonarch conn action) -throwError' :: Code -> SomeException -> Monarch a+throwError' :: (Monad m) => Code -> SomeException -> MonarchT m a throwError' e _ = throwError e -sendLBS :: LBS.ByteString -> Monarch ()+sendLBS :: (MonadBaseControl IO m, MonadIO m) => LBS.ByteString -> MonarchT m () sendLBS lbs = do conn <- connection <$> ask liftIO (NSLBS.sendAll conn lbs) `E.catch` throwError' SendError -recvLBS :: Int64 -> Monarch LBS.ByteString+recvLBS :: (MonadBaseControl IO m, MonadIO m) => Int64 -> MonarchT m LBS.ByteString recvLBS n = do conn <- connection <$> ask lbs <- liftIO (NSLBS.recv conn n) `E.catch` throwError' SendError
Database/Monarch/Utils.hs view
@@ -1,3 +1,4 @@+{-# LANGUAGE FlexibleContexts #-} module Database.Monarch.Utils ( toCode@@ -20,6 +21,8 @@ import Data.Binary.Put (runPut, putWord32be) import Data.Binary.Get (runGet, getWord32be) import Control.Applicative+import Control.Monad.IO.Class+import Control.Monad.Trans.Control import Database.Monarch.Raw @@ -67,32 +70,32 @@ fromLBS :: LBS.ByteString -> BS.ByteString fromLBS = BS.pack . LBS.unpack -yieldRequest :: B.Put -> Monarch ()+yieldRequest :: (MonadBaseControl IO m, MonadIO m) => B.Put -> MonarchT m () yieldRequest = sendLBS . runPut -responseCode :: Monarch Code+responseCode :: (MonadBaseControl IO m, MonadIO m) => MonarchT m Code responseCode = toCode . fromIntegral . runGet B.getWord8 <$> recvLBS 1 -parseLBS :: Monarch LBS.ByteString+parseLBS :: (MonadBaseControl IO m, MonadIO m) => MonarchT m LBS.ByteString parseLBS = recvLBS 4 >>= recvLBS . fromIntegral . runGet getWord32be -parseBS :: Monarch BS.ByteString+parseBS :: (MonadBaseControl IO m, MonadIO m) => MonarchT m BS.ByteString parseBS = fromLBS <$> parseLBS -parseWord32 :: Monarch B.Word32+parseWord32 :: (MonadBaseControl IO m, MonadIO m) => MonarchT m B.Word32 parseWord32 = runGet getWord32be <$> recvLBS 4 -parseInt64 :: Monarch Int64+parseInt64 :: (MonadBaseControl IO m, MonadIO m) => MonarchT m Int64 parseInt64 = runGet (B.get :: B.Get Int64) <$> recvLBS 8 -parseDouble :: Monarch Double+parseDouble :: (MonadBaseControl IO m, MonadIO m) => MonarchT m Double parseDouble = do integ <- fromIntegral <$> parseInt64 fract <- fromIntegral <$> parseInt64 return $ integ + fract * 1e-12 -parseKeyValue :: Monarch (BS.ByteString, BS.ByteString)+parseKeyValue :: (MonadBaseControl IO m, MonadIO m) => MonarchT m (BS.ByteString, BS.ByteString) parseKeyValue = do ksiz <- recvLBS 4 vsiz <- recvLBS 4@@ -102,9 +105,10 @@ runGet getWord32be vsiz return (fromLBS key, fromLBS value) -communicate :: B.Put- -> (Code -> Monarch a)- -> Monarch a+communicate :: (MonadBaseControl IO m, MonadIO m) =>+ B.Put+ -> (Code -> MonarchT m a)+ -> MonarchT m a communicate makeRequest makeResponse = yieldRequest makeRequest >> responseCode >>=
monarch.cabal view
@@ -1,5 +1,5 @@ name: monarch-version: 0.5.0.0+version: 0.6.0.0 synopsis: Monadic interface for TokyoTyrant. description: This package provides simple monadic interface for TokyoTyrant. license: BSD3@@ -20,6 +20,7 @@ ghc-options: -Wall build-depends: base ==4.* , mtl ==2.1.*+ , transformers ==0.3.* , bytestring ==0.9.* , network-conduit ==0.5.* , binary ==0.5.*@@ -37,6 +38,7 @@ main-is: test.hs build-depends: base ==4.* , mtl ==2.1.*+ , transformers ==0.3.* , bytestring ==0.9.* , network-conduit ==0.5.* , binary ==0.5.*@@ -55,6 +57,7 @@ main-is: benchmark.hs build-depends: base ==4.* , mtl ==2.1.*+ , transformers ==0.3.* , bytestring ==0.9.* , binary ==0.5.* , network ==2.3.*
test/test.hs view
@@ -50,7 +50,7 @@ it "store a record" casePutNrMsgPackRecord returns :: (Eq a, Show a) =>- Monarch a+ MonarchT IO a -> Either Code a -> IO () action `returns` expected = connTest >> poolTest