From df927db68e55053f068b45e298d06c1f285f8c5c Mon Sep 17 00:00:00 2001
From: Romain GERARD <r.gerard@criteo.com>
Date: Sat, 4 Jan 2020 13:28:36 +0100
Subject: [PATCH] Perf improvements: Use default os setting for socket recv
 buffer size

  + This commit https://github.com/fpco/streaming-commons/commit/8e38589efb60d38e10ece0c7987186efd852fffc#diff-8c54fc2d40ad45803c6889efbb0192bbR278 introduce a default fixed size read buffer which is too low for most modern system. Thus it induce a lot of unecessary syscall and cpu usage.
  Use the default OS settings in order to let the user control it with
  ie: /proc/sys/net/ipv4/tcp_rmem


Former-commit-id: 11329e7b2d39a571afcfa1c41b36ca43b8c6ee0c
Former-commit-id: d125be3860d756e8608707db387b9293005d02f8 [formerly cc16d8a3c00a1f2ae215b44b94356f0fd9b06abc] [formerly a4977ba6a35eb7805b01eb9b628786e22842f480 [formerly fd3d401b93d75acf5a20d37598cf115d234b47ad [formerly fd3d401b93d75acf5a20d37598cf115d234b47ad [formerly fd3d401b93d75acf5a20d37598cf115d234b47ad [formerly bec6f99d38ff1e9c53a0a7d71ae6051280508d2e]]]]]
Former-commit-id: 18d8b263236b960c37a41e63491bc287bf584a67 [formerly 9d2ab35501de57b0ba1ee8d18f1fb173a3ca98f6]
Former-commit-id: 00bdbc5e1cd318896a012b76dfdc68964434b43d
Former-commit-id: 86df02c0670359a2bb2429eae4b9b633f5d520ef
Former-commit-id: 59966a7acefbbdc76e580d281f8be7ee2ca1db03
Former-commit-id: d670c023b29c085d4e76809ec539fcd91d6be993 [formerly 2bfa1100e83fd689dd2e2c565fe0838036c1b588]
Former-commit-id: c7c40b2a4e933cbff27713a87d7cc701c1279d32
---
 src/Protocols.hs |  6 ++++--
 src/Tunnel.hs    | 19 +++++++++++++------
 src/Types.hs     |  9 ++++++++-
 3 files changed, 25 insertions(+), 9 deletions(-)

diff --git a/src/Protocols.hs b/src/Protocols.hs
index 2b69b59..afac9d7 100644
--- a/src/Protocols.hs
+++ b/src/Protocols.hs
@@ -41,13 +41,15 @@ runSTDIOServer app = do
 runTCPServer :: (HostName, PortNumber) -> (N.AppData -> IO ()) -> IO ()
 runTCPServer endPoint@(host, port) app = do
   info $ "WAIT for tcp connection on " <> toStr endPoint
-  void $ N.runTCPServer (N.serverSettingsTCP (fromIntegral port) (fromString host)) app
+  let srvSet = N.setReadBufferSize defaultRecvBufferSize $ N.serverSettingsTCP (fromIntegral port) (fromString host)
+  void $ N.runTCPServer srvSet app
   info $ "CLOSE tcp server on " <> toStr endPoint
 
 runTCPClient :: (HostName, PortNumber) -> (N.AppData -> IO ()) -> IO ()
 runTCPClient endPoint@(host, port) app = do
   info $ "CONNECTING to " <> toStr endPoint
-  void $ N.runTCPClient (N.clientSettingsTCP (fromIntegral port) (BC.pack host)) app
+  let srvSet = N.setReadBufferSize defaultRecvBufferSize $ N.clientSettingsTCP (fromIntegral port) (BC.pack host)
+  void $ N.runTCPClient srvSet app
   info $ "CLOSE connection to " <> toStr endPoint
 
 
diff --git a/src/Tunnel.hs b/src/Tunnel.hs
index e64f91e..cf4b951 100644
--- a/src/Tunnel.hs
+++ b/src/Tunnel.hs
@@ -40,10 +40,15 @@ import qualified Credentials
 
 rrunTCPClient :: N.ClientSettings -> (Connection -> IO a) -> IO a
 rrunTCPClient cfg app = bracket
-    (N.getSocketFamilyTCP (N.getHost cfg) (N.getPort cfg) (N.getAddrFamily cfg))
+    (do
+      (s,addr) <- N.getSocketFamilyTCP (N.getHost cfg) (N.getPort cfg) (N.getAddrFamily cfg)
+      N.setSocketOption s N.RecvBuffer defaultRecvBufferSize
+      N.setSocketOption s N.SendBuffer defaultSendBufferSize
+      return (s,addr)
+    )
     (\r -> catch (N.close $ fst r) (\(_ :: SomeException) -> return ()))
     (\(s, _) -> app Connection
-        { read = Just <$> N.safeRecv s (N.getReadBufferSize cfg)
+        { read = Just <$> N.safeRecv s defaultRecvBufferSize
         , write = N.sendAll s
         , close = N.close s
         , rawConnection = Just s
@@ -198,14 +203,16 @@ runTunnelingServer :: (HostName, PortNumber) -> ((ByteString, Int) -> Bool) -> I
 runTunnelingServer endPoint@(host, port) isAllowed = do
   info $ "WAIT for connection on " <> toStr endPoint
 
-  void $ N.runTCPServer (N.serverSettingsTCP (fromIntegral port) (fromString host)) $ \sClient ->
-    runApp (fromJust $ N.appRawSocket sClient) WS.defaultConnectionOptions (serverEventLoop isAllowed)
+  let srvSet = N.setReadBufferSize defaultRecvBufferSize $ N.serverSettingsTCP (fromIntegral port) (fromString host)
+  void $ N.runTCPServer (srvSet) $ \sClient -> do
+    stream <- WS.makeStream (Just <$> N.appRead sClient) (N.appWrite sClient . toStrict . fromJust)
+    runApp stream WS.defaultConnectionOptions (serverEventLoop isAllowed)
 
   info "CLOSE server"
 
   where
-    runApp :: N.Socket -> WS.ConnectionOptions -> WS.ServerApp -> IO ()
-    runApp socket opts = bracket (WS.makePendingConnection socket opts)
+    runApp :: WS.Stream -> WS.ConnectionOptions -> WS.ServerApp -> IO ()
+    runApp socket opts = bracket (WS.makePendingConnectionFromStream socket opts)
                          (\conn -> catch (WS.close $ WS.pendingStream conn) (\(_ :: SomeException) -> return ()))
 
 serverEventLoop :: ((ByteString, Int) -> Bool) -> WS.PendingConnection -> IO ()
diff --git a/src/Types.hs b/src/Types.hs
index 836977c..17089f8 100644
--- a/src/Types.hs
+++ b/src/Types.hs
@@ -2,7 +2,6 @@
 {-# LANGUAGE DeriveGeneric      #-}
 {-# LANGUAGE StandaloneDeriving #-}
 
-
 module Types where
 
 import           ClassyPrelude
@@ -19,6 +18,7 @@ import qualified Network.Socket                as N hiding (recv, recvFrom,
 import qualified Network.Socket.ByteString     as N
 
 import qualified Network.WebSockets.Connection as WS
+import                  System.IO.Unsafe (unsafeDupablePerformIO)
 
 deriving instance Generic PortNumber
 deriving instance Hashable PortNumber
@@ -26,6 +26,13 @@ deriving instance Generic N.SockAddr
 deriving instance Hashable N.SockAddr
 
 
+defaultRecvBufferSize ::  Int
+defaultRecvBufferSize = unsafeDupablePerformIO $
+  bracket (N.socket N.AF_INET N.Stream 0) N.close (\sock -> N.getSocketOption  sock N.RecvBuffer)
+
+defaultSendBufferSize :: Int
+defaultSendBufferSize = defaultRecvBufferSize
+
 data Protocol = UDP | TCP | STDIO | SOCKS5 deriving (Show, Read, Eq)
 
 data StdioAppData = StdioAppData