Skip to content

Commit b5ef1fa

Browse files
ffakenzffakenz
authored
Merge pull request #1235 from input-output-hk/head-explorer-backend
Create a hydra-explorer executable that can track all heads on-chain
2 parents 3659f50 + 594558b commit b5ef1fa

File tree

21 files changed

+1300
-55
lines changed

21 files changed

+1300
-55
lines changed

‎cabal.project

+1
Original file line numberDiff line numberDiff line change
@@ -28,6 +28,7 @@ packages:
2828
hydra-tui
2929
hydraw
3030
hydra-chain-observer
31+
hydra-explorer
3132

3233
-- Compile more things in parallel
3334
package *

‎hydra-chain-observer/exe/Main.hs

+2-1
Original file line numberDiff line numberDiff line change
@@ -1,7 +1,8 @@
11
module Main where
22

3+
import Hydra.ChainObserver (defaultObserverHandler)
34
import Hydra.ChainObserver qualified
45
import Hydra.Prelude
56

67
main :: IO ()
7-
main = Hydra.ChainObserver.main
8+
main = Hydra.ChainObserver.main defaultObserverHandler

‎hydra-chain-observer/src/Hydra/ChainObserver.hs

+44-27
Original file line numberDiff line numberDiff line change
@@ -21,6 +21,7 @@ import Hydra.Cardano.Api (
2121
SocketPath,
2222
Tx,
2323
UTxO,
24+
chainTipToChainPoint,
2425
connectToLocalNode,
2526
getTxBody,
2627
getTxId,
@@ -52,8 +53,13 @@ import Ouroboros.Network.Protocol.ChainSync.Client (
5253
ClientStNext (..),
5354
)
5455

55-
main :: IO ()
56-
main = do
56+
type ObserverHandler m = [HeadObservation] -> m ()
57+
58+
defaultObserverHandler :: Applicative m => ObserverHandler m
59+
defaultObserverHandler = const $ pure ()
60+
61+
main :: ObserverHandler IO -> IO ()
62+
main observerHandler = do
5763
Options{networkId, nodeSocket, startChainFrom} <- execParser hydraChainObserverOptions
5864
withTracer (Verbose "hydra-chain-observer") $ \tracer -> do
5965
traceWith tracer KnownScripts{scriptInfo = Contract.scriptInfo}
@@ -64,7 +70,7 @@ main = do
6470
traceWith tracer StartObservingFrom{chainPoint}
6571
connectToLocalNode
6672
(connectInfo nodeSocket networkId)
67-
(clientProtocols tracer networkId chainPoint)
73+
(clientProtocols tracer networkId chainPoint observerHandler)
6874

6975
type ChainObserverLog :: Type
7076
data ChainObserverLog
@@ -79,7 +85,7 @@ data ChainObserverLog
7985
| HeadAbortTx {headId :: HeadId}
8086
| HeadContestTx {headId :: HeadId}
8187
| Rollback {point :: ChainPoint}
82-
| RollForward {receivedTxIds :: [TxId]}
88+
| RollForward {point :: ChainPoint, receivedTxIds :: [TxId]}
8389
deriving stock (Eq, Show, Generic)
8490
deriving anyclass (ToJSON)
8591

@@ -101,10 +107,11 @@ clientProtocols ::
101107
Tracer IO ChainObserverLog ->
102108
NetworkId ->
103109
ChainPoint ->
110+
ObserverHandler IO ->
104111
LocalNodeClientProtocols BlockType ChainPoint ChainTip slot tx txid txerr query IO
105-
clientProtocols tracer networkId startingPoint =
112+
clientProtocols tracer networkId startingPoint observerHandler =
106113
LocalNodeClientProtocols
107-
{ localChainSyncClient = LocalChainSyncClient $ chainSyncClient tracer networkId startingPoint
114+
{ localChainSyncClient = LocalChainSyncClient $ chainSyncClient tracer networkId startingPoint observerHandler
108115
, localTxSubmissionClient = Nothing
109116
, localStateQueryClient = Nothing
110117
, localTxMonitoringClient = Nothing
@@ -128,8 +135,9 @@ chainSyncClient ::
128135
Tracer m ChainObserverLog ->
129136
NetworkId ->
130137
ChainPoint ->
138+
ObserverHandler m ->
131139
ChainSyncClient BlockType ChainPoint ChainTip m ()
132-
chainSyncClient tracer networkId startingPoint =
140+
chainSyncClient tracer networkId startingPoint observerHandler =
133141
ChainSyncClient $
134142
pure $
135143
SendMsgFindIntersect [startingPoint] clientStIntersect
@@ -143,44 +151,53 @@ chainSyncClient tracer networkId startingPoint =
143151
ChainSyncClient $ throwIO (IntersectionNotFound startingPoint)
144152
}
145153

146-
clientStIdle :: UTxO -> ClientStIdle BlockType ChainPoint tip m ()
154+
clientStIdle :: UTxO -> ClientStIdle BlockType ChainPoint ChainTip m ()
147155
clientStIdle utxo = SendMsgRequestNext (clientStNext utxo) (pure $ clientStNext utxo)
148156

149-
clientStNext :: UTxO -> ClientStNext BlockType ChainPoint tip m ()
157+
clientStNext :: UTxO -> ClientStNext BlockType ChainPoint ChainTip m ()
150158
clientStNext utxo =
151159
ClientStNext
152-
{ recvMsgRollForward = \blockInMode _tip -> ChainSyncClient $ do
160+
{ recvMsgRollForward = \blockInMode tip -> ChainSyncClient $ do
153161
case blockInMode of
154162
BlockInMode _ (Block _header txs) BabbageEraInCardanoMode -> do
155-
traceWith tracer RollForward{receivedTxIds = getTxId . getTxBody <$> txs}
156-
let (utxo', logs) = observeAll networkId utxo txs
157-
forM_ logs (traceWith tracer)
163+
let point = chainTipToChainPoint tip
164+
let receivedTxIds = getTxId . getTxBody <$> txs
165+
traceWith tracer RollForward{point, receivedTxIds}
166+
let (utxo', observations) = observeAll networkId utxo txs
167+
-- FIXME we should be exposing OnChainTx instead of working around NoHeadTx.
168+
forM_ observations (maybe (pure ()) (traceWith tracer) . logObservation)
169+
observerHandler observations
158170
pure $ clientStIdle utxo'
159171
_ -> pure $ clientStIdle utxo
160172
, recvMsgRollBackward = \point _tip -> ChainSyncClient $ do
161173
traceWith tracer Rollback{point}
162174
pure $ clientStIdle utxo
163175
}
164176

165-
observeTx :: NetworkId -> UTxO -> Tx -> (UTxO, Maybe ChainObserverLog)
177+
logObservation :: HeadObservation -> Maybe ChainObserverLog
178+
logObservation = \case
179+
NoHeadTx -> Nothing
180+
Init InitObservation{headId} -> pure $ HeadInitTx{headId}
181+
Commit CommitObservation{headId} -> pure $ HeadCommitTx{headId}
182+
CollectCom CollectComObservation{headId} -> pure $ HeadCollectComTx{headId}
183+
Close CloseObservation{headId} -> pure $ HeadCloseTx{headId}
184+
Fanout FanoutObservation{headId} -> pure $ HeadFanoutTx{headId}
185+
Abort AbortObservation{headId} -> pure $ HeadAbortTx{headId}
186+
Contest ContestObservation{headId} -> pure $ HeadContestTx{headId}
187+
188+
observeTx :: NetworkId -> UTxO -> Tx -> (UTxO, Maybe HeadObservation)
166189
observeTx networkId utxo tx =
167190
let utxo' = adjustUTxO tx utxo
168191
in case observeHeadTx networkId utxo tx of
169192
NoHeadTx -> (utxo, Nothing)
170-
Init InitObservation{headId} -> (utxo', pure $ HeadInitTx{headId})
171-
Commit CommitObservation{headId} -> (utxo', pure $ HeadCommitTx{headId})
172-
CollectCom CollectComObservation{headId} -> (utxo', pure $ HeadCollectComTx{headId})
173-
Close CloseObservation{headId} -> (utxo', pure $ HeadCloseTx{headId})
174-
Fanout FanoutObservation{headId} -> (utxo', pure $ HeadFanoutTx{headId})
175-
Abort AbortObservation{headId} -> (utxo', pure $ HeadAbortTx{headId})
176-
Contest ContestObservation{headId} -> (utxo', pure $ HeadContestTx{headId})
177-
178-
observeAll :: NetworkId -> UTxO -> [Tx] -> (UTxO, [ChainObserverLog])
193+
observation -> (utxo', pure observation)
194+
195+
observeAll :: NetworkId -> UTxO -> [Tx] -> (UTxO, [HeadObservation])
179196
observeAll networkId utxo txs =
180197
second reverse $ foldr go (utxo, []) txs
181198
where
182-
go :: Tx -> (UTxO, [ChainObserverLog]) -> (UTxO, [ChainObserverLog])
183-
go tx (utxo'', logs) =
199+
go :: Tx -> (UTxO, [HeadObservation]) -> (UTxO, [HeadObservation])
200+
go tx (utxo'', observations) =
184201
case observeTx networkId utxo'' tx of
185-
(utxo', Nothing) -> (utxo', logs)
186-
(utxo', Just logEntry) -> (utxo', logEntry : logs)
202+
(utxo', Nothing) -> (utxo', observations)
203+
(utxo', Just observation) -> (utxo', observation : observations)

‎hydra-chain-observer/test/Hydra/ChainObserverSpec.hs

+9-8
Original file line numberDiff line numberDiff line change
@@ -6,7 +6,8 @@ import Test.Hydra.Prelude
66
import Hydra.Chain.Direct.Fixture (testNetworkId)
77
import Hydra.Chain.Direct.State (HasKnownUTxO (getKnownUTxO), genChainStateWithTx)
88
import Hydra.Chain.Direct.State qualified as Transition
9-
import Hydra.ChainObserver (ChainObserverLog (..), observeAll, observeTx)
9+
import Hydra.Chain.Direct.Tx (HeadObservation (..))
10+
import Hydra.ChainObserver (observeAll, observeTx)
1011
import Hydra.Ledger.Cardano (genSequenceOfSimplePaymentTransactions)
1112
import Test.QuickCheck (counterexample, forAll, forAllBlind, property, (=/=), (===))
1213
import Test.QuickCheck.Property (checkCoverage)
@@ -21,13 +22,13 @@ spec =
2122
counterexample (show transition) $
2223
let utxo = getKnownUTxO st
2324
in case snd $ observeTx testNetworkId utxo tx of
24-
Just (HeadInitTx{}) -> transition === Transition.Init
25-
Just (HeadCommitTx{}) -> transition === Transition.Commit
26-
Just (HeadCollectComTx{}) -> transition === Transition.Collect
27-
Just (HeadAbortTx{}) -> transition === Transition.Abort
28-
Just (HeadCloseTx{}) -> transition === Transition.Close
29-
Just (HeadContestTx{}) -> transition === Transition.Contest
30-
Just (HeadFanoutTx{}) -> transition === Transition.Fanout
25+
Just (Init{}) -> transition === Transition.Init
26+
Just (Commit{}) -> transition === Transition.Commit
27+
Just (CollectCom{}) -> transition === Transition.Collect
28+
Just (Abort{}) -> transition === Transition.Abort
29+
Just (Close{}) -> transition === Transition.Close
30+
Just (Contest{}) -> transition === Transition.Contest
31+
Just (Fanout{}) -> transition === Transition.Fanout
3132
_ -> property False
3233

3334
prop "Updates UTxO state given transaction part of Head lifecycle" $

‎hydra-cluster/hydra-cluster.cabal

+4
Original file line numberDiff line numberDiff line change
@@ -157,6 +157,7 @@ test-suite tests
157157
Test.Hydra.Cluster.CardanoCliSpec
158158
Test.Hydra.Cluster.FaucetSpec
159159
Test.Hydra.Cluster.MithrilSpec
160+
Test.HydraExplorerSpec
160161
Test.OfflineChainSpec
161162

162163
build-depends:
@@ -168,6 +169,8 @@ test-suite tests
168169
, directory
169170
, filepath
170171
, hspec
172+
, http-client
173+
, http-conduit
171174
, hydra-cardano-api
172175
, hydra-cluster
173176
, hydra-node:{hydra-node, testlib}
@@ -185,6 +188,7 @@ test-suite tests
185188
build-tool-depends:
186189
, hspec-discover:hspec-discover
187190
, hydra-chain-observer:hydra-chain-observer
191+
, hydra-explorer:hydra-explorer
188192
, hydra-node:hydra-node
189193

190194
ghc-options: -threaded -rtsopts

‎hydra-cluster/test/Test/ChainObserverSpec.hs

+5-11
Original file line numberDiff line numberDiff line change
@@ -12,7 +12,6 @@ import Test.Hydra.Prelude
1212
import CardanoClient (RunningNode (..), submitTx)
1313
import CardanoNode (NodeLog, withCardanoNodeDevnet)
1414
import Control.Concurrent.Class.MonadSTM (modifyTVar', newTVarIO, readTVarIO)
15-
import Control.Exception (IOException)
1615
import Control.Lens ((^?))
1716
import Data.Aeson as Aeson
1817
import Data.Aeson.Lens (key, _String)
@@ -112,16 +111,11 @@ data ChainObserverLog
112111
-- | Starts a 'hydra-chain-observer' on some Cardano network.
113112
withChainObserver :: RunningNode -> (ChainObserverHandle -> IO ()) -> IO ()
114113
withChainObserver cardanoNode action =
115-
-- XXX: If this throws an IOException, 'withFile' invocations around mislead
116-
-- to the file path opened (e.g. the cardano-node log file) in the test
117-
-- failure output. Print the exception here to have some debuggability at
118-
-- least.
119-
handle (\(e :: IOException) -> print e >> throwIO e) $
120-
withCreateProcess process{std_out = CreatePipe} $ \_in (Just out) _err _ph ->
121-
action
122-
ChainObserverHandle
123-
{ awaitNext = awaitNext out
124-
}
114+
withCreateProcess process{std_out = CreatePipe} $ \_in (Just out) _err _ph ->
115+
action
116+
ChainObserverHandle
117+
{ awaitNext = awaitNext out
118+
}
125119
where
126120
awaitNext :: Handle -> IO Aeson.Value
127121
awaitNext out = do

‎hydra-cluster/test/Test/HydraExplorerSpec.hs

+134
Original file line numberDiff line numberDiff line change
@@ -0,0 +1,134 @@
1+
{-# LANGUAGE DeriveAnyClass #-}
2+
3+
-- | Integration tests for the 'hydra-explorer' executable. These will run
4+
-- also 'hydra-node' on a devnet and assert correct observation.
5+
module Test.HydraExplorerSpec where
6+
7+
import Hydra.Prelude hiding (get)
8+
import Test.Hydra.Prelude
9+
10+
import CardanoClient (RunningNode (..))
11+
import CardanoNode (NodeLog, withCardanoNodeDevnet)
12+
import Control.Lens ((^.), (^?))
13+
import Data.Aeson as Aeson
14+
import Data.Aeson.Lens (key, nth, _Array, _String)
15+
import Hydra.Cardano.Api (NetworkId (..), NetworkMagic (..), unFile)
16+
import Hydra.Cluster.Faucet (FaucetLog, publishHydraScriptsAs, seedFromFaucet_)
17+
import Hydra.Cluster.Fixture (Actor (..), aliceSk, bobSk, cperiod)
18+
import Hydra.Cluster.Util (chainConfigFor, keysFor)
19+
import Hydra.Logging (showLogsOnFailure)
20+
import HydraNode (HydraNodeLog, input, send, waitMatch, withHydraNode)
21+
import Network.HTTP.Client (responseBody)
22+
import Network.HTTP.Simple (httpJSON, parseRequestThrow)
23+
import System.Process (CreateProcess (..), StdStream (..), proc, withCreateProcess)
24+
25+
spec :: Spec
26+
spec = do
27+
it "can observe hydra transactions created by multiple hydra-nodes" $
28+
failAfter 60 $
29+
showLogsOnFailure "HydraExplorerSpec" $ \tracer -> do
30+
withTempDir "hydra-explorer-history" $ \tmpDir -> do
31+
withCardanoNodeDevnet (contramap FromCardanoNode tracer) tmpDir $ \cardanoNode@RunningNode{nodeSocket} -> do
32+
let hydraTracer = contramap FromHydraNode tracer
33+
hydraScriptsTxId <- publishHydraScriptsAs cardanoNode Faucet
34+
35+
let initHead hydraNode = do
36+
send hydraNode $ input "Init" []
37+
waitMatch 5 hydraNode $ \v -> do
38+
guard $ v ^? key "tag" == Just "HeadIsInitializing"
39+
v ^? key "headId" . _String
40+
41+
(aliceCardanoVk, _aliceCardanoSk) <- keysFor Alice
42+
aliceChainConfig <- chainConfigFor Alice tmpDir nodeSocket hydraScriptsTxId [] cperiod
43+
seedFromFaucet_ cardanoNode aliceCardanoVk 25_000_000 (contramap FromFaucet tracer)
44+
aliceHeadId <- withHydraNode hydraTracer aliceChainConfig tmpDir 1 aliceSk [] [1] initHead
45+
46+
(bobCardanoVk, _bobCardanoSk) <- keysFor Bob
47+
bobChainConfig <- chainConfigFor Bob tmpDir nodeSocket hydraScriptsTxId [] cperiod
48+
seedFromFaucet_ cardanoNode bobCardanoVk 25_000_000 (contramap FromFaucet tracer)
49+
bobHeadId <- withHydraNode hydraTracer bobChainConfig tmpDir 2 bobSk [] [2] initHead
50+
51+
withHydraExplorer cardanoNode $ \explorer -> do
52+
allHeads <- getHeads explorer
53+
length (allHeads ^. _Array) `shouldBe` 2
54+
allHeads ^. nth 0 . key "headId" . _String `shouldBe` aliceHeadId
55+
allHeads ^. nth 0 . key "status" . _String `shouldBe` "Initializing"
56+
allHeads ^. nth 1 . key "headId" . _String `shouldBe` bobHeadId
57+
allHeads ^. nth 1 . key "status" . _String `shouldBe` "Initializing"
58+
59+
it "can query for all hydra heads observed" $
60+
failAfter 60 $
61+
showLogsOnFailure "HydraExplorerSpec" $ \tracer -> do
62+
withTempDir "hydra-explorer-get-heads" $ \tmpDir -> do
63+
withCardanoNodeDevnet (contramap FromCardanoNode tracer) tmpDir $ \cardanoNode@RunningNode{nodeSocket} -> do
64+
let hydraTracer = contramap FromHydraNode tracer
65+
hydraScriptsTxId <- publishHydraScriptsAs cardanoNode Faucet
66+
withHydraExplorer cardanoNode $ \explorer -> do
67+
(aliceCardanoVk, _aliceCardanoSk) <- keysFor Alice
68+
aliceChainConfig <- chainConfigFor Alice tmpDir nodeSocket hydraScriptsTxId [] cperiod
69+
seedFromFaucet_ cardanoNode aliceCardanoVk 25_000_000 (contramap FromFaucet tracer)
70+
aliceHeadId <- withHydraNode hydraTracer aliceChainConfig tmpDir 1 aliceSk [] [1] $ \hydraNode -> do
71+
send hydraNode $ input "Init" []
72+
73+
waitMatch 5 hydraNode $ \v -> do
74+
guard $ v ^? key "tag" == Just "HeadIsInitializing"
75+
v ^? key "headId" . _String
76+
77+
(bobCardanoVk, _bobCardanoSk) <- keysFor Bob
78+
bobChainConfig <- chainConfigFor Bob tmpDir nodeSocket hydraScriptsTxId [] cperiod
79+
seedFromFaucet_ cardanoNode bobCardanoVk 25_000_000 (contramap FromFaucet tracer)
80+
bobHeadId <- withHydraNode hydraTracer bobChainConfig tmpDir 2 bobSk [] [2] $ \hydraNode -> do
81+
send hydraNode $ input "Init" []
82+
83+
bobHeadId <- waitMatch 5 hydraNode $ \v -> do
84+
guard $ v ^? key "tag" == Just "HeadIsInitializing"
85+
v ^? key "headId" . _String
86+
87+
send hydraNode $ input "Abort" []
88+
89+
waitMatch 5 hydraNode $ \v -> do
90+
guard $ v ^? key "tag" == Just "HeadIsAborted"
91+
guard $ v ^? key "headId" . _String == Just bobHeadId
92+
93+
pure bobHeadId
94+
95+
allHeads <- getHeads explorer
96+
length (allHeads ^. _Array) `shouldBe` 2
97+
allHeads ^. nth 0 . key "headId" . _String `shouldBe` aliceHeadId
98+
allHeads ^. nth 0 . key "status" . _String `shouldBe` "Initializing"
99+
allHeads ^. nth 1 . key "headId" . _String `shouldBe` bobHeadId
100+
allHeads ^. nth 1 . key "status" . _String `shouldBe` "Aborted"
101+
102+
newtype HydraExplorerHandle = HydraExplorerHandle {getHeads :: IO Value}
103+
104+
data HydraExplorerLog
105+
= FromCardanoNode NodeLog
106+
| FromHydraNode HydraNodeLog
107+
| FromFaucet FaucetLog
108+
deriving (Eq, Show, Generic)
109+
deriving anyclass (ToJSON)
110+
111+
-- | Starts a 'hydra-explorer' on some Cardano network.
112+
withHydraExplorer :: RunningNode -> (HydraExplorerHandle -> IO ()) -> IO ()
113+
withHydraExplorer cardanoNode action =
114+
withCreateProcess process{std_out = CreatePipe, std_err = CreatePipe} $
115+
\_in _stdOut err processHandle ->
116+
race
117+
(checkProcessHasNotDied "hydra-explorer" processHandle err)
118+
( -- XXX: wait for the http server to be listening on port
119+
threadDelay 3
120+
*> action HydraExplorerHandle{getHeads}
121+
)
122+
<&> either absurd id
123+
where
124+
getHeads = responseBody <$> (parseRequestThrow "http://127.0.0.1:9090/heads" >>= httpJSON)
125+
126+
process =
127+
proc
128+
"hydra-explorer"
129+
$ ["--node-socket", unFile nodeSocket]
130+
<> case networkId of
131+
Mainnet -> ["--mainnet"]
132+
Testnet (NetworkMagic magic) -> ["--testnet-magic", show magic]
133+
134+
RunningNode{nodeSocket, networkId} = cardanoNode

0 commit comments

Comments
 (0)