.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,95 +390,92 @@ 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
+      headState <- holdDyn Idle newState
-      HNRunning actors -> mdo
+      let headStateDom = elClass "div" "text-lg" . text . ("Head State: " <>)
-        let actorNames = Map.keys actors
+      unless (null actors) $ elClass "div" "ml-4 mt-8 mr-4 mb-2 w-full font-black text-green-500" $ dyn_ $ ffor headState $ \case
-        headState <- holdDyn Idle newState
+        Idle -> do
-        let headStateDom = elClass "div" "text-lg" . text . ("Head State: " <>)
+          headStateDom "Idle"
-        unless (null actors) $ elClass "div" "ml-4 mt-8 mr-4 mb-2 w-full font-black text-green-500" $ dyn_ $ ffor headState $ \case
+          elClass "div" "text-green-700 text-sm" $ text "Waiting for participant to init..."
-          Idle -> do
+        Initializing -> do
-            headStateDom "Idle"
+          headStateDom "Initializing"
-            elClass "div" "text-green-700 text-sm" $ text "Waiting for participant to init..."
+          elClass "div" "text-green-700 text-sm" $ text $ "Waiting for commits from: " <> T.intercalate ", " actorNames
-          Initializing -> do
+        Open -> headStateDom "Open"
-            headStateDom "Initializing"
+        Closed _ -> headStateDom "Closed/Contestation period"
-            elClass "div" "text-green-700 text-sm" $ text $ "Waiting for commits from: " <> T.intercalate ", " actorNames
+        StateReadyToFanout -> headStateDom "Ready to fanout"
-          Open -> headStateDom "Open"
+
-          Closed _ -> headStateDom "Closed/Contestation period"
+      newState <- elClass "div" "ml-4 mr-4 overflow-hidden rounded-lg hover:drop-shadow-xl transition-all drop-shadow bg-gray-800" $ mdo
-          StateReadyToFanout -> headStateDom "Ready to fanout"
+        rec
-  
+          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
+
-          rec
+          changeTab <- fmap leftmost $ elClass "div" "w-full flex flex-row justify-start" $ for actorNames $ \name -> do
-            currentTab <- holdDyn (head actorNames) changeTab
+            let
-  
+              isSelected = (== name) <$> currentTab
-            changeTab <- fmap leftmost $ elClass "div" "w-full flex flex-row justify-start" $ for actorNames $ \name -> do
+              mkClasses selected =
-              let
+                T.intercalate " " [ "leading-none p-4 font-bold text-2xl text-gray-100 flex items-center justify-center"
-                isSelected = (== name) <$> currentTab
+                                  , bool "bg-gray-800 text-gray-300 pointer-cursor" "bg-gray-700 text-gray-100" selected
-                mkClasses selected =
+                                  ]
-                  T.intercalate " " [ "leading-none p-4 font-bold text-2xl text-gray-100 flex items-center justify-center"
+            (buttonEl, _) <- elDynClass' "button" (mkClasses <$> isSelected) $ text name
-                                    , bool "bg-gray-800 text-gray-300 pointer-cursor" "bg-gray-700 text-gray-100" selected
+            pure $ name <$ domEvent Click buttonEl
-                                    ]
+        fmap (fmap getFirst . snd) . runEventWriterT $ forM (Map.toList actors) $ \(name, (actorAddress, wsUrl)) -> mdo
-              (buttonEl, _) <- elDynClass' "button" (mkClasses <$> isSelected) $ text name
+              let wsCfg = (WebSocketConfig @t @ClientInput) action never True []
-              pure $ name <$ domEvent Click buttonEl
+              ws <- jsonWebSocket wsUrl wsCfg
-          fmap (fmap getFirst . snd) . runEventWriterT $ forM (Map.toList actors) $ \(name, RunningNode { _rnNodeInfo = nInfo, _rnAddress = actorAddress}) -> mdo
+              let isSelected = (== name) <$> currentTab
-                let wsUrl = apiAddress nInfo
+              let mkClasses selected =
-                let wsCfg = (WebSocketConfig @t @ClientInput) action never True []
+                     T.intercalate " " [ "p-2 bg-gray-700 text-white flex flex-col items-left"
-                ws <- jsonWebSocket wsUrl wsCfg
+                                       , bool "hidden" "" selected
-                let isSelected = (== name) <$> currentTab
+                                       ]
-                let mkClasses selected =
+              (_, action) <- elDynClass "div" (mkClasses <$> isSelected) $ runEventWriterT $ runWithReplace (elClass "div" "text-white" $ text "Connecting to node...") . ffor (_webSocket_open ws) $ \() -> do
-                       T.intercalate " " [ "p-2 bg-gray-700 text-white flex flex-col items-left"
+                let
-                                         , bool "hidden" "" selected
+                  webSocketMessage :: Event t (ServerOutput Aeson.Value) =
-                                         ]
+                    fromMaybe (error "Parsing message from Hydra node failed") <$> _webSocket_recv ws
-                (_, action) <- elDynClass "div" (mkClasses <$> isSelected) $ runEventWriterT $ runWithReplace (elClass "div" "text-white" $ text "Connecting to node...") . ffor (_webSocket_open ws) $ \() -> do
+                  processLog = \case
-                  let
+                    ReadyToCommit {} -> Just Initializing
-                    webSocketMessage :: Event t (ServerOutput Aeson.Value) =
+                    HeadIsOpen {} -> Just Open
-                      fromMaybe (error "Parsing message from Hydra node failed") <$> _webSocket_recv ws
+                    HeadIsClosed _ fanoutTime -> Just (Closed fanoutTime)
-                    processLog = \case
+                    ReadyToFanout {} -> Just StateReadyToFanout
-                      ReadyToCommit {} -> Just Initializing
+                    HeadIsAborted {} -> Just Idle
-                      HeadIsOpen {} -> Just Open
+                    HeadIsFinalized {} -> Just Idle
-                      HeadIsClosed _ fanoutTime -> Just (Closed fanoutTime)
+                    _ -> Nothing
-                      ReadyToFanout {} -> Just StateReadyToFanout
+                let stateChange = fmapMaybe processLog webSocketMessage
-                      HeadIsAborted {} -> Just Idle
+                let
-                      HeadIsFinalized {} -> Just Idle
+
-                      _ -> Nothing
+                myVKeyB :: Behavior t (Maybe T.Text) <-
-                  let stateChange = fmapMaybe processLog webSocketMessage
+                   hold Nothing
-                  let
+                     . fmap Just
-  
+                     . mapMaybe (\case
-                  myVKeyB :: Behavior t (Maybe T.Text) <-
+                                    Greetings (Party vkey') -> Just vkey'
-                     hold Nothing
+                                    _ -> Nothing)
-                       . fmap Just
+                     $ webSocketMessage
-                       . mapMaybe (\case
+                headStateE <- mdo
-                                      Greetings (Party vkey') -> Just vkey'
+                  void $ dyn $ ffor headState $ \case
-                                      _ -> Nothing)
+                    Idle -> idleScreen name
-                       $ webSocketMessage
+                    Initializing -> initializingScreen actorAddress myVKeyB webSocketMessage
-                  headStateE <- mdo
+                    Open -> openScreen hydraProcessHandlesRef name actorNames actorAddress webSocketMessage
-                    void $ dyn $ ffor headState $ \case
+                    Closed fanoutTime -> closedScreen fanoutTime
-                      Idle -> idleScreen name
+                    StateReadyToFanout ->
-                      Initializing -> initializingScreen actorAddress myVKeyB webSocketMessage
+                      tellAction
-                      Open -> openScreen actors name webSocketMessage
+                        . (Fanout <$)
-                      Closed fanoutTime -> closedScreen fanoutTime
+                        <=< 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"
-                      StateReadyToFanout ->
+                  elClass "div" "mt-4" $ do
-                        tellAction
+                    elClass "div" "mb-1 font-semibold text-sm" $ text "Hydra Node Log"
-                          . (Fanout <$)
+                    elClass "div" "p-2 bg-gray-800 rounded-md drop-shadow break-all" $
-                          <=< 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"
+                      el "ul" $ do
-                    elClass "div" "mt-4" $ do
+                      comms <- foldDyn (++) [] $
-                      elClass "div" "mb-1 font-semibold text-sm" $ text "Hydra Node Log"
+                        ((:[]) . ("Rcv: " <>) . toStrict . toLazyText . encodeToTextBuilder . toJSON <$> webSocketMessage)
-                      elClass "div" "p-2 bg-gray-800 rounded-md drop-shadow break-all" $
+                        <>
-                        el "ul" $ do
+                        fmap (fmap (("Snd: " <>) . toStrict . toLazyText . encodeToTextBuilder . toJSON)) action
-                        comms <- foldDyn (++) [] $
+                      dyn_ $ mapM (el "li" . text) <$> comms
-                          ((:[]) . ("Rcv: " <>) . toStrict . toLazyText . encodeToTextBuilder . toJSON <$> webSocketMessage)
+                  pure stateChange
-                          <>
+                lift $ tellEvent (First <$> headStateE)
-                          fmap (fmap (("Snd: " <>) . toStrict . toLazyText . encodeToTextBuilder . toJSON)) action
+              pure ()
-                        dyn_ $ mapM (el "li" . text) <$> comms
+      pure ()
-                    pure stateChange
-                  lift $ tellEvent (First <$> headStateE)
-                pure ()
-        pure ()
 
 filterUtxos :: Address -> WholeUTXO -> WholeUTXO
 filterUtxos addr = Map.filter ((== addr) . HT.address)
@@ -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)