monarch 0.7.0.1 → 0.8.0.0
raw patch · 8 files changed
+466/−456 lines, 8 filesdep +doctestdep −msgpack
Dependencies added: doctest
Dependencies removed: msgpack
Files
- Database/Monarch/Binary.hs +70/−51
- Database/Monarch/MessagePack.hs +0/−87
- Database/Monarch/Raw.hs +33/−17
- Database/Monarch/Utils.hs +81/−11
- monarch.cabal +26/−9
- test/doctests.hs +6/−0
- test/specs.hs +250/−0
- test/test.hs +0/−281
Database/Monarch/Binary.hs view
@@ -18,10 +18,12 @@ ) where import Data.Int+import Data.Maybe import qualified Data.Binary as B import Data.Binary.Put (putWord32be, putByteString) import Data.ByteString hiding (length, copy) import Control.Applicative+import Control.Monad import Control.Monad.Error import Control.Monad.Trans.Control @@ -31,7 +33,8 @@ -- | Store a record. -- If a record with the same key exists in the database, -- it is overwritten.-put :: (MonadBaseControl IO m, MonadIO m) =>+put :: ( MonadBaseControl IO m+ , MonadIO m ) => ByteString -- ^ key -> ByteString -- ^ value -> MonarchT m ()@@ -39,17 +42,16 @@ where request = do putMagic 0x10- putWord32be $ lengthBS32 key- putWord32be $ lengthBS32 value- putByteString key- putByteString value+ mapM_ (putWord32be . lengthBS32) [key, value]+ mapM_ putByteString [key, value] response Success = return () response code = throwError code -- | Store a new record. -- If a record with the same key exists in the database, -- this function has no effect.-putKeep :: (MonadBaseControl IO m, MonadIO m) =>+putKeep :: ( MonadBaseControl IO m+ , MonadIO m ) => ByteString -- ^ key -> ByteString -- ^ value -> MonarchT m ()@@ -57,17 +59,16 @@ where request = do putMagic 0x11- putWord32be $ lengthBS32 key- putWord32be $ lengthBS32 value- putByteString key- putByteString value+ mapM_ (putWord32be . lengthBS32) [key, value]+ mapM_ putByteString [key, value] response Success = return () response InvalidOperation = return () response code = throwError code -- | Concatenate a value at the end of the existing record. -- If there is no corresponding record, a new record is created.-putCat :: (MonadBaseControl IO m, MonadIO m) =>+putCat :: ( MonadBaseControl IO m+ , MonadIO m ) => ByteString -- ^ key -> ByteString -- ^ value -> MonarchT m ()@@ -75,16 +76,15 @@ where request = do putMagic 0x12- putWord32be $ lengthBS32 key- putWord32be $ lengthBS32 value- putByteString key- putByteString value+ mapM_ (putWord32be . lengthBS32) [key, value]+ mapM_ putByteString [key, value] response Success = return () response code = throwError code -- | 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 :: (MonadBaseControl IO m, MonadIO m) =>+putShiftLeft :: ( MonadBaseControl IO m+ , MonadIO m ) => ByteString -- ^ key -> ByteString -- ^ value -> Int -- ^ width@@ -93,17 +93,16 @@ where request = do putMagic 0x13- putWord32be $ lengthBS32 key- putWord32be $ lengthBS32 value+ mapM_ (putWord32be . lengthBS32) [key, value] putWord32be $ fromIntegral width- putByteString key- putByteString value+ mapM_ putByteString [key, value] response Success = return () response code = throwError code -- | Store a record without response. -- If a record with the same key exists in the database, it is overwritten.-putNoResponse :: (MonadBaseControl IO m, MonadIO m) =>+putNoResponse :: ( MonadBaseControl IO m+ , MonadIO m ) => ByteString -- ^ key -> ByteString -- ^ value -> MonarchT m ()@@ -111,13 +110,12 @@ where request = do putMagic 0x18- putWord32be $ lengthBS32 key- putWord32be $ lengthBS32 value- putByteString key- putByteString value+ mapM_ (putWord32be . lengthBS32) [key, value]+ mapM_ putByteString [key, value] -- | Remove a record.-out :: (MonadBaseControl IO m, MonadIO m) =>+out :: ( MonadBaseControl IO m+ , MonadIO m ) => ByteString -- ^ key -> MonarchT m () out key = communicate request response@@ -131,7 +129,8 @@ response code = throwError code -- | Retrieve a record.-get :: (MonadBaseControl IO m, MonadIO m) =>+get :: ( MonadBaseControl IO m+ , MonadIO m ) => ByteString -- ^ key -> MonarchT m (Maybe ByteString) get key = communicate request response@@ -145,24 +144,26 @@ response code = throwError code -- | Retrieve records.-multipleGet :: (MonadBaseControl IO m, MonadIO m) =>+multipleGet :: ( MonadBaseControl IO m+ , MonadIO m ) => [ByteString] -- ^ keys -> MonarchT m [(ByteString, ByteString)] multipleGet keys = communicate request response where request = do putMagic 0x31- putWord32be $ fromIntegral $ length keys+ putWord32be . fromIntegral $ length keys mapM_ (\key -> do putWord32be $ lengthBS32 key putByteString key) keys response Success = do siz <- fromIntegral <$> parseWord32- sequence $ Prelude.replicate siz parseKeyValue+ replicateM siz parseKeyValue response code = throwError code -- | Get the size of the value of a record.-valueSize :: (MonadBaseControl IO m, MonadIO m) =>+valueSize :: ( MonadBaseControl IO m+ , MonadIO m ) => ByteString -- ^ key -> MonarchT m (Maybe Int) valueSize key = communicate request response@@ -176,7 +177,8 @@ response code = throwError code -- | Initialize the iterator.-iterInit :: (MonadBaseControl IO m, MonadIO m) =>+iterInit :: ( MonadBaseControl IO m+ , MonadIO m ) => MonarchT m () iterInit = communicate request response where@@ -186,7 +188,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 :: (MonadBaseControl IO m, MonadIO m) =>+iterNext :: ( MonadBaseControl IO m+ , MonadIO m ) => MonarchT m (Maybe ByteString) iterNext = communicate request response where@@ -196,7 +199,8 @@ response code = throwError code -- | Get forward matching keys.-forwardMatchingKeys :: (MonadBaseControl IO m, MonadIO m) =>+forwardMatchingKeys :: ( MonadBaseControl IO m+ , MonadIO m ) => ByteString -- ^ key prefix -> Maybe Int -- ^ maximum number of keys to be fetched. 'Nothing' means unlimited. -> MonarchT m [ByteString]@@ -205,17 +209,18 @@ request = do putMagic 0x58 putWord32be $ lengthBS32 prefix- putWord32be $ fromIntegral (maybe (-1) id n)+ putWord32be $ fromIntegral (fromMaybe (-1) n) putByteString prefix response Success = do siz <- fromIntegral <$> parseWord32- sequence $ Prelude.replicate siz parseBS+ replicateM siz parseBS response code = throwError code -- | 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 :: (MonadBaseControl IO m, MonadIO m) =>+addInt :: ( MonadBaseControl IO m+ , MonadIO m ) => ByteString -- ^ key -> Int -- ^ value -> MonarchT m Int@@ -232,7 +237,8 @@ -- | 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 :: (MonadBaseControl IO m, MonadIO m) =>+addDouble :: ( MonadBaseControl IO m+ , MonadIO m ) => ByteString -- ^ key -> Double -- ^ value -> MonarchT m Double@@ -248,7 +254,8 @@ response code = throwError code -- | Call a function of the script language extension.-ext :: (MonadBaseControl IO m, MonadIO m) =>+ext :: ( MonadBaseControl IO m+ , MonadIO m ) => ByteString -- ^ function -> [ExtOption] -- ^ option flags -> ByteString -- ^ key@@ -269,7 +276,8 @@ response code = throwError code -- | Synchronize updated contents with the file and the device.-sync :: (MonadBaseControl IO m, MonadIO m) =>+sync :: ( MonadBaseControl IO m+ , MonadIO m ) => MonarchT m () sync = communicate request response where@@ -278,7 +286,8 @@ response code = throwError code -- | Optimize the storage.-optimize :: (MonadBaseControl IO m, MonadIO m) =>+optimize :: ( MonadBaseControl IO m+ , MonadIO m ) => ByteString -- ^ parameter -> MonarchT m () optimize param = communicate request response@@ -291,7 +300,8 @@ response code = throwError code -- | Remove all records.-vanish :: (MonadBaseControl IO m, MonadIO m) =>+vanish :: ( MonadBaseControl IO m+ , MonadIO m ) => MonarchT m () vanish = communicate request response where@@ -300,7 +310,8 @@ response code = throwError code -- | Copy the database file.-copy :: (MonadBaseControl IO m, MonadIO m) =>+copy :: ( MonadBaseControl IO m+ , MonadIO m ) => ByteString -- ^ path -> MonarchT m () copy path = communicate request response@@ -313,7 +324,9 @@ response code = throwError code -- | Restore the database file from the update log.-restore :: (MonadBaseControl IO m, MonadIO m, Integral a) =>+restore :: ( MonadBaseControl IO m+ , MonadIO m+ , Integral a ) => ByteString -- ^ path -> a -- ^ beginning time stamp in microseconds -> [RestoreOption] -- ^ option flags@@ -330,7 +343,9 @@ response code = throwError code -- | Set the replication master.-setMaster :: (MonadBaseControl IO m, MonadIO m, Integral a) =>+setMaster :: ( MonadBaseControl IO m+ , MonadIO m+ , Integral a ) => ByteString -- ^ host -> Int -- ^ port -> a -- ^ beginning time stamp in microseconds@@ -349,7 +364,8 @@ response code = throwError code -- | Get the number of records.-recordNum :: (MonadBaseControl IO m, MonadIO m) =>+recordNum :: ( MonadBaseControl IO m+ , MonadIO m ) => MonarchT m Int64 recordNum = communicate request response where@@ -358,7 +374,8 @@ response code = throwError code -- | Get the size of the database.-size :: (MonadBaseControl IO m, MonadIO m) =>+size :: ( MonadBaseControl IO m+ , MonadIO m ) => MonarchT m Int64 size = communicate request response where@@ -367,7 +384,8 @@ response code = throwError code -- | Get the status string of the database.-status :: (MonadBaseControl IO m, MonadIO m) =>+status :: ( MonadBaseControl IO m+ , MonadIO m ) => MonarchT m ByteString status = communicate request response where@@ -376,7 +394,8 @@ response code = throwError code -- | Call a versatile function for miscellaneous operations.-misc :: (MonadBaseControl IO m, MonadIO m) =>+misc :: ( MonadBaseControl IO m+ , MonadIO m ) => ByteString -- ^ function name -> [MiscOption] -- ^ option flags -> [ByteString] -- ^ arguments@@ -387,10 +406,10 @@ putMagic 0x90 putWord32be $ lengthBS32 func putOptions opts- putWord32be $ fromIntegral $ length args+ putWord32be . fromIntegral $ length args putByteString func mapM_ putByteString args response Success = do siz <- fromIntegral <$> parseWord32- sequence $ Prelude.replicate siz parseBS+ replicateM siz parseBS response code = throwError code
− Database/Monarch/MessagePack.hs
@@ -1,87 +0,0 @@-{-# LANGUAGE FlexibleContexts #-}--- | Store/Retrieve a MessagePackable record.-module Database.Monarch.MessagePack- (- put, putKeep- , putNoResponse- , get- ) where--import qualified Data.MessagePack as MsgPack-import Data.ByteString-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---- | Store a record.--- If a record with the same key exists in the database,--- it is overwritten.-put :: (MonadBaseControl IO m, MonadIO m, MsgPack.Packable a) =>- ByteString -- ^ key- -> a -- ^ value- -> MonarchT m ()-put key value = communicate request response- where- msg = MsgPack.pack value- request = do- putMagic 0x10- putWord32be $ lengthBS32 key- putWord32be $ lengthLBS32 msg- putByteString key- putLazyByteString msg- response Success = return ()- response code = throwError code---- | Store a new record.--- If a record with the same key exists in the database,--- this function has no effect.-putKeep :: (MonadBaseControl IO m, MonadIO m, MsgPack.Packable a) =>- ByteString -- ^ key- -> a -- ^ value- -> MonarchT m ()-putKeep key value = communicate request response- where- msg = MsgPack.pack value- request = do- putMagic 0x11- putWord32be $ lengthBS32 key- putWord32be $ lengthLBS32 msg- putByteString key- putLazyByteString msg- response Success = return ()- response InvalidOperation = return ()- response code = throwError code---- | Store a record without response.--- If a record with the same key exists in the database, it is overwritten.-putNoResponse :: (MonadBaseControl IO m, MonadIO m, MsgPack.Packable a) =>- ByteString -- ^ key- -> a -- ^ value- -> MonarchT m ()-putNoResponse key value = yieldRequest request- where- msg = MsgPack.pack value- request = do- putMagic 0x18- putWord32be $ lengthBS32 key- putWord32be $ lengthLBS32 msg- putByteString key- putLazyByteString msg---- | Retrieve a record.-get :: (MonadBaseControl IO m, MonadIO m, MsgPack.Unpackable a) =>- ByteString -- ^ key- -> MonarchT m (Maybe a)-get key = communicate request response- where- request = do- putMagic 0x30- putWord32be $ lengthBS32 key- putByteString key- response Success = Just . MsgPack.unpack <$> parseLBS- response InvalidOperation = return Nothing- response code = throwError code
Database/Monarch/Raw.hs view
@@ -28,7 +28,7 @@ import Control.Applicative import Control.Monad.Trans.Control import Network.Socket-import qualified Network.Socket.ByteString.Lazy as NSLBS+import qualified Network.Socket.ByteString.Lazy as LBS import qualified Data.ByteString.Lazy as LBS -- | Connection with TokyoTyrant@@ -87,24 +87,26 @@ Connection -> MonarchT m a -> m (Either Code a)-runMonarch conn action = runReaderT (runErrorT $ unMonarchT 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.-withMonarchConn :: (MonadBaseControl IO m, MonadIO m) =>+withMonarchConn :: ( MonadBaseControl IO m+ , MonadIO m ) => String -- ^ host -> Int -- ^ port -> (Connection -> m a) -> m a-withMonarchConn host port f =- bracket open' close' f+withMonarchConn host port = bracket open' close' where open' = liftIO $ getConnection 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) =>+withMonarchPool :: ( MonadBaseControl IO m+ , MonadIO m ) => String -- ^ host -> Int -- ^ port -> Int -- ^ number of connections@@ -117,38 +119,52 @@ close' = sClose . connection -- | Run action with a connection.-runMonarchConn :: (MonadBaseControl IO m, MonadIO m) =>+runMonarchConn :: ( MonadBaseControl IO m+ , MonadIO m ) => MonarchT m a -- ^ action -> Connection -- ^ 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) =>+runMonarchPool :: ( MonadBaseControl IO m+ , MonadIO m ) => MonarchT m a -- ^ action -> ConnectionPool -- ^ connection pool -> m (Either Code a)-runMonarchPool action pool = withResource pool (\conn -> runMonarch conn action)+runMonarchPool action pool =+ withResource pool $ flip runMonarch action -throwError' :: (Monad m) => Code -> SomeException -> MonarchT m a-throwError' e _ = throwError e+throwError' :: Monad m =>+ Code+ -> SomeException+ -> MonarchT m a+throwError' = const . throwError -sendLBS :: (MonadBaseControl IO m, MonadIO m) => LBS.ByteString -> MonarchT m ()+sendLBS :: ( MonadBaseControl IO m+ , MonadIO m ) =>+ LBS.ByteString+ -> MonarchT m () sendLBS lbs = do conn <- connection <$> ask- liftIO (NSLBS.sendAll conn lbs) `catch` throwError' SendError+ liftIO (LBS.sendAll conn lbs) `catch` throwError' SendError -recvLBS :: (MonadBaseControl IO m, MonadIO m) => Int64 -> MonarchT m 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) `catch` throwError' ReceiveError+ lbs <- liftIO (LBS.recv conn n) `catch` throwError' ReceiveError if n /= LBS.length lbs then throwError ReceiveError else return lbs -getConnection :: HostName -> Int -> IO Connection+getConnection :: HostName+ -> Int+ -> IO Connection getConnection host port = do- let hints = defaultHints { addrFlags = [AI_ADDRCONFIG]+ let hints = defaultHints { addrFlags = [ AI_ADDRCONFIG ] , addrSocketType = Stream } (addr:_) <- getAddrInfo (Just hints) (Just host) (Just $ show port)
Database/Monarch/Utils.hs view
@@ -51,51 +51,120 @@ toCode 9999 = MiscellaneousError toCode _ = error "Invalid Code" -putMagic :: B.Word8- -> B.Put+-- | TokyoTyrant Original Binary Protocal magic id.+--+-- Example:+--+-- >>> :m +Data.ByteString.Char8+-- >>> :set -XOverloadedStrings+-- >>> fromLBS (runPut $ putMagic 0x10) == "\xC8\x10"+-- True+--+putMagic :: B.Word8 -> B.Put putMagic magic = B.putWord8 0xC8 >> B.putWord8 magic +-- | Option+--+-- Example:+--+-- >>> :m +Data.ByteString.Char8+-- >>> :set -XOverloadedStrings+-- >>> fromLBS (runPut $ putOptions [RecordLocking]) == "\0\0\0\1"+-- True+-- >>> fromLBS (runPut $ putOptions [GlobalLocking]) == "\0\0\0\2"+-- True+-- >>> fromLBS (runPut $ putOptions [RecordLocking, GlobalLocking]) == "\0\0\0\3"+-- True+-- putOptions :: BitFlag32 option => [option] -> B.Put putOptions = putWord32be . fromIntegral . foldl (.|.) 0 . map fromOption +-- | Get Length+--+-- Example:+--+-- >>> :m +Data.ByteString.Char8+-- >>> :set -XOverloadedStrings+-- >>> lengthBS32 "test"+-- 4+-- >>> lengthBS32 ""+-- 0+-- lengthBS32 :: BS.ByteString -> B.Word32 lengthBS32 = fromIntegral . BS.length +-- | Get Length+--+-- Example:+--+-- >>> :m +Data.ByteString.Lazy.Char8+-- >>> :set -XOverloadedStrings+-- >>> lengthLBS32 "test"+-- 4+-- >>> lengthLBS32 ""+-- 0+-- lengthLBS32 :: LBS.ByteString -> B.Word32 lengthLBS32 = fromIntegral . LBS.length +-- | Convert+--+-- Example:+--+-- >>> :m +Data.ByteString.Lazy.Char8+-- >>> :set -XOverloadedStrings+-- >>> fromLBS "test"+-- "test"+-- fromLBS :: LBS.ByteString -> BS.ByteString fromLBS = BS.pack . LBS.unpack -yieldRequest :: (MonadBaseControl IO m, MonadIO m) => B.Put -> MonarchT m ()+yieldRequest :: ( MonadBaseControl IO m+ , MonadIO m ) =>+ B.Put+ -> MonarchT m () yieldRequest = sendLBS . runPut -responseCode :: (MonadBaseControl IO m, MonadIO m) => MonarchT m Code+responseCode :: ( MonadBaseControl IO m+ , MonadIO m ) =>+ MonarchT m Code responseCode = toCode . fromIntegral . runGet B.getWord8 <$> recvLBS 1 -parseLBS :: (MonadBaseControl IO m, MonadIO m) => MonarchT m LBS.ByteString+parseLBS :: ( MonadBaseControl IO m+ , MonadIO m ) =>+ MonarchT m LBS.ByteString parseLBS = recvLBS 4 >>= recvLBS . fromIntegral . runGet getWord32be -parseBS :: (MonadBaseControl IO m, MonadIO m) => MonarchT m BS.ByteString+parseBS :: ( MonadBaseControl IO m+ , MonadIO m ) =>+ MonarchT m BS.ByteString parseBS = fromLBS <$> parseLBS -parseWord32 :: (MonadBaseControl IO m, MonadIO m) => MonarchT m B.Word32+parseWord32 :: ( MonadBaseControl IO m+ , MonadIO m ) =>+ MonarchT m B.Word32 parseWord32 = runGet getWord32be <$> recvLBS 4 -parseInt64 :: (MonadBaseControl IO m, MonadIO m) => MonarchT m Int64+parseInt64 :: ( MonadBaseControl IO m+ , MonadIO m ) =>+ MonarchT m Int64 parseInt64 = runGet (B.get :: B.Get Int64) <$> recvLBS 8 -parseDouble :: (MonadBaseControl IO m, MonadIO m) => MonarchT m Double+parseDouble :: ( MonadBaseControl IO m+ , MonadIO m ) =>+ MonarchT m Double parseDouble = do integ <- fromIntegral <$> parseInt64 fract <- fromIntegral <$> parseInt64 return $ integ + fract * 1e-12 -parseKeyValue :: (MonadBaseControl IO m, MonadIO m) => MonarchT m (BS.ByteString, BS.ByteString)+parseKeyValue :: ( MonadBaseControl IO m+ , MonadIO m ) =>+ MonarchT m (BS.ByteString, BS.ByteString) parseKeyValue = do ksiz <- recvLBS 4 vsiz <- recvLBS 4@@ -105,7 +174,8 @@ runGet getWord32be vsiz return (fromLBS key, fromLBS value) -communicate :: (MonadBaseControl IO m, MonadIO m) =>+communicate :: ( MonadBaseControl IO m+ , MonadIO m) => B.Put -> (Code -> MonarchT m a) -> MonarchT m a
monarch.cabal view
@@ -1,5 +1,5 @@ name: monarch-version: 0.7.0.1+version: 0.8.0.0 synopsis: Monadic interface for TokyoTyrant. description: This package provides simple monadic interface for TokyoTyrant. license: BSD3@@ -10,10 +10,18 @@ build-type: Simple cabal-version: >=1.8 homepage: https://github.com/notogawa/monarch+tested-with: GHC ==7.4.2 +source-repository head+ type: git+ location: https://github.com/notogawa/monarch++flag develop+ description: For developer+ default: False+ library exposed-modules: Database.Monarch- , Database.Monarch.MessagePack other-modules: Database.Monarch.Utils , Database.Monarch.Raw , Database.Monarch.Binary@@ -23,7 +31,6 @@ , transformers ==0.3.* , bytestring ==0.9.* , binary ==0.5.*- , msgpack ==0.7.* , transformers ==0.3.* , network ==2.3.* , pool-conduit ==0.1.*@@ -32,15 +39,18 @@ , transformers-base ==0.4.* test-suite specs+ if flag(develop)+ buildable: True+ else+ buildable: False hs-source-dirs: test, . type: exitcode-stdio-1.0- main-is: test.hs+ main-is: specs.hs build-depends: base ==4.* , mtl ==2.1.* , transformers ==0.3.* , bytestring ==0.9.* , binary ==0.5.*- , msgpack ==0.7.* , network ==2.3.* , pool-conduit ==0.1.* , monad-control ==0.3.*@@ -49,7 +59,18 @@ , hspec ==1.3.* , HUnit ==1.2.* +test-suite doctests+ hs-source-dirs: test, .+ type: exitcode-stdio-1.0+ main-is: doctests.hs+ build-depends: base ==4.*+ , doctest ==0.8.*+ test-suite benchmark+ if flag(develop)+ buildable: True+ else+ buildable: False hs-source-dirs: test, . type: exitcode-stdio-1.0 main-is: benchmark.hs@@ -65,7 +86,3 @@ , tokyotyrant-haskell ==1.0.* , transformers ==0.3.* , transformers-base ==0.4.*--source-repository head- type: git- location: https://github.com/notogawa/monarch
+ test/doctests.hs view
@@ -0,0 +1,6 @@+import Test.DocTest++main :: IO ()+main = doctest [ "-Lcabal-dev/lib"+ , "-package-conf=cabal-dev/packages-7.4.2.conf"+ , "Database/Monarch/Utils.hs" ]
+ test/specs.hs view
@@ -0,0 +1,250 @@+{-# LANGUAGE OverloadedStrings #-}+import Database.Monarch++import Control.Applicative+import Data.List+import Data.ByteString.Char8 ()+import Test.HUnit+import Test.Hspec.Monadic+import Test.Hspec.HUnit ()++main :: IO ()+main = hspec $ do+ describe "put" $ do+ it "store a record" casePutRecord+ it "overwrite a record if same key exists" casePutOverwriteRecord+ describe "putkeep" $ do+ it "store a new record" casePutKeepNewRecord+ it "has no effect if same key exists" casePutKeepNoEffect+ describe "putcat" $ do+ it "concatenate a value at the end of the existing record" casePutCatRecord+ it "store a new record if there is no corresponding record" casePutCatNewRecord+ describe "putshl" $ do+ it "concatenate a value at the end of the existing record and shift it to the left" casePutShlRecord+ it "store a new record if there is no corresponding record" casePutShlNewRecord+ describe "putnr" $ do+ it "store a record" casePutNrRecord+ it "overwrite a record if same key exists" casePutNrOverwriteRecord+ describe "out" $ do+ it "remove a record" caseOutRecord+ it "no effect if same key not exists" caseOutNoEffect+ describe "get" $ do+ it "retrieve a record" caseGetRecord+ describe "mget" $ do+ it "retrieve records" caseMgetRecords+ describe "vsiz" $ do+ it "get the size of the value of a record" caseVsizRecord+ describe "iterinit" $ do+ it "initialize the iterator" caseIterinit+ describe "iternext" $ do+ it "get the next key of the iterator" caseIternext+ it "invalid if end iterator" caseIternextInvalid+ describe "fwmkeys" $ do+ it "get forward matching keys" caseFwmkeys++returns :: (Eq a, Show a) =>+ MonarchT IO a+ -> Either Code a+ -> IO ()+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 =+ action `returns` Right (Just "bar")+ where+ action = do+ put "foo" "bar"+ get "foo"++casePutOverwriteRecord :: Assertion+casePutOverwriteRecord =+ action `returns` Right (Just "hoge")+ where+ action = do+ put "foo" "bar"+ put "foo" "hoge"+ get "foo"++casePutKeepNewRecord :: Assertion+casePutKeepNewRecord =+ action `returns` Right (Just "hoge")+ where+ action = do+ putKeep "foo" "hoge"+ get "foo"++casePutKeepNoEffect :: Assertion+casePutKeepNoEffect =+ action `returns` Right (Just "bar")+ where+ action = do+ putKeep "foo" "bar"+ putKeep "foo" "hoge"+ get "foo"++casePutCatRecord :: Assertion+casePutCatRecord =+ action `returns` Right (Just "abracadabra")+ where+ action = do+ put "foo" "abra"+ putCat "foo" "cadabra"+ get "foo"++casePutCatNewRecord :: Assertion+casePutCatNewRecord =+ action `returns` Right (Just "cadabra")+ where+ action = do+ putCat "foo" "cadabra"+ get "foo"++casePutShlRecord :: Assertion+casePutShlRecord =+ action `returns` Right (Just "racadabra")+ where+ action = do+ put "foo" "abra"+ putShiftLeft "foo" "cadabra" 9+ get "foo"++casePutShlNewRecord :: Assertion+casePutShlNewRecord =+ action `returns` Right (Just "cadabra")+ where+ action = do+ putShiftLeft "foo" "cadabra" 4+ get "foo"++casePutNrRecord :: Assertion+casePutNrRecord =+ action `returns` Right (Just "bar")+ where+ action = do+ putNoResponse "foo" "bar"+ get "foo"++casePutNrOverwriteRecord :: Assertion+casePutNrOverwriteRecord =+ action `returns` Right (Just "hoge")+ where+ action = do+ putNoResponse "foo" "bar"+ putNoResponse "foo" "hoge"+ get "foo"++caseOutRecord :: Assertion+caseOutRecord =+ action `returns` Right (Just "bar", Nothing)+ where+ action = do+ put "foo" "bar"+ put "hoge" "fuga"+ out "hoge"+ stored <- get "foo"+ unstored <- get "hoge"+ return (stored, unstored)++caseOutNoEffect :: Assertion+caseOutNoEffect =+ action `returns` Right ()+ where+ action = do+ out "hoge"++caseGetRecord :: Assertion+caseGetRecord =+ action `returns` Right (Just "bar", Nothing)+ where+ action = do+ put "foo" "bar"+ stored <- get "foo"+ unstored <- get "bar"+ return (stored, unstored)++caseMgetRecords :: Assertion+caseMgetRecords =+ action `returns` Right [ ("foo", "bar")+ , ("huga", "hoge")+ , ("abra", "cadabra")+ ]+ where+ action = do+ put "foo" "bar"+ put "huga" "hoge"+ put "abra" "cadabra"+ multipleGet [ "foo"+ , "huga"+ , "unstored"+ , "abra"+ ]++caseVsizRecord :: Assertion+caseVsizRecord =+ action `returns` Right (Just 3, Nothing)+ where+ action = do+ put "foo" "bar"+ stored <- valueSize "foo"+ unstored <- valueSize "bar"+ return (stored, unstored)++caseIterinit :: Assertion+caseIterinit =+ action `returns` Right True+ where+ action = do+ put "foo" "bar"+ put "fuga" "hoge"+ put "abra" "cadabra"+ iterInit+ key1 <- iterNext+ _ <- iterNext+ iterInit+ key2 <- iterNext+ return $ key1 == key2++caseIternext :: Assertion+caseIternext =+ action `returns` Right [ Just "abra", Just "foo", Just "fuga" ]+ where+ action = do+ put "foo" "bar"+ put "fuga" "hoge"+ put "abra" "cadabra"+ iterInit+ key1 <- iterNext+ key2 <- iterNext+ key3 <- iterNext+ return $ sort [key1, key2, key3]++caseIternextInvalid :: Assertion+caseIternextInvalid =+ action `returns` Right Nothing+ where+ action = do+ iterNext++caseFwmkeys :: Assertion+caseFwmkeys =+ action `returns` Right [ "abra", "abrac" ]+ where+ action = do+ put "abr" "acadabra"+ put "abra" "cadabra"+ put "abrac" "adabra"+ put "abraca" "dabra"+ sort <$> forwardMatchingKeys "abra" (Just 2)
− test/test.hs
@@ -1,281 +0,0 @@-{-# LANGUAGE OverloadedStrings #-}-import Database.Monarch-import qualified Database.Monarch.MessagePack as MsgPack--import Control.Applicative-import Data.List-import Data.ByteString.Char8 ()-import Test.HUnit-import Test.Hspec.Monadic-import Test.Hspec.HUnit ()--main :: IO ()-main = hspec $ do- describe "put" $ do- it "store a record" casePutRecord- it "overwrite a record if same key exists" casePutOverwriteRecord- describe "putkeep" $ do- it "store a new record" casePutKeepNewRecord- it "has no effect if same key exists" casePutKeepNoEffect- describe "putcat" $ do- it "concatenate a value at the end of the existing record" casePutCatRecord- it "store a new record if there is no corresponding record" casePutCatNewRecord- describe "putshl" $ do- it "concatenate a value at the end of the existing record and shift it to the left" casePutShlRecord- it "store a new record if there is no corresponding record" casePutShlNewRecord- describe "putnr" $ do- it "store a record" casePutNrRecord- it "overwrite a record if same key exists" casePutNrOverwriteRecord- describe "out" $ do- it "remove a record" caseOutRecord- it "no effect if same key not exists" caseOutNoEffect- describe "get" $ do- it "retrieve a record" caseGetRecord- describe "mget" $ do- it "retrieve records" caseMgetRecords- describe "vsiz" $ do- it "get the size of the value of a record" caseVsizRecord- describe "iterinit" $ do- it "initialize the iterator" caseIterinit- describe "iternext" $ do- it "get the next key of the iterator" caseIternext- it "invalid if end iterator" caseIternextInvalid- describe "fwmkeys" $ do- it "get forward matching keys" caseFwmkeys- describe "put MsgPackable" $ do- it "store a MessagePackable record" casePutMsgPackRecord- describe "putkeep MsgPackable" $ do- it "store a new MessagePackable record" casePutKeepNewMsgPackRecord- describe "putnr MsgPackable" $ do- it "store a record" casePutNrMsgPackRecord--returns :: (Eq a, Show a) =>- MonarchT IO a- -> Either Code a- -> IO ()-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 =- action `returns` Right (Just "bar")- where- action = do- put "foo" "bar"- get "foo"--casePutOverwriteRecord :: Assertion-casePutOverwriteRecord =- action `returns` Right (Just "hoge")- where- action = do- put "foo" "bar"- put "foo" "hoge"- get "foo"--casePutKeepNewRecord :: Assertion-casePutKeepNewRecord =- action `returns` Right (Just "hoge")- where- action = do- putKeep "foo" "hoge"- get "foo"--casePutKeepNoEffect :: Assertion-casePutKeepNoEffect =- action `returns` Right (Just "bar")- where- action = do- putKeep "foo" "bar"- putKeep "foo" "hoge"- get "foo"--casePutCatRecord :: Assertion-casePutCatRecord =- action `returns` Right (Just "abracadabra")- where- action = do- put "foo" "abra"- putCat "foo" "cadabra"- get "foo"--casePutCatNewRecord :: Assertion-casePutCatNewRecord =- action `returns` Right (Just "cadabra")- where- action = do- putCat "foo" "cadabra"- get "foo"--casePutShlRecord :: Assertion-casePutShlRecord =- action `returns` Right (Just "racadabra")- where- action = do- put "foo" "abra"- putShiftLeft "foo" "cadabra" 9- get "foo"--casePutShlNewRecord :: Assertion-casePutShlNewRecord =- action `returns` Right (Just "cadabra")- where- action = do- putShiftLeft "foo" "cadabra" 4- get "foo"--casePutNrRecord :: Assertion-casePutNrRecord =- action `returns` Right (Just "bar")- where- action = do- putNoResponse "foo" "bar"- get "foo"--casePutNrOverwriteRecord :: Assertion-casePutNrOverwriteRecord =- action `returns` Right (Just "hoge")- where- action = do- putNoResponse "foo" "bar"- putNoResponse "foo" "hoge"- get "foo"--caseOutRecord :: Assertion-caseOutRecord =- action `returns` Right (Just "bar", Nothing)- where- action = do- put "foo" "bar"- put "hoge" "fuga"- out "hoge"- stored <- get "foo"- unstored <- get "hoge"- return (stored, unstored)--caseOutNoEffect :: Assertion-caseOutNoEffect =- action `returns` Right ()- where- action = do- out "hoge"--caseGetRecord :: Assertion-caseGetRecord =- action `returns` Right (Just "bar", Nothing)- where- action = do- put "foo" "bar"- stored <- get "foo"- unstored <- get "bar"- return (stored, unstored)--caseMgetRecords :: Assertion-caseMgetRecords =- action `returns` Right [ ("foo", "bar")- , ("huga", "hoge")- , ("abra", "cadabra")- ]- where- action = do- put "foo" "bar"- put "huga" "hoge"- put "abra" "cadabra"- multipleGet [ "foo"- , "huga"- , "unstored"- , "abra"- ]--caseVsizRecord :: Assertion-caseVsizRecord =- action `returns` Right (Just 3, Nothing)- where- action = do- put "foo" "bar"- stored <- valueSize "foo"- unstored <- valueSize "bar"- return (stored, unstored)--caseIterinit :: Assertion-caseIterinit =- action `returns` Right True- where- action = do- put "foo" "bar"- put "fuga" "hoge"- put "abra" "cadabra"- iterInit- key1 <- iterNext- _ <- iterNext- iterInit- key2 <- iterNext- return $ key1 == key2--caseIternext :: Assertion-caseIternext =- action `returns` Right [ Just "abra", Just "foo", Just "fuga" ]- where- action = do- put "foo" "bar"- put "fuga" "hoge"- put "abra" "cadabra"- iterInit- key1 <- iterNext- key2 <- iterNext- key3 <- iterNext- return $ sort [key1, key2, key3]--caseIternextInvalid :: Assertion-caseIternextInvalid =- action `returns` Right Nothing- where- action = do- iterNext--caseFwmkeys :: Assertion-caseFwmkeys =- action `returns` Right [ "abra", "abrac" ]- where- action = do- put "abr" "acadabra"- put "abra" "cadabra"- put "abrac" "adabra"- put "abraca" "dabra"- sort <$> forwardMatchingKeys "abra" (Just 2)--casePutMsgPackRecord :: Assertion-casePutMsgPackRecord =- action `returns` Right (Just True)- where- action = do- MsgPack.put "foo" True- MsgPack.get "foo"--casePutKeepNewMsgPackRecord :: Assertion-casePutKeepNewMsgPackRecord =- action `returns` Right (Just [1,2,3::Int])- where- action = do- MsgPack.putKeep "foo" [1,2,3::Int]- MsgPack.get "foo"--casePutNrMsgPackRecord :: Assertion-casePutNrMsgPackRecord =- action `returns` Right (Just (10::Int, False, 0.5::Double))- where- action = do- MsgPack.putNoResponse "foo" (10::Int, False, 0.5::Double)- MsgPack.get "foo"