Skip to content

Commit

Permalink
Merge pull request #1121 from input-output-hk/hydraw-with-race
Browse files Browse the repository at this point in the history
Fix Hydraw connection problems
  • Loading branch information
Arnaud Bailly authored Oct 19, 2023
2 parents fa82bbd + c01874d commit 7175e6c
Show file tree
Hide file tree
Showing 3 changed files with 17 additions and 8 deletions.
18 changes: 10 additions & 8 deletions hydraw/app/Main.hs
Original file line number Diff line number Diff line change
Expand Up @@ -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,
Expand All @@ -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

Expand Down Expand Up @@ -66,18 +66,20 @@ websocketApp :: Host -> WS.PendingConnection -> IO ()
websocketApp host pendingConnection = do
frontend <- WS.acceptRequest pendingConnection
withClient host $ \backend ->
concurrently_
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
Expand Down
1 change: 1 addition & 0 deletions hydraw/hydraw.cabal
Original file line number Diff line number Diff line change
Expand Up @@ -72,6 +72,7 @@ executable hydraw
, hydra-node
, hydra-prelude
, hydraw
, io-classes
, safe
, wai
, wai-websockets
Expand Down
6 changes: 6 additions & 0 deletions hydraw/src/Hydra/Painter.hs
Original file line number Diff line number Diff line change
Expand Up @@ -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
Expand Down

0 comments on commit 7175e6c

Please sign in to comment.