670 lines
27 KiB
Haskell
670 lines
27 KiB
Haskell
{-# LANGUAGE TemplateHaskell #-}
|
||
{-# LANGUAGE PartialTypeSignatures #-}
|
||
{-# OPTIONS_GHC -Wno-unused-do-bind #-}
|
||
{-# LANGUAGE TupleSections #-}
|
||
{-# LANGUAGE ConstraintKinds #-}
|
||
{-# OPTIONS_GHC -Wno-unrecognised-pragmas #-}
|
||
|
||
|
||
module Main
|
||
|
||
(main)
|
||
|
||
where
|
||
|
||
import Prelude hiding (filter)
|
||
|
||
import Hydra.Devnet
|
||
|
||
import Control.Monad
|
||
|
||
import System.Directory
|
||
import Control.Monad.IO.Class (MonadIO, liftIO)
|
||
|
||
import qualified Data.Map as Map
|
||
import Data.Map (Map, (!))
|
||
import Data.Witherable
|
||
import Data.String.Interpolate ( i, iii, __i )
|
||
import qualified Data.Text as T
|
||
|
||
import Control.Concurrent
|
||
import System.Process
|
||
|
||
import Data.Aeson as Aeson
|
||
( decode, (.:), withObject, Value )
|
||
|
||
import Data.Aeson.Text (encodeToTextBuilder)
|
||
import Data.Text.Lazy (toStrict)
|
||
import Data.Text.Lazy.Builder (toLazyText)
|
||
|
||
import qualified Data.Map.Merge.Lazy as Map
|
||
import qualified Hydra.Types as HT
|
||
import Data.Maybe (fromJust, fromMaybe)
|
||
import Data.Aeson.Types (parseMaybe)
|
||
import System.IO (IOMode(WriteMode), openFile)
|
||
import Hydra.Types
|
||
import Data.Text (Text)
|
||
import qualified Data.ByteString.Lazy.Char8 as ByteString.Char8
|
||
import Data.Time (UTCTime, diffUTCTime)
|
||
|
||
import Reflex
|
||
import Reflex.Dom
|
||
import Control.Monad.Fix
|
||
import Hydra.ClientInput
|
||
import Hydra.ServerOutput
|
||
import Data.Bool (bool)
|
||
import Text.Read (readMaybe)
|
||
import Data.Traversable (for)
|
||
import Data.Semigroup (First(getFirst, First))
|
||
import Data.Aeson
|
||
|
||
import Control.Monad.Trans (lift)
|
||
import Language.Javascript.JSaddle.Types ( MonadJSM )
|
||
|
||
standupDemoHydraNetwork :: (MonadIO m)
|
||
=> HydraScriptTxId
|
||
-> Map Text HydraKeyInfo
|
||
-> m (Map Text (ProcessHandle, HydraNodeInfo))
|
||
standupDemoHydraNetwork hstxid actors = do
|
||
liftIO $ createDirectoryIfMissing True "demo-logs"
|
||
liftIO $ sequence . flip Map.mapWithKey nodes $ \name node'' -> do
|
||
logHndl <- openFile [iii|demo-logs/hydra-node-#{name}.log|] WriteMode
|
||
errHndl <- openFile [iii|demo-logs/phydra-node-#{name}.error.log|] WriteMode
|
||
let cp = (mkHydraNodeCP sharedInfo node'' (filter ((/= _nodeId node'') . _nodeId) (Map.elems nodes)))
|
||
{ std_out = UseHandle logHndl
|
||
, std_err = UseHandle errHndl
|
||
}
|
||
(_,_,_,handle) <- createProcess cp
|
||
pure (handle, node'')
|
||
where
|
||
portNum p n = p * 1000 + n
|
||
node' (n, (name, keys)) =
|
||
( name
|
||
, HydraNodeInfo n (portNum 5 n) (portNum 9 n) (portNum 6 n) keys
|
||
)
|
||
nodes = Map.fromList . fmap node' $ zip [1 ..] (Map.toList actors)
|
||
sharedInfo = HydraSharedInfo
|
||
{ _hydraScriptsTxId = T.unpack hstxid
|
||
, _ledgerGenesis = "devnet/genesis-shelley.json"
|
||
, _ledgerProtocolParameters = "devnet/protocol-parameters.json"
|
||
, _networkId = show devnetMagic
|
||
, _nodeSocket = "devnet/node.socket"
|
||
}
|
||
|
||
-- | Takes the node participant and the list of peers
|
||
mkHydraNodeCP :: HydraSharedInfo -> HydraNodeInfo -> [HydraNodeInfo] -> CreateProcess
|
||
mkHydraNodeCP sharedInfo node peers =
|
||
(proc hydraNodePath $ sharedArgs sharedInfo <> nodeArgs node <> concatMap peerArgs peers)
|
||
{ std_out = Inherit
|
||
}
|
||
|
||
data HydraSharedInfo = HydraSharedInfo
|
||
{ _hydraScriptsTxId :: String
|
||
, _ledgerGenesis :: FilePath
|
||
, _ledgerProtocolParameters :: FilePath
|
||
, _networkId :: String
|
||
, _nodeSocket :: FilePath
|
||
}
|
||
|
||
data HydraNodeInfo = HydraNodeInfo
|
||
{ _nodeId :: Int
|
||
, _port :: Int
|
||
, _apiPort :: Int
|
||
, _monitoringPort :: Int
|
||
, _keys :: HydraKeyInfo
|
||
}
|
||
|
||
sharedArgs :: HydraSharedInfo -> [String]
|
||
sharedArgs (HydraSharedInfo hydraScriptsTxId ledgerGenesis protocolParams networkId nodeSocket) =
|
||
[ "--ledger-genesis"
|
||
, ledgerGenesis
|
||
, "--ledger-protocol-parameters"
|
||
, protocolParams
|
||
, "--network-id"
|
||
, networkId
|
||
, "--node-socket"
|
||
, nodeSocket
|
||
, "--hydra-scripts-tx-id"
|
||
, hydraScriptsTxId
|
||
]
|
||
|
||
nodeArgs :: HydraNodeInfo -> [String]
|
||
nodeArgs (HydraNodeInfo nodeId port' apiPort monitoringPort
|
||
(HydraKeyInfo
|
||
(KeyPair cskPath _cvkPath)
|
||
(KeyPair hskPath _hvkPath))) =
|
||
[ "--node-id"
|
||
, show nodeId
|
||
, "--port"
|
||
, show port'
|
||
, "--api-port"
|
||
, show apiPort
|
||
, "--monitoring-port"
|
||
, show monitoringPort
|
||
, "--hydra-signing-key"
|
||
, hskPath
|
||
, "--cardano-signing-key"
|
||
, cskPath
|
||
]
|
||
|
||
peerArgs :: HydraNodeInfo -> [String]
|
||
peerArgs ni =
|
||
[ "--peer"
|
||
, [i|127.0.0.1:#{_port ni}|]
|
||
, "--hydra-verification-key"
|
||
, _verificationKey . _hydraKeys . _keys $ ni
|
||
, "--cardano-verification-key"
|
||
, _verificationKey . _cardanoKeys . _keys $ ni
|
||
]
|
||
|
||
cardanoNodeCreateProcess :: CreateProcess
|
||
cardanoNodeCreateProcess =
|
||
(proc cardanoNodePath
|
||
[ "run"
|
||
, "--config"
|
||
, "devnet/cardano-node.json"
|
||
, "--topology"
|
||
, "devnet/topology.json"
|
||
, "--database-path"
|
||
, "devnet/db"
|
||
, "--socket-path"
|
||
, "devnet/node.socket"
|
||
, "--shelley-operational-certificate"
|
||
, "devnet/opcert.cert"
|
||
, "--shelley-kes-key"
|
||
, "devnet/kes.skey"
|
||
, "--shelley-vrf-key"
|
||
, "devnet/vrf.skey"
|
||
]) { std_out = CreatePipe
|
||
}
|
||
|
||
runHydraDemo :: (MonadIO m)
|
||
=> HydraDemo
|
||
-> m RunningNodes
|
||
runHydraDemo nodes = do
|
||
keysAddresses <- forM nodes $ \(actorSeed, fuelSeed) -> do
|
||
keys@(HydraKeyInfo (KeyPair _ vk) _) <- generateKeys
|
||
addr <- liftIO $ getCardanoAddress vk
|
||
void $ seedAddressFromFaucetAndWait addr actorSeed False
|
||
void $ seedAddressFromFaucetAndWait addr fuelSeed True
|
||
pure (keys, addr)
|
||
liftIO . putStrLn $ "Publishing reference scripts"
|
||
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
|
||
|
||
|
||
headElement :: forall t m. ( TriggerEvent t m, DomBuilder t m) =>m ()
|
||
headElement = do
|
||
el "title" $ text "Hydra Head Demo"
|
||
elAttr "script" ("src"=:"https://cdn.tailwindcss.com") blank
|
||
|
||
main :: IO ()
|
||
main = liftIO $ do
|
||
prepareDevnet
|
||
withCreateProcess cardanoNodeCreateProcess $ \_ _stdout _ _handle -> do
|
||
putStrLn "Devnet is running"
|
||
threadDelay $ seconds 3
|
||
mainWidgetWithHead headElement app
|
||
|
||
makeTx :: () => RunningNodes -> Text
|
||
-> Map TxIn TxInInfo -> Lovelace -> Text -> IO Text
|
||
makeTx actors fromName utxos lovelace toName = do
|
||
let lovelaceUtxos = mapMaybe (Map.lookup "lovelace" . HT.value) utxos
|
||
jsonStr <-
|
||
buildSignedHydraTx
|
||
(_signingKey . _cardanoKeys . _keys . _rnNodeInfo $ actors ! fromName)
|
||
(_rnAddress $ actors ! fromName)
|
||
(_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
|
||
|
||
|
||
-- | Stopped demo desired state.
|
||
stoppedDemo :: HydraDemo
|
||
stoppedDemo = mempty
|
||
|
||
data HydraNetStatus = HNNotRunning | HNStarting | HNRunning { _hnRunningNodes :: RunningNodes }
|
||
|
||
-- | Start stop demo. When demo is 'mempty' the demo is stopped. If
|
||
-- status is 'HNStarting' nothing is done.
|
||
manageDemo ::
|
||
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
|
||
|
||
data RunningNode = RunningNode
|
||
{ _rnProcessHandle :: ProcessHandle
|
||
, _rnAddress :: Address
|
||
, _rnNodeInfo :: HydraNodeInfo
|
||
}
|
||
|
||
type RunningNodes = Map DemoNodeName RunningNode
|
||
|
||
type HydraDemo = Map
|
||
DemoNodeName
|
||
( Lovelace -- Seed for actor
|
||
, Lovelace -- Seed for fuel
|
||
)
|
||
|
||
seconds :: Int -> Int
|
||
seconds = (* 1000000)
|
||
|
||
alicebobcarolDemo :: HydraDemo
|
||
alicebobcarolDemo = Map.fromList [("Alice", (1000000000, 100000000)), ("Bob", (500000000, 100000000)), ("Carol", (250000000, 100000000))]
|
||
|
||
|
||
filterOutFuel :: WholeUTXO -> WholeUTXO
|
||
filterOutFuel = Map.filter (not . isFuel)
|
||
|
||
isFuel :: TxInInfo -> Bool
|
||
isFuel txinfo = datumhash txinfo == Just fuelMarkerDatumHash
|
||
|
||
-- | Tracks the state of the head based on Hydra Node responses
|
||
data HeadState
|
||
= Idle
|
||
| Initializing
|
||
| Open
|
||
| Closed UTCTime
|
||
| StateReadyToFanout
|
||
deriving (Eq, Show)
|
||
|
||
|
||
buttonClass :: (PostBuild t m, DomBuilder t m) => Dynamic t T.Text -> m b -> m (Event t ())
|
||
buttonClass cls content = do
|
||
(buttonEl, _) <- elDynClass' "button" cls content
|
||
pure $ domEvent Click buttonEl
|
||
|
||
|
||
utxoPicker :: forall t m. (DomBuilder t m, MonadFix m, MonadHold t m, PostBuild t m) => Bool -> WholeUTXO -> m (Dynamic t (Maybe WholeUTXO))
|
||
utxoPicker pickable wholeUtxo = mdo
|
||
elClass "div" "font-semibold text-lg mb-2" $ text "UTxOs"
|
||
|
||
currentUtxo <- holdDyn Nothing selectedUtxo
|
||
selectedUtxo <- fmap (leftmost . Map.elems) $ elClass "div" "flex flex-row flex-wrap gap-2" $ flip Map.traverseWithKey wholeUtxo $ \k v -> mdo
|
||
let amiSelected = maybe False ((k ==) . fst) <$> currentUtxo
|
||
let cls = ("text-white font-bold text-xl px-4 py-2 rounded-md flex flex-row cursor-pointer mr-2 " <>)
|
||
. bool
|
||
"bg-gray-500 hover:bg-gray-400 active:bg-gray-300"
|
||
"bg-blue-500 hover:bg-blue-400 active:bg-blue-300"
|
||
<$> amiSelected
|
||
(buttonEl, _) <- elDynClass' "button" cls $ do
|
||
elClass "div" "text-sm text-gray-300 font-semibold flex justify-between" $ do
|
||
elClass "div" "flex flex-col" $ do
|
||
elClass "div" "w-full flex flex-row justify-between" $ do
|
||
elClass "div" "text-gray-400 mr-4" $ text "lovelace"
|
||
when (isFuel v) $ elClass "div" "px-2 py-0 flex items-center justify-center leading-node bg-green-500 text-xs text-white font-semibold text-sm rounded-full flex" $
|
||
el "div" $ text "FUEL"
|
||
elClass "div" "text-lg text-left font-semibold" $ text $ maybe "" (T.pack . show) (Map.lookup "lovelace" $ HT.value v)
|
||
|
||
pure $ bool Nothing (Just (k, v)) . (pickable &&) . not <$> current amiSelected <@ domEvent Click buttonEl
|
||
pure $ fmap (uncurry Map.singleton) <$> currentUtxo
|
||
|
||
demoSettings :: (DomBuilder t m, PostBuild t m, MonadHold t m, MonadFix m) => HydraDemo -> m (Dynamic t HydraDemo)
|
||
demoSettings setngs = elClass "div" "flex flex-col pl-4 pr-4" $ do
|
||
let initSize = Map.size setngs
|
||
let initialList = Map.fromList (zip [1 .. ] (Map.toList setngs))
|
||
rec
|
||
nextIdentityNumber <- fmap (1 + initSize +) <$> count newNode
|
||
let updates =
|
||
((\n -> Map.singleton n (Just ([i|Node #{n}|], (100000000, 100000000)))) <$> current nextIdentityNumber <@ newNode)
|
||
<> deleteEs
|
||
(((), deleteEs), demoDyn) <- runDynamicWriterT $ runEventWriterT $ void $ elClass "div" "flex-col space-y-2" $ do
|
||
elClass "p" "text-white text-2xl my-4" $ text "Configure a Hydra Head by specifying the node names and their initial funds in Lovelace."
|
||
listHoldWithKey initialList updates $ \k (name, (actorSeed, _hydraSeed)) -> elClass "div" "flex flex-col" $ do
|
||
name' <- elClass "div" "flex flex-row space-x-2" $ do
|
||
name' <- fmap _inputElement_value . inputElement $
|
||
def & inputElementConfig_initialValue .~ name
|
||
& initialAttributes .~ ("class" =: "text-white bg-gray-800 text-2xl font-bold focus:outline-none p-2" <> "type" =: "text")
|
||
amount' <- fmap _inputElement_value . inputElement $
|
||
def & inputElementConfig_initialValue .~ (T.pack . show $ actorSeed)
|
||
& initialAttributes .~ ("class" =: "text-white bg-gray-800 text-2xl font-bold focus:outline-none p-2" <> "type" =: "number")
|
||
deleteE <- buttonClass "bg-gray-400 hover:bg-gray-300 active:bg-gray-200 text-white font-bold text-xl px-4 py-2 rounded-md" $
|
||
text "×"
|
||
let actorSeed' = (\n a -> (n,) <$> readMaybe (T.unpack a)) <$> name' <*> amount'
|
||
tellDyn (maybe mempty (Map.singleton k. (\(actor,sd) -> (actor, (sd, 100000000)))) <$> actorSeed')
|
||
tellEvent (Map.singleton k Nothing <$ deleteE)
|
||
pure name'
|
||
let hasDuplicateName = (\n ns -> (> 1) . Map.size . Map.filter (\(n',_) -> n == n') $ ns) <$> name' <*> demoDyn
|
||
let duplicateNameMsg = elClass "div" "text-red-400 m-2" $ text "Duplicate name"
|
||
dyn_ (bool blank duplicateNameMsg <$> fromUniqDynamic (uniqDynamic hasDuplicateName))
|
||
pure ()
|
||
newNode <- buttonClass "bg-gray-400 hover:bg-gray-300 active:bg-gray-200 text-white font-bold text-xl my-4 px-4 py-2 rounded-md w-32" $
|
||
text "Add node"
|
||
let demoDyn' = Map.fromList . Map.elems <$> demoDyn
|
||
pure demoDyn'
|
||
|
||
startStopDemoControls ::
|
||
( DomBuilder t m,
|
||
MonadFix m,
|
||
PostBuild t m,
|
||
MonadHold t m,
|
||
MonadIO (Performable m),
|
||
PerformEvent t m,
|
||
TriggerEvent t m
|
||
) =>
|
||
m (Dynamic t HydraNetStatus)
|
||
startStopDemoControls = mdo
|
||
demoStatusDyn <- manageDemo desiredDemoStateE
|
||
((), demoConfigDyn) <- runDynamicWriterT $ dyn_ . ffor demoStatusDyn $ \case
|
||
HNNotRunning -> tellDyn =<< demoSettings alicebobcarolDemo
|
||
_ -> blank
|
||
let btnBaseCls = "text-white font-bold text-xl m-4 px-4 py-2 rounded-md" :: Text
|
||
let btnStartStopCls (color :: Text) =
|
||
[__i|bg-#{color}-500 hover:bg-#{color}-400 active:bg-#{color}-300 #{btnBaseCls}|]
|
||
desiredDemoStateE <- switchHold never <=< dyn . ffor demoStatusDyn $ \case
|
||
HNNotRunning ->
|
||
fmap (pushAlways (const (sample (current demoConfigDyn)))) $
|
||
buttonClass (pure $ btnStartStopCls "green") $ text "Start head"
|
||
HNStarting -> do
|
||
_ <- elAttr' "button" ("class" =: (btnStartStopCls "gray" <> " cursor-not-allowed")
|
||
<> "disabled" =: "true")
|
||
$ text "Starting head..."
|
||
pure never
|
||
HNRunning _ -> do
|
||
fmap (stoppedDemo <$) $ buttonClass (pure $ btnStartStopCls "red") $ text "Stop head"
|
||
pure demoStatusDyn
|
||
|
||
|
||
app ::
|
||
forall t m.
|
||
( PostBuild t m,
|
||
DomBuilder t m,
|
||
MonadFix m,
|
||
MonadJSM m, MonadJSM (Performable m),
|
||
MonadHold t m, PerformEvent t m, TriggerEvent t m) =>
|
||
m ()
|
||
app = 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"
|
||
mdo
|
||
headNetStatusDyn <- startStopDemoControls
|
||
void $ dyn_ . ffor headNetStatusDyn $ \case
|
||
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
|
||
Idle -> do
|
||
headStateDom "Idle"
|
||
elClass "div" "text-green-700 text-sm" $ text "Waiting for participant to init..."
|
||
Initializing -> do
|
||
headStateDom "Initializing"
|
||
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
|
||
rec
|
||
currentTab <- holdDyn (head actorNames) changeTab
|
||
|
||
changeTab <- fmap leftmost $ elClass "div" "w-full flex flex-row justify-start" $ for actorNames $ \name -> do
|
||
let
|
||
isSelected = (== name) <$> currentTab
|
||
mkClasses selected =
|
||
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
|
||
]
|
||
(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
|
||
let wsUrl = apiAddress nInfo
|
||
let wsCfg = (WebSocketConfig @t @ClientInput) action never True []
|
||
ws <- jsonWebSocket wsUrl wsCfg
|
||
let isSelected = (== name) <$> currentTab
|
||
let mkClasses 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
|
||
webSocketMessage :: Event t (ServerOutput Aeson.Value) =
|
||
fromMaybe (error "Parsing message from Hydra node failed") <$> _webSocket_recv ws
|
||
processLog = \case
|
||
ReadyToCommit {} -> Just Initializing
|
||
HeadIsOpen {} -> Just Open
|
||
HeadIsClosed _ fanoutTime -> Just (Closed fanoutTime)
|
||
ReadyToFanout {} -> Just StateReadyToFanout
|
||
HeadIsAborted {} -> Just Idle
|
||
HeadIsFinalized {} -> Just Idle
|
||
_ -> Nothing
|
||
let stateChange = fmapMaybe processLog webSocketMessage
|
||
let
|
||
|
||
myVKeyB :: Behavior t (Maybe T.Text) <-
|
||
hold Nothing
|
||
. fmap Just
|
||
. mapMaybe (\case
|
||
Greetings (Party vkey') -> Just vkey'
|
||
_ -> Nothing)
|
||
$ webSocketMessage
|
||
headStateE <- mdo
|
||
void $ dyn $ ffor headState $ \case
|
||
Idle -> idleScreen name
|
||
Initializing -> initializingScreen actorAddress myVKeyB webSocketMessage
|
||
Open -> openScreen actors name webSocketMessage
|
||
Closed fanoutTime -> closedScreen fanoutTime
|
||
StateReadyToFanout ->
|
||
tellAction
|
||
. (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" "mb-1 font-semibold text-sm" $ text "Hydra Node Log"
|
||
elClass "div" "p-2 bg-gray-800 rounded-md drop-shadow break-all" $
|
||
el "ul" $ do
|
||
comms <- foldDyn (++) [] $
|
||
((:[]) . ("Rcv: " <>) . toStrict . toLazyText . encodeToTextBuilder . toJSON <$> webSocketMessage)
|
||
<>
|
||
fmap (fmap (("Snd: " <>) . toStrict . toLazyText . encodeToTextBuilder . toJSON)) action
|
||
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)
|
||
|
||
tellAction :: (EventWriter t [a] m, Reflex t) => Event t a -> m ()
|
||
tellAction = tellEvent . fmap (:[])
|
||
|
||
idleScreen :: (EventWriter t [ClientInput] m, DomBuilder t m) => Text -> m ()
|
||
idleScreen name =
|
||
elClass "div" "p-2 flex flex-row" $ do
|
||
(buttonEl, _) <- elClass' "button" "bg-blue-500 hover:bg-blue-400 active:bg-blue-300 text-white font-bold text-xl px-4 py-2 rounded-md" $ text $ "Initialize head as " <> name
|
||
tellAction $ Init 10 <$ domEvent Click buttonEl
|
||
|
||
initializingScreen ::
|
||
( EventWriter t [ClientInput] m,
|
||
DomBuilder t m,
|
||
MonadFix m,
|
||
MonadHold t m,
|
||
PostBuild t m, MonadIO m) =>
|
||
Address ->
|
||
Behavior t (Maybe Text) ->
|
||
Event t (ServerOutput tx) ->
|
||
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
|
||
newUTXOs <- liftIO $ queryAddressUTXOs actorAddress
|
||
let commitSelection doCommit = do
|
||
(_, currentSet) <-
|
||
runDynamicWriterT $ (tellDyn <=< utxoPicker True) newUTXOs
|
||
tellAction $ fmap (Commit . fromMaybe mempty) $ current currentSet <@ doCommit
|
||
let hasCommitted =
|
||
attachWithMaybe
|
||
( \mvkey -> \case
|
||
Committed (Party vk) _ -> guard (Just vk == mvkey)
|
||
_ -> Nothing
|
||
)
|
||
myVKeyB
|
||
webSocketMessage
|
||
|
||
mdo
|
||
void . runWithReplace (commitSelection doCommit) . ffor hasCommitted $ \() ->
|
||
elClass "div" "text-xl py-4" $ text "Committed, waiting for the others."
|
||
doCommit <- elClass "div" "flex flex-row mt-4" $ do
|
||
-- Until the head is committed starting the head can be aborted:
|
||
tellAction
|
||
. (Hydra.ClientInput.Abort <$)
|
||
<=< buttonClass "bg-gray-400 hover:bg-gray-300 active:bg-gray-200 text-white font-bold text-xl px-4 py-2 rounded-md mr-2"
|
||
$ text "Abort"
|
||
isDisabled <- holdDyn False (True <$ hasCommitted)
|
||
let cls =
|
||
(bool "bg-blue-500 hover:bg-blue-400 active:bg-blue-300" "bg-gray-500 hover:bg-gray-500 active:bg-gray-500 cursor-not-allowed " <$> isDisabled)
|
||
<> " text-white font-bold text-xl px-4 py-2 rounded-md"
|
||
buttonClass cls $ text "Commit"
|
||
pure ()
|
||
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,
|
||
MonadFix m,
|
||
MonadHold t m,
|
||
PostBuild t m,
|
||
MonadIO (Performable m), PerformEvent t m) =>
|
||
RunningNodes ->
|
||
Text ->
|
||
Event t (ServerOutput tx) ->
|
||
m ()
|
||
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 $
|
||
filter
|
||
( \case
|
||
TxSeen {} -> True
|
||
_ -> False
|
||
)
|
||
webSocketMessage
|
||
)
|
||
<>
|
||
)
|
||
=<< getPostBuild
|
||
let updatedUTXOs =
|
||
fmap (filterUtxos actorAddress)
|
||
. mapMaybe
|
||
( \case
|
||
GetUTxOResponse utxoz -> Just utxoz
|
||
_ -> Nothing
|
||
)
|
||
$ webSocketMessage
|
||
currentUTXOs <- holdDyn mempty updatedUTXOs
|
||
let ifUTXOs yes no = dyn_ (bool yes no <$> fmap Map.null currentUTXOs)
|
||
ifUTXOsDyn yes no = dyn (bool yes no <$> fmap Map.null currentUTXOs)
|
||
mdo
|
||
(_, currentSet) <-
|
||
runDynamicWriterT
|
||
. runWithReplace (elClass "div" "text-white text-2xl" $ text "Getting your UTxOs")
|
||
$ fmap (tellDyn <=< (pure . pure . filterOutFuel)) updatedUTXOs
|
||
_ <- elClass "div" "mb-4 ml-2" $ dyn_ $ utxoPicker False <$> currentSet
|
||
elClass "div" "text-xl mb-8 ml-2" $ ifUTXOs (text "Send Ada to a participant:") (text "No UTXOs for this participant")
|
||
flip ifUTXOs blank $ do
|
||
(recipientDyn, lovelaceDyn) <- elClass "div" "flex ml-2 mb-2" $
|
||
elClass "div" "w-auto flex flex-row rounded bg-gray-800 mb-2 overflow-hidden" $ do
|
||
ie <- elClass "div" "flex flex-col p-2" $ do
|
||
elClass "div" "text-gray-600 text-sm font-semibold" $ text "LOVELACES"
|
||
inputElement $
|
||
def
|
||
& initialAttributes .~ ("class" =: "bg-gray-800 text-2xl font-bold focus:outline-none p-2" <> "type" =: "number")
|
||
& inputElementConfig_initialValue .~ "1000000"
|
||
recipient <- fmap Reflex.Dom.value $
|
||
elClass "div" "flex flex-col p-2" $ do
|
||
elClass "div" "text-gray-600 text-sm font-semibold uppercase" $ text "To"
|
||
-- FIXME: unsafe head, will crash with <= 1 actors
|
||
dropdown
|
||
(head $ filter (/= name) actorNames)
|
||
(pure (Map.filter (/= name) $ Map.fromList (fmap (\n -> (n, n)) actorNames)))
|
||
$ def & dropdownConfig_attributes .~ pure ("class" =: "bg-gray-800 hover:bg-gray-700 active:bg-gray-900 text-gray-100 font-semibold text-xl px-4 py-2 rounded-md m-2")
|
||
pure (recipient, readMaybe . T.unpack <$> _inputElement_value ie)
|
||
elClass "div" "flex" $ do
|
||
signedTxE <-
|
||
performEvent . fmap liftIO $
|
||
makeTx actors name
|
||
<$> current currentSet
|
||
-- NOTE/TODO(skylar): This is just to default to the minimum
|
||
<*> current (fromMaybe 1000000 <$> lovelaceDyn)
|
||
<*> current recipientDyn
|
||
<@ doSend
|
||
tellAction
|
||
. fmap NewTx
|
||
$ signedTxE
|
||
|
||
doSend <- elClass "div" "flex flex-row ml-2" $ do
|
||
sendButtonClick <- flip ifUTXOsDyn (pure never) $ do
|
||
buttonClass "bg-green-500 hover:bg-green-400 active:bg-green-200 text-white font-bold text-xl mr-2 px-4 py-2 rounded-md" $ text "Send"
|
||
tellAction
|
||
. (Close <$)
|
||
<=< buttonClass "bg-red-500 hover:bg-red-400 active:bg-red-200 text-white font-bold text-xl px-4 py-2 rounded-md"
|
||
$ text "Close Head"
|
||
switchHold never sendButtonClick
|
||
pure ()
|
||
pure ()
|
||
|
||
closedScreen ::
|
||
( MonadFix m,
|
||
MonadIO m,
|
||
MonadIO (Performable m),
|
||
DomBuilder t m,
|
||
PostBuild t m,
|
||
TriggerEvent t m,
|
||
PerformEvent t m,
|
||
MonadHold t m
|
||
) =>
|
||
UTCTime ->
|
||
m ()
|
||
closedScreen fanoutTime = do
|
||
countDownDyn <- clockLossy 1 fanoutTime
|
||
elClass "div" "text-white text-2xl my-4 ml-2" $ do
|
||
text "Fanout time left: "
|
||
dyn_
|
||
( text . T.pack . show @Integer
|
||
. ceiling
|
||
. diffUTCTime fanoutTime
|
||
. _tickInfo_lastUTC
|
||
<$> countDownDyn
|
||
)
|
||
text " seconds"
|