lodewallet/hydra-demo
21
0
Fork 0
Code Issues Pull Requests Projects Releases Wiki Activity

Reflex-ify Hydra network managemement + make start async

Browse Source
This commit is contained in:
Adriaan Leijnse 2022-10-26 17:35:33 +01:00
parent 25c2914293
commit e2c2cd0070
1 changed files with 173 additions and 153 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

320
src/Main.hs
View File

@ -42,7 +42,6 @@ import qualified Hydra.Types as HT
import Data.Maybe (fromJust, fromMaybe) import Data.Maybe (fromJust, fromMaybe)
import Data.Aeson.Types (parseMaybe) import Data.Aeson.Types (parseMaybe)
import System.IO (IOMode(WriteMode), openFile) import System.IO (IOMode(WriteMode), openFile)
import Data.IORef (readIORef, writeIORef, IORef, newIORef)
import Hydra.Types import Hydra.Types
import Data.Text (Text) import Data.Text (Text)
import qualified Data.ByteString.Lazy.Char8 as ByteString.Char8 import qualified Data.ByteString.Lazy.Char8 as ByteString.Char8
@ -181,10 +180,7 @@ cardanoNodeCreateProcess =
runHydraDemo :: (MonadIO m) runHydraDemo :: (MonadIO m)
=> HydraDemo => HydraDemo
-> m (Map Text ( ProcessHandle -> m RunningNodes
, Address -- Cardano address
, HydraNodeInfo
))
runHydraDemo nodes = do runHydraDemo nodes = do
keysAddresses <- forM nodes $ \(actorSeed, fuelSeed) -> do keysAddresses <- forM nodes $ \(actorSeed, fuelSeed) -> do
keys@(HydraKeyInfo (KeyPair _ vk) _) <- generateKeys keys@(HydraKeyInfo (KeyPair _ vk) _) <- generateKeys
@ -196,14 +192,9 @@ runHydraDemo nodes = do
hstxid <- publishReferenceScripts hstxid <- publishReferenceScripts
handles <- standupDemoHydraNetwork hstxid (fmap fst keysAddresses) handles <- standupDemoHydraNetwork hstxid (fmap fst keysAddresses)
liftIO . putStrLn $ [i|Hydra Network Running for nodes #{Map.keys nodes}|] 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 :: forall t m. ( TriggerEvent t m, DomBuilder t m) =>m ()
headElement = do headElement = do
el "title" $ text "Hydra Head Demo" el "title" $ text "Hydra Head Demo"
@ -217,42 +208,71 @@ main = liftIO $ do
threadDelay $ seconds 3 threadDelay $ seconds 3
mainWidgetWithHead headElement app mainWidgetWithHead headElement app
makeTx :: () => IORef State -> Text makeTx :: () => RunningNodes -> Text
-> Map TxIn TxInInfo -> Lovelace -> Text -> IO 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 let lovelaceUtxos = mapMaybe (Map.lookup "lovelace" . HT.value) utxos
actors <- readIORef hydraProcessHandlesRef
jsonStr <- jsonStr <-
buildSignedHydraTx 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 lovelaceUtxos
lovelace lovelace
let jsonTx :: Aeson.Value = fromMaybe (error "Failed to parse TX") . Aeson.decode . ByteString.Char8.pack $ jsonStr let jsonTx :: Aeson.Value = fromMaybe (error "Failed to parse TX") . Aeson.decode . ByteString.Char8.pack $ jsonStr
pure . fromJust . parseMaybe (withObject "signed tx" (.: "cborHex")) $ jsonTx 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. -- | Friendly name for a Hydra node.
type DemoNodeName = Text 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 type HydraDemo = Map
DemoNodeName DemoNodeName
@ -260,7 +280,6 @@ type HydraDemo = Map
, Lovelace -- Seed for fuel , Lovelace -- Seed for fuel
) )
seconds :: Int -> Int seconds :: Int -> Int
seconds = (* 1000000) seconds = (* 1000000)
@ -352,33 +371,32 @@ startStopDemoControls ::
( DomBuilder t m, ( DomBuilder t m,
MonadFix m, MonadFix m,
PostBuild t 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 :: app ::
@ -390,92 +408,95 @@ app ::
MonadHold t m, PerformEvent t m, TriggerEvent t m) => MonadHold t m, PerformEvent t m, TriggerEvent t m) =>
m () m ()
app = do 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" "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" elClass "div" "p-4 m-4 text-white text-5xl font-bold" $ text "Hydra Proof Of Concept Demo"
mdo 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"
Closed _ -> headStateDom "Closed/Contestation period"
StateReadyToFanout -> headStateDom "Ready to fanout"
newState <- elClass "div" "ml-4 mr-4 overflow-hidden rounded-lg hover:drop-shadow-xl transition-all drop-shadow bg-gray-800" $ mdo newState <- elClass "div" "ml-4 mr-4 overflow-hidden rounded-lg hover:drop-shadow-xl transition-all drop-shadow bg-gray-800" $ mdo
rec rec
currentTab <- holdDyn (head actorNames) changeTab currentTab <- holdDyn (head actorNames) changeTab
changeTab <- fmap leftmost $ elClass "div" "w-full flex flex-row justify-start" $ for actorNames $ \name -> do changeTab <- fmap leftmost $ elClass "div" "w-full flex flex-row justify-start" $ for actorNames $ \name -> do
let let
isSelected = (== name) <$> currentTab isSelected = (== name) <$> currentTab
mkClasses selected = mkClasses selected =
T.intercalate " " [ "leading-none p-4 font-bold text-2xl text-gray-100 flex items-center justify-center" T.intercalate " " [ "leading-none p-4 font-bold text-2xl text-gray-100 flex items-center justify-center"
, bool "bg-gray-800 text-gray-300 pointer-cursor" "bg-gray-700 text-gray-100" selected , bool "bg-gray-800 text-gray-300 pointer-cursor" "bg-gray-700 text-gray-100" selected
] ]
(buttonEl, _) <- elDynClass' "button" (mkClasses <$> isSelected) $ text name (buttonEl, _) <- elDynClass' "button" (mkClasses <$> isSelected) $ text name
pure $ name <$ domEvent Click buttonEl 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 wsCfg = (WebSocketConfig @t @ClientInput) action never True [] let wsUrl = apiAddress nInfo
ws <- jsonWebSocket wsUrl wsCfg let wsCfg = (WebSocketConfig @t @ClientInput) action never True []
let isSelected = (== name) <$> currentTab ws <- jsonWebSocket wsUrl wsCfg
let mkClasses selected = let isSelected = (== name) <$> currentTab
T.intercalate " " [ "p-2 bg-gray-700 text-white flex flex-col items-left" let mkClasses selected =
, bool "hidden" "" selected T.intercalate " " [ "p-2 bg-gray-700 text-white flex flex-col items-left"
] , bool "hidden" "" selected
(_, action) <- elDynClass "div" (mkClasses <$> isSelected) $ runEventWriterT $ runWithReplace (elClass "div" "text-white" $ text "Connecting to node...") . ffor (_webSocket_open ws) $ \() -> do ]
let (_, action) <- elDynClass "div" (mkClasses <$> isSelected) $ runEventWriterT $ runWithReplace (elClass "div" "text-white" $ text "Connecting to node...") . ffor (_webSocket_open ws) $ \() -> do
webSocketMessage :: Event t (ServerOutput Aeson.Value) = let
fromMaybe (error "Parsing message from Hydra node failed") <$> _webSocket_recv ws webSocketMessage :: Event t (ServerOutput Aeson.Value) =
processLog = \case fromMaybe (error "Parsing message from Hydra node failed") <$> _webSocket_recv ws
ReadyToCommit {} -> Just Initializing processLog = \case
HeadIsOpen {} -> Just Open ReadyToCommit {} -> Just Initializing
HeadIsClosed _ fanoutTime -> Just (Closed fanoutTime) HeadIsOpen {} -> Just Open
ReadyToFanout {} -> Just StateReadyToFanout HeadIsClosed _ fanoutTime -> Just (Closed fanoutTime)
HeadIsAborted {} -> Just Idle ReadyToFanout {} -> Just StateReadyToFanout
HeadIsFinalized {} -> Just Idle HeadIsAborted {} -> Just Idle
_ -> Nothing HeadIsFinalized {} -> Just Idle
let stateChange = fmapMaybe processLog webSocketMessage _ -> Nothing
let let stateChange = fmapMaybe processLog webSocketMessage
let
myVKeyB :: Behavior t (Maybe T.Text) <- myVKeyB :: Behavior t (Maybe T.Text) <-
hold Nothing hold Nothing
. fmap Just . fmap Just
. mapMaybe (\case . mapMaybe (\case
Greetings (Party vkey') -> Just vkey' Greetings (Party vkey') -> Just vkey'
_ -> Nothing) _ -> Nothing)
$ webSocketMessage $ webSocketMessage
headStateE <- mdo headStateE <- mdo
void $ dyn $ ffor headState $ \case void $ dyn $ ffor headState $ \case
Idle -> idleScreen name Idle -> idleScreen name
Initializing -> initializingScreen actorAddress myVKeyB webSocketMessage Initializing -> initializingScreen actorAddress myVKeyB webSocketMessage
Open -> openScreen hydraProcessHandlesRef name actorNames actorAddress webSocketMessage Open -> openScreen actors name webSocketMessage
Closed fanoutTime -> closedScreen fanoutTime Closed fanoutTime -> closedScreen fanoutTime
StateReadyToFanout -> StateReadyToFanout ->
tellAction tellAction
. (Fanout <$) . (Fanout <$)
<=< 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" <=< 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"
elClass "div" "mt-4" $ do elClass "div" "mt-4" $ do
elClass "div" "mb-1 font-semibold text-sm" $ text "Hydra Node Log" 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" $ elClass "div" "p-2 bg-gray-800 rounded-md drop-shadow break-all" $
el "ul" $ do el "ul" $ do
comms <- foldDyn (++) [] $ comms <- foldDyn (++) [] $
((:[]) . ("Rcv: " <>) . toStrict . toLazyText . encodeToTextBuilder . toJSON <$> webSocketMessage) ((:[]) . ("Rcv: " <>) . toStrict . toLazyText . encodeToTextBuilder . toJSON <$> webSocketMessage)
<> <>
fmap (fmap (("Snd: " <>) . toStrict . toLazyText . encodeToTextBuilder . toJSON)) action fmap (fmap (("Snd: " <>) . toStrict . toLazyText . encodeToTextBuilder . toJSON)) action
dyn_ $ mapM (el "li" . text) <$> comms dyn_ $ mapM (el "li" . text) <$> comms
pure stateChange pure stateChange
lift $ tellEvent (First <$> headStateE) lift $ tellEvent (First <$> headStateE)
pure () pure ()
pure () pure ()
filterUtxos :: Address -> WholeUTXO -> WholeUTXO filterUtxos :: Address -> WholeUTXO -> WholeUTXO
filterUtxos addr = Map.filter ((== addr) . HT.address) filterUtxos addr = Map.filter ((== addr) . HT.address)
@ -501,13 +522,11 @@ initializingScreen ::
m () m ()
initializingScreen actorAddress myVKeyB webSocketMessage = do initializingScreen actorAddress myVKeyB webSocketMessage = do
elClass "div" "p-2 flex flex-col" $ 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 let commitSelection doCommit = do
(_, currentSet) <- (_, currentSet) <-
runDynamicWriterT $ (tellDyn <=< utxoPicker True) newUTXOs 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 tellAction $ fmap (Commit . fromMaybe mempty) $ current currentSet <@ doCommit
let hasCommitted = let hasCommitted =
attachWithMaybe attachWithMaybe
@ -536,6 +555,7 @@ initializingScreen actorAddress myVKeyB webSocketMessage = do
pure () pure ()
-- TODO: the names are passed in multiple times, the actorAddress can be found in twice as well
openScreen :: openScreen ::
( EventWriter t [ClientInput] m, ( EventWriter t [ClientInput] m,
DomBuilder t m, DomBuilder t m,
@ -543,13 +563,13 @@ openScreen ::
MonadHold t m, MonadHold t m,
PostBuild t m, PostBuild t m,
MonadIO (Performable m), PerformEvent t m) => MonadIO (Performable m), PerformEvent t m) =>
IORef State -> RunningNodes ->
Text -> Text ->
[Text] ->
Address ->
Event t (ServerOutput tx) -> Event t (ServerOutput tx) ->
m () 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 -- Get your UTxOs on page load and when we observe a transaction
tellAction . (GetUTxO <$) tellAction . (GetUTxO <$)
. ( ( void $ . ( ( void $
@ -602,7 +622,7 @@ openScreen hydraProcessHandlesRef name actorNames actorAddress webSocketMessage
elClass "div" "flex" $ do elClass "div" "flex" $ do
signedTxE <- signedTxE <-
performEvent . fmap liftIO $ performEvent . fmap liftIO $
makeTx hydraProcessHandlesRef name makeTx actors name
<$> current currentSet <$> current currentSet
-- NOTE/TODO(skylar): This is just to default to the minimum -- NOTE/TODO(skylar): This is just to default to the minimum
<*> current (fromMaybe 1000000 <$> lovelaceDyn) <*> current (fromMaybe 1000000 <$> lovelaceDyn)