SCB: Streaming JSON data via websockets.

...for improved UX, and to ensure we see updates from other systems
(roughly) as they happen.

marlowe-playground-client/package.json

@@ -7,7 +7,7 @@
     "webpack:server": "webpack-dev-server --progress --inline --hot --mode=development --display verbose",
     "webpack:server:debug": "DEBUG=purs-loader* DEBUG_DEPTH=100 webpack-dev-server --progress --inline --hot",
     "purs:compile": "spago build",
-    "purs:ide": "purs ide server --log-level=debug 'src/**/*.purs' 'generated/**/*.purs' 'test/**/*.purs' '../web-common/**/*.purs'",
+    "purs:ide": "purs ide server --port 4243 --log-level=debug 'src/**/*.purs' 'generated/**/*.purs' 'test/**/*.purs' '../web-common/**/*.purs'",
     "test": "NODE_OPTIONS=\"--max-old-space-size=8192\" webpack --config webpack.test.config.js --mode=development && node --max-old-space-size=8192 dist/test.js",
     "docs": "spago docs",
     "repl": "spago repl"

marlowe-playground-client/src/Main.purs

@@ -5,6 +5,7 @@ import Control.Coroutine (Consumer, Process, connect, consumer, runProcess, ($$)
 import Data.Maybe (Maybe(..))
 import Effect (Effect)
 import Effect.Aff (forkAff, Aff)
+import Control.Coroutine.Extra (mapConsumer)
 import Effect.Class (liftEffect)
 import Effect.Console (log)
 import Effect.Unsafe (unsafePerformEffect)
@@ -16,11 +17,10 @@ import LocalStorage as LocalStorage
 import MainFrame (mkMainFrame)
 import Marlowe (SPParams_(SPParams_))
 import Servant.PureScript.Settings (SPSettingsDecodeJson_(..), SPSettingsEncodeJson_(..), SPSettings_(..), defaultSettings)
-import Web.HTML as W
-import Web.HTML.Location as WL
-import Web.HTML.Window as WW
-import Web.Socket.WebSocket as WS
-import Websockets (wsConsumer, wsProducer, wsSender)
+import WebSocket (WebSocketResponseMessage)
+import Types (HQuery(..), Message(..))
+import WebSocket.Support (wsConsumer, wsProducer, wsSender, mkSocket)
+import WebSocket.Support as WS
 
 ajaxSettings :: SPSettings_ SPParams_
 ajaxSettings = SPSettings_ $ (settings { decodeJson = decodeJson, encodeJson = encodeJson })
@@ -36,25 +36,19 @@ ajaxSettings = SPSettings_ $ (settings { decodeJson = decodeJson, encodeJson = e
 main ::
   Effect Unit
 main = do
-  window <- W.window
-  location <- WW.location window
-  protocol <- WL.protocol location
-  hostname <- WL.hostname location
-  port <- WL.port location
-  let
-    wsProtocol = case protocol of
-      "https:" -> "wss"
-      _ -> "ws"
-
-    wsPath = wsProtocol <> "://" <> hostname <> ":" <> port <> "/api/ws"
-  socket <- WS.create wsPath []
+  socket <- mkSocket "/api/ws"
   let
     mainFrame = mkMainFrame ajaxSettings
   runHalogenAff do
     body <- awaitBody
     driver <- runUI mainFrame unit body
-    driver.subscribe $ wsSender socket driver.query
-    void $ forkAff $ runProcess (wsProducer socket $$ wsConsumer driver.query)
+    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)
     forkAff $ runProcess watchLocalStorageProcess
 
 watchLocalStorageProcess :: Process Aff Unit

marlowe-playground-client/src/MainFrame.purs

@@ -8,6 +8,7 @@ import Data.Either (Either(..))
 import Data.Json.JsonEither (JsonEither(..))
 import Data.Lens (assign, to, use, view, (^.))
 import Data.Map as Map
+import WebSocket.Support as WS
 import Data.Maybe (Maybe(..), fromMaybe)
 import Data.Newtype (unwrap)
 import Data.String as String
@@ -86,18 +87,14 @@ handleQuery ::
   forall m a.
   HQuery a ->
   HalogenM FrontendState HAction ChildSlots Message m (Maybe a)
-handleQuery (ReceiveWebsocketMessage msg next) = do
-  let
-    msgDecoded =
-      unwrap <<< runExceptT
-        $ do
-            f <- parseJSON msg
-            decode f
-  void
-    $ case msgDecoded of
-        Left err -> query _simulationSlot unit (ST.WebsocketResponse (Failure (show msg)) unit)
-        Right (OtherError err) -> query _simulationSlot unit ((ST.WebsocketResponse $ Failure err) unit)
-        Right (CheckForWarningsResult result) -> query _simulationSlot unit ((ST.WebsocketResponse $ Success result) unit)
+handleQuery (ReceiveWebSocketMessage msg next) = do
+  void $ query _simulationSlot unit
+    $ flip ST.WebSocketResponse unit
+    $ case msg of
+        WS.WebSocketClosed -> Failure "Connection lost."
+        WS.ReceiveMessage (Left err) -> Failure (show msg)
+        WS.ReceiveMessage (Right (OtherError err)) -> Failure err
+        WS.ReceiveMessage (Right (CheckForWarningsResult result)) -> Success result
   pure $ Just next
 
 handleAction ::
@@ -111,7 +108,7 @@ handleAction _ (HandleSimulationMessage (ST.BlocklyCodeSet source)) = do
   assign _view BlocklyEditor
   void $ query _blocklySlot unit (Blockly.Resize unit)
 
-handleAction _ (HandleSimulationMessage (ST.WebsocketMessage msg)) = H.raise (WebsocketMessage msg)
+handleAction _ (HandleSimulationMessage (ST.WebSocketMessage msg)) = H.raise (WebSocketMessage msg)
 
 handleAction _ (HandleWalletMessage Wallet.SendContractToWallet) = do
   mContract <- query _simulationSlot unit (request ST.GetCurrentContract)

marlowe-playground-client/src/Reachability.purs

@@ -3,15 +3,14 @@ module Reachability (startReachabilityAnalysis, updateWithResponse) where
 import Data.Function (flip)
 import Data.List (List(..), concatMap, foldl, fromFoldable, length, reverse, snoc, toUnfoldable)
 import Data.Tuple.Nested (type (/\), (/\))
-import Foreign.Generic (encode, encodeJSON)
-import Global.Unsafe (unsafeStringify)
+import Foreign.Generic (encodeJSON)
 import Halogen (HalogenM)
 import Halogen as H
 import Marlowe.Semantics (AccountId, Case(..), Contract(..), Observation(..), Payee, Timeout, Token, Value, ValueId)
 import Marlowe.Semantics as S
 import Marlowe.Symbolic.Types.Response (Result(..))
 import Network.RemoteData (RemoteData(..))
-import Prelude (Unit, bind, discard, map, pure, unit, ($), (<<<), (+), (/=))
+import Prelude (Unit, bind, discard, map, pure, unit, ($), (+), (/=))
 import Simulation.Types (Action, ChildSlots, ContractPathStep(..), ContractPath, Message(..), ReachabilityAnalysisData(..), State)
 import WebSocket (WebSocketRequestMessage(..))
 
@@ -110,9 +109,7 @@ zipperToContractPath :: ContractZipper -> ContractPath
 zipperToContractPath zipper = zipperToContractPathAux zipper Nil
 
 checkContractForReachability :: forall m. String -> String -> HalogenM State Action ChildSlots Message m Unit
-checkContractForReachability contract state = H.raise (WebsocketMessage msgString)
-  where
-  msgString = unsafeStringify <<< encode $ CheckForWarnings (encodeJSON true) contract state
+checkContractForReachability contract state = H.raise $ WebSocketMessage $ CheckForWarnings (encodeJSON true) contract state
 
 expandSubproblem :: ContractZipper -> (ContractPath /\ Contract)
 expandSubproblem z = zipperToContractPath z /\ closeZipperContract z (Assert FalseObs Close)

marlowe-playground-client/src/Simulation.purs

@@ -113,7 +113,7 @@ handleQuery (ResetContract next) = do
   resetContract
   pure (Just next)
 
-handleQuery (WebsocketResponse response next) = do
+handleQuery (WebSocketResponse response next) = do
   analysisState <- use _analysisState
   case analysisState of
     NoneAsked -> pure (Just next) -- Unrequested response
@@ -283,9 +283,7 @@ handleAction _ AnalyseContract = do
       assign _analysisState (WarningAnalysis Loading)
   where
   checkContractForWarnings contract state = do
-    let
-      msgString = unsafeStringify <<< encode $ CheckForWarnings (encodeJSON false) contract state
-    H.raise (WebsocketMessage msgString)
+    H.raise $ WebSocketMessage $ CheckForWarnings (encodeJSON false) contract state
 
 handleAction _ AnalyseReachabilityContract = do
   currContract <- use _currentContract

marlowe-playground-client/src/Simulation/Types.purs

@@ -10,6 +10,7 @@ import Data.Either (Either(..))
 import Data.Generic.Rep (class Generic)
 import Data.Generic.Rep.Show (genericShow)
 import Data.Lens (Lens', to, view)
+import WebSocket (WebSocketRequestMessage)
 import Data.Lens.NonEmptyList (_Head)
 import Data.Lens.Record (prop)
 import Data.List.NonEmpty as NEL
@@ -234,13 +235,13 @@ data Query a
   = SetEditorText String a
   | ResizeEditor a
   | ResetContract a
-  | WebsocketResponse (RemoteData String Result) a
+  | WebSocketResponse (RemoteData String Result) a
   | HasStarted (Boolean -> a)
   | GetCurrentContract (String -> a)
 
 data Message
   = BlocklyCodeSet String
-  | WebsocketMessage String
+  | WebSocketMessage WebSocketRequestMessage
 
 type ChildSlots
   = ( editorSlot :: H.Slot Monaco.Query Monaco.Message Unit

marlowe-playground-client/src/Types.purs

@@ -3,7 +3,9 @@ module Types where
 import API (RunResult)
 import Analytics (class IsEvent, defaultEvent)
 import Blockly.Types (BlocklyState)
+import Data.Either (Either)
 import Data.Generic.Rep (class Generic)
+import Foreign (MultipleErrors)
 import Data.Generic.Rep.Show (genericShow)
 import Data.Json.JsonEither (JsonEither)
 import Data.Lens (Lens', (^.))
@@ -25,13 +27,15 @@ import Prelude (class Eq, class Show, Unit, eq, show, (<<<), ($))
 import Servant.PureScript.Ajax (AjaxError)
 import Simulation.Types as Simulation
 import Wallet as Wallet
+import WebSocket.Support as WS
+import WebSocket (WebSocketResponseMessage, WebSocketRequestMessage)
 
 ------------------------------------------------------------
 data HQuery a
-  = ReceiveWebsocketMessage String a
+  = ReceiveWebSocketMessage (WS.Output WebSocketResponseMessage) a
 
 data Message
-  = WebsocketMessage String
+  = WebSocketMessage WebSocketRequestMessage
 
 data HAction
   -- Haskell Editor

marlowe-playground-server/app/PSGenerator.hs

@@ -37,10 +37,10 @@ import           Language.Haskell.Interpreter                     (CompilationEr
                                                                    InterpreterResult, SourceCode, Warning)
 import qualified Language.Marlowe.ACTUS.Definitions.ContractTerms as CT
 import           Language.Marlowe.Pretty                          (pretty)
-import           Language.PureScript.Bridge                       (BridgePart, Language (Haskell), PSType, SumType,
-                                                                   TypeInfo (TypeInfo), buildBridge, mkSumType,
-                                                                   psTypeParameters, typeModule, typeName,
-                                                                   writePSTypesWith, (^==))
+import           Language.PureScript.Bridge                       (BridgePart, Language (Haskell), Language (Haskell),
+                                                                   PSType, SumType, TypeInfo (TypeInfo), buildBridge,
+                                                                   genericShow, mkSumType, psTypeParameters, typeModule,
+                                                                   typeName, writePSTypesWith, writePSTypesWith, (^==))
 import           Language.PureScript.Bridge.Builder               (BridgeData)
 import           Language.PureScript.Bridge.CodeGenSwitches       (ForeignOptions (ForeignOptions), defaultSwitch,
                                                                    genForeign)
@@ -109,7 +109,7 @@ myTypes =
     , mkSumType (Proxy @Warning)
     , mkSumType (Proxy @(InterpreterResult A))
     , mkSumType (Proxy @MSRes.Response)
-    , mkSumType (Proxy @MSRes.Result)
+    , (genericShow <*> mkSumType) (Proxy @MSRes.Result)
     , mkSumType (Proxy @MSReq.Request)
     , mkSumType (Proxy @DT.Day)
     , mkSumType (Proxy @CT.ContractTerms)
@@ -127,8 +127,8 @@ myTypes =
     , mkSumType (Proxy @CT.FEB)
     , mkSumType (Proxy @CT.ContractRole)
     , mkSumType (Proxy @CT.ContractType)
-    , mkSumType (Proxy @WebSocketRequestMessage)
-    , mkSumType (Proxy @WebSocketResponseMessage)
+    , (genericShow <*> mkSumType) (Proxy @WebSocketRequestMessage)
+    , (genericShow <*> mkSumType) (Proxy @WebSocketResponseMessage)
     ]
 
 mySettings :: Settings

plutus-playground-client/spago-packages.nix

@@ -41,6 +41,18 @@ let
         installPhase = "ln -s $src $out";
       };
 
+    "aff-coroutines" = pkgs.stdenv.mkDerivation {
+        name = "aff-coroutines";
+        version = "v7.0.0";
+        src = pkgs.fetchgit {
+          url = "https://github.com/purescript-contrib/purescript-aff-coroutines.git";
+          rev = "f2f410f3cc9030487ddadf9ffdaab75ba508bde9";
+          sha256 = "1cbly4m2na5kf3halj68rjy5khydb71gzz0ry323z5h1i0fna2g9";
+        };
+        phases = "installPhase";
+        installPhase = "ln -s $src $out";
+      };
+
     "affjax" = pkgs.stdenv.mkDerivation {
         name = "affjax";
         version = "v10.0.0";
@@ -1197,7 +1209,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";
         };
@@ -1277,6 +1289,18 @@ let
         installPhase = "ln -s $src $out";
       };
 
+    "web-socket" = pkgs.stdenv.mkDerivation {
+        name = "web-socket";
+        version = "v2.0.0";
+        src = pkgs.fetchgit {
+          url = "https://github.com/purescript-web/purescript-web-socket.git";
+          rev = "00f4ab583efb6fc60e0517d782d2ba2a89d8ec66";
+          sha256 = "0kp4rmrqmsjmih7nw7dl75d36pny3ikafnhnfchpc834ap9451zh";
+        };
+        phases = "installPhase";
+        installPhase = "ln -s $src $out";
+      };
+
     "web-storage" = pkgs.stdenv.mkDerivation {
         name = "web-storage";
         version = "v3.0.0";