From 0a788ca3f773a0c47d7df95f7e830cf0c6057d48 Mon Sep 17 00:00:00 2001 From: Romain GERARD Date: Mon, 24 Feb 2020 18:37:38 +0100 Subject: [PATCH] Fix High CPU utilization #38 + Properly notify that the stream is closed when there is no more data to read from the socket Former-commit-id: 040b6f949d9f6751cdb626d080094ea359926d56 Former-commit-id: a13469bd6a307b44d8fb33085406a29755d98f61 [formerly adee22fb776a28d4746cd99fe5bd33699b2f46ce] [formerly a01daff330828687249cd040a74eb1bd66143c4d [formerly f79391c53820f0df1a4609ed01fdb5de68222f0b [formerly c358f0ababd30764b97017f12f4b508b04caf1de] [formerly be3e3e6f4b78ffd53b6a3ea67d3aa09bfab91f2b] [formerly be3e3e6f4b78ffd53b6a3ea67d3aa09bfab91f2b [formerly be3e3e6f4b78ffd53b6a3ea67d3aa09bfab91f2b [formerly b008128bf854a39bbc5c6abdc5fd87cc8e38fffe]]]]] Former-commit-id: cf525aa4cde74e9d22826fc2fd46fc6f08ca478b [formerly 6751159b82b46bedef7fde04c0444c76d391bd99] Former-commit-id: 9669125c02d8fdb2339cd927d28db7cdc0a60a58 Former-commit-id: e711b3a557f7b037794667c0b4249a21c44abc3f Former-commit-id: eccc9eaf7007ec09119c4307389991d4d199f4b6 Former-commit-id: a6d5dd21c88508a5c8f2afd031852955cb45998d [formerly 3e1eca9a176bb75971f232a2dc0dc887e2dd1d31] Former-commit-id: 053a1b7025f8cb4d6c67a648c15b66be18f1e9f0 --- src/Tunnel.hs | 8 ++++---- 1 file changed, 4 insertions(+), 4 deletions(-) diff --git a/src/Tunnel.hs b/src/Tunnel.hs index 7a3df7c..667a76e 100644 --- a/src/Tunnel.hs +++ b/src/Tunnel.hs @@ -195,8 +195,8 @@ runTlsTunnelingServer endPoint@(bindTo, portNumber) isAllowed = do where runApp :: N.AppData -> WS.ConnectionOptions -> WS.ServerApp -> IO () - runApp appData opts app= do - stream <- WS.makeStream (Just <$> N.appRead appData) (N.appWrite appData . toStrict . fromJust) + runApp appData opts app = do + stream <- WS.makeStream (N.appRead appData <&> \payload -> if payload == mempty then Nothing else Just payload) (N.appWrite appData . toStrict . fromJust) bracket (WS.makePendingConnectionFromStream stream opts) (\conn -> catch (WS.close $ WS.pendingStream conn) (\(_ :: SomeException) -> return ())) app @@ -206,8 +206,8 @@ runTunnelingServer endPoint@(host, port) isAllowed = do info $ "WAIT for connection on " <> toStr endPoint 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) + void $ N.runTCPServer srvSet $ \sClient -> do + stream <- WS.makeStream (N.appRead sClient <&> \payload -> if payload == mempty then Nothing else Just payload) (N.appWrite sClient . toStrict . fromJust) runApp stream WS.defaultConnectionOptions (serverEventLoop isAllowed) info "CLOSE server"