Commit b0a7e3771bfd changed sending of JSON-encoded answers to standard String sending. This was necessary as converting Strings to ByteStrings, even to lazy ones, fully enforced the String before the first Char got out of scope and could be garbage collected. The down-side of this approach is, that we now end up with one system call per character to be send. The good news, however, is that the library's buffering uses memory only a little more than a byte for a byte, so we can afford buffering in that layer. Do so to reduce the number of system calls.
On a, not quite realistic, test cluster, this resulted in the time for a config-read going down by 1.5 orders of magnitude with only small increase in residual memory. Signed-off-by: Klaus Aehlig <[email protected]> --- src/Ganeti/UDSServer.hs | 7 ++++++- 1 file changed, 6 insertions(+), 1 deletion(-) diff --git a/src/Ganeti/UDSServer.hs b/src/Ganeti/UDSServer.hs index a374f69..b4f975f 100644 --- a/src/Ganeti/UDSServer.hs +++ b/src/Ganeti/UDSServer.hs @@ -83,7 +83,8 @@ import Data.List import Data.Word (Word8) import qualified Network.Socket as S import System.Directory (removeFile) -import System.IO (hClose, hFlush, hPutStr, hWaitForInput, Handle, IOMode(..)) +import System.IO ( hClose, hFlush, hPutStr, hWaitForInput, Handle, IOMode(..) + , hSetBuffering, BufferMode(..)) import System.IO.Error (isEOFError) import System.Posix.Types (Fd) import System.Posix.IO (createPipe, fdToHandle, handleToFd) @@ -287,6 +288,10 @@ clientToFd client | rh == wh = join (,) <$> handleToFd rh sendMsg :: Client -> String -> IO () sendMsg s buf = withTimeout (sendTmo $ clientConfig s) "sending a message" $ do let handle = wsocket s + -- Allow buffering (up to 1MiB) when writing to the socket. Note that + -- otherwise we get the default of sending each byte in a separate + -- system call, resulting in very poor performance. + hSetBuffering handle (BlockBuffering . Just $ 1024 * 1024) hPutStr handle buf B.hPut handle bEOM hFlush handle -- 2.7.0.rc3.207.g0ac5344
