Address performance issues with insert
Compile notices and request into one strict string for performance boost.
This commit is contained in:
parent
79b88ddeb5
commit
e45d9329e9
1 changed files with 14 additions and 9 deletions
|
@ -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)
|
||||||
|
|
Loading…
Reference in a new issue