.gitignore

@@ -1,4 +0,0 @@
-# Directories produced by demo
-demo-logs/
-tmp/
-devnet/

README.md

@@ -8,11 +8,8 @@ It allows starting and closing a head with an arbitrary number of nodes, each wi
 To run the demo enter a Nix shell and run it with `cabal`:
 
 ```
-nix-shell -A shells.ghc default.nix --option substituters "https://cache.nixos.org https://cache.iog.io https://nixcache.reflex-frp.org" --option trusted-public-keys "cache.nixos.org-1:6NCHdD59X431o0gWypbMrAURkbJ16ZPMQFGspcDShjY= hydra.iohk.io:f/Ea+s+dFdN+3Y/G+FDgSq+a5NEWhJGzdjvKNGv0/EQ= ryantrinkle.com-1:JJiAKaRv9mWgpVAz8dwewnZe0AzzEAzPkagE9SP5NWI="
+ $ nix-shell -A shells.ghc default.nix
-
+ $ cabal run
-cabal run
 ```
 
-The demo can then be viewed in **Chrome**(*Chrome must be used at this time because of a limitation in JSaddle*) at `http://localhost:3003/`.
+The demo can then be viewed in Chrome at `http://localhost:3003/`.
-
-![](./demo.png)

src/Main.hs

@@ -42,6 +42,7 @@ 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
@@ -180,7 +181,10 @@ cardanoNodeCreateProcess =
 
 runHydraDemo :: (MonadIO m)
   => HydraDemo
-  -> m RunningNodes
+  -> m (Map Text ( ProcessHandle
+                   , Address -- Cardano address
+                   , HydraNodeInfo
+                   ))
 runHydraDemo nodes = do
   keysAddresses <- forM nodes $ \(actorSeed, fuelSeed) -> do
     keys@(HydraKeyInfo (KeyPair _ vk) _) <- generateKeys
@@ -192,9 +196,14 @@ 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) -> RunningNode handle addr nodeInfo)) (fmap snd keysAddresses) handles
+  pure $ Map.merge Map.dropMissing Map.dropMissing (Map.zipWithMatched (\_ addr (handle, nodeInfo) -> (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"
@@ -208,71 +217,42 @@ main =  liftIO $ do
    threadDelay $ seconds 3
    mainWidgetWithHead headElement app
 
-makeTx :: () => RunningNodes -> Text
+makeTx :: () => IORef State -> Text
                   -> Map TxIn TxInInfo -> Lovelace -> Text -> IO Text
-makeTx actors fromName utxos lovelace toName = do
+makeTx hydraProcessHandlesRef fromName utxos lovelace toName = do
   let lovelaceUtxos = mapMaybe (Map.lookup "lovelace" . HT.value) utxos
+  actors <- readIORef hydraProcessHandlesRef
   jsonStr <-
     buildSignedHydraTx
-      (_signingKey . _cardanoKeys . _keys . _rnNodeInfo $ actors ! fromName)
+      (_signingKey . _cardanoKeys . _keys . (\(_, _, hn) -> hn) $ actors ! fromName)
-      (_rnAddress $ actors ! fromName)
+      ((\(_, addr, _) -> addr) $ actors ! fromName)
-      (_rnAddress $ actors ! toName)
+      ((\(_, addr, _) -> addr) $ 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
--- | Stopped demo desired state.
+startDemo hydraProcessHandlesRef demo = do
-stoppedDemo :: HydraDemo
+  liftIO (mapM (terminateProcess . (\(hndl, _, _) -> hndl)) =<< readIORef hydraProcessHandlesRef)
-stoppedDemo = mempty
+  nodeInfos <- runHydraDemo demo
-
+  liftIO . writeIORef hydraProcessHandlesRef $ nodeInfos
-data HydraNetStatus = HNNotRunning | HNStarting | HNRunning { _hnRunningNodes :: RunningNodes }
+  actorList :: RunningNodes <- forM nodeInfos $ \(_, addr, nInfo) -> do
-
+    pure
--- | Start stop demo. When demo is 'mempty' the demo is stopped. If
+      ( addr,
--- status is 'HNStarting' nothing is done.
+        [iii|ws://localhost:#{_apiPort nInfo}|]
-manageDemo ::
+      )
-  forall t m.
+  pure actorList
-  ( 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
 
-data RunningNode = RunningNode
+-- | WebSocket URL
-  { _rnProcessHandle :: ProcessHandle
+type ApiUrl = Text
-  , _rnAddress :: Address
-  , _rnNodeInfo :: HydraNodeInfo
-  }
 
-type RunningNodes = Map DemoNodeName RunningNode
+type RunningNodes = Map DemoNodeName ( Address -- Cardano address
+                                     , ApiUrl
+                                     )
 
 type HydraDemo =  Map
                   DemoNodeName
@@ -280,6 +260,7 @@ type HydraDemo =  Map
                   , Lovelace -- Seed for fuel
                   )
 
+
 seconds :: Int -> Int
 seconds = (* 1000000)
 
@@ -371,32 +352,33 @@ startStopDemoControls ::
   ( DomBuilder t m,
     MonadFix m,
     PostBuild t m,
-    MonadHold t m,
+    MonadHold t m, MonadIO (Performable m), PerformEvent t m) =>
-    MonadIO (Performable m),
+  IORef State ->
-    PerformEvent t m,
+  m (Event t RunningNodes)
-    TriggerEvent t m
+startStopDemoControls hydraProcessHandlesRef = mdo
-  ) =>
+  headRunning <- toggle False headStartedOrStoppedE
-  m (Dynamic t HydraNetStatus)
+  ((), demoConfig) <- runDynamicWriterT $ dyn_ (bool (tellDyn =<< demoSettings alicebobcarolDemo) blank <$> headRunning)
-startStopDemoControls = mdo
+  startStopHeadE <- buttonClass ((\running ->
-  demoStatusDyn <- manageDemo desiredDemoStateE
+                                    let color :: Text = bool "green" "red" running
-  ((), demoConfigDyn) <- runDynamicWriterT $ dyn_ . ffor demoStatusDyn $ \case
+                                    in [__i|bg-#{color}-500 hover:bg-#{color}-400 active:bg-#{color}-300
-    HNNotRunning -> tellDyn =<< demoSettings alicebobcarolDemo
+                                           text-white font-bold text-xl m-4 px-4 py-2 rounded-md|]
-    _ -> blank
+                                      :: Text)
-  let btnBaseCls = "text-white font-bold text-xl m-4 px-4 py-2 rounded-md" :: Text
+                                  <$> headRunning)
-  let btnStartStopCls (color :: Text) =
+                    $ dynText (bool "Start head" "Stop head" <$> headRunning)
-        [__i|bg-#{color}-500 hover:bg-#{color}-400 active:bg-#{color}-300 #{btnBaseCls}|]
+  let startStopWithConfE = current demoConfig <@ startStopHeadE
-  desiredDemoStateE <- switchHold never <=< dyn . ffor demoStatusDyn $ \case
+  headStartedOrStoppedE <- performEvent $
-    HNNotRunning ->
+    -- Start with mempty to stop the demo:
-      fmap (pushAlways (const (sample (current demoConfigDyn)))) $
+    (\running conf -> startDemo hydraProcessHandlesRef $ bool conf mempty running)
-        buttonClass (pure $ btnStartStopCls "green") $ text "Start head"
+    <$> current headRunning
-    HNStarting -> do
+    <@> startStopWithConfE
-      _ <- elAttr' "button" ("class" =: (btnStartStopCls "gray" <> " cursor-not-allowed")
+  let headStartingDom conf =
-                              <> "disabled" =: "true")
+        if Map.null conf
-                       $ text "Starting head..."
+        then blank
-      pure never
+        else elClass "div" "text-white text-2xl m-4" $ text "Head starting..."
-    HNRunning _ -> do
+  void $ runWithReplace blank $ leftmost [ headStartingDom <$> startStopWithConfE
-      fmap (stoppedDemo <$) $ buttonClass (pure $ btnStartStopCls "red") $ text "Stop head"
+                                         , blank <$ headStartedOrStoppedE
-  pure demoStatusDyn
+                                         ]
+  pure headStartedOrStoppedE
 
 
 app ::
@@ -408,15 +390,13 @@ 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
-    headNetStatusDyn <- startStopDemoControls
+    headStartedE <- startStopDemoControls hydraProcessHandlesRef
-    void $ dyn_ . ffor headNetStatusDyn $ \case
+    void $ runWithReplace blank $ ffor headStartedE $ \actors -> mdo
-      HNNotRunning -> blank
+      let actorNames = ffor (Map.toList actors) $ \(name, (_,_)) -> name
-      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
@@ -443,8 +423,7 @@ app = do
                                   ]
             (buttonEl, _) <- elDynClass' "button" (mkClasses <$> isSelected) $ text name
             pure $ name <$ domEvent Click buttonEl
-          fmap (fmap getFirst . snd) . runEventWriterT $ forM (Map.toList actors) $ \(name, RunningNode { _rnNodeInfo = nInfo, _rnAddress = actorAddress}) -> mdo
+        fmap (fmap getFirst . snd) . runEventWriterT $ forM (Map.toList actors) $ \(name, (actorAddress, wsUrl)) -> mdo
-                let wsUrl = apiAddress nInfo
               let wsCfg = (WebSocketConfig @t @ClientInput) action never True []
               ws <- jsonWebSocket wsUrl wsCfg
               let isSelected = (== name) <$> currentTab
@@ -478,7 +457,7 @@ app = do
                   void $ dyn $ ffor headState $ \case
                     Idle -> idleScreen name
                     Initializing -> initializingScreen actorAddress myVKeyB webSocketMessage
-                      Open -> openScreen actors name webSocketMessage
+                    Open -> openScreen hydraProcessHandlesRef name actorNames actorAddress webSocketMessage
                     Closed fanoutTime -> closedScreen fanoutTime
                     StateReadyToFanout ->
                       tellAction
@@ -522,11 +501,13 @@ initializingScreen ::
   m ()
 initializingScreen actorAddress myVKeyB webSocketMessage = do
   elClass "div" "p-2 flex flex-col" $ do
-    -- TODO: did not use performEvent here so this will block the UI until UTXOs are queried
+    -- TODO: did not use performEvent here
-    newUTXOs <- liftIO $ queryAddressUTXOs actorAddress
+    newUTXOs <- liftIO $ queryAddressUTXOs actorAddress -- fmapMaybe eitherToMaybe <$> (undefined . (DemoApi_GetActorUTXO actorAddress <$) =<< getPostBuild)
     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
@@ -555,7 +536,6 @@ 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,
@@ -563,13 +543,13 @@ openScreen ::
     MonadHold t m,
     PostBuild t m,
     MonadIO (Performable m), PerformEvent t m) =>
-  RunningNodes ->
+  IORef State ->
   Text ->
+  [Text] ->
+  Address ->
   Event t (ServerOutput tx) ->
   m ()
-openScreen actors name webSocketMessage = do
+openScreen hydraProcessHandlesRef name actorNames actorAddress 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 $
@@ -622,7 +602,7 @@ openScreen actors name webSocketMessage = do
       elClass "div" "flex" $ do
         signedTxE <-
           performEvent . fmap liftIO $
-            makeTx actors name
+            makeTx hydraProcessHandlesRef name
               <$> current currentSet
               -- NOTE/TODO(skylar): This is just to default to the minimum
               <*> current (fromMaybe 1000000 <$> lovelaceDyn)