Merge pull request #28 from VictorDenisov/master
Fix slow requests to the database server
This commit is contained in:
commit
23784db8df
5 changed files with 70 additions and 14 deletions
26
Benchmark.hs
Normal file
26
Benchmark.hs
Normal file
|
@ -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
|
|
@ -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
|
||||
|
|
|
@ -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
|
||||
|
|
|
@ -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)
|
||||
|
|
|
@ -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
|
||||
|
|
Loading…
Reference in a new issue