diff --git a/Benchmark.hs b/Benchmark.hs new file mode 100644 index 0000000..a299ad7 --- /dev/null +++ b/Benchmark.hs @@ -0,0 +1,26 @@ +import Criterion.Main + +import Control.Monad (forM_, void) +import qualified Database.MongoDB as M +import Data.Bson (Document, Field(..), Label, Val, Value(String, Doc, Bool), + Javascript, at, valueAt, lookup, look, genObjectId, (=:), + (=?)) + +import Database.MongoDB.Query + +import qualified Data.Text as T + +main = defaultMain [ + bgroup "insert" [ bench "100" $ nfIO doInserts ] + ] + +doInserts = do + let docs = (flip map) [0..100] $ \i -> + ["name" M.=: (T.pack $ "name " ++ (show i))] + + pipe <- M.connect (M.host "127.0.0.1") + + forM_ docs $ \doc -> do + void $ M.access pipe M.master "mongodb-haskell-test" $ M.insert "bigCollection" doc + + M.close pipe diff --git a/CHANGELOG.md b/CHANGELOG.md index d7c7b0c..394a22a 100644 --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -2,6 +2,11 @@ All notable changes to this project will be documented in this file. This project adheres to [Package Versioning Policy](https://wiki.haskell.org/Package_versioning_policy). +## [Unreleased] - unreleased + +### Fixed +- Slow requests to the database server. + ## [2.0.6] - 2015-08-02 ### Added diff --git a/Database/MongoDB/Internal/Connection.hs b/Database/MongoDB/Internal/Connection.hs index ddb23f8..d921941 100644 --- a/Database/MongoDB/Internal/Connection.hs +++ b/Database/MongoDB/Internal/Connection.hs @@ -5,7 +5,6 @@ module Database.MongoDB.Internal.Connection ( Connection(..), readExactly, - writeLazy, fromHandle, ) where @@ -52,9 +51,6 @@ readExactly conn count = go mempty count eof = mkIOError eofErrorType "Database.MongoDB.Internal.Connection" Nothing Nothing -writeLazy :: Connection -> Lazy.ByteString -> IO () -writeLazy conn = mapM_ (write conn) . Lazy.ByteString.toChunks - fromHandle :: Handle -> IO Connection -- ^ Make connection form handle fromHandle handle = do diff --git a/Database/MongoDB/Internal/Protocol.hs b/Database/MongoDB/Internal/Protocol.hs index a5f389b..53db3be 100644 --- a/Database/MongoDB/Internal/Protocol.hs +++ b/Database/MongoDB/Internal/Protocol.hs @@ -26,7 +26,7 @@ module Database.MongoDB.Internal.Protocol ( import Control.Applicative ((<$>)) #endif import Control.Arrow ((***)) -import Control.Monad (forM_, replicateM, unless) +import Control.Monad (forM, replicateM, unless) import Data.Binary.Get (Get, runGet) import Data.Binary.Put (Put, runPut) import Data.Bits (bit, testBit) @@ -34,6 +34,7 @@ import Data.Int (Int32, Int64) import Data.IORef (IORef, newIORef, atomicModifyIORef) import System.IO (Handle) import System.IO.Unsafe (unsafePerformIO) +import Data.Maybe (maybeToList) import qualified Data.ByteString.Lazy as L @@ -93,16 +94,20 @@ type Message = ([Notice], Maybe (Request, RequestId)) writeMessage :: Connection -> Message -> IO () -- ^ Write message to connection writeMessage conn (notices, mRequest) = do - forM_ notices $ \n -> writeReq . (Left n,) =<< genRequestId - whenJust mRequest $ writeReq . (Right *** id) + noticeStrings <- forM notices $ \n -> do + requestId <- genRequestId + let s = runPut $ putNotice n requestId + return $ (lenBytes s) `L.append` s + + let requestString = do + (request, requestId) <- mRequest + let s = runPut $ putRequest request requestId + return $ (lenBytes s) `L.append` s + + Connection.write conn $ L.toStrict $ L.concat $ noticeStrings ++ (maybeToList requestString) Connection.flush conn where - writeReq (e, requestId) = do - Connection.writeLazy conn lenBytes - Connection.writeLazy conn bytes - where - bytes = runPut $ (either putNotice putRequest e) requestId - lenBytes = encodeSize . toEnum . fromEnum $ L.length bytes + lenBytes bytes = encodeSize . toEnum . fromEnum $ L.length bytes encodeSize = runPut . putInt32 . (+ 4) type Response = (ResponseTo, Reply) diff --git a/mongoDB.cabal b/mongoDB.cabal index 1bda803..be589c0 100644 --- a/mongoDB.cabal +++ b/mongoDB.cabal @@ -58,7 +58,7 @@ Source-repository head test-suite test hs-source-dirs: test main-is: Spec.hs - ghc-options: -Wall + ghc-options: -Wall -with-rtsopts "-K32m" type: exitcode-stdio-1.0 build-depends: mongoDB , base @@ -73,3 +73,27 @@ test-suite test default-language: Haskell2010 default-extensions: OverloadedStrings + +Benchmark bench + main-is: Benchmark.hs + type: exitcode-stdio-1.0 + Build-depends: array -any + , base < 5 + , binary -any + , bson >= 0.3 && < 0.4 + , text + , bytestring -any + , containers -any + , mtl >= 2 + , cryptohash -any + , network -any + , parsec -any + , random -any + , random-shuffle -any + , monad-control >= 0.3.1 + , lifted-base >= 0.1.0.3 + , transformers-base >= 0.4.1 + , hashtables >= 1.1.2.0 + , criterion + default-language: Haskell2010 + default-extensions: OverloadedStrings