diff --git a/Database/Monarch.hs b/Database/Monarch.hs deleted file mode 100644 --- a/Database/Monarch.hs +++ /dev/null @@ -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 diff --git a/Database/Monarch/Binary.hs b/Database/Monarch/Binary.hs deleted file mode 100644 --- a/Database/Monarch/Binary.hs +++ /dev/null @@ -1,436 +0,0 @@ -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE OverloadedStrings #-} --- | TokyoTyrant Original Binary 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 diff --git a/Database/Monarch/Raw.hs b/Database/Monarch/Raw.hs deleted file mode 100644 --- a/Database/Monarch/Raw.hs +++ /dev/null @@ -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 diff --git a/Database/Monarch/Utils.hs b/Database/Monarch/Utils.hs deleted file mode 100644 --- a/Database/Monarch/Utils.hs +++ /dev/null @@ -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 diff --git a/monarch.cabal b/monarch.cabal --- a/monarch.cabal +++ b/monarch.cabal @@ -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 diff --git a/src/Database/Monarch.hs b/src/Database/Monarch.hs new file mode 100644 --- /dev/null +++ b/src/Database/Monarch.hs @@ -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 () diff --git a/src/Database/Monarch/Action.hs b/src/Database/Monarch/Action.hs new file mode 100644 --- /dev/null +++ b/src/Database/Monarch/Action.hs @@ -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(). +-- +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 diff --git a/src/Database/Monarch/Mock.hs b/src/Database/Monarch/Mock.hs new file mode 100644 --- /dev/null +++ b/src/Database/Monarch/Mock.hs @@ -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 () diff --git a/src/Database/Monarch/Mock/Action.hs b/src/Database/Monarch/Mock/Action.hs new file mode 100644 --- /dev/null +++ b/src/Database/Monarch/Mock/Action.hs @@ -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" diff --git a/src/Database/Monarch/Mock/Types.hs b/src/Database/Monarch/Mock/Types.hs new file mode 100644 --- /dev/null +++ b/src/Database/Monarch/Mock/Types.hs @@ -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) diff --git a/src/Database/Monarch/Types.hs b/src/Database/Monarch/Types.hs new file mode 100644 --- /dev/null +++ b/src/Database/Monarch/Types.hs @@ -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] diff --git a/src/Database/Monarch/Utils.hs b/src/Database/Monarch/Utils.hs new file mode 100644 --- /dev/null +++ b/src/Database/Monarch/Utils.hs @@ -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 diff --git a/test/Database/Monarch/ActionSpec.hs b/test/Database/Monarch/ActionSpec.hs new file mode 100644 --- /dev/null +++ b/test/Database/Monarch/ActionSpec.hs @@ -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) diff --git a/test/Database/Monarch/Mock/ActionSpec.hs b/test/Database/Monarch/Mock/ActionSpec.hs new file mode 100644 --- /dev/null +++ b/test/Database/Monarch/Mock/ActionSpec.hs @@ -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) diff --git a/test/Spec.hs b/test/Spec.hs new file mode 100644 --- /dev/null +++ b/test/Spec.hs @@ -0,0 +1,1 @@ +{-# OPTIONS_GHC -F -pgmF hspec-discover #-} diff --git a/test/benchmark.hs b/test/benchmark.hs --- a/test/benchmark.hs +++ b/test/benchmark.hs @@ -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 () diff --git a/test/doctests.hs b/test/doctests.hs --- a/test/doctests.hs +++ b/test/doctests.hs @@ -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" + ] diff --git a/test/specs.hs b/test/specs.hs deleted file mode 100644 --- a/test/specs.hs +++ /dev/null @@ -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)