Reflex-ify Hydra network managemement + make start async

src/Main.hs

@@ -42,7 +42,6 @@ import qualified Hydra.Types as HT
 import Data.Maybe (fromJust, fromMaybe)
 import Data.Aeson.Types (parseMaybe)
 import System.IO (IOMode(WriteMode), openFile)
-import Data.IORef (readIORef, writeIORef, IORef, newIORef)
 import Hydra.Types
 import Data.Text (Text)
 import qualified Data.ByteString.Lazy.Char8 as ByteString.Char8
@@ -181,10 +180,7 @@ cardanoNodeCreateProcess =
 
 runHydraDemo :: (MonadIO m)
   => HydraDemo
-  -> m (Map Text ( ProcessHandle
+  -> m RunningNodes
-                   , Address -- Cardano address
-                   , HydraNodeInfo
-                   ))
 runHydraDemo nodes = do
   keysAddresses <- forM nodes $ \(actorSeed, fuelSeed) -> do
     keys@(HydraKeyInfo (KeyPair _ vk) _) <- generateKeys
@@ -196,14 +192,9 @@ runHydraDemo nodes = do
   hstxid <- publishReferenceScripts
   handles <- standupDemoHydraNetwork hstxid (fmap fst keysAddresses)
   liftIO . putStrLn $ [i|Hydra Network Running for nodes #{Map.keys nodes}|]
-  pure $ Map.merge Map.dropMissing Map.dropMissing (Map.zipWithMatched (\_ addr (handle, nodeInfo) -> (handle, addr, nodeInfo))) (fmap snd keysAddresses) handles
+  pure $ Map.merge Map.dropMissing Map.dropMissing (Map.zipWithMatched (\_ addr (handle, nodeInfo) -> RunningNode handle addr nodeInfo)) (fmap snd keysAddresses) handles
 
 
-type State = Map Text ( ProcessHandle
-                             , Address -- Cardano address
-                             , HydraNodeInfo
-                             )
-
 headElement :: forall t m. ( TriggerEvent t m, DomBuilder t m) =>m ()
 headElement = do
     el "title" $ text "Hydra Head Demo"
@@ -217,42 +208,71 @@ main =  liftIO $ do
    threadDelay $ seconds 3
    mainWidgetWithHead headElement app
 
-makeTx :: () => IORef State -> Text
+makeTx :: () => RunningNodes -> Text
                   -> Map TxIn TxInInfo -> Lovelace -> Text -> IO Text
-makeTx hydraProcessHandlesRef fromName utxos lovelace toName = do
+makeTx actors fromName utxos lovelace toName = do
   let lovelaceUtxos = mapMaybe (Map.lookup "lovelace" . HT.value) utxos
-  actors <- readIORef hydraProcessHandlesRef
   jsonStr <-
     buildSignedHydraTx
-      (_signingKey . _cardanoKeys . _keys . (\(_, _, hn) -> hn) $ actors ! fromName)
+      (_signingKey . _cardanoKeys . _keys . _rnNodeInfo $ actors ! fromName)
-      ((\(_, addr, _) -> addr) $ actors ! fromName)
+      (_rnAddress $ actors ! fromName)
-      ((\(_, addr, _) -> addr) $ actors ! toName)
+      (_rnAddress $ actors ! toName)
       lovelaceUtxos
       lovelace
   let jsonTx :: Aeson.Value = fromMaybe (error "Failed to parse TX") . Aeson.decode . ByteString.Char8.pack $ jsonStr
   pure . fromJust . parseMaybe (withObject "signed tx" (.: "cborHex")) $ jsonTx
 
-startDemo :: MonadIO m => IORef State -> HydraDemo -> m RunningNodes
+
-startDemo hydraProcessHandlesRef demo = do
+-- | Stopped demo desired state.
-  liftIO (mapM (terminateProcess . (\(hndl, _, _) -> hndl)) =<< readIORef hydraProcessHandlesRef)
+stoppedDemo :: HydraDemo
-  nodeInfos <- runHydraDemo demo
+stoppedDemo = mempty
-  liftIO . writeIORef hydraProcessHandlesRef $ nodeInfos
+
-  actorList :: RunningNodes <- forM nodeInfos $ \(_, addr, nInfo) -> do
+data HydraNetStatus = HNNotRunning | HNStarting | HNRunning { _hnRunningNodes :: RunningNodes }
-    pure
+
-      ( addr,
+-- | Start stop demo. When demo is 'mempty' the demo is stopped. If
-        [iii|ws://localhost:#{_apiPort nInfo}|]
+-- status is 'HNStarting' nothing is done.
-      )
+manageDemo ::
-  pure actorList
+  forall t m.
+  ( MonadIO (Performable m),
+    PerformEvent t m,
+    TriggerEvent t m,
+    MonadHold t m,
+    MonadFix m
+  ) =>
+  Event t HydraDemo ->
+  m (Dynamic t HydraNetStatus)
+manageDemo desiredStateE = mdo
+  let startStopDemoE = attachWithMaybe (\status demo ->
+                                          case status of
+                                            HNStarting -> Nothing
+                                            _ -> Just demo)
+                       (current statusDyn)
+                       desiredStateE
+  newRunningE <- performEventAsync . ffor (attach (current statusDyn) startStopDemoE) $ \(status, demo) returnAction -> do
+    case status of
+      HNRunning ns -> liftIO . mapM_ (terminateProcess . _rnProcessHandle) $ ns
+      _ -> pure ()
+    unless (demo == stoppedDemo) $
+      liftIO $ void $ forkIO $ returnAction <=< runHydraDemo $ demo
+  statusDyn <- holdDyn HNNotRunning $ leftmost [ bool HNStarting HNNotRunning . (== stoppedDemo) <$> desiredStateE
+                                               , HNRunning <$> newRunningE
+                                               ]
+  pure statusDyn
+
+
+apiAddress :: HydraNodeInfo -> Text
+apiAddress nInfo = [__i|ws://localhost:#{_apiPort nInfo}|]
 
 -- | Friendly name for a Hydra node.
 type DemoNodeName = Text
 
--- | WebSocket URL
+data RunningNode = RunningNode
-type ApiUrl = Text
+  { _rnProcessHandle :: ProcessHandle
+  , _rnAddress :: Address
+  , _rnNodeInfo :: HydraNodeInfo
+  }
 
-type RunningNodes = Map DemoNodeName ( Address -- Cardano address
+type RunningNodes = Map DemoNodeName RunningNode
-                                     , ApiUrl
-                                     )
 
 type HydraDemo =  Map
                   DemoNodeName
@@ -260,7 +280,6 @@ type HydraDemo =  Map
                   , Lovelace -- Seed for fuel
                   )
 
-
 seconds :: Int -> Int
 seconds = (* 1000000)
 
@@ -352,33 +371,32 @@ startStopDemoControls ::
   ( DomBuilder t m,
     MonadFix m,
     PostBuild t m,
-    MonadHold t m, MonadIO (Performable m), PerformEvent t m) =>
+    MonadHold t m,
-  IORef State ->
+    MonadIO (Performable m),
-  m (Event t RunningNodes)
+    PerformEvent t m,
-startStopDemoControls hydraProcessHandlesRef = mdo
+    TriggerEvent t m
-  headRunning <- toggle False headStartedOrStoppedE
+  ) =>
-  ((), demoConfig) <- runDynamicWriterT $ dyn_ (bool (tellDyn =<< demoSettings alicebobcarolDemo) blank <$> headRunning)
+  m (Dynamic t HydraNetStatus)
-  startStopHeadE <- buttonClass ((\running ->
+startStopDemoControls = mdo
-                                    let color :: Text = bool "green" "red" running
+  demoStatusDyn <- manageDemo desiredDemoStateE
-                                    in [__i|bg-#{color}-500 hover:bg-#{color}-400 active:bg-#{color}-300
+  ((), demoConfigDyn) <- runDynamicWriterT $ dyn_ . ffor demoStatusDyn $ \case
-                                           text-white font-bold text-xl m-4 px-4 py-2 rounded-md|]
+    HNNotRunning -> tellDyn =<< demoSettings alicebobcarolDemo
-                                      :: Text)
+    _ -> blank
-                                  <$> headRunning)
+  let btnBaseCls = "text-white font-bold text-xl m-4 px-4 py-2 rounded-md" :: Text
-                    $ dynText (bool "Start head" "Stop head" <$> headRunning)
+  let btnStartStopCls (color :: Text) =
-  let startStopWithConfE = current demoConfig <@ startStopHeadE
+        [__i|bg-#{color}-500 hover:bg-#{color}-400 active:bg-#{color}-300 #{btnBaseCls}|]
-  headStartedOrStoppedE <- performEvent $
+  desiredDemoStateE <- switchHold never <=< dyn . ffor demoStatusDyn $ \case
-    -- Start with mempty to stop the demo:
+    HNNotRunning ->
-    (\running conf -> startDemo hydraProcessHandlesRef $ bool conf mempty running)
+      fmap (pushAlways (const (sample (current demoConfigDyn)))) $
-    <$> current headRunning
+        buttonClass (pure $ btnStartStopCls "green") $ text "Start head"
-    <@> startStopWithConfE
+    HNStarting -> do
-  let headStartingDom conf =
+      _ <- elAttr' "button" ("class" =: (btnStartStopCls "gray" <> " cursor-not-allowed")
-        if Map.null conf
+                              <> "disabled" =: "true")
-        then blank
+                       $ text "Starting head..."
-        else elClass "div" "text-white text-2xl m-4" $ text "Head starting..."
+      pure never
-  void $ runWithReplace blank $ leftmost [ headStartingDom <$> startStopWithConfE
+    HNRunning _ -> do
-                                         , blank <$ headStartedOrStoppedE
+      fmap (stoppedDemo <$) $ buttonClass (pure $ btnStartStopCls "red") $ text "Stop head"
-                                         ]
+  pure demoStatusDyn
-  pure headStartedOrStoppedE
 
 
 app ::
@@ -390,92 +408,95 @@ app ::
     MonadHold t m, PerformEvent t m, TriggerEvent t m) =>
   m ()
 app = do
- hydraProcessHandlesRef :: IORef State <- liftIO (newIORef mempty)
  elClass "div" "w-screen h-screen bg-gray-900 overflow-y-scroll overflow-x-hidden" $ do
   elClass "div" "p-4 m-4 text-white text-5xl font-bold" $ text "Hydra Proof Of Concept Demo"
   mdo
-    headStartedE <- startStopDemoControls hydraProcessHandlesRef
+    headNetStatusDyn <- startStopDemoControls
-    void $ runWithReplace blank $ ffor headStartedE $ \actors -> mdo
+    void $ dyn_ . ffor headNetStatusDyn $ \case
-      let actorNames = ffor (Map.toList actors) $ \(name, (_,_)) -> name
+      HNNotRunning -> blank
-      headState <- holdDyn Idle newState
+      HNStarting -> blank
-      let headStateDom = elClass "div" "text-lg" . text . ("Head State: " <>)
+      HNRunning actors -> mdo
-      unless (null actors) $ elClass "div" "ml-4 mt-8 mr-4 mb-2 w-full font-black text-green-500" $ dyn_ $ ffor headState $ \case
+        let actorNames = Map.keys actors
-        Idle -> do
+        headState <- holdDyn Idle newState
-          headStateDom "Idle"
+        let headStateDom = elClass "div" "text-lg" . text . ("Head State: " <>)
-          elClass "div" "text-green-700 text-sm" $ text "Waiting for participant to init..."
+        unless (null actors) $ elClass "div" "ml-4 mt-8 mr-4 mb-2 w-full font-black text-green-500" $ dyn_ $ ffor headState $ \case
-        Initializing -> do
+          Idle -> do
-          headStateDom "Initializing"
+            headStateDom "Idle"
-          elClass "div" "text-green-700 text-sm" $ text $ "Waiting for commits from: " <> T.intercalate ", " actorNames
+            elClass "div" "text-green-700 text-sm" $ text "Waiting for participant to init..."
-        Open -> headStateDom "Open"
+          Initializing -> do
-        Closed _ -> headStateDom "Closed/Contestation period"
+            headStateDom "Initializing"
-        StateReadyToFanout -> headStateDom "Ready to fanout"
+            elClass "div" "text-green-700 text-sm" $ text $ "Waiting for commits from: " <> T.intercalate ", " actorNames
-
+          Open -> headStateDom "Open"
-      newState <- elClass "div" "ml-4 mr-4 overflow-hidden rounded-lg hover:drop-shadow-xl transition-all drop-shadow bg-gray-800" $ mdo
+          Closed _ -> headStateDom "Closed/Contestation period"
-        rec
+          StateReadyToFanout -> headStateDom "Ready to fanout"
-          currentTab <- holdDyn (head actorNames) changeTab
+  
-
+        newState <- elClass "div" "ml-4 mr-4 overflow-hidden rounded-lg hover:drop-shadow-xl transition-all drop-shadow bg-gray-800" $ mdo
-          changeTab <- fmap leftmost $ elClass "div" "w-full flex flex-row justify-start" $ for actorNames $ \name -> do
+          rec
-            let
+            currentTab <- holdDyn (head actorNames) changeTab
-              isSelected = (== name) <$> currentTab
+  
-              mkClasses selected =
+            changeTab <- fmap leftmost $ elClass "div" "w-full flex flex-row justify-start" $ for actorNames $ \name -> do
-                T.intercalate " " [ "leading-none p-4 font-bold text-2xl text-gray-100 flex items-center justify-center"
+              let
-                                  , bool "bg-gray-800 text-gray-300 pointer-cursor" "bg-gray-700 text-gray-100" selected
+                isSelected = (== name) <$> currentTab
-                                  ]
+                mkClasses selected =
-            (buttonEl, _) <- elDynClass' "button" (mkClasses <$> isSelected) $ text name
+                  T.intercalate " " [ "leading-none p-4 font-bold text-2xl text-gray-100 flex items-center justify-center"
-            pure $ name <$ domEvent Click buttonEl
+                                    , bool "bg-gray-800 text-gray-300 pointer-cursor" "bg-gray-700 text-gray-100" selected
-        fmap (fmap getFirst . snd) . runEventWriterT $ forM (Map.toList actors) $ \(name, (actorAddress, wsUrl)) -> mdo
+                                    ]
-              let wsCfg = (WebSocketConfig @t @ClientInput) action never True []
+              (buttonEl, _) <- elDynClass' "button" (mkClasses <$> isSelected) $ text name
-              ws <- jsonWebSocket wsUrl wsCfg
+              pure $ name <$ domEvent Click buttonEl
-              let isSelected = (== name) <$> currentTab
+          fmap (fmap getFirst . snd) . runEventWriterT $ forM (Map.toList actors) $ \(name, RunningNode { _rnNodeInfo = nInfo, _rnAddress = actorAddress}) -> mdo
-              let mkClasses selected =
+                let wsUrl = apiAddress nInfo
-                     T.intercalate " " [ "p-2 bg-gray-700 text-white flex flex-col items-left"
+                let wsCfg = (WebSocketConfig @t @ClientInput) action never True []
-                                       , bool "hidden" "" selected
+                ws <- jsonWebSocket wsUrl wsCfg
-                                       ]
+                let isSelected = (== name) <$> currentTab
-              (_, action) <- elDynClass "div" (mkClasses <$> isSelected) $ runEventWriterT $ runWithReplace (elClass "div" "text-white" $ text "Connecting to node...") . ffor (_webSocket_open ws) $ \() -> do
+                let mkClasses selected =
-                let
+                       T.intercalate " " [ "p-2 bg-gray-700 text-white flex flex-col items-left"
-                  webSocketMessage :: Event t (ServerOutput Aeson.Value) =
+                                         , bool "hidden" "" selected
-                    fromMaybe (error "Parsing message from Hydra node failed") <$> _webSocket_recv ws
+                                         ]
-                  processLog = \case
+                (_, action) <- elDynClass "div" (mkClasses <$> isSelected) $ runEventWriterT $ runWithReplace (elClass "div" "text-white" $ text "Connecting to node...") . ffor (_webSocket_open ws) $ \() -> do
-                    ReadyToCommit {} -> Just Initializing
+                  let
-                    HeadIsOpen {} -> Just Open
+                    webSocketMessage :: Event t (ServerOutput Aeson.Value) =
-                    HeadIsClosed _ fanoutTime -> Just (Closed fanoutTime)
+                      fromMaybe (error "Parsing message from Hydra node failed") <$> _webSocket_recv ws
-                    ReadyToFanout {} -> Just StateReadyToFanout
+                    processLog = \case
-                    HeadIsAborted {} -> Just Idle
+                      ReadyToCommit {} -> Just Initializing
-                    HeadIsFinalized {} -> Just Idle
+                      HeadIsOpen {} -> Just Open
-                    _ -> Nothing
+                      HeadIsClosed _ fanoutTime -> Just (Closed fanoutTime)
-                let stateChange = fmapMaybe processLog webSocketMessage
+                      ReadyToFanout {} -> Just StateReadyToFanout
-                let
+                      HeadIsAborted {} -> Just Idle
-
+                      HeadIsFinalized {} -> Just Idle
-                myVKeyB :: Behavior t (Maybe T.Text) <-
+                      _ -> Nothing
-                   hold Nothing
+                  let stateChange = fmapMaybe processLog webSocketMessage
-                     . fmap Just
+                  let
-                     . mapMaybe (\case
+  
-                                    Greetings (Party vkey') -> Just vkey'
+                  myVKeyB :: Behavior t (Maybe T.Text) <-
-                                    _ -> Nothing)
+                     hold Nothing
-                     $ webSocketMessage
+                       . fmap Just
-                headStateE <- mdo
+                       . mapMaybe (\case
-                  void $ dyn $ ffor headState $ \case
+                                      Greetings (Party vkey') -> Just vkey'
-                    Idle -> idleScreen name
+                                      _ -> Nothing)
-                    Initializing -> initializingScreen actorAddress myVKeyB webSocketMessage
+                       $ webSocketMessage
-                    Open -> openScreen hydraProcessHandlesRef name actorNames actorAddress webSocketMessage
+                  headStateE <- mdo
-                    Closed fanoutTime -> closedScreen fanoutTime
+                    void $ dyn $ ffor headState $ \case
-                    StateReadyToFanout ->
+                      Idle -> idleScreen name
-                      tellAction
+                      Initializing -> initializingScreen actorAddress myVKeyB webSocketMessage
-                        . (Fanout <$)
+                      Open -> openScreen actors name webSocketMessage
-                        <=< buttonClass "bg-green-400 hover:bg-green-400 active:bg-green-200 text-white font-bold text-xl my-2 px-4 py-2 rounded-md w-32" $ text "Do fanout"
+                      Closed fanoutTime -> closedScreen fanoutTime
-                  elClass "div" "mt-4" $ do
+                      StateReadyToFanout ->
-                    elClass "div" "mb-1 font-semibold text-sm" $ text "Hydra Node Log"
+                        tellAction
-                    elClass "div" "p-2 bg-gray-800 rounded-md drop-shadow break-all" $
+                          . (Fanout <$)
-                      el "ul" $ do
+                          <=< buttonClass "bg-green-400 hover:bg-green-400 active:bg-green-200 text-white font-bold text-xl my-2 px-4 py-2 rounded-md w-32" $ text "Do fanout"
-                      comms <- foldDyn (++) [] $
+                    elClass "div" "mt-4" $ do
-                        ((:[]) . ("Rcv: " <>) . toStrict . toLazyText . encodeToTextBuilder . toJSON <$> webSocketMessage)
+                      elClass "div" "mb-1 font-semibold text-sm" $ text "Hydra Node Log"
-                        <>
+                      elClass "div" "p-2 bg-gray-800 rounded-md drop-shadow break-all" $
-                        fmap (fmap (("Snd: " <>) . toStrict . toLazyText . encodeToTextBuilder . toJSON)) action
+                        el "ul" $ do
-                      dyn_ $ mapM (el "li" . text) <$> comms
+                        comms <- foldDyn (++) [] $
-                  pure stateChange
+                          ((:[]) . ("Rcv: " <>) . toStrict . toLazyText . encodeToTextBuilder . toJSON <$> webSocketMessage)
-                lift $ tellEvent (First <$> headStateE)
+                          <>
-              pure ()
+                          fmap (fmap (("Snd: " <>) . toStrict . toLazyText . encodeToTextBuilder . toJSON)) action
-      pure ()
+                        dyn_ $ mapM (el "li" . text) <$> comms
+                    pure stateChange
+                  lift $ tellEvent (First <$> headStateE)
+                pure ()
+        pure ()
 
 filterUtxos :: Address -> WholeUTXO -> WholeUTXO
 filterUtxos addr = Map.filter ((== addr) . HT.address)
@@ -501,13 +522,11 @@ initializingScreen ::
   m ()
 initializingScreen actorAddress myVKeyB webSocketMessage = do
   elClass "div" "p-2 flex flex-col" $ do
-    -- TODO: did not use performEvent here
+    -- TODO: did not use performEvent here so this will block the UI until UTXOs are queried
-    newUTXOs <- liftIO $ queryAddressUTXOs actorAddress -- fmapMaybe eitherToMaybe <$> (undefined . (DemoApi_GetActorUTXO actorAddress <$) =<< getPostBuild)
+    newUTXOs <- liftIO $ queryAddressUTXOs actorAddress
     let commitSelection doCommit = do
           (_, currentSet) <-
             runDynamicWriterT $ (tellDyn <=< utxoPicker True) newUTXOs
---              runWithReplace (elClass "div" "p-4 bg-gray-800 rounded mb-2" $ text $ "Getting " <> name <> "'s UTXOs...") $
---                (tellDyn <=< utxoPicker True) <$> newUTXOs
           tellAction $ fmap (Commit . fromMaybe mempty) $ current currentSet <@ doCommit
     let hasCommitted =
           attachWithMaybe
@@ -536,6 +555,7 @@ initializingScreen actorAddress myVKeyB webSocketMessage = do
     pure ()
 
 
+-- TODO: the names are passed in multiple times, the actorAddress can be found in twice as well
 openScreen ::
   ( EventWriter t [ClientInput] m,
     DomBuilder t m,
@@ -543,13 +563,13 @@ openScreen ::
     MonadHold t m,
     PostBuild t m,
     MonadIO (Performable m), PerformEvent t m) =>
-  IORef State ->
+  RunningNodes ->
   Text ->
-  [Text] ->
-  Address ->
   Event t (ServerOutput tx) ->
   m ()
-openScreen hydraProcessHandlesRef name actorNames actorAddress webSocketMessage = do
+openScreen actors name webSocketMessage = do
+  let actorNames = Map.keys actors
+  let actorAddress = _rnAddress (actors ! name)
   -- Get your UTxOs on page load and when we observe a transaction
   tellAction . (GetUTxO <$)
     . ( ( void $
@@ -602,7 +622,7 @@ openScreen hydraProcessHandlesRef name actorNames actorAddress webSocketMessage
       elClass "div" "flex" $ do
         signedTxE <-
           performEvent . fmap liftIO $
-            makeTx hydraProcessHandlesRef name
+            makeTx actors name
               <$> current currentSet
               -- NOTE/TODO(skylar): This is just to default to the minimum
               <*> current (fromMaybe 1000000 <$> lovelaceDyn)