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,13 +408,15 @@ 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
+      HNStarting -> blank
+      HNRunning actors -> mdo
+        let actorNames = Map.keys actors
         headState <- holdDyn Idle newState
         let headStateDom = elClass "div" "text-lg" . text . ("Head State: " <>)
         unless (null actors) $ elClass "div" "ml-4 mt-8 mr-4 mb-2 w-full font-black text-green-500" $ dyn_ $ ffor headState $ \case
@@ -423,7 +443,8 @@ app = do
                                     ]
               (buttonEl, _) <- elDynClass' "button" (mkClasses <$> isSelected) $ text name
               pure $ name <$ domEvent Click buttonEl
-        fmap (fmap getFirst . snd) . runEventWriterT $ forM (Map.toList actors) $ \(name, (actorAddress, wsUrl)) -> mdo
+          fmap (fmap getFirst . snd) . runEventWriterT $ forM (Map.toList actors) $ \(name, RunningNode { _rnNodeInfo = nInfo, _rnAddress = actorAddress}) -> mdo
+                let wsUrl = apiAddress nInfo
                 let wsCfg = (WebSocketConfig @t @ClientInput) action never True []
                 ws <- jsonWebSocket wsUrl wsCfg
                 let isSelected = (== name) <$> currentTab
@@ -457,7 +478,7 @@ app = do
                     void $ dyn $ ffor headState $ \case
                       Idle -> idleScreen name
                       Initializing -> initializingScreen actorAddress myVKeyB webSocketMessage
-                    Open -> openScreen hydraProcessHandlesRef name actorNames actorAddress webSocketMessage
+                      Open -> openScreen actors name webSocketMessage
                       Closed fanoutTime -> closedScreen fanoutTime
                       StateReadyToFanout ->
                         tellAction
@@ -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)