WIP on schnorrkel; just missing script as input

cardano-scaling · Jan 9, 2025 · 7d42c2b · 7d42c2b
1 parent 1cce7d3
commit 7d42c2b
Show file tree

Hide file tree

Showing 2 changed files with 64 additions and 126 deletions.
diff --git a/hydra-cluster/src/Hydra/Cluster/Scenarios.hs b/hydra-cluster/src/Hydra/Cluster/Scenarios.hs
@@ -11,12 +11,14 @@ import CardanoClient (
   QueryPoint (QueryTip),
   RunningNode (..),
   buildTransaction,
+  buildTransactionWithBody,
   queryProtocolParameters,
   queryTip,
   queryUTxOFor,
   submitTx,
   waitForUTxO,
  )
+import Hydra.Cardano.Api.Pretty (renderTxWithUTxO)
 import CardanoNode (NodeLog)
 import Control.Concurrent.Async (mapConcurrently_)
 import Control.Lens ((^..), (^?))
@@ -36,6 +38,7 @@ import Hydra.API.HTTPServer (
  )
 import Hydra.Cardano.Api (
   Coin (..),
+  mkTxIn,
   File (File),
   Key (SigningKey),
   KeyWitnessInCtx (KeyWitnessForSpending),
@@ -403,157 +406,76 @@ singlePartyUsesSchnorrkelScriptOnL2 tracer workDir node hydraScriptsTxId =
         returnFundsToFaucet tracer node AliceFunds
   )
     $ do
-      refuelIfNeeded tracer node Alice 25_000_000
+      refuelIfNeeded tracer node Alice 250_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])
 
-        -- Commit nothing just to open
-        requestCommitTx n1 mempty >>= submitTx node
-        waitFor hydraTracer (10 * blockTime) [n1] $
-          output "HeadIsOpen" ["utxo" .= object mempty, "headId" .= headId]
-
-        -- Then commit a Tx with the schnorrkel validator
         (walletVk, walletSk) <- keysFor AliceFunds
 
-        let amt = 5_000_000
-            fee = 173_465
+        -- Create money on L1
+        utxoToCommit <- seedFromFaucet node walletVk 100_000_000 (contramap FromFaucet tracer)
 
-        -- L1 setup to (incrementally) commit funds
-        -- Script
-        (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)
-
-        -- "Normal"
-        (clientPayload, utxoToCommit) <- 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)
-
-        -- Collateral
-        (clientPayload, collateralUTxO) <- prepareScriptPayload amt
-        res <-
-          runReq defaultHttpConfig $
-            req
-              POST
-              (http "127.0.0.1" /: "commit")
-              (ReqBodyJson clientPayload)
-              (Proxy :: Proxy (JsonResponse Tx))
-              (port $ 4000 + hydraNodeId)
+        -- Push it into L2
+        requestCommitTx n1 utxoToCommit <&> signTx walletSk >>= \tx -> do
+          putStrLn $ renderTxWithUTxO utxoToCommit tx
+          submitTx node tx
 
-        let commitTx = responseBody res
-        submitTx node commitTx
+        -- Check UTxO is present in L2
+        waitFor hydraTracer (10 * blockTime) [n1] $
+          output "HeadIsOpen" ["utxo" .= toJSON utxoToCommit, "headId" .= headId]
 
-        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)
-
-        --
-        -- Now, L2 with schnorrkel
-        let (scriptInput, _) = List.head $ UTxO.pairs scriptUTxO
-        let (normalInput', _) = List.head $ UTxO.pairs utxoToCommit
-        let (collateralInput, _) = List.head $ UTxO.pairs collateralUTxO
         pparams <- queryProtocolParameters networkId nodeSocket QueryTip
 
-        -- Note: Here is the first time we use the schnorrkel validator
-        let serializedScript = PlutusScriptSerialised schnorrkelValidatorScript
+        -- Send the UTxO to a script; in preparation for running the script
+        let serializedScript = PlutusScriptSerialised dummyValidatorScript
+        -- let serializedScript = PlutusScriptSerialised schnorrkelValidatorScript
         let scriptAddress = mkScriptAddress networkId serializedScript
         let scriptOutput =
               mkTxOutAutoBalance
                 pparams
                 scriptAddress
-                (lovelaceToValue 0)
+                (lovelaceToValue 0) -- Autobalanced
                 (mkTxOutDatumHash ())
                 ReferenceScriptNone
 
-        let returnOutput =
-              TxOut (mkVkAddress networkId walletVk) (lovelaceToValue (amt - fee)) TxOutDatumNone ReferenceScriptNone
+        Right tx <- buildTransaction networkId nodeSocket (mkVkAddress networkId walletVk) utxoToCommit [] [scriptOutput]
 
-        let normalInput = (,BuildTxWith $ KeyWitness KeyWitnessForSpending) <$> [normalInput']
+        let signedL2tx = signTx walletSk tx
+        send n1 $ input "NewTx" ["transaction" .= signedL2tx]
+
+        putStrLn $ renderTxWithUTxO utxoToCommit signedL2tx
+
+        waitMatch 10 n1 $ \v -> do
+          guard $ v ^? key "tag" == Just "SnapshotConfirmed"
+          guard $
+            toJSON signedL2tx
+              `elem` (v ^.. key "snapshot" . key "confirmed" . values)
+
+        -- Finally, take money from the script
         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 fee)
+        -- TODO: Include the script as an input!
+        let body =
+              defaultTxBodyContent
+                & addTxIns [(mkTxIn signedL2tx 0, scriptWitness)]
 
+        tx <- either (failure . show) pure =<< buildTransactionWithBody networkId nodeSocket (mkVkAddress networkId walletVk) body utxoToCommit
         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
+            toJSON signedL2tx
               `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 lovelaceAmt = do
-    let script = dummyValidatorScript
-    let serializedScript = PlutusScriptSerialised script
-    let scriptAddress = mkScriptAddress networkId serializedScript
-    let datumHash = mkTxOutDatumHash ()
-    (scriptIn, scriptOut) <- createOutputAtAddress node scriptAddress datumHash (lovelaceToValue lovelaceAmt)
-    let scriptUTxO = UTxO.singleton (scriptIn, scriptOut)
-
-    let scriptWitness =
-          BuildTxWith $
-            ScriptWitness scriptWitnessInCtx $
-              mkScriptWitness serializedScript (mkScriptDatum ()) (toScriptData ())
-    let spendingTx =
-          unsafeBuildTransaction $
-            defaultTxBodyContent
-              & addTxIns [(scriptIn, scriptWitness)]
-    pure
-      ( Aeson.object
-          [ "blueprintTx" .= spendingTx
-          , "utxo" .= scriptUTxO
-          ]
-      , scriptUTxO
-      )
 
 singlePartyCommitsScriptBlueprint ::
   Tracer IO EndToEndLog ->

diff --git a/hydra-node/src/Hydra/Chain/CardanoClient.hs b/hydra-node/src/Hydra/Chain/CardanoClient.hs
@@ -63,26 +63,19 @@ mkCardanoClient networkId nodeSocket =
 
 -- * Tx Construction / Submission
 
--- | Construct a simple payment consuming some inputs and producing some
--- outputs (no certificates or withdrawals involved).
---
--- On success, the returned transaction is fully balanced. On error, return
--- `TxBodyErrorAutoBalance`.
-buildTransaction ::
+buildTransactionWithBody ::
   -- | Current network identifier
   NetworkId ->
   -- | Filepath to the cardano-node's domain socket
   SocketPath ->
   -- | Change address to send
   AddressInEra ->
+  -- | Body
+  TxBodyContent BuildTx ->
   -- | Unspent transaction outputs to spend.
   UTxO ->
-  -- | Collateral inputs.
-  [TxIn] ->
-  -- | Outputs to create.
-  [TxOut CtxTx] ->
   IO (Either (TxBodyErrorAutoBalance Era) Tx)
-buildTransaction networkId socket changeAddress utxoToSpend collateral outs = do
+buildTransactionWithBody networkId socket changeAddress body utxoToSpend = do
   pparams <- queryProtocolParameters networkId socket QueryTip
   systemStart <- querySystemStart networkId socket QueryTip
   eraHistory <- queryEraHistory networkId socket QueryTip
@@ -98,9 +91,32 @@ buildTransaction networkId socket changeAddress utxoToSpend collateral outs = do
         mempty
         mempty
         (UTxO.toApi utxoToSpend)
-        (bodyContent pparams)
+        body
         changeAddress
         Nothing
+
+-- | Construct a simple payment consuming some inputs and producing some
+-- outputs (no certificates or withdrawals involved).
+--
+-- On success, the returned transaction is fully balanced. On error, return
+-- `TxBodyErrorAutoBalance`.
+buildTransaction ::
+  -- | Current network identifier
+  NetworkId ->
+  -- | Filepath to the cardano-node's domain socket
+  SocketPath ->
+  -- | Change address to send
+  AddressInEra ->
+  -- | Unspent transaction outputs to spend.
+  UTxO ->
+  -- | Collateral inputs.
+  [TxIn] ->
+  -- | Outputs to create.
+  [TxOut CtxTx] ->
+  IO (Either (TxBodyErrorAutoBalance Era) Tx)
+buildTransaction networkId socket changeAddress utxoToSpend collateral outs = do
+  pparams <- queryProtocolParameters networkId socket QueryTip
+  buildTransactionWithBody networkId socket changeAddress (bodyContent pparams) utxoToSpend
  where
   -- NOTE: 'makeTransactionBodyAutoBalance' overwrites this.
   dummyFeeForBalancing = TxFeeExplicit 0