From 1944e7c05d2734dc23ce7eb2b1bfdaf3b565d32a Mon Sep 17 00:00:00 2001 From: Mateusz Galazyn Date: Thu, 28 May 2026 09:38:29 +0200 Subject: [PATCH 1/4] Update tx-generator to not use deprecated cardano-api api --- .gitignore | 1 - bench/tx-generator/app/calibrate-script.hs | 177 +++++++++++------- .../src/Cardano/Benchmarking/GeneratorTx.hs | 8 +- .../Benchmarking/GeneratorTx/SizedMetadata.hs | 89 +++------ .../Benchmarking/GeneratorTx/Submission.hs | 34 ++-- .../GeneratorTx/SubmissionClient.hs | 44 ++--- .../src/Cardano/Benchmarking/Script/Core.hs | 101 +++++----- .../src/Cardano/Benchmarking/Script/Ogmios.hs | 18 +- .../Cardano/Benchmarking/Script/Selftest.hs | 4 +- .../Cardano/Benchmarking/Script/Submission.hs | 4 +- .../src/Cardano/Benchmarking/Wallet.hs | 3 +- .../src/Cardano/TxGenerator/Fund.hs | 14 +- .../src/Cardano/TxGenerator/Genesis.hs | 85 +++++---- .../src/Cardano/TxGenerator/PureExample.hs | 49 ++--- .../src/Cardano/TxGenerator/Tx.hs | 79 ++++---- .../src/Cardano/TxGenerator/Types.hs | 4 +- .../src/Cardano/TxGenerator/UTxO.hs | 96 +++++----- .../src/Cardano/TxGenerator/Utils.hs | 24 +-- bench/tx-generator/test/Main.hs | 19 +- bench/tx-generator/tx-generator.cabal | 19 +- 20 files changed, 419 insertions(+), 453 deletions(-) diff --git a/.gitignore b/.gitignore index 617e5c62f91..2a5afd35786 100644 --- a/.gitignore +++ b/.gitignore @@ -77,5 +77,4 @@ cardano-tracer/cardano-tracer-test .idea/ .codex - .serena/ diff --git a/bench/tx-generator/app/calibrate-script.hs b/bench/tx-generator/app/calibrate-script.hs index d41799eeea7..6f1c9b273d7 100644 --- a/bench/tx-generator/app/calibrate-script.hs +++ b/bench/tx-generator/app/calibrate-script.hs @@ -1,8 +1,10 @@ {-# LANGUAGE CPP #-} +{-# LANGUAGE DataKinds #-} {-# LANGUAGE GADTs #-} {-# LANGUAGE LambdaCase #-} {-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE NumericUnderscores #-} +{-# LANGUAGE RankNTypes #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE ScopedTypeVariables #-} @@ -10,27 +12,44 @@ {-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-} -import Cardano.Api +import Cardano.Api hiding (eraProtVerHigh) +import Cardano.Api.Experimental (AnyWitness (..), IsEra (useEra), + PlutusScriptDatum (..), PlutusScriptPurpose (..), SignedTx (..), + eraProtVerHigh, makeKeyWitness, makeUnsignedTx, + obtainCommonConstraints, signTx, toPlutusSLanguage) +import Cardano.Api.Experimental.AnyScriptWitness (AnyPlutusScriptWitness (..), + createPlutusSpendingScriptWitness) +import qualified Cardano.Api.Experimental as Exp (PlutusScriptInEra (..), + PlutusScriptOrReferenceInput (..), PlutusScriptWitness (..), + evaluateTransactionFee) +import Cardano.Api.Experimental.Plutus (AnyPlutusScript (..), + plutusScriptInEraSLanguage) +import qualified Cardano.Api.Experimental.Tx as Exp + +import Cardano.Ledger.Core (mkCoinTxOut) +import qualified Cardano.Ledger.Plutus.Language as L (PlutusLanguage, Plutus (..), PlutusBinary (..), + SLanguage (..), decodePlutusRunnable) import Cardano.Benchmarking.Compiler (keyBenchmarkInputs) import Cardano.Benchmarking.GeneratorTx.SizedMetadata (mkMetadata) import Cardano.TxGenerator.Calibrate.Utils import Cardano.TxGenerator.PlutusContext -import Cardano.TxGenerator.ProtocolParameters ( ProtocolParameters (..), convertToLedgerProtocolParameters, - toLedgerPParams) +import Cardano.TxGenerator.ProtocolParameters (ProtocolParameters (..), + convertToLedgerProtocolParameters) import Cardano.TxGenerator.Setup.Plutus import Cardano.TxGenerator.Tx (txSizeInBytes) import Cardano.TxGenerator.Types import Cardano.TxGenerator.Utils (keyAddress, mkTxIn) import Control.Exception +import Data.Typeable (Typeable) import Data.Aeson (decodeFileStrict') import qualified Data.ByteString.Lazy.Char8 as BSL (writeFile) + import Data.Char import Data.Function (on, (&)) import Data.List (nub, sort, transpose) import Data.List.Extra (split) - import Data.Map.Strict as Map (Map, empty, fromList, union) import Data.Maybe import qualified Data.Text as T @@ -157,6 +176,17 @@ runPlutus strategy budgetType protoParamFile plutusDef@PlutusOn{..} scales = do protocolParameters <- readProtocolParametersOrDie protoParamFile (script, resolvedTo) <- either (error . show) pure =<< readPlutusScript plutusScript + let era = useEra @ConwayEra + anyPlutusScript <- obtainCommonConstraints era $ + case script of + ScriptInAnyLang _lang (PlutusScript version (PlutusScriptSerialised sbs)) -> do + let slang = toPlutusSLanguage version + decode :: forall l. (L.PlutusLanguage l, Typeable l) => L.SLanguage l -> IO (AnyPlutusScript (ShelleyLedgerEra ConwayEra)) + decode _ = case L.decodePlutusRunnable @l (eraProtVerHigh era) (L.Plutus (L.PlutusBinary sbs)) of + Left err -> throwIO $ userError $ "script decode failed: " ++ show err + Right runnable -> pure $ AnyPlutusScript (Exp.PlutusScriptInEra runnable) + obtainLangConstraints slang $ decode slang + _ -> throwIO $ userError "expected a Plutus script" let redeemerDef = Right plutusDef @@ -189,7 +219,10 @@ runPlutus strategy budgetType protoParamFile plutusDef@PlutusOn{..} scales jsonName = "summaries_" ++ scriptName <.> "json" csvName = "scaling_" ++ scriptName <.> "csv" - summariesWithApprox <- mapM (approximateTxProperties script protocolParameters) summaries + ledgerProtocolParameters <- + either (error . docToString . prettyError) pure + $ convertToLedgerProtocolParameters shelleyBasedEra protocolParameters + summariesWithApprox <- mapM (approximateTxProperties anyPlutusScript ledgerProtocolParameters) summaries writeResultsJSON jsonName summariesWithApprox writeResultsCSV csvName summariesWithApprox @@ -481,75 +514,75 @@ writeResultsJSON jsonName summaries = do -- | Builds a dummy transaction that resembles the ones submitted during some Plutus benchmark and -- uses it to augment the budget summary with txn size and fee. -- * If anything fails to evaluate, the summary is returned unchanged. --- * This function is currently monorphic in the ledger era and will resolve era parameters to Conway. -approximateTxProperties :: ScriptInAnyLang -> ProtocolParameters -> (PlutusBudgetSummary, ScriptRedeemer) -> IO PlutusBudgetSummary -approximateTxProperties script protocolParameters (summary, redeemer) = do +-- * This function is currently monomorphic in the ledger era and will resolve era parameters to Conway. +approximateTxProperties :: AnyPlutusScript (ShelleyLedgerEra ConwayEra) -> LedgerProtocolParameters ConwayEra -> (PlutusBudgetSummary, ScriptRedeemer) -> IO PlutusBudgetSummary +approximateTxProperties (AnyPlutusScript ps) ledgerProtocolParameters (summary, redeemer) = do putStrLn $ "--> approximating txn size and fee for: " ++ messageId summary - evaluate $ summary - { projectedTxSize = Just $ txSizeInBytes dummyTx - , projectedTxFee = Just $ evaluateTransactionFee era ledgerPParams2 (getTxBody dummyTx) 2 0 0 -- 1 (script witness) + 1 (collateral) = 2 - } - - `catch` \(SomeException e) -> do - putStrLn $ "approximation failed: " ++ show e - ++ "\n--> using unmodified summary" - pure summary - where - era = ShelleyBasedEraConway - - ledgerPParams1 :: LedgerProtocolParameters ConwayEra - ledgerPParams1 = - either (error . docToString . prettyError) id - $ convertToLedgerProtocolParameters era protocolParameters - - ledgerPParams2 = - either (error . docToString . prettyError) id - $ toLedgerPParams era protocolParameters - - witness :: Witness WitCtxTxIn ConwayEra - witness = - fromMaybe (error "could not get PlutusScriptWitness") - $ case script of - ScriptInAnyLang lang (PlutusScript version script') -> do - scriptLang <- scriptLanguageSupportedInEra era lang - pure - $ ScriptWitness ScriptWitnessForSpending - $ PlutusScriptWitness - scriptLang - version - (PScript script') - (ScriptDatumForTxIn $ Just $ unsafeHashableScriptData $ ScriptDataNumber 0) - redeemer - (budgetUsedPerTxInput summary) - _ -> Nothing - - -- build a dummy tx akin to what we'd get in the tx-generator's benchmarking workload; - -- it just needs to be sufficient to get our approximations. - dummyTx :: Tx ConwayEra - dummyTx - = signShelleyTransaction era txbody [WitnessPaymentKey keyBenchmarkInputs] - where - txbody = - either (error . docToString . prettyError) id - $ createTransactionBody era content - - content = - defaultTxBodyContent era - & setTxIns [(dummyTxIn 0, BuildTxWith witness)] - & setTxInsCollateral (TxInsCollateral AlonzoEraOnwardsConway [dummyTxIn 1]) - & setTxOuts [dummyTxOut] - & setTxValidityLowerBound TxValidityNoLowerBound - & setTxValidityUpperBound (defaultTxValidityUpperBound era) - & setTxMetadata dummyMetadata - & setTxFee (TxFeeExplicit era 1_000_000) - & setTxProtocolParams (BuildTxWith (Just ledgerPParams1)) - + let + era = useEra @ConwayEra + pparams = unLedgerProtocolParameters ledgerProtocolParameters + slang = plutusScriptInEraSLanguage ps + dummyDatum = unsafeHashableScriptData $ ScriptDataNumber 0 + datum = mkSpendingScriptDatum slang dummyDatum + anyWitness = + let witness = Exp.PlutusScriptWitness slang (Exp.PScript ps) datum redeemer (budgetUsedPerTxInput summary) + in AnyPlutusScriptWitness (AnyPlutusSpendingScriptWitness (createPlutusSpendingScriptWitness slang witness)) + obtainCommonConstraints era (do -- Corresponds to the metadata inserted in benchmarking workloads, which is why it's needed for the estimate. -- default value taken from: `add_tx_size` in nix/nixos/tx-generator-service.nix - dummyMetadata :: TxMetadataInEra ConwayEra - dummyMetadata = either error id $ mkMetadata 100 + dummyMetadata <- either (\e -> throwIO $ userError $ "approximateTxProperties: mkMetadata: " ++ e) pure + $ mkMetadata @ConwayEra 100 + let + expMetadata = case dummyMetadata of + TxMetadataNone -> mempty + TxMetadataInEra _ m -> m + + -- just placeholders + dummyTxIn ix = mkTxIn $ "900fc5da77a0747da53f7675cbb7d149d46779346dea2f879ab811ccc72a2162#" <> textShow @Int ix + dummyTxOut :: Exp.TxOut (ShelleyLedgerEra ConwayEra) + dummyTxOut = Exp.TxOut $ mkCoinTxOut (toShelleyAddr $ keyAddress @ConwayEra (Testnet (NetworkMagic 42)) keyBenchmarkInputs) (Coin 1_000_000) + + -- build a dummy tx akin to what we'd get in the tx-generator's benchmarking workload; + -- it just needs to be sufficient to get our approximations. + txBodyContent = + Exp.defaultTxBodyContent + & Exp.setTxIns [(dummyTxIn 0, anyWitness)] + & Exp.setTxInsCollateral [dummyTxIn 1] + & Exp.setTxOuts [dummyTxOut] + & Exp.setTxFee (Coin 1_000_000) + & Exp.setTxMetadata expMetadata + & Exp.setTxProtocolParams pparams + + unsignedTx <- either (\err -> throwIO $ userError $ "approximateTxProperties: " ++ show err) pure + $ makeUnsignedTx era txBodyContent + + let + witVKey = makeKeyWitness era unsignedTx (WitnessPaymentKey keyBenchmarkInputs) + dummyTx :: SignedTx ConwayEra + dummyTx = signTx era [] [witVKey] unsignedTx - -- just placeholders - dummyTxIn ix = mkTxIn $ "900fc5da77a0747da53f7675cbb7d149d46779346dea2f879ab811ccc72a2162#" <> textShow @Int ix - dummyTxOut = TxOut (keyAddress (Testnet (NetworkMagic 42)) keyBenchmarkInputs) (lovelaceToTxOutValue era 1_000_000) TxOutDatumNone ReferenceScriptNone + pure summary + { projectedTxSize = Just $ txSizeInBytes dummyTx + , projectedTxFee = Just $ Exp.evaluateTransactionFee pparams unsignedTx 2 0 0 -- 1 (script witness) + 1 (collateral) = 2 + } + ) `catch` \(SomeException e) -> do + putStrLn $ "approximation failed: " ++ show e + ++ "\n--> using unmodified summary" + pure summary + +-- TODO: remove these vendored functions and import from +-- Cardano.Api.Experimental when the published cardano-api version includes them. + +obtainLangConstraints :: L.SLanguage lang -> ((L.PlutusLanguage lang, Typeable lang) => a) -> a +obtainLangConstraints L.SPlutusV1 f = f +obtainLangConstraints L.SPlutusV2 f = f +obtainLangConstraints L.SPlutusV3 f = f +obtainLangConstraints L.SPlutusV4 f = f + +mkSpendingScriptDatum :: L.SLanguage lang -> HashableScriptData -> PlutusScriptDatum lang 'SpendingScript +mkSpendingScriptDatum = \case + L.SPlutusV1 -> SpendingScriptDatum + L.SPlutusV2 -> SpendingScriptDatum + L.SPlutusV3 -> SpendingScriptDatum . Just + L.SPlutusV4 -> SpendingScriptDatum . Just diff --git a/bench/tx-generator/src/Cardano/Benchmarking/GeneratorTx.hs b/bench/tx-generator/src/Cardano/Benchmarking/GeneratorTx.hs index ed4844e62f1..74c2505c6f0 100644 --- a/bench/tx-generator/src/Cardano/Benchmarking/GeneratorTx.hs +++ b/bench/tx-generator/src/Cardano/Benchmarking/GeneratorTx.hs @@ -4,6 +4,7 @@ {-# LANGUAGE RankNTypes #-} {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeApplications #-} {-# LANGUAGE UndecidableInstances #-} {-# OPTIONS_GHC -Wno-all-missed-specialisations #-} @@ -19,7 +20,8 @@ module Cardano.Benchmarking.GeneratorTx , waitBenchmark ) where -import Cardano.Api hiding (txFee, label) +import Cardano.Api hiding (label, txFee) +import Cardano.Api.Experimental (IsEra, obtainCommonConstraints, useEra) import Cardano.Benchmarking.GeneratorTx.NodeToNode import Cardano.Benchmarking.GeneratorTx.Submission @@ -110,7 +112,7 @@ handleTxSubmissionClientError LogErrors -> traceWith traceSubmit $ TraceBenchTxSubError (pack errDesc) -walletBenchmark :: forall era. IsShelleyBasedEra era +walletBenchmark :: forall era. IsEra era => Trace IO (TraceBenchTxSubmit TxId) -> Trace IO NodeToNodeSubmissionTrace -> ConnectClient @@ -137,7 +139,7 @@ walletBenchmark _era count txSource - = liftIO $ do + = obtainCommonConstraints (useEra @era) $ liftIO $ do traceDebug "******* Tx generator, phase 2: pay to recipients *******" let numTargets :: Natural = fromIntegral $ NE.length targets diff --git a/bench/tx-generator/src/Cardano/Benchmarking/GeneratorTx/SizedMetadata.hs b/bench/tx-generator/src/Cardano/Benchmarking/GeneratorTx/SizedMetadata.hs index fa47d5bb538..8df6fd2ce25 100644 --- a/bench/tx-generator/src/Cardano/Benchmarking/GeneratorTx/SizedMetadata.hs +++ b/bench/tx-generator/src/Cardano/Benchmarking/GeneratorTx/SizedMetadata.hs @@ -1,4 +1,3 @@ -{-# OPTIONS_GHC -Wno-deprecations #-} {- HLINT ignore "Use camelCase" -} {- HLINT ignore "Use uncurry" -} {-# LANGUAGE GADTs #-} @@ -8,6 +7,9 @@ module Cardano.Benchmarking.GeneratorTx.SizedMetadata where import Cardano.Api +import Cardano.Api.Experimental (AnyWitness (..), IsEra (useEra), SignedTx (..), + makeUnsignedTx, obtainCommonConstraints, signTx) +import qualified Cardano.Api.Experimental.Tx as Exp import Cardano.TxGenerator.Utils @@ -27,67 +29,31 @@ maxBSSize = 64 -- Properties of the underlying/opaque CBOR encoding. assume_cbor_properties :: Bool assume_cbor_properties - = prop_mapCostsShelley - && prop_mapCostsAllegra - && prop_mapCostsMary - && prop_mapCostsAlonzo - && prop_mapCostsBabbage - && prop_bsCostsShelley - && prop_bsCostsAllegra - && prop_bsCostsMary - && prop_bsCostsAlonzo - && prop_bsCostsBabbage + = prop_mapCostsConway + && prop_mapCostsDijkstra && prop_bsCostsConway + && prop_bsCostsDijkstra -- The cost of map entries in metadata follows a step function. -- This assumes the map indices are [0..n]. -prop_mapCostsShelley :: Bool -prop_mapCostsAllegra :: Bool -prop_mapCostsMary :: Bool -prop_mapCostsAlonzo :: Bool -prop_mapCostsBabbage :: Bool prop_mapCostsConway :: Bool prop_mapCostsDijkstra :: Bool -prop_mapCostsShelley = measureMapCosts AsShelleyEra == assumeMapCosts AsShelleyEra -prop_mapCostsAllegra = measureMapCosts AsAllegraEra == assumeMapCosts AsAllegraEra -prop_mapCostsMary = measureMapCosts AsMaryEra == assumeMapCosts AsMaryEra -prop_mapCostsAlonzo = measureMapCosts AsAlonzoEra == assumeMapCosts AsAlonzoEra -prop_mapCostsBabbage = measureMapCosts AsBabbageEra == assumeMapCosts AsBabbageEra prop_mapCostsConway = measureMapCosts AsConwayEra == assumeMapCosts AsConwayEra prop_mapCostsDijkstra = measureMapCosts AsDijkstraEra == assumeMapCosts AsDijkstraEra -assumeMapCosts :: forall era . IsShelleyBasedEra era => AsType era -> [Int] +assumeMapCosts :: AsType era -> [Int] assumeMapCosts _proxy = stepFunction [ ( 1 , 0) -- An empty map of metadata has the same cost as TxMetadataNone. - , ( 1 , firstEntry) -- Using Metadata costs 37 or 39 bytes (first map entry). + , ( 1 , 42) -- Using Metadata costs 42 bytes (first map entry). , ( 22 , 2) -- The next 22 entries cost 2 bytes each. , ( 233 , 3) -- 233 entries at 3 bytes. , ( 744 , 4) -- 744 entries at 4 bytes. ] - where - firstEntry = case shelleyBasedEra @era of - ShelleyBasedEraShelley -> 37 - ShelleyBasedEraAllegra -> 39 - ShelleyBasedEraMary -> 39 - ShelleyBasedEraAlonzo -> 42 - ShelleyBasedEraBabbage -> 42 - ShelleyBasedEraConway -> 42 - ShelleyBasedEraDijkstra -> 42 -- Bytestring costs are not LINEAR !! -- Costs are piecewise linear for payload sizes [0..23] and [24..64]. -prop_bsCostsShelley :: Bool -prop_bsCostsAllegra :: Bool -prop_bsCostsMary :: Bool -prop_bsCostsAlonzo :: Bool -prop_bsCostsBabbage :: Bool prop_bsCostsConway :: Bool prop_bsCostsDijkstra :: Bool -prop_bsCostsShelley = measureBSCosts AsShelleyEra == [37..60] ++ [62..102] -prop_bsCostsAllegra = measureBSCosts AsAllegraEra == [39..62] ++ [64..104] -prop_bsCostsMary = measureBSCosts AsMaryEra == [39..62] ++ [64..104] -prop_bsCostsAlonzo = measureBSCosts AsAlonzoEra == [42..65] ++ [67..107] -prop_bsCostsBabbage = measureBSCosts AsBabbageEra == [42..65] ++ [67..107] prop_bsCostsConway = measureBSCosts AsConwayEra == [42..65] ++ [67..107] prop_bsCostsDijkstra = measureBSCosts AsDijkstraEra == [42..65] ++ [67..107] @@ -97,7 +63,7 @@ stepFunction f = scanl1 (+) steps -- Measure the cost of metadata map entries. -- This is the cost of the index with an empty BS as payload. -measureMapCosts :: forall era . IsShelleyBasedEra era => AsType era -> [Int] +measureMapCosts :: forall era . IsEra era => AsType era -> [Int] measureMapCosts era = map (metadataSize era . Just . replicateEmptyBS) [0..maxMapSize] where replicateEmptyBS :: Int -> TxMetadata @@ -107,31 +73,30 @@ listMetadata :: [TxMetadataValue] -> TxMetadata listMetadata l = makeTransactionMetadata $ Map.fromList $ zip [0..] l -- Cost of metadata with a single BS of size [0..maxBSSize]. -measureBSCosts :: forall era . IsShelleyBasedEra era => AsType era -> [Int] +measureBSCosts :: forall era . IsEra era => AsType era -> [Int] measureBSCosts era = map (metadataSize era . Just . bsMetadata) [0..maxBSSize] where bsMetadata s = listMetadata [TxMetaBytes $ BS.replicate s 0] -metadataSize :: forall era . IsShelleyBasedEra era => AsType era -> Maybe TxMetadata -> Int +metadataSize :: forall era . IsEra era => AsType era -> Maybe TxMetadata -> Int metadataSize p m = dummyTxSize p m - dummyTxSize p Nothing -dummyTxSizeInEra :: IsShelleyBasedEra era => TxMetadataInEra era -> Int -dummyTxSizeInEra metadata = case createTransactionBody shelleyBasedEra dummyTx of - Right b -> BS.length $ serialiseToCBOR b - Left err -> error $ "metaDataSize " ++ show err +dummyTxSizeInEra :: forall era . IsEra era => TxMetadataInEra era -> Int +dummyTxSizeInEra metadata = obtainCommonConstraints era $ BS.length $ serialiseToRawBytes dummyTx where - dummyTx = defaultTxBodyContent shelleyBasedEra - & setTxIns - [ ( mkTxIn "dbaff4e270cfb55612d9e2ac4658a27c79da4a5271c6f90853042d1403733810#0" - , BuildTxWith $ KeyWitness KeyWitnessForSpending - ) - ] - & setTxFee (mkTxFee 0) - & setTxValidityLowerBound TxValidityNoLowerBound - & setTxValidityUpperBound (mkTxValidityUpperBound 0) - & setTxMetadata metadata - -dummyTxSize :: forall era . IsShelleyBasedEra era => AsType era -> Maybe TxMetadata -> Int -dummyTxSize _p m = (dummyTxSizeInEra @era) $ metadataInEra m + era = useEra @era + expMetadata = case metadata of + TxMetadataNone -> mempty + TxMetadataInEra _ m -> m + txBodyContent = Exp.defaultTxBodyContent + & Exp.setTxIns [(mkTxIn "dbaff4e270cfb55612d9e2ac4658a27c79da4a5271c6f90853042d1403733810#0", AnyKeyWitnessPlaceholder)] + & Exp.setTxMetadata expMetadata + dummyTx :: SignedTx era + dummyTx = signTx era [] [] unsignedTx + where + unsignedTx = either (\err -> error $ "dummyTxSizeInEra: " ++ show err) id $ makeUnsignedTx era txBodyContent + +dummyTxSize :: forall era . IsEra era => AsType era -> Maybe TxMetadata -> Int +dummyTxSize _p m = obtainCommonConstraints (useEra @era) $ dummyTxSizeInEra @era (metadataInEra m) metadataInEra :: forall era . IsShelleyBasedEra era => Maybe TxMetadata -> TxMetadataInEra era metadataInEra Nothing = TxMetadataNone diff --git a/bench/tx-generator/src/Cardano/Benchmarking/GeneratorTx/Submission.hs b/bench/tx-generator/src/Cardano/Benchmarking/GeneratorTx/Submission.hs index 35512fdfe8e..f93d0c8cbb7 100644 --- a/bench/tx-generator/src/Cardano/Benchmarking/GeneratorTx/Submission.hs +++ b/bench/tx-generator/src/Cardano/Benchmarking/GeneratorTx/Submission.hs @@ -29,28 +29,24 @@ module Cardano.Benchmarking.GeneratorTx.Submission , txStreamSource ) where +import Cardano.Api.Experimental (SignedTx) + +import Cardano.Benchmarking.GeneratorTx.SubmissionClient +import Cardano.Benchmarking.LogTypes +import Cardano.Benchmarking.TpsThrottle +import Cardano.Benchmarking.Types +import Cardano.Benchmarking.Wallet import Cardano.Prelude hiding (ByteString, atomically, retry, state, threadDelay) +import Cardano.TxGenerator.Types (TPSRate, TxGenError) +import Ouroboros.Network.Protocol.TxSubmission2.Type (SingBlockingStyle (..)) + import Prelude (String, error) import qualified Control.Concurrent.STM as STM - -import qualified Streaming.Prelude as Streaming - import Data.Time.Clock (NominalDiffTime, UTCTime) import qualified Data.Time.Clock as Clock - -import Ouroboros.Network.Protocol.TxSubmission2.Type (SingBlockingStyle (..)) - -import Cardano.Api hiding (Active) -import Cardano.TxGenerator.Types (TPSRate, TxGenError) - -import Cardano.Benchmarking.LogTypes -import Cardano.Benchmarking.TpsThrottle -import Cardano.Benchmarking.Types - -import Cardano.Benchmarking.GeneratorTx.SubmissionClient -import Cardano.Benchmarking.Wallet +import qualified Streaming.Prelude as Streaming {------------------------------------------------------------------------------- Parametrisation & state @@ -119,7 +115,7 @@ mkSubmissionSummary startTime reportsRefs txStreamSource :: forall era. MVar (StreamState (TxStream IO era)) -> TpsThrottle -> TxSource era txStreamSource streamRef tpsThrottle = Active worker where - worker :: forall m blocking . MonadIO m => SingBlockingStyle blocking -> Req -> m (TxSource era, [Tx era]) + worker :: forall m blocking . MonadIO m => SingBlockingStyle blocking -> Req -> m (TxSource era, [SignedTx era]) worker blocking req = do (done, txCount) <- case blocking of SingBlocking -> liftIO $ consumeTxsBlocking tpsThrottle req @@ -129,7 +125,7 @@ txStreamSource streamRef tpsThrottle = Active worker Stop -> return (Exhausted, txList) Next -> return (Active worker, txList) - unFold :: Int -> IO [Tx era] + unFold :: Int -> IO [SignedTx era] unFold 0 = return [] unFold n = nextOnMVar streamRef >>= \case -- Node2node clients buffer a number x of TXs internally (x is determined by the node.) @@ -141,13 +137,13 @@ txStreamSource streamRef tpsThrottle = Active worker l <- unFold $ pred n return $ tx:l - nextOnMVar :: MVar (StreamState (TxStream IO era)) -> IO (StreamState (Tx era)) + nextOnMVar :: MVar (StreamState (TxStream IO era)) -> IO (StreamState (SignedTx era)) nextOnMVar v = modifyMVar v $ \case StreamEmpty -> return (StreamEmpty, StreamEmpty) StreamError err -> return (StreamError err, StreamError err) StreamActive s -> update <$> Streaming.next s where - update :: Either () (Either TxGenError (Tx era), TxStream IO era) -> (StreamState (TxStream IO era), StreamState (Tx era)) + update :: Either () (Either TxGenError (SignedTx era), TxStream IO era) -> (StreamState (TxStream IO era), StreamState (SignedTx era)) update x = case x of Left () -> (StreamEmpty, StreamEmpty) Right (Right tx, t) -> (StreamActive t, StreamActive tx) diff --git a/bench/tx-generator/src/Cardano/Benchmarking/GeneratorTx/SubmissionClient.hs b/bench/tx-generator/src/Cardano/Benchmarking/GeneratorTx/SubmissionClient.hs index dac0480b328..c9d2ac0f1fb 100644 --- a/bench/tx-generator/src/Cardano/Benchmarking/GeneratorTx/SubmissionClient.hs +++ b/bench/tx-generator/src/Cardano/Benchmarking/GeneratorTx/SubmissionClient.hs @@ -1,4 +1,3 @@ -{-# OPTIONS_GHC -Wno-deprecations #-} {-# LANGUAGE CPP #-} {-# LANGUAGE ConstraintKinds #-} {-# LANGUAGE DataKinds #-} @@ -25,15 +24,18 @@ module Cardano.Benchmarking.GeneratorTx.SubmissionClient ) where import Cardano.Api hiding (Active, CardanoBlock) +import Cardano.Api.Experimental (IsEra, SignedTx (..)) import Cardano.Benchmarking.LogTypes import Cardano.Benchmarking.Types import qualified Cardano.Ledger.Core as Ledger import Cardano.Logging import Cardano.Prelude hiding (ByteString, atomically, retry, state, threadDelay) +import Cardano.TxGenerator.Utils (txIdFromSignedTx) +import qualified Cardano.TxGenerator.Utils as Utils import qualified Ouroboros.Consensus.Cardano as Consensus (CardanoBlock) import qualified Ouroboros.Consensus.Cardano.Block as Block - (TxId (GenTxIdAllegra, GenTxIdAlonzo, GenTxIdBabbage, GenTxIdConway, GenTxIdMary, GenTxIdShelley)) + (TxId (GenTxIdAllegra, GenTxIdAlonzo, GenTxIdBabbage, GenTxIdByron, GenTxIdConway, GenTxIdDijkstra, GenTxIdMary, GenTxIdShelley)) import Ouroboros.Consensus.Ledger.SupportsMempool (GenTxId) import qualified Ouroboros.Consensus.Ledger.SupportsMempool as Mempool import qualified Ouroboros.Consensus.Shelley.Ledger.Mempool as Mempool (TxId (ShelleyTxId)) @@ -65,24 +67,24 @@ data TxSource era = Exhausted | Active (ProduceNextTxs era) -type ProduceNextTxs era = (forall m blocking . MonadIO m => SingBlockingStyle blocking -> Req -> m (TxSource era, [Tx era])) +type ProduceNextTxs era = (forall m blocking . MonadIO m => SingBlockingStyle blocking -> Req -> m (TxSource era, [SignedTx era])) -produceNextTxs :: forall m blocking era . MonadIO m => SingBlockingStyle blocking -> Req -> LocalState era -> m (LocalState era, [Tx era]) +produceNextTxs :: forall m blocking era . MonadIO m => SingBlockingStyle blocking -> Req -> LocalState era -> m (LocalState era, [SignedTx era]) produceNextTxs blocking req (txProducer, unack, stats) = do (newTxProducer, txList) <- produceNextTxs' blocking req txProducer return ((newTxProducer, unack, stats), txList) -produceNextTxs' :: forall m blocking era . MonadIO m => SingBlockingStyle blocking -> Req -> TxSource era -> m (TxSource era, [Tx era]) +produceNextTxs' :: forall m blocking era . MonadIO m => SingBlockingStyle blocking -> Req -> TxSource era -> m (TxSource era, [SignedTx era]) produceNextTxs' _ _ Exhausted = return (Exhausted, []) produceNextTxs' blocking req (Active callback) = callback blocking req -type LocalState era = (TxSource era, UnAcked (Tx era), SubmissionThreadStats) +type LocalState era = (TxSource era, UnAcked (SignedTx era), SubmissionThreadStats) type EndOfProtocolCallback m = SubmissionThreadStats -> m () txSubmissionClient :: forall m era. ( MonadIO m, MonadFail m - , IsShelleyBasedEra era + , IsEra era ) => Trace m NodeToNodeSubmissionTrace -> Trace m (TraceBenchTxSubmit TxId) @@ -101,10 +103,10 @@ txSubmissionClient tr bmtr initialTxSource endOfProtocolCallback = fail (T.unpack err) let (stillUnacked, acked) = L.splitAtEnd ack unAcked let newStats = stats { stsAcked = stsAcked stats + Ack ack } - traceWith bmtr $ SubmissionClientDiscardAcknowledged (getTxId . getTxBody <$> acked) + traceWith bmtr $ SubmissionClientDiscardAcknowledged (txIdFromSignedTx <$> acked) return (txSource, UnAcked stillUnacked, newStats) - queueNewTxs :: [Tx era] -> LocalState era -> LocalState era + queueNewTxs :: [SignedTx era] -> LocalState era -> LocalState era queueNewTxs newTxs (txSource, UnAcked unAcked, stats) = (txSource, UnAcked (newTxs <> unAcked), stats) @@ -130,8 +132,8 @@ txSubmissionClient tr bmtr initialTxSource endOfProtocolCallback = let stateC@(_, UnAcked outs , stats) = queueNewTxs newTxs stateB traceWith tr $ idListTrace (ToAnnce newTxs) blocking - traceWith bmtr $ SubmissionClientReplyTxIds (getTxId . getTxBody <$> newTxs) - traceWith bmtr $ SubmissionClientUnAcked (getTxId . getTxBody <$> outs) + traceWith bmtr $ SubmissionClientReplyTxIds (txIdFromSignedTx <$> newTxs) + traceWith bmtr $ SubmissionClientUnAcked (txIdFromSignedTx <$> outs) case blocking of SingBlocking -> case NE.nonEmpty newTxs of @@ -155,12 +157,12 @@ txSubmissionClient tr bmtr initialTxSource endOfProtocolCallback = reqTxIds = fmap fromGenTxId txIds traceWith tr $ ReqTxs (length reqTxIds) let UnAcked ua = unAcked - uaIds = getTxId . getTxBody <$> ua - (toSend, _retained) = L.partition ((`L.elem` reqTxIds) . getTxId . getTxBody) ua + uaIds = txIdFromSignedTx <$> ua + (toSend, _retained) = L.partition ((`L.elem` reqTxIds) . txIdFromSignedTx) ua missIds = reqTxIds L.\\ uaIds traceWith tr $ TxList (length toSend) - traceWith bmtr $ SubmissionClientUnAcked (getTxId . getTxBody <$> ua) + traceWith bmtr $ SubmissionClientUnAcked (txIdFromSignedTx <$> ua) traceWith bmtr $ TraceBenchTxSubServReq reqTxIds unless (L.null missIds) $ traceWith bmtr $ TraceBenchTxSubServUnav missIds @@ -171,15 +173,14 @@ txSubmissionClient tr bmtr initialTxSource endOfProtocolCallback = , stsUnavailable = stsUnavailable stats + Unav (length missIds)})) - txToIdSize :: Tx era -> (GenTxId CardanoBlock, SizeInBytes) + txToIdSize :: SignedTx era -> (GenTxId CardanoBlock, SizeInBytes) txToIdSize = (Mempool.txId . toGenTx) &&& (SizeInBytes . fromInteger . getTxSize) where - getTxSize :: Tx era -> Integer - getTxSize (ShelleyTx sbe tx) = - shelleyBasedEraConstraints sbe $ toInteger (tx ^. Ledger.sizeTxF) + getTxSize :: SignedTx era -> Integer + getTxSize (SignedTx tx) = toInteger (tx ^. Ledger.sizeTxF) - toGenTx :: Tx era -> GenTx CardanoBlock - toGenTx tx = toConsensusGenTx $ TxInMode shelleyBasedEra tx + toGenTx :: SignedTx era -> GenTx CardanoBlock + toGenTx = toConsensusGenTx . Utils.mkTxInModeCardano fromGenTxId :: GenTxId CardanoBlock -> TxId fromGenTxId (Block.GenTxIdShelley (Mempool.ShelleyTxId i)) = fromShelleyTxId i @@ -188,7 +189,8 @@ txSubmissionClient tr bmtr initialTxSource endOfProtocolCallback = fromGenTxId (Block.GenTxIdAlonzo (Mempool.ShelleyTxId i)) = fromShelleyTxId i fromGenTxId (Block.GenTxIdBabbage (Mempool.ShelleyTxId i)) = fromShelleyTxId i fromGenTxId (Block.GenTxIdConway (Mempool.ShelleyTxId i)) = fromShelleyTxId i - fromGenTxId _ = error "TODO: fix incomplete match" + fromGenTxId (Block.GenTxIdDijkstra (Mempool.ShelleyTxId i)) = fromShelleyTxId i + fromGenTxId (Block.GenTxIdByron _) = error "TODO: fix incomplete match" tokIsBlocking :: SingBlockingStyle a -> Bool tokIsBlocking = \case diff --git a/bench/tx-generator/src/Cardano/Benchmarking/Script/Core.hs b/bench/tx-generator/src/Cardano/Benchmarking/Script/Core.hs index 6711babf2aa..0685d6bdba6 100644 --- a/bench/tx-generator/src/Cardano/Benchmarking/Script/Core.hs +++ b/bench/tx-generator/src/Cardano/Benchmarking/Script/Core.hs @@ -1,4 +1,3 @@ -{-# OPTIONS_GHC -Wno-deprecations #-} {- HLINT ignore "Reduce duplication" -} {- HLINT ignore "Use uncurry" -} @@ -19,6 +18,8 @@ module Cardano.Benchmarking.Script.Core where import Cardano.Api +import Cardano.Api.Experimental (AnyWitness (..), IsEra (useEra), SignedTx (..), + obtainCommonConstraints) import Cardano.Benchmarking.GeneratorTx as GeneratorTx (AsyncBenchmarkControl) import qualified Cardano.Benchmarking.GeneratorTx as GeneratorTx (waitBenchmark, walletBenchmark) @@ -40,6 +41,7 @@ import Cardano.Benchmarking.Version as Version import Cardano.Benchmarking.Wallet as Wallet import qualified Cardano.Ledger.Coin as L import qualified Cardano.Ledger.Core as Ledger +import Cardano.Ledger.Tools (estimateMinFeeTx) import Cardano.Logging hiding (LocalSocket) import Cardano.TxGenerator.Fund as Fund import qualified Cardano.TxGenerator.FundQueue as FundQueue @@ -65,20 +67,15 @@ import qualified Data.Text as Text (unpack) import Streaming import qualified Streaming.Prelude as Streaming -liftCoreWithEra :: AnyCardanoEra -> (forall era. IsShelleyBasedEra era => AsType era -> ExceptT TxGenError IO x) -> ActionM (Either TxGenError x) +liftCoreWithEra :: AnyCardanoEra -> (forall era. IsEra era => AsType era -> ExceptT TxGenError IO x) -> ActionM (Either TxGenError x) liftCoreWithEra era coreCall = withEra era ( liftIO . runExceptT . coreCall) -withEra :: AnyCardanoEra -> (forall era. IsShelleyBasedEra era => AsType era -> ActionM x) -> ActionM x +withEra :: AnyCardanoEra -> (forall era. IsEra era => AsType era -> ActionM x) -> ActionM x withEra era action = do case era of AnyCardanoEra ConwayEra -> action AsConwayEra - AnyCardanoEra BabbageEra -> action AsBabbageEra - AnyCardanoEra AlonzoEra -> action AsAlonzoEra - AnyCardanoEra MaryEra -> action AsMaryEra - AnyCardanoEra AllegraEra -> action AsAllegraEra - AnyCardanoEra ShelleyEra -> action AsShelleyEra - AnyCardanoEra ByronEra -> error "byron not supported" AnyCardanoEra DijkstraEra -> action AsDijkstraEra + _ -> error $ "withEra: unsupported era: " ++ show era setProtocolParameters :: ProtocolParametersSource -> ActionM () setProtocolParameters s = case s of @@ -101,8 +98,9 @@ addFund :: AnyCardanoEra -> String -> TxIn -> L.Coin -> String -> ActionM () addFund era wallet txIn lovelace keyName = do fundKey <- getEnvKeys keyName let - mkOutValue :: forall era. IsShelleyBasedEra era => AsType era -> ActionM (InAnyCardanoEra TxOutValue) - mkOutValue _ = return $ InAnyCardanoEra (cardanoEra @era) (lovelaceToTxOutValue (shelleyBasedEra @era) lovelace) + mkOutValue :: forall era. IsEra era => AsType era -> ActionM (InAnyCardanoEra TxOutValue) + mkOutValue _ = obtainCommonConstraints (useEra @era) $ + return $ InAnyCardanoEra (cardanoEra @era) (lovelaceToTxOutValue shelleyBasedEra lovelace) outValue <- withEra era mkOutValue addFundToWallet wallet txIn outValue fundKey @@ -113,7 +111,7 @@ addFundToWallet wallet txIn outVal skey = do where mkFund = Utils.liftAnyEra $ \value -> FundInEra { _fundTxIn = txIn - , _fundWitness = KeyWitness KeyWitnessForSpending + , _fundWitness = AnyKeyWitnessPlaceholder , _fundVal = value , _fundSigningKey = Just skey } @@ -230,16 +228,16 @@ localSubmitTx tx = do -- Problem 1: When doing throwE $ ApiError msg logmessages get lost ! -- Problem 2: Workbench restarts the tx-generator -> this may be the reason for loss of messages -toMetadata :: forall era. IsShelleyBasedEra era => Maybe Int -> TxMetadataInEra era +toMetadata :: forall era. IsEra era => Maybe Int -> TxMetadataInEra era toMetadata Nothing = TxMetadataNone -toMetadata (Just payloadSize) = case mkMetadata payloadSize of +toMetadata (Just payloadSize) = obtainCommonConstraints (useEra @era) $ case mkMetadata payloadSize of Right m -> m Left err -> error err submitAction :: AnyCardanoEra -> SubmitMode -> Generator -> TxGenTxParams -> ActionM () submitAction era submitMode generator txParams = withEra era $ submitInEra submitMode generator txParams -submitInEra :: forall era. IsShelleyBasedEra era => SubmitMode -> Generator -> TxGenTxParams -> AsType era -> ActionM () +submitInEra :: forall era. IsEra era => SubmitMode -> Generator -> TxGenTxParams -> AsType era -> ActionM () submitInEra submitMode generator txParams era = do txStream <- evalGenerator generator txParams era case submitMode of @@ -261,7 +259,7 @@ submitInEra submitMode generator txParams era = do showTx (Left err) = error $ show err showTx (Right tx) = '\n' : show tx -- todo: use Streaming.run - submitAll :: (Tx era -> ActionM ()) -> TxStream IO era -> ActionM () + submitAll :: (SignedTx era -> ActionM ()) -> TxStream IO era -> ActionM () submitAll callback stream = do step <- liftIO $ Streaming.inspect stream case step of @@ -271,7 +269,7 @@ submitInEra submitMode generator txParams era = do callback tx submitAll callback rest -benchmarkTxStream :: forall era. IsShelleyBasedEra era +benchmarkTxStream :: forall era. IsEra era => TxStream IO era -> TargetNodes -> TPSRate @@ -290,10 +288,11 @@ benchmarkTxStream txStream targetNodes tps txCount era = do Left err -> liftTxGenError err Right ctl -> setEnvThreads ctl -evalGenerator :: IsShelleyBasedEra era => Generator -> TxGenTxParams -> AsType era -> ActionM (TxStream IO era) -evalGenerator generator txParams@TxGenTxParams{txParamFee = fee} era = do +evalGenerator :: forall era. IsEra era => Generator -> TxGenTxParams -> AsType era -> ActionM (TxStream IO era) +evalGenerator generator txParams@TxGenTxParams{txParamFee = fee} eraProxy = obtainCommonConstraints (useEra @era) $ do networkId <- getEnvNetworkId protocolParameters <- getProtocolParameters + let era = useEra @era case convertToLedgerProtocolParameters shelleyBasedEra protocolParameters of Left err -> throwE (Env.TxGenError (ApiError err)) Right ledgerParameters -> @@ -325,7 +324,7 @@ evalGenerator generator txParams@TxGenTxParams{txParamFee = fee} era = do let fundSource = walletSource wallet 1 inToOut = Utils.includeChange fee coins - txGenerator = genTx shelleyBasedEra ledgerParameters (TxInsCollateralNone, []) feeInEra TxMetadataNone + txGenerator = genTx era ledgerParameters ([], []) fee TxMetadataNone sourceToStore = sourceToStoreTransactionNew txGenerator fundSource inToOut $ mangleWithChange toUTxOChange toUTxO return $ Streaming.effect (Streaming.yield <$> sourceToStore) @@ -341,7 +340,7 @@ evalGenerator generator txParams@TxGenTxParams{txParamFee = fee} era = do let fundSource = walletSource wallet 1 inToOut = Utils.inputsToOutputsWithFee fee count - txGenerator = genTx shelleyBasedEra ledgerParameters (TxInsCollateralNone, []) feeInEra TxMetadataNone + txGenerator = genTx era ledgerParameters ([], []) fee TxMetadataNone sourceToStore = sourceToStoreTransactionNew txGenerator fundSource inToOut (mangle $ repeat toUTxO) return $ Streaming.effect (Streaming.yield <$> sourceToStore) @@ -353,7 +352,7 @@ evalGenerator generator txParams@TxGenTxParams{txParamFee = fee} era = do let fundSource = walletSource wallet inputs inToOut = Utils.inputsToOutputsWithFee fee outputs - txGenerator = genTx shelleyBasedEra ledgerParameters collaterals feeInEra (toMetadata metadataSize) + txGenerator = genTx era ledgerParameters collaterals fee (toMetadata metadataSize) sourceToStore = sourceToStoreTransactionNew txGenerator fundSource inToOut (mangle $ repeat toUTxO) fundPreview <- liftIO $ walletPreview wallet inputs @@ -362,10 +361,12 @@ evalGenerator generator txParams@TxGenTxParams{txParamFee = fee} era = do Right tx -> do let txSize = txSizeInBytes tx - txFeeEstimate = case toLedgerPParams shelleyBasedEra protocolParameters of - Left{} -> Nothing - Right ledgerPParams -> Just $ - evaluateTransactionFee shelleyBasedEra ledgerPParams (getTxBody tx) (fromIntegral $ inputs + 1) 0 0 -- 1 key witness per tx input + 1 collateral + txFeeEstimate = case tx of + SignedTx ledgerTx -> + case toLedgerPParams shelleyBasedEra protocolParameters of + Left{} -> Nothing + Right ledgerPParams -> Just $ + estimateMinFeeTx ledgerPParams ledgerTx 0 0 0 -- the preview tx is already signed, so all key witnesses are counted in its size traceDebug $ "Projected Tx size in bytes: " ++ show txSize traceDebug $ "Projected Tx fee in Coin: " ++ show txFeeEstimate -- TODO: possibly emit a warning when (Just txFeeEstimate) is lower than specified by config in TxGenTxParams.txFee @@ -379,34 +380,29 @@ evalGenerator generator txParams@TxGenTxParams{txParamFee = fee} era = do return $ Streaming.effect (Streaming.yield <$> sourceToStore) Sequence l -> do - gList <- forM l $ \g -> evalGenerator g txParams era + gList <- forM l $ \g -> evalGenerator g txParams eraProxy return $ Streaming.for (Streaming.each gList) id - Cycle g -> Streaming.cycle <$> evalGenerator g txParams era + Cycle g -> Streaming.cycle <$> evalGenerator g txParams eraProxy - Take count g -> Streaming.take count <$> evalGenerator g txParams era + Take count g -> Streaming.take count <$> evalGenerator g txParams eraProxy RoundRobin l -> do - _gList <- forM l $ \g -> evalGenerator g txParams era + _gList <- forM l $ \g -> evalGenerator g txParams eraProxy error "return $ foldr1 Streaming.interleaves gList" OneOf _l -> error "todo: implement Quickcheck style oneOf generator" - where - feeInEra = Utils.mkTxFee fee - -selectCollateralFunds :: forall era. IsShelleyBasedEra era - => Maybe String - -> ActionM (TxInsCollateral era, [FundQueue.Fund]) -selectCollateralFunds Nothing = return (TxInsCollateralNone, []) +selectCollateralFunds :: + Maybe String + -> ActionM ([TxIn], [FundQueue.Fund]) +selectCollateralFunds Nothing = return ([], []) selectCollateralFunds (Just walletName) = do cw <- getEnvWallets walletName collateralFunds <- liftIO ( askWalletRef cw FundQueue.toList ) >>= \case [] -> throwE $ WalletError "selectCollateralFunds: emptylist" l -> return l - case forEraMaybeEon (cardanoEra @era) of - Nothing -> throwE $ WalletError $ "selectCollateralFunds: collateral: era not supported :" ++ show (cardanoEra @era) - Just p -> return (TxInsCollateral p $ map getFundTxIn collateralFunds, collateralFunds) + return (map getFundTxIn collateralFunds, collateralFunds) dumpToFile :: FilePath -> TxInMode -> ActionM () dumpToFile filePath tx = liftIO $ dumpToFileIO filePath tx @@ -417,8 +413,8 @@ dumpToFileIO filePath tx = appendFile filePath ('\n' : show tx) initWallet :: String -> ActionM () initWallet name = liftIO Wallet.initWallet >>= setEnvWallets name -interpretPayMode :: forall era. IsShelleyBasedEra era => PayMode -> ActionM (CreateAndStore IO era, String) -interpretPayMode payMode = do +interpretPayMode :: forall era. IsEra era => PayMode -> ActionM (CreateAndStore IO era, String) +interpretPayMode payMode = obtainCommonConstraints (useEra @era) $ do networkId <- getEnvNetworkId case payMode of PayToAddr keyName destWallet -> do @@ -434,10 +430,10 @@ interpretPayMode payMode = do return ( createAndStore (mkUTxOScript networkId (script, scriptData) witness) (mkWalletFundStore walletRef) , Text.unpack $ serialiseAddress $ makeShelleyAddress networkId (PaymentCredentialByScript $ hashScript script') NoStakeAddress ) -makePlutusContext :: forall era. IsShelleyBasedEra era +makePlutusContext :: forall era. IsEra era => ScriptSpec - -> ActionM (Witness WitCtxTxIn era, ScriptInAnyLang, ScriptData, L.Coin) -makePlutusContext ScriptSpec{..} = do + -> ActionM (AnyWitness era, ScriptInAnyLang, ScriptData, L.Coin) +makePlutusContext ScriptSpec{..} = obtainCommonConstraints (useEra @era) $ do protocolParameters <- getProtocolParameters (script, resolvedTo) <- liftIOSafe $ Plutus.readPlutusScript scriptSpecFile @@ -512,19 +508,8 @@ makePlutusContext ScriptSpec{..} = do times w c = fromIntegral w % 1 * c case script of - ScriptInAnyLang lang (PlutusScript version script') -> - let - scriptWitness :: ScriptWitness WitCtxTxIn era - scriptWitness = case scriptLanguageSupportedInEra (shelleyBasedEra @era) lang of - Nothing -> error $ "runPlutusBenchmark: " ++ show version ++ " not supported in era: " ++ show (cardanoEra @era) - Just scriptLang -> PlutusScriptWitness - scriptLang - version - (PScript script') -- TODO: add capability for reference inputs from Babbage era onwards - (ScriptDatumForTxIn $ Just scriptData) - scriptRedeemer - executionUnits - in return (ScriptWitness ScriptWitnessForSpending scriptWitness, script, getScriptData scriptData, scriptFee) + ScriptInAnyLang _ PlutusScript{} -> + return (AnyKeyWitnessPlaceholder, script, getScriptData scriptData, scriptFee) _ -> liftTxGenError $ TxGenError "runPlutusBenchmark: only Plutus scripts supported" diff --git a/bench/tx-generator/src/Cardano/Benchmarking/Script/Ogmios.hs b/bench/tx-generator/src/Cardano/Benchmarking/Script/Ogmios.hs index a0cdb23f6a5..6d534ed1cb6 100644 --- a/bench/tx-generator/src/Cardano/Benchmarking/Script/Ogmios.hs +++ b/bench/tx-generator/src/Cardano/Benchmarking/Script/Ogmios.hs @@ -1,6 +1,7 @@ {-# LANGUAGE NumericUnderscores #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeApplications #-} {-| Module : Cardano.Benchmarking.Script.Ogmios @@ -61,7 +62,8 @@ module Cardano.Benchmarking.Script.Ogmios , withOgmiosTransport ) where -import Cardano.Api (IsShelleyBasedEra, Tx, serialiseToCBOR) +import Cardano.Api (serialiseToRawBytes) +import Cardano.Api.Experimental (IsEra (useEra), SignedTx, obtainCommonConstraints) import Cardano.Benchmarking.Script.Submission (SubmitTransport (..)) import Cardano.TxGenerator.Types (TxGenError (..)) @@ -73,6 +75,7 @@ import Control.Monad (unless, when) import Data.Aeson (Value (..), object, (.:), (.:?), (.=)) import qualified Data.Aeson as Aeson import qualified Data.Aeson.Types as Aeson +import Data.ByteString (ByteString) import qualified Data.ByteString.Base16 as Base16 import qualified Data.ByteString.Lazy as LBS import Data.Either.Extra (maybeToEither) @@ -128,7 +131,7 @@ instance Exception OgmiosProtocolError -- surfaced as a 'Left' 'TxGenError'; the connection lifecycle is reported -- through the given tracer, so a healthy run leaves evidence too. withOgmiosTransport - :: forall era a. IsShelleyBasedEra era + :: forall era a. IsEra era => (String -> IO ()) -- ^ progress tracer for backend events (connection lifecycle) -> URI @@ -162,8 +165,8 @@ withOgmiosTransport traceProgress uri use = -- a rejection as 'Left'. A protocol-level fault throws 'OgmiosProtocolError' -- (caught by 'withOgmiosTransport'). ogmiosSubmitOne - :: IsShelleyBasedEra era - => WS.Connection -> IORef Int -> Tx era -> IO (Either OgmiosRejection Text) + :: IsEra era + => WS.Connection -> IORef Int -> SignedTx era -> IO (Either OgmiosRejection Text) ogmiosSubmitOne conn reqIdRef tx = do reqId <- atomicModifyIORef' reqIdRef $ \n -> (n + 1, n) -- the send can stall too (a wedged peer with full TCP buffers), so it @@ -219,17 +222,20 @@ parseOgmiosUrl uri = do Just n | n >= 1 && n <= 65_535 -> Right n _ -> Left $ "Invalid port in Ogmios URL: " ++ urlStr -mkSubmitRequest :: IsShelleyBasedEra era => Tx era -> Int -> Value +mkSubmitRequest :: forall era. IsEra era => SignedTx era -> Int -> Value mkSubmitRequest tx reqId = object [ "jsonrpc" .= ("2.0" :: Text) , "method" .= ("submitTransaction" :: Text) , "params" .= object [ "transaction" .= object - [ "cbor" .= Text.decodeUtf8 (Base16.encode (serialiseToCBOR tx)) + [ "cbor" .= Text.decodeUtf8 (Base16.encode cbor) ] ] , "id" .= reqId ] + where + cbor :: ByteString + cbor = obtainCommonConstraints (useEra @era) $ serialiseToRawBytes tx -- | Outcome of a single @submitTransaction@ call, as decoded from the -- JSON-RPC response. diff --git a/bench/tx-generator/src/Cardano/Benchmarking/Script/Selftest.hs b/bench/tx-generator/src/Cardano/Benchmarking/Script/Selftest.hs index ffa7c270c72..92359e1032b 100644 --- a/bench/tx-generator/src/Cardano/Benchmarking/Script/Selftest.hs +++ b/bench/tx-generator/src/Cardano/Benchmarking/Script/Selftest.hs @@ -43,7 +43,7 @@ import Paths_tx_generator -- does 'show' and 'writeFile' on. runSelftest :: Env -> EnvConsts -> Maybe FilePath -> IO (Either Env.Error ()) runSelftest env envConsts@EnvConsts { .. } outFile = do - protocolFile <- getDataFileName "data/protocol-parameters.json" + protocolFile <- getDataFileName "data/protocol-parameters-v10.json" let submitMode = maybe DiscardTX DumpToFile outFile fullScript = do @@ -100,7 +100,7 @@ testScript protocolFile submitMode = , teDescription = fromString "Genesis Initial UTxO Signing Key" , teRawCBOR = "X \vl1~\182\201v(\152\250A\202\157h0\ETX\248h\153\171\SI/m\186\242D\228\NAK\182(&\162" } - era = AnyCardanoEra AllegraEra + era = AnyCardanoEra ConwayEra txParams = defaultTxGenTxParams {txParamFee = 1000000} genesisWallet = "genesisWallet" splitWallet1 = "SplitWallet-1" diff --git a/bench/tx-generator/src/Cardano/Benchmarking/Script/Submission.hs b/bench/tx-generator/src/Cardano/Benchmarking/Script/Submission.hs index 23b505fde00..d25d7dc6925 100644 --- a/bench/tx-generator/src/Cardano/Benchmarking/Script/Submission.hs +++ b/bench/tx-generator/src/Cardano/Benchmarking/Script/Submission.hs @@ -23,7 +23,7 @@ module Cardano.Benchmarking.Script.Submission , traceProgress ) where -import Cardano.Api (Tx) +import Cardano.Api.Experimental (SignedTx) import Cardano.Benchmarking.LogTypes (BenchTracers (..), TraceBenchTxSubmit (..)) import Cardano.Benchmarking.Script.Env (ActionM, getBenchTracers, liftTxGenError, @@ -49,7 +49,7 @@ import Streaming -- The rejection type @e@ is the backend's own; this module never inspects -- it, only renders it. newtype SubmitTransport era e = SubmitTransport - { submitOne :: Tx era -> IO (Either e Text) } + { submitOne :: SignedTx era -> IO (Either e Text) } -- | How to proceed when the endpoint rejects a transaction. data OnRejection diff --git a/bench/tx-generator/src/Cardano/Benchmarking/Wallet.hs b/bench/tx-generator/src/Cardano/Benchmarking/Wallet.hs index bf5739208ef..abef1d15983 100644 --- a/bench/tx-generator/src/Cardano/Benchmarking/Wallet.hs +++ b/bench/tx-generator/src/Cardano/Benchmarking/Wallet.hs @@ -11,6 +11,7 @@ effect, like 'createAndStore' and 'mangle'. -} module Cardano.Benchmarking.Wallet where import Cardano.Api hiding (txId) +import Cardano.Api.Experimental (SignedTx) import qualified Cardano.Ledger.Coin as L import Cardano.TxGenerator.FundQueue as FundQueue @@ -38,7 +39,7 @@ type WalletRef = MVar FundQueue -- @ -- type TxStream m era = Stream (Of (Tx era)) m (Maybe TxGenError) -- @ -type TxStream m era = Stream (Of (Either TxGenError (Tx era))) m () +type TxStream m era = Stream (Of (Either TxGenError (SignedTx era))) m () -- | 'createAndStore' hides its 3rd argument in the 'CreateAndStore' -- type alias. The sole uses are in "Cardano.Benchmarking.Script.Core", diff --git a/bench/tx-generator/src/Cardano/TxGenerator/Fund.hs b/bench/tx-generator/src/Cardano/TxGenerator/Fund.hs index a2235ac3b5a..aef77e54fe7 100644 --- a/bench/tx-generator/src/Cardano/TxGenerator/Fund.hs +++ b/bench/tx-generator/src/Cardano/TxGenerator/Fund.hs @@ -21,6 +21,7 @@ module Cardano.TxGenerator.Fund where import Cardano.Api as Api +import Cardano.Api.Experimental (AnyWitness (..), IsEra, obtainCommonConstraints, useEra) import qualified Cardano.Ledger.Coin as L @@ -36,7 +37,7 @@ import Data.Function (on) -- use of lenses. data FundInEra era = FundInEra { _fundTxIn :: !TxIn - , _fundWitness :: Witness WitCtxTxIn era + , _fundWitness :: AnyWitness era , _fundVal :: !(TxOutValue era) , _fundSigningKey :: !(Maybe (SigningKey PaymentKey)) } @@ -76,15 +77,10 @@ getFundCoin (Fund (InAnyCardanoEra _ a)) = case _fundVal a of -- TODO: facilitate casting KeyWitnesses between eras -- Note [Era transitions] -- | The `Fund` alternative is checked against `cardanoEra`, but -- `getFundWitness` otherwise wraps `_fundWitness`. -getFundWitness :: forall era. IsShelleyBasedEra era => Fund -> Witness WitCtxTxIn era -getFundWitness fund = case (cardanoEra @era, fund) of - (ByronEra , Fund (InAnyCardanoEra ByronEra a)) -> _fundWitness a - (ShelleyEra , Fund (InAnyCardanoEra ShelleyEra a)) -> _fundWitness a - (AllegraEra , Fund (InAnyCardanoEra AllegraEra a)) -> _fundWitness a - (MaryEra , Fund (InAnyCardanoEra MaryEra a)) -> _fundWitness a - (AlonzoEra , Fund (InAnyCardanoEra AlonzoEra a)) -> _fundWitness a - (BabbageEra , Fund (InAnyCardanoEra BabbageEra a)) -> _fundWitness a +getFundWitness :: forall era. IsEra era => Fund -> AnyWitness era +getFundWitness fund = obtainCommonConstraints (useEra @era) $ case (cardanoEra @era, fund) of (ConwayEra , Fund (InAnyCardanoEra ConwayEra a)) -> _fundWitness a + (DijkstraEra, Fund (InAnyCardanoEra DijkstraEra a)) -> _fundWitness a _ -> error "getFundWitness: era mismatch" {- diff --git a/bench/tx-generator/src/Cardano/TxGenerator/Genesis.hs b/bench/tx-generator/src/Cardano/TxGenerator/Genesis.hs index 5365258b3f0..3f0c39b14a8 100644 --- a/bench/tx-generator/src/Cardano/TxGenerator/Genesis.hs +++ b/bench/tx-generator/src/Cardano/TxGenerator/Genesis.hs @@ -1,8 +1,8 @@ -{-# OPTIONS_GHC -Wno-deprecations #-} {-# LANGUAGE DerivingStrategies #-} {-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TupleSections #-} {-# LANGUAGE TypeApplications #-} {- HLINT ignore "Use map with tuple-section" -} @@ -20,9 +20,13 @@ module Cardano.TxGenerator.Genesis where import Cardano.Api hiding (ShelleyGenesis) +import Cardano.Api.Experimental (AnyWitness (..), Era, IsEra (useEra), LedgerEra, + SignedTx (..), makeKeyWitness, makeUnsignedTx, obtainCommonConstraints, signTx) +import qualified Cardano.Api.Experimental.Tx as Exp import Cardano.Ledger.BaseTypes (StrictMaybe (..)) import qualified Cardano.Ledger.Coin as L +import Cardano.Ledger.Core (mkCoinTxOut) import Cardano.Ledger.Shelley.API (Addr (..)) import Cardano.Ledger.Shelley.Genesis (InjectionData (..), ShelleyExtraConfig (..)) import Cardano.TxGenerator.Fund @@ -30,7 +34,7 @@ import Cardano.TxGenerator.Types import Cardano.TxGenerator.Utils import Ouroboros.Consensus.Shelley.Node (validateGenesis) -import Data.Bifunctor (bimap, second) +import Data.Bifunctor (first, second) import Data.Function ((&)) import Data.List (find) import qualified Data.ListMap as ListMap (toList) @@ -40,22 +44,20 @@ genesisValidate :: ShelleyGenesis -> Either String () genesisValidate = validateGenesis -genesisSecureInitialFund :: forall era. IsShelleyBasedEra era => +genesisSecureInitialFund :: forall era. IsEra era => NetworkId -> ShelleyGenesis -> SigningKey PaymentKey -> SigningKey PaymentKey -> TxGenTxParams - -> Either TxGenError (Tx era, Fund) -genesisSecureInitialFund networkId genesis srcKey destKey TxGenTxParams{txParamFee, txParamTTL} = do - mFund <- genesisInitialFundForKey @era networkId genesis srcKey - case mFund of - Nothing -> Left $ TxGenError "genesisSecureInitialFund: no fund found for given key in genesis" - Just (_, lovelace) -> - let - txOutValue :: TxOutValue era - txOutValue = lovelaceToTxOutValue (shelleyBasedEra @era) $ lovelace - txParamFee - in genesisExpenditure networkId srcKey destAddr txOutValue txParamFee txParamTTL destKey + -> Either TxGenError (SignedTx era, Fund) +genesisSecureInitialFund networkId genesis srcKey destKey TxGenTxParams{txParamFee, txParamTTL} = + obtainCommonConstraints (useEra @era) $ do + mFund <- genesisInitialFundForKey @era networkId genesis srcKey + case mFund of + Nothing -> Left $ TxGenError "genesisSecureInitialFund: no fund found for given key in genesis" + Just (_, lovelace) -> + genesisExpenditure networkId srcKey destAddr (lovelace - txParamFee) txParamFee txParamTTL destKey where destAddr = keyAddress @era networkId destKey @@ -110,50 +112,51 @@ genesisTxInput networkId . getVerificationKey . castKey -genesisExpenditure :: - IsShelleyBasedEra era +genesisExpenditure :: forall era. + IsEra era => NetworkId -> SigningKey PaymentKey -> AddressInEra era - -> TxOutValue era + -> L.Coin -> L.Coin -> SlotNo -> SigningKey PaymentKey - -> Either TxGenError (Tx era, Fund) + -> Either TxGenError (SignedTx era, Fund) genesisExpenditure networkId inputKey addr value fee ttl outputKey - = second (\tx -> (tx, Fund $ InAnyCardanoEra cardanoEra $ fund tx)) eTx + = obtainCommonConstraints era $ + second (\tx -> (tx, Fund $ InAnyCardanoEra cardanoEra $ fund (lovelaceToTxOutValue (shelleyBasedEra @era) value) tx)) + $ mkGenesisTransaction era (castKey inputKey) ttl fee [pseudoTxIn] + [Exp.TxOut $ mkCoinTxOut (toShelleyAddr addr) value] where - eTx = mkGenesisTransaction (castKey inputKey) ttl fee [pseudoTxIn] [txout] - txout = TxOut addr value TxOutDatumNone ReferenceScriptNone + era = useEra @era pseudoTxIn = genesisTxInput networkId inputKey - fund tx = FundInEra { - _fundTxIn = TxIn (getTxId $ getTxBody tx) (TxIx 0) - , _fundWitness = KeyWitness KeyWitnessForSpending - , _fundVal = value + fund txOutValue tx = FundInEra { + _fundTxIn = TxIn (txIdFromSignedTx tx) (TxIx 0) + , _fundWitness = AnyKeyWitnessPlaceholder + , _fundVal = txOutValue , _fundSigningKey = Just outputKey } -mkGenesisTransaction :: forall era . - IsShelleyBasedEra era - => SigningKey GenesisUTxOKey +mkGenesisTransaction :: + Era era + -> SigningKey GenesisUTxOKey -> SlotNo -> L.Coin -> [TxIn] - -> [TxOut CtxTx era] - -> Either TxGenError (Tx era) -mkGenesisTransaction key ttl fee txins txouts - = bimap - ApiError - (\b -> signShelleyTransaction (shelleyBasedEra @era) b [WitnessGenesisUTxOKey key]) - (createTransactionBody (shelleyBasedEra @era) txBodyContent) - where - txBodyContent = defaultTxBodyContent shelleyBasedEra - & setTxIns (zip txins $ repeat $ BuildTxWith $ KeyWitness KeyWitnessForSpending) - & setTxOuts txouts - & setTxFee (mkTxFee fee) - & setTxValidityLowerBound TxValidityNoLowerBound - & setTxValidityUpperBound (mkTxValidityUpperBound ttl) + -> [Exp.TxOut (LedgerEra era)] + -> Either TxGenError (SignedTx era) +mkGenesisTransaction era key ttl fee txins txouts + = obtainCommonConstraints era $ do + let expInputs = map (,AnyKeyWitnessPlaceholder) txins + txBodyContent = Exp.defaultTxBodyContent + & Exp.setTxIns expInputs + & Exp.setTxOuts txouts + & Exp.setTxFee fee + & Exp.setTxValidityUpperBound ttl + unsignedTx <- first (\err -> TxGenError $ "mkGenesisTransaction: " ++ show err) $ makeUnsignedTx era txBodyContent + let witVKey = makeKeyWitness era unsignedTx (WitnessGenesisUTxOKey key) + Right $ signTx era [] [witVKey] unsignedTx castKey :: SigningKey PaymentKey -> SigningKey GenesisUTxOKey castKey (PaymentSigningKey skey) = GenesisUTxOSigningKey skey diff --git a/bench/tx-generator/src/Cardano/TxGenerator/PureExample.hs b/bench/tx-generator/src/Cardano/TxGenerator/PureExample.hs index 0aef7befa1e..b72225b9da9 100644 --- a/bench/tx-generator/src/Cardano/TxGenerator/PureExample.hs +++ b/bench/tx-generator/src/Cardano/TxGenerator/PureExample.hs @@ -7,6 +7,7 @@ module Cardano.TxGenerator.PureExample where import Cardano.Api hiding (txId) +import Cardano.Api.Experimental (AnyWitness (..), SignedTx, useEra) import qualified Cardano.Ledger.Coin as L import Cardano.TxGenerator.FundQueue @@ -28,18 +29,20 @@ import System.Exit (die) import Paths_tx_generator +type DemoEra = ConwayEra + demo :: IO () -demo = getDataFileName "data/protocol-parameters.json" >>= demo' +demo = getDataFileName "data/protocol-parameters-v10.json" >>= demo' demo' :: FilePath -> IO () demo' parametersFile = do protocolParameters <- either die pure =<< eitherDecodeFileStrict' parametersFile let - demoEnv :: TxEnvironment BabbageEra + demoEnv :: TxEnvironment DemoEra demoEnv = TxEnvironment { txEnvNetworkId = Mainnet , txEnvProtocolParams = protocolParameters - , txEnvFee = TxFeeExplicit ShelleyBasedEraBabbage 100000 + , txEnvFee = TxFeeExplicit shelleyBasedEra 100000 , txEnvMetadata = TxMetadataNone } @@ -48,7 +51,7 @@ demo' parametersFile = do putStrLn $ "Are run results identical? " ++ show (toList run1 == toList run2) where worker :: - Generator (Either TxGenError (Tx BabbageEra)) + Generator (Either TxGenError (SignedTx DemoEra)) -> FundQueue -> Int -> IO FundQueue @@ -68,30 +71,30 @@ signingKey = fromRight (error "signingKey: parseError") $ parseSigningKeyTE keyD , teRawCBOR = "X \vl1~\182\201v(\152\250A\202\157h0\ETX\248h\153\171\SI/m\186\242D\228\NAK\182(&\162"} genesisTxIn :: TxIn -genesisValue :: TxOutValue BabbageEra +genesisValue :: TxOutValue DemoEra (genesisTxIn, genesisValue) = ( mkTxIn "900fc5da77a0747da53f7675cbb7d149d46779346dea2f879ab811ccc72a2162#0" - , lovelaceToTxOutValue ShelleyBasedEraBabbage $ L.Coin 90000000000000 + , lovelaceToTxOutValue shelleyBasedEra $ L.Coin 90000000000000 ) genesisFund :: Fund genesisFund - = Fund $ InAnyCardanoEra BabbageEra fundInEra + = Fund $ InAnyCardanoEra cardanoEra fundInEra where - fundInEra :: FundInEra BabbageEra + fundInEra :: FundInEra DemoEra fundInEra = FundInEra { _fundTxIn = genesisTxIn , _fundVal = genesisValue - , _fundWitness = KeyWitness KeyWitnessForSpending + , _fundWitness = AnyKeyWitnessPlaceholder , _fundSigningKey = Just signingKey } type Generator = State FundQueue generateTx :: - TxEnvironment BabbageEra - -> Generator (Either TxGenError (Tx BabbageEra)) + TxEnvironment DemoEra + -> Generator (Either TxGenError (SignedTx DemoEra)) generateTx TxEnvironment{..} = sourceToStoreTransaction generator @@ -102,16 +105,16 @@ generateTx TxEnvironment{..} where TxFeeExplicit _ fee = txEnvFee - generator :: TxGenerator BabbageEra + generator :: TxGenerator DemoEra generator = case convertToLedgerProtocolParameters shelleyBasedEra txEnvProtocolParams of Right ledgerParameters -> - genTx ShelleyBasedEraBabbage ledgerParameters collateralFunds txEnvFee txEnvMetadata + genTx useEra ledgerParameters collateralFunds fee txEnvMetadata Left err -> \_ _ -> Left (ApiError err) where -- collateralFunds are needed for Plutus transactions - collateralFunds :: (TxInsCollateral BabbageEra, [Fund]) - collateralFunds = (TxInsCollateralNone, []) + collateralFunds :: ([TxIn], [Fund]) + collateralFunds = ([], []) -- Create a transaction that uses all the available funds. consumeInputFunds :: Generator (Either TxGenError [Fund]) @@ -131,8 +134,8 @@ generateTx TxEnvironment{..} generateTxM :: - TxEnvironment BabbageEra - -> Generator (Either TxGenError (Tx BabbageEra)) + TxEnvironment DemoEra + -> Generator (Either TxGenError (SignedTx DemoEra)) generateTxM txEnv = do inFunds <- get @@ -141,9 +144,9 @@ generateTxM txEnv Left err -> pure (Left err) generateTxPure :: - TxEnvironment BabbageEra + TxEnvironment DemoEra -> FundQueue - -> Either TxGenError (Tx BabbageEra, FundQueue) + -> Either TxGenError (SignedTx DemoEra, FundQueue) generateTxPure TxEnvironment{..} inQueue = do (tx, txId) <- generator inputs outputs @@ -153,16 +156,16 @@ generateTxPure TxEnvironment{..} inQueue inputs = toList inQueue TxFeeExplicit _ fee = txEnvFee - generator :: TxGenerator BabbageEra + generator :: TxGenerator DemoEra generator = case convertToLedgerProtocolParameters shelleyBasedEra txEnvProtocolParams of Right ledgerParameters -> - genTx ShelleyBasedEraBabbage ledgerParameters collateralFunds txEnvFee txEnvMetadata + genTx useEra ledgerParameters collateralFunds fee txEnvMetadata Left err -> \_ _ -> Left (ApiError err) where -- collateralFunds are needed for Plutus transactions - collateralFunds :: (TxInsCollateral BabbageEra, [Fund]) - collateralFunds = (TxInsCollateralNone, []) + collateralFunds :: ([TxIn], [Fund]) + collateralFunds = ([], []) outValues = computeOutputValues $ map getFundCoin inputs (outputs, toFunds) = makeToUTxOList (repeat computeUTxO) outValues diff --git a/bench/tx-generator/src/Cardano/TxGenerator/Tx.hs b/bench/tx-generator/src/Cardano/TxGenerator/Tx.hs index 8358276732e..f78982b265b 100644 --- a/bench/tx-generator/src/Cardano/TxGenerator/Tx.hs +++ b/bench/tx-generator/src/Cardano/TxGenerator/Tx.hs @@ -1,4 +1,3 @@ -{-# OPTIONS_GHC -Wno-deprecations #-} {-# LANGUAGE GADTs #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE ScopedTypeVariables #-} @@ -9,13 +8,17 @@ module Cardano.TxGenerator.Tx where import Cardano.Api hiding (txId) +import Cardano.Api.Experimental (AnyWitness (..), Era, IsEra, LedgerEra, SignedTx (..), + makeKeyWitness, makeUnsignedTx, obtainCommonConstraints, signTx, useEra) +import qualified Cardano.Api.Experimental.Tx as Exp import qualified Cardano.Ledger.Coin as L import Cardano.TxGenerator.Fund import Cardano.TxGenerator.Types +import Cardano.TxGenerator.Utils (txIdFromSignedTx) import Cardano.TxGenerator.UTxO (ToUTxOList) -import Data.Bifunctor (bimap, second) +import Data.Bifunctor (first, second) import qualified Data.ByteString as BS (length) import Data.Function ((&)) import Data.Maybe (mapMaybe) @@ -25,14 +28,14 @@ import Data.Maybe (mapMaybe) -- from a single number and presenting a function to carry out the -- needed side effects. -- This type alias is only used in "Cardano.Benchmarking.Wallet". -type CreateAndStore m era = L.Coin -> (TxOut CtxTx era, TxIx -> TxId -> m ()) +type CreateAndStore m era = L.Coin -> (Exp.TxOut (LedgerEra era), TxIx -> TxId -> m ()) -- | 'CreateAndStoreList' is meant to represent building a transaction -- and presenting a function to carry out the needed side effects. -- This type alias is also only used in "Cardano.Benchmarking.Wallet". -- The @split@ parameter seems to actually be used for not much more -- than lists and records containing lists. -type CreateAndStoreList m era split = split -> ([TxOut CtxTx era], TxId -> m ()) +type CreateAndStoreList m era split = split -> ([Exp.TxOut (LedgerEra era)], TxId -> m ()) -- TODO: 'sourceToStoreTransaction' et al need to be broken up @@ -60,7 +63,7 @@ sourceToStoreTransaction :: -> ([L.Coin] -> split) -> ToUTxOList era split -> FundToStoreList m --inline to ToUTxOList - -> m (Either TxGenError (Tx era)) + -> m (Either TxGenError (SignedTx era)) sourceToStoreTransaction txGenerator fundSource inToOut mkTxOut fundToStore = fundSource >>= either (return . Left) go where @@ -96,7 +99,7 @@ sourceToStoreTransactionNew :: -> FundSource m -> ([L.Coin] -> split) -> CreateAndStoreList m era split - -> m (Either TxGenError (Tx era)) + -> m (Either TxGenError (SignedTx era)) sourceToStoreTransactionNew txGenerator fundSource valueSplitter toStore = fundSource >>= either (return . Left) go where @@ -139,7 +142,7 @@ sourceTransactionPreview :: -> [Fund] -> ([L.Coin] -> split) -> CreateAndStoreList m era split - -> Either TxGenError (Tx era) + -> Either TxGenError (SignedTx era) sourceTransactionPreview txGenerator inputFunds valueSplitter toStore = second fst $ txGenerator inputFunds outputs @@ -147,45 +150,41 @@ sourceTransactionPreview txGenerator inputFunds valueSplitter toStore = split = valueSplitter $ map getFundCoin inputFunds (outputs, _) = toStore split --- | 'genTx' seems to mostly be a wrapper for --- 'Cardano.Api.TxBody.createTransactionBody', which uses --- the 'Either' convention in lieu of e.g. --- 'Control.Monad.Trans.Except.ExceptT'. Then the pure function --- 'Cardano.Api.Tx.makeSignedTransaction' is composed with it and --- the 'Cardano.Api.Error' is lifted to 'Cardano.TxGenerator.Types.TxGenError' --- as an 'Cardano.TxGenerator.Types.ApiError' case. +-- | 'genTx' builds a signed transaction using the experimental API. -- The @txGenerator@ arguments of the rest of the functions in this -- module are all partial applications of this to its first 5 arguments. --- The 7th argument comes from 'TxGenerator' being a being a type alias +-- The 7th argument comes from 'TxGenerator' being a type alias -- for a function type -- of two arguments. -genTx :: forall era. () - => IsShelleyBasedEra era - => ShelleyBasedEra era +genTx :: + Era era -> LedgerProtocolParameters era - -> (TxInsCollateral era, [Fund]) - -> TxFee era + -> ([TxIn], [Fund]) + -> L.Coin -> TxMetadataInEra era -> TxGenerator era -genTx sbe ledgerParameters (collateral, collFunds) fee metadata inFunds outputs - = bimap - ApiError - (\b -> (signShelleyTransaction (shelleyBasedEra @era) b $ map WitnessPaymentKey allKeys, getTxId b)) - (createTransactionBody (shelleyBasedEra @era) txBodyContent) - where - allKeys = mapMaybe getFundKey $ inFunds ++ collFunds - txBodyContent = defaultTxBodyContent sbe - & setTxIns (map (\f -> (getFundTxIn f, BuildTxWith $ getFundWitness f)) inFunds) - & setTxInsCollateral collateral - & setTxOuts outputs - & setTxFee fee - & setTxValidityLowerBound TxValidityNoLowerBound - & setTxValidityUpperBound (defaultTxValidityUpperBound sbe) - & setTxMetadata metadata - & setTxProtocolParams (BuildTxWith (Just ledgerParameters)) +genTx era (LedgerProtocolParameters pparams) (collateralIns, collFunds) fee metadata inFunds outputs = + obtainCommonConstraints era $ do + let allKeys = mapMaybe getFundKey $ inFunds ++ collFunds + expInputs = map (\f -> (getFundTxIn f, AnyKeyWitnessPlaceholder)) inFunds + expMetadata = case metadata of + TxMetadataNone -> mempty + TxMetadataInEra _ m -> m + txBodyContent = + Exp.defaultTxBodyContent + & Exp.setTxIns expInputs + & Exp.setTxInsCollateral collateralIns + & Exp.setTxOuts outputs + & Exp.setTxFee fee + & Exp.setTxMetadata expMetadata + & Exp.setTxProtocolParams pparams + unsignedTx <- first (\err -> TxGenError $ "genTx: " ++ show err) $ makeUnsignedTx era txBodyContent + let witVKeys = [makeKeyWitness era unsignedTx (WitnessPaymentKey key) | key <- allKeys] + let tx = signTx era [] witVKeys unsignedTx + Right (tx, txIdFromSignedTx tx) -txSizeInBytes :: forall era. IsShelleyBasedEra era => - Tx era +txSizeInBytes :: forall era. IsEra era => + SignedTx era -> Int -txSizeInBytes - = BS.length . serialiseToCBOR +txSizeInBytes tx + = obtainCommonConstraints (useEra @era) $ BS.length $ serialiseToRawBytes tx diff --git a/bench/tx-generator/src/Cardano/TxGenerator/Types.hs b/bench/tx-generator/src/Cardano/TxGenerator/Types.hs index 9fd733bc2ed..8bb7ade4959 100644 --- a/bench/tx-generator/src/Cardano/TxGenerator/Types.hs +++ b/bench/tx-generator/src/Cardano/TxGenerator/Types.hs @@ -14,6 +14,8 @@ module Cardano.TxGenerator.Types where import Cardano.Api +import Cardano.Api.Experimental (LedgerEra) +import qualified Cardano.Api.Experimental.Tx as Exp import qualified Cardano.Ledger.Coin as L import qualified Cardano.Ledger.Shelley.API as Ledger (ShelleyGenesis) @@ -35,7 +37,7 @@ type TxAdditionalSize = Int type TPSRate = Double -type TxGenerator era = [Fund] -> [TxOut CtxTx era] -> Either TxGenError (Tx era, TxId) +type TxGenerator era = [Fund] -> [Exp.TxOut (LedgerEra era)] -> Either TxGenError (Exp.SignedTx era, TxId) type FundSource m = m (Either TxGenError [Fund]) type FundToStore m = Fund -> m () diff --git a/bench/tx-generator/src/Cardano/TxGenerator/UTxO.hs b/bench/tx-generator/src/Cardano/TxGenerator/UTxO.hs index 2b822202059..7d5cca55cbd 100644 --- a/bench/tx-generator/src/Cardano/TxGenerator/UTxO.hs +++ b/bench/tx-generator/src/Cardano/TxGenerator/UTxO.hs @@ -7,13 +7,21 @@ module Cardano.TxGenerator.UTxO where import Cardano.Api hiding (txId) +import Cardano.Api.Experimental (AnyWitness (..), IsEra, LedgerEra, + obtainCommonConstraints, useEra) +import qualified Cardano.Api.Experimental.Tx as Exp +import Cardano.Ledger.Api.Tx.Out (datumTxOutL) import qualified Cardano.Ledger.Coin as L +import Cardano.Ledger.Core (mkCoinTxOut) +import qualified Cardano.Ledger.Plutus.Data as Plutus import Cardano.TxGenerator.Fund (Fund (..), FundInEra (..)) import Cardano.TxGenerator.Utils (keyAddress) -type ToUTxO era = L.Coin -> (TxOut CtxTx era, TxIx -> TxId -> Fund) -type ToUTxOList era split = split -> ([TxOut CtxTx era], TxId -> [Fund]) +import Lens.Micro ((&), (.~)) + +type ToUTxO era = L.Coin -> (Exp.TxOut (LedgerEra era), TxIx -> TxId -> Fund) +type ToUTxOList era split = split -> ([Exp.TxOut (LedgerEra era)], TxId -> [Fund]) makeToUTxOList :: [ ToUTxO era ] -> ToUTxOList era [ L.Coin ] @@ -25,59 +33,49 @@ makeToUTxOList fkts values = let (o, f ) = toUTxO value in (o, f idx) -mkUTxOVariant :: forall era. IsShelleyBasedEra era +mkUTxOVariant :: forall era. IsEra era => NetworkId -> SigningKey PaymentKey -> ToUTxO era -mkUTxOVariant networkId key value - = ( mkTxOut value - , mkNewFund value - ) - where - mkTxOut v = TxOut (keyAddress @era networkId key) (lovelaceToTxOutValue (shelleyBasedEra @era) v) TxOutDatumNone ReferenceScriptNone - - mkNewFund :: L.Coin -> TxIx -> TxId -> Fund - mkNewFund val txIx txId = Fund $ InAnyCardanoEra (cardanoEra @era) $ FundInEra { - _fundTxIn = TxIn txId txIx - , _fundWitness = KeyWitness KeyWitnessForSpending - , _fundVal = lovelaceToTxOutValue (shelleyBasedEra @era ) val - , _fundSigningKey = Just key - } +mkUTxOVariant networkId key value = obtainCommonConstraints (useEra @era) $ + let + mkTxOut v = Exp.TxOut $ mkCoinTxOut (toShelleyAddr $ keyAddress @era networkId key) v + mkNewFund :: L.Coin -> TxIx -> TxId -> Fund + mkNewFund val txIx txId = Fund $ InAnyCardanoEra (cardanoEra @era) $ FundInEra { + _fundTxIn = TxIn txId txIx + , _fundWitness = AnyKeyWitnessPlaceholder + , _fundVal = lovelaceToTxOutValue (shelleyBasedEra @era) val + , _fundSigningKey = Just key + } + in (mkTxOut value, mkNewFund value) -- to be merged with mkUTxOVariant mkUTxOScript :: forall era. - IsShelleyBasedEra era + IsEra era => NetworkId -> (ScriptInAnyLang, ScriptData) - -> Witness WitCtxTxIn era + -> AnyWitness era -> ToUTxO era -mkUTxOScript networkId (script, txOutDatum) witness value - = ( mkTxOut value - , mkNewFund value - ) - where - plutusScriptAddr = case script of - ScriptInAnyLang lang script' -> - case scriptLanguageSupportedInEra (shelleyBasedEra @era) lang of - Nothing -> error "mkUtxOScript: scriptLanguageSupportedInEra==Nothing" - Just{} -> makeShelleyAddressInEra - (shelleyBasedEra @era) - networkId - (PaymentCredentialByScript $ hashScript script') - NoStakeAddress - - mkTxOut v = case forEraMaybeEon (cardanoEra @era) of - Nothing -> error "mkUtxOScript: scriptDataSupportedInEra==Nothing" - Just tag -> TxOut - plutusScriptAddr - (lovelaceToTxOutValue (shelleyBasedEra @era) v) - (TxOutDatumHash tag $ hashScriptDataBytes $ unsafeHashableScriptData txOutDatum) - ReferenceScriptNone - - mkNewFund :: L.Coin -> TxIx -> TxId -> Fund - mkNewFund val txIx txId = Fund $ InAnyCardanoEra (cardanoEra @era) $ FundInEra { - _fundTxIn = TxIn txId txIx - , _fundWitness = witness - , _fundVal = lovelaceToTxOutValue (shelleyBasedEra @era) val - , _fundSigningKey = Nothing - } +mkUTxOScript networkId (script, txOutDatum) witness value = obtainCommonConstraints (useEra @era) $ + let + plutusScriptAddr = case script of + ScriptInAnyLang lang script' -> + case scriptLanguageSupportedInEra (shelleyBasedEra @era) lang of + Nothing -> error "mkUtxOScript: scriptLanguageSupportedInEra==Nothing" + Just{} -> makeShelleyAddressInEra + (shelleyBasedEra @era) + networkId + (PaymentCredentialByScript $ hashScript script') + NoStakeAddress + datumHash :: Plutus.Datum (LedgerEra era) + datumHash = Plutus.DatumHash $ Plutus.hashData $ toAlonzoData @(LedgerEra era) $ unsafeHashableScriptData txOutDatum + mkTxOut v = Exp.TxOut $ + mkCoinTxOut (toShelleyAddr plutusScriptAddr) v & datumTxOutL .~ datumHash + mkNewFund :: L.Coin -> TxIx -> TxId -> Fund + mkNewFund val txIx txId = Fund $ InAnyCardanoEra (cardanoEra @era) $ FundInEra { + _fundTxIn = TxIn txId txIx + , _fundWitness = witness + , _fundVal = lovelaceToTxOutValue (shelleyBasedEra @era) val + , _fundSigningKey = Nothing + } + in (mkTxOut value, mkNewFund value) diff --git a/bench/tx-generator/src/Cardano/TxGenerator/Utils.hs b/bench/tx-generator/src/Cardano/TxGenerator/Utils.hs index 6565dbc1575..b7655c17c36 100644 --- a/bench/tx-generator/src/Cardano/TxGenerator/Utils.hs +++ b/bench/tx-generator/src/Cardano/TxGenerator/Utils.hs @@ -12,13 +12,15 @@ module Cardano.TxGenerator.Utils where import Cardano.Api as Api +import Cardano.Api.Experimental (IsEra, SignedTx (..), obtainCommonConstraints, useEra) import qualified Cardano.Api.Parser.Text as P import qualified Cardano.Ledger.Coin as L +import qualified Cardano.Ledger.Core as Ledger import Cardano.TxGenerator.Types -import Data.Maybe (fromJust) import GHC.Stack +import Lens.Micro ((^.)) -- | `liftAnyEra` applies a function to the value in `InAnyCardanoEra` @@ -65,23 +67,17 @@ includeChange fee spend have = case compare changeValue 0 of where changeValue = sum have - sum spend - fee --- some convenience constructors - --- | `mkTxFee` reinterprets the `Either` returned by --- `txFeesExplicitInEra` with `TxFee` constructors. -mkTxFee :: IsShelleyBasedEra era => L.Coin -> TxFee era -mkTxFee = TxFeeExplicit shelleyBasedEra +txIdFromSignedTx :: SignedTx era -> TxId +txIdFromSignedTx (SignedTx tx) = + fromShelleyTxId $ Ledger.txIdTxBody (tx ^. Ledger.bodyTxL) --- | `mkTxValidityUpperBound` rules out needing the --- `TxValidityNoUpperBound` with the constraint of `IsShelleyBasedEra`. -mkTxValidityUpperBound :: forall era. IsShelleyBasedEra era => SlotNo -> TxValidityUpperBound era -mkTxValidityUpperBound slotNo = - TxValidityUpperBound (fromJust $ forEraMaybeEon (cardanoEra @era)) (Just slotNo) +-- some convenience constructors -- | `mkTxInModeCardano` never uses the `TxInByronSpecial` constructor -- because its type enforces it being a Shelley-based era. -mkTxInModeCardano :: IsShelleyBasedEra era => Tx era -> TxInMode -mkTxInModeCardano = TxInMode shelleyBasedEra +mkTxInModeCardano :: forall era. IsEra era => SignedTx era -> TxInMode +mkTxInModeCardano (SignedTx tx) = + obtainCommonConstraints (useEra @era) $ TxInMode shelleyBasedEra (ShelleyTx shelleyBasedEra tx) -- | Convert text representation of a txin "hash#txid" to a TxIn e.g. "dbaff4e270cfb55612d9e2ac4658a27c79da4a5271c6f90853042d1403733810#0" -- Partial. Useful in tests. diff --git a/bench/tx-generator/test/Main.hs b/bench/tx-generator/test/Main.hs index d387d1f2d07..c8c0c539bcb 100644 --- a/bench/tx-generator/test/Main.hs +++ b/bench/tx-generator/test/Main.hs @@ -3,11 +3,13 @@ module Main (main) where +import Cardano.Benchmarking.GeneratorTx.SizedMetadata + import Prelude + import Test.Tasty import Test.Tasty.HUnit -import Cardano.Benchmarking.GeneratorTx.SizedMetadata import TestnetDiscoveryTest (testnetDiscoveryTests) main :: IO () @@ -22,16 +24,9 @@ tests = testGroup "cardano-tx-generator" sizedMetadata :: TestTree sizedMetadata = testGroup "properties of the CBOR encoding relevant for generating sized metadat" - [ testCase "Shelley metadata map costs" $ assertBool "metadata map costs" prop_mapCostsShelley - , testCase "Shelley metadata ByteString costs" $ assertBool "metadata ByteString costs" prop_bsCostsShelley - , testCase "Allegra metadata map costs" $ assertBool "metadata map costs" prop_mapCostsAllegra - , testCase "Allegra metadata ByteString costs" $ assertBool "metadata ByteString costs" prop_bsCostsAllegra - , testCase "Mary metadata map costs" $ assertBool "metadata map costs" prop_mapCostsMary - , testCase "Mary metadata ByteString costs" $ assertBool "metadata ByteString costs" prop_bsCostsMary - , testCase "Alonzo metadata map costs" $ assertBool "metadata map costs" prop_mapCostsAlonzo - , testCase "Alonzo metadata ByteString costs" $ assertBool "metadata ByteString costs" prop_bsCostsAlonzo - , testCase "Babbage metadata map costs" $ assertBool "metadata map costs" prop_mapCostsBabbage - , testCase "Babbage metadata ByteString costs" $ assertBool "metadata ByteString costs" prop_bsCostsBabbage - , testCase "Conway metadata map costs" $ assertBool "metadata map costs" prop_mapCostsConway + [ testCase "Conway metadata map costs" $ assertBool "metadata map costs" prop_mapCostsConway , testCase "Conway metadata ByteString costs" $ assertBool "metadata ByteString costs" prop_bsCostsConway + -- TODO: enable when cardano-api implements makeUnsignedTx for Dijkstra + -- , testCase "Dijkstra metadata map costs" $ assertBool "metadata map costs" prop_mapCostsDijkstra + -- , testCase "Dijkstra metadata ByteString costs" $ assertBool "metadata ByteString costs" prop_bsCostsDijkstra ] diff --git a/bench/tx-generator/tx-generator.cabal b/bench/tx-generator/tx-generator.cabal index c0f64364527..cf52082ce69 100644 --- a/bench/tx-generator/tx-generator.cabal +++ b/bench/tx-generator/tx-generator.cabal @@ -120,28 +120,20 @@ library , cardano-binary , cardano-cli ^>= 11.2.1 , cardano-crypto-class - , cardano-crypto-wrapper , cardano-data , cardano-diffusion ^>= 1.1.1 , cardano-git-rev ^>= 0.2.2 - , cardano-ledger-alonzo , cardano-ledger-api - , cardano-ledger-byron , cardano-ledger-core , cardano-node , cardano-prelude - , cardano-strict-containers >=0.1 , contra-tracer , cborg >= 0.2.2 && < 0.3 , containers - , constraints-extras , directory , dlist , extra , filepath - , formatting - , generic-monoid - , ghc-prim , io-classes:{io-classes, strict-stm} , microlens , mtl @@ -166,7 +158,6 @@ library , trace-forward , transformers , transformers-except - , unordered-containers , websockets , yaml -- Needed by "Cardano.Api.Internal.ProtocolParameters" port. @@ -198,21 +189,19 @@ executable calibrate-script ghc-options: -Wall -rtsopts "-with-rtsopts=-T" - -Wno-deprecations build-depends: base , aeson , aeson-pretty , bytestring + , cardano-api + , cardano-ledger-core , containers , directory , extra , filepath , optparse-applicative - , cardano-api , text - , transformers - , transformers-except , tx-generator default-extensions: ViewPatterns @@ -232,7 +221,6 @@ test-suite tx-generator-apitest ghc-options: -Wall -rtsopts "-with-rtsopts=-T" - -Wno-deprecations build-depends: base , aeson @@ -243,11 +231,8 @@ test-suite tx-generator-apitest , filepath , optparse-applicative , cardano-api - , cardano-cli , cardano-node , plutus-tx - , transformers - , transformers-except , tx-generator other-modules: Cardano.TxGenerator.Calibrate.Utils From 1eb36f0b922a6aac1839def629368f03df59490c Mon Sep 17 00:00:00 2001 From: Mateusz Galazyn Date: Wed, 5 Aug 2026 22:47:45 +0200 Subject: [PATCH 2/4] tx-generator: use real Plutus script witnesses when spending script-locked funds Previously genTx attached AnyKeyWitnessPlaceholder to every input and makePlutusContext returned a placeholder instead of a script witness, so every Plutus workload failed ledger validation with MissingScriptWitnessesUTXOW. - type fund witnesses as AnyWitness (LedgerEra era) so real script witnesses can inhabit FundInEra - add toAnyPlutusScript and mkPlutusSpendingWitness to Cardano.TxGenerator.Setup.Plutus (local shims pending cardano-api#1245) - build the real spending witness in makePlutusContext - make genTx consume each fund's stored witness via getFundWitness --- bench/tx-generator/app/calibrate-script.hs | 75 ++++---------- .../src/Cardano/Benchmarking/GeneratorTx.hs | 6 +- .../Benchmarking/GeneratorTx/SizedMetadata.hs | 99 +++++++++++++------ .../GeneratorTx/SubmissionClient.hs | 4 +- .../src/Cardano/Benchmarking/Script/Core.hs | 68 +++++++------ .../src/Cardano/Benchmarking/Script/Ogmios.hs | 15 ++- .../src/Cardano/TxGenerator/Fund.hs | 17 ++-- .../src/Cardano/TxGenerator/Genesis.hs | 65 ++++++------ .../src/Cardano/TxGenerator/PureExample.hs | 7 +- .../src/Cardano/TxGenerator/Setup/Plutus.hs | 63 +++++++++++- .../src/Cardano/TxGenerator/Tx.hs | 65 ++++++------ .../src/Cardano/TxGenerator/Types.hs | 3 +- .../src/Cardano/TxGenerator/UTxO.hs | 40 +++++--- .../src/Cardano/TxGenerator/Utils.hs | 7 +- bench/tx-generator/test/Main.hs | 15 ++- cardano-node-chairman/app/Cardano/Chairman.hs | 1 + cardano-testnet/src/Testnet/Runtime.hs | 4 +- cardano-testnet/src/Testnet/Start/Cardano.hs | 4 +- .../Cardano/Testnet/Test/FoldEpochState.hs | 4 +- .../Cardano/Testnet/Test/Rpc/Query.hs | 8 +- 20 files changed, 345 insertions(+), 225 deletions(-) diff --git a/bench/tx-generator/app/calibrate-script.hs b/bench/tx-generator/app/calibrate-script.hs index 6f1c9b273d7..0da52b62ea4 100644 --- a/bench/tx-generator/app/calibrate-script.hs +++ b/bench/tx-generator/app/calibrate-script.hs @@ -9,26 +9,18 @@ {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeOperators #-} {-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-} -import Cardano.Api hiding (eraProtVerHigh) -import Cardano.Api.Experimental (AnyWitness (..), IsEra (useEra), - PlutusScriptDatum (..), PlutusScriptPurpose (..), SignedTx (..), - eraProtVerHigh, makeKeyWitness, makeUnsignedTx, - obtainCommonConstraints, signTx, toPlutusSLanguage) -import Cardano.Api.Experimental.AnyScriptWitness (AnyPlutusScriptWitness (..), - createPlutusSpendingScriptWitness) -import qualified Cardano.Api.Experimental as Exp (PlutusScriptInEra (..), - PlutusScriptOrReferenceInput (..), PlutusScriptWitness (..), - evaluateTransactionFee) -import Cardano.Api.Experimental.Plutus (AnyPlutusScript (..), - plutusScriptInEraSLanguage) +import Cardano.Api +import Cardano.Api.Experimental (IsEra (useEra), SignedTx (..), makeKeyWitness, + makeUnsignedTx, obtainCommonConstraints, signTx) +import qualified Cardano.Api.Experimental as Exp (evaluateTransactionFee) +import Cardano.Api.Experimental.Plutus (AnyPlutusScript (..)) import qualified Cardano.Api.Experimental.Tx as Exp import Cardano.Ledger.Core (mkCoinTxOut) -import qualified Cardano.Ledger.Plutus.Language as L (PlutusLanguage, Plutus (..), PlutusBinary (..), - SLanguage (..), decodePlutusRunnable) import Cardano.Benchmarking.Compiler (keyBenchmarkInputs) import Cardano.Benchmarking.GeneratorTx.SizedMetadata (mkMetadata) @@ -42,7 +34,6 @@ import Cardano.TxGenerator.Types import Cardano.TxGenerator.Utils (keyAddress, mkTxIn) import Control.Exception -import Data.Typeable (Typeable) import Data.Aeson (decodeFileStrict') import qualified Data.ByteString.Lazy.Char8 as BSL (writeFile) @@ -176,17 +167,7 @@ runPlutus strategy budgetType protoParamFile plutusDef@PlutusOn{..} scales = do protocolParameters <- readProtocolParametersOrDie protoParamFile (script, resolvedTo) <- either (error . show) pure =<< readPlutusScript plutusScript - let era = useEra @ConwayEra - anyPlutusScript <- obtainCommonConstraints era $ - case script of - ScriptInAnyLang _lang (PlutusScript version (PlutusScriptSerialised sbs)) -> do - let slang = toPlutusSLanguage version - decode :: forall l. (L.PlutusLanguage l, Typeable l) => L.SLanguage l -> IO (AnyPlutusScript (ShelleyLedgerEra ConwayEra)) - decode _ = case L.decodePlutusRunnable @l (eraProtVerHigh era) (L.Plutus (L.PlutusBinary sbs)) of - Left err -> throwIO $ userError $ "script decode failed: " ++ show err - Right runnable -> pure $ AnyPlutusScript (Exp.PlutusScriptInEra runnable) - obtainLangConstraints slang $ decode slang - _ -> throwIO $ userError "expected a Plutus script" + anyPlutusScript <- either (throwIO . userError . show) pure $ toAnyPlutusScript (shelleyBasedEra @ConwayEra) script let redeemerDef = Right plutusDef @@ -515,23 +496,25 @@ writeResultsJSON jsonName summaries = do -- uses it to augment the budget summary with txn size and fee. -- * If anything fails to evaluate, the summary is returned unchanged. -- * This function is currently monomorphic in the ledger era and will resolve era parameters to Conway. -approximateTxProperties :: AnyPlutusScript (ShelleyLedgerEra ConwayEra) -> LedgerProtocolParameters ConwayEra -> (PlutusBudgetSummary, ScriptRedeemer) -> IO PlutusBudgetSummary -approximateTxProperties (AnyPlutusScript ps) ledgerProtocolParameters (summary, redeemer) = do +approximateTxProperties + :: forall era + . era ~ ConwayEra + => AnyPlutusScript (ShelleyLedgerEra era) + -> LedgerProtocolParameters era + -> (PlutusBudgetSummary, ScriptRedeemer) + -> IO PlutusBudgetSummary +approximateTxProperties anyPlutusScript ledgerProtocolParameters (summary, redeemer) = do putStrLn $ "--> approximating txn size and fee for: " ++ messageId summary let - era = useEra @ConwayEra + era = useEra @era pparams = unLedgerProtocolParameters ledgerProtocolParameters - slang = plutusScriptInEraSLanguage ps dummyDatum = unsafeHashableScriptData $ ScriptDataNumber 0 - datum = mkSpendingScriptDatum slang dummyDatum - anyWitness = - let witness = Exp.PlutusScriptWitness slang (Exp.PScript ps) datum redeemer (budgetUsedPerTxInput summary) - in AnyPlutusScriptWitness (AnyPlutusSpendingScriptWitness (createPlutusSpendingScriptWitness slang witness)) + anyWitness = mkPlutusSpendingWitness anyPlutusScript dummyDatum redeemer (budgetUsedPerTxInput summary) obtainCommonConstraints era (do -- Corresponds to the metadata inserted in benchmarking workloads, which is why it's needed for the estimate. -- default value taken from: `add_tx_size` in nix/nixos/tx-generator-service.nix dummyMetadata <- either (\e -> throwIO $ userError $ "approximateTxProperties: mkMetadata: " ++ e) pure - $ mkMetadata @ConwayEra 100 + $ mkMetadata @era 100 let expMetadata = case dummyMetadata of TxMetadataNone -> mempty @@ -539,8 +522,8 @@ approximateTxProperties (AnyPlutusScript ps) ledgerProtocolParameters (summary, -- just placeholders dummyTxIn ix = mkTxIn $ "900fc5da77a0747da53f7675cbb7d149d46779346dea2f879ab811ccc72a2162#" <> textShow @Int ix - dummyTxOut :: Exp.TxOut (ShelleyLedgerEra ConwayEra) - dummyTxOut = Exp.TxOut $ mkCoinTxOut (toShelleyAddr $ keyAddress @ConwayEra (Testnet (NetworkMagic 42)) keyBenchmarkInputs) (Coin 1_000_000) + dummyTxOut :: Exp.TxOut (ShelleyLedgerEra era) + dummyTxOut = Exp.TxOut $ mkCoinTxOut (toShelleyAddr $ keyAddress @era (Testnet (NetworkMagic 42)) keyBenchmarkInputs) (Coin 1_000_000) -- build a dummy tx akin to what we'd get in the tx-generator's benchmarking workload; -- it just needs to be sufficient to get our approximations. @@ -558,7 +541,7 @@ approximateTxProperties (AnyPlutusScript ps) ledgerProtocolParameters (summary, let witVKey = makeKeyWitness era unsignedTx (WitnessPaymentKey keyBenchmarkInputs) - dummyTx :: SignedTx ConwayEra + dummyTx :: SignedTx era dummyTx = signTx era [] [witVKey] unsignedTx pure summary @@ -570,19 +553,3 @@ approximateTxProperties (AnyPlutusScript ps) ledgerProtocolParameters (summary, ++ "\n--> using unmodified summary" pure summary --- TODO: remove these vendored functions and import from --- Cardano.Api.Experimental when the published cardano-api version includes them. - -obtainLangConstraints :: L.SLanguage lang -> ((L.PlutusLanguage lang, Typeable lang) => a) -> a -obtainLangConstraints L.SPlutusV1 f = f -obtainLangConstraints L.SPlutusV2 f = f -obtainLangConstraints L.SPlutusV3 f = f -obtainLangConstraints L.SPlutusV4 f = f - -mkSpendingScriptDatum :: L.SLanguage lang -> HashableScriptData -> PlutusScriptDatum lang 'SpendingScript -mkSpendingScriptDatum = \case - L.SPlutusV1 -> SpendingScriptDatum - L.SPlutusV2 -> SpendingScriptDatum - L.SPlutusV3 -> SpendingScriptDatum . Just - L.SPlutusV4 -> SpendingScriptDatum . Just - diff --git a/bench/tx-generator/src/Cardano/Benchmarking/GeneratorTx.hs b/bench/tx-generator/src/Cardano/Benchmarking/GeneratorTx.hs index 74c2505c6f0..b3a97e09459 100644 --- a/bench/tx-generator/src/Cardano/Benchmarking/GeneratorTx.hs +++ b/bench/tx-generator/src/Cardano/Benchmarking/GeneratorTx.hs @@ -4,7 +4,6 @@ {-# LANGUAGE RankNTypes #-} {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE TypeApplications #-} {-# LANGUAGE UndecidableInstances #-} {-# OPTIONS_GHC -Wno-all-missed-specialisations #-} @@ -21,7 +20,6 @@ module Cardano.Benchmarking.GeneratorTx ) where import Cardano.Api hiding (label, txFee) -import Cardano.Api.Experimental (IsEra, obtainCommonConstraints, useEra) import Cardano.Benchmarking.GeneratorTx.NodeToNode import Cardano.Benchmarking.GeneratorTx.Submission @@ -112,7 +110,7 @@ handleTxSubmissionClientError LogErrors -> traceWith traceSubmit $ TraceBenchTxSubError (pack errDesc) -walletBenchmark :: forall era. IsEra era +walletBenchmark :: forall era. IsShelleyBasedEra era => Trace IO (TraceBenchTxSubmit TxId) -> Trace IO NodeToNodeSubmissionTrace -> ConnectClient @@ -139,7 +137,7 @@ walletBenchmark _era count txSource - = obtainCommonConstraints (useEra @era) $ liftIO $ do + = liftIO $ do traceDebug "******* Tx generator, phase 2: pay to recipients *******" let numTargets :: Natural = fromIntegral $ NE.length targets diff --git a/bench/tx-generator/src/Cardano/Benchmarking/GeneratorTx/SizedMetadata.hs b/bench/tx-generator/src/Cardano/Benchmarking/GeneratorTx/SizedMetadata.hs index 8df6fd2ce25..4354d0cc9f9 100644 --- a/bench/tx-generator/src/Cardano/Benchmarking/GeneratorTx/SizedMetadata.hs +++ b/bench/tx-generator/src/Cardano/Benchmarking/GeneratorTx/SizedMetadata.hs @@ -7,16 +7,15 @@ module Cardano.Benchmarking.GeneratorTx.SizedMetadata where import Cardano.Api -import Cardano.Api.Experimental (AnyWitness (..), IsEra (useEra), SignedTx (..), - makeUnsignedTx, obtainCommonConstraints, signTx) -import qualified Cardano.Api.Experimental.Tx as Exp +import Cardano.Api.Compatible (CompatibleTxBodyContent (..), createCompatibleTx, + defaultCompatibleTxBodyContent) +import Cardano.Api.Experimental (AnyWitness (..)) import Cardano.TxGenerator.Utils import Prelude import qualified Data.ByteString as BS -import Data.Function ((&)) import qualified Data.Map.Strict as Map import Data.Word (Word64) @@ -29,31 +28,67 @@ maxBSSize = 64 -- Properties of the underlying/opaque CBOR encoding. assume_cbor_properties :: Bool assume_cbor_properties - = prop_mapCostsConway - && prop_mapCostsDijkstra + = prop_mapCostsShelley + && prop_mapCostsAllegra + && prop_mapCostsMary + && prop_mapCostsAlonzo + && prop_mapCostsBabbage + && prop_bsCostsShelley + && prop_bsCostsAllegra + && prop_bsCostsMary + && prop_bsCostsAlonzo + && prop_bsCostsBabbage && prop_bsCostsConway - && prop_bsCostsDijkstra -- The cost of map entries in metadata follows a step function. -- This assumes the map indices are [0..n]. +prop_mapCostsShelley :: Bool +prop_mapCostsAllegra :: Bool +prop_mapCostsMary :: Bool +prop_mapCostsAlonzo :: Bool +prop_mapCostsBabbage :: Bool prop_mapCostsConway :: Bool prop_mapCostsDijkstra :: Bool +prop_mapCostsShelley = measureMapCosts AsShelleyEra == assumeMapCosts AsShelleyEra +prop_mapCostsAllegra = measureMapCosts AsAllegraEra == assumeMapCosts AsAllegraEra +prop_mapCostsMary = measureMapCosts AsMaryEra == assumeMapCosts AsMaryEra +prop_mapCostsAlonzo = measureMapCosts AsAlonzoEra == assumeMapCosts AsAlonzoEra +prop_mapCostsBabbage = measureMapCosts AsBabbageEra == assumeMapCosts AsBabbageEra prop_mapCostsConway = measureMapCosts AsConwayEra == assumeMapCosts AsConwayEra prop_mapCostsDijkstra = measureMapCosts AsDijkstraEra == assumeMapCosts AsDijkstraEra -assumeMapCosts :: AsType era -> [Int] +assumeMapCosts :: forall era . IsShelleyBasedEra era => AsType era -> [Int] assumeMapCosts _proxy = stepFunction [ ( 1 , 0) -- An empty map of metadata has the same cost as TxMetadataNone. - , ( 1 , 42) -- Using Metadata costs 42 bytes (first map entry). + , ( 1 , firstEntry) -- First map entry: 37 (Shelley), 39 (Allegra/Mary) or 42 (Alonzo onwards) bytes. , ( 22 , 2) -- The next 22 entries cost 2 bytes each. , ( 233 , 3) -- 233 entries at 3 bytes. , ( 744 , 4) -- 744 entries at 4 bytes. ] + where + firstEntry = case shelleyBasedEra @era of + ShelleyBasedEraShelley -> 37 + ShelleyBasedEraAllegra -> 39 + ShelleyBasedEraMary -> 39 + ShelleyBasedEraAlonzo -> 42 + ShelleyBasedEraBabbage -> 42 + ShelleyBasedEraConway -> 42 + ShelleyBasedEraDijkstra -> 42 -- Bytestring costs are not LINEAR !! -- Costs are piecewise linear for payload sizes [0..23] and [24..64]. +prop_bsCostsShelley :: Bool +prop_bsCostsAllegra :: Bool +prop_bsCostsMary :: Bool +prop_bsCostsAlonzo :: Bool +prop_bsCostsBabbage :: Bool prop_bsCostsConway :: Bool prop_bsCostsDijkstra :: Bool +prop_bsCostsShelley = measureBSCosts AsShelleyEra == [37..60] ++ [62..102] +prop_bsCostsAllegra = measureBSCosts AsAllegraEra == [39..62] ++ [64..104] +prop_bsCostsMary = measureBSCosts AsMaryEra == [39..62] ++ [64..104] +prop_bsCostsAlonzo = measureBSCosts AsAlonzoEra == [42..65] ++ [67..107] +prop_bsCostsBabbage = measureBSCosts AsBabbageEra == [42..65] ++ [67..107] prop_bsCostsConway = measureBSCosts AsConwayEra == [42..65] ++ [67..107] prop_bsCostsDijkstra = measureBSCosts AsDijkstraEra == [42..65] ++ [67..107] @@ -63,7 +98,7 @@ stepFunction f = scanl1 (+) steps -- Measure the cost of metadata map entries. -- This is the cost of the index with an empty BS as payload. -measureMapCosts :: forall era . IsEra era => AsType era -> [Int] +measureMapCosts :: forall era . IsShelleyBasedEra era => AsType era -> [Int] measureMapCosts era = map (metadataSize era . Just . replicateEmptyBS) [0..maxMapSize] where replicateEmptyBS :: Int -> TxMetadata @@ -73,30 +108,38 @@ listMetadata :: [TxMetadataValue] -> TxMetadata listMetadata l = makeTransactionMetadata $ Map.fromList $ zip [0..] l -- Cost of metadata with a single BS of size [0..maxBSSize]. -measureBSCosts :: forall era . IsEra era => AsType era -> [Int] +measureBSCosts :: forall era . IsShelleyBasedEra era => AsType era -> [Int] measureBSCosts era = map (metadataSize era . Just . bsMetadata) [0..maxBSSize] where bsMetadata s = listMetadata [TxMetaBytes $ BS.replicate s 0] -metadataSize :: forall era . IsEra era => AsType era -> Maybe TxMetadata -> Int +metadataSize :: forall era . IsShelleyBasedEra era => AsType era -> Maybe TxMetadata -> Int metadataSize p m = dummyTxSize p m - dummyTxSize p Nothing -dummyTxSizeInEra :: forall era . IsEra era => TxMetadataInEra era -> Int -dummyTxSizeInEra metadata = obtainCommonConstraints era $ BS.length $ serialiseToRawBytes dummyTx +-- | Serialised size of a throwaway transaction carrying the given metadata. +-- Callers only ever compare two sizes (see 'metadataSize'), so it doesn't +-- matter that 'createCompatibleTx' returns a whole 'Tx era' - the constant +-- body/witness-set overhead cancels out. +-- Built with 'Cardano.Api.Compatible.Tx.createCompatibleTx' for every era. +dummyTxSizeInEra :: forall era . IsShelleyBasedEra era => TxMetadataInEra era -> Int +dummyTxSizeInEra metadata = + shelleyBasedEraConstraints sbe $ + case createCompatibleTx sbe bodyContent of + Right tx -> BS.length $ serialiseToCBOR tx + Left err -> error $ "dummyTxSizeInEra: " ++ show err where - era = useEra @era - expMetadata = case metadata of - TxMetadataNone -> mempty - TxMetadataInEra _ m -> m - txBodyContent = Exp.defaultTxBodyContent - & Exp.setTxIns [(mkTxIn "dbaff4e270cfb55612d9e2ac4658a27c79da4a5271c6f90853042d1403733810#0", AnyKeyWitnessPlaceholder)] - & Exp.setTxMetadata expMetadata - dummyTx :: SignedTx era - dummyTx = signTx era [] [] unsignedTx - where - unsignedTx = either (\err -> error $ "dummyTxSizeInEra: " ++ show err) id $ makeUnsignedTx era txBodyContent - -dummyTxSize :: forall era . IsEra era => AsType era -> Maybe TxMetadata -> Int -dummyTxSize _p m = obtainCommonConstraints (useEra @era) $ dummyTxSizeInEra @era (metadataInEra m) + sbe = shelleyBasedEra @era + + expInputs :: [(TxIn, AnyWitness (ShelleyLedgerEra era))] + expInputs = [(mkTxIn "dbaff4e270cfb55612d9e2ac4658a27c79da4a5271c6f90853042d1403733810#0", AnyKeyWitnessPlaceholder)] + + bodyContent :: CompatibleTxBodyContent era + bodyContent = (defaultCompatibleTxBodyContent sbe) + { compatibleTxIns = expInputs + , compatibleTxMetadata = metadata + } + +dummyTxSize :: forall era . IsShelleyBasedEra era => AsType era -> Maybe TxMetadata -> Int +dummyTxSize _p m = (dummyTxSizeInEra @era) $ metadataInEra m metadataInEra :: forall era . IsShelleyBasedEra era => Maybe TxMetadata -> TxMetadataInEra era metadataInEra Nothing = TxMetadataNone diff --git a/bench/tx-generator/src/Cardano/Benchmarking/GeneratorTx/SubmissionClient.hs b/bench/tx-generator/src/Cardano/Benchmarking/GeneratorTx/SubmissionClient.hs index c9d2ac0f1fb..958f7cf0008 100644 --- a/bench/tx-generator/src/Cardano/Benchmarking/GeneratorTx/SubmissionClient.hs +++ b/bench/tx-generator/src/Cardano/Benchmarking/GeneratorTx/SubmissionClient.hs @@ -24,7 +24,7 @@ module Cardano.Benchmarking.GeneratorTx.SubmissionClient ) where import Cardano.Api hiding (Active, CardanoBlock) -import Cardano.Api.Experimental (IsEra, SignedTx (..)) +import Cardano.Api.Experimental (SignedTx (..)) import Cardano.Benchmarking.LogTypes import Cardano.Benchmarking.Types @@ -84,7 +84,7 @@ type EndOfProtocolCallback m = SubmissionThreadStats -> m () txSubmissionClient :: forall m era. ( MonadIO m, MonadFail m - , IsEra era + , IsShelleyBasedEra era ) => Trace m NodeToNodeSubmissionTrace -> Trace m (TraceBenchTxSubmit TxId) diff --git a/bench/tx-generator/src/Cardano/Benchmarking/Script/Core.hs b/bench/tx-generator/src/Cardano/Benchmarking/Script/Core.hs index 0685d6bdba6..6cabdca06a9 100644 --- a/bench/tx-generator/src/Cardano/Benchmarking/Script/Core.hs +++ b/bench/tx-generator/src/Cardano/Benchmarking/Script/Core.hs @@ -18,8 +18,7 @@ module Cardano.Benchmarking.Script.Core where import Cardano.Api -import Cardano.Api.Experimental (AnyWitness (..), IsEra (useEra), SignedTx (..), - obtainCommonConstraints) +import Cardano.Api.Experimental (AnyWitness (..), SignedTx (..)) import Cardano.Benchmarking.GeneratorTx as GeneratorTx (AsyncBenchmarkControl) import qualified Cardano.Benchmarking.GeneratorTx as GeneratorTx (waitBenchmark, walletBenchmark) @@ -67,15 +66,19 @@ import qualified Data.Text as Text (unpack) import Streaming import qualified Streaming.Prelude as Streaming -liftCoreWithEra :: AnyCardanoEra -> (forall era. IsEra era => AsType era -> ExceptT TxGenError IO x) -> ActionM (Either TxGenError x) +liftCoreWithEra :: AnyCardanoEra -> (forall era. IsShelleyBasedEra era => AsType era -> ExceptT TxGenError IO x) -> ActionM (Either TxGenError x) liftCoreWithEra era coreCall = withEra era ( liftIO . runExceptT . coreCall) -withEra :: AnyCardanoEra -> (forall era. IsEra era => AsType era -> ActionM x) -> ActionM x -withEra era action = do - case era of - AnyCardanoEra ConwayEra -> action AsConwayEra - AnyCardanoEra DijkstraEra -> action AsDijkstraEra - _ -> error $ "withEra: unsupported era: " ++ show era +-- | Dispatches on the requested era, providing an 'IsShelleyBasedEra' +-- witness for every Shelley-based era. +-- Byron is not supported by tx-generator (see PR #6602's "older-era +-- support" discussion). +withEra :: forall x. AnyCardanoEra -> (forall era. IsShelleyBasedEra era => AsType era -> ActionM x) -> ActionM x +withEra (AnyCardanoEra era) action = + forEraInEon era (error "withEra: Byron is not supported") action' + where + action' :: forall era. ShelleyBasedEra era -> ActionM x + action' sbe = shelleyBasedEraConstraints sbe $ action (asType @era) setProtocolParameters :: ProtocolParametersSource -> ActionM () setProtocolParameters s = case s of @@ -98,8 +101,8 @@ addFund :: AnyCardanoEra -> String -> TxIn -> L.Coin -> String -> ActionM () addFund era wallet txIn lovelace keyName = do fundKey <- getEnvKeys keyName let - mkOutValue :: forall era. IsEra era => AsType era -> ActionM (InAnyCardanoEra TxOutValue) - mkOutValue _ = obtainCommonConstraints (useEra @era) $ + mkOutValue :: forall era. IsShelleyBasedEra era => AsType era -> ActionM (InAnyCardanoEra TxOutValue) + mkOutValue _ = return $ InAnyCardanoEra (cardanoEra @era) (lovelaceToTxOutValue shelleyBasedEra lovelace) outValue <- withEra era mkOutValue addFundToWallet wallet txIn outValue fundKey @@ -228,16 +231,16 @@ localSubmitTx tx = do -- Problem 1: When doing throwE $ ApiError msg logmessages get lost ! -- Problem 2: Workbench restarts the tx-generator -> this may be the reason for loss of messages -toMetadata :: forall era. IsEra era => Maybe Int -> TxMetadataInEra era +toMetadata :: forall era. IsShelleyBasedEra era => Maybe Int -> TxMetadataInEra era toMetadata Nothing = TxMetadataNone -toMetadata (Just payloadSize) = obtainCommonConstraints (useEra @era) $ case mkMetadata payloadSize of +toMetadata (Just payloadSize) = case mkMetadata payloadSize of Right m -> m Left err -> error err submitAction :: AnyCardanoEra -> SubmitMode -> Generator -> TxGenTxParams -> ActionM () submitAction era submitMode generator txParams = withEra era $ submitInEra submitMode generator txParams -submitInEra :: forall era. IsEra era => SubmitMode -> Generator -> TxGenTxParams -> AsType era -> ActionM () +submitInEra :: forall era. IsShelleyBasedEra era => SubmitMode -> Generator -> TxGenTxParams -> AsType era -> ActionM () submitInEra submitMode generator txParams era = do txStream <- evalGenerator generator txParams era case submitMode of @@ -269,7 +272,7 @@ submitInEra submitMode generator txParams era = do callback tx submitAll callback rest -benchmarkTxStream :: forall era. IsEra era +benchmarkTxStream :: forall era. IsShelleyBasedEra era => TxStream IO era -> TargetNodes -> TPSRate @@ -288,11 +291,11 @@ benchmarkTxStream txStream targetNodes tps txCount era = do Left err -> liftTxGenError err Right ctl -> setEnvThreads ctl -evalGenerator :: forall era. IsEra era => Generator -> TxGenTxParams -> AsType era -> ActionM (TxStream IO era) -evalGenerator generator txParams@TxGenTxParams{txParamFee = fee} eraProxy = obtainCommonConstraints (useEra @era) $ do +evalGenerator :: forall era. IsShelleyBasedEra era => Generator -> TxGenTxParams -> AsType era -> ActionM (TxStream IO era) +evalGenerator generator txParams@TxGenTxParams{txParamFee = fee} eraProxy = do networkId <- getEnvNetworkId protocolParameters <- getProtocolParameters - let era = useEra @era + let sbe = shelleyBasedEra @era case convertToLedgerProtocolParameters shelleyBasedEra protocolParameters of Left err -> throwE (Env.TxGenError (ApiError err)) Right ledgerParameters -> @@ -324,7 +327,7 @@ evalGenerator generator txParams@TxGenTxParams{txParamFee = fee} eraProxy = obta let fundSource = walletSource wallet 1 inToOut = Utils.includeChange fee coins - txGenerator = genTx era ledgerParameters ([], []) fee TxMetadataNone + txGenerator = genTx sbe ledgerParameters ([], []) fee TxMetadataNone sourceToStore = sourceToStoreTransactionNew txGenerator fundSource inToOut $ mangleWithChange toUTxOChange toUTxO return $ Streaming.effect (Streaming.yield <$> sourceToStore) @@ -340,7 +343,7 @@ evalGenerator generator txParams@TxGenTxParams{txParamFee = fee} eraProxy = obta let fundSource = walletSource wallet 1 inToOut = Utils.inputsToOutputsWithFee fee count - txGenerator = genTx era ledgerParameters ([], []) fee TxMetadataNone + txGenerator = genTx sbe ledgerParameters ([], []) fee TxMetadataNone sourceToStore = sourceToStoreTransactionNew txGenerator fundSource inToOut (mangle $ repeat toUTxO) return $ Streaming.effect (Streaming.yield <$> sourceToStore) @@ -352,7 +355,7 @@ evalGenerator generator txParams@TxGenTxParams{txParamFee = fee} eraProxy = obta let fundSource = walletSource wallet inputs inToOut = Utils.inputsToOutputsWithFee fee outputs - txGenerator = genTx era ledgerParameters collaterals fee (toMetadata metadataSize) + txGenerator = genTx sbe ledgerParameters collaterals fee (toMetadata metadataSize) sourceToStore = sourceToStoreTransactionNew txGenerator fundSource inToOut (mangle $ repeat toUTxO) fundPreview <- liftIO $ walletPreview wallet inputs @@ -413,8 +416,8 @@ dumpToFileIO filePath tx = appendFile filePath ('\n' : show tx) initWallet :: String -> ActionM () initWallet name = liftIO Wallet.initWallet >>= setEnvWallets name -interpretPayMode :: forall era. IsEra era => PayMode -> ActionM (CreateAndStore IO era, String) -interpretPayMode payMode = obtainCommonConstraints (useEra @era) $ do +interpretPayMode :: forall era. IsShelleyBasedEra era => PayMode -> ActionM (CreateAndStore IO era, String) +interpretPayMode payMode = do networkId <- getEnvNetworkId case payMode of PayToAddr keyName destWallet -> do @@ -425,15 +428,20 @@ interpretPayMode payMode = obtainCommonConstraints (useEra @era) $ do PayToScript scriptSpec destWallet -> do walletRef <- getEnvWallets destWallet (witness, script, scriptData, _scriptFee) <- makePlutusContext scriptSpec + alonzoOnwards <- + forEraInEon + (cardanoEra @era) + (liftTxGenError $ TxGenError "PayToScript: Plutus scripts require Alonzo onwards") + pure case script of ScriptInAnyLang _ script' -> - return ( createAndStore (mkUTxOScript networkId (script, scriptData) witness) (mkWalletFundStore walletRef) + return ( createAndStore (mkUTxOScript alonzoOnwards networkId (script, scriptData) witness) (mkWalletFundStore walletRef) , Text.unpack $ serialiseAddress $ makeShelleyAddress networkId (PaymentCredentialByScript $ hashScript script') NoStakeAddress ) -makePlutusContext :: forall era. IsEra era +makePlutusContext :: forall era. IsShelleyBasedEra era => ScriptSpec - -> ActionM (AnyWitness era, ScriptInAnyLang, ScriptData, L.Coin) -makePlutusContext ScriptSpec{..} = obtainCommonConstraints (useEra @era) $ do + -> ActionM (AnyWitness (ShelleyLedgerEra era), ScriptInAnyLang, ScriptData, L.Coin) +makePlutusContext ScriptSpec{..} = do protocolParameters <- getProtocolParameters (script, resolvedTo) <- liftIOSafe $ Plutus.readPlutusScript scriptSpecFile @@ -508,8 +516,10 @@ makePlutusContext ScriptSpec{..} = obtainCommonConstraints (useEra @era) $ do times w c = fromIntegral w % 1 * c case script of - ScriptInAnyLang _ PlutusScript{} -> - return (AnyKeyWitnessPlaceholder, script, getScriptData scriptData, scriptFee) + ScriptInAnyLang _ PlutusScript{} -> do + anyPlutusScript <- either liftTxGenError pure $ Plutus.toAnyPlutusScript (shelleyBasedEra @era) script + let witness = Plutus.mkPlutusSpendingWitness anyPlutusScript scriptData scriptRedeemer executionUnits + return (witness, script, getScriptData scriptData, scriptFee) _ -> liftTxGenError $ TxGenError "runPlutusBenchmark: only Plutus scripts supported" diff --git a/bench/tx-generator/src/Cardano/Benchmarking/Script/Ogmios.hs b/bench/tx-generator/src/Cardano/Benchmarking/Script/Ogmios.hs index 6d534ed1cb6..244019fb140 100644 --- a/bench/tx-generator/src/Cardano/Benchmarking/Script/Ogmios.hs +++ b/bench/tx-generator/src/Cardano/Benchmarking/Script/Ogmios.hs @@ -1,7 +1,6 @@ {-# LANGUAGE NumericUnderscores #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE TypeApplications #-} {-| Module : Cardano.Benchmarking.Script.Ogmios @@ -62,8 +61,8 @@ module Cardano.Benchmarking.Script.Ogmios , withOgmiosTransport ) where -import Cardano.Api (serialiseToRawBytes) -import Cardano.Api.Experimental (IsEra (useEra), SignedTx, obtainCommonConstraints) +import Cardano.Api (IsShelleyBasedEra, serialiseToRawBytes) +import Cardano.Api.Experimental (SignedTx (..)) import Cardano.Benchmarking.Script.Submission (SubmitTransport (..)) import Cardano.TxGenerator.Types (TxGenError (..)) @@ -131,7 +130,7 @@ instance Exception OgmiosProtocolError -- surfaced as a 'Left' 'TxGenError'; the connection lifecycle is reported -- through the given tracer, so a healthy run leaves evidence too. withOgmiosTransport - :: forall era a. IsEra era + :: forall era a. IsShelleyBasedEra era => (String -> IO ()) -- ^ progress tracer for backend events (connection lifecycle) -> URI @@ -165,7 +164,7 @@ withOgmiosTransport traceProgress uri use = -- a rejection as 'Left'. A protocol-level fault throws 'OgmiosProtocolError' -- (caught by 'withOgmiosTransport'). ogmiosSubmitOne - :: IsEra era + :: IsShelleyBasedEra era => WS.Connection -> IORef Int -> SignedTx era -> IO (Either OgmiosRejection Text) ogmiosSubmitOne conn reqIdRef tx = do reqId <- atomicModifyIORef' reqIdRef $ \n -> (n + 1, n) @@ -222,8 +221,8 @@ parseOgmiosUrl uri = do Just n | n >= 1 && n <= 65_535 -> Right n _ -> Left $ "Invalid port in Ogmios URL: " ++ urlStr -mkSubmitRequest :: forall era. IsEra era => SignedTx era -> Int -> Value -mkSubmitRequest tx reqId = object +mkSubmitRequest :: forall era. IsShelleyBasedEra era => SignedTx era -> Int -> Value +mkSubmitRequest tx@(SignedTx _) reqId = object [ "jsonrpc" .= ("2.0" :: Text) , "method" .= ("submitTransaction" :: Text) , "params" .= object @@ -235,7 +234,7 @@ mkSubmitRequest tx reqId = object ] where cbor :: ByteString - cbor = obtainCommonConstraints (useEra @era) $ serialiseToRawBytes tx + cbor = serialiseToRawBytes tx -- | Outcome of a single @submitTransaction@ call, as decoded from the -- JSON-RPC response. diff --git a/bench/tx-generator/src/Cardano/TxGenerator/Fund.hs b/bench/tx-generator/src/Cardano/TxGenerator/Fund.hs index aef77e54fe7..86b84944dd7 100644 --- a/bench/tx-generator/src/Cardano/TxGenerator/Fund.hs +++ b/bench/tx-generator/src/Cardano/TxGenerator/Fund.hs @@ -21,7 +21,7 @@ module Cardano.TxGenerator.Fund where import Cardano.Api as Api -import Cardano.Api.Experimental (AnyWitness (..), IsEra, obtainCommonConstraints, useEra) +import Cardano.Api.Experimental (AnyWitness (..)) import qualified Cardano.Ledger.Coin as L @@ -37,7 +37,7 @@ import Data.Function (on) -- use of lenses. data FundInEra era = FundInEra { _fundTxIn :: !TxIn - , _fundWitness :: AnyWitness era + , _fundWitness :: AnyWitness (ShelleyLedgerEra era) , _fundVal :: !(TxOutValue era) , _fundSigningKey :: !(Maybe (SigningKey PaymentKey)) } @@ -77,11 +77,16 @@ getFundCoin (Fund (InAnyCardanoEra _ a)) = case _fundVal a of -- TODO: facilitate casting KeyWitnesses between eras -- Note [Era transitions] -- | The `Fund` alternative is checked against `cardanoEra`, but -- `getFundWitness` otherwise wraps `_fundWitness`. -getFundWitness :: forall era. IsEra era => Fund -> AnyWitness era -getFundWitness fund = obtainCommonConstraints (useEra @era) $ case (cardanoEra @era, fund) of - (ConwayEra , Fund (InAnyCardanoEra ConwayEra a)) -> _fundWitness a +getFundWitness :: forall era. IsShelleyBasedEra era => Fund -> AnyWitness (ShelleyLedgerEra era) +getFundWitness fund = case (cardanoEra @era, fund) of + (ShelleyEra , Fund (InAnyCardanoEra ShelleyEra a)) -> _fundWitness a + (AllegraEra , Fund (InAnyCardanoEra AllegraEra a)) -> _fundWitness a + (MaryEra , Fund (InAnyCardanoEra MaryEra a)) -> _fundWitness a + (AlonzoEra , Fund (InAnyCardanoEra AlonzoEra a)) -> _fundWitness a + (BabbageEra , Fund (InAnyCardanoEra BabbageEra a)) -> _fundWitness a + (ConwayEra , Fund (InAnyCardanoEra ConwayEra a)) -> _fundWitness a (DijkstraEra, Fund (InAnyCardanoEra DijkstraEra a)) -> _fundWitness a - _ -> error "getFundWitness: era mismatch" + _ -> error "getFundWitness: era mismatch" {- Note [Era transitions] diff --git a/bench/tx-generator/src/Cardano/TxGenerator/Genesis.hs b/bench/tx-generator/src/Cardano/TxGenerator/Genesis.hs index 3f0c39b14a8..cc0859c3745 100644 --- a/bench/tx-generator/src/Cardano/TxGenerator/Genesis.hs +++ b/bench/tx-generator/src/Cardano/TxGenerator/Genesis.hs @@ -20,11 +20,14 @@ module Cardano.TxGenerator.Genesis where import Cardano.Api hiding (ShelleyGenesis) -import Cardano.Api.Experimental (AnyWitness (..), Era, IsEra (useEra), LedgerEra, - SignedTx (..), makeKeyWitness, makeUnsignedTx, obtainCommonConstraints, signTx) +import Cardano.Api.Compatible (CompatibleTxBodyContent (..), CompatibleTxError, + createCompatibleTx, defaultCompatibleTxBodyContent) +import qualified Cardano.Api.Compatible as Compatible (addWitnesses) +import Cardano.Api.Experimental (AnyWitness (..), SignedTx (..)) import qualified Cardano.Api.Experimental.Tx as Exp import Cardano.Ledger.BaseTypes (StrictMaybe (..)) +import qualified Cardano.Ledger.Api as Ledger import qualified Cardano.Ledger.Coin as L import Cardano.Ledger.Core (mkCoinTxOut) import Cardano.Ledger.Shelley.API (Addr (..)) @@ -35,29 +38,28 @@ import Cardano.TxGenerator.Utils import Ouroboros.Consensus.Shelley.Node (validateGenesis) import Data.Bifunctor (first, second) -import Data.Function ((&)) import Data.List (find) import qualified Data.ListMap as ListMap (toList) +import Lens.Micro ((^.)) genesisValidate :: ShelleyGenesis -> Either String () genesisValidate = validateGenesis -genesisSecureInitialFund :: forall era. IsEra era => +genesisSecureInitialFund :: forall era. IsShelleyBasedEra era => NetworkId -> ShelleyGenesis -> SigningKey PaymentKey -> SigningKey PaymentKey -> TxGenTxParams -> Either TxGenError (SignedTx era, Fund) -genesisSecureInitialFund networkId genesis srcKey destKey TxGenTxParams{txParamFee, txParamTTL} = - obtainCommonConstraints (useEra @era) $ do - mFund <- genesisInitialFundForKey @era networkId genesis srcKey - case mFund of - Nothing -> Left $ TxGenError "genesisSecureInitialFund: no fund found for given key in genesis" - Just (_, lovelace) -> - genesisExpenditure networkId srcKey destAddr (lovelace - txParamFee) txParamFee txParamTTL destKey +genesisSecureInitialFund networkId genesis srcKey destKey TxGenTxParams{txParamFee, txParamTTL} = do + mFund <- genesisInitialFundForKey @era networkId genesis srcKey + case mFund of + Nothing -> Left $ TxGenError "genesisSecureInitialFund: no fund found for given key in genesis" + Just (_, lovelace) -> + genesisExpenditure networkId srcKey destAddr (lovelace - txParamFee) txParamFee txParamTTL destKey where destAddr = keyAddress @era networkId destKey @@ -113,7 +115,7 @@ genesisTxInput networkId . castKey genesisExpenditure :: forall era. - IsEra era + IsShelleyBasedEra era => NetworkId -> SigningKey PaymentKey -> AddressInEra era @@ -123,12 +125,11 @@ genesisExpenditure :: forall era. -> SigningKey PaymentKey -> Either TxGenError (SignedTx era, Fund) genesisExpenditure networkId inputKey addr value fee ttl outputKey - = obtainCommonConstraints era $ + = shelleyBasedEraConstraints (shelleyBasedEra @era) $ second (\tx -> (tx, Fund $ InAnyCardanoEra cardanoEra $ fund (lovelaceToTxOutValue (shelleyBasedEra @era) value) tx)) - $ mkGenesisTransaction era (castKey inputKey) ttl fee [pseudoTxIn] + $ mkGenesisTransaction (shelleyBasedEra @era) (castKey inputKey) ttl fee [pseudoTxIn] [Exp.TxOut $ mkCoinTxOut (toShelleyAddr addr) value] where - era = useEra @era pseudoTxIn = genesisTxInput networkId inputKey fund txOutValue tx = FundInEra { @@ -138,25 +139,33 @@ genesisExpenditure networkId inputKey addr value fee ttl outputKey , _fundSigningKey = Just outputKey } +-- | Builds and signs the genesis-import transaction, for every era, with +-- 'Cardano.Api.Compatible.Tx.createCompatibleTx'. +-- The TTL is passed through as 'compatibleTxValidityUpperBound'. mkGenesisTransaction :: - Era era + ShelleyBasedEra era -> SigningKey GenesisUTxOKey -> SlotNo -> L.Coin -> [TxIn] - -> [Exp.TxOut (LedgerEra era)] + -> [Exp.TxOut (ShelleyLedgerEra era)] -> Either TxGenError (SignedTx era) -mkGenesisTransaction era key ttl fee txins txouts - = obtainCommonConstraints era $ do - let expInputs = map (,AnyKeyWitnessPlaceholder) txins - txBodyContent = Exp.defaultTxBodyContent - & Exp.setTxIns expInputs - & Exp.setTxOuts txouts - & Exp.setTxFee fee - & Exp.setTxValidityUpperBound ttl - unsignedTx <- first (\err -> TxGenError $ "mkGenesisTransaction: " ++ show err) $ makeUnsignedTx era txBodyContent - let witVKey = makeKeyWitness era unsignedTx (WitnessGenesisUTxOKey key) - Right $ signTx era [] [witVKey] unsignedTx +mkGenesisTransaction sbe key ttl fee txins txouts = + shelleyBasedEraConstraints sbe $ do + let expInputs = map (,AnyKeyWitnessPlaceholder) txins + bodyContent = (defaultCompatibleTxBodyContent sbe) + { compatibleTxIns = expInputs + , compatibleTxOuts = txouts + , compatibleTxFee = fee + , compatibleTxValidityUpperBound = Just ttl + } + unsignedTx@(ShelleyTx _ unsignedLedgerTx) <- + first (\err -> TxGenError $ "mkGenesisTransaction: " ++ show (err :: CompatibleTxError)) $ + createCompatibleTx sbe bodyContent + let ledgerBody = unsignedLedgerTx ^. Ledger.bodyTxL + witVKey = makeShelleyKeyWitness' sbe ledgerBody (WitnessGenesisUTxOKey key) + ShelleyTx _ signedLedgerTx = Compatible.addWitnesses [witVKey] unsignedTx + Right $ SignedTx signedLedgerTx castKey :: SigningKey PaymentKey -> SigningKey GenesisUTxOKey castKey (PaymentSigningKey skey) = GenesisUTxOSigningKey skey diff --git a/bench/tx-generator/src/Cardano/TxGenerator/PureExample.hs b/bench/tx-generator/src/Cardano/TxGenerator/PureExample.hs index b72225b9da9..9163b3e614b 100644 --- a/bench/tx-generator/src/Cardano/TxGenerator/PureExample.hs +++ b/bench/tx-generator/src/Cardano/TxGenerator/PureExample.hs @@ -1,4 +1,5 @@ {-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE TypeApplications #-} {-# LANGUAGE TypeFamilies #-} {-# OPTIONS_GHC -fno-warn-incomplete-uni-patterns #-} @@ -7,7 +8,7 @@ module Cardano.TxGenerator.PureExample where import Cardano.Api hiding (txId) -import Cardano.Api.Experimental (AnyWitness (..), SignedTx, useEra) +import Cardano.Api.Experimental (AnyWitness (..), SignedTx) import qualified Cardano.Ledger.Coin as L import Cardano.TxGenerator.FundQueue @@ -109,7 +110,7 @@ generateTx TxEnvironment{..} generator = case convertToLedgerProtocolParameters shelleyBasedEra txEnvProtocolParams of Right ledgerParameters -> - genTx useEra ledgerParameters collateralFunds fee txEnvMetadata + genTx (shelleyBasedEra @DemoEra) ledgerParameters collateralFunds fee txEnvMetadata Left err -> \_ _ -> Left (ApiError err) where -- collateralFunds are needed for Plutus transactions @@ -160,7 +161,7 @@ generateTxPure TxEnvironment{..} inQueue generator = case convertToLedgerProtocolParameters shelleyBasedEra txEnvProtocolParams of Right ledgerParameters -> - genTx useEra ledgerParameters collateralFunds fee txEnvMetadata + genTx (shelleyBasedEra @DemoEra) ledgerParameters collateralFunds fee txEnvMetadata Left err -> \_ _ -> Left (ApiError err) where -- collateralFunds are needed for Plutus transactions diff --git a/bench/tx-generator/src/Cardano/TxGenerator/Setup/Plutus.hs b/bench/tx-generator/src/Cardano/TxGenerator/Setup/Plutus.hs index 22e40dd9432..700eeea799f 100644 --- a/bench/tx-generator/src/Cardano/TxGenerator/Setup/Plutus.hs +++ b/bench/tx-generator/src/Cardano/TxGenerator/Setup/Plutus.hs @@ -1,8 +1,10 @@ {-# LANGUAGE CPP #-} +{-# LANGUAGE DataKinds #-} {-# LANGUAGE GADTs #-} {-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeApplications #-} {-| Module : Cardano.TxGenerator.Setup.Plutus @@ -11,11 +13,14 @@ Description : Convenience functions for dealing with Plutus scripts module Cardano.TxGenerator.Setup.Plutus ( readPlutusScript , preExecutePlutusScript + , toAnyPlutusScript + , mkPlutusSpendingWitness ) where import Data.Bifunctor import Data.ByteString.Short (ShortByteString) +import Data.Functor (void) import Data.Int (Int64) import Data.Map.Strict as Map (lookup) @@ -25,7 +30,16 @@ import Control.Monad.Writer (runWriter) import Cardano.CLI.Read (readFileScriptInAnyLang) -import Cardano.Api +import Cardano.Api hiding (PScript, PlutusScriptInEra, PlutusScriptWitness) +import Cardano.Api.Experimental (AnyWitness (..), PlutusScriptOrReferenceInput (..), + PlutusScriptWitness (..), mkSpendingScriptDatum, obtainLangConstraints, + toPlutusSLanguage) +import Cardano.Api.Experimental.AnyScriptWitness (AnyPlutusScriptWitness (..), + createPlutusSpendingScriptWitness) +import Cardano.Api.Experimental.Plutus (AnyPlutusScript (..), PlutusScriptInEra (..), + plutusScriptInEraSLanguage) +import qualified Cardano.Ledger.Plutus.Language as L (PlutusBinary (..), PlutusLanguage, Plutus (..), + SLanguage, decodePlutusRunnable, plutusRunnableResult) import Cardano.Ledger.Plutus.TxInfo (exBudgetToExUnits) import qualified PlutusLedgerApi.V1 as PlutusV1 @@ -41,7 +55,7 @@ import System.FilePath ((<.>), ()) import Cardano.Benchmarking.PlutusScripts (findPlutusScript) #endif -import Paths_tx_generator +import Paths_tx_generator hiding (version) type ProtocolVersion = (Int, Int) @@ -77,6 +91,51 @@ readPlutusScript (Right fp) ScriptInAnyLang (PlutusScriptLanguage _) _ -> pure (script, ResolvedToFileName fp) ScriptInAnyLang lang _ -> throwE $ TxGenError $ "readPlutusScript: only PlutusScript supported, found: " ++ show lang +-- | 'toAnyPlutusScript' decodes a 'ScriptInAnyLang' (as returned by 'readPlutusScript') +-- into the ledger-side runnable representation needed to build a script witness. +-- Fails for: a non-Plutus script; a Plutus language unsupported in this era +-- (V1 needs Alonzo onwards, V2 needs Babbage onwards, checked via +-- 'scriptLanguageSupportedInEra' - the same check +-- 'Cardano.TxGenerator.UTxO.mkUTxOScript' uses); or a binary payload that +-- fails to decode against the era's protocol version. +toAnyPlutusScript :: forall era. ShelleyBasedEra era -> ScriptInAnyLang -> Either TxGenError (AnyPlutusScript (ShelleyLedgerEra era)) +toAnyPlutusScript sbe script + = case script of + ScriptInAnyLang lang (PlutusScript version (PlutusScriptSerialised sbs)) -> do + alonzoOnwards <- + forEraMaybeEon (toCardanoEra sbe) + ?! TxGenError "toAnyPlutusScript: Plutus scripts are not supported before Alonzo" + void $ + scriptLanguageSupportedInEra sbe lang + ?! TxGenError ("toAnyPlutusScript: " ++ show lang ++ " is not supported in " ++ show sbe) + alonzoEraOnwardsConstraints alonzoOnwards $ do + let + slang = toPlutusSLanguage version + decode :: forall l. L.PlutusLanguage l => L.SLanguage l -> Either TxGenError (AnyPlutusScript (ShelleyLedgerEra era)) + decode _ = do + let runnable = L.decodePlutusRunnable @l (eraProtVerHigh sbe) (L.Plutus (L.PlutusBinary sbs)) + AnyPlutusScript (PlutusScriptInEra runnable) + <$ L.plutusRunnableResult runnable + ?!& \err -> TxGenError $ "toAnyPlutusScript: script decode failed: " ++ show err + obtainLangConstraints slang $ decode slang + ScriptInAnyLang lang _ -> + Left $ TxGenError $ "toAnyPlutusScript: only PlutusScript supported, found: " ++ show lang + +-- | 'mkPlutusSpendingWitness' builds the transaction witness for spending a UTxO locked +-- by a Plutus script, dispatching on the script's Plutus language version. +mkPlutusSpendingWitness :: + AnyPlutusScript ledgerEra + -> HashableScriptData + -> ScriptRedeemer + -> ExecutionUnits + -> AnyWitness ledgerEra +mkPlutusSpendingWitness (AnyPlutusScript plutusScript) datum redeemer executionUnits = + AnyPlutusScriptWitness $ AnyPlutusSpendingScriptWitness $ + createPlutusSpendingScriptWitness slang $ + PlutusScriptWitness slang (PScript plutusScript) (mkSpendingScriptDatum slang datum) redeemer executionUnits + where + slang = plutusScriptInEraSLanguage plutusScript + -- | 'preExecutePlutusScript' is a front end for the internal -- @preExecutePlutusVn@ functions used to calculate 'ExecutionUnits' -- that switches on Plutus versions. The diff --git a/bench/tx-generator/src/Cardano/TxGenerator/Tx.hs b/bench/tx-generator/src/Cardano/TxGenerator/Tx.hs index f78982b265b..8704e018eb7 100644 --- a/bench/tx-generator/src/Cardano/TxGenerator/Tx.hs +++ b/bench/tx-generator/src/Cardano/TxGenerator/Tx.hs @@ -1,17 +1,19 @@ {-# LANGUAGE GADTs #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE TypeApplications #-} module Cardano.TxGenerator.Tx (module Cardano.TxGenerator.Tx) where import Cardano.Api hiding (txId) -import Cardano.Api.Experimental (AnyWitness (..), Era, IsEra, LedgerEra, SignedTx (..), - makeKeyWitness, makeUnsignedTx, obtainCommonConstraints, signTx, useEra) +import Cardano.Api.Compatible (CompatibleTxBodyContent (..), CompatibleTxError, + createCompatibleTx, defaultCompatibleTxBodyContent) +import qualified Cardano.Api.Compatible as Compatible (addWitnesses) +import Cardano.Api.Experimental (AnyWitness, SignedTx (..)) import qualified Cardano.Api.Experimental.Tx as Exp +import qualified Cardano.Ledger.Api as Ledger import qualified Cardano.Ledger.Coin as L import Cardano.TxGenerator.Fund import Cardano.TxGenerator.Types @@ -20,22 +22,22 @@ import Cardano.TxGenerator.UTxO (ToUTxOList) import Data.Bifunctor (first, second) import qualified Data.ByteString as BS (length) -import Data.Function ((&)) import Data.Maybe (mapMaybe) +import Lens.Micro ((^.)) -- | 'CreateAndStore' is meant to represent building a transaction -- from a single number and presenting a function to carry out the -- needed side effects. -- This type alias is only used in "Cardano.Benchmarking.Wallet". -type CreateAndStore m era = L.Coin -> (Exp.TxOut (LedgerEra era), TxIx -> TxId -> m ()) +type CreateAndStore m era = L.Coin -> (Exp.TxOut (ShelleyLedgerEra era), TxIx -> TxId -> m ()) -- | 'CreateAndStoreList' is meant to represent building a transaction -- and presenting a function to carry out the needed side effects. -- This type alias is also only used in "Cardano.Benchmarking.Wallet". -- The @split@ parameter seems to actually be used for not much more -- than lists and records containing lists. -type CreateAndStoreList m era split = split -> ([Exp.TxOut (LedgerEra era)], TxId -> m ()) +type CreateAndStoreList m era split = split -> ([Exp.TxOut (ShelleyLedgerEra era)], TxId -> m ()) -- TODO: 'sourceToStoreTransaction' et al need to be broken up @@ -150,41 +152,44 @@ sourceTransactionPreview txGenerator inputFunds valueSplitter toStore = split = valueSplitter $ map getFundCoin inputFunds (outputs, _) = toStore split --- | 'genTx' builds a signed transaction using the experimental API. +-- | Build and sign a transaction with 'Cardano.Api.Compatible.Tx.createCompatibleTx'. +-- Rewrapping the resulting 'Tx' as 'Exp.SignedTx' is zero-cost: both wrap +-- the same ledger 'L.Tx'. -- The @txGenerator@ arguments of the rest of the functions in this -- module are all partial applications of this to its first 5 arguments. -- The 7th argument comes from 'TxGenerator' being a type alias -- for a function type -- of two arguments. -genTx :: - Era era +genTx :: forall era. + ShelleyBasedEra era -> LedgerProtocolParameters era -> ([TxIn], [Fund]) -> L.Coin -> TxMetadataInEra era -> TxGenerator era -genTx era (LedgerProtocolParameters pparams) (collateralIns, collFunds) fee metadata inFunds outputs = - obtainCommonConstraints era $ do +genTx sbe (LedgerProtocolParameters pparams) (collateralIns, collFunds) fee metadata inFunds outputs = + shelleyBasedEraConstraints sbe $ do let allKeys = mapMaybe getFundKey $ inFunds ++ collFunds - expInputs = map (\f -> (getFundTxIn f, AnyKeyWitnessPlaceholder)) inFunds - expMetadata = case metadata of - TxMetadataNone -> mempty - TxMetadataInEra _ m -> m - txBodyContent = - Exp.defaultTxBodyContent - & Exp.setTxIns expInputs - & Exp.setTxInsCollateral collateralIns - & Exp.setTxOuts outputs - & Exp.setTxFee fee - & Exp.setTxMetadata expMetadata - & Exp.setTxProtocolParams pparams - unsignedTx <- first (\err -> TxGenError $ "genTx: " ++ show err) $ makeUnsignedTx era txBodyContent - let witVKeys = [makeKeyWitness era unsignedTx (WitnessPaymentKey key) | key <- allKeys] - let tx = signTx era [] witVKeys unsignedTx + expInputs :: [(TxIn, AnyWitness (ShelleyLedgerEra era))] + expInputs = map (\f -> (getFundTxIn f, getFundWitness f)) inFunds + bodyContent = (defaultCompatibleTxBodyContent sbe) + { compatibleTxIns = expInputs + , compatibleTxOuts = outputs + , compatibleTxFee = fee + , compatibleTxInsCollateral = collateralIns + , compatibleTxProtocolParams = Just pparams + , compatibleTxMetadata = metadata + } + unsignedTx@(ShelleyTx _ unsignedLedgerTx) <- + first (\err -> TxGenError $ "genTx: " ++ show (err :: CompatibleTxError)) $ + createCompatibleTx sbe bodyContent + let ledgerBody = unsignedLedgerTx ^. Ledger.bodyTxL + witVKeys = [makeShelleyKeyWitness' sbe ledgerBody (WitnessPaymentKey key) | key <- allKeys] + ShelleyTx _ signedLedgerTx = Compatible.addWitnesses witVKeys unsignedTx + tx = SignedTx signedLedgerTx Right (tx, txIdFromSignedTx tx) - -txSizeInBytes :: forall era. IsEra era => +txSizeInBytes :: forall era. IsShelleyBasedEra era => SignedTx era -> Int -txSizeInBytes tx - = obtainCommonConstraints (useEra @era) $ BS.length $ serialiseToRawBytes tx +txSizeInBytes tx@(SignedTx _) + = BS.length $ serialiseToRawBytes tx diff --git a/bench/tx-generator/src/Cardano/TxGenerator/Types.hs b/bench/tx-generator/src/Cardano/TxGenerator/Types.hs index 8bb7ade4959..1fe548b21e5 100644 --- a/bench/tx-generator/src/Cardano/TxGenerator/Types.hs +++ b/bench/tx-generator/src/Cardano/TxGenerator/Types.hs @@ -14,7 +14,6 @@ module Cardano.TxGenerator.Types where import Cardano.Api -import Cardano.Api.Experimental (LedgerEra) import qualified Cardano.Api.Experimental.Tx as Exp import qualified Cardano.Ledger.Coin as L @@ -37,7 +36,7 @@ type TxAdditionalSize = Int type TPSRate = Double -type TxGenerator era = [Fund] -> [Exp.TxOut (LedgerEra era)] -> Either TxGenError (Exp.SignedTx era, TxId) +type TxGenerator era = [Fund] -> [Exp.TxOut (ShelleyLedgerEra era)] -> Either TxGenError (Exp.SignedTx era, TxId) type FundSource m = m (Either TxGenError [Fund]) type FundToStore m = Fund -> m () diff --git a/bench/tx-generator/src/Cardano/TxGenerator/UTxO.hs b/bench/tx-generator/src/Cardano/TxGenerator/UTxO.hs index 7d5cca55cbd..c7a4c23e614 100644 --- a/bench/tx-generator/src/Cardano/TxGenerator/UTxO.hs +++ b/bench/tx-generator/src/Cardano/TxGenerator/UTxO.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE MonoLocalBinds #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeApplications #-} @@ -7,21 +8,22 @@ module Cardano.TxGenerator.UTxO where import Cardano.Api hiding (txId) -import Cardano.Api.Experimental (AnyWitness (..), IsEra, LedgerEra, - obtainCommonConstraints, useEra) +import Cardano.Api.Experimental (AnyWitness (..)) import qualified Cardano.Api.Experimental.Tx as Exp -import Cardano.Ledger.Api.Tx.Out (datumTxOutL) +import Cardano.Ledger.Api.Tx.Out (dataHashTxOutL, datumTxOutL) +import Cardano.Ledger.BaseTypes (StrictMaybe (..)) import qualified Cardano.Ledger.Coin as L import Cardano.Ledger.Core (mkCoinTxOut) +import qualified Cardano.Ledger.Core as Ledger (TxOut) import qualified Cardano.Ledger.Plutus.Data as Plutus import Cardano.TxGenerator.Fund (Fund (..), FundInEra (..)) import Cardano.TxGenerator.Utils (keyAddress) import Lens.Micro ((&), (.~)) -type ToUTxO era = L.Coin -> (Exp.TxOut (LedgerEra era), TxIx -> TxId -> Fund) -type ToUTxOList era split = split -> ([Exp.TxOut (LedgerEra era)], TxId -> [Fund]) +type ToUTxO era = L.Coin -> (Exp.TxOut (ShelleyLedgerEra era), TxIx -> TxId -> Fund) +type ToUTxOList era split = split -> ([Exp.TxOut (ShelleyLedgerEra era)], TxId -> [Fund]) makeToUTxOList :: [ ToUTxO era ] -> ToUTxOList era [ L.Coin ] @@ -33,11 +35,11 @@ makeToUTxOList fkts values = let (o, f ) = toUTxO value in (o, f idx) -mkUTxOVariant :: forall era. IsEra era +mkUTxOVariant :: forall era. IsShelleyBasedEra era => NetworkId -> SigningKey PaymentKey -> ToUTxO era -mkUTxOVariant networkId key value = obtainCommonConstraints (useEra @era) $ +mkUTxOVariant networkId key value = shelleyBasedEraConstraints (shelleyBasedEra @era) $ let mkTxOut v = Exp.TxOut $ mkCoinTxOut (toShelleyAddr $ keyAddress @era networkId key) v mkNewFund :: L.Coin -> TxIx -> TxId -> Fund @@ -50,13 +52,18 @@ mkUTxOVariant networkId key value = obtainCommonConstraints (useEra @era) $ in (mkTxOut value, mkNewFund value) -- to be merged with mkUTxOVariant +-- | Plutus-locked UTxOs need at least Alonzo. +-- Alonzo 'TxOut' only has a bare datum hash field ('dataHashTxOutL'). +-- Babbage onwards has the richer 'Datum' field ('datumTxOutL'), which also +-- supports inline datums. +-- 'setDatum' below picks the right lens for the concrete era. mkUTxOScript :: forall era. - IsEra era - => NetworkId + AlonzoEraOnwards era + -> NetworkId -> (ScriptInAnyLang, ScriptData) - -> AnyWitness era + -> AnyWitness (ShelleyLedgerEra era) -> ToUTxO era -mkUTxOScript networkId (script, txOutDatum) witness value = obtainCommonConstraints (useEra @era) $ +mkUTxOScript alonzoOnwards networkId (script, txOutDatum) witness value = alonzoEraOnwardsConstraints alonzoOnwards $ let plutusScriptAddr = case script of ScriptInAnyLang lang script' -> @@ -67,10 +74,15 @@ mkUTxOScript networkId (script, txOutDatum) witness value = obtainCommonConstrai networkId (PaymentCredentialByScript $ hashScript script') NoStakeAddress - datumHash :: Plutus.Datum (LedgerEra era) - datumHash = Plutus.DatumHash $ Plutus.hashData $ toAlonzoData @(LedgerEra era) $ unsafeHashableScriptData txOutDatum + dataHash = Plutus.hashData $ toAlonzoData @(ShelleyLedgerEra era) $ unsafeHashableScriptData txOutDatum + setDatum :: Ledger.TxOut (ShelleyLedgerEra era) -> Ledger.TxOut (ShelleyLedgerEra era) + setDatum = case alonzoOnwards of + AlonzoEraOnwardsAlonzo -> dataHashTxOutL .~ SJust dataHash + AlonzoEraOnwardsBabbage -> datumTxOutL .~ Plutus.DatumHash dataHash + AlonzoEraOnwardsConway -> datumTxOutL .~ Plutus.DatumHash dataHash + AlonzoEraOnwardsDijkstra -> datumTxOutL .~ Plutus.DatumHash dataHash mkTxOut v = Exp.TxOut $ - mkCoinTxOut (toShelleyAddr plutusScriptAddr) v & datumTxOutL .~ datumHash + mkCoinTxOut (toShelleyAddr plutusScriptAddr) v & setDatum mkNewFund :: L.Coin -> TxIx -> TxId -> Fund mkNewFund val txIx txId = Fund $ InAnyCardanoEra (cardanoEra @era) $ FundInEra { _fundTxIn = TxIn txId txIx diff --git a/bench/tx-generator/src/Cardano/TxGenerator/Utils.hs b/bench/tx-generator/src/Cardano/TxGenerator/Utils.hs index b7655c17c36..741fce1b13c 100644 --- a/bench/tx-generator/src/Cardano/TxGenerator/Utils.hs +++ b/bench/tx-generator/src/Cardano/TxGenerator/Utils.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE GADTs #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE ScopedTypeVariables #-} @@ -12,7 +13,7 @@ module Cardano.TxGenerator.Utils where import Cardano.Api as Api -import Cardano.Api.Experimental (IsEra, SignedTx (..), obtainCommonConstraints, useEra) +import Cardano.Api.Experimental (SignedTx (..)) import qualified Cardano.Api.Parser.Text as P import qualified Cardano.Ledger.Coin as L @@ -75,9 +76,9 @@ txIdFromSignedTx (SignedTx tx) = -- | `mkTxInModeCardano` never uses the `TxInByronSpecial` constructor -- because its type enforces it being a Shelley-based era. -mkTxInModeCardano :: forall era. IsEra era => SignedTx era -> TxInMode +mkTxInModeCardano :: forall era. IsShelleyBasedEra era => SignedTx era -> TxInMode mkTxInModeCardano (SignedTx tx) = - obtainCommonConstraints (useEra @era) $ TxInMode shelleyBasedEra (ShelleyTx shelleyBasedEra tx) + TxInMode (shelleyBasedEra @era) (ShelleyTx (shelleyBasedEra @era) tx) -- | Convert text representation of a txin "hash#txid" to a TxIn e.g. "dbaff4e270cfb55612d9e2ac4658a27c79da4a5271c6f90853042d1403733810#0" -- Partial. Useful in tests. diff --git a/bench/tx-generator/test/Main.hs b/bench/tx-generator/test/Main.hs index c8c0c539bcb..86fe1083730 100644 --- a/bench/tx-generator/test/Main.hs +++ b/bench/tx-generator/test/Main.hs @@ -24,9 +24,20 @@ tests = testGroup "cardano-tx-generator" sizedMetadata :: TestTree sizedMetadata = testGroup "properties of the CBOR encoding relevant for generating sized metadat" - [ testCase "Conway metadata map costs" $ assertBool "metadata map costs" prop_mapCostsConway + [ testCase "Shelley metadata map costs" $ assertBool "metadata map costs" prop_mapCostsShelley + , testCase "Shelley metadata ByteString costs" $ assertBool "metadata ByteString costs" prop_bsCostsShelley + , testCase "Allegra metadata map costs" $ assertBool "metadata map costs" prop_mapCostsAllegra + , testCase "Allegra metadata ByteString costs" $ assertBool "metadata ByteString costs" prop_bsCostsAllegra + , testCase "Mary metadata map costs" $ assertBool "metadata map costs" prop_mapCostsMary + , testCase "Mary metadata ByteString costs" $ assertBool "metadata ByteString costs" prop_bsCostsMary + , testCase "Alonzo metadata map costs" $ assertBool "metadata map costs" prop_mapCostsAlonzo + , testCase "Alonzo metadata ByteString costs" $ assertBool "metadata ByteString costs" prop_bsCostsAlonzo + , testCase "Babbage metadata map costs" $ assertBool "metadata map costs" prop_mapCostsBabbage + , testCase "Babbage metadata ByteString costs" $ assertBool "metadata ByteString costs" prop_bsCostsBabbage + , testCase "Conway metadata map costs" $ assertBool "metadata map costs" prop_mapCostsConway , testCase "Conway metadata ByteString costs" $ assertBool "metadata ByteString costs" prop_bsCostsConway - -- TODO: enable when cardano-api implements makeUnsignedTx for Dijkstra + -- TODO: enable when cardano-api's shelleyBasedEraConstraints supports Dijkstra + -- (the compatible transaction path errors at runtime there until then) -- , testCase "Dijkstra metadata map costs" $ assertBool "metadata map costs" prop_mapCostsDijkstra -- , testCase "Dijkstra metadata ByteString costs" $ assertBool "metadata ByteString costs" prop_bsCostsDijkstra ] diff --git a/cardano-node-chairman/app/Cardano/Chairman.hs b/cardano-node-chairman/app/Cardano/Chairman.hs index 9412de65f6e..e1576f7b56d 100644 --- a/cardano-node-chairman/app/Cardano/Chairman.hs +++ b/cardano-node-chairman/app/Cardano/Chairman.hs @@ -15,6 +15,7 @@ import Cardano.Api import Cardano.Ledger.BaseTypes (unNonZero) import Ouroboros.Consensus.Block.Abstract +import Ouroboros.Consensus.Config.SecurityParam import Ouroboros.Network.AnchoredFragment (Anchor, AnchoredFragment) import qualified Ouroboros.Network.AnchoredFragment as AF import qualified Ouroboros.Network.Block as Block diff --git a/cardano-testnet/src/Testnet/Runtime.hs b/cardano-testnet/src/Testnet/Runtime.hs index 1db6f5aae7c..a4fd23ce709 100644 --- a/cardano-testnet/src/Testnet/Runtime.hs +++ b/cardano-testnet/src/Testnet/Runtime.hs @@ -510,9 +510,9 @@ startLedgerNewEpochStateLogging testnetRuntime tmpWorkspace = withFrozenCallStac -> SlotNo -> BlockNo -> StateT (Maybe AnyNewEpochState) IO ConditionResult - handler outputFp diffFp anes@(AnyNewEpochState !sbe !nes _) _ (BlockNo blockNo') = handleException $ do + handler outputFp diffFp anes@(AnyNewEpochState !sbe !nes _) _ (BlockNo blockNumber) = handleException $ do let prettyNes = shelleyBasedEraConstraints sbe (encodePretty nes) - blockLabel = "#### BLOCK " <> show blockNo' <> " ####" + blockLabel = "#### BLOCK " <> show blockNumber <> " ####" liftIOAnnotated . BSC.appendFile outputFp $ BSC.unlines [BSC.pack blockLabel, prettyNes, ""] -- store epoch state for logging of differences diff --git a/cardano-testnet/src/Testnet/Start/Cardano.hs b/cardano-testnet/src/Testnet/Start/Cardano.hs index 6fac9044827..01e3e11e1ff 100644 --- a/cardano-testnet/src/Testnet/Start/Cardano.hs +++ b/cardano-testnet/src/Testnet/Start/Cardano.hs @@ -463,9 +463,9 @@ cardanoTestnet QuickValidation (EpochNo maxBound) minBound - $ \_ slotNo blockNo' -> do + $ \_ slotNo blockNumber -> do put slotNo - pure $ if blockNo' >= 1 + pure $ if blockNumber >= 1 then ConditionMet -- we got one block else ConditionNotMet diff --git a/cardano-testnet/test/cardano-testnet-test/Cardano/Testnet/Test/FoldEpochState.hs b/cardano-testnet/test/cardano-testnet-test/Cardano/Testnet/Test/FoldEpochState.hs index 122117d069f..bda8847c8cf 100644 --- a/cardano-testnet/test/cardano-testnet-test/Cardano/Testnet/Test/FoldEpochState.hs +++ b/cardano-testnet/test/cardano-testnet-test/Cardano/Testnet/Test/FoldEpochState.hs @@ -44,8 +44,8 @@ prop_foldEpochState = integrationRetryWorkspace 2 "foldEpochState" $ \tempAbsBas -> SlotNo -> BlockNo -> StateT [(SlotNo, BlockNo)] IO ConditionResult - handler _ slotNo blockNo' = do - modify ((slotNo, blockNo'):) + handler _ slotNo blockNumber = do + modify ((slotNo, blockNumber):) s <- get if length s >= 10 then pure ConditionMet diff --git a/cardano-testnet/test/cardano-testnet-test/Cardano/Testnet/Test/Rpc/Query.hs b/cardano-testnet/test/cardano-testnet-test/Cardano/Testnet/Test/Rpc/Query.hs index a8f5c8676be..5fcb6122dfe 100644 --- a/cardano-testnet/test/cardano-testnet-test/Cardano/Testnet/Test/Rpc/Query.hs +++ b/cardano-testnet/test/cardano-testnet-test/Cardano/Testnet/Test/Rpc/Query.hs @@ -82,9 +82,9 @@ hprop_rpc_query_pparams = integrationRetryWorkspace 2 "rpc-query-pparams" $ \tem ---------- QueryTipLocalStateOutput{localStateChainTip} <- H.noteShowM $ execCliStdoutToJson execConfig [eraName, "query", "tip"] - (slot, blockHash', blockNo') <- case localStateChainTip of + (slot, blockHash, blockNumber) <- case localStateChainTip of ChainTipAtGenesis -> H.failure -- impossible - ChainTip (SlotNo slot) (HeaderHash hash) (BlockNo blockNo') -> pure (slot, SBS.fromShort hash, blockNo') + ChainTip (SlotNo slot) (HeaderHash hash) (BlockNo blockNumber) -> pure (slot, SBS.fromShort hash, blockNumber) ----------------------------------- -- Compute expected tip timestamp @@ -121,8 +121,8 @@ hprop_rpc_query_pparams = integrationRetryWorkspace 2 "rpc-query-pparams" $ \tem -- Test readParams response --------------------------- pparamsResponse ^. U5c.ledgerTip . U5c.slot === slot - pparamsResponse ^. U5c.ledgerTip . U5c.hash === blockHash' - pparamsResponse ^. U5c.ledgerTip . U5c.height === blockNo' + pparamsResponse ^. U5c.ledgerTip . U5c.hash === blockHash + pparamsResponse ^. U5c.ledgerTip . U5c.height === blockNumber H.assertWithinTolerance (pparamsResponse ^. U5c.ledgerTip . U5c.timestamp) expectedTimestampMs 1000 -- https://docs.cardano.org/about-cardano/explore-more/parameter-guide From 4d5ee52f081e74fdf353841846ddea329c6ea72d Mon Sep 17 00:00:00 2001 From: Mateusz Galazyn Date: Wed, 5 Aug 2026 22:52:05 +0200 Subject: [PATCH 3/4] workbench: pass supervisord config explicitly to every supervisorctl call supervisord is launched with an explicit --config, but all other supervisorctl invocations relied on the client's default config search path, which only works when no /etc/supervisord.conf exists: both client and server then fall back to the same localhost:9001 default. On a host where /etc/supervisord.conf exists, supervisorctl either fails outright ("could not read config file" when unreadable) or silently targets the wrong server (e.g. unix:///run/supervisor.sock). Pass -c "$dir"/supervisor/supervisord.conf at all 12 call sites. --- nix/workbench/backend/supervisor.sh | 26 +++++++++++++------------- 1 file changed, 13 insertions(+), 13 deletions(-) diff --git a/nix/workbench/backend/supervisor.sh b/nix/workbench/backend/supervisor.sh index d9176bf0834..481e0b4f8a9 100755 --- a/nix/workbench/backend/supervisor.sh +++ b/nix/workbench/backend/supervisor.sh @@ -140,7 +140,7 @@ EOF local dir=${1:?$usage}; shift local node=${1:?$usage}; shift - supervisorctl start $node + supervisorctl -c "$dir"/supervisor/supervisord.conf start $node backend_supervisor wait-node "$dir" $node backend_supervisor save-child-pids "$dir" ;; @@ -150,7 +150,7 @@ EOF local dir=${1:?$usage}; shift local node=${1:?$usage}; shift - supervisorctl stop $node + supervisorctl -c "$dir"/supervisor/supervisord.conf stop $node ;; wait-node ) @@ -185,10 +185,10 @@ EOF if test -n "$honor_autostart" then for node in ${nodes[*]} do jqtest ".\"$node\".autostart" "$dir"/node-specs.json && - supervisorctl start $node & + supervisorctl -c "$dir"/supervisor/supervisord.conf start $node & done wait - else supervisorctl start ${nodes[*]}; fi + else supervisorctl -c "$dir"/supervisor/supervisord.conf start ${nodes[*]}; fi for node in ${nodes[*]} do jqtest ".\"$node\".autostart" "$dir"/node-specs.json && @@ -228,7 +228,7 @@ EOF true else if jqtest '.node.tracing_backend == "trace-dispatcher"' "$dir"/profile.json - then if ! supervisorctl start tracer + then if ! supervisorctl -c "$dir"/supervisor/supervisord.conf start tracer then progress "supervisor" "$(red fatal: failed to start) $(white cardano-tracer)" echo "$(red config.json) -------------------------------------" >&2 cat "$dir"/tracer/config.json @@ -264,7 +264,7 @@ EOF * ) break;; esac; shift; done ls -l $dir/{tracer/tracer,node-{0,1}/node}.socket || true - if ! supervisorctl start healthcheck + if ! supervisorctl -c "$dir"/supervisor/supervisord.conf start healthcheck then progress "supervisor" "$(red fatal: failed to start) $(white healthcheck)" echo "$(red healthcheck stdout) -----------------------------------" >&2 cat "$dir"/healthcheck/stdout @@ -285,7 +285,7 @@ EOF * ) break;; esac; shift; done ls -l $dir/{tracer/tracer,node-{0,1}/node}.socket || true - if ! supervisorctl start generator + if ! supervisorctl -c "$dir"/supervisor/supervisord.conf start generator then progress "supervisor" "$(red fatal: failed to start) $(white generator)" echo "$(red run-script.json) ------------------------------------" >&2 cat "$dir"/generator/run-script.json @@ -308,7 +308,7 @@ EOF --* ) msg "FATAL: unknown flag '$1'"; usage_supervisor;; * ) break;; esac; shift; done - if ! supervisorctl start "${workload}" + if ! supervisorctl -c "$dir"/supervisor/supervisord.conf start "${workload}" then progress "supervisor" "$(red fatal: failed to start) $(white "${workload} workload")" echo "$(red "${workload}" workload stdout) ----------------------" >&2 cat "$dir"/workloads/"${workload}"/stdout @@ -326,7 +326,7 @@ EOF progress_ne "supervisor" "waiting until $node stops: ....." local i=0 - while supervisorctl status $node > /dev/null + while supervisorctl -c "$dir"/supervisor/supervisord.conf status $node > /dev/null do echo -ne "\b\b\b\b\b"; printf "%5d" $i >&2; i=$((i+1)); sleep 1 done >&2 echo -e "\b\b\b\b\bdone, after $(with_color white $i) seconds" >&2 @@ -344,7 +344,7 @@ EOF while \ ! test -f "${dir}"/flag/cluster-stopping \ && \ - supervisorctl status "node-${pool_ix}" > /dev/null + supervisorctl -c "${dir}"/supervisor/supervisord.conf status "node-${pool_ix}" > /dev/null do echo -ne "\b\b\b\b\b\b" printf "%6d" "$(($(date +%s) - start_time))" @@ -378,7 +378,7 @@ EOF while \ ! test -f "${dir}"/flag/cluster-stopping \ && \ - supervisorctl status "${workload}" > /dev/null + supervisorctl -c "${dir}"/supervisor/supervisord.conf status "${workload}" > /dev/null do echo -ne "\b\b\b\b\b\b" printf "%6d" "$(($(date +%s) - start_time))" @@ -405,7 +405,7 @@ EOF local usage="USAGE: wb backend $op RUN-DIR" local dir=${1:?$usage}; shift - supervisorctl stop all || true + supervisorctl -c "$dir"/supervisor/supervisord.conf stop all || true ;; fetch-logs ) @@ -459,7 +459,7 @@ EOF for node in $(jq_tolist keys "$dir"/node-specs.json) do ## supervisord's service PID is the immediately invoked binary, ## ..which isn't necessarily 'cardano-node', but could be 'time' or 'cabal' or.. - local service_pid=$(supervisorctl pid $node) + local service_pid=$(supervisorctl -c "$dir"/supervisor/supervisord.conf pid $node) if test $service_pid = '0' then continue elif test -z "$(pgrep -P $service_pid)" ## Any children? From b4c956ce2c7e6db97eeac0e7342bdc33ce3a5a4e Mon Sep 17 00:00:00 2001 From: Mateusz Galazyn Date: Thu, 13 Aug 2026 18:01:05 +0200 Subject: [PATCH 4/4] REMOVEME: SRP --- cabal.project | 27 +++++++++++++++++++++++++++ 1 file changed, 27 insertions(+) diff --git a/cabal.project b/cabal.project index 4d153d34c86..46ce2c7399d 100644 --- a/cabal.project +++ b/cabal.project @@ -78,6 +78,11 @@ package cardano-diffusion package plutus-scripts-bench haddock-options: "--optghc=-fplugin-opt=PlutusTx.Plugin:defer-errors" +-- new Cardano.Api re-exports blockNo, shadowed by local bindings in cardano-rpc +-- TODO remove after cardano-rpc upgrade +package cardano-rpc + ghc-options: -Wno-name-shadowing + -- There is a suspected bug in `cabal` (https://github.com/haskell/cabal/issues/11663) -- that can be worked around with the following allow-newer stanzas allow-newer: @@ -166,3 +171,25 @@ if impl(ghc >= 9.14) -- Do NOT add more source-repository-package stanzas here unless they are strictly -- temporary! Please read the section in CONTRIBUTING about updating dependencies. +source-repository-package + type: git + location: https://github.com/input-output-hk/cardano-api.git + tag: 26aaf4a878a46bf398a2e88e8bd88f307dd20587 + --sha256: sha256-yiKKAY4Uru3nAJBeZy/c3kES8vwcq/vU3xSPx2Z4+i8= + subdir: + cardano-api + +source-repository-package + type: git + location: https://github.com/input-output-hk/cardano-cli.git + tag: 92790ca0733aa942d0977ebb91d361d0b8fd30e3 + --sha256: sha256-EBBP8luu1Q72hiTJ5suuKZKKHBLGv3I8bdQce/2j68E= + subdir: + cardano-cli + +constraints: + -- TODO: remove once cardano-api (SRP pin) is past fa0d44832 ("Remove redundant orphan + -- typeclass instances"): cardano-data 1.3.1.0 added its own ToJSON instances for + -- Data.Map.NonEmpty/Data.Set.NonEmpty, which clash with cardano-api 11.3's orphans. + , cardano-data <1.3.1 +