From c305a778137f3c3a8656b674109a205362396bd9 Mon Sep 17 00:00:00 2001
From: Romain GERARD <erebe@erebe.eu>
Date: Sat, 5 Nov 2022 19:38:21 +0100
Subject: [PATCH] Use directly socket for ws server stream

Former-commit-id: daa234438e35601f69c10115d502f3bb122900f6
Former-commit-id: b9c4a4820fed7c7fa9261fa3bc6097440e40b2e6 [formerly 0e80c23298933e37c2fc83f9690e2721de07dc1a] [formerly cc233a88979073852c3a3a09993f84038f632317 [formerly b78e81998262bdcf5ec2942e0c87e5f6e28e7865 [formerly b78e81998262bdcf5ec2942e0c87e5f6e28e7865 [formerly b78e81998262bdcf5ec2942e0c87e5f6e28e7865 [formerly d669991b6a4c285b1cfcd3966fd909d323eb0d2e]]]]]
Former-commit-id: eb6e0472a22f4c1eb9cf69e6533480b5fef5823a [formerly fb50ebbd510221c67dd18d4311eb995a3d392a07]
Former-commit-id: f6b4b9ff598de2a623d881018e949bf7e1f042fc
Former-commit-id: 0f42326884818628d0d79539c5559187d8d995e3
Former-commit-id: 3de35bb7f07cd76eab4e107034f08a963cfa9272
Former-commit-id: 532d3531daf0365ae6e59167b5997b4cd252737e [formerly c973fbc73d36e7a09fd3a4e37483ac4fa327b299]
Former-commit-id: ad6171066b614d131cbb450e35d75f1f630a5fbd
---
 src/Tunnel.hs | 4 +++-
 1 file changed, 3 insertions(+), 1 deletion(-)

diff --git a/src/Tunnel.hs b/src/Tunnel.hs
index edc8c88..4faefb5 100644
--- a/src/Tunnel.hs
+++ b/src/Tunnel.hs
@@ -20,6 +20,7 @@ import           Network.Socket                (HostName, PortNumber)
 import qualified Network.Socket                as N hiding (recv, recvFrom,
                                                      send, sendTo)
 import qualified Network.Socket.ByteString     as N
+import qualified Network.Socket.ByteString.Lazy     as NL
 
 import qualified Network.WebSockets            as WS
 import qualified Network.WebSockets.Connection as WS
@@ -210,7 +211,8 @@ runTunnelingServer endPoint@(host, port) isAllowed = do
 
   let srvSet = N.setReadBufferSize defaultRecvBufferSize $ N.serverSettingsTCP (fromIntegral port) (fromString host)
   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)
+    let socket = fromJust $ N.appRawSocket sClient
+    stream <- WS.makeStream (N.recv socket defaultRecvBufferSize <&> \payload -> if payload == mempty then Nothing else Just payload) (NL.sendAll socket . fromJust)
     runApp stream WS.defaultConnectionOptions (serverEventLoop (N.appSockAddr sClient) isAllowed)
 
   info "CLOSE server"