From 28e24cde07b89bbb88494f79096e770bab205a69 Mon Sep 17 00:00:00 2001 From: Noon van der Silk Date: Tue, 7 Jan 2025 11:18:34 +0000 Subject: [PATCH] Almost there; insufficient collateral now --- hydra-cluster/src/Hydra/Cluster/Scenarios.hs | 152 ++++++++++--------- 1 file changed, 82 insertions(+), 70 deletions(-) diff --git a/hydra-cluster/src/Hydra/Cluster/Scenarios.hs b/hydra-cluster/src/Hydra/Cluster/Scenarios.hs index a895ca1140e..81d568dec6c 100644 --- a/hydra-cluster/src/Hydra/Cluster/Scenarios.hs +++ b/hydra-cluster/src/Hydra/Cluster/Scenarios.hs @@ -397,86 +397,98 @@ singlePartyUsesSchnorrkelScriptOnL2 :: [TxId] -> IO () singlePartyUsesSchnorrkelScriptOnL2 tracer workDir node hydraScriptsTxId = - (`finally` returnFundsToFaucet tracer node Alice) $ do - refuelIfNeeded tracer node Alice 20_000_000 - aliceChainConfig <- chainConfigFor Alice workDir nodeSocket hydraScriptsTxId [] $ UnsafeContestationPeriod 100 - let hydraNodeId = 1 - let hydraTracer = contramap FromHydraNode tracer - (walletVk, walletSk) <- keysFor AliceFunds - utxoToCommit <- seedFromFaucet node walletVk 5_000_000 (contramap FromFaucet tracer) - withHydraNode hydraTracer aliceChainConfig workDir hydraNodeId aliceSk [] [1] $ \n1 -> do - send n1 $ input "Init" [] - headId <- waitMatch (10 * blockTime) n1 $ headIsInitializingWith (Set.fromList [alice]) + ( `finally` + do + returnFundsToFaucet tracer node Alice + returnFundsToFaucet tracer node AliceFunds + ) + $ do + refuelIfNeeded tracer node Alice 25_000_000 + aliceChainConfig <- chainConfigFor Alice workDir nodeSocket hydraScriptsTxId [] $ UnsafeContestationPeriod 100 + let hydraNodeId = 1 + let hydraTracer = contramap FromHydraNode tracer + withHydraNode hydraTracer aliceChainConfig workDir hydraNodeId aliceSk [] [1] $ \n1 -> do + send n1 $ input "Init" [] + headId <- waitMatch (10 * blockTime) n1 $ headIsInitializingWith (Set.fromList [alice]) - requestCommitTx n1 utxoToCommit <&> signTx walletSk >>= submitTx node - waitFor hydraTracer (10 * blockTime) [n1] $ - output "HeadIsOpen" ["utxo" .= toJSON utxoToCommit, "headId" .= headId] - (clientPayload, scriptUTxO) <- prepareScriptPayload - res <- - runReq defaultHttpConfig $ - req - POST - (http "127.0.0.1" /: "commit") - (ReqBodyJson clientPayload) - (Proxy :: Proxy (JsonResponse Tx)) - (port $ 4000 + hydraNodeId) + -- Commit nothing just to open + requestCommitTx n1 mempty >>= submitTx node + waitFor hydraTracer (10 * blockTime) [n1] $ + output "HeadIsOpen" ["utxo" .= object mempty, "headId" .= headId] - let commitTx = responseBody res - submitTx node commitTx + -- Then commit a Tx with the schnorrkel validator + (walletVk, walletSk) <- keysFor AliceFunds - depositTxId <- waitMatch (10 * blockTime) n1 $ \v -> do - guard $ v ^? key "headId" == Just (toJSON headId) - guard $ v ^? key "tag" == Just "CommitFinalized" - pure $ v ^? key "theDeposit" - depositTxId `shouldBe` Just (toJSON $ getTxId $ getTxBody commitTx) - let (collateralInput, _) = List.head $ UTxO.pairs utxoToCommit - - let (scriptInput, _) = List.head $ UTxO.pairs scriptUTxO - let (normalInput', _) = List.head $ UTxO.pairs utxoToCommit - pparams <- queryProtocolParameters networkId nodeSocket QueryTip - - let serializedScript = PlutusScriptSerialised dummyValidatorScript - let scriptAddress = mkScriptAddress networkId serializedScript - let scriptOutput = - mkTxOutAutoBalance - pparams - scriptAddress - (lovelaceToValue 0) - (mkTxOutDatumHash ()) - ReferenceScriptNone - let returnOutput = - TxOut (mkVkAddress networkId walletVk) (lovelaceToValue 4_826_535) TxOutDatumNone ReferenceScriptNone - let normalInput = (,BuildTxWith $ KeyWitness KeyWitnessForSpending) <$> [normalInput'] - let scriptWitness = - BuildTxWith $ - ScriptWitness scriptWitnessInCtx $ - mkScriptWitness serializedScript (mkScriptDatum ()) (toScriptData ()) - let tx = - unsafeBuildTransaction $ - defaultTxBodyContent - & changePParams pparams - & addTxIns ([(scriptInput, scriptWitness)] <> normalInput) - & addTxInsCollateral [collateralInput] - & addTxOuts [scriptOutput, returnOutput] - & setTxFee (TxFeeExplicit $ Coin 173_465) - let signedL2tx = signTx walletSk tx - send n1 $ input "NewTx" ["transaction" .= signedL2tx] - - waitMatch 10 n1 $ \v -> do - guard $ v ^? key "tag" == Just "SnapshotConfirmed" - guard $ - toJSON tx - `elem` (v ^.. key "snapshot" . key "confirmed" . values) - v ^? key "snapshot" . key "utxo" >>= parseMaybe parseJSON + let amt = 5_000_000 + + utxoToCommit <- seedFromFaucet node walletVk amt (contramap FromFaucet tracer) + + (clientPayload, scriptUTxO) <- prepareScriptPayload amt + res <- + runReq defaultHttpConfig $ + req + POST + (http "127.0.0.1" /: "commit") + (ReqBodyJson clientPayload) + (Proxy :: Proxy (JsonResponse Tx)) + (port $ 4000 + hydraNodeId) + + let commitTx = responseBody res + submitTx node commitTx + + depositTxId <- waitMatch (10 * blockTime) n1 $ \v -> do + guard $ v ^? key "headId" == Just (toJSON headId) + guard $ v ^? key "tag" == Just "CommitFinalized" + pure $ v ^? key "theDeposit" + depositTxId `shouldBe` Just (toJSON $ getTxId $ getTxBody commitTx) + let (collateralInput, _) = List.head $ UTxO.pairs utxoToCommit + + let (scriptInput, _) = List.head $ UTxO.pairs scriptUTxO + let (normalInput', _) = List.head $ UTxO.pairs utxoToCommit + pparams <- queryProtocolParameters networkId nodeSocket QueryTip + + let serializedScript = PlutusScriptSerialised dummyValidatorScript + let scriptAddress = mkScriptAddress networkId serializedScript + let scriptOutput = + mkTxOutAutoBalance + pparams + scriptAddress + (lovelaceToValue 0) + (mkTxOutDatumHash ()) + ReferenceScriptNone + let returnOutput = + TxOut (mkVkAddress networkId walletVk) (lovelaceToValue 4_826_535) TxOutDatumNone ReferenceScriptNone + let normalInput = (,BuildTxWith $ KeyWitness KeyWitnessForSpending) <$> [normalInput'] + let scriptWitness = + BuildTxWith $ + ScriptWitness scriptWitnessInCtx $ + mkScriptWitness serializedScript (mkScriptDatum ()) (toScriptData ()) + let tx = + unsafeBuildTransaction $ + defaultTxBodyContent + & changePParams pparams + & addTxIns ([(scriptInput, scriptWitness)] <> normalInput) + & addTxInsCollateral [collateralInput] + & addTxOuts [scriptOutput, returnOutput] + & setTxFee (TxFeeExplicit $ Coin 173_465) + let signedL2tx = signTx walletSk tx + send n1 $ input "NewTx" ["transaction" .= signedL2tx] + + waitMatch 10 n1 $ \v -> do + guard $ v ^? key "tag" == Just "SnapshotConfirmed" + guard $ + toJSON tx + `elem` (v ^.. key "snapshot" . key "confirmed" . values) + v ^? key "snapshot" . key "utxo" >>= parseMaybe parseJSON where RunningNode{networkId, nodeSocket, blockTime} = node -- TODO: extract this to standalone function - prepareScriptPayload = do + prepareScriptPayload lovelaceAmt = do let script = dummyValidatorScript let serializedScript = PlutusScriptSerialised script let scriptAddress = mkScriptAddress networkId serializedScript let datumHash = mkTxOutDatumHash () - (scriptIn, scriptOut) <- createOutputAtAddress node scriptAddress datumHash (lovelaceToValue 1_000_000) + (scriptIn, scriptOut) <- createOutputAtAddress node scriptAddress datumHash (lovelaceToValue lovelaceAmt) let scriptUTxO = UTxO.singleton (scriptIn, scriptOut) let scriptWitness =