FE: Websockets now automatically reconnect if there's a network dropout.

marlowe-playground-client/packages.dhall

@@ -143,6 +143,16 @@ let additions =
           , version =
               "v10.0.0"
           }
+      , concurrent-queues =
+          { dependencies =
+              [ "aff"
+              , "avar"
+              ]
+          , repo =
+              "https://github.com/purescript-contrib/purescript-concurrent-queues.git"
+          , version =
+              "v1.1.0"
+          }
       , foreign-generic =
               upstream.foreign-generic
           //  { repo =

marlowe-playground-client/spago-packages.nix

@@ -137,6 +137,18 @@ let
         installPhase = "ln -s $src $out";
       };
 
+    "concurrent-queues" = pkgs.stdenv.mkDerivation {
+        name = "concurrent-queues";
+        version = "v1.1.0";
+        src = pkgs.fetchgit {
+          url = "https://github.com/purescript-contrib/purescript-concurrent-queues.git";
+          rev = "e461aa5bbcfb99dd59c993a7c5c4f0e0751e4a8b";
+          sha256 = "1a0vlxbl0vnk68v4wszgy6sz51klvnxfw8v8l4fpwkbb886mvxaj";
+        };
+        phases = "installPhase";
+        installPhase = "ln -s $src $out";
+      };
+
     "console" = pkgs.stdenv.mkDerivation {
         name = "console";
         version = "v4.4.0";
@@ -1209,7 +1221,7 @@ let
         name = "unsafe-reference";
         version = "v3.0.1";
         src = pkgs.fetchgit {
-          url = "https://github.com/purescript-contrib/purescript-unsafe-reference";
+          url = "https://github.com/purescript-contrib/purescript-unsafe-reference.git";
           rev = "79d7de7b9351346a73e6c060d80532c95ba1c7c1";
           sha256 = "0q758dz59qz0li4s3w1qcg921xp5i5rh6i1l611iv7rr8cbj11al";
         };

marlowe-playground-client/spago.dhall

@@ -4,8 +4,9 @@ You can edit this file as you like.
 -}
 { name = "marlowe-playground-client"
 , dependencies =
-  [ "aff-coroutines"
+  [ "avar"
   , "bigints"
+  , "concurrent-queues"
   , "console"
   , "coroutines"
   , "debug"

marlowe-playground-client/src/Main.purs

@@ -1,11 +1,10 @@
 module Main where
 
 import Prelude
-import Control.Coroutine (Consumer, Process, connect, consumer, runProcess, ($$))
+import Control.Coroutine (Consumer, Process, connect, consumer, runProcess)
 import Data.Maybe (Maybe(..))
 import Effect (Effect)
 import Effect.Aff (Aff, forkAff, launchAff_)
-import Control.Coroutine.Extra (mapConsumer)
 import Effect.Class (liftEffect)
 import Effect.Console (log)
 import Effect.Unsafe (unsafePerformEffect)
@@ -20,9 +19,9 @@ import Router as Router
 import Routing.Duplex as Routing
 import Routing.Hash (matchesWith)
 import Servant.PureScript.Settings (SPSettingsDecodeJson_(..), SPSettingsEncodeJson_(..), SPSettings_(..), defaultSettings)
-import WebSocket (WebSocketResponseMessage)
-import Types (HQuery(..), Message(..))
-import WebSocket.Support (wsConsumer, wsProducer, wsSender, mkSocket)
+import WebSocket (WebSocketRequestMessage, WebSocketResponseMessage)
+import Types (HQuery(..))
+import WebSocket.Support (WebSocketManager)
 import WebSocket.Support as WS
 
 ajaxSettings :: SPSettings_ SPParams_
@@ -39,19 +38,18 @@ ajaxSettings = SPSettings_ $ (settings { decodeJson = decodeJson, encodeJson = e
 main ::
   Effect Unit
 main = do
-  socket <- mkSocket "/api/ws"
   let
     mainFrame = mkMainFrame ajaxSettings
   runHalogenAff do
     body <- awaitBody
     driver <- runUI mainFrame unit body
-    let
-      handleWebSocket :: WS.Output WebSocketResponseMessage -> Aff Unit
-      handleWebSocket msg = void $ driver.query $ ReceiveWebSocketMessage msg unit
-    driver.subscribe
-      $ mapConsumer (case _ of (WebSocketMessage msg) -> WS.SendMessage msg)
-      $ wsSender handleWebSocket socket
-    void $ forkAff $ runProcess (wsProducer socket $$ wsConsumer handleWebSocket)
+    wsManager :: WebSocketManager WebSocketResponseMessage WebSocketRequestMessage <- WS.mkWebSocketManager
+    void
+      $ forkAff
+      $ WS.runWebSocketManager
+          (WS.URI "/api/ws")
+          (\msg -> void $ driver.query $ ReceiveWebSocketMessage msg unit)
+          wsManager
     void $ liftEffect
       $ matchesWith (Routing.parse Router.route) \old new -> do
           when (old /= Just new) $ launchAff_ $ driver.query (ChangeRoute new unit)

marlowe-playground-client/src/MainFrame.purs

@@ -128,10 +128,11 @@ handleQuery ::
 handleQuery (ReceiveWebSocketMessage msg next) = do
   void <<< toSimulation
     $ case msg of
-        WS.ReceiveMessage (Left err) -> Simulation.handleQuery (ST.WebsocketResponse (Failure (show msg)) unit)
+        WS.WebSocketOpen -> pure $ Just unit
+        WS.ReceiveMessage (Left err) -> Simulation.handleQuery (ST.WebsocketResponse (Failure (show err)) unit)
         WS.ReceiveMessage (Right (OtherError err)) -> Simulation.handleQuery ((ST.WebsocketResponse $ Failure err) unit)
         WS.ReceiveMessage (Right (CheckForWarningsResult result)) -> Simulation.handleQuery ((ST.WebsocketResponse $ Success result) unit)
-        WS.WebSocketClosed -> pure $ Just unit
+        (WS.WebSocketClosed _) -> pure $ Just unit
   pure $ Just next
 
 handleQuery (ChangeRoute route next) = do

marlowe-playground-client/src/Types.purs

@@ -28,7 +28,7 @@ import WebSocket (WebSocketResponseMessage, WebSocketRequestMessage)
 
 ------------------------------------------------------------
 data HQuery a
-  = ReceiveWebSocketMessage (WS.Output WebSocketResponseMessage) a
+  = ReceiveWebSocketMessage (WS.FromSocket WebSocketResponseMessage) a
   | ChangeRoute Route a
 
 data Message

plutus-playground-client/packages.dhall

@@ -181,6 +181,16 @@ let additions =
           , version =
               "v7.0.0"
           }
+      , concurrent-queues =
+          { dependencies =
+              [ "aff"
+              , "avar"
+              ]
+          , repo =
+              "https://github.com/purescript-contrib/purescript-concurrent-queues.git"
+          , version =
+              "v1.1.0"
+          }
       , matryoshka =
           { dependencies =
               [ "prelude"

plutus-playground-client/spago-packages.nix

@@ -173,6 +173,18 @@ let
         installPhase = "ln -s $src $out";
       };
 
+    "concurrent-queues" = pkgs.stdenv.mkDerivation {
+        name = "concurrent-queues";
+        version = "v1.1.0";
+        src = pkgs.fetchgit {
+          url = "https://github.com/purescript-contrib/purescript-concurrent-queues.git";
+          rev = "e461aa5bbcfb99dd59c993a7c5c4f0e0751e4a8b";
+          sha256 = "1a0vlxbl0vnk68v4wszgy6sz51klvnxfw8v8l4fpwkbb886mvxaj";
+        };
+        phases = "installPhase";
+        installPhase = "ln -s $src $out";
+      };
+
     "console" = pkgs.stdenv.mkDerivation {
         name = "console";
         version = "v4.4.0";

plutus-playground-client/spago.dhall

@@ -9,6 +9,7 @@ You can edit this file as you like.
   , "ace"
   , "aff"
   , "bigints"
+  , "concurrent-queues"
   , "console"
   , "coroutines"
   , "aff-coroutines"

plutus-scb-client/packages.dhall

@@ -143,6 +143,16 @@ let additions =
           , version =
               "v10.0.0"
           }
+      , concurrent-queues =
+          { dependencies =
+              [ "aff"
+              , "avar"
+              ]
+          , repo =
+              "https://github.com/purescript-contrib/purescript-concurrent-queues.git"
+          , version =
+              "v1.1.0"
+          }
       , foreign-generic =
             upstream.foreign-generic
           ⫽ { repo =

plutus-scb-client/spago-packages.nix

@@ -137,6 +137,18 @@ let
         installPhase = "ln -s $src $out";
       };
 
+    "concurrent-queues" = pkgs.stdenv.mkDerivation {
+        name = "concurrent-queues";
+        version = "v1.1.0";
+        src = pkgs.fetchgit {
+          url = "https://github.com/purescript-contrib/purescript-concurrent-queues.git";
+          rev = "e461aa5bbcfb99dd59c993a7c5c4f0e0751e4a8b";
+          sha256 = "1a0vlxbl0vnk68v4wszgy6sz51klvnxfw8v8l4fpwkbb886mvxaj";
+        };
+        phases = "installPhase";
+        installPhase = "ln -s $src $out";
+      };
+
     "console" = pkgs.stdenv.mkDerivation {
         name = "console";
         version = "v4.4.0";

plutus-scb-client/spago.dhall

@@ -6,9 +6,9 @@ You can edit this file as you like.
 , dependencies =
   [ "prelude"
   , "aff"
+  , "avar"
   , "console"
-  , "coroutines"
-  , "aff-coroutines"
+  , "concurrent-queues"
   , "debug"
   , "effect"
   , "halogen"

plutus-scb-client/src/Main.purs

@@ -1,36 +1,30 @@
 module Main where
 
 import Prelude
-import Control.Coroutine (connect, runProcess)
-import Control.Coroutine.Extra (mapConsumer)
 import Effect (Effect)
 import Effect.Aff (Aff, forkAff)
 import Effect.Unsafe (unsafePerformEffect)
 import Halogen.Aff (awaitBody, runHalogenAff)
 import Halogen.VDom.Driver (runUI)
 import MainFrame (initialMainFrame)
-import Plutus.SCB.Webserver.Types (StreamToClient)
-import Types (HAction(..), Output(..), Query(..))
-import WebSocket.Support (mkSocket, Output) as WS
-import WebSocket.Support (wsConsumer, wsProducer, wsSender)
+import Plutus.SCB.Webserver.Types (StreamToClient, StreamToServer)
+import Types (HAction(..), Query(..))
+import WebSocket.Support (WebSocketManager, mkWebSocketManager)
+import WebSocket.Support as WS
 
 main :: Effect Unit
 main = do
-  socket <- WS.mkSocket "/ws"
   runHalogenAff do
     body <- awaitBody
     driver <- runUI initialMainFrame Init body
-    let
-      handleWebSocket :: WS.Output StreamToClient -> Aff Unit
-      handleWebSocket msg = void $ driver.query $ ReceiveWebSocketMessage msg unit
-    void $ forkAff
-      $ runProcess
-      $ connect
-          (wsProducer socket)
-          (wsConsumer handleWebSocket)
-    driver.subscribe
-      $ mapConsumer (case _ of (SendWebSocketMessage msg) -> msg)
-      $ wsSender handleWebSocket socket
+    wsManager :: WebSocketManager StreamToClient StreamToServer <-
+      mkWebSocketManager
+    void
+      $ forkAff
+      $ WS.runWebSocketManager
+          (WS.URI "/ws")
+          (\msg -> void $ driver.query $ ReceiveWebSocketMessage msg unit)
+          wsManager
 
 onLoad :: Unit
 onLoad = unsafePerformEffect main

plutus-scb-client/src/MainFrame.purs

@@ -37,7 +37,7 @@ import Language.Plutus.Contract.Effects.ExposeEndpoint (EndpointDescription)
 import Ledger.Ada (Ada(..))
 import Ledger.Extra (adaToValue)
 import Ledger.Value (Value)
-import MonadApp (class MonadApp, activateContract, getFullReport, invokeEndpoint, log, runHalogenApp)
+import MonadApp (class MonadApp, activateContract, getFullReport, invokeEndpoint, runHalogenApp)
 import Network.RemoteData (RemoteData(..))
 import Network.RemoteData as RemoteData
 import Network.StreamData as Stream
@@ -52,7 +52,7 @@ import Schema (FormSchema)
 import Schema.Types (formArgumentToJson, toArgument)
 import Schema.Types as Schema
 import Servant.PureScript.Settings (SPSettings_, defaultSettings)
-import Types (ContractSignatures, EndpointForm, HAction(..), Output, Query(..), State(..), StreamError(..), View(..), WebStreamData, _annotatedBlockchain, _chainReport, _chainState, _contractActiveEndpoints, _contractReport, _contractSignatures, _contractStates, _crActiveContractStates, _crAvailableContracts, _csContract, _csCurrentState, _currentView, _events, _webSocketMessage, fromWebData)
+import Types (ContractSignatures, EndpointForm, HAction(..), Output, Query(..), State(..), StreamError(..), View(..), WebSocketStatus(..), WebStreamData, _annotatedBlockchain, _chainReport, _chainState, _contractActiveEndpoints, _contractReport, _contractSignatures, _contractStates, _crActiveContractStates, _crAvailableContracts, _csContract, _csCurrentState, _currentView, _events, _webSocketMessage, _webSocketStatus, fromWebData)
 import Validation (_argument)
 import View as View
 import WebSocket.Support as WS
@@ -70,6 +70,7 @@ initialState =
     , chainState: Chain.initialState
     , contractStates: Map.empty
     , webSocketMessage: Stream.NotAsked
+    , webSocketStatus: WebSocketClosed Nothing
     }
 
 ------------------------------------------------------------
@@ -98,8 +99,6 @@ initialMainFrame =
 
 handleQuery ::
   forall m a.
-  Warn (Text "Handle WebSocket errors.") =>
-  Warn (Text "Handle WebSocket disconnections.") =>
   MonadState State m =>
   MonadApp m =>
   Query a -> m (Maybe a)
@@ -116,8 +115,12 @@ handleQuery (ReceiveWebSocketMessage (WS.ReceiveMessage msg) next) = do
   assign _webSocketMessage $ lmap DecodingError $ Stream.fromEither msg
   pure $ Just next
 
-handleQuery (ReceiveWebSocketMessage WS.WebSocketClosed next) = do
-  log "Closed"
+handleQuery (ReceiveWebSocketMessage WS.WebSocketOpen next) = do
+  assign _webSocketStatus WebSocketOpen
+  pure $ Just next
+
+handleQuery (ReceiveWebSocketMessage (WS.WebSocketClosed closeEvent) next) = do
+  assign _webSocketStatus (WebSocketClosed (Just closeEvent))
   pure $ Just next
 
 handleAction ::

plutus-scb-client/src/MonadApp.purs

@@ -80,7 +80,7 @@ instance monadAppHalogenApp :: (MonadAff m, MonadAsk (SPSettings_ SPParams_) m)
           (view _contractInstanceIdString contractInstanceId)
           (view _getEndpointDescription endpointDescription)
   activateContract contract = void $ runAjax $ postApiContractActivate contract
-  sendWebSocketMessage msg = HalogenApp $ raise $ SendWebSocketMessage $ WS.SendMessage msg
+  sendWebSocketMessage msg = HalogenApp $ raise $ SendWebSocketMessage msg
   log str = liftEffect $ Console.log str
 
 runAjax :: forall m a. Functor m => ExceptT AjaxError m a -> m (WebData a)

plutus-scb-client/src/Types.purs

@@ -12,6 +12,7 @@ import Data.Lens (Getter', Traversal', Lens', to, traversed)
 import Data.Lens.Iso.Newtype (_Newtype)
 import Data.Lens.Record (prop)
 import Data.Map (Map)
+import Data.Maybe (Maybe(..))
 import Data.Newtype (class Newtype)
 import Data.NonEmpty ((:|))
 import Data.Symbol (SProxy(..))
@@ -36,13 +37,14 @@ import Schema.Types (FormArgument, FormEvent)
 import Servant.PureScript.Ajax (AjaxError)
 import Test.QuickCheck (class Arbitrary)
 import Wallet.Rollup.Types (AnnotatedTx)
-import WebSocket.Support as WS
+import Web.Socket.Event.CloseEvent (CloseEvent, reason) as WS
+import WebSocket.Support (FromSocket) as WS
 
 data Query a
-  = ReceiveWebSocketMessage (WS.Output StreamToClient) a
+  = ReceiveWebSocketMessage (WS.FromSocket StreamToClient) a
 
 data Output
-  = SendWebSocketMessage (WS.Input StreamToServer)
+  = SendWebSocketMessage StreamToServer
 
 data StreamError
   = DecodingError MultipleErrors
@@ -72,6 +74,17 @@ type ContractStates
 type ContractSignatures
   = Array (ContractSignatureResponse ContractExe)
 
+data WebSocketStatus
+  = WebSocketOpen
+  | WebSocketClosed (Maybe WS.CloseEvent)
+
+derive instance genericWebSocketStatus :: Generic WebSocketStatus _
+
+instance showWebSocketStatus :: Show WebSocketStatus where
+  show WebSocketOpen = "WebSocketOpen"
+  show (WebSocketClosed Nothing) = "WebSocketClosed"
+  show (WebSocketClosed (Just closeEvent)) = "WebSocketClosed " <> WS.reason closeEvent
+
 newtype State
   = State
   { currentView :: View
@@ -81,6 +94,7 @@ newtype State
   , chainState :: Chain.State
   , contractStates :: ContractStates
   , webSocketMessage :: WebStreamData StreamToClient
+  , webSocketStatus :: WebSocketStatus
   }
 
 type EndpointForm
@@ -119,6 +133,9 @@ _transactionMap = _ChainReport <<< prop (SProxy :: SProxy "transactionMap")
 _webSocketMessage :: forall s a r. Newtype s { webSocketMessage :: a | r } => Lens' s a
 _webSocketMessage = _Newtype <<< prop (SProxy :: SProxy "webSocketMessage")
 
+_webSocketStatus :: forall s a r. Newtype s { webSocketStatus :: a | r } => Lens' s a
+_webSocketStatus = _Newtype <<< prop (SProxy :: SProxy "webSocketStatus")
+
 _contractReport :: forall s a r. Newtype s { contractReport :: a | r } => Lens' s a
 _contractReport = _Newtype <<< prop (SProxy :: SProxy "contractReport")