From f2888b50cad687fb9bedf2356b15e4a43779db17 Mon Sep 17 00:00:00 2001 From: Sasha Bogicevic Date: Mon, 9 Dec 2024 19:13:20 +0100 Subject: [PATCH] Improve schnorkel test cases Still getting PPViewHashesDontMatch but this is the final error to solve --- hydra-cluster/hydra-cluster.cabal | 4 - hydra-cluster/src/Hydra/Cluster/Scenarios.hs | 88 +++++++++++++++----- hydra-cluster/src/HydraNode.hs | 48 +++++++++-- hydra-cluster/test/Test/EndToEndSpec.hs | 2 +- hydra-tx/src/Hydra/Ledger/Cardano/Builder.hs | 5 ++ 5 files changed, 110 insertions(+), 37 deletions(-) diff --git a/hydra-cluster/hydra-cluster.cabal b/hydra-cluster/hydra-cluster.cabal index 23a7d1d9a06..5fc922554bd 100644 --- a/hydra-cluster/hydra-cluster.cabal +++ b/hydra-cluster/hydra-cluster.cabal @@ -88,7 +88,6 @@ library , base >=4.7 && <5 , bytestring , cardano-slotting - , cardano-api , containers , contra-tracer , data-default @@ -99,7 +98,6 @@ library , hydra-cardano-api , hydra-node , hydra-prelude - , hydra-plutus , hydra-test-utils , hydra-tx , hydra-tx:testlib @@ -108,8 +106,6 @@ library , lens , lens-aeson , optparse-applicative - , plutus-ledger-api - , plutus-tx , process , QuickCheck , req diff --git a/hydra-cluster/src/Hydra/Cluster/Scenarios.hs b/hydra-cluster/src/Hydra/Cluster/Scenarios.hs index 8e9f9bb450e..92443d4fe55 100644 --- a/hydra-cluster/src/Hydra/Cluster/Scenarios.hs +++ b/hydra-cluster/src/Hydra/Cluster/Scenarios.hs @@ -6,9 +6,6 @@ module Hydra.Cluster.Scenarios where import Hydra.Prelude import Test.Hydra.Prelude -import qualified Cardano.Api.Shelley as C -import qualified PlutusTx.Prelude as PlutusTx -import qualified PlutusLedgerApi.V1 as PV1 import Cardano.Api.UTxO qualified as UTxO import CardanoClient ( QueryPoint (QueryTip), @@ -19,7 +16,6 @@ import CardanoClient ( submitTx, waitForUTxO, ) -import Hydra.Contract.Dummy (dummyValidatorHash) import CardanoNode (NodeLog) import Control.Concurrent.Async (mapConcurrently_) import Control.Lens ((^..), (^?)) @@ -42,11 +38,8 @@ import Hydra.Cardano.Api ( File (File), Key (SigningKey), PaymentKey, - StakeAddressReference(..), - PaymentCredential(..), + ToTxContext (toTxContext), Tx, - shelleyBasedEra, - makeShelleyAddressInEra, TxId, UTxO, getTxBody, @@ -79,7 +72,7 @@ import Hydra.Cluster.Fixture (Actor (..), actorName, alice, aliceSk, aliceVk, bo import Hydra.Cluster.Mithril (MithrilLog) import Hydra.Cluster.Options (Options) import Hydra.Cluster.Util (chainConfigFor, keysFor, modifyConfig, setNetworkId) -import Hydra.Ledger.Cardano (addInputs, emptyTxBody, mkSimpleTx, mkTransferTx, unsafeBuildTransaction) +import Hydra.Ledger.Cardano (addCollateralInput, addInputs, addOutputs, emptyTxBody, mkSimpleTx, mkTransferTx, unsafeBuildTransaction) import Hydra.Logging (Tracer, traceWith) import Hydra.Options (DirectChainConfig (..), networkId, startChainFrom) import Hydra.Tx (HeadId, IsTx (balance), Party, txId) @@ -100,6 +93,7 @@ import HydraNode ( waitMatch, withHydraCluster, withHydraNode, + withHydraNodeRealFee, ) import Network.HTTP.Conduit (parseUrlThrow) import Network.HTTP.Conduit qualified as L @@ -402,32 +396,80 @@ singlePartyUsesSchnorrkelScriptOnL2 tracer workDir node hydraScriptsTxId = 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 + withHydraNodeRealFee 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] - scriptHash <- unTransScriptHash dummyValidatorHash - let scriptAddress = makeShelleyAddressInEra shelleyBasedEra networkId (PaymentCredentialByScript scriptHash) NoStakeAddress - let i = undefined - let o = undefined - let tx = mkSimpleTx (i, o) (scriptAddress, txOutValue o) walletSk - send n1 $ input "NewTx" ["transaction" .= tx] + (clientPayload, scriptUTxO) <- prepareScriptPayload + 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 (i, o) = List.head $ UTxO.pairs scriptUTxO + + let serializedScript = PlutusScriptSerialised dummyValidatorScript + let scriptWitness = + BuildTxWith $ + ScriptWitness scriptWitnessInCtx $ + mkScriptWitness serializedScript (mkScriptDatum ()) (toScriptData ()) + let tx = + unsafeBuildTransaction $ + emptyTxBody + & addInputs [(i, scriptWitness)] + & addCollateralInput collateralInput + & addOutputs [toTxContext o] + 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 - unTransScriptHash :: PV1.ScriptHash -> IO C.ScriptHash - unTransScriptHash (PV1.ScriptHash vh) = - case C.deserialiseFromRawBytes C.AsScriptHash $ PlutusTx.fromBuiltin vh of - Left e -> fail $ show e - Right x -> pure x + where + RunningNode{networkId, nodeSocket, blockTime} = node + -- TODO: extract this to standalone function + prepareScriptPayload = do + let script = dummyValidatorScript + let serializedScript = PlutusScriptSerialised script + let scriptAddress = mkScriptAddress networkId serializedScript + let datumHash = mkTxOutDatumHash () + (scriptIn, scriptOut) <- createOutputAtAddress node scriptAddress datumHash (lovelaceToValue 0) + let scriptUTxO = UTxO.singleton (scriptIn, scriptOut) + let scriptWitness = + BuildTxWith $ + ScriptWitness scriptWitnessInCtx $ + mkScriptWitness serializedScript (mkScriptDatum ()) (toScriptData ()) + let spendingTx = + unsafeBuildTransaction $ + emptyTxBody + & addInputs [(scriptIn, scriptWitness)] + pure + ( Aeson.object + [ "blueprintTx" .= spendingTx + , "utxo" .= scriptUTxO + ] + , scriptUTxO + ) singlePartyCommitsScriptBlueprint :: Tracer IO EndToEndLog -> diff --git a/hydra-cluster/src/HydraNode.hs b/hydra-cluster/src/HydraNode.hs index 420434566b8..73295296fc5 100644 --- a/hydra-cluster/src/HydraNode.hs +++ b/hydra-cluster/src/HydraNode.hs @@ -310,7 +310,7 @@ withHydraNode :: IO a withHydraNode tracer chainConfig workDir hydraNodeId hydraSKey hydraVKeys allNodeIds action = do withLogFile logFilePath $ \logFileHandle -> do - withHydraNode' tracer chainConfig workDir hydraNodeId hydraSKey hydraVKeys allNodeIds (Just logFileHandle) $ do + withHydraNode' tracer chainConfig workDir hydraNodeId hydraSKey hydraVKeys allNodeIds (Just logFileHandle) True $ do \_ err processHandle -> do race (checkProcessHasNotDied ("hydra-node (" <> show hydraNodeId <> ")") processHandle (Just err)) @@ -319,6 +319,31 @@ withHydraNode tracer chainConfig workDir hydraNodeId hydraSKey hydraVKeys allNod where logFilePath = workDir "logs" "hydra-node-" <> show hydraNodeId <.> "log" +-- | Run a hydra-node with given 'ChainConfig', and real protocol parameters (no zero fees). +withHydraNodeRealFee :: + Tracer IO HydraNodeLog -> + ChainConfig -> + FilePath -> + Int -> + SigningKey HydraKey -> + [VerificationKey HydraKey] -> + [Int] -> + (HydraClient -> IO a) -> + IO a +withHydraNodeRealFee tracer chainConfig workDir hydraNodeId hydraSKey hydraVKeys allNodeIds action = do + withLogFile logFilePath $ \logFileHandle -> do + withHydraNode' tracer chainConfig workDir hydraNodeId hydraSKey hydraVKeys allNodeIds (Just logFileHandle) True $ do + \_ err processHandle -> do + race + (checkProcessHasNotDied ("hydra-node (" <> show hydraNodeId <> ")") processHandle (Just err)) + (withConnectionToNode tracer hydraNodeId action) + <&> either absurd id + where + logFilePath = workDir "logs" "hydra-node-" <> show hydraNodeId <.> "log" + +-- | A bit of boolean blindness, if this type is True we should zero the fees in queried protocol parameters. +type ZeroFees = Bool + -- | Run a hydra-node with given 'ChainConfig' and using the config from -- config/. withHydraNode' :: @@ -331,9 +356,10 @@ withHydraNode' :: [Int] -> -- | If given use this as std out. Maybe Handle -> + ZeroFees -> (Handle -> Handle -> ProcessHandle -> IO a) -> IO a -withHydraNode' tracer chainConfig workDir hydraNodeId hydraSKey hydraVKeys allNodeIds mGivenStdOut action = do +withHydraNode' tracer chainConfig workDir hydraNodeId hydraSKey hydraVKeys allNodeIds mGivenStdOut zeroFees action = do -- NOTE: AirPlay on MacOS uses 5000 and we must avoid it. when (os == "darwin") $ port `shouldNotBe` (5_000 :: Network.PortNumber) withSystemTempDirectory "hydra-node" $ \dir -> do @@ -346,11 +372,15 @@ withHydraNode' tracer chainConfig workDir hydraNodeId hydraSKey hydraVKeys allNo -- NOTE: This implicitly tests of cardano-cli with hydra-node protocolParameters <- cliQueryProtocolParameters nodeSocket networkId Aeson.encodeFile cardanoLedgerProtocolParametersFile $ - protocolParameters - & atKey "txFeeFixed" ?~ toJSON (Number 0) - & atKey "txFeePerByte" ?~ toJSON (Number 0) - & key "executionUnitPrices" . atKey "priceMemory" ?~ toJSON (Number 0) - & key "executionUnitPrices" . atKey "priceSteps" ?~ toJSON (Number 0) + if zeroFees + then + protocolParameters + & atKey "txFeeFixed" ?~ toJSON (Number 0) + & atKey "txFeePerByte" ?~ toJSON (Number 0) + & key "executionUnitPrices" . atKey "priceMemory" ?~ toJSON (Number 0) + & key "executionUnitPrices" . atKey "priceSteps" ?~ toJSON (Number 0) + else + protocolParameters let hydraSigningKey = dir (show hydraNodeId <> ".sk") void $ writeFileTextEnvelope (File hydraSigningKey) Nothing hydraSKey @@ -384,14 +414,14 @@ withHydraNode' tracer chainConfig workDir hydraNodeId hydraSKey hydraVKeys allNo } ) { std_out = maybe CreatePipe UseHandle mGivenStdOut - , std_err = CreatePipe + , std_err = Inherit } traceWith tracer $ HydraNodeCommandSpec $ show $ cmdspec p withCreateProcess p $ \_stdin mCreatedStdOut mCreatedStdErr processHandle -> case (mCreatedStdOut <|> mGivenStdOut, mCreatedStdErr) of - (Just out, Just err) -> action out err processHandle + (Just out, Nothing) -> action out stderr processHandle (Nothing, _) -> error "Should not happen™" (_, Nothing) -> error "Should not happen™" where diff --git a/hydra-cluster/test/Test/EndToEndSpec.hs b/hydra-cluster/test/Test/EndToEndSpec.hs index 783d886ef08..ed37690ee8c 100644 --- a/hydra-cluster/test/Test/EndToEndSpec.hs +++ b/hydra-cluster/test/Test/EndToEndSpec.hs @@ -520,7 +520,7 @@ spec = around (showLogsOnFailure "EndToEndSpec") $ do let hydraTracer = contramap FromHydraNode tracer hydraScriptsTxId <- publishHydraScriptsAs node Faucet chainConfig <- chainConfigFor Alice dir nodeSocket hydraScriptsTxId [] (UnsafeContestationPeriod 1) - withHydraNode' hydraTracer chainConfig dir 1 aliceSk [] [1] Nothing $ \stdOut _ _processHandle -> do + withHydraNode' hydraTracer chainConfig dir 1 aliceSk [] [1] Nothing False $ \stdOut _ _processHandle -> do waitForLog 10 stdOut "JSON object with key NodeOptions" $ \line -> line ^? key "message" . key "tag" == Just (Aeson.String "NodeOptions") diff --git a/hydra-tx/src/Hydra/Ledger/Cardano/Builder.hs b/hydra-tx/src/Hydra/Ledger/Cardano/Builder.hs index bd996c69643..31d4919dcea 100644 --- a/hydra-tx/src/Hydra/Ledger/Cardano/Builder.hs +++ b/hydra-tx/src/Hydra/Ledger/Cardano/Builder.hs @@ -83,6 +83,11 @@ addInputs :: TxIns BuildTx -> TxBodyContent BuildTx -> TxBodyContent BuildTx addInputs ins tx = tx{txIns = txIns tx <> ins} +-- | Add new inputs to an ongoing builder. +addCollateralInput :: TxIn -> TxBodyContent BuildTx -> TxBodyContent BuildTx +addCollateralInput txin tx = + tx{txInsCollateral = TxInsCollateral [txin]} + addReferenceInputs :: [TxIn] -> TxBodyContent BuildTx -> TxBodyContent BuildTx addReferenceInputs refs' tx = tx