Almost there; insufficient collateral now

cardano-scaling · Jan 7, 2025 · 28e24cd · 28e24cd
1 parent 5dae6c3
commit 28e24cd
Showing 1 changed file with 82 additions and 70 deletions.
diff --git 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 =