From c01874dccc61240146ab826cc18e88435b8b22e2 Mon Sep 17 00:00:00 2001
From: Sasha Bogicevic <sasha.bogicevic@iohk.io>
Date: Tue, 10 Oct 2023 17:30:46 +0200
Subject: [PATCH] Create websocket connection in another thread

- Don't pass the connection to the webserver but connect on each
request to the websocket in another thead.
---
 hydraw/app/Main.hs          | 18 ++++++++++--------
 hydraw/hydraw.cabal         |  1 +
 hydraw/src/Hydra/Painter.hs |  6 ++++++
 3 files changed, 17 insertions(+), 8 deletions(-)

diff --git a/hydraw/app/Main.hs b/hydraw/app/Main.hs
index a82999c8ac9..ddc54540505 100644
--- a/hydraw/app/Main.hs
+++ b/hydraw/app/Main.hs
@@ -2,9 +2,10 @@ module Main where
 
 import Hydra.Prelude
 
+import Control.Monad.Class.MonadAsync (async)
 import Hydra.Cardano.Api (NetworkId (..), NetworkMagic (..))
 import Hydra.Network (Host, readHost)
-import Hydra.Painter (Pixel (..), paintPixel, withClient)
+import Hydra.Painter (Pixel (..), paintPixel, withClient, withClientNoRetry)
 import Network.HTTP.Types.Status (status200, status400, status404)
 import Network.Wai (
   Application,
@@ -23,9 +24,8 @@ main = do
   key <- requireEnv "HYDRAW_CARDANO_SIGNING_KEY"
   host <- parseHost =<< requireEnv "HYDRA_API_HOST"
   network <- parseNetwork =<< requireEnv "HYDRAW_NETWORK"
-  withClient host $ \cnx ->
-    Warp.runSettings settings $
-      Wai.websocketsOr WS.defaultConnectionOptions (websocketApp host) (httpApp network key cnx)
+  Warp.runSettings settings $
+    Wai.websocketsOr WS.defaultConnectionOptions (websocketApp host) (httpApp network key host)
  where
   port = 1337
 
@@ -66,18 +66,20 @@ websocketApp :: Host -> WS.PendingConnection -> IO ()
 websocketApp host pendingConnection = do
   frontend <- WS.acceptRequest pendingConnection
   withClient host $ \backend ->
-   race_
+    race_
       (forever $ WS.receive frontend >>= WS.send backend)
       (forever $ WS.receive backend >>= WS.send frontend)
 
-httpApp :: NetworkId -> FilePath -> WS.Connection -> Application
-httpApp networkId key cnx req send =
+httpApp :: NetworkId -> FilePath -> Host -> Application
+httpApp networkId key host req send =
   case (requestMethod req, pathInfo req) of
     ("GET", "paint" : args) -> do
       case traverse (readMay . toString) args of
         Just [x, y, red, green, blue] -> do
           putStrLn $ show (x, y) <> " -> " <> show (red, green, blue)
-          paintPixel networkId key cnx Pixel{x, y, red, green, blue}
+          -- | spawn a connection in a new thread
+          void $ async $ withClientNoRetry host $ \cnx ->
+            paintPixel networkId key cnx Pixel{x, y, red, green, blue}
           send $ responseLBS status200 corsHeaders "OK"
         _ ->
           send handleError
diff --git a/hydraw/hydraw.cabal b/hydraw/hydraw.cabal
index 1d824f93f08..1eba9c167a3 100644
--- a/hydraw/hydraw.cabal
+++ b/hydraw/hydraw.cabal
@@ -72,6 +72,7 @@ executable hydraw
     , hydra-node
     , hydra-prelude
     , hydraw
+    , io-classes
     , safe
     , wai
     , wai-websockets
diff --git a/hydraw/src/Hydra/Painter.hs b/hydraw/src/Hydra/Painter.hs
index 3ddd0aae2e7..7160086f393 100644
--- a/hydraw/src/Hydra/Painter.hs
+++ b/hydraw/src/Hydra/Painter.hs
@@ -42,6 +42,12 @@ paintPixel networkId signingKeyPath cnx pixel = do
   flushQueue =
     race_ (threadDelay 0.25) (void (receive cnx) >> flushQueue)
 
+-- | Same as 'withClient' except we don't retry if connection fails.
+withClientNoRetry :: Host -> (Connection -> IO ()) -> IO ()
+withClientNoRetry Host{hostname, port} action =
+  runClient (toString hostname) (fromIntegral port) "/" action
+    `catch` \(e :: IOException) -> print e >> threadDelay 1
+
 withClient :: Host -> (Connection -> IO ()) -> IO ()
 withClient Host{hostname, port} action =
   retry