|
| 1 | +module HydraSdk.Example.Minimal.Main |
| 2 | + ( main |
| 3 | + ) where |
| 4 | + |
| 5 | +import Prelude |
| 6 | + |
| 7 | +import Cardano.AsCbor (encodeCbor) |
| 8 | +import Contract.CborBytes (cborBytesToHex) |
| 9 | +import Contract.Log (logError', logInfo', logTrace', logWarn') |
| 10 | +import Contract.Monad (ContractEnv, stopContractEnv) |
| 11 | +import Contract.Transaction (submit) |
| 12 | +import Control.Monad.Error.Class (throwError) |
| 13 | +import Control.Monad.Reader (ask) |
| 14 | +import Data.Argonaut (stringifyWithIndent) |
| 15 | +import Data.Codec.Argonaut (encode) as CA |
| 16 | +import Data.Either (Either(Left, Right)) |
| 17 | +import Data.Log.Level (LogLevel(Info, Error)) |
| 18 | +import Data.Map (empty, fromFoldable) as Map |
| 19 | +import Data.Maybe (Maybe(Just, Nothing)) |
| 20 | +import Data.Posix.Signal (Signal(SIGINT, SIGTERM)) |
| 21 | +import Data.Traversable (traverse_) |
| 22 | +import Data.UInt (fromInt) as UInt |
| 23 | +import Effect (Effect) |
| 24 | +import Effect.Aff (Aff, launchAff_, runAff_) |
| 25 | +import Effect.Aff.Class (liftAff) |
| 26 | +import Effect.Class (liftEffect) |
| 27 | +import Effect.Exception (error, message) |
| 28 | +import Effect.Ref (Ref) |
| 29 | +import Effect.Ref (new, read, write) as Ref |
| 30 | +import HydraSdk.Example.Minimal.App |
| 31 | + ( AppLogger |
| 32 | + , AppM |
| 33 | + , AppState |
| 34 | + , appLogger |
| 35 | + , initApp |
| 36 | + , readHeadStatus |
| 37 | + , runAppEff |
| 38 | + , runContractInApp |
| 39 | + ) |
| 40 | +import HydraSdk.Example.Minimal.App (setHeadStatus, setUtxoSnapshot) as App |
| 41 | +import HydraSdk.Example.Minimal.Config (configFromArgv) |
| 42 | +import HydraSdk.Lib (log') |
| 43 | +import HydraSdk.NodeApi |
| 44 | + ( HydraNodeApiWebSocket |
| 45 | + , HydraTxRetryStrategy(RetryTxWithParams, DontRetryTx) |
| 46 | + , commitRequest |
| 47 | + , mkHydraNodeApiWebSocket |
| 48 | + ) |
| 49 | +import HydraSdk.Process (spawnHydraNode) |
| 50 | +import HydraSdk.Types |
| 51 | + ( HydraHeadStatus |
| 52 | + ( HeadStatus_Idle |
| 53 | + , HeadStatus_Initializing |
| 54 | + , HeadStatus_Open |
| 55 | + , HeadStatus_Closed |
| 56 | + ) |
| 57 | + , HydraNodeApi_InMessage(Greetings, HeadIsInitializing, HeadIsOpen) |
| 58 | + , HydraSnapshot(HydraSnapshot) |
| 59 | + , hydraSnapshotCodec |
| 60 | + , mkSimpleCommitRequest |
| 61 | + , printHeadStatus |
| 62 | + , printHost |
| 63 | + , printHostPort |
| 64 | + , toUtxoMap |
| 65 | + ) |
| 66 | +import Node.ChildProcess (ChildProcess, kill) |
| 67 | +import Node.Process (onSignal, onUncaughtException) |
| 68 | +import URI.Port (toInt) as Port |
| 69 | + |
| 70 | +type AppHandle = |
| 71 | + { cleanupHandler :: Effect Unit |
| 72 | + , hydraNodeProcess :: ChildProcess |
| 73 | + } |
| 74 | + |
| 75 | +main :: Effect Unit |
| 76 | +main = |
| 77 | + launchAff_ do |
| 78 | + config <- liftEffect configFromArgv |
| 79 | + appState <- initApp config |
| 80 | + let logger = appLogger |
| 81 | + appHandle <- startDelegateServer appState logger |
| 82 | + liftEffect do |
| 83 | + onUncaughtException \err -> do |
| 84 | + runAppEff appState logger $ logError' $ "UNCAUGHT EXCEPTION: " <> message err |
| 85 | + appHandle.cleanupHandler |
| 86 | + onSignal SIGINT appHandle.cleanupHandler |
| 87 | + onSignal SIGTERM appHandle.cleanupHandler |
| 88 | + |
| 89 | +startDelegateServer :: AppState -> AppLogger -> Aff AppHandle |
| 90 | +startDelegateServer state logger = do |
| 91 | + hydraNodeApiWsRef <- liftEffect $ Ref.new Nothing |
| 92 | + hydraNodeProcess <- spawnHydraNode state.config.hydraNodeStartupParams |
| 93 | + { apiServerStartedHandler: |
| 94 | + Just $ appEff do |
| 95 | + let |
| 96 | + wsUrl = "ws://" <> printHostPort |
| 97 | + state.config.hydraNodeStartupParams.hydraNodeApiAddress |
| 98 | + hydraNodeApiWs <- mkHydraNodeApiWebSocket |
| 99 | + { url: wsUrl |
| 100 | + , runM: appEff |
| 101 | + , handlers: |
| 102 | + { connectHandler: const (pure unit) |
| 103 | + , messageHandler: \ws -> messageHandler ws |
| 104 | + , errorHandler: \_ws err -> |
| 105 | + logError' $ "hydra-node API WebSocket error: " <> show err |
| 106 | + } |
| 107 | + , txRetryStrategies: |
| 108 | + { close: |
| 109 | + RetryTxWithParams |
| 110 | + { delaySec: 90 |
| 111 | + , maxRetries: top |
| 112 | + , successPredicate: (_ >= HeadStatus_Closed) <$> readHeadStatus |
| 113 | + , failHandler: pure unit |
| 114 | + } |
| 115 | + , contest: DontRetryTx |
| 116 | + } |
| 117 | + } |
| 118 | + liftEffect $ Ref.write (Just hydraNodeApiWs) hydraNodeApiWsRef |
| 119 | + , stdoutHandler: |
| 120 | + Just (appEff <<< logTrace' <<< append "[hydra-node:stdout] ") |
| 121 | + , stderrHandler: |
| 122 | + Just (appEff <<< logWarn' <<< append "[hydra-node:stderr] ") |
| 123 | + } |
| 124 | + pure |
| 125 | + { cleanupHandler: cleanupHandler (\logLevel -> appEff <<< log' logLevel Map.empty) |
| 126 | + { hydraNodeProcess |
| 127 | + , hydraNodeApiWsRef |
| 128 | + , contractEnv: state.contractEnv |
| 129 | + } |
| 130 | + , hydraNodeProcess |
| 131 | + } |
| 132 | + where |
| 133 | + appEff :: forall a. AppM a -> Effect Unit |
| 134 | + appEff = runAppEff state logger |
| 135 | + |
| 136 | +messageHandler |
| 137 | + :: HydraNodeApiWebSocket AppM |
| 138 | + -> Either String HydraNodeApi_InMessage |
| 139 | + -> AppM Unit |
| 140 | +messageHandler ws = |
| 141 | + case _ of |
| 142 | + Left _rawMessage -> pure unit |
| 143 | + Right message -> |
| 144 | + case message of |
| 145 | + Greetings { headStatus } -> do |
| 146 | + setHeadStatus headStatus |
| 147 | + when (headStatus == HeadStatus_Idle) $ liftEffect ws.initHead |
| 148 | + HeadIsInitializing _ -> do |
| 149 | + setHeadStatus HeadStatus_Initializing |
| 150 | + { commitUtxo, config: { hydraNodeStartupParams: { hydraNodeApiAddress } } } <- ask |
| 151 | + let |
| 152 | + payload = mkSimpleCommitRequest $ Map.fromFoldable [ commitUtxo ] |
| 153 | + serverConfig = |
| 154 | + { port: UInt.fromInt $ Port.toInt hydraNodeApiAddress.port |
| 155 | + , host: printHost hydraNodeApiAddress |
| 156 | + , secure: false |
| 157 | + , path: Nothing |
| 158 | + } |
| 159 | + liftAff (commitRequest serverConfig payload) >>= case _ of |
| 160 | + Left httpErr -> |
| 161 | + throwError $ error $ "Commit request failed with error: " |
| 162 | + <> show httpErr |
| 163 | + Right { cborHex: commitTx } -> do |
| 164 | + txHash <- runContractInApp $ submit commitTx |
| 165 | + logInfo' $ "Submitted Commit transaction: " <> cborBytesToHex |
| 166 | + (encodeCbor txHash) |
| 167 | + HeadIsOpen { headId, utxo } -> do |
| 168 | + setHeadStatus HeadStatus_Open |
| 169 | + logInfo' $ "Head ID: " <> cborBytesToHex (encodeCbor headId) |
| 170 | + setUtxoSnapshot $ HydraSnapshot |
| 171 | + { snapshotNumber: zero |
| 172 | + , utxo |
| 173 | + } |
| 174 | + _ -> pure unit |
| 175 | + |
| 176 | +setHeadStatus :: HydraHeadStatus -> AppM Unit |
| 177 | +setHeadStatus status = do |
| 178 | + App.setHeadStatus status |
| 179 | + logInfo' $ "New Head status: " <> printHeadStatus status |
| 180 | + |
| 181 | +setUtxoSnapshot :: HydraSnapshot -> AppM Unit |
| 182 | +setUtxoSnapshot snapshot = do |
| 183 | + App.setUtxoSnapshot snapshot |
| 184 | + let snapshotFormatted = stringifyWithIndent 2 $ CA.encode hydraSnapshotCodec snapshot |
| 185 | + logInfo' $ "New confirmed snapshot: " <> snapshotFormatted |
| 186 | + |
| 187 | +cleanupHandler |
| 188 | + :: forall (m :: Type -> Type) |
| 189 | + . (LogLevel -> String -> Effect Unit) |
| 190 | + -> { hydraNodeProcess :: ChildProcess |
| 191 | + , hydraNodeApiWsRef :: Ref (Maybe (HydraNodeApiWebSocket m)) |
| 192 | + , contractEnv :: ContractEnv |
| 193 | + } |
| 194 | + -> Effect Unit |
| 195 | +cleanupHandler logger { hydraNodeProcess, hydraNodeApiWsRef, contractEnv } = do |
| 196 | + logger Info "Killing hydra-node." |
| 197 | + kill SIGINT hydraNodeProcess |
| 198 | + logger Info "Closing hydra-node API WebSocket connection." |
| 199 | + Ref.read hydraNodeApiWsRef >>= traverse_ _.baseWs.close |
| 200 | + logger Info "Finalizing CTL Contract environment." |
| 201 | + runAff_ |
| 202 | + ( case _ of |
| 203 | + Left err -> |
| 204 | + logger Error $ "stopContractEnv failed with error: " |
| 205 | + <> message err |
| 206 | + Right _ -> |
| 207 | + logger Info "Successfully completed all cleanup actions -> exiting." |
| 208 | + ) |
| 209 | + (stopContractEnv contractEnv) |
0 commit comments