Set block buffering for UDSServer
authorKlaus Aehlig <aehlig@google.com>
Thu, 21 Jan 2016 14:45:23 +0000 (15:45 +0100)
committerKlaus Aehlig <aehlig@google.com>
Fri, 22 Jan 2016 11:26:35 +0000 (12:26 +0100)
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 <aehlig@google.com>
Reviewed-by: Hrvoje Ribicic <riba@google.com>

src/Ganeti/UDSServer.hs

index a374f69..b4f975f 100644 (file)
@@ -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