|
| 1 | +{-# LANGUAGE DuplicateRecordFields #-} |
| 2 | + |
| 3 | +module Test.BlockfrostChainSpec where |
| 4 | + |
| 5 | +import Hydra.Prelude |
| 6 | +import Test.Hydra.Prelude |
| 7 | + |
| 8 | +import Cardano.Api.UTxO qualified as UTxO |
| 9 | +import CardanoClient ( |
| 10 | + buildAddress, |
| 11 | + ) |
| 12 | +import Control.Concurrent.STM (newEmptyTMVarIO, takeTMVar) |
| 13 | +import Control.Concurrent.STM.TMVar (putTMVar) |
| 14 | +import Data.List qualified as List |
| 15 | +import Hydra.Chain ( |
| 16 | + Chain (Chain, draftCommitTx, postTx), |
| 17 | + ChainEvent (..), |
| 18 | + OnChainTx (..), |
| 19 | + PostChainTx (..), |
| 20 | + initHistory, |
| 21 | + ) |
| 22 | +import Hydra.Chain.Blockfrost (BlockfrostBackend (..), withBlockfrostChain) |
| 23 | +import Hydra.Chain.Blockfrost.Client qualified as Blockfrost |
| 24 | +import Hydra.Chain.Direct (loadChainContext, mkTinyWallet) |
| 25 | +import Hydra.Chain.Direct.Handlers (DirectChainLog) |
| 26 | +import Hydra.Chain.Direct.State (initialChainState) |
| 27 | +import Hydra.Chain.ScriptRegistry (publishHydraScripts) |
| 28 | +import Hydra.Cluster.Faucet ( |
| 29 | + seedFromFaucetBlockfrost, |
| 30 | + ) |
| 31 | +import Hydra.Cluster.Fixture ( |
| 32 | + Actor (Alice, Faucet), |
| 33 | + alice, |
| 34 | + aliceSk, |
| 35 | + blockfrostcperiod, |
| 36 | + ddeadline, |
| 37 | + ) |
| 38 | +import Hydra.Cluster.Util (chainConfigFor', keysFor) |
| 39 | +import Hydra.Ledger.Cardano (Tx) |
| 40 | +import Hydra.Logging (Tracer, showLogsOnFailure) |
| 41 | +import Hydra.Options ( |
| 42 | + BlockfrostOptions (..), |
| 43 | + CardanoChainConfig (..), |
| 44 | + ChainBackendOptions (..), |
| 45 | + ChainConfig (..), |
| 46 | + ) |
| 47 | +import Hydra.Tx.BlueprintTx (CommitBlueprintTx (..)) |
| 48 | +import Hydra.Tx.Crypto (aggregate, sign) |
| 49 | +import Hydra.Tx.HeadParameters (HeadParameters (..)) |
| 50 | +import Hydra.Tx.IsTx (IsTx (..)) |
| 51 | +import Hydra.Tx.Party (Party) |
| 52 | +import Hydra.Tx.Snapshot (ConfirmedSnapshot (..), Snapshot (..)) |
| 53 | +import Hydra.Tx.Snapshot qualified as Snapshot |
| 54 | +import Test.DirectChainSpec ( |
| 55 | + CardanoChainTest (..), |
| 56 | + DirectChainTestLog (..), |
| 57 | + externalCommit', |
| 58 | + hasInitTxWith, |
| 59 | + loadParticipants, |
| 60 | + observesInTime', |
| 61 | + observesInTimeSatisfying', |
| 62 | + waitMatch, |
| 63 | + ) |
| 64 | +import Test.Hydra.Tx.Gen (genKeyPair) |
| 65 | +import Test.QuickCheck (generate) |
| 66 | + |
| 67 | +spec :: Spec |
| 68 | +spec = around (showLogsOnFailure "BlockfrostChainSpec") $ do |
| 69 | + it "can open, close & fanout a Head using Blockfrost" $ \tracer -> do |
| 70 | + withTempDir "hydra-cluster" $ \tmp -> do |
| 71 | + (vk, sk) <- keysFor Faucet |
| 72 | + let projectPath = "./../blockfrost-project.txt" |
| 73 | + prj <- Blockfrost.projectFromFile projectPath |
| 74 | + (aliceCardanoVk, _) <- keysFor Alice |
| 75 | + (aliceExternalVk, aliceExternalSk) <- generate genKeyPair |
| 76 | + hydraScriptsTxId <- publishHydraScripts (BlockfrostBackend $ BlockfrostOptions{projectPath}) sk |
| 77 | + |
| 78 | + Blockfrost.Genesis |
| 79 | + { _genesisNetworkMagic |
| 80 | + , _genesisSystemStart |
| 81 | + } <- |
| 82 | + Blockfrost.runBlockfrostM prj Blockfrost.queryGenesisParameters |
| 83 | + |
| 84 | + let networkId = Blockfrost.toCardanoNetworkId _genesisNetworkMagic |
| 85 | + let faucetAddress = buildAddress vk networkId |
| 86 | + -- wait to see the last txid propagated on the blockfrost network |
| 87 | + void $ Blockfrost.runBlockfrostM prj $ Blockfrost.awaitUTxO networkId [faucetAddress] (List.last hydraScriptsTxId) 100 |
| 88 | + |
| 89 | + -- Alice setup |
| 90 | + aliceChainConfig <- chainConfigFor' Alice tmp (Left projectPath) hydraScriptsTxId [] blockfrostcperiod ddeadline |
| 91 | + |
| 92 | + withBlockfrostChainTest (contramap (FromBlockfrostChain "alice") tracer) aliceChainConfig alice $ |
| 93 | + \aliceChain@CardanoChainTest{postTx} -> do |
| 94 | + _ <- Blockfrost.runBlockfrostM prj $ seedFromFaucetBlockfrost aliceCardanoVk 100_000_000 |
| 95 | + someUTxO <- Blockfrost.runBlockfrostM prj $ seedFromFaucetBlockfrost aliceExternalVk 7_000_000 |
| 96 | + -- Scenario |
| 97 | + participants <- loadParticipants [Alice] |
| 98 | + let headParameters = HeadParameters blockfrostcperiod [alice] |
| 99 | + postTx $ InitTx{participants, headParameters} |
| 100 | + (headId, headSeed) <- observesInTimeSatisfying' aliceChain 500 $ hasInitTxWith headParameters participants |
| 101 | + |
| 102 | + let blueprintTx = txSpendingUTxO someUTxO |
| 103 | + externalCommit' (Left projectPath) aliceChain [aliceExternalSk] headId someUTxO blueprintTx |
| 104 | + aliceChain `observesInTime'` OnCommitTx headId alice someUTxO |
| 105 | + |
| 106 | + postTx $ CollectComTx someUTxO headId headParameters |
| 107 | + aliceChain `observesInTime'` OnCollectComTx{headId} |
| 108 | + |
| 109 | + let snapshotVersion = 0 |
| 110 | + let snapshot = |
| 111 | + Snapshot |
| 112 | + { headId |
| 113 | + , number = 1 |
| 114 | + , utxo = someUTxO |
| 115 | + , confirmed = [] |
| 116 | + , utxoToCommit = Nothing |
| 117 | + , utxoToDecommit = Nothing |
| 118 | + , version = snapshotVersion |
| 119 | + } |
| 120 | + |
| 121 | + postTx $ CloseTx headId headParameters snapshotVersion (ConfirmedSnapshot{snapshot, signatures = aggregate [sign aliceSk snapshot]}) |
| 122 | + |
| 123 | + deadline <- |
| 124 | + waitMatch aliceChain $ \case |
| 125 | + Observation{observedTx = OnCloseTx{snapshotNumber, contestationDeadline}} |
| 126 | + | snapshotNumber == 1 -> Just contestationDeadline |
| 127 | + _ -> Nothing |
| 128 | + |
| 129 | + waitMatch aliceChain $ \case |
| 130 | + Tick t _ | t > deadline -> Just () |
| 131 | + _ -> Nothing |
| 132 | + postTx $ |
| 133 | + FanoutTx |
| 134 | + { utxo = Snapshot.utxo snapshot |
| 135 | + , utxoToCommit = Nothing |
| 136 | + , utxoToDecommit = Nothing |
| 137 | + , headSeed |
| 138 | + , contestationDeadline = deadline |
| 139 | + } |
| 140 | + let expectedUTxO = |
| 141 | + (Snapshot.utxo snapshot <> fromMaybe mempty (Snapshot.utxoToCommit snapshot)) |
| 142 | + `withoutUTxO` fromMaybe mempty (Snapshot.utxoToDecommit snapshot) |
| 143 | + observesInTimeSatisfying' aliceChain 500 $ \case |
| 144 | + OnFanoutTx _ finalUTxO -> |
| 145 | + if UTxO.containsOutputs finalUTxO expectedUTxO |
| 146 | + then pure () |
| 147 | + else failure "OnFanoutTx does not contain expected UTxO" |
| 148 | + _ -> failure "expected OnFanoutTx" |
| 149 | + |
| 150 | +-- | Wrapper around 'withBlockfrostChain' that threads a 'ChainStateType tx' through |
| 151 | +-- 'postTx' and 'waitCallback' calls. |
| 152 | +withBlockfrostChainTest :: |
| 153 | + Tracer IO DirectChainLog -> |
| 154 | + ChainConfig -> |
| 155 | + Party -> |
| 156 | + (CardanoChainTest Tx IO -> IO a) -> |
| 157 | + IO a |
| 158 | +withBlockfrostChainTest tracer config party action = do |
| 159 | + (configuration, backend) <- |
| 160 | + case config of |
| 161 | + Cardano cfg@CardanoChainConfig{chainBackendOptions} -> |
| 162 | + case chainBackendOptions of |
| 163 | + Blockfrost blockfrostOptions -> pure (cfg, BlockfrostBackend blockfrostOptions) |
| 164 | + _ -> failure $ "unexpected chainBackendOptions: " <> show chainBackendOptions |
| 165 | + otherConfig -> failure $ "unexpected chainConfig: " <> show otherConfig |
| 166 | + ctx <- loadChainContext backend configuration party |
| 167 | + eventMVar <- newEmptyTMVarIO |
| 168 | + |
| 169 | + let callback event = atomically $ putTMVar eventMVar event |
| 170 | + |
| 171 | + wallet <- mkTinyWallet backend tracer configuration |
| 172 | + withBlockfrostChain backend tracer configuration ctx wallet (initHistory initialChainState) callback $ \Chain{postTx, draftCommitTx} -> do |
| 173 | + action |
| 174 | + CardanoChainTest |
| 175 | + { postTx |
| 176 | + , waitCallback = atomically $ takeTMVar eventMVar |
| 177 | + , draftCommitTx = \headId utxo blueprintTx -> do |
| 178 | + eTx <- draftCommitTx headId $ CommitBlueprintTx{lookupUTxO = utxo, blueprintTx} |
| 179 | + case eTx of |
| 180 | + Left e -> throwIO e |
| 181 | + Right tx -> pure tx |
| 182 | + } |
0 commit comments