monarch 0.8.1.3 → 0.9.0.0

raw patch · 18 files changed

+1686/−1157 lines, 18 filesdep +containersdep +monarchdep +stmdep −HUnitdep ~bytestringdep ~criteriondep ~doctestPVP ok

version bump matches the API change (PVP)

Dependencies added: containers, monarch, stm

Dependencies removed: HUnit

Dependency ranges changed: bytestring, criterion, doctest, hspec, lifted-base, network, tokyotyrant-haskell, transformers

API changes (from Hackage documentation)

Files

• Database/Monarch.hs +0/−30
• Database/Monarch/Binary.hs +0/−436
• Database/Monarch/Raw.hs +0/−176
• Database/Monarch/Utils.hs +0/−185
• monarch.cabal +29/−35
• src/Database/Monarch.hs +26/−0
• src/Database/Monarch/Action.hs +247/−0
• src/Database/Monarch/Mock.hs +19/−0
• src/Database/Monarch/Mock/Action.hs +166/−0
• src/Database/Monarch/Mock/Types.hs +79/−0
• src/Database/Monarch/Types.hs +333/−0
• src/Database/Monarch/Utils.hs +206/−0
• test/Database/Monarch/ActionSpec.hs +287/−0
• test/Database/Monarch/Mock/ActionSpec.hs +285/−0
• test/Spec.hs +1/−0
• test/benchmark.hs +4/−4
• test/doctests.hs +4/−3
• test/specs.hs +0/−288

@@ -1,30 +0,0 @@-{-# LANGUAGE GeneralizedNewtypeDeriving #-}--- | This module provide TokyoTyrant monadic access interface.----module Database.Monarch-    (-      Monarch, MonarchT-    , Connection, ConnectionPool-    , withMonarchConn-    , withMonarchPool-    , runMonarchConn-    , runMonarchPool-    , ExtOption(..), RestoreOption(..), MiscOption(..)-    , Code(..)-    , put, putKeep, putCat, putShiftLeft, multiplePut-    , putNoResponse-    , out, multipleOut-    , get, multipleGet-    , valueSize-    , iterInit, iterNext-    , forwardMatchingKeys-    , addInt, addDouble-    , ext, sync, optimize, vanish, copy, restore-    , setMaster-    , recordNum, size-    , status-    , misc-    ) where--import Database.Monarch.Raw hiding (sendLBS, recvLBS)-import Database.Monarch.Binary

@@ -1,436 +0,0 @@-{-# LANGUAGE FlexibleContexts #-}-{-# LANGUAGE OverloadedStrings #-}--- | TokyoTyrant Original Binary Protocol(<http://fallabs.com/tokyotyrant/spex.html#protocol>).-module Database.Monarch.Binary-    (-      put, putKeep, putCat, putShiftLeft, multiplePut-    , putNoResponse-    , out, multipleOut-    , get, multipleGet-    , valueSize-    , iterInit, iterNext-    , forwardMatchingKeys-    , addInt, addDouble-    , ext, sync, optimize, vanish, copy, restore-    , setMaster-    , recordNum, size-    , status-    , misc-    ) where--import Data.Int-import Data.Maybe-import qualified Data.Binary as B-import Data.Binary.Put (putWord32be, putByteString)-import Data.ByteString.Char8 hiding (length, copy, init, last)-import Control.Applicative-import Control.Monad-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 ) =>-       ByteString -- ^ key-    -> ByteString -- ^ value-    -> MonarchT m ()-put key value = communicate request response-    where-      request = do-        putMagic 0x10-        mapM_ (putWord32be . lengthBS32) [key, value]-        mapM_ putByteString [key, value]-      response Success = return ()-      response code = throwError code---- | Store records.---   If a record with the same key exists in the database,---   it is overwritten.-multiplePut :: ( MonadBaseControl IO m-               , MonadIO m ) =>-               [(ByteString,ByteString)] -- ^ key & value pairs-            -> MonarchT m ()-multiplePut [] = return ()-multiplePut kvs = void $ misc "putlist" [] (kvs >>= \(k,v)->[k,v])---- | 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 ) =>-           ByteString -- ^ key-        -> ByteString -- ^ value-        -> MonarchT m ()-putKeep key value = communicate request response-    where-      request = do-        putMagic 0x11-        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 ) =>-          ByteString -- ^ key-       -> ByteString -- ^ value-       -> MonarchT m ()-putCat key value = communicate request response-    where-      request = do-        putMagic 0x12-        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 ) =>-                ByteString -- ^ key-             -> ByteString -- ^ value-             -> Int  -- ^ width-             -> MonarchT m ()-putShiftLeft key value width = communicate request response-    where-      request = do-        putMagic 0x13-        mapM_ (putWord32be . lengthBS32) [key, value]-        putWord32be $ fromIntegral width-        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 ) =>-                 ByteString -- ^ key-              -> ByteString -- ^ value-              -> MonarchT m ()-putNoResponse key value = yieldRequest request-    where-      request = do-        putMagic 0x18-        mapM_ (putWord32be . lengthBS32) [key, value]-        mapM_ putByteString [key, value]---- | Remove a record.-out :: ( MonadBaseControl IO m-       , MonadIO m ) =>-       ByteString -- ^ key-    -> MonarchT m ()-out key = communicate request response-    where-      request = do-        putMagic 0x20-        putWord32be $ lengthBS32 key-        putByteString key-      response Success = return ()-      response InvalidOperation = return ()-      response code = throwError code---- | Remove records.-multipleOut :: ( MonadBaseControl IO m-               , MonadIO m ) =>-               [ByteString] -- ^ keys-            -> MonarchT m ()-multipleOut [] = return ()-multipleOut keys = void $ misc "outlist" [] keys---- | Retrieve a record.-get :: ( MonadBaseControl IO m-       , MonadIO m ) =>-       ByteString -- ^ key-    -> MonarchT m (Maybe ByteString)-get key = communicate request response-    where-      request = do-        putMagic 0x30-        putWord32be $ lengthBS32 key-        putByteString key-      response Success = Just <$> parseBS-      response InvalidOperation = return Nothing-      response code = throwError code---- | Retrieve records.-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-        mapM_ (\key -> do-                 putWord32be $ lengthBS32 key-                 putByteString key) keys-      response Success = do-          siz <- fromIntegral <$> parseWord32-          replicateM siz parseKeyValue-      response code = throwError code---- | Get the size of the value of a record.-valueSize :: ( MonadBaseControl IO m-             , MonadIO m ) =>-             ByteString -- ^ key-          -> MonarchT m (Maybe Int)-valueSize key = communicate request response-    where-      request = do-        putMagic 0x38-        putWord32be $ lengthBS32 key-        putByteString key-      response Success = Just . fromIntegral <$> parseWord32-      response InvalidOperation = return Nothing-      response code = throwError code---- | Initialize the iterator.-iterInit :: ( MonadBaseControl IO m-            , MonadIO m ) =>-            MonarchT m ()-iterInit = communicate request response-    where-      request = putMagic 0x50-      response Success = return ()-      response code = throwError code---- | 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 ) =>-            MonarchT m (Maybe ByteString)-iterNext = communicate request response-    where-      request = putMagic 0x51-      response Success = Just <$> parseBS-      response InvalidOperation = return Nothing-      response code = throwError code---- | Get forward matching keys.-forwardMatchingKeys :: ( MonadBaseControl IO m-                       , MonadIO m ) =>-                       ByteString -- ^ key prefix-                    -> Maybe Int -- ^ maximum number of keys to be fetched. 'Nothing' means unlimited.-                    -> MonarchT m [ByteString]-forwardMatchingKeys prefix n = communicate request response-    where-      request = do-        putMagic 0x58-        putWord32be $ lengthBS32 prefix-        putWord32be $ fromIntegral (fromMaybe (-1) n)-        putByteString prefix-      response Success = do-        siz <- fromIntegral <$> parseWord32-        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 ) =>-          ByteString -- ^ key-       -> Int -- ^ value-       -> MonarchT m Int-addInt key n = communicate request response-    where-      request = do-        putMagic 0x60-        putWord32be $ lengthBS32 key-        putWord32be $ fromIntegral n-        putByteString key-      response Success = fromIntegral <$> parseWord32-      response code = throwError code---- | 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 ) =>-             ByteString -- ^ key-          -> Double -- ^ value-          -> MonarchT m Double-addDouble key n = communicate request response-    where-      request = do-        putMagic 0x61-        putWord32be $ lengthBS32 key-        B.put (truncate n :: Int64)-        B.put (truncate (snd (properFraction n :: (Int,Double)) * 1e12) :: Int64)-        putByteString key-      response Success = parseDouble-      response code = throwError code---- | Call a function of the script language extension.-ext :: ( MonadBaseControl IO m-       , MonadIO m ) =>-       ByteString -- ^ function-    -> [ExtOption] -- ^ option flags-    -> ByteString -- ^ key-    -> ByteString -- ^ value-    -> MonarchT m ByteString-ext func opts key value = communicate request response-    where-      request = do-        putMagic 0x68-        putWord32be $ lengthBS32 func-        putOptions opts-        putWord32be $ lengthBS32 key-        putWord32be $ lengthBS32 value-        putByteString func-        putByteString key-        putByteString value-      response Success = parseBS-      response code = throwError code---- | Synchronize updated contents with the file and the device.-sync :: ( MonadBaseControl IO m-        , MonadIO m ) =>-        MonarchT m ()-sync = communicate request response-    where-      request = putMagic 0x70-      response Success = return ()-      response code = throwError code---- | Optimize the storage.-optimize :: ( MonadBaseControl IO m-            , MonadIO m ) =>-            ByteString -- ^ parameter-         -> MonarchT m ()-optimize param = communicate request response-    where-      request = do-        putMagic 0x71-        putWord32be $ lengthBS32 param-        putByteString param-      response Success = return ()-      response code = throwError code---- | Remove all records.-vanish :: ( MonadBaseControl IO m-          , MonadIO m ) =>-          MonarchT m ()-vanish = communicate request response-    where-      request = putMagic 0x72-      response Success = return ()-      response code = throwError code---- | Copy the database file.-copy :: ( MonadBaseControl IO m-        , MonadIO m ) =>-        ByteString -- ^ path-     -> MonarchT m ()-copy path = communicate request response-    where-      request = do-        putMagic 0x73-        putWord32be $ lengthBS32 path-        putByteString path-      response Success = return ()-      response code = throwError code---- | Restore the database file from the update log.-restore :: ( MonadBaseControl IO m-           , MonadIO m-           , Integral a ) =>-           ByteString -- ^ path-        -> a -- ^ beginning time stamp in microseconds-        -> [RestoreOption] -- ^ option flags-        -> MonarchT m ()-restore path usec opts = communicate request response-    where-      request = do-        putMagic 0x74-        putWord32be $ lengthBS32 path-        B.put (fromIntegral usec :: Int64)-        putOptions opts-        putByteString path-      response Success = return ()-      response code = throwError code---- | Set the replication master.-setMaster :: ( MonadBaseControl IO m-             , MonadIO m-             , Integral a ) =>-             ByteString -- ^ host-          -> Int -- ^ port-          -> a -- ^ beginning time stamp in microseconds-          -> [RestoreOption] -- ^ option flags-          -> MonarchT m ()-setMaster host port usec opts = communicate request response-    where-      request = do-        putMagic 0x78-        putWord32be $ lengthBS32 host-        putWord32be $ fromIntegral port-        B.put (fromIntegral usec :: Int64)-        putOptions opts-        putByteString host-      response Success = return ()-      response code = throwError code---- | Get the number of records.-recordNum :: ( MonadBaseControl IO m-             , MonadIO m ) =>-             MonarchT m Int64-recordNum = communicate request response-    where-      request = putMagic 0x80-      response Success = parseInt64-      response code = throwError code---- | Get the size of the database.-size :: ( MonadBaseControl IO m-        , MonadIO m ) =>-        MonarchT m Int64-size = communicate request response-    where-      request = putMagic 0x81-      response Success = parseInt64-      response code = throwError code---- | Get the status string of the database.-status :: ( MonadBaseControl IO m-          , MonadIO m ) =>-          MonarchT m ByteString-status = communicate request response-    where-      request = putMagic 0x88-      response Success = parseBS-      response code = throwError code---- | Call a versatile function for miscellaneous operations.-misc :: ( MonadBaseControl IO m-        , MonadIO m ) =>-        ByteString -- ^ function name-     -> [MiscOption] -- ^ option flags-     -> [ByteString] -- ^ arguments-     -> MonarchT m [ByteString]-misc func opts args = communicate request response-  where-    request = do-      putMagic 0x90-      putWord32be $ lengthBS32 func-      putOptions opts-      putWord32be . fromIntegral $ length args-      putByteString func-      mapM_ (\arg -> do-               putWord32be $ lengthBS32 arg-               putByteString arg) args-    response Success = do-      siz <- fromIntegral <$> parseWord32-      replicateM siz parseBS-    response code = throwError code

@@ -1,176 +0,0 @@-{-# LANGUAGE GeneralizedNewtypeDeriving #-}-{-# LANGUAGE FlexibleContexts #-}-{-# LANGUAGE FlexibleInstances #-}-{-# LANGUAGE UndecidableInstances #-}-{-# LANGUAGE MultiParamTypeClasses #-}-{-# LANGUAGE TypeFamilies #-}--- | Raw definitions.-module Database.Monarch.Raw-    (-      Monarch, MonarchT-    , Connection, ConnectionPool-    , withMonarchConn-    , withMonarchPool-    , runMonarchConn-    , runMonarchPool-    , ExtOption(..), RestoreOption(..), MiscOption(..)-    , Code(..)-    , sendLBS, recvLBS-    ) where--import Prelude hiding (catch)-import Data.Int-import Data.Conduit.Pool-import Control.Exception.Lifted-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 LBS-import qualified Data.ByteString.Lazy as LBS---- | 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---- | 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 base )--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-           -> MonarchT m a-           -> m (Either Code a)-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 ) =>-                   String -- ^ host-                -> Int -- ^ port-                -> (Connection -> m a)-                -> m a-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 ) =>-                   String -- ^ host-                -> Int -- ^ port-                -> Int -- ^ number of connections-                -> (ConnectionPool -> m a)-                -> m a-withMonarchPool host port size f =-    liftIO (createPool open' close' 1 20 size) >>= f-    where-      open' = getConnection host port-      close' = sClose . connection---- | Run action with a connection.-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 ) =>-                  MonarchT m a -- ^ action-               -> ConnectionPool -- ^ connection pool-               -> m (Either Code a)-runMonarchPool action pool =-    withResource pool $ flip runMonarch action--throwError' :: Monad m =>-               Code-            -> SomeException-            -> MonarchT m a-throwError' = const . throwError--sendLBS :: ( MonadBaseControl IO m-           , MonadIO m ) =>-           LBS.ByteString-        -> MonarchT m ()-sendLBS lbs = do-  conn <- connection <$> ask-  liftIO (LBS.sendAll conn lbs) `catch` throwError' SendError--recvLBS :: ( MonadBaseControl IO m-           , MonadIO m ) =>-           Int64-        -> MonarchT m LBS.ByteString-recvLBS n = do-  conn <- connection <$> ask-  lbs <- liftIO (LBS.recv conn n) `catch` throwError' ReceiveError-  if LBS.null lbs-    then throwError ReceiveError-    else if n == LBS.length lbs-           then return lbs-           else LBS.append lbs <$> recvLBS (n - LBS.length lbs)--getConnection :: HostName-              -> Int-              -> IO Connection-getConnection host port = do-  let hints = defaultHints { addrFlags = [ AI_ADDRCONFIG ]-                           , addrSocketType = Stream-                           }-  (addr:_) <- getAddrInfo (Just hints) (Just host) (Just $ show port)-  sock <- socket (addrFamily addr) (addrSocketType addr) (addrProtocol addr)-  let failConnect = (\e -> sClose sock >> throwIO e) :: SomeException -> IO ()-  connect sock (addrAddress addr) `catch` failConnect-  return $ Connection sock

@@ -1,185 +0,0 @@-{-# LANGUAGE FlexibleContexts #-}-module Database.Monarch.Utils-    (-      toCode-    , putMagic, putOptions-    , lengthBS32, lengthLBS32-    , fromLBS-    , yieldRequest-    , responseCode-    , parseLBS, parseBS-    , parseWord32, parseInt64, parseDouble-    , parseKeyValue-    , communicate-    ) where--import Data.Int-import Data.Bits-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.IO.Class-import Control.Monad.Trans.Control--import Database.Monarch.Raw--class BitFlag32 a where-    fromOption :: a -> Int32--instance BitFlag32 ExtOption where-    fromOption RecordLocking = 0x1-    fromOption GlobalLocking = 0x2--instance BitFlag32 RestoreOption where-    fromOption ConsistencyChecking = 0x1--instance BitFlag32 MiscOption where-    fromOption NoUpdateLog = 0x1--toCode :: Int -> Code-toCode 0 = Success-toCode 1 = InvalidOperation-toCode 2 = HostNotFound-toCode 3 = ConnectionRefused-toCode 4 = SendError-toCode 5 = ReceiveError-toCode 6 = ExistingRecord-toCode 7 = NoRecordFound-toCode 9999 = MiscellaneousError-toCode _ = error "Invalid Code"---- | 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 = sendLBS . runPut--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 = recvLBS 4 >>=-           recvLBS . fromIntegral . runGet getWord32be--parseBS :: ( MonadBaseControl IO m-           , MonadIO m ) =>-           MonarchT m BS.ByteString-parseBS = fromLBS <$> parseLBS--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 = runGet (B.get :: B.Get Int64) <$> recvLBS 8--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 = 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 :: ( MonadBaseControl IO m-               , MonadIO m) =>-               B.Put-            -> (Code -> MonarchT m a)-            -> MonarchT m a-communicate makeRequest makeResponse =-    yieldRequest makeRequest >>-    responseCode >>=-    makeResponse

@@ -1,5 +1,5 @@ name:                monarch-version:             0.8.1.3+version:             0.9.0.0 synopsis:            Monadic interface for TokyoTyrant. description:         This package provides simple monadic interface for TokyoTyrant. license:             BSD3@@ -10,7 +10,7 @@ build-type:          Simple cabal-version:       >=1.8 homepage:            https://github.com/notogawa/monarch-tested-with:         GHC ==7.4.2+tested-with:         GHC ==7.4.1, GHC ==7.6.3  source-repository head   type:                git@@ -21,69 +21,63 @@   default:             False  library+  hs-source-dirs:      src   exposed-modules:     Database.Monarch+                       Database.Monarch.Mock   other-modules:       Database.Monarch.Utils-                     , Database.Monarch.Raw-                     , Database.Monarch.Binary+                       Database.Monarch.Types+                       Database.Monarch.Action+                       Database.Monarch.Mock.Types+                       Database.Monarch.Mock.Action   ghc-options:         -Wall   build-depends:       base ==4.*                      , mtl ==2.1.*                      , transformers ==0.3.*-                     , bytestring ==0.9.*+                     , bytestring >=0.9 && <0.11                      , binary ==0.5.*                      , transformers ==0.3.*-                     , network ==2.3.*+                     , network >=2.3 && <2.5                      , pool-conduit ==0.1.*                      , monad-control ==0.3.*-                     , lifted-base ==0.1.*+                     , lifted-base >=0.1 && <0.3                      , transformers-base ==0.4.*+                     , containers >=0.4 && <0.6+                     , stm >=2.3 && <2.5  test-suite specs   if flag(develop)     buildable:         True   else     buildable:         False-  hs-source-dirs:      test, .+  hs-source-dirs:      test   type:                exitcode-stdio-1.0-  main-is:             specs.hs+  ghc-options:         -Wall -threaded+  main-is:             Spec.hs+  other-modules:       Database.Monarch.ActionSpec+                       Database.Monarch.Mock.ActionSpec   build-depends:       base ==4.*-                     , mtl ==2.1.*-                     , transformers ==0.3.*-                     , bytestring ==0.9.*-                     , binary ==0.5.*-                     , network ==2.3.*-                     , pool-conduit ==0.1.*-                     , monad-control ==0.3.*-                     , lifted-base ==0.1.*-                     , transformers-base ==0.4.*-                     , hspec ==1.3.*-                     , HUnit ==1.2.*+                     , monarch+                     , bytestring+                     , transformers+                     , hspec >=1.3  test-suite doctests-  hs-source-dirs:      test, .+  hs-source-dirs:      test   type:                exitcode-stdio-1.0   main-is:             doctests.hs   build-depends:       base ==4.*-                     , doctest ==0.8.*+                     , doctest  benchmark benchmark   if flag(develop)     buildable:         True   else     buildable:         False-  hs-source-dirs:      test, .+  hs-source-dirs:      test   type:                exitcode-stdio-1.0   main-is:             benchmark.hs   build-depends:       base ==4.*-                     , mtl ==2.1.*-                     , transformers ==0.3.*-                     , bytestring ==0.9.*-                     , binary ==0.5.*-                     , network ==2.3.*-                     , pool-conduit ==0.1.*-                     , monad-control ==0.3.*-                     , lifted-base ==0.1.*-                     , tokyotyrant-haskell ==1.0.*-                     , transformers ==0.3.*-                     , transformers-base ==0.4.*-                     , criterion ==0.6.*+                     , monarch+                     , tokyotyrant-haskell+                     , bytestring+                     , criterion

@@ -0,0 +1,26 @@+-- |+-- Module      : Database.Monarch+-- Copyright   : 2013 Noriyuki OHKAWA+-- License     : BSD3+--+-- Maintainer  : n.ohkawa@gmail.com+-- Stability   : experimental+-- Portability : unknown+--+-- Provide TokyoTyrant monadic access interface.+--+module Database.Monarch+    (+      Monarch, MonarchT+    , Connection, ConnectionPool+    , withMonarchConn+    , withMonarchPool+    , runMonarchConn+    , runMonarchPool+    , ExtOption(..), RestoreOption(..), MiscOption(..)+    , Code(..)+    , MonadMonarch(..)+    ) where++import Database.Monarch.Types hiding (sendLBS, recvLBS)+import Database.Monarch.Action ()

@@ -0,0 +1,247 @@+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE UndecidableInstances #-}+{-# OPTIONS_GHC -fno-warn-orphans #-}+-- |+-- Module      : Database.Monarch.Action+-- Copyright   : 2013 Noriyuki OHKAWA+-- License     : BSD3+--+-- Maintainer  : n.ohkawa@gmail.com+-- Stability   : experimental+-- Portability : unknown+--+-- TokyoTyrant Original Binary Protocol(<http://fallabs.com/tokyotyrant/spex.html#protocol>).+--+module Database.Monarch.Action () where++import Data.Int+import Data.Maybe+import qualified Data.Binary as B+import Data.Binary.Put (putWord32be, putByteString)+import Data.ByteString.Char8 ()+import Control.Applicative+import Control.Monad+import Control.Monad.Error+import Control.Monad.Trans.Control++import Database.Monarch.Types+import Database.Monarch.Utils++instance ( MonadBaseControl IO m, MonadIO m ) => MonadMonarch (MonarchT m) where++    put key value = communicate request response where+        request = do+          putMagic 0x10+          mapM_ (putWord32be . lengthBS32) [key, value]+          mapM_ putByteString [key, value]+        response Success = return ()+        response code = throwError code++    multiplePut [] = return ()+    multiplePut kvs = void $ misc "putlist" [] (kvs >>= \(k,v)->[k,v])++    putKeep key value = communicate request response where+        request = do+          putMagic 0x11+          mapM_ (putWord32be . lengthBS32) [key, value]+          mapM_ putByteString [key, value]+        response Success = return ()+        response InvalidOperation = return ()+        response code = throwError code++    putCat key value = communicate request response where+        request = do+          putMagic 0x12+          mapM_ (putWord32be . lengthBS32) [key, value]+          mapM_ putByteString [key, value]+        response Success = return ()+        response code = throwError code++    putShiftLeft key value width = communicate request response where+        request = do+          putMagic 0x13+          mapM_ (putWord32be . lengthBS32) [key, value]+          putWord32be $ fromIntegral width+          mapM_ putByteString [key, value]+        response Success = return ()+        response code = throwError code++    putNoResponse key value = yieldRequest request where+        request = do+          putMagic 0x18+          mapM_ (putWord32be . lengthBS32) [key, value]+          mapM_ putByteString [key, value]++    out key = communicate request response where+        request = do+          putMagic 0x20+          putWord32be $ lengthBS32 key+          putByteString key+        response Success = return ()+        response InvalidOperation = return ()+        response code = throwError code++    multipleOut [] = return ()+    multipleOut keys = void $ misc "outlist" [] keys++    get key = communicate request response where+        request = do+          putMagic 0x30+          putWord32be $ lengthBS32 key+          putByteString key+        response Success = Just <$> parseBS+        response InvalidOperation = return Nothing+        response code = throwError code++    multipleGet keys = communicate request response where+        request = do+          putMagic 0x31+          putWord32be . fromIntegral $ length keys+          mapM_ (\key -> do+                   putWord32be $ lengthBS32 key+                   putByteString key) keys+        response Success = do+            siz <- fromIntegral <$> parseWord32+            replicateM siz parseKeyValue+        response code = throwError code++    valueSize key = communicate request response where+        request = do+          putMagic 0x38+          putWord32be $ lengthBS32 key+          putByteString key+        response Success = Just . fromIntegral <$> parseWord32+        response InvalidOperation = return Nothing+        response code = throwError code++    iterInit = communicate request response where+        request = putMagic 0x50+        response Success = return ()+        response code = throwError code++    iterNext = communicate request response where+        request = putMagic 0x51+        response Success = Just <$> parseBS+        response InvalidOperation = return Nothing+        response code = throwError code++    forwardMatchingKeys prefix n = communicate request response where+        request = do+          putMagic 0x58+          putWord32be $ lengthBS32 prefix+          putWord32be $ fromIntegral (fromMaybe (-1) n)+          putByteString prefix+        response Success = do+          siz <- fromIntegral <$> parseWord32+          replicateM siz parseBS+        response code = throwError code++    addInt key n = communicate request response where+        request = do+          putMagic 0x60+          putWord32be $ lengthBS32 key+          putWord32be $ fromIntegral n+          putByteString key+        response Success = fromIntegral <$> parseWord32+        response code = throwError code++    addDouble key n = communicate request response where+        request = do+          putMagic 0x61+          putWord32be $ lengthBS32 key+          B.put (truncate n :: Int64)+          B.put (truncate (snd (properFraction n :: (Int,Double)) * 1e12) :: Int64)+          putByteString key+        response Success = parseDouble+        response code = throwError code++    ext func opts key value = communicate request response where+        request = do+          putMagic 0x68+          putWord32be $ lengthBS32 func+          putOptions opts+          putWord32be $ lengthBS32 key+          putWord32be $ lengthBS32 value+          putByteString func+          putByteString key+          putByteString value+        response Success = parseBS+        response code = throwError code++    sync = communicate request response where+        request = putMagic 0x70+        response Success = return ()+        response code = throwError code++    optimize param = communicate request response where+        request = do+          putMagic 0x71+          putWord32be $ lengthBS32 param+          putByteString param+        response Success = return ()+        response code = throwError code++    vanish = communicate request response where+        request = putMagic 0x72+        response Success = return ()+        response code = throwError code++    copy path = communicate request response where+        request = do+          putMagic 0x73+          putWord32be $ lengthBS32 path+          putByteString path+        response Success = return ()+        response code = throwError code++    restore path usec opts = communicate request response where+        request = do+          putMagic 0x74+          putWord32be $ lengthBS32 path+          B.put (fromIntegral usec :: Int64)+          putOptions opts+          putByteString path+        response Success = return ()+        response code = throwError code++    setMaster host port usec opts = communicate request response where+        request = do+          putMagic 0x78+          putWord32be $ lengthBS32 host+          putWord32be $ fromIntegral port+          B.put (fromIntegral usec :: Int64)+          putOptions opts+          putByteString host+        response Success = return ()+        response code = throwError code++    recordNum = communicate request response where+        request = putMagic 0x80+        response Success = parseInt64+        response code = throwError code++    size = communicate request response where+        request = putMagic 0x81+        response Success = parseInt64+        response code = throwError code++    status = communicate request response where+        request = putMagic 0x88+        response Success = parseBS+        response code = throwError code++    misc func opts args = communicate request response where+        request = do+          putMagic 0x90+          putWord32be $ lengthBS32 func+          putOptions opts+          putWord32be . fromIntegral $ length args+          putByteString func+          mapM_ (\arg -> do+                   putWord32be $ lengthBS32 arg+                   putByteString arg) args+        response Success = do+          siz <- fromIntegral <$> parseWord32+          replicateM siz parseBS+        response code = throwError code

@@ -0,0 +1,19 @@+-- |+-- Module      : Database.Monarch.Mock+-- Copyright   : 2013 Noriyuki OHKAWA+-- License     : BSD3+--+-- Maintainer  : n.ohkawa@gmail.com+-- Stability   : experimental+-- Portability : unknown+--+-- Provide TokyoTyrant mock.+--+module Database.Monarch.Mock+    ( MockT, MockDB+    , newMockDB+    , runMock+    ) where++import Database.Monarch.Mock.Types+import Database.Monarch.Mock.Action ()

@@ -0,0 +1,166 @@+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE UndecidableInstances #-}+{-# OPTIONS_GHC -fno-warn-orphans #-}+-- |+-- Module      : Database.Monarch.Mock.Types+-- Copyright   : 2013 Noriyuki OHKAWA+-- License     : BSD3+--+-- Maintainer  : n.ohkawa@gmail.com+-- Stability   : experimental+-- Portability : unknown+--+-- Mock actions.+--+module Database.Monarch.Mock.Action () where++import Control.Concurrent.STM.TVar+import Control.Monad.Reader+import Control.Monad.STM ( atomically )+import Control.Monad.Trans.Control+import Database.Monarch.Types ( MonadMonarch(..) )+import Database.Monarch.Mock.Types ( MockT, MockDB, mockDB, emptyMockDB, TTValue(..) )+import qualified Data.ByteString as BS+import qualified Data.Map as M+import Data.Map ( (!) )+import Data.Monoid ( (<>) )++putDB :: BS.ByteString -> TTValue -> MockDB -> MockDB+putDB key value db = db { mockDB = M.insert key value (mockDB db) }++putDBS :: BS.ByteString -> BS.ByteString -> MockDB -> MockDB+putDBS key value = putDB key (TTString value)++putDBI :: BS.ByteString -> Int -> MockDB -> MockDB+putDBI key value = putDB key (TTInt value)++putDBD :: BS.ByteString -> Double -> MockDB -> MockDB+putDBD key value = putDB key (TTDouble value)++getDB :: BS.ByteString -> MockDB -> Maybe BS.ByteString+getDB key db = M.lookup key (mockDB db) >>= \mvalue ->+               case mvalue of+                 TTString value -> return value+                 _              -> error "get"++instance ( MonadBaseControl IO m, MonadIO m ) => MonadMonarch (MockT m) where++    put key value = do+      tdb <- ask+      liftIO $ atomically $ modifyTVar tdb $ putDBS key value++    multiplePut = mapM_ (uncurry put)++    putKeep key value = do+      tdb <- ask+      let modify db+              | M.member key (mockDB db) = db+              | otherwise              = putDBS key value db+      liftIO $ atomically $ modifyTVar tdb modify++    putCat key value = do+      tdb <- ask+      let modify db+              | M.member key (mockDB db) =+                  case mockDB db ! key of+                    TTString v -> putDBS key (v <> value) db+                    _          -> error "putCat"+              | otherwise                =+                  putDBS key value db+      liftIO $ atomically $ modifyTVar tdb modify++    putShiftLeft key value width = do+      tdb <- ask+      let modify db+              | M.member key (mockDB db) =+                  case mockDB db ! key of+                    TTString v -> putDBS key (BS.drop (BS.length (v <> value) - width) $ v <> value) db+                    _          -> error "putShiftLeft"+              | otherwise              =+                  putDBS key value db+      liftIO $ atomically $ modifyTVar tdb modify++    putNoResponse = put++    out key = do+      tdb <- ask+      let modify db = db { mockDB = M.delete key (mockDB db) }+      liftIO $ atomically $ modifyTVar tdb modify++    multipleOut = mapM_ out++    get key = do+      tdb <- ask+      liftIO $ atomically $ fmap (getDB key) $ readTVar tdb++    multipleGet keys = do+      vs <- mapM (\k -> fmap (\v -> (k, v)) $ get k) keys+      return [ (k, v) | (k, Just v) <- vs]++    valueSize = fmap (fmap BS.length) . get++    iterInit = return ()++    iterNext = error "not implemented"++    forwardMatchingKeys prefix n = do+      tdb <- ask+      let readKeys db = filter (BS.isPrefixOf prefix) $ M.keys $ mockDB db+      ks <- liftIO $ atomically $ fmap readKeys $ readTVar tdb+      case n of+        Nothing -> return ks+        Just x -> return $ take x ks++    addInt key n = do+      tdb <- ask+      let modify db+              | M.member key (mockDB db) =+                  case mockDB db ! key of+                    TTInt x -> putDBI key (x + n) db+                    _       -> error "addInt"+              | otherwise                =+                  putDBI key n db+      let readDouble db = case mockDB db ! key of+                            TTInt x -> x+                            _       -> error "addInt"+      liftIO $ atomically $ modifyTVar tdb modify >> fmap readDouble (readTVar tdb)++    addDouble key n = do+      tdb <- ask+      let modify db+              | M.member key (mockDB db) =+                  case mockDB db ! key of+                    TTDouble x -> putDBD key (x + n) db+                    _          -> error "addDouble"+              | otherwise                =+                  putDBD key n db+      let readDouble db = case mockDB db ! key of+                            TTDouble x -> x+                            _          -> error "addDouble"+      liftIO $ atomically $ modifyTVar tdb modify >> fmap readDouble (readTVar tdb)++    ext _func _opts _key _value = error "not implemented"++    sync = error "not implemented"++    optimize _param = return ()++    vanish = do+      tdb <- ask+      liftIO $ atomically $ modifyTVar tdb $ const emptyMockDB++    copy _path = error "not implemented"++    restore _path _usec _opts = error "not implemented"++    setMaster _host _port _usec _opts = error "not implemented"++    recordNum = do+      tdb <- ask+      liftIO $ atomically $ fmap (toEnum . M.size . mockDB) $ readTVar tdb++    size = error "not implemented"++    status = error "not implemented"++    misc _func _opts _args = error "not implemented"

@@ -0,0 +1,79 @@+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE UndecidableInstances #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE TypeFamilies #-}+-- |+-- Module      : Database.Monarch.Mock.Types+-- Copyright   : 2013 Noriyuki OHKAWA+-- License     : BSD3+--+-- Maintainer  : n.ohkawa@gmail.com+-- Stability   : experimental+-- Portability : unknown+--+-- Type definitions.+--+module Database.Monarch.Mock.Types+    (+      MockT+    , MockDB, mockDB+    , newMockDB, emptyMockDB+    , runMock+    , TTValue(..)+    ) where++import Control.Concurrent.STM.TVar+import Control.Monad.Error+import Control.Monad.Reader+import Control.Monad.Base+import Control.Applicative+import Control.Monad.Trans.Control+import qualified Data.ByteString as BS+import qualified Data.Map as M++import Database.Monarch.Types ( Code )++-- | KVS Value type+data TTValue = TTString BS.ByteString+             | TTInt Int+             | TTDouble Double++-- | Connection with TokyoTyrant+data MockDB = MockDB { mockDB :: M.Map BS.ByteString TTValue -- ^ DB+                     }++-- | The Mock monad transformer to provide TokyoTyrant access.+newtype MockT m a =+    MockT { unMockT :: ErrorT Code (ReaderT (TVar MockDB) m) a }+    deriving ( Functor, Applicative, Monad, MonadIO+             , MonadReader (TVar MockDB), MonadError Code, MonadBase base )++instance MonadTrans MockT where+    lift = MockT . lift . lift++instance MonadTransControl MockT where+    newtype StT MockT a = StMock { unStMock :: Either Code a }+    liftWith f = MockT . ErrorT . ReaderT $ (\r -> liftM Right (f $ \t -> liftM StMock (runReaderT (runErrorT (unMockT t)) r)))+    restoreT = MockT . ErrorT . ReaderT . const . liftM unStMock++instance MonadBaseControl base m => MonadBaseControl base (MockT m) where+    newtype StM (MockT m) a = StMMockT { unStMMockT :: ComposeSt MockT m a }+    liftBaseWith = defaultLiftBaseWith StMMockT+    restoreM = defaultRestoreM unStMMockT++-- | Empty mock DB+emptyMockDB :: MockDB+emptyMockDB = MockDB { mockDB = M.empty }++-- | Create mock DB+newMockDB :: IO (TVar MockDB)+newMockDB = newTVarIO emptyMockDB++-- | Run Mock with TokyoTyrant at target host and port.+runMock :: MonadIO m =>+           MockT m a+        -> TVar MockDB+        -> m (Either Code a)+runMock action =+    runReaderT (runErrorT $ unMockT action)

@@ -0,0 +1,333 @@+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE UndecidableInstances #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE TypeFamilies #-}+-- |+-- Module      : Database.Monarch.Types+-- Copyright   : 2013 Noriyuki OHKAWA+-- License     : BSD3+--+-- Maintainer  : n.ohkawa@gmail.com+-- Stability   : experimental+-- Portability : unknown+--+-- Type definitions.+--+module Database.Monarch.Types+    (+      Monarch, MonarchT+    , Connection, ConnectionPool+    , withMonarchConn+    , withMonarchPool+    , runMonarchConn+    , runMonarchPool+    , ExtOption(..), RestoreOption(..), MiscOption(..)+    , Code(..)+    , sendLBS, recvLBS+    , MonadMonarch(..)+    ) where++import Prelude hiding (catch)+import Data.Int+import Data.Conduit.Pool+import Control.Exception.Lifted+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 LBS+import qualified Data.ByteString.Lazy as LBS+import qualified Data.ByteString as BS++-- | 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++-- | 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 base )++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++-- | IO Specialized+type Monarch = MonarchT IO++-- | Run Monarch with TokyoTyrant at target host and port.+runMonarch :: MonadIO m =>+              Connection+           -> MonarchT m a+           -> m (Either Code a)+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 ) =>+                   String -- ^ host+                -> Int -- ^ port+                -> (Connection -> m a)+                -> m a+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 ) =>+                   String -- ^ host+                -> Int -- ^ port+                -> Int -- ^ number of connections+                -> (ConnectionPool -> m a)+                -> m a+withMonarchPool host port connections f =+    liftIO (createPool open' close' 1 20 connections) >>= f+    where+      open' = getConnection host port+      close' = sClose . connection++-- | Run action with a connection.+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 ) =>+                  MonarchT m a -- ^ action+               -> ConnectionPool -- ^ connection pool+               -> m (Either Code a)+runMonarchPool action pool =+    withResource pool $ flip runMonarch action++throwError' :: Monad m =>+             Code+          -> SomeException+          -> MonarchT m a+throwError' = const . throwError++-- | Send.+sendLBS :: ( MonadBaseControl IO m+           , MonadIO m ) =>+           LBS.ByteString+        -> MonarchT m ()+sendLBS lbs = do+  conn <- connection <$> ask+  liftIO (LBS.sendAll conn lbs) `catch` throwError' SendError++-- | Receive.+recvLBS :: ( MonadBaseControl IO m+           , MonadIO m ) =>+           Int64+        -> MonarchT m LBS.ByteString+recvLBS n = do+  conn <- connection <$> ask+  lbs <- liftIO (LBS.recv conn n) `catch` throwError' ReceiveError+  if LBS.null lbs+    then throwError ReceiveError+    else if n == LBS.length lbs+           then return lbs+           else LBS.append lbs <$> recvLBS (n - LBS.length lbs)++-- | Make connection from host and port.+getConnection :: HostName+              -> Int+              -> IO Connection+getConnection host port = do+  let hints = defaultHints { addrFlags = [ AI_ADDRCONFIG ]+                           , addrSocketType = Stream+                           }+  (addr:_) <- getAddrInfo (Just hints) (Just host) (Just $ show port)+  sock <- socket (addrFamily addr) (addrSocketType addr) (addrProtocol addr)+  let failConnect = (\e -> sClose sock >> throwIO e) :: SomeException -> IO ()+  connect sock (addrAddress addr) `catch` failConnect+  return $ Connection sock++-- | Monad Monarch interfaces+class MonadMonarch m where++  -- | Store a record.+  --   If a record with the same key exists in the database,+  --   it is overwritten.+  put :: BS.ByteString -- ^ key+      -> BS.ByteString -- ^ value+      -> m ()++  -- | Store records.+  --   If a record with the same key exists in the database,+  --   it is overwritten.+  multiplePut :: [(BS.ByteString,BS.ByteString)] -- ^ key & value pairs+              -> m ()++  -- | Store a new record.+  --   If a record with the same key exists in the database,+  --   this function has no effect.+  putKeep :: BS.ByteString -- ^ key+          -> BS.ByteString -- ^ value+          -> m ()++  -- | Concatenate a value at the end of the existing record.+  --   If there is no corresponding record, a new record is created.+  putCat :: BS.ByteString -- ^ key+         -> BS.ByteString -- ^ value+         -> m ()++  -- | 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 :: BS.ByteString -- ^ key+               -> BS.ByteString -- ^ value+               -> Int  -- ^ width+               -> m ()++  -- | Store a record without response.+  --   If a record with the same key exists in the database, it is overwritten.+  putNoResponse :: BS.ByteString -- ^ key+                -> BS.ByteString -- ^ value+                -> m ()++  -- | Remove a record.+  out :: ( MonadBaseControl IO m+         , MonadIO m ) =>+         BS.ByteString -- ^ key+      -> m ()++  -- | Remove records.+  multipleOut :: [BS.ByteString] -- ^ keys+              -> m ()++  -- | Retrieve a record.+  get :: BS.ByteString -- ^ key+      -> m (Maybe BS.ByteString)++  -- | Retrieve records.+  multipleGet :: [BS.ByteString] -- ^ keys+              -> m [(BS.ByteString, BS.ByteString)]++  -- | Get the size of the value of a record.+  valueSize :: BS.ByteString -- ^ key+            -> m (Maybe Int)++  -- | Initialize the iterator.+  iterInit :: m ()++  -- | 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 :: m (Maybe BS.ByteString)++  -- | Get forward matching keys.+  forwardMatchingKeys :: BS.ByteString -- ^ key prefix+                      -> Maybe Int -- ^ maximum number of keys to be fetched. 'Nothing' means unlimited.+                      -> m [BS.ByteString]++  -- | 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 :: BS.ByteString -- ^ key+         -> Int -- ^ value+         -> m Int++  -- | 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 :: BS.ByteString -- ^ key+            -> Double -- ^ value+            -> m Double++  -- | Call a function of the script language extension.+  ext :: BS.ByteString -- ^ function+      -> [ExtOption] -- ^ option flags+      -> BS.ByteString -- ^ key+      -> BS.ByteString -- ^ value+      -> m BS.ByteString++  -- | Synchronize updated contents with the file and the device.+  sync :: m ()++  -- | Optimize the storage.+  optimize :: BS.ByteString -- ^ parameter+           -> m ()++  -- | Remove all records.+  vanish :: m ()++  -- | Copy the database file.+  copy :: BS.ByteString -- ^ path+       -> m ()++  -- | Restore the database file from the update log.+  restore :: ( Integral a ) =>+             BS.ByteString -- ^ path+          -> a -- ^ beginning time stamp in microseconds+          -> [RestoreOption] -- ^ option flags+          -> m ()++  -- | Set the replication master.+  setMaster :: ( Integral a ) =>+               BS.ByteString -- ^ host+            -> Int -- ^ port+            -> a -- ^ beginning time stamp in microseconds+            -> [RestoreOption] -- ^ option flags+            -> m ()++  -- | Get the number of records.+  recordNum :: m Int64++  -- | Get the size of the database.+  size :: m Int64++  -- | Get the status string of the database.+  status :: m BS.ByteString++  -- | Call a versatile function for miscellaneous operations.+  misc :: BS.ByteString -- ^ function name+       -> [MiscOption] -- ^ option flags+       -> [BS.ByteString] -- ^ arguments+       -> m [BS.ByteString]

@@ -0,0 +1,206 @@+{-# LANGUAGE FlexibleContexts #-}+-- |+-- Module      : Database.Monarch.Utils+-- Copyright   : 2013 Noriyuki OHKAWA+-- License     : BSD3+--+-- Maintainer  : n.ohkawa@gmail.com+-- Stability   : experimental+-- Portability : unknown+--+-- Internal utilities.+--+module Database.Monarch.Utils+    (+      toCode+    , putMagic, putOptions+    , lengthBS32, lengthLBS32+    , fromLBS+    , yieldRequest+    , responseCode+    , parseLBS, parseBS+    , parseWord32, parseInt64, parseDouble+    , parseKeyValue+    , communicate+    ) where++import Data.Int+import Data.Bits+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.IO.Class+import Control.Monad.Trans.Control++import Database.Monarch.Types++class BitFlag32 a where+    fromOption :: a -> Int32++instance BitFlag32 ExtOption where+    fromOption RecordLocking = 0x1+    fromOption GlobalLocking = 0x2++instance BitFlag32 RestoreOption where+    fromOption ConsistencyChecking = 0x1++instance BitFlag32 MiscOption where+    fromOption NoUpdateLog = 0x1++-- | Convert status code+toCode :: Int -> Code+toCode 0 = Success+toCode 1 = InvalidOperation+toCode 2 = HostNotFound+toCode 3 = ConnectionRefused+toCode 4 = SendError+toCode 5 = ReceiveError+toCode 6 = ExistingRecord+toCode 7 = NoRecordFound+toCode 9999 = MiscellaneousError+toCode _ = error "Invalid Code"++-- | 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++-- | Send request.+yieldRequest :: ( MonadBaseControl IO m+                , MonadIO m ) =>+                B.Put+             -> MonarchT m ()+yieldRequest = sendLBS . runPut++-- | Receive response code.+responseCode :: ( MonadBaseControl IO m+                , MonadIO m ) =>+                MonarchT m Code+responseCode = toCode . fromIntegral . runGet B.getWord8 <$> recvLBS 1++-- | Parse byte string (lazy) value.+parseLBS :: ( MonadBaseControl IO m+            , MonadIO m ) =>+            MonarchT m LBS.ByteString+parseLBS = recvLBS 4 >>=+           recvLBS . fromIntegral . runGet getWord32be++-- | Parse byte string (strict) value.+parseBS :: ( MonadBaseControl IO m+           , MonadIO m ) =>+           MonarchT m BS.ByteString+parseBS = fromLBS <$> parseLBS++-- | Parse Word32 value.+parseWord32 :: ( MonadBaseControl IO m+               , MonadIO m ) =>+               MonarchT m B.Word32+parseWord32 = runGet getWord32be <$> recvLBS 4++-- | Parse Int64 value.+parseInt64 :: ( MonadBaseControl IO m+              , MonadIO m ) =>+              MonarchT m Int64+parseInt64 = runGet (B.get :: B.Get Int64) <$> recvLBS 8++-- | Parse Double value.+parseDouble :: ( MonadBaseControl IO m+               , MonadIO m ) =>+               MonarchT m Double+parseDouble = do+  integ <- fromIntegral <$> parseInt64+  fract <- fromIntegral <$> parseInt64+  return $ integ + fract * 1e-12++-- | Parse key value pair.+parseKeyValue :: ( MonadBaseControl IO m+                 , MonadIO m ) =>+                 MonarchT m (BS.ByteString, BS.ByteString)+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)++-- | Make a query.+communicate :: ( MonadBaseControl IO m+               , MonadIO m) =>+               B.Put+            -> (Code -> MonarchT m a)+            -> MonarchT m a+communicate makeRequest makeResponse =+    yieldRequest makeRequest >>+    responseCode >>=+    makeResponse

@@ -0,0 +1,287 @@+{-# LANGUAGE OverloadedStrings #-}+module Database.Monarch.ActionSpec ( spec ) where++import Control.Applicative+import Control.Monad.IO.Class+import Data.List+import qualified Data.ByteString as BS+import Data.ByteString.Char8 ()+import Test.Hspec+import Database.Monarch++spec :: Spec+spec = do+  describe "put" $ do+    it "store a record" casePutRecord+    it "overwrite a record if same key exists" casePutOverwriteRecord+  describe "mput" $ do+    it "store records" caseMputRecords+  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 "mout" $ do+    it "remove records" caseMoutRecords+  describe "get" $ do+    it "retrieve a record" caseGetRecord+    it "retrieve large record" caseGetLargeRecord+  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 "127.0.0.1" 1978 $ runMonarchConn $ do+                            vanish+                            result <- action+                            vanish+                            return result+                result `shouldBe` expected+  poolTest = do result <- withMonarchPool "127.0.0.1" 1978 20 $ runMonarchPool $ do+                            vanish+                            result <- action+                            vanish+                            return result+                result `shouldBe` expected++casePutRecord :: IO ()+casePutRecord =+    action `returns` Right (Just "bar")+    where+      action = do+        put "foo" "bar"+        get "foo"++casePutOverwriteRecord :: IO ()+casePutOverwriteRecord =+    action `returns` Right (Just "hoge")+    where+      action = do+        put "foo" "bar"+        put "foo" "hoge"+        get "foo"++caseMputRecords :: IO ()+caseMputRecords =+    action `returns` Right (Just "bob", Just "bar")+    where+      action = do+        multiplePut [("foo","bar"),("alice","bob")]+        bob <- get "alice"+        bar <- get "foo"+        return (bob, bar)++casePutKeepNewRecord :: IO ()+casePutKeepNewRecord =+    action `returns` Right (Just "hoge")+    where+      action = do+        putKeep "foo" "hoge"+        get "foo"++casePutKeepNoEffect :: IO ()+casePutKeepNoEffect =+    action `returns` Right (Just "bar")+    where+      action = do+        putKeep "foo" "bar"+        putKeep "foo" "hoge"+        get "foo"++casePutCatRecord :: IO ()+casePutCatRecord =+    action `returns` Right (Just "abracadabra")+    where+      action = do+        put "foo" "abra"+        putCat "foo" "cadabra"+        get "foo"++casePutCatNewRecord :: IO ()+casePutCatNewRecord =+    action `returns` Right (Just "cadabra")+    where+      action = do+        putCat "foo" "cadabra"+        get "foo"++casePutShlRecord :: IO ()+casePutShlRecord =+    action `returns` Right (Just "racadabra")+    where+      action = do+        put "foo" "abra"+        putShiftLeft "foo" "cadabra" 9+        get "foo"++casePutShlNewRecord :: IO ()+casePutShlNewRecord =+    action `returns` Right (Just "cadabra")+    where+      action = do+        putShiftLeft "foo" "cadabra" 4+        get "foo"++casePutNrRecord :: IO ()+casePutNrRecord =+    action `returns` Right (Just "bar")+    where+      action = do+        putNoResponse "foo" "bar"+        get "foo"++casePutNrOverwriteRecord :: IO ()+casePutNrOverwriteRecord =+    action `returns` Right (Just "hoge")+    where+      action = do+        putNoResponse "foo" "bar"+        putNoResponse "foo" "hoge"+        get "foo"++caseOutRecord :: IO ()+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 :: IO ()+caseOutNoEffect =+    action `returns` Right ()+    where+      action = do+        out "hoge"++caseMoutRecords :: IO ()+caseMoutRecords =+    action `returns` Right (Nothing, Nothing)+    where+      action = do+        put "foo" "bar"+        put "hoge" "fuga"+        multipleOut ["foo", "hoge"]+        bar <- get "foo"+        fuga <- get "hoge"+        return (bar, fuga)++caseGetRecord :: IO ()+caseGetRecord =+    action `returns` Right (Just "bar", Nothing)+    where+      action = do+        put "foo" "bar"+        stored <- get "foo"+        unstored <- get "bar"+        return (stored, unstored)++caseGetLargeRecord :: IO ()+caseGetLargeRecord = do+  content <- BS.concat . replicate 1024 <$> liftIO (BS.readFile "monarch.cabal")+  action content `returns` Right (Just content)+    where+      action content = do+        put "foo" content+        get "foo"++caseMgetRecords :: IO ()+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 :: IO ()+caseVsizRecord =+    action `returns` Right (Just 3, Nothing)+    where+      action = do+        put "foo" "bar"+        stored <- valueSize "foo"+        unstored <- valueSize "bar"+        return (stored, unstored)++caseIterinit :: IO ()+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 :: IO ()+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 :: IO ()+caseIternextInvalid =+    action `returns` Right Nothing+    where+      action = do+        iterNext++caseFwmkeys :: IO ()+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)

@@ -0,0 +1,285 @@+{-# LANGUAGE OverloadedStrings #-}+module Database.Monarch.Mock.ActionSpec ( spec ) where++import Control.Applicative+import Control.Monad.IO.Class+import Data.List+import qualified Data.ByteString as BS+import Data.ByteString.Char8 ()+import Test.Hspec+import Database.Monarch+import Database.Monarch.Mock++spec :: Spec+spec = do+  describe "put" $ do+    it "store a record" casePutRecord+    it "overwrite a record if same key exists" casePutOverwriteRecord+  describe "mput" $ do+    it "store records" caseMputRecords+  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 "mout" $ do+    it "remove records" caseMoutRecords+  describe "get" $ do+    it "retrieve a record" caseGetRecord+    it "retrieve large record" caseGetLargeRecord+  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) =>+           MockT IO a+        -> Either Code a+        -> IO ()+action `returns` expected = mockTest+  where+  mockTest = do+    mdb <- newMockDB+    result <- runMock (do+                        vanish+                        result <- action+                        vanish+                        return result+                      ) mdb+    result `shouldBe` expected++casePutRecord :: IO ()+casePutRecord =+    action `returns` Right (Just "bar")+    where+      action = do+        put "foo" "bar"+        get "foo"++casePutOverwriteRecord :: IO ()+casePutOverwriteRecord =+    action `returns` Right (Just "hoge")+    where+      action = do+        put "foo" "bar"+        put "foo" "hoge"+        get "foo"++caseMputRecords :: IO ()+caseMputRecords =+    action `returns` Right (Just "bob", Just "bar")+    where+      action = do+        multiplePut [("foo","bar"),("alice","bob")]+        bob <- get "alice"+        bar <- get "foo"+        return (bob, bar)++casePutKeepNewRecord :: IO ()+casePutKeepNewRecord =+    action `returns` Right (Just "hoge")+    where+      action = do+        putKeep "foo" "hoge"+        get "foo"++casePutKeepNoEffect :: IO ()+casePutKeepNoEffect =+    action `returns` Right (Just "bar")+    where+      action = do+        putKeep "foo" "bar"+        putKeep "foo" "hoge"+        get "foo"++casePutCatRecord :: IO ()+casePutCatRecord =+    action `returns` Right (Just "abracadabra")+    where+      action = do+        put "foo" "abra"+        putCat "foo" "cadabra"+        get "foo"++casePutCatNewRecord :: IO ()+casePutCatNewRecord =+    action `returns` Right (Just "cadabra")+    where+      action = do+        putCat "foo" "cadabra"+        get "foo"++casePutShlRecord :: IO ()+casePutShlRecord =+    action `returns` Right (Just "racadabra")+    where+      action = do+        put "foo" "abra"+        putShiftLeft "foo" "cadabra" 9+        get "foo"++casePutShlNewRecord :: IO ()+casePutShlNewRecord =+    action `returns` Right (Just "cadabra")+    where+      action = do+        putShiftLeft "foo" "cadabra" 4+        get "foo"++casePutNrRecord :: IO ()+casePutNrRecord =+    action `returns` Right (Just "bar")+    where+      action = do+        putNoResponse "foo" "bar"+        get "foo"++casePutNrOverwriteRecord :: IO ()+casePutNrOverwriteRecord =+    action `returns` Right (Just "hoge")+    where+      action = do+        putNoResponse "foo" "bar"+        putNoResponse "foo" "hoge"+        get "foo"++caseOutRecord :: IO ()+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 :: IO ()+caseOutNoEffect =+    action `returns` Right ()+    where+      action = do+        out "hoge"++caseMoutRecords :: IO ()+caseMoutRecords =+    action `returns` Right (Nothing, Nothing)+    where+      action = do+        put "foo" "bar"+        put "hoge" "fuga"+        multipleOut ["foo", "hoge"]+        bar <- get "foo"+        fuga <- get "hoge"+        return (bar, fuga)++caseGetRecord :: IO ()+caseGetRecord =+    action `returns` Right (Just "bar", Nothing)+    where+      action = do+        put "foo" "bar"+        stored <- get "foo"+        unstored <- get "bar"+        return (stored, unstored)++caseGetLargeRecord :: IO ()+caseGetLargeRecord = do+  content <- BS.concat . replicate 1024 <$> liftIO (BS.readFile "monarch.cabal")+  action content `returns` Right (Just content)+    where+      action content = do+        put "foo" content+        get "foo"++caseMgetRecords :: IO ()+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 :: IO ()+caseVsizRecord =+    action `returns` Right (Just 3, Nothing)+    where+      action = do+        put "foo" "bar"+        stored <- valueSize "foo"+        unstored <- valueSize "bar"+        return (stored, unstored)++_caseIterinit :: IO ()+_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 :: IO ()+_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 :: IO ()+_caseIternextInvalid =+    action `returns` Right Nothing+    where+      action = do+        iterNext++caseFwmkeys :: IO ()+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)

@@ -0,0 +1,1 @@+{-# OPTIONS_GHC -F -pgmF hspec-discover #-}

@@ -21,25 +21,25 @@  ffi :: IO () ffi = do-  Right conn <- FFI.open "localhost" 1978+  Right conn <- FFI.open "127.0.0.1" 1978   FFI.put conn "foo" "bar"   FFI.close conn  mffi :: IO () mffi = do-  Right conn <- FFI.open "localhost" 1978+  Right conn <- FFI.open "127.0.0.1" 1978   FFI.mput conn $ replicate size ("foo", "bar")   FFI.close conn  monarch :: IO () monarch = do-  Right () <- Monarch.withMonarchConn "localhost" 1978 $+  Right () <- Monarch.withMonarchConn "127.0.0.1" 1978 $               Monarch.runMonarchConn $               Monarch.put "foo" "bar"   return ()  mmonarch :: IO () mmonarch = do-  Right () <- Monarch.withMonarchConn "localhost" 1978 $ Monarch.runMonarchConn $+  Right () <- Monarch.withMonarchConn "127.0.0.1" 1978 $ Monarch.runMonarchConn $          Monarch.multiplePut $ replicate size ("foo", "bar")   return ()

@@ -1,6 +1,7 @@ import Test.DocTest  main :: IO ()-main = doctest [ "-Lcabal-dev/lib"-               , "-package-conf=cabal-dev/packages-7.4.2.conf"-               , "Database/Monarch/Utils.hs" ]+main = doctest [ "-isrc"+               , "-ignore-package", "monads-tf"+               , "Database.Monarch.Utils"+               ]

@@ -1,288 +0,0 @@-{-# LANGUAGE OverloadedStrings #-}-import Database.Monarch--import Control.Applicative-import Control.Monad.IO.Class-import Data.List-import qualified Data.ByteString as BS-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 "mput" $ do-           it "store records" caseMputRecords-         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 "mout" $ do-           it "remove records" caseMoutRecords-         describe "get" $ do-           it "retrieve a record" caseGetRecord-           it "retrieve large record" caseGetLargeRecord-         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"--caseMputRecords :: Assertion-caseMputRecords =-    action `returns` Right (Just "bob", Just "bar")-    where-      action = do-        multiplePut [("foo","bar"),("alice","bob")]-        bob <- get "alice"-        bar <- get "foo"-        return (bob, bar)--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"--caseMoutRecords :: Assertion-caseMoutRecords =-    action `returns` Right (Nothing, Nothing)-    where-      action = do-        put "foo" "bar"-        put "hoge" "fuga"-        multipleOut ["foo", "hoge"]-        bar <- get "foo"-        fuga <- get "hoge"-        return (bar, fuga)--caseGetRecord :: Assertion-caseGetRecord =-    action `returns` Right (Just "bar", Nothing)-    where-      action = do-        put "foo" "bar"-        stored <- get "foo"-        unstored <- get "bar"-        return (stored, unstored)--caseGetLargeRecord :: Assertion-caseGetLargeRecord = do-  content <- BS.concat . replicate 1024 <$> liftIO (BS.readFile "test/specs.hs")-  action content `returns` Right (Just content)-    where-      action content = do-        put "foo" content-        get "foo"--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)