Address performance issues with insert

Compile notices and request into one strict string for performance
boost.
This commit is contained in:
Victor Denisov 2015-08-29 15:18:34 -07:00
parent 79b88ddeb5
commit e45d9329e9

View file

@ -26,7 +26,7 @@ module Database.MongoDB.Internal.Protocol (
import Control.Applicative ((<$>)) import Control.Applicative ((<$>))
#endif #endif
import Control.Arrow ((***)) import Control.Arrow ((***))
import Control.Monad (forM_, replicateM, unless) import Control.Monad (forM, replicateM, unless)
import Data.Binary.Get (Get, runGet) import Data.Binary.Get (Get, runGet)
import Data.Binary.Put (Put, runPut) import Data.Binary.Put (Put, runPut)
import Data.Bits (bit, testBit) import Data.Bits (bit, testBit)
@ -34,6 +34,7 @@ import Data.Int (Int32, Int64)
import Data.IORef (IORef, newIORef, atomicModifyIORef) import Data.IORef (IORef, newIORef, atomicModifyIORef)
import System.IO (Handle) import System.IO (Handle)
import System.IO.Unsafe (unsafePerformIO) import System.IO.Unsafe (unsafePerformIO)
import Data.Maybe (maybeToList)
import qualified Data.ByteString.Lazy as L import qualified Data.ByteString.Lazy as L
@ -93,16 +94,20 @@ type Message = ([Notice], Maybe (Request, RequestId))
writeMessage :: Connection -> Message -> IO () writeMessage :: Connection -> Message -> IO ()
-- ^ Write message to connection -- ^ Write message to connection
writeMessage conn (notices, mRequest) = do writeMessage conn (notices, mRequest) = do
forM_ notices $ \n -> writeReq . (Left n,) =<< genRequestId noticeStrings <- forM notices $ \n -> do
whenJust mRequest $ writeReq . (Right *** id) 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 Connection.flush conn
where where
writeReq (e, requestId) = do lenBytes bytes = encodeSize . toEnum . fromEnum $ L.length bytes
Connection.writeLazy conn lenBytes
Connection.writeLazy conn bytes
where
bytes = runPut $ (either putNotice putRequest e) requestId
lenBytes = encodeSize . toEnum . fromEnum $ L.length bytes
encodeSize = runPut . putInt32 . (+ 4) encodeSize = runPut . putInt32 . (+ 4)
type Response = (ResponseTo, Reply) type Response = (ResponseTo, Reply)