diff --git a/.gitignore b/.gitignore index fa56a0bd882..2a5afd35786 100644 --- a/.gitignore +++ b/.gitignore @@ -77,3 +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 d24d51f99ff..5c601f03e51 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,7 +12,22 @@ {-# 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 qualified Cardano.Ledger.Plutus.Language as L (PlutusLanguage, Plutus (..), PlutusBinary (..), + SLanguage (..), decodePlutusRunnable) import Cardano.Benchmarking.Compiler (keyBenchmarkInputs) import Cardano.Benchmarking.GeneratorTx.SizedMetadata (mkMetadata) @@ -19,21 +36,22 @@ import Cardano.Benchmarking.PlutusScripts (listPlutusScripts) #endif 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 +175,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 +218,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 +513,76 @@ 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 = TxOut (keyAddress (Testnet (NetworkMagic 42)) keyBenchmarkInputs) (lovelaceToTxOutValue shelleyBasedEra 1_000_000) TxOutDatumNone ReferenceScriptNone + + -- 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 [Exp.TxOut $ toShelleyTxOutAny shelleyBasedEra 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 :: Tx ConwayEra + dummyTx = + case signTx era [] [witVKey] unsignedTx of + SignedTx signedLedgerTx -> ShelleyTx shelleyBasedEra signedLedgerTx - -- 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..080c6a557a7 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,32 @@ 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 $ serialiseToCBOR 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 :: Tx era + dummyTx = obtainCommonConstraints era $ + case signTx era [] [] unsignedTx of + SignedTx signedLedgerTx -> ShelleyTx shelleyBasedEra signedLedgerTx + 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/SubmissionClient.hs b/bench/tx-generator/src/Cardano/Benchmarking/GeneratorTx/SubmissionClient.hs index 3efa975616e..3803b07d01c 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 #-} @@ -12,6 +11,7 @@ {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeApplications #-} {-# LANGUAGE UndecidableInstances #-} {-# OPTIONS_GHC -Wno-unticked-promoted-constructors #-} @@ -25,15 +25,17 @@ module Cardano.Benchmarking.GeneratorTx.SubmissionClient ) where import Cardano.Api hiding (Active) +import Cardano.Api.Experimental (IsEra, obtainCommonConstraints, useEra) 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 (txIdFromTx) 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 Ouroboros.Consensus.Shelley.Eras (StandardCrypto) @@ -83,7 +85,7 @@ type EndOfProtocolCallback m = SubmissionThreadStats -> m () txSubmissionClient :: forall m era. ( MonadIO m, MonadFail m - , IsShelleyBasedEra era + , IsEra era ) => Trace m NodeToNodeSubmissionTrace -> Trace m (TraceBenchTxSubmit TxId) @@ -102,7 +104,7 @@ 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 (txIdFromTx <$> acked) return (txSource, UnAcked stillUnacked, newStats) queueNewTxs :: [Tx era] -> LocalState era -> LocalState era @@ -131,8 +133,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 (txIdFromTx <$> newTxs) + traceWith bmtr $ SubmissionClientUnAcked (txIdFromTx <$> outs) case blocking of SingBlocking -> case NE.nonEmpty newTxs of @@ -156,12 +158,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 = txIdFromTx <$> ua + (toSend, _retained) = L.partition ((`L.elem` reqTxIds) . txIdFromTx) ua missIds = reqTxIds L.\\ uaIds traceWith tr $ TxList (length toSend) - traceWith bmtr $ SubmissionClientUnAcked (getTxId . getTxBody <$> ua) + traceWith bmtr $ SubmissionClientUnAcked (txIdFromTx <$> ua) traceWith bmtr $ TraceBenchTxSubServReq reqTxIds unless (L.null missIds) $ traceWith bmtr $ TraceBenchTxSubServUnav missIds @@ -180,7 +182,7 @@ txSubmissionClient tr bmtr initialTxSource endOfProtocolCallback = shelleyBasedEraConstraints sbe $ toInteger (tx ^. Ledger.sizeTxF) toGenTx :: Tx era -> GenTx CardanoBlock - toGenTx tx = toConsensusGenTx $ TxInMode shelleyBasedEra tx + toGenTx tx = obtainCommonConstraints (useEra @era) $ toConsensusGenTx $ TxInMode shelleyBasedEra tx fromGenTxId :: GenTxId CardanoBlock -> TxId fromGenTxId (Block.GenTxIdShelley (Mempool.ShelleyTxId i)) = fromShelleyTxId i @@ -189,7 +191,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 592c4fed620..d3c59189e81 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" -} @@ -20,6 +19,7 @@ module Cardano.Benchmarking.Script.Core where import Cardano.Api +import Cardano.Api.Experimental (AnyWitness (..), IsEra (useEra), obtainCommonConstraints) import Cardano.Benchmarking.GeneratorTx as GeneratorTx (AsyncBenchmarkControl) import qualified Cardano.Benchmarking.GeneratorTx as GeneratorTx (waitBenchmark, walletBenchmark) @@ -39,6 +39,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 +66,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 +97,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 +110,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 } @@ -229,16 +226,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 @@ -263,7 +260,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 @@ -282,10 +279,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 -> @@ -317,7 +315,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) @@ -333,7 +331,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) @@ -345,7 +343,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 @@ -354,10 +352,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 + ShelleyTx sbe ledgerTx -> shelleyBasedEraConstraints sbe $ + case toLedgerPParams sbe protocolParameters of + Left{} -> Nothing + Right ledgerPParams -> Just $ + estimateMinFeeTx ledgerPParams ledgerTx (inputs + 1) 0 0 -- 1 key witness per tx input + 1 collateral 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 @@ -371,34 +371,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 @@ -409,8 +404,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 @@ -426,10 +421,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 @@ -504,19 +499,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/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/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 d15f80a3a38..fcd121a6bc2 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,6 +20,9 @@ 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 qualified Cardano.Ledger.Coin as L import Cardano.Ledger.Shelley.API (Addr (..)) @@ -28,7 +31,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) @@ -38,7 +41,7 @@ genesisValidate :: ShelleyGenesis -> Either String () genesisValidate = validateGenesis -genesisSecureInitialFund :: forall era. IsShelleyBasedEra era => +genesisSecureInitialFund :: forall era. IsEra era => NetworkId -> ShelleyGenesis -> SigningKey PaymentKey @@ -46,15 +49,15 @@ genesisSecureInitialFund :: forall era. IsShelleyBasedEra era => -> TxGenTxParams -> Either TxGenError (Tx era, Fund) genesisSecureInitialFund networkId genesis srcKey destKey TxGenTxParams{txParamFee, txParamTTL} - = case genesisInitialFundForKey @era networkId genesis srcKey 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 - where - destAddr = keyAddress @era networkId destKey + = obtainCommonConstraints (useEra @era) $ + case genesisInitialFundForKey @era networkId genesis srcKey of + Nothing -> Left $ TxGenError "genesisSecureInitialFund: no fund found for given key in genesis" + Just (_, lovelace) -> + let + txOutValue :: TxOutValue era + txOutValue = lovelaceToTxOutValue shelleyBasedEra $ lovelace - txParamFee + destAddress = keyAddress @era networkId destKey + in genesisExpenditure networkId srcKey destAddress txOutValue txParamFee txParamTTL destKey genesisInitialFunds :: forall era. IsShelleyBasedEra era => NetworkId @@ -88,8 +91,8 @@ genesisTxInput networkId . getVerificationKey . castKey -genesisExpenditure :: - IsShelleyBasedEra era +genesisExpenditure :: forall era. + IsEra era => NetworkId -> SigningKey PaymentKey -> AddressInEra era @@ -99,39 +102,42 @@ genesisExpenditure :: -> SigningKey PaymentKey -> Either TxGenError (Tx 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 tx)) + $ mkGenesisTransaction era (castKey inputKey) ttl fee [pseudoTxIn] + [Exp.TxOut $ toShelleyTxOutAny shelleyBasedEra txout] where - eTx = mkGenesisTransaction (castKey inputKey) ttl fee [pseudoTxIn] [txout] + era = useEra @era txout = TxOut addr value TxOutDatumNone ReferenceScriptNone pseudoTxIn = genesisTxInput networkId inputKey fund tx = FundInEra { - _fundTxIn = TxIn (getTxId $ getTxBody tx) (TxIx 0) - , _fundWitness = KeyWitness KeyWitnessForSpending + _fundTxIn = TxIn (txIdFromTx tx) (TxIx 0) + , _fundWitness = AnyKeyWitnessPlaceholder , _fundVal = value , _fundSigningKey = Just outputKey } -mkGenesisTransaction :: forall era . - IsShelleyBasedEra era - => SigningKey GenesisUTxOKey +mkGenesisTransaction :: + Era era + -> SigningKey GenesisUTxOKey -> SlotNo -> L.Coin -> [TxIn] - -> [TxOut CtxTx era] + -> [Exp.TxOut (LedgerEra 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) +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) + case signTx era [] [witVKey] unsignedTx of + SignedTx signedLedgerTx -> Right $ ShelleyTx shelleyBasedEra 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 0aef7befa1e..3caee5155bc 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 (..), 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 (Tx 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 (Tx 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 (Tx 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 (Tx 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..ab574bb98f5 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, 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 (txIdFromTx) 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) @@ -147,45 +150,43 @@ 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 + expOutputs = map (Exp.TxOut . toShelleyTxOutAny shelleyBasedEra) outputs + expMetadata = case metadata of + TxMetadataNone -> mempty + TxMetadataInEra _ m -> m + txBodyContent = + Exp.defaultTxBodyContent + & Exp.setTxIns expInputs + & Exp.setTxInsCollateral collateralIns + & Exp.setTxOuts expOutputs + & 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 = case signTx era [] witVKeys unsignedTx of + SignedTx signedLedgerTx -> ShelleyTx shelleyBasedEra signedLedgerTx + Right (tx, txIdFromTx tx) -txSizeInBytes :: forall era. IsShelleyBasedEra era => +txSizeInBytes :: forall era. IsEra era => Tx era -> Int -txSizeInBytes - = BS.length . serialiseToCBOR +txSizeInBytes tx + = obtainCommonConstraints (useEra @era) $ BS.length $ serialiseToCBOR tx diff --git a/bench/tx-generator/src/Cardano/TxGenerator/UTxO.hs b/bench/tx-generator/src/Cardano/TxGenerator/UTxO.hs index 2b822202059..230af9a09eb 100644 --- a/bench/tx-generator/src/Cardano/TxGenerator/UTxO.hs +++ b/bench/tx-generator/src/Cardano/TxGenerator/UTxO.hs @@ -7,6 +7,7 @@ module Cardano.TxGenerator.UTxO where import Cardano.Api hiding (txId) +import Cardano.Api.Experimental (AnyWitness (..), IsEra, obtainCommonConstraints, useEra) import qualified Cardano.Ledger.Coin as L import Cardano.TxGenerator.Fund (Fund (..), FundInEra (..)) @@ -25,59 +26,52 @@ 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 = 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 = 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 + 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 + } + 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..0041b5226f0 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, 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,16 @@ 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 +txIdFromTx :: Tx era -> TxId +txIdFromTx (ShelleyTx sbe tx) = + shelleyBasedEraConstraints sbe $ 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 => Tx era -> TxInMode +mkTxInModeCardano tx = obtainCommonConstraints (useEra @era) $ TxInMode 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 5ebadb43f08..62ecbfb0a31 100644 --- a/bench/tx-generator/tx-generator.cabal +++ b/bench/tx-generator/tx-generator.cabal @@ -113,28 +113,20 @@ library , cardano-binary , cardano-cli ^>= 11.1 , cardano-crypto-class - , cardano-crypto-wrapper , cardano-data , cardano-diffusion ^>= 1.0 , 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 @@ -158,7 +150,6 @@ library , trace-forward , transformers , transformers-except - , unordered-containers , yaml -- Needed by "Cardano.Api.Internal.ProtocolParameters" port. , either @@ -189,21 +180,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 @@ -223,7 +212,6 @@ test-suite tx-generator-apitest ghc-options: -Wall -rtsopts "-with-rtsopts=-T" - -Wno-deprecations build-depends: base , aeson @@ -234,11 +222,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