From bcca023deff596593b57814b9925613c2af0390a Mon Sep 17 00:00:00 2001 From: Alexey Kuleshevich Date: Thu, 23 Mar 2023 17:20:51 +0300 Subject: [PATCH 01/38] Add `cardano-tracer/cardano-tracer-test` to `.gitignore` --- .gitignore | 3 +++ 1 file changed, 3 insertions(+) diff --git a/.gitignore b/.gitignore index 528a424c5d1..b6e8ffcdee5 100644 --- a/.gitignore +++ b/.gitignore @@ -64,3 +64,6 @@ logs /testnet .vscode/ + +# Test artifacts +cardano-tracer/cardano-tracer-test From 768375b2fd18fff02020d7b88432e5c7f5c54c76 Mon Sep 17 00:00:00 2001 From: Erik de Castro Lopo Date: Wed, 8 Mar 2023 16:20:35 +1100 Subject: [PATCH 02/38] Take all dependecies from Hackage or CHaP This also updates the version of `ledger` for repliminary support for the Conway era. The `network` and `consensus` dependencies are also updated. --- cardano-api/src/Cardano/Api/Fees.hs | 14 ++++++++++++-- 1 file changed, 12 insertions(+), 2 deletions(-) diff --git a/cardano-api/src/Cardano/Api/Fees.hs b/cardano-api/src/Cardano/Api/Fees.hs index 47e62fd373e..e6208cb4a05 100644 --- a/cardano-api/src/Cardano/Api/Fees.hs +++ b/cardano-api/src/Cardano/Api/Fees.hs @@ -527,6 +527,10 @@ evaluateTransactionExecutionUnits systemstart epochInfo bpp utxo txbody = case collateralSupportedInEra $ shelleyBasedToCardanoEra sbe of Just supp -> obtainHasFieldConstraint supp $ evalConway sbe tx' Nothing -> return mempty + ShelleyBasedEraConway -> + case collateralSupportedInEra $ shelleyBasedToCardanoEra era of + Just supp -> obtainHasFieldConstraint supp $ evalConway era tx' + Nothing -> return mempty where LedgerEpochInfo ledgerEpochInfo = epochInfo @@ -593,9 +597,9 @@ evaluateTransactionExecutionUnits systemstart epochInfo bpp utxo txbody = (Map ScriptWitnessIndex (Either ScriptExecutionError ExecutionUnits)) evalConway era tx = do - costModelsArray <- toAlonzoCostModelsArray (protocolParamCostModels (unbundleProtocolParams bpp)) + costModelsArray <- toAlonzoCostModelsArray (protocolParamCostModels pparams) case Alonzo.evaluateTransactionExecutionUnits - (toLedgerPParams era (unbundleProtocolParams bpp)) + (toLedgerPParams era pparams) tx (toLedgerUTxO era utxo) ledgerEpochInfo @@ -1374,6 +1378,12 @@ calculateMinimumUTxO era txout@(TxOut _ v _ _) bpp = minUTxO = Shelley.evaluateMinLovelaceOutput (unbundleLedgerShelleyBasedProtocolParams era bpp) lTxOut val = fromShelleyLovelace minUTxO in Right val + ShelleyBasedEraConway -> + let lTxOut = toShelleyTxOutAny era txout + babPParams = toConwayPParams pparams' + minUTxO = Shelley.evaluateMinLovelaceOutput babPParams lTxOut + val = fromShelleyLovelace minUTxO + in Right val where calcMinUTxOAllegraMary :: Either MinimumUTxOError Lovelace calcMinUTxOAllegraMary = do From c69247a9bc0e529976692261e406b22a0e1531e0 Mon Sep 17 00:00:00 2001 From: Alexey Kuleshevich Date: Wed, 8 Mar 2023 17:00:37 +0300 Subject: [PATCH 03/38] Update bounds and dependencies --- cabal.project | 61 +++++++++++++++++++ cardano-api/cardano-api.cabal | 60 +++++++++--------- cardano-cli/cardano-cli.cabal | 30 ++++----- cardano-client-demo/cardano-client-demo.cabal | 4 +- cardano-node/cardano-node.cabal | 16 ++--- cardano-submit-api/cardano-submit-api.cabal | 4 +- 6 files changed, 117 insertions(+), 58 deletions(-) diff --git a/cabal.project b/cabal.project index 97971e8fd63..b70980acb71 100644 --- a/cabal.project +++ b/cabal.project @@ -108,3 +108,64 @@ allow-newer: -- IMPORTANT -- Do NOT add more source-repository-package stanzas here unless they are strictly -- temporary! Please read the section in CONTRIBUTING about updating dependencies. + +-- And has the adjustments for the ledger refactor +source-repository-package + type: git + location: https://github.com/input-output-hk/ouroboros-network + tag: 321472170618560f56565c2459e3ac0892b1fe2e + --sha256: 1i5h28ris135b6gi94y1ccnf80bkhhjxhsvncngpsxmbz2dl7rdj + subdir: + monoidal-synchronisation + network-mux + ouroboros-consensus + ouroboros-consensus-byron + ouroboros-consensus-cardano + ouroboros-consensus-protocol + ouroboros-consensus-shelley + ouroboros-network + ouroboros-network-framework + ouroboros-network-testing + ouroboros-consensus-cardano-tools + +-- Waiting for proper Windows ghc-9.2 release. +source-repository-package + type: git + location: https://github.com/input-output-hk/snap-core + tag: b87b2ffa52bf58867a7239ebe74f61b1a2c762d2 + --sha256: 0ndm57z5zpxd5n8s47kh8k1jfqf3b78qv7gkgrx9wwaajs9bf196 + +-- source-repository-package +-- type: git +-- location: https://github.com/input-output-hk/cardano-ledger +-- tag: 66b1490467b512bab88552f7c2bb7f36d6adfa53 +-- --sha256: 1y3x0nz0bcndhwdn1h4qgxjmgvymy0in6rs3nvy4avz8hrij7rj9 +-- subdir: +-- eras/alonzo/impl +-- eras/alonzo/test-suite +-- eras/allegra/impl +-- eras/babbage/impl +-- eras/babbage/test-suite +-- eras/byron/chain/executable-spec +-- eras/byron/crypto +-- eras/byron/crypto/test +-- eras/byron/ledger/executable-spec +-- eras/byron/ledger/impl +-- eras/byron/ledger/impl/test +-- eras/conway/impl +-- eras/conway/test-suite +-- eras/mary/impl +-- eras/shelley-ma/impl +-- eras/shelley-ma/test-suite +-- eras/shelley/impl +-- eras/shelley/test-suite +-- libs/cardano-data +-- libs/cardano-ledger-binary +-- libs/cardano-ledger-core +-- libs/cardano-ledger-pretty +-- libs/cardano-protocol-tpraos +-- libs/non-integral +-- libs/set-algebra +-- libs/small-steps +-- libs/small-steps-test +-- libs/vector-map diff --git a/cardano-api/cardano-api.cabal b/cardano-api/cardano-api.cabal index 65cd169de19..257f3ab7708 100644 --- a/cardano-api/cardano-api.cabal +++ b/cardano-api/cardano-api.cabal @@ -116,17 +116,19 @@ library , bytestring , cardano-binary , cardano-crypto - , cardano-crypto-class ^>= 2.0 - , cardano-crypto-wrapper ^>= 1.4 - , cardano-data ^>= 0.1 - , cardano-ledger-alonzo ^>= 0.1 - , cardano-ledger-babbage ^>= 0.1 - , cardano-ledger-conway - , cardano-ledger-byron ^>= 0.1 - , cardano-ledger-core ^>= 0.1 - , cardano-ledger-shelley-ma ^>= 0.1 - , cardano-protocol-tpraos >= 0.1 + , cardano-crypto-class ^>= 2.1 + , cardano-crypto-wrapper ^>= 1.5 + , cardano-data ^>= 1.0 + , cardano-ledger-alonzo ^>= 1.0 + , cardano-ledger-allegra ^>= 1.0 + , cardano-ledger-babbage ^>= 1.0 + , cardano-ledger-byron ^>= 1.0 + , cardano-ledger-core ^>= 1.0 + , cardano-ledger-mary ^>= 1.0 + , cardano-ledger-shelley ^>= 1.0 + , cardano-protocol-tpraos >= 1.0 , cardano-slotting >= 0.1 + , cardano-strict-containers ^>= 0.1 , cborg , contra-tracer , containers @@ -160,11 +162,8 @@ library , random , scientific , serialise - , small-steps ^>= 0.1 - , cardano-ledger-shelley ^>= 0.1 - , small-steps ^>= 0.1 + , small-steps ^>= 1.0 , stm - , cardano-strict-containers ^>= 0.1 , text , time , transformers @@ -172,7 +171,7 @@ library , typed-protocols ^>= 0.1 , unordered-containers >= 0.2.11 , vector - , vector-map ^>= 0.1 + , vector-map ^>= 1.0 , yaml library gen @@ -193,14 +192,14 @@ library gen , base16-bytestring , bytestring , cardano-api - , cardano-binary - , cardano-crypto-class ^>= 2.0 - , cardano-crypto-test ^>= 1.4 - , cardano-ledger-alonzo ^>= 0.1 - , cardano-ledger-alonzo-test ^>= 0.1 - , cardano-ledger-byron-test ^>= 1.4 - , cardano-ledger-core ^>= 0.1 - , cardano-ledger-shelley ^>= 0.1 + , cardano-binary ^>= 1.6 + , cardano-crypto-class ^>= 2.1 + , cardano-crypto-test ^>= 1.5 + , cardano-ledger-alonzo ^>= 1.0 + , cardano-ledger-alonzo-test + , cardano-ledger-byron-test ^>= 1.5 + , cardano-ledger-core ^>= 1.0 + , cardano-ledger-shelley ^>= 1.0 , containers , hedgehog , text @@ -215,13 +214,14 @@ test-suite cardano-api-test , bytestring , cardano-api , cardano-api:gen - , cardano-data ^>= 0.1 + , cardano-data ^>= 1.0 , cardano-crypto - , cardano-crypto-class ^>= 2.0 - , cardano-crypto-test ^>= 1.4 - , cardano-crypto-tests ^>= 2.0 - , cardano-ledger-alonzo ^>= 0.1 - , cardano-ledger-core ^>= 0.1 + , cardano-crypto-class ^>= 2.1 + , cardano-crypto-test ^>= 1.5 + , cardano-crypto-tests ^>= 2.1 + , cardano-ledger-core ^>= 1.0 + , cardano-ledger-shelley ^>= 1.0 + , cardano-ledger-shelley-test ^>= 1.0 , cardano-slotting ^>= 0.1 , containers , hedgehog @@ -230,8 +230,6 @@ test-suite cardano-api-test , ouroboros-consensus , ouroboros-consensus-shelley , QuickCheck - , cardano-ledger-shelley ^>= 0.1 - , cardano-ledger-shelley-test ^>= 0.1 , tasty , tasty-hedgehog , tasty-quickcheck diff --git a/cardano-cli/cardano-cli.cabal b/cardano-cli/cardano-cli.cabal index 4b00a8ac298..907e21abcdd 100644 --- a/cardano-cli/cardano-cli.cabal +++ b/cardano-cli/cardano-cli.cabal @@ -110,19 +110,19 @@ library , cardano-api , cardano-binary , cardano-crypto - , cardano-crypto-class ^>= 2.0 - , cardano-crypto-wrapper ^>= 1.4 - , cardano-data ^>= 0.1 + , cardano-crypto-class ^>= 2.1 + , cardano-crypto-wrapper ^>= 1.5 + , cardano-data ^>= 1.0 , cardano-git-rev - , cardano-ledger-alonzo ^>= 0.1 - , cardano-ledger-byron ^>= 0.1 - , cardano-ledger-conway - , cardano-ledger-core ^>= 0.1 - , cardano-ledger-shelley ^>= 0.1 - , cardano-ledger-shelley-ma ^>= 0.1 + , cardano-ledger-alonzo ^>= 1.0 + , cardano-ledger-allegra ^>= 1.0 + , cardano-ledger-byron ^>= 1.0 + , cardano-ledger-core ^>= 1.0 + , cardano-ledger-mary ^>= 1.0 + , cardano-ledger-shelley ^>= 1.0 , cardano-ping , cardano-prelude - , cardano-protocol-tpraos ^>= 0.1 + , cardano-protocol-tpraos ^>= 1.0 , cardano-slotting ^>= 0.1 , cardano-strict-containers ^>= 0.1 , cborg >= 0.2.4 && < 0.3 @@ -149,7 +149,7 @@ library , prettyprinter , prettyprinter-ansi-terminal , random - , set-algebra ^>= 0.1 + , set-algebra ^>= 1.0 , split , strict-stm , text @@ -159,7 +159,7 @@ library , unliftio-core , utf8-string , vector - , vector-map ^>= 0.1 + , vector-map ^>= 1.0 , yaml executable cardano-cli @@ -170,7 +170,7 @@ executable cardano-cli ghc-options: -threaded -rtsopts "-with-rtsopts=-T" build-depends: cardano-cli - , cardano-crypto-class ^>= 2.0 + , cardano-crypto-class ^>= 2.1 , optparse-applicative-fork , transformers-except @@ -232,8 +232,8 @@ test-suite cardano-cli-golden , bytestring , cardano-api , cardano-cli - , cardano-crypto-wrapper ^>= 1.4 - , cardano-ledger-byron ^>= 0.1 + , cardano-crypto-wrapper ^>= 1.5 + , cardano-ledger-byron ^>= 1.0 , cardano-prelude , cborg , containers diff --git a/cardano-client-demo/cardano-client-demo.cabal b/cardano-client-demo/cardano-client-demo.cabal index eadc1babc4e..1ac7b086821 100644 --- a/cardano-client-demo/cardano-client-demo.cabal +++ b/cardano-client-demo/cardano-client-demo.cabal @@ -31,7 +31,7 @@ executable scan-blocks-pipelined import: project-config main-is: ScanBlocksPipelined.hs build-depends: cardano-api - , cardano-ledger-byron ^>= 0.1 + , cardano-ledger-byron ^>= 1.0 , cardano-slotting ^>= 0.1 , filepath , time @@ -40,7 +40,7 @@ executable chain-sync-client-with-ledger-state import: project-config main-is: ChainSyncClientWithLedgerState.hs build-depends: cardano-api - , cardano-ledger-byron ^>= 0.1 + , cardano-ledger-byron ^>= 1.0 , cardano-slotting ^>= 0.1 , ouroboros-consensus , ouroboros-consensus-cardano diff --git a/cardano-node/cardano-node.cabal b/cardano-node/cardano-node.cabal index 0c7a6893acd..044723ffc7b 100644 --- a/cardano-node/cardano-node.cabal +++ b/cardano-node/cardano-node.cabal @@ -138,7 +138,7 @@ library , base16-bytestring , bytestring , cardano-api - , cardano-data >= 0.1 + , cardano-data ^>= 1.0 , cardano-git-rev , cardano-crypto-class , cardano-crypto-wrapper @@ -154,9 +154,9 @@ library , cardano-ledger-shelley , cardano-ledger-shelley-ma , cardano-prelude - , cardano-protocol-tpraos >= 0.1 - , cardano-slotting >= 0.1 - , cborg >= 0.2.4 + , cardano-protocol-tpraos ^>= 1.0 + , cardano-slotting ^>= 0.1 + , cborg ^>= 0.2.4 , contra-tracer , containers , contra-tracer @@ -178,18 +178,18 @@ library , lobemo-backend-trace-forwarder , mtl , network - , network-mux >= 0.2 + , network-mux ^>= 0.3 , nothunks , optparse-applicative-fork - , ouroboros-consensus >= 0.2 + , ouroboros-consensus ^>= 0.2 , ouroboros-consensus-byron , ouroboros-consensus-cardano , ouroboros-consensus-diffusion , ouroboros-consensus-protocol , ouroboros-consensus-shelley - , ouroboros-network >= 0.3 , ouroboros-network-api - , ouroboros-network-framework >= 0.3 + , ouroboros-network ^>= 0.4 + , ouroboros-network-framework ^>= 0.3 , ouroboros-network-protocols , prettyprinter , prettyprinter-ansi-terminal diff --git a/cardano-submit-api/cardano-submit-api.cabal b/cardano-submit-api/cardano-submit-api.cabal index 558545404a2..f72a25367e9 100644 --- a/cardano-submit-api/cardano-submit-api.cabal +++ b/cardano-submit-api/cardano-submit-api.cabal @@ -40,8 +40,8 @@ library , bytestring , cardano-api , cardano-binary - , cardano-crypto-class ^>= 2.0 - , cardano-ledger-byron ^>= 0.1 + , cardano-crypto-class ^>= 2.1 + , cardano-ledger-byron ^>= 1.0 , formatting , http-media , iohk-monitoring From 2f729cd231e52aafe2f4a2c01ae8bc45a4abfe71 Mon Sep 17 00:00:00 2001 From: Alexey Kuleshevich Date: Fri, 24 Feb 2023 00:06:39 +0300 Subject: [PATCH 04/38] cardano-api: Initial integration steps --- cabal.project | 1 + .../src/Cardano/Api/Crypto/Ed25519Bip32.hs | 2 +- cardano-api/src/Cardano/Api/Genesis.hs | 32 ++++++++++--------- 3 files changed, 19 insertions(+), 16 deletions(-) diff --git a/cabal.project b/cabal.project index b70980acb71..42471818609 100644 --- a/cabal.project +++ b/cabal.project @@ -126,6 +126,7 @@ source-repository-package ouroboros-network ouroboros-network-framework ouroboros-network-testing + ouroboros-network-protocols ouroboros-consensus-cardano-tools -- Waiting for proper Windows ghc-9.2 release. diff --git a/cardano-api/src/Cardano/Api/Crypto/Ed25519Bip32.hs b/cardano-api/src/Cardano/Api/Crypto/Ed25519Bip32.hs index 16390d0ef92..10bcab59d93 100644 --- a/cardano-api/src/Cardano/Api/Crypto/Ed25519Bip32.hs +++ b/cardano-api/src/Cardano/Api/Crypto/Ed25519Bip32.hs @@ -132,7 +132,7 @@ instance FromCBOR (VerKeyDSIGN Ed25519Bip32DSIGN) where instance ToCBOR (SignKeyDSIGN Ed25519Bip32DSIGN) where toCBOR = encodeSignKeyDSIGN - encodedSizeExpr _ = encodedSignKeyDESIGNSizeExpr + encodedSizeExpr _ = encodedSignKeyDSIGNSizeExpr instance FromCBOR (SignKeyDSIGN Ed25519Bip32DSIGN) where fromCBOR = decodeSignKeyDSIGN diff --git a/cardano-api/src/Cardano/Api/Genesis.hs b/cardano-api/src/Cardano/Api/Genesis.hs index bb360beec40..dfb528305bb 100644 --- a/cardano-api/src/Cardano/Api/Genesis.hs +++ b/cardano-api/src/Cardano/Api/Genesis.hs @@ -10,12 +10,15 @@ import qualified Data.ListMap as ListMap import qualified Data.Map.Strict as Map import Data.Maybe (fromMaybe) import qualified Data.Time as Time +import Lens.Micro import Cardano.Ledger.BaseTypes as Ledger -import Cardano.Ledger.Shelley.PParams as Ledger (emptyPParams, ShelleyPParamsHKD (..)) -import Cardano.Slotting.Slot (EpochSize (..)) +import Cardano.Ledger.Coin (Coin (..)) +import Cardano.Ledger.Crypto (Crypto) +import Cardano.Ledger.Shelley.Core +import Cardano.Ledger.Shelley.Genesis (NominalDiffTimeMicro, ShelleyGenesis (..), + emptyGenesisStaking) -import Ouroboros.Consensus.Shelley.Node (ShelleyGenesis (..), emptyGenesisStaking) -- | Some reasonable starting defaults for constructing a 'ShelleyGenesis'. @@ -29,7 +32,7 @@ import Ouroboros.Consensus.Shelley.Node (ShelleyGenesis (..), emptyGen -- * 'sgMaxLovelaceSupply' must be at least the sum of the 'sgInitialFunds' -- but more if you want to allow for rewards. -- -shelleyGenesisDefaults :: ShelleyGenesis crypto +shelleyGenesisDefaults :: Crypto crypto => ShelleyGenesis crypto shelleyGenesisDefaults = ShelleyGenesis { @@ -39,27 +42,26 @@ shelleyGenesisDefaults = , sgNetworkId = Ledger.Testnet -- consensus protocol parameters - , sgSlotLength = 1.0 :: Time.NominalDiffTime -- 1s slots + , sgSlotLength = 1.0 :: NominalDiffTimeMicro -- 1s slots , sgActiveSlotsCoeff = fromMaybe (error "shelleyGenesisDefaults: impossible") (Ledger.boundRational (1/20)) -- 20s block times on average , sgSecurityParam = k - , sgEpochLength = EpochSize (k * 10 * 20) -- 10k/f + , sgEpochLength = Ledger.EpochSize (k * 10 * 20) -- 10k/f , sgSlotsPerKESPeriod = 60 * 60 * 36 -- 1.5 days with 1s slots , sgMaxKESEvolutions = 60 -- 90 days , sgUpdateQuorum = 5 -- assuming 7 genesis keys -- ledger protocol parameters , sgProtocolParams = - Ledger.emptyPParams - { Ledger._d = maxBound - , Ledger._maxBHSize = 1100 -- TODO: compute from crypto - , Ledger._maxBBSize = 64 * 1024 -- max 64kb blocks - , Ledger._maxTxSize = 16 * 1024 -- max 16kb txs - , Ledger._eMax = 18 - , Ledger._minfeeA = 1 -- The linear factor for the minimum fee calculation - , Ledger._minfeeB = 0 -- The constant factor for the minimum fee calculation - } + emptyPParams + & ppDL .~ maxBound + & ppMaxBHSizeL .~ 1100 -- TODO: compute from crypto + & ppMaxBBSizeL .~ 64 * 1024 -- max 64kb blocks + & ppMaxTxSizeL .~ 16 * 1024 -- max 16kb txs + & ppEMaxL .~ 18 + & ppMinFeeAL .~ Coin 1 -- The linear factor for the minimum fee calculation + & ppMinFeeBL .~ Coin 0 -- The constant factor for the minimum fee calculation -- genesis keys and initial funds , sgGenDelegs = Map.empty From f900b6d1cf75cc84d56670bc09831c0d50f6e299 Mon Sep 17 00:00:00 2001 From: Alexey Kuleshevich Date: Fri, 24 Feb 2023 01:43:45 +0300 Subject: [PATCH 05/38] cardano-api:Continue with integration. Ran into a problem with Script parameterization on era --- cabal.project | 46 ++++++++++----------- cardano-api/cardano-api.cabal | 1 + cardano-api/src/Cardano/Api/Keys/Byron.hs | 8 ++-- cardano-api/src/Cardano/Api/Script.hs | 2 +- cardano-api/src/Cardano/Api/ScriptData.hs | 5 ++- cardano-api/src/Cardano/Api/SpecialByron.hs | 7 +++- cardano-api/src/Cardano/Api/TxMetadata.hs | 38 ++++++++--------- 7 files changed, 54 insertions(+), 53 deletions(-) diff --git a/cabal.project b/cabal.project index 42471818609..6bf5c8f455e 100644 --- a/cabal.project +++ b/cabal.project @@ -37,41 +37,41 @@ packages: trace-resources trace-forward -extra-packages: - ouroboros-consensus-cardano-tools +-- extra-packages: +-- ouroboros-consensus-cardano-tools -package cardano-api +program-options ghc-options: -Werror -package cardano-cli - ghc-options: -Werror +-- package cardano-api +-- ghc-options: -Werror -package cardano-git-rev - ghc-options: -Werror +-- package cardano-cli +-- ghc-options: -Werror -package cardano-node - ghc-options: -Werror +-- package cardano-node +-- -- ghc-options: -Werror -package cardano-node-chairman - ghc-options: -Werror +-- package cardano-node-chairman +-- ghc-options: -Werror -package cardano-testnet - ghc-options: -Werror +-- package cardano-testnet +-- ghc-options: -Werror -package tx-generator - ghc-options: -Werror +-- package tx-generator +-- ghc-options: -Werror -package trace-dispatcher - ghc-options: -Werror +-- package trace-dispatcher +-- ghc-options: -Werror -package trace-resources - ghc-options: -Werror +-- package trace-resources +-- ghc-options: -Werror -package cardano-tracer - ghc-options: -Werror +-- package cardano-tracer +-- ghc-options: -Werror -package submit-api - ghc-options: -Werror +-- package submit-api +-- ghc-options: -Werror package cryptonite -- Using RDRAND instead of /dev/urandom as an entropy source for key diff --git a/cardano-api/cardano-api.cabal b/cardano-api/cardano-api.cabal index 257f3ab7708..a1064c233ea 100644 --- a/cardano-api/cardano-api.cabal +++ b/cardano-api/cardano-api.cabal @@ -122,6 +122,7 @@ library , cardano-ledger-alonzo ^>= 1.0 , cardano-ledger-allegra ^>= 1.0 , cardano-ledger-babbage ^>= 1.0 + , cardano-ledger-binary ^>= 1.0 , cardano-ledger-byron ^>= 1.0 , cardano-ledger-core ^>= 1.0 , cardano-ledger-mary ^>= 1.0 diff --git a/cardano-api/src/Cardano/Api/Keys/Byron.hs b/cardano-api/src/Cardano/Api/Keys/Byron.hs index 72c9584988f..f85257a2318 100644 --- a/cardano-api/src/Cardano/Api/Keys/Byron.hs +++ b/cardano-api/src/Cardano/Api/Keys/Byron.hs @@ -35,7 +35,6 @@ import qualified Codec.CBOR.Read as CBOR import Control.Monad import Data.Bifunctor import qualified Data.ByteString.Lazy as LB -import Data.Coders (cborError) import Data.Either.Combinators import Data.String (IsString) import Data.Text (Text) @@ -47,7 +46,7 @@ import qualified Cardano.Crypto.Seed as Crypto import qualified Cardano.Crypto.Signing as Crypto import qualified Cardano.Crypto.Wallet as Crypto.HD -import Cardano.Binary (toStrictByteString) +import Cardano.Binary (toStrictByteString, cborError) import qualified Cardano.Chain.Common as Byron import qualified Cardano.Crypto.Hashing as Byron import qualified Cardano.Crypto.Signing as Byron @@ -146,12 +145,11 @@ instance SerialiseAsRawBytes (VerificationKey ByronKey) where ByronVerificationKey . Byron.VerificationKey <$> Crypto.HD.xpub bs instance SerialiseAsRawBytes (SigningKey ByronKey) where - serialiseToRawBytes (ByronSigningKey (Byron.SigningKey xsk)) = - toStrictByteString $ Crypto.toCBORXPrv xsk + serialiseToRawBytes (ByronSigningKey sk) = toStrictByteString $ toCBOR sk deserialiseFromRawBytes (AsSigningKey AsByronKey) bs = first (\e -> SerialiseAsRawBytesError ("Unable to deserialise SigningKey ByronKey" ++ show e)) $ - ByronSigningKey . Byron.SigningKey . snd <$> CBOR.deserialiseFromBytes Byron.fromCBORXPrv (LB.fromStrict bs) + ByronSigningKey . snd <$> CBOR.deserialiseFromBytes fromCBOR (LB.fromStrict bs) newtype instance Hash ByronKey = ByronKeyHash Byron.KeyHash deriving (Eq, Ord) diff --git a/cardano-api/src/Cardano/Api/Script.hs b/cardano-api/src/Cardano/Api/Script.hs index e06b8c646cc..f4f6c98d789 100644 --- a/cardano-api/src/Cardano/Api/Script.hs +++ b/cardano-api/src/Cardano/Api/Script.hs @@ -139,9 +139,9 @@ import Cardano.Slotting.Slot (SlotNo) import Cardano.Ledger.BaseTypes (StrictMaybe (..)) import qualified Cardano.Ledger.Core as Ledger +import qualified Cardano.Ledger.Allegra.Scripts as Timelock import qualified Cardano.Ledger.Keys as Shelley import qualified Cardano.Ledger.Shelley.Scripts as Shelley -import qualified Cardano.Ledger.ShelleyMA.Timelocks as Timelock import Ouroboros.Consensus.Shelley.Eras (StandardCrypto) import qualified Cardano.Ledger.Alonzo.Language as Alonzo diff --git a/cardano-api/src/Cardano/Api/ScriptData.hs b/cardano-api/src/Cardano/Api/ScriptData.hs index 5d0e90fa446..c2b0ab502d5 100644 --- a/cardano-api/src/Cardano/Api/ScriptData.hs +++ b/cardano-api/src/Cardano/Api/ScriptData.hs @@ -74,7 +74,8 @@ import qualified Data.Attoparsec.ByteString.Char8 as Atto import Control.Applicative (Alternative (..)) import qualified Cardano.Crypto.Hash.Class as Crypto -import qualified Cardano.Ledger.Alonzo.Data as Alonzo +import Cardano.Ledger.Core (Era) +import qualified Cardano.Ledger.Alonzo.Scripts.Data as Alonzo import qualified Cardano.Ledger.SafeHash as Ledger import Ouroboros.Consensus.Shelley.Eras (StandardAlonzo, StandardCrypto) import qualified PlutusLedgerApi.V1 as Plutus @@ -194,7 +195,7 @@ newtype ScriptBytesError = ScriptBytesError String deriving Show -- data i.e differing script data hashes due to the re-encoding being slightly -- different to the original encoding. See: https://github.com/input-output-hk/cardano-ledger/issues/2943 -toAlonzoData :: HashableScriptData -> Alonzo.Data ledgerera +toAlonzoData :: Era ledgerera => HashableScriptData -> Alonzo.Data ledgerera toAlonzoData = either (\ e -> error $ "toAlonzoData: " <> show e) diff --git a/cardano-api/src/Cardano/Api/SpecialByron.hs b/cardano-api/src/Cardano/Api/SpecialByron.hs index 6ffcc651f82..ff65e86071d 100644 --- a/cardano-api/src/Cardano/Api/SpecialByron.hs +++ b/cardano-api/src/Cardano/Api/SpecialByron.hs @@ -35,6 +35,8 @@ import Cardano.Chain.Update (AProposal (aBody, annotation), InstallerH recoverVoteId, signProposal) import qualified Cardano.Chain.Update.Vote as ByronVote import Cardano.Crypto (SafeSigner, noPassSafeSigner) +import qualified Cardano.Ledger.Binary as Binary (Annotated (..), ByteSpan (..), annotation, + annotationBytes, reAnnotate, byronProtVer) import Ouroboros.Consensus.Byron.Ledger.Block (ByronBlock) import qualified Ouroboros.Consensus.Byron.Ledger.Mempool as Mempool @@ -76,7 +78,7 @@ makeByronUpdateProposal nId pVer sVer sysTag insHash let nonAnnotatedProposal :: AProposal () nonAnnotatedProposal = signProposal (toByronProtocolMagicId nId) proposalBody noPassSigningKey annotatedPropBody :: Binary.Annotated ProposalBody ByteString - annotatedPropBody = Binary.reAnnotate $ aBody nonAnnotatedProposal + annotatedPropBody = Binary.reAnnotate Binary.byronProtVer $ aBody nonAnnotatedProposal in ByronUpdateProposal $ nonAnnotatedProposal { aBody = annotatedPropBody , annotation = Binary.serialize' nonAnnotatedProposal @@ -187,7 +189,8 @@ makeByronVote nId sKey (ByronUpdateProposal proposal) yesOrNo = nonAnnotatedVote :: ByronVote.AVote () nonAnnotatedVote = mkVote (toByronProtocolMagicId nId) signingKey (recoverUpId proposal) yesOrNo annotatedProposalId :: Binary.Annotated UpId ByteString - annotatedProposalId = Binary.reAnnotate $ ByronVote.aProposalId nonAnnotatedVote + annotatedProposalId = + Binary.reAnnotate Binary.byronProtVer $ ByronVote.aProposalId nonAnnotatedVote in ByronVote $ nonAnnotatedVote { ByronVote.aProposalId = annotatedProposalId , ByronVote.annotation = Binary.annotation annotatedProposalId diff --git a/cardano-api/src/Cardano/Api/TxMetadata.hs b/cardano-api/src/Cardano/Api/TxMetadata.hs index 7b8c1ab7de4..1c18aed6aeb 100644 --- a/cardano-api/src/Cardano/Api/TxMetadata.hs +++ b/cardano-api/src/Cardano/Api/TxMetadata.hs @@ -43,9 +43,7 @@ module Cardano.Api.TxMetadata ( import Cardano.Api.Eras import Cardano.Api.Error import Cardano.Api.HasTypeProxy -import Cardano.Api.SerialiseCBOR -import qualified Cardano.Binary as CBOR -import qualified Cardano.Ledger.Shelley.Metadata as Shelley +import qualified Cardano.Ledger.Shelley.TxAuxData as Shelley import Control.Applicative (Alternative (..)) import Control.Monad (guard, when) import qualified Data.Aeson as Aeson @@ -104,23 +102,23 @@ instance HasTypeProxy TxMetadata where data AsType TxMetadata = AsTxMetadata proxyToAsType _ = AsTxMetadata -instance SerialiseAsCBOR TxMetadata where - serialiseToCBOR = - CBOR.serialize' - . (Shelley.Metadata :: Map Word64 Shelley.Metadatum -> Shelley.Metadata ()) - -- The Shelley (Metadata era) is always polymorphic in era, - -- so we pick the unit type. - . toShelleyMetadata - . (\(TxMetadata m) -> m) - - deserialiseFromCBOR AsTxMetadata bs = - TxMetadata - . fromShelleyMetadata - . (\(Shelley.Metadata m) -> m) - <$> (CBOR.decodeAnnotator "TxMetadata" fromCBOR (LBS.fromStrict bs) - :: Either CBOR.DecoderError (Shelley.Metadata ())) - -- The Shelley (Metadata era) is always polymorphic in era, - -- so we pick the unit type. +-- instance SerialiseAsCBOR TxMetadata where +-- serialiseToCBOR = +-- CBOR.serialize' +-- . (Shelley.Metadata :: Map Word64 Shelley.Metadatum -> Shelley.Metadata ()) +-- -- The Shelley (Metadata era) is always polymorphic in era, +-- -- so we pick the unit type. +-- . toShelleyMetadata +-- . (\(TxMetadata m) -> m) + +-- deserialiseFromCBOR AsTxMetadata bs = +-- TxMetadata +-- . fromShelleyMetadata +-- . (\(Shelley.Metadata m) -> m) +-- <$> (CBOR.decodeAnnotator "TxMetadata" fromCBOR (LBS.fromStrict bs) +-- :: Either CBOR.DecoderError (Shelley.Metadata ())) +-- -- The Shelley (Metadata era) is always polymorphic in era, +-- -- so we pick the unit type. makeTransactionMetadata :: Map Word64 TxMetadataValue -> TxMetadata makeTransactionMetadata = TxMetadata From 4973e517ba8beaa6b956673300da784eba6cdba2 Mon Sep 17 00:00:00 2001 From: Alexey Kuleshevich Date: Thu, 2 Mar 2023 18:27:59 +0300 Subject: [PATCH 06/38] Move all Ledger related JSON instances --- cardano-api/src/Cardano/Api/Orphans.hs | 678 +------------------------ cardano-api/src/Cardano/Api/Script.hs | 21 +- cardano-api/src/Cardano/Api/Value.hs | 15 +- 3 files changed, 22 insertions(+), 692 deletions(-) diff --git a/cardano-api/src/Cardano/Api/Orphans.hs b/cardano-api/src/Cardano/Api/Orphans.hs index de24300988d..356e01fbe74 100644 --- a/cardano-api/src/Cardano/Api/Orphans.hs +++ b/cardano-api/src/Cardano/Api/Orphans.hs @@ -1,695 +1,19 @@ -{-# LANGUAGE BangPatterns #-} -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE DerivingStrategies #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE GADTs #-} -{-# LANGUAGE GeneralizedNewtypeDeriving #-} -{-# LANGUAGE LambdaCase #-} {-# LANGUAGE NamedFieldPuns #-} -{-# LANGUAGE RankNTypes #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE StandaloneDeriving #-} -{-# LANGUAGE UndecidableInstances #-} {-# OPTIONS_GHC -Wno-orphans #-} -{-# OPTIONS_GHC -Wno-unticked-promoted-constructors #-} - module Cardano.Api.Orphans () where -import Data.Aeson (FromJSON (..), ToJSON (..), object, pairs, (.=)) +import Data.Aeson (ToJSON (..), object, pairs, (.=)) import qualified Data.Aeson as Aeson -import Data.Aeson.Types (ToJSONKey (..), toJSONKeyText) -import Data.BiMap (BiMap (..), Bimap) -import qualified Data.ByteString.Base16 as B16 -import qualified Data.ByteString.Short as Short -import qualified Data.Map.Strict as Map -import Data.Text (Text) -import qualified Data.Text as Text -import qualified Data.Text.Encoding as Text -import Data.UMap (Trip (Triple), UMap (UnifiedMap)) -import Data.VMap (VB, VMap, VP) -import qualified Data.VMap as VMap - -import qualified Cardano.Ledger.Babbage as Babbage -import Cardano.Ledger.BaseTypes (StrictMaybe (..)) -import qualified Cardano.Ledger.BaseTypes as Ledger -import Cardano.Ledger.Compactible (Compactible (fromCompact)) -import qualified Cardano.Ledger.Conway as Conway -import qualified Cardano.Ledger.Era as Ledger -import qualified Cardano.Ledger.Shelley.PoolRank as Shelley -import Cardano.Ledger.UnifiedMap (UnifiedMap) -import Cardano.Slotting.Slot (SlotNo (..)) -import Cardano.Slotting.Time (SystemStart (..)) -import Control.State.Transition (STS (State)) -import Cardano.Api.Script -import qualified Cardano.Binary as CBOR -import qualified Cardano.Crypto.Hash.Class as Crypto -import qualified Cardano.Ledger.Alonzo.Data as Alonzo -import Cardano.Ledger.Alonzo.Scripts (AlonzoScript) -import Cardano.Ledger.Babbage.PParams (BabbagePParams, BabbagePParamsUpdate) -import qualified Cardano.Ledger.Babbage.PParams as Babbage -import qualified Cardano.Ledger.Babbage.TxBody as Babbage -import qualified Cardano.Ledger.Coin as Shelley -import Cardano.Ledger.Core (EraTxOut) -import qualified Cardano.Ledger.Core as Core import qualified Cardano.Ledger.Crypto as Crypto -import Cardano.Ledger.Mary.Value (MaryValue (..)) -import qualified Cardano.Ledger.Mary.Value as Mary -import qualified Cardano.Ledger.PoolDistr as Ledger -import qualified Cardano.Ledger.SafeHash as SafeHash -import Cardano.Ledger.Shelley.API (ShelleyTxOut (..)) -import qualified Cardano.Ledger.Shelley.API as Shelley -import Cardano.Ledger.Val (Val) - -import Cardano.Ledger.Babbage.TxBody (BabbageTxOut (..)) -import qualified Cardano.Ledger.Shelley.EpochBoundary as ShelleyEpoch -import qualified Cardano.Ledger.Shelley.LedgerState as ShelleyLedger -import Cardano.Ledger.Shelley.PParams (ShelleyPParamsUpdate) -import qualified Cardano.Ledger.Shelley.Rewards as Shelley -import qualified Cardano.Ledger.Shelley.RewardUpdate as Shelley -import qualified Ouroboros.Consensus.Shelley.Eras as Consensus import qualified Ouroboros.Consensus.Shelley.Ledger.Query as Consensus -- Orphan instances involved in the JSON output of the API queries. -- We will remove/replace these as we provide more API wrapper types -instance ToJSON (MaryValue era) where - toJSON = object . toMaryValuePairs - toEncoding = Aeson.pairs . mconcat . toMaryValuePairs - -toMaryValuePairs :: Aeson.KeyValue a => MaryValue crypto -> [a] -toMaryValuePairs (MaryValue !l !ps) = - [ "lovelace" .= l - , "policies" .= ps - ] - -instance ToJSONKey Mary.AssetName where - toJSONKey = toJSONKeyText render - where - render = Text.decodeLatin1 . B16.encode . Short.fromShort . Mary.assetName - -instance ToJSON (Mary.PolicyID era) where - toJSON (Mary.PolicyID (Shelley.ScriptHash h)) = Aeson.String (hashToText h) - -instance ToJSONKey (Mary.PolicyID era) where - toJSONKey = toJSONKeyText render - where - render (Mary.PolicyID (Shelley.ScriptHash h)) = hashToText h - -instance ToJSON Mary.AssetName where - toJSON = Aeson.String . Text.decodeLatin1 . B16.encode . Short.fromShort . Mary.assetName - -instance ToJSON Shelley.AccountState where - toJSON = object . toAccountStatePairs - toEncoding = Aeson.pairs . mconcat . toAccountStatePairs - -toAccountStatePairs :: Aeson.KeyValue a => ShelleyLedger.AccountState -> [a] -toAccountStatePairs (Shelley.AccountState !tr !rs) = - [ "treasury" .= tr - , "reserves" .= rs - ] - -instance forall era. - ( Consensus.ShelleyBasedEra era - , ToJSON (Core.TxOut era) - , ToJSON (Core.PParams era) - , ToJSON (Core.PParamsUpdate era) - ) => ToJSON (Shelley.EpochState era) where - toJSON = object . toEpochStatePairs - toEncoding = Aeson.pairs . mconcat . toEpochStatePairs - -toEpochStatePairs :: - ( Consensus.ShelleyBasedEra era - , ToJSON (Core.TxOut era) - , ToJSON (Core.PParamsUpdate era) - , ToJSON (Core.PParams era) - , Aeson.KeyValue a - ) - => ShelleyLedger.EpochState era - -> [a] -toEpochStatePairs eState = - let !esAccountState = Shelley.esAccountState eState - !esSnapshots = Shelley.esSnapshots eState - !esLState = Shelley.esLState eState - !esPrevPp = Shelley.esPrevPp eState - !esPp = Shelley.esPp eState - !esNonMyopic = Shelley.esNonMyopic eState - in [ "esAccountState" .= esAccountState - , "esSnapshots" .= esSnapshots - , "esLState" .= esLState - , "esPrevPp" .= esPrevPp - , "esPp" .= esPp - , "esNonMyopic" .= esNonMyopic - ] - - -instance ( Consensus.ShelleyBasedEra era - , ToJSON (Core.TxOut era) - , ToJSON (Core.PParamsUpdate era) - ) => ToJSON (Shelley.LedgerState era) where - toJSON = object . toLedgerStatePairs - toEncoding = Aeson.pairs . mconcat . toLedgerStatePairs - -toLedgerStatePairs :: - ( Consensus.ShelleyBasedEra era - , ToJSON (Core.TxOut era) - , ToJSON (Core.PParamsUpdate era) - , Aeson.KeyValue a - ) => ShelleyLedger.LedgerState era -> [a] -toLedgerStatePairs lState = - let !lsUTxOState = Shelley.lsUTxOState lState - !lsDPState = Shelley.lsDPState lState - in [ "utxoState" .= lsUTxOState - , "delegationState" .= lsDPState - ] - -instance Crypto.Crypto crypto => ToJSON (ShelleyLedger.IncrementalStake crypto) where - toJSON = object . toIncrementalStakePairs - toEncoding = Aeson.pairs . mconcat . toIncrementalStakePairs - -toIncrementalStakePairs :: - ( Aeson.KeyValue a - , Crypto.Crypto crypto - ) => ShelleyLedger.IncrementalStake crypto -> [a] -toIncrementalStakePairs iStake = - let !credentials = Map.toList (ShelleyLedger.credMap iStake) - !pointers = Map.toList (ShelleyLedger.ptrMap iStake) - in [ "credentials" .= credentials - , "pointers" .= pointers - ] - -instance ( Consensus.ShelleyBasedEra era - , ToJSON (Core.TxOut era) - , ToJSON (Core.PParamsUpdate era) - ) => ToJSON (Shelley.UTxOState era) where - toJSON = object . toUtxoStatePairs - toEncoding = Aeson.pairs . mconcat . toUtxoStatePairs - -toUtxoStatePairs :: - ( Aeson.KeyValue a - , Consensus.ShelleyBasedEra era - , ToJSON (Core.TxOut era) - , ToJSON (State (Core.EraRule "PPUP" era)) - ) => ShelleyLedger.UTxOState era -> [a] -toUtxoStatePairs utxoState = - let !utxo = Shelley._utxo utxoState - !deposited = Shelley._deposited utxoState - !fees = Shelley._fees utxoState - !ppups = Shelley._ppups utxoState - !stakeDistro = Shelley._stakeDistro utxoState - in [ "utxo" .= utxo - , "deposited" .= deposited - , "fees" .= fees - , "ppups" .= ppups - , "stake" .= stakeDistro - ] - -instance ( ToJSON (Core.PParamsUpdate era) - , Core.Era era - ) => ToJSON (Shelley.PPUPState era) where - toJSON = object . toPpupStatePairs - toEncoding = Aeson.pairs . mconcat . toPpupStatePairs - -toPpupStatePairs :: - ( Aeson.KeyValue a - , ToJSON (Core.PParamsUpdate era) - , Core.Era era - ) => ShelleyLedger.PPUPState era -> [a] -toPpupStatePairs ppUpState = - let !proposals = Shelley.proposals ppUpState - !futureProposals = Shelley.futureProposals ppUpState - in [ "proposals" .= proposals - , "futureProposals" .= futureProposals - ] - -instance ( ToJSON (Core.PParamsUpdate era) - , Core.Era era - ) => ToJSON (Shelley.ProposedPPUpdates era) where - toJSON (Shelley.ProposedPPUpdates ppUpdates) = toJSON $ Map.toList ppUpdates - toEncoding (Shelley.ProposedPPUpdates ppUpdates) = toEncoding $ Map.toList ppUpdates - -instance ToJSON (ShelleyPParamsUpdate era) where - toJSON pp = - Aeson.object $ - [ "minFeeA" .= x | x <- mbfield (Shelley._minfeeA pp) ] - ++ [ "minFeeB" .= x | x <- mbfield (Shelley._minfeeB pp) ] - ++ [ "maxBlockBodySize" .= x | x <- mbfield (Shelley._maxBBSize pp) ] - ++ [ "maxTxSize" .= x | x <- mbfield (Shelley._maxTxSize pp) ] - ++ [ "maxBlockHeaderSize" .= x | x <- mbfield (Shelley._maxBHSize pp) ] - ++ [ "keyDeposit" .= x | x <- mbfield (Shelley._keyDeposit pp) ] - ++ [ "poolDeposit" .= x | x <- mbfield (Shelley._poolDeposit pp) ] - ++ [ "eMax" .= x | x <- mbfield (Shelley._eMax pp) ] - ++ [ "nOpt" .= x | x <- mbfield (Shelley._nOpt pp) ] - ++ [ "a0" .= x | x <- mbfield (Shelley._a0 pp) ] - ++ [ "rho" .= x | x <- mbfield (Shelley._rho pp) ] - ++ [ "tau" .= x | x <- mbfield (Shelley._tau pp) ] - ++ [ "decentralisationParam" .= x | x <- mbfield (Shelley._d pp) ] - ++ [ "extraEntropy" .= x | x <- mbfield (Shelley._extraEntropy pp) ] - ++ [ "protocolVersion" .= x | x <- mbfield (Shelley._protocolVersion pp) ] - ++ [ "minUTxOValue" .= x | x <- mbfield (Shelley._minUTxOValue pp) ] - ++ [ "minPoolCost" .= x | x <- mbfield (Shelley._minPoolCost pp) ] - -instance ToJSON (BabbagePParamsUpdate era) where - toJSON pp = - Aeson.object $ - [ "minFeeA" .= x | x <- mbfield (Babbage._minfeeA pp) ] - ++ [ "minFeeB" .= x | x <- mbfield (Babbage._minfeeB pp) ] - ++ [ "maxBlockBodySize" .= x | x <- mbfield (Babbage._maxBBSize pp) ] - ++ [ "maxTxSize" .= x | x <- mbfield (Babbage._maxTxSize pp) ] - ++ [ "maxBlockHeaderSize" .= x | x <- mbfield (Babbage._maxBHSize pp) ] - ++ [ "keyDeposit" .= x | x <- mbfield (Babbage._keyDeposit pp) ] - ++ [ "poolDeposit" .= x | x <- mbfield (Babbage._poolDeposit pp) ] - ++ [ "eMax" .= x | x <- mbfield (Babbage._eMax pp) ] - ++ [ "nOpt" .= x | x <- mbfield (Babbage._nOpt pp) ] - ++ [ "a0" .= x | x <- mbfield (Babbage._a0 pp) ] - ++ [ "rho" .= x | x <- mbfield (Babbage._rho pp) ] - ++ [ "tau" .= x | x <- mbfield (Babbage._tau pp) ] - ++ [ "protocolVersion" .= x | x <- mbfield (Babbage._protocolVersion pp) ] - ++ [ "minPoolCost" .= x | x <- mbfield (Babbage._minPoolCost pp) ] - ++ [ "coinsPerUTxOByte" .= x | x <- mbfield (Babbage._coinsPerUTxOByte pp) ] - ++ [ "costmdls" .= x | x <- mbfield (Babbage._costmdls pp) ] - ++ [ "prices" .= x | x <- mbfield (Babbage._prices pp) ] - ++ [ "maxTxExUnits" .= x | x <- mbfield (Babbage._maxTxExUnits pp) ] - ++ [ "maxBlockExUnits" .= x | x <- mbfield (Babbage._maxBlockExUnits pp) ] - ++ [ "maxValSize" .= x | x <- mbfield (Babbage._maxValSize pp) ] - ++ [ "collateralPercentage" .= x | x <- mbfield (Babbage._collateralPercentage pp) ] - ++ [ "maxCollateralInputs" .= x | x <- mbfield (Babbage._maxCollateralInputs pp) ] - -instance ToJSON (BabbagePParams (era Consensus.StandardCrypto)) where - toJSON pp = - Aeson.object - [ "minFeeA" .= Babbage._minfeeA pp - , "minFeeB" .= Babbage._minfeeB pp - , "maxBlockBodySize" .= Babbage._maxBBSize pp - , "maxTxSize" .= Babbage._maxTxSize pp - , "maxBlockHeaderSize" .= Babbage._maxBHSize pp - , "keyDeposit" .= Babbage._keyDeposit pp - , "poolDeposit" .= Babbage._poolDeposit pp - , "eMax" .= Babbage._eMax pp - , "nOpt" .= Babbage._nOpt pp - , "a0" .= Babbage._a0 pp - , "rho" .= Babbage._rho pp - , "tau" .= Babbage._tau pp - , "protocolVersion" .= Babbage._protocolVersion pp - , "minPoolCost" .= Babbage._minPoolCost pp - , "coinsPerUTxOByte" .= Babbage._coinsPerUTxOByte pp - , "costmdls" .= Babbage._costmdls pp - , "prices" .= Babbage._prices pp - , "maxTxExUnits" .= Babbage._maxTxExUnits pp - , "maxBlockExUnits" .= Babbage._maxBlockExUnits pp - , "maxValSize" .= Babbage._maxValSize pp - , "collateralPercentage" .= Babbage._collateralPercentage pp - , "maxCollateralInputs" .= Babbage._maxCollateralInputs pp - ] - -mbfield :: StrictMaybe a -> [a] -mbfield SNothing = [] -mbfield (SJust x) = [x] - -instance ( Ledger.Era era - , ToJSON (Core.Value era) - , ToJSON (Babbage.Datum era) - , ToJSON (Core.Script era) - , Ledger.Crypto era ~ Consensus.StandardCrypto - , Val (Core.Value era) - ) => ToJSON (BabbageTxOut era) where - toJSON = object . toBabbageTxOutPairs - toEncoding = Aeson.pairs . mconcat . toBabbageTxOutPairs - -toBabbageTxOutPairs :: - ( Aeson.KeyValue a - , Ledger.Era era - , ToJSON (Core.Value era) - , ToJSON (Core.Script era) - , Ledger.Crypto era ~ Consensus.StandardCrypto - , Val (Core.Value era) - ) => BabbageTxOut era -> [a] -toBabbageTxOutPairs (BabbageTxOut !addr !val !dat !mRefScript) = - [ "address" .= addr - , "value" .= val - , "datum" .= dat - , "referenceScript" .= mRefScript - ] - -instance ( Ledger.Era era - , Ledger.Crypto era ~ Consensus.StandardCrypto - ) => ToJSON (Babbage.Datum era) where - toJSON d = - case Alonzo.datumDataHash d of - SNothing -> Aeson.Null - SJust dH -> toJSON $ ScriptDataHash dH - toEncoding d = - case Alonzo.datumDataHash d of - SNothing -> toEncoding Aeson.Null - SJust dH -> toEncoding $ ScriptDataHash dH - -instance ToJSON (AlonzoScript (Babbage.BabbageEra Consensus.StandardCrypto)) where - toJSON = Aeson.String . Text.decodeUtf8 . B16.encode . CBOR.serialize' - -instance ToJSON (AlonzoScript (Conway.ConwayEra Consensus.StandardCrypto)) where - toJSON = Aeson.String . Text.decodeUtf8 . B16.encode . CBOR.serialize' - -instance Crypto.Crypto crypto => ToJSON (Shelley.DPState crypto) where - toJSON = object . toDpStatePairs - toEncoding = Aeson.pairs . mconcat . toDpStatePairs - -toDpStatePairs :: - ( Aeson.KeyValue a - , Crypto.Crypto crypto - ) => ShelleyLedger.DPState crypto -> [a] -toDpStatePairs dpState = - let !dstate = Shelley.dpsDState dpState - !pstate = Shelley.dpsPState dpState - in [ "dstate" .= dstate - , "pstate" .= pstate - ] - -instance (ToJSON coin, ToJSON ptr, ToJSON pool) => ToJSON (Trip coin ptr pool) where - toJSON = object . toTripPair - toEncoding = Aeson.pairs . mconcat . toTripPair - -toTripPair :: - ( Aeson.KeyValue a - , ToJSON coin - , ToJSON ptr - , ToJSON pool - ) => Trip coin ptr pool -> [a] -toTripPair (Triple !coin !ptr !pool) = - [ "coin" .= coin - , "ptr" .= ptr - , "pool" .= pool - ] - -instance Crypto.Crypto crypto => ToJSON (UnifiedMap crypto) where - toJSON = object . toUnifiedMapPair - toEncoding = Aeson.pairs . mconcat . toUnifiedMapPair - -toUnifiedMapPair :: - ( Aeson.KeyValue a - , ToJSON coin - , ToJSON ptr - , ToJSON pool - , ToJSON cred - , ToJSONKey cred - , ToJSONKey ptr - ) => UMap coin cred pool ptr -> [a] -toUnifiedMapPair (UnifiedMap !m1 !m2) = - [ "credentials" .= m1 - , "pointers" .= m2 - ] - -instance Crypto.Crypto crypto => ToJSON (Shelley.DState crypto) where - toJSON = object . toDStatePair - toEncoding = Aeson.pairs . mconcat . toDStatePair - -toDStatePair :: - ( Aeson.KeyValue a - , Crypto.Crypto crypto - ) => ShelleyLedger.DState crypto -> [a] -toDStatePair dState = - let !unifiedRewards = Shelley._unified dState - !fGenDelegs = Map.toList (Shelley._fGenDelegs dState) - !genDelegs = Shelley._genDelegs dState - !irwd = Shelley._irwd dState - in [ "unifiedRewards" .= unifiedRewards - , "fGenDelegs" .= fGenDelegs - , "genDelegs" .= genDelegs - , "irwd" .= irwd - ] - -instance Crypto.Crypto crypto => ToJSON (ShelleyLedger.FutureGenDeleg crypto) where - toJSON fGenDeleg = - object [ "fGenDelegSlot" .= ShelleyLedger.fGenDelegSlot fGenDeleg - , "fGenDelegGenKeyHash" .= ShelleyLedger.fGenDelegGenKeyHash fGenDeleg - ] - -instance Crypto.Crypto crypto => ToJSON (Shelley.GenDelegs crypto) where - toJSON (Shelley.GenDelegs delegs) = toJSON delegs - toEncoding (Shelley.GenDelegs delegs) = toEncoding delegs - -instance Crypto.Crypto crypto => ToJSON (Shelley.InstantaneousRewards crypto) where - toJSON = object . toInstantaneousRewardsPair - toEncoding = Aeson.pairs . mconcat . toInstantaneousRewardsPair - -toInstantaneousRewardsPair :: - ( Aeson.KeyValue a - , Crypto.Crypto crypto - ) => ShelleyLedger.InstantaneousRewards crypto -> [a] -toInstantaneousRewardsPair iRwds = - let !iRReserves = Shelley.iRReserves iRwds - !iRTreasury = Shelley.iRTreasury iRwds - in [ "iRReserves" .= iRReserves - , "iRTreasury" .= iRTreasury - ] - -instance - Crypto.Crypto crypto => - ToJSON (Bimap Shelley.Ptr (Shelley.Credential Shelley.Staking crypto)) - where - toJSON = object . toPtrCredentialStakingPair - toEncoding = Aeson.pairs . mconcat . toPtrCredentialStakingPair - -toPtrCredentialStakingPair :: - ( Aeson.KeyValue a - , Crypto.Crypto crypto - ) => Bimap Shelley.Ptr (Shelley.Credential Shelley.Staking crypto) -> [a] -toPtrCredentialStakingPair (MkBiMap ptsStakeM stakePtrSetM) = - let !stakedCreds = Map.toList ptsStakeM - !credPtrR = stakePtrSetM - in [ "stakedCreds" .= stakedCreds - , "credPtrR" .= credPtrR - ] - -deriving newtype instance ToJSON Shelley.CertIx -deriving newtype instance ToJSON Shelley.TxIx - -instance ToJSON Shelley.Ptr where - toJSON = object . toPtrPair - toEncoding = Aeson.pairs . mconcat . toPtrPair - -instance ToJSONKey Shelley.Ptr - -toPtrPair :: Aeson.KeyValue a => Shelley.Ptr -> [a] -toPtrPair (Shelley.Ptr !slotNo !txIndex !certIndex) = - [ "slot" .= unSlotNo slotNo - , "txIndex" .= txIndex - , "certIndex" .= certIndex - ] - - -instance Crypto.Crypto crypto => ToJSON (Shelley.PState crypto) where - toJSON = object . toPStatePair - toEncoding = Aeson.pairs . mconcat . toPStatePair - -toPStatePair :: - ( Aeson.KeyValue a - , Crypto.Crypto crypto - ) => ShelleyLedger.PState crypto -> [a] -toPStatePair pState = - let !pParams = Shelley._pParams pState - !fPParams = Shelley._fPParams pState - !retiring = Shelley._retiring pState - in [ "pParams pState" .= pParams - , "fPParams pState" .= fPParams - , "retiring pState" .= retiring - ] - -instance ( Consensus.ShelleyBasedEra era - , ToJSON (Core.TxOut era) - ) => ToJSON (Shelley.UTxO era) where - toJSON (Shelley.UTxO utxo) = toJSON utxo - toEncoding (Shelley.UTxO utxo) = toEncoding utxo - -instance ( Consensus.ShelleyBasedEra era - , ToJSON (Core.Value era) - ) => ToJSON (ShelleyTxOut era) where - toJSON = object . toTxOutPair - toEncoding = Aeson.pairs . mconcat . toTxOutPair - -toTxOutPair :: - ( Aeson.KeyValue a - , ToJSON (Core.Value era) - , EraTxOut era) - => ShelleyTxOut era -> [a] -toTxOutPair (ShelleyTxOut !addr !amount) = - [ "address" .= addr - , "amount" .= amount - ] - -instance Crypto.Crypto crypto => ToJSON (Shelley.TxIn crypto) where - toJSON = toJSON . txInToText - toEncoding = toEncoding . txInToText - -instance Crypto.Crypto crypto => ToJSONKey (Shelley.TxIn crypto) where - toJSONKey = toJSONKeyText txInToText - -txInToText :: Shelley.TxIn crypto -> Text -txInToText (Shelley.TxIn (Shelley.TxId txidHash) ix) = - hashToText (SafeHash.extractHash txidHash) - <> Text.pack "#" - <> Text.pack (show ix) - -hashToText :: Crypto.Hash crypto a -> Text -hashToText = Text.decodeLatin1 . Crypto.hashToBytesAsHex - -instance Crypto.Crypto crypto => ToJSON (Shelley.NonMyopic crypto) where - toJSON = object . toNonMyopicPair - toEncoding = Aeson.pairs . mconcat . toNonMyopicPair - -toNonMyopicPair :: - ( Aeson.KeyValue a - , Crypto.Crypto crypto - ) => Shelley.NonMyopic crypto -> [a] -toNonMyopicPair nonMy = - let !likelihoodsNM = Shelley.likelihoodsNM nonMy - !rewardPotNM = Shelley.rewardPotNM nonMy - in [ "likelihoodsNM" .= likelihoodsNM - , "rewardPotNM" .= rewardPotNM - ] - -instance ToJSON Shelley.Likelihood where - toJSON (Shelley.Likelihood llhd) = - toJSON $ fmap (\(Shelley.LogWeight f) -> exp $ realToFrac f :: Double) llhd - toEncoding (Shelley.Likelihood llhd) = - toEncoding $ fmap (\(Shelley.LogWeight f) -> exp $ realToFrac f :: Double) llhd - -instance Crypto.Crypto crypto => ToJSON (Shelley.SnapShots crypto) where - toJSON = object . toSnapShotsPair - toEncoding = Aeson.pairs . mconcat . toSnapShotsPair - -toSnapShotsPair :: - ( Aeson.KeyValue a - , Crypto.Crypto crypto - ) => ShelleyEpoch.SnapShots crypto -> [a] -toSnapShotsPair ss = - let !pstakeMark = Shelley._pstakeMark ss - !pstakeSet = Shelley._pstakeSet ss - !pstakeGo = Shelley._pstakeGo ss - !feeSS = Shelley._feeSS ss - in [ "pstakeMark" .= pstakeMark - , "pstakeSet" .= pstakeSet - , "pstakeGo" .= pstakeGo - , "feeSS" .= feeSS - ] - -instance Crypto.Crypto crypto => ToJSON (Shelley.SnapShot crypto) where - toJSON = object . toSnapShotPair - toEncoding = Aeson.pairs . mconcat . toSnapShotPair - -toSnapShotPair :: - ( Aeson.KeyValue a - , Crypto.Crypto crypto - ) => ShelleyEpoch.SnapShot crypto -> [a] -toSnapShotPair ss = - let !stake = Shelley._stake ss - !delegations = ShelleyEpoch._delegations ss - !poolParams = Shelley._poolParams ss - in [ "stake" .= stake - , "delegations" .= delegations - , "poolParams" .= poolParams - ] - -instance Crypto.Crypto crypto => ToJSON (Shelley.Stake crypto) where - toJSON (Shelley.Stake s) = toJSON s - toEncoding (Shelley.Stake s) = toEncoding s - -instance Crypto.Crypto crypto => ToJSON (Shelley.RewardUpdate crypto) where - toJSON = object . toRewardUpdatePair - toEncoding = Aeson.pairs . mconcat . toRewardUpdatePair - -toRewardUpdatePair :: - ( Aeson.KeyValue a - , Crypto.Crypto crypto - ) => Shelley.RewardUpdate crypto -> [a] -toRewardUpdatePair rUpdate = - let !deltaT = Shelley.deltaT rUpdate - !deltaR = Shelley.deltaR rUpdate - !rs = Shelley.rs rUpdate - !deltaF = Shelley.deltaF rUpdate - !nonMyopic = Shelley.nonMyopic rUpdate - in [ "deltaT" .= deltaT - , "deltaR" .= deltaR - , "rs" .= rs - , "deltaF" .= deltaF - , "nonMyopic" .= nonMyopic - ] - -instance Crypto.Crypto crypto => ToJSON (Shelley.PulsingRewUpdate crypto) where - toJSON = \case - Shelley.Pulsing _ _ -> Aeson.Null - Shelley.Complete ru -> toJSON ru - toEncoding = \case - Shelley.Pulsing _ _ -> toEncoding Aeson.Null - Shelley.Complete ru -> toEncoding ru - -instance ToJSON Shelley.DeltaCoin where - toJSON (Shelley.DeltaCoin i) = toJSON i - toEncoding (Shelley.DeltaCoin i) = toEncoding i - -instance Crypto.Crypto crypto => ToJSON (Ledger.PoolDistr crypto) where - toJSON (Ledger.PoolDistr m) = toJSON m - toEncoding (Ledger.PoolDistr m) = toEncoding m - -instance Crypto.Crypto crypto => ToJSON (Ledger.IndividualPoolStake crypto) where - toJSON = object . toIndividualPoolStakePair - toEncoding = Aeson.pairs . mconcat . toIndividualPoolStakePair - -toIndividualPoolStakePair :: - ( Aeson.KeyValue a - , Crypto.HashAlgorithm (Crypto.HASH crypto) - ) => Ledger.IndividualPoolStake crypto -> [a] -toIndividualPoolStakePair indivPoolStake = - let !individualPoolStake = Ledger.individualPoolStake indivPoolStake - !individualPoolStakeVrf = Ledger.individualPoolStakeVrf indivPoolStake - in [ "individualPoolStake" .= individualPoolStake - , "individualPoolStakeVrf" .= individualPoolStakeVrf - ] - -instance Crypto.Crypto crypto => ToJSON (Shelley.Reward crypto) where - toJSON = object . toRewardPair - toEncoding = Aeson.pairs . mconcat . toRewardPair - -toRewardPair :: - ( Aeson.KeyValue a - , Crypto.Crypto crypto - ) => Shelley.Reward crypto -> [a] -toRewardPair reward = - let !rewardType = Shelley.rewardType reward - !rewardPool = Shelley.rewardPool reward - !rewardAmount = Shelley.rewardAmount reward - in [ "rewardType" .= rewardType - , "rewardPool" .= rewardPool - , "rewardAmount" .= rewardAmount - ] - -instance ToJSON Shelley.RewardType where - toJSON Shelley.MemberReward = "MemberReward" - toJSON Shelley.LeaderReward = "LeaderReward" - -instance Crypto.Crypto c => ToJSON (SafeHash.SafeHash c a) where - toJSON = toJSON . SafeHash.extractHash - toEncoding = toEncoding . SafeHash.extractHash - ----- -deriving newtype instance ToJSON SystemStart -deriving newtype instance FromJSON SystemStart - - -instance Crypto.Crypto crypto => ToJSON (VMap VB VB (Shelley.Credential 'Shelley.Staking crypto) (Shelley.KeyHash 'Shelley.StakePool crypto)) where - toJSON = toJSON . VMap.toMap - toEncoding = toEncoding . VMap.toMap - -instance Crypto.Crypto crypto => ToJSON (VMap VB VB (Shelley.KeyHash 'Shelley.StakePool crypto) (Shelley.PoolParams crypto)) where - toJSON = toJSON . VMap.toMap - toEncoding = toEncoding . VMap.toMap - -instance Crypto.Crypto crypto => ToJSON (VMap VB VP (Shelley.Credential 'Shelley.Staking crypto) (Shelley.CompactForm Shelley.Coin)) where - toJSON = toJSON . fmap fromCompact . VMap.toMap - toEncoding = toEncoding . fmap fromCompact . VMap.toMap - instance Crypto.Crypto crypto => ToJSON (Consensus.StakeSnapshots crypto) where toJSON = object . stakeSnapshotsToPair toEncoding = pairs . mconcat . stakeSnapshotsToPair diff --git a/cardano-api/src/Cardano/Api/Script.hs b/cardano-api/src/Cardano/Api/Script.hs index f4f6c98d789..7380879e8a8 100644 --- a/cardano-api/src/Cardano/Api/Script.hs +++ b/cardano-api/src/Cardano/Api/Script.hs @@ -137,6 +137,7 @@ import qualified Cardano.Crypto.Hash.Class as Crypto import Cardano.Slotting.Slot (SlotNo) import Cardano.Ledger.BaseTypes (StrictMaybe (..)) +import Cardano.Ledger.Core (Era (EraCrypto)) import qualified Cardano.Ledger.Core as Ledger import qualified Cardano.Ledger.Allegra.Scripts as Timelock @@ -146,6 +147,7 @@ import Ouroboros.Consensus.Shelley.Eras (StandardCrypto) import qualified Cardano.Ledger.Alonzo.Language as Alonzo import qualified Cardano.Ledger.Alonzo.Scripts as Alonzo +import qualified Cardano.Ledger.Binary as Binary (decCBOR, decodeFullAnnotator, shelleyProtVer) import qualified PlutusLedgerApi.Test.Examples as Plutus @@ -1106,10 +1108,13 @@ data MultiSigError = MultiSigErrorTimelockNotsupported deriving Show -- | Conversion for the 'Shelley.MultiSig' language used by the Shelley era. -- -toShelleyMultiSig :: SimpleScript -> Either MultiSigError (Shelley.MultiSig StandardCrypto) +toShelleyMultiSig :: forall era. + (Era era, EraCrypto era ~ StandardCrypto) + => SimpleScript + -> Either MultiSigError (Shelley.MultiSig era) toShelleyMultiSig = go where - go :: SimpleScript -> Either MultiSigError (Shelley.MultiSig StandardCrypto) + go :: SimpleScript -> Either MultiSigError (Shelley.MultiSig era) go (RequireSignature (PaymentKeyHash kh)) = return $ Shelley.RequireSignature (Shelley.coerceKeyRole kh) go (RequireAllOf s) = mapM go s <&> Shelley.RequireAllOf @@ -1119,7 +1124,8 @@ toShelleyMultiSig = go -- | Conversion for the 'Shelley.MultiSig' language used by the Shelley era. -- -fromShelleyMultiSig :: Shelley.MultiSig StandardCrypto -> SimpleScript +fromShelleyMultiSig :: (Era era, EraCrypto era ~ StandardCrypto) + => Shelley.MultiSig era -> SimpleScript fromShelleyMultiSig = go where go (Shelley.RequireSignature kh) @@ -1132,10 +1138,12 @@ fromShelleyMultiSig = go -- | Conversion for the 'Timelock.Timelock' language that is shared between the -- Allegra and Mary eras. -- -toAllegraTimelock :: SimpleScript -> Timelock.Timelock StandardCrypto +toAllegraTimelock :: forall era lang. + (Era era, EraCrypto era ~ StandardCrypto) + => SimpleScript -> Timelock.Timelock era toAllegraTimelock = go where - go :: SimpleScript -> Timelock.Timelock StandardCrypto + go :: SimpleScript -> Timelock.Timelock era go (RequireSignature (PaymentKeyHash kh)) = Timelock.RequireSignature (Shelley.coerceKeyRole kh) go (RequireAllOf s) = Timelock.RequireAllOf (Seq.fromList (map go s)) @@ -1147,7 +1155,8 @@ toAllegraTimelock = go -- | Conversion for the 'Timelock.Timelock' language that is shared between the -- Allegra and Mary eras. -- -fromAllegraTimelock :: Timelock.Timelock StandardCrypto -> SimpleScript +fromAllegraTimelock :: (Era era, EraCrypto era ~ StandardCrypto) + => Timelock.Timelock era -> SimpleScript fromAllegraTimelock = go where go (Timelock.RequireSignature kh) = RequireSignature diff --git a/cardano-api/src/Cardano/Api/Value.hs b/cardano-api/src/Cardano/Api/Value.hs index 56e4996cb9a..e86a0503c48 100644 --- a/cardano-api/src/Cardano/Api/Value.hs +++ b/cardano-api/src/Cardano/Api/Value.hs @@ -85,7 +85,7 @@ import Cardano.Api.SerialiseUsing import Cardano.Api.Utils (failEitherWith) import Cardano.Ledger.Mary.Value (MaryValue (..)) import qualified Cardano.Ledger.Mary.Value as Mary -import qualified Cardano.Ledger.ShelleyMA.Rules as Shelley +import Cardano.Ledger.Mary.TxOut as Mary (scaledMinDeposit) -- ---------------------------------------------------------------------------- -- Lovelace @@ -266,13 +266,11 @@ valueToLovelace v = toMaryValue :: Value -> MaryValue StandardCrypto toMaryValue v = - MaryValue lovelace other + Mary.valueFromList lovelace other where Quantity lovelace = selectAsset v AdaAssetId - --TODO: write QC tests to show it's ok to use Map.fromAscListWith here - other = Map.fromListWith Map.union - [ (toMaryPolicyID pid, Map.singleton (toMaryAssetName name) q) - | (AssetId pid name, Quantity q) <- valueToList v ] + other = [ (toMaryPolicyID pid, toMaryAssetName name, q) + | (AssetId pid name, Quantity q) <- valueToList v ] toMaryPolicyID :: PolicyId -> Mary.PolicyID StandardCrypto toMaryPolicyID (PolicyId sh) = Mary.PolicyID (toShelleyScriptHash sh) @@ -288,8 +286,7 @@ fromMaryValue (MaryValue lovelace other) = Map.fromList $ [ (AdaAssetId, Quantity lovelace) | lovelace /= 0 ] ++ [ (AssetId (fromMaryPolicyID pid) (fromMaryAssetName name), Quantity q) - | (pid, as) <- Map.toList other - , (name, q) <- Map.toList as ] + | (pid, name, q) <- Mary.flattenMultiAsset other ] where fromMaryPolicyID :: Mary.PolicyID StandardCrypto -> PolicyId fromMaryPolicyID (Mary.PolicyID sh) = PolicyId (fromShelleyScriptHash sh) @@ -301,7 +298,7 @@ fromMaryValue (MaryValue lovelace other) = -- mininimum UTxO value derived from the 'ProtocolParameters' calcMinimumDeposit :: Value -> Lovelace -> Lovelace calcMinimumDeposit v minUTxo = - fromShelleyLovelace $ Shelley.scaledMinDeposit (toMaryValue v) (toShelleyLovelace minUTxo) + fromShelleyLovelace $ Mary.scaledMinDeposit (toMaryValue v) (toShelleyLovelace minUTxo) -- ---------------------------------------------------------------------------- -- An alternative nested representation From f37e30dc99c45c2cf742a172a49a8a33f154f14b Mon Sep 17 00:00:00 2001 From: Alexey Kuleshevich Date: Fri, 3 Mar 2023 02:23:02 +0300 Subject: [PATCH 07/38] PParams are done --- cabal.project | 76 +- cardano-api/ChangeLog.md | 4 + cardano-api/cardano-api.cabal | 25 +- .../src/Cardano/Api/GenesisParameters.hs | 9 +- .../src/Cardano/Api/ProtocolParameters.hs | 1317 +++++++---------- cardano-cli/cardano-cli.cabal | 10 +- cardano-node/cardano-node.cabal | 2 +- 7 files changed, 571 insertions(+), 872 deletions(-) diff --git a/cabal.project b/cabal.project index 6bf5c8f455e..7b7cb35fbed 100644 --- a/cabal.project +++ b/cabal.project @@ -94,7 +94,7 @@ allow-newer: -- ekg does not suport newer snap , ekg:snap-server , ekg:snap-core - -- cardano-node-capi depends on aeson > 2.1, even our patched ekg-json only + -- cardano-node-capi depends on aeson > 2.1, even our patched ekg-json only -- supports between 2 and 2.1 , ekg-json:aeson -- These are currently required for 9.2. @@ -113,8 +113,8 @@ allow-newer: source-repository-package type: git location: https://github.com/input-output-hk/ouroboros-network - tag: 321472170618560f56565c2459e3ac0892b1fe2e - --sha256: 1i5h28ris135b6gi94y1ccnf80bkhhjxhsvncngpsxmbz2dl7rdj + tag: f6bc60dff6a4a7c49ec909d2db80a6277c177d0b + --sha256: 09mp5ivjlvkix9f2vab046832as7mfqdhylvp9qc75g1mw8i2vnr subdir: monoidal-synchronisation network-mux @@ -128,6 +128,7 @@ source-repository-package ouroboros-network-testing ouroboros-network-protocols ouroboros-consensus-cardano-tools + ouroboros-consensus-diffusion -- Waiting for proper Windows ghc-9.2 release. source-repository-package @@ -136,37 +137,38 @@ source-repository-package tag: b87b2ffa52bf58867a7239ebe74f61b1a2c762d2 --sha256: 0ndm57z5zpxd5n8s47kh8k1jfqf3b78qv7gkgrx9wwaajs9bf196 --- source-repository-package --- type: git --- location: https://github.com/input-output-hk/cardano-ledger --- tag: 66b1490467b512bab88552f7c2bb7f36d6adfa53 --- --sha256: 1y3x0nz0bcndhwdn1h4qgxjmgvymy0in6rs3nvy4avz8hrij7rj9 --- subdir: --- eras/alonzo/impl --- eras/alonzo/test-suite --- eras/allegra/impl --- eras/babbage/impl --- eras/babbage/test-suite --- eras/byron/chain/executable-spec --- eras/byron/crypto --- eras/byron/crypto/test --- eras/byron/ledger/executable-spec --- eras/byron/ledger/impl --- eras/byron/ledger/impl/test --- eras/conway/impl --- eras/conway/test-suite --- eras/mary/impl --- eras/shelley-ma/impl --- eras/shelley-ma/test-suite --- eras/shelley/impl --- eras/shelley/test-suite --- libs/cardano-data --- libs/cardano-ledger-binary --- libs/cardano-ledger-core --- libs/cardano-ledger-pretty --- libs/cardano-protocol-tpraos --- libs/non-integral --- libs/set-algebra --- libs/small-steps --- libs/small-steps-test --- libs/vector-map +source-repository-package + type: git + location: https://github.com/input-output-hk/cardano-ledger + tag: 94425510a75bd61336e8e819e2521799575d7185 + --sha256: 15afwiqkja60pd2g6zjpvf131px38kb8zi3hcrfkxpxfapnkgq5v + subdir: + eras/alonzo/impl + eras/alonzo/test-suite + eras/allegra/impl + eras/babbage/impl + eras/babbage/test-suite + eras/byron/chain/executable-spec + eras/byron/crypto + eras/byron/crypto/test + eras/byron/ledger/executable-spec + eras/byron/ledger/impl + eras/byron/ledger/impl/test + eras/conway/impl + eras/conway/test-suite + eras/mary/impl + eras/shelley-ma/impl + eras/shelley-ma/test-suite + eras/shelley/impl + eras/shelley/test-suite + libs/cardano-data + libs/cardano-ledger-api + libs/cardano-ledger-binary + libs/cardano-ledger-core + libs/cardano-ledger-pretty + libs/cardano-protocol-tpraos + libs/non-integral + libs/set-algebra + libs/small-steps + libs/small-steps-test + libs/vector-map diff --git a/cardano-api/ChangeLog.md b/cardano-api/ChangeLog.md index 1f2953f0c8e..a61c9f1b7b3 100644 --- a/cardano-api/ChangeLog.md +++ b/cardano-api/ChangeLog.md @@ -4,6 +4,10 @@ ### Features +- Changed type of `protocolParamTxFeeFixed`, `protocolParamTxFeePerByte` from `Natural` to + `Lovelace` and `protocolUpdateTxFeeFixed` and `protocolUpdateTxFeePerByte` from `Maybe + Natural` to `Maybe Lovelace` + - Append, not prepend change output when balancing a transaction ([PR 4343](https://github.com/input-output-hk/cardano-node/pull/4343)) - Expose convenience functions `executeQueryCardanoMode`, `determineEra`, `constructBalancedTx` and `queryStateForBalancedTx` ([PR 4446](https://github.com/input-output-hk/cardano-node/pull/4446)) diff --git a/cardano-api/cardano-api.cabal b/cardano-api/cardano-api.cabal index a1064c233ea..f8884cd5df2 100644 --- a/cardano-api/cardano-api.cabal +++ b/cardano-api/cardano-api.cabal @@ -119,14 +119,15 @@ library , cardano-crypto-class ^>= 2.1 , cardano-crypto-wrapper ^>= 1.5 , cardano-data ^>= 1.0 - , cardano-ledger-alonzo ^>= 1.0 - , cardano-ledger-allegra ^>= 1.0 - , cardano-ledger-babbage ^>= 1.0 - , cardano-ledger-binary ^>= 1.0 + , cardano-ledger-alonzo ^>= 1.1 + , cardano-ledger-allegra ^>= 1.1 + , cardano-ledger-api >= 1.0 + , cardano-ledger-babbage ^>= 1.1 + , cardano-ledger-binary ^>= 1.0.1 , cardano-ledger-byron ^>= 1.0 - , cardano-ledger-core ^>= 1.0 - , cardano-ledger-mary ^>= 1.0 - , cardano-ledger-shelley ^>= 1.0 + , cardano-ledger-core ^>= 1.1 + , cardano-ledger-mary ^>= 1.1 + , cardano-ledger-shelley ^>= 1.1 , cardano-protocol-tpraos >= 1.0 , cardano-slotting >= 0.1 , cardano-strict-containers ^>= 0.1 @@ -196,11 +197,11 @@ library gen , cardano-binary ^>= 1.6 , cardano-crypto-class ^>= 2.1 , cardano-crypto-test ^>= 1.5 - , cardano-ledger-alonzo ^>= 1.0 + , cardano-ledger-alonzo ^>= 1.1 , cardano-ledger-alonzo-test , cardano-ledger-byron-test ^>= 1.5 - , cardano-ledger-core ^>= 1.0 - , cardano-ledger-shelley ^>= 1.0 + , cardano-ledger-core ^>= 1.1 + , cardano-ledger-shelley ^>= 1.1 , containers , hedgehog , text @@ -220,8 +221,8 @@ test-suite cardano-api-test , cardano-crypto-class ^>= 2.1 , cardano-crypto-test ^>= 1.5 , cardano-crypto-tests ^>= 2.1 - , cardano-ledger-core ^>= 1.0 - , cardano-ledger-shelley ^>= 1.0 + , cardano-ledger-core ^>= 1.1 + , cardano-ledger-shelley ^>= 1.1 , cardano-ledger-shelley-test ^>= 1.0 , cardano-slotting ^>= 0.1 , containers diff --git a/cardano-api/src/Cardano/Api/GenesisParameters.hs b/cardano-api/src/Cardano/Api/GenesisParameters.hs index bd26bd43422..fbf22dd4947 100644 --- a/cardano-api/src/Cardano/Api/GenesisParameters.hs +++ b/cardano-api/src/Cardano/Api/GenesisParameters.hs @@ -21,8 +21,10 @@ import Data.Time (NominalDiffTime, UTCTime) import Cardano.Slotting.Slot (EpochSize (..)) import qualified Cardano.Ledger.BaseTypes as Ledger +import qualified Cardano.Ledger.Crypto as Ledger import qualified Cardano.Ledger.Shelley.Genesis as Shelley +import Cardano.Api.Eras (ShelleyBasedEra (ShelleyBasedEraShelley)) import Cardano.Api.NetworkId import Cardano.Api.ProtocolParameters import Cardano.Api.Value @@ -99,7 +101,7 @@ data GenesisParameters = -- Conversion functions -- -fromShelleyGenesis :: Shelley.ShelleyGenesis era -> GenesisParameters +fromShelleyGenesis :: Shelley.ShelleyGenesis Ledger.StandardCrypto -> GenesisParameters fromShelleyGenesis Shelley.ShelleyGenesis { Shelley.sgSystemStart @@ -126,12 +128,13 @@ fromShelleyGenesis sgActiveSlotsCoeff , protocolParamSecurity = fromIntegral sgSecurityParam , protocolParamEpochLength = sgEpochLength - , protocolParamSlotLength = sgSlotLength + , protocolParamSlotLength = Shelley.fromNominalDiffTimeMicro sgSlotLength , protocolParamSlotsPerKESPeriod = fromIntegral sgSlotsPerKESPeriod , protocolParamMaxKESEvolutions = fromIntegral sgMaxKESEvolutions , protocolParamUpdateQuorum = fromIntegral sgUpdateQuorum , protocolParamMaxLovelaceSupply = Lovelace (fromIntegral sgMaxLovelaceSupply) - , protocolInitialUpdateableProtocolParameters = fromShelleyPParams + , protocolInitialUpdateableProtocolParameters = fromLedgerPParams + ShelleyBasedEraShelley sgProtocolParams } diff --git a/cardano-api/src/Cardano/Api/ProtocolParameters.hs b/cardano-api/src/Cardano/Api/ProtocolParameters.hs index 02acaec2479..b592f3b61d0 100644 --- a/cardano-api/src/Cardano/Api/ProtocolParameters.hs +++ b/cardano-api/src/Cardano/Api/ProtocolParameters.hs @@ -41,7 +41,6 @@ module Cardano.Api.ProtocolParameters ( ExecutionUnits(..), ExecutionUnitPrices(..), CostModel(..), - validateCostModel, fromAlonzoCostModels, -- * Update proposals to change the protocol parameters @@ -55,8 +54,11 @@ module Cardano.Api.ProtocolParameters ( toLedgerProposedPPUpdates, fromLedgerProposedPPUpdates, toLedgerPParams, + toLedgerPParamsEither, + toLedgerPParamsUpdate, + toLedgerPParamsUpdateEither, fromLedgerPParams, - fromShelleyPParams, + fromLedgerPParamsUpdate, toAlonzoPrices, fromAlonzoPrices, toAlonzoScriptLanguage, @@ -64,15 +66,11 @@ module Cardano.Api.ProtocolParameters ( toAlonzoCostModel, fromAlonzoCostModel, toAlonzoCostModels, - toAlonzoPParams, - toBabbagePParams, - toConwayPParams, -- * Data family instances AsType(..), ) where -import Control.Applicative ((<|>)) import Control.Monad import Data.Aeson (FromJSON (..), ToJSON (..), object, withObject, (.!=), (.:), (.:?), (.=)) @@ -81,10 +79,11 @@ import Data.ByteString (ByteString) import Data.Either.Combinators (maybeToRight) import Data.Map.Strict (Map) import qualified Data.Map.Strict as Map -import Data.Maybe (fromMaybe, isJust) +import Data.Maybe (isJust) +import Data.Maybe.Strict (StrictMaybe(..)) import Data.String (IsString) -import Data.Text (Text) import GHC.Generics +import Lens.Micro import Numeric.Natural import Cardano.Api.Json (toRationalJSON) @@ -92,8 +91,8 @@ import qualified Cardano.Binary as CBOR import qualified Cardano.Crypto.Hash.Class as Crypto import Cardano.Slotting.Slot (EpochNo) -import Cardano.Ledger.Babbage.PParams (BabbagePParams, BabbagePParamsHKD (..), - BabbagePParamsUpdate) +import qualified Cardano.Ledger.Api.Era as Ledger +import Cardano.Ledger.Api.PParams import Cardano.Ledger.BaseTypes (strictMaybeToMaybe) import qualified Cardano.Ledger.BaseTypes as Ledger import qualified Cardano.Ledger.Core as Ledger @@ -105,12 +104,9 @@ import qualified Cardano.Ledger.Keys as Ledger -- So we import in twice under different names. import qualified Cardano.Ledger.Alonzo.Language as Alonzo -import Cardano.Ledger.Alonzo.PParams (AlonzoPParams, AlonzoPParamsHKD (..), - AlonzoPParamsUpdate) +--import Cardano.Ledger.Alonzo.PParams () import qualified Cardano.Ledger.Alonzo.Scripts as Alonzo -import qualified Cardano.Ledger.Shelley.API as Ledger hiding (PParams) -import Cardano.Ledger.Shelley.PParams (ShelleyPParams, ShelleyPParamsHKD (..), - ShelleyPParamsUpdate) +import qualified Cardano.Ledger.Shelley.API as Ledger import Text.PrettyBy.Default (display) @@ -202,11 +198,11 @@ data ProtocolParameters = -- | The constant factor for the minimum fee calculation. -- - protocolParamTxFeeFixed :: Natural, + protocolParamTxFeeFixed :: Lovelace, -- | The linear factor for the minimum fee calculation. -- - protocolParamTxFeePerByte :: Natural, + protocolParamTxFeePerByte :: Lovelace, -- | The minimum permitted value for new UTxO entries, ie for -- transaction outputs. @@ -437,11 +433,11 @@ data ProtocolParametersUpdate = -- | The constant factor for the minimum fee calculation. -- - protocolUpdateTxFeeFixed :: Maybe Natural, + protocolUpdateTxFeeFixed :: Maybe Lovelace, -- | The linear factor for the minimum fee calculation. -- - protocolUpdateTxFeePerByte :: Maybe Natural, + protocolUpdateTxFeePerByte :: Maybe Lovelace, -- | The minimum permitted value for new UTxO entries, ie for -- transaction outputs. @@ -755,13 +751,13 @@ instance FromJSON ExecutionUnitPrices where <*> o .: "priceMemory" -toAlonzoPrices :: ExecutionUnitPrices -> Maybe Alonzo.Prices +toAlonzoPrices :: ExecutionUnitPrices -> Either String Alonzo.Prices toAlonzoPrices ExecutionUnitPrices { priceExecutionSteps, priceExecutionMemory } = do - prSteps <- Ledger.boundRational priceExecutionSteps - prMem <- Ledger.boundRational priceExecutionMemory + prSteps <- boundRationalEither "Steps" priceExecutionSteps + prMem <- boundRationalEither "Mem" priceExecutionMemory return Alonzo.Prices { Alonzo.prSteps, Alonzo.prMem @@ -779,21 +775,11 @@ fromAlonzoPrices Alonzo.Prices{Alonzo.prSteps, Alonzo.prMem} = -- Script cost models -- -newtype CostModel = CostModel (Map Text Integer) +newtype CostModel = CostModel [Integer] --(Map Text Integer) deriving (Eq, Show) deriving newtype (ToJSON, FromJSON) deriving newtype (ToCBOR, FromCBOR) -validateCostModel :: PlutusScriptVersion lang - -> CostModel - -> Either InvalidCostModel () -validateCostModel PlutusScriptV1 (CostModel m) = - first (InvalidCostModel (CostModel m)) - $ Alonzo.assertWellFormedCostModelParams m -validateCostModel PlutusScriptV2 (CostModel m) = - first (InvalidCostModel (CostModel m)) - $ Alonzo.assertWellFormedCostModelParams m - -- TODO alonzo: it'd be nice if the library told us what was wrong data InvalidCostModel = InvalidCostModel CostModel Alonzo.CostModelApplyError deriving Show @@ -809,10 +795,10 @@ toAlonzoCostModels -> Either String Alonzo.CostModels toAlonzoCostModels m = do f <- mapM conv $ Map.toList m - Right . Alonzo.CostModels $ Map.fromList f + Right (Alonzo.emptyCostModels { Alonzo.costModelsValid = Map.fromList f }) where conv :: (AnyPlutusScriptVersion, CostModel) -> Either String (Alonzo.Language, Alonzo.CostModel) - conv (anySVer, cModel )= do + conv (anySVer, cModel) = do -- TODO: Propagate InvalidCostModel further alonzoCostModel <- first displayError $ toAlonzoCostModel cModel (toAlonzoScriptLanguage anySVer) Right (toAlonzoScriptLanguage anySVer, alonzoCostModel) @@ -820,7 +806,7 @@ toAlonzoCostModels m = do fromAlonzoCostModels :: Alonzo.CostModels -> Map AnyPlutusScriptVersion CostModel -fromAlonzoCostModels (Alonzo.CostModels m)= +fromAlonzoCostModels (Alonzo.CostModels m _ _) = Map.fromList . map (bimap fromAlonzoScriptLanguage fromAlonzoCostModel) $ Map.toList m @@ -888,7 +874,7 @@ makeShelleyUpdateProposal params genesisKeyHashes = toLedgerUpdate :: forall era ledgerera. ShelleyLedgerEra era ~ ledgerera - => Ledger.Crypto ledgerera ~ StandardCrypto + => Ledger.EraCrypto ledgerera ~ StandardCrypto => ShelleyBasedEra era -> UpdateProposal -> Ledger.Update ledgerera @@ -898,7 +884,7 @@ toLedgerUpdate era (UpdateProposal ppup epochno) = toLedgerProposedPPUpdates :: forall era ledgerera. ShelleyLedgerEra era ~ ledgerera - => Ledger.Crypto ledgerera ~ StandardCrypto + => Ledger.EraCrypto ledgerera ~ StandardCrypto => ShelleyBasedEra era -> Map (Hash GenesisKey) ProtocolParametersUpdate -> Ledger.ProposedPPUpdates ledgerera @@ -907,33 +893,34 @@ toLedgerProposedPPUpdates era = . Map.mapKeysMonotonic (\(GenesisKeyHash kh) -> kh) . Map.map (toLedgerPParamsUpdate era) - +-- TODO: Stop using partial function and switch to the Either String variant toLedgerPParamsUpdate :: ShelleyBasedEra era - -> ProtocolParametersUpdate - -> Ledger.PParamsUpdate (ShelleyLedgerEra era) -toLedgerPParamsUpdate ShelleyBasedEraShelley = toShelleyPParamsUpdate -toLedgerPParamsUpdate ShelleyBasedEraAllegra = toShelleyPParamsUpdate -toLedgerPParamsUpdate ShelleyBasedEraMary = toShelleyPParamsUpdate -toLedgerPParamsUpdate ShelleyBasedEraAlonzo = toAlonzoPParamsUpdate -toLedgerPParamsUpdate ShelleyBasedEraBabbage = toBabbagePParamsUpdate -toLedgerPParamsUpdate ShelleyBasedEraConway = toConwayPParamsUpdate - - ---TODO: we should do validation somewhere, not just silently drop changes that --- are not valid. Specifically, see Ledger.boundRational below. -toShelleyPParamsUpdate :: ProtocolParametersUpdate - -> ShelleyPParamsUpdate ledgerera -toShelleyPParamsUpdate + -> ProtocolParametersUpdate + -> Ledger.PParamsUpdate (ShelleyLedgerEra era) +toLedgerPParamsUpdate sbe = either error id . toLedgerPParamsUpdateEither sbe + +toLedgerPParamsUpdateEither :: ShelleyBasedEra era + -> ProtocolParametersUpdate + -> Either String (PParamsUpdate (ShelleyLedgerEra era)) +toLedgerPParamsUpdateEither ShelleyBasedEraShelley = toShelleyPParamsUpdate +toLedgerPParamsUpdateEither ShelleyBasedEraAllegra = toShelleyPParamsUpdate +toLedgerPParamsUpdateEither ShelleyBasedEraMary = toShelleyPParamsUpdate +toLedgerPParamsUpdateEither ShelleyBasedEraAlonzo = toAlonzoPParamsUpdate +toLedgerPParamsUpdateEither ShelleyBasedEraBabbage = toBabbagePParamsUpdate +toLedgerPParamsUpdateEither ShelleyBasedEraConway = toConwayPParamsUpdate + + +toShelleyCommonPParamsUpdate :: EraPParams ledgerera + => ProtocolParametersUpdate + -> Either String (PParamsUpdate ledgerera) +toShelleyCommonPParamsUpdate ProtocolParametersUpdate { protocolUpdateProtocolVersion - , protocolUpdateDecentralization - , protocolUpdateExtraPraosEntropy , protocolUpdateMaxBlockHeaderSize , protocolUpdateMaxBlockBodySize , protocolUpdateMaxTxSize , protocolUpdateTxFeeFixed , protocolUpdateTxFeePerByte - , protocolUpdateMinUTxOValue , protocolUpdateStakeAddressDeposit , protocolUpdateStakePoolDeposit , protocolUpdateMinPoolCost @@ -942,180 +929,148 @@ toShelleyPParamsUpdate , protocolUpdatePoolPledgeInfluence , protocolUpdateMonetaryExpansion , protocolUpdateTreasuryCut - } = - ShelleyPParams { - _minfeeA = noInlineMaybeToStrictMaybe protocolUpdateTxFeePerByte - , _minfeeB = noInlineMaybeToStrictMaybe protocolUpdateTxFeeFixed - , _maxBBSize = noInlineMaybeToStrictMaybe protocolUpdateMaxBlockBodySize - , _maxTxSize = noInlineMaybeToStrictMaybe protocolUpdateMaxTxSize - , _maxBHSize = noInlineMaybeToStrictMaybe protocolUpdateMaxBlockHeaderSize - , _keyDeposit = toShelleyLovelace <$> - noInlineMaybeToStrictMaybe protocolUpdateStakeAddressDeposit - , _poolDeposit = toShelleyLovelace <$> - noInlineMaybeToStrictMaybe protocolUpdateStakePoolDeposit - , _eMax = noInlineMaybeToStrictMaybe protocolUpdatePoolRetireMaxEpoch - , _nOpt = noInlineMaybeToStrictMaybe protocolUpdateStakePoolTargetNum - , _a0 = noInlineMaybeToStrictMaybe $ Ledger.boundRational =<< - protocolUpdatePoolPledgeInfluence - , _rho = noInlineMaybeToStrictMaybe $ Ledger.boundRational =<< - protocolUpdateMonetaryExpansion - , _tau = noInlineMaybeToStrictMaybe $ Ledger.boundRational =<< - protocolUpdateTreasuryCut - , _d = noInlineMaybeToStrictMaybe $ Ledger.boundRational =<< - protocolUpdateDecentralization - , _extraEntropy = toLedgerNonce <$> - noInlineMaybeToStrictMaybe protocolUpdateExtraPraosEntropy - , _protocolVersion = uncurry Ledger.ProtVer <$> - noInlineMaybeToStrictMaybe protocolUpdateProtocolVersion - , _minUTxOValue = toShelleyLovelace <$> - noInlineMaybeToStrictMaybe protocolUpdateMinUTxOValue - , _minPoolCost = toShelleyLovelace <$> - noInlineMaybeToStrictMaybe protocolUpdateMinPoolCost - } - - -toAlonzoPParamsUpdate :: ProtocolParametersUpdate - -> AlonzoPParamsUpdate ledgerera -toAlonzoPParamsUpdate - ProtocolParametersUpdate { - protocolUpdateProtocolVersion - , protocolUpdateDecentralization + } = do + a0 <- mapM (boundRationalEither "A0") protocolUpdatePoolPledgeInfluence + rho <- mapM (boundRationalEither "Rho") protocolUpdateMonetaryExpansion + tau <- mapM (boundRationalEither "Tau") protocolUpdateTreasuryCut + protVer <- mapM mkProtVer protocolUpdateProtocolVersion + let ppuCommon = + emptyPParamsUpdate + & ppuMinFeeAL .~ + (toShelleyLovelace <$> noInlineMaybeToStrictMaybe protocolUpdateTxFeePerByte) + & ppuMinFeeBL .~ + (toShelleyLovelace <$> noInlineMaybeToStrictMaybe protocolUpdateTxFeeFixed) + & ppuMaxBBSizeL .~ noInlineMaybeToStrictMaybe protocolUpdateMaxBlockBodySize + & ppuMaxTxSizeL .~ noInlineMaybeToStrictMaybe protocolUpdateMaxTxSize + & ppuMaxBHSizeL .~ noInlineMaybeToStrictMaybe protocolUpdateMaxBlockHeaderSize + & ppuKeyDepositL .~ + (toShelleyLovelace <$> noInlineMaybeToStrictMaybe protocolUpdateStakeAddressDeposit) + & ppuPoolDepositL .~ + (toShelleyLovelace <$> noInlineMaybeToStrictMaybe protocolUpdateStakePoolDeposit) + & ppuEMaxL .~ noInlineMaybeToStrictMaybe protocolUpdatePoolRetireMaxEpoch + & ppuNOptL .~ noInlineMaybeToStrictMaybe protocolUpdateStakePoolTargetNum + & ppuA0L .~ noInlineMaybeToStrictMaybe a0 + + & ppuRhoL .~ noInlineMaybeToStrictMaybe rho + & ppuTauL .~ noInlineMaybeToStrictMaybe tau + & ppuProtocolVersionL .~ noInlineMaybeToStrictMaybe protVer + & ppuMinPoolCostL .~ + (toShelleyLovelace <$> noInlineMaybeToStrictMaybe protocolUpdateMinPoolCost) + pure ppuCommon + +toShelleyPParamsUpdate :: ( EraPParams ledgerera + , Ledger.AtMostEra Ledger.MaryEra ledgerera + , Ledger.AtMostEra Ledger.AlonzoEra ledgerera + ) + => ProtocolParametersUpdate + -> Either String (PParamsUpdate ledgerera) +toShelleyPParamsUpdate + protocolParametersUpdate@ProtocolParametersUpdate { + protocolUpdateDecentralization , protocolUpdateExtraPraosEntropy - , protocolUpdateMaxBlockHeaderSize - , protocolUpdateMaxBlockBodySize - , protocolUpdateMaxTxSize - , protocolUpdateTxFeeFixed - , protocolUpdateTxFeePerByte - , protocolUpdateStakeAddressDeposit - , protocolUpdateStakePoolDeposit - , protocolUpdateMinPoolCost - , protocolUpdatePoolRetireMaxEpoch - , protocolUpdateStakePoolTargetNum - , protocolUpdatePoolPledgeInfluence - , protocolUpdateMonetaryExpansion - , protocolUpdateTreasuryCut - , protocolUpdateUTxOCostPerWord - , protocolUpdateCostModels + , protocolUpdateMinUTxOValue + } = do + ppuCommon <- toShelleyCommonPParamsUpdate protocolParametersUpdate + d <- mapM (boundRationalEither "D") protocolUpdateDecentralization + let ppuShelley = + ppuCommon + & ppuDL .~ noInlineMaybeToStrictMaybe d + & ppuExtraEntropyL .~ + (toLedgerNonce <$> noInlineMaybeToStrictMaybe protocolUpdateExtraPraosEntropy) + & ppuMinUTxOValueL .~ + (toShelleyLovelace <$> noInlineMaybeToStrictMaybe protocolUpdateMinUTxOValue) + pure ppuShelley + + +toAlonzoCommonPParamsUpdate :: AlonzoEraPParams ledgerera + => ProtocolParametersUpdate + -> Either String (PParamsUpdate ledgerera) +toAlonzoCommonPParamsUpdate + protocolParametersUpdate@ProtocolParametersUpdate { + protocolUpdateCostModels , protocolUpdatePrices , protocolUpdateMaxTxExUnits , protocolUpdateMaxBlockExUnits , protocolUpdateMaxValueSize , protocolUpdateCollateralPercent , protocolUpdateMaxCollateralInputs - } = - AlonzoPParams { - _minfeeA = noInlineMaybeToStrictMaybe protocolUpdateTxFeePerByte - , _minfeeB = noInlineMaybeToStrictMaybe protocolUpdateTxFeeFixed - , _maxBBSize = noInlineMaybeToStrictMaybe protocolUpdateMaxBlockBodySize - , _maxTxSize = noInlineMaybeToStrictMaybe protocolUpdateMaxTxSize - , _maxBHSize = noInlineMaybeToStrictMaybe protocolUpdateMaxBlockHeaderSize - , _keyDeposit = toShelleyLovelace <$> - noInlineMaybeToStrictMaybe protocolUpdateStakeAddressDeposit - , _poolDeposit = toShelleyLovelace <$> - noInlineMaybeToStrictMaybe protocolUpdateStakePoolDeposit - , _eMax = noInlineMaybeToStrictMaybe protocolUpdatePoolRetireMaxEpoch - , _nOpt = noInlineMaybeToStrictMaybe protocolUpdateStakePoolTargetNum - , _a0 = noInlineMaybeToStrictMaybe $ Ledger.boundRational =<< - protocolUpdatePoolPledgeInfluence - , _rho = noInlineMaybeToStrictMaybe $ Ledger.boundRational =<< - protocolUpdateMonetaryExpansion - , _tau = noInlineMaybeToStrictMaybe $ Ledger.boundRational =<< - protocolUpdateTreasuryCut - , _d = noInlineMaybeToStrictMaybe $ Ledger.boundRational =<< - protocolUpdateDecentralization - , _extraEntropy = toLedgerNonce <$> - noInlineMaybeToStrictMaybe protocolUpdateExtraPraosEntropy - , _protocolVersion = uncurry Ledger.ProtVer <$> - noInlineMaybeToStrictMaybe protocolUpdateProtocolVersion - , _minPoolCost = toShelleyLovelace <$> - noInlineMaybeToStrictMaybe protocolUpdateMinPoolCost - , _coinsPerUTxOWord = toShelleyLovelace <$> - noInlineMaybeToStrictMaybe protocolUpdateUTxOCostPerWord - , _costmdls = if Map.null protocolUpdateCostModels - then Ledger.SNothing - else either (const Ledger.SNothing) Ledger.SJust - (toAlonzoCostModels protocolUpdateCostModels) - , _prices = noInlineMaybeToStrictMaybe $ - toAlonzoPrices =<< protocolUpdatePrices - , _maxTxExUnits = toAlonzoExUnits <$> - noInlineMaybeToStrictMaybe protocolUpdateMaxTxExUnits - , _maxBlockExUnits = toAlonzoExUnits <$> - noInlineMaybeToStrictMaybe protocolUpdateMaxBlockExUnits - , _maxValSize = noInlineMaybeToStrictMaybe protocolUpdateMaxValueSize - , _collateralPercentage = noInlineMaybeToStrictMaybe protocolUpdateCollateralPercent - , _maxCollateralInputs = noInlineMaybeToStrictMaybe protocolUpdateMaxCollateralInputs - } - --- Decentralization and extra entropy are deprecated in Babbage -toBabbagePParamsUpdate :: ProtocolParametersUpdate - -> BabbagePParamsUpdate ledgerera + } = do + ppuShelleyCommon <- toShelleyCommonPParamsUpdate protocolParametersUpdate + costModels <- + if Map.null protocolUpdateCostModels + then pure SNothing + else SJust <$> toAlonzoCostModels protocolUpdateCostModels + prices <- mapM toAlonzoPrices protocolUpdatePrices + let ppuAlonzoCommon = + ppuShelleyCommon + & ppuCostModelsL .~ costModels + & ppuPricesL .~ noInlineMaybeToStrictMaybe prices + & ppuMaxTxExUnitsL .~ + (toAlonzoExUnits <$> noInlineMaybeToStrictMaybe protocolUpdateMaxTxExUnits) + & ppuMaxBlockExUnitsL .~ + (toAlonzoExUnits <$> noInlineMaybeToStrictMaybe protocolUpdateMaxBlockExUnits) + & ppuMaxValSizeL .~ noInlineMaybeToStrictMaybe protocolUpdateMaxValueSize + & ppuCollateralPercentageL .~ noInlineMaybeToStrictMaybe protocolUpdateCollateralPercent + & ppuMaxCollateralInputsL .~ noInlineMaybeToStrictMaybe protocolUpdateMaxCollateralInputs + pure ppuAlonzoCommon + + +toAlonzoPParamsUpdate :: Ledger.Crypto crypto + => ProtocolParametersUpdate + -> Either String (PParamsUpdate (Ledger.AlonzoEra crypto)) +toAlonzoPParamsUpdate + protocolParametersUpdate@ProtocolParametersUpdate { + protocolUpdateDecentralization + , protocolUpdateUTxOCostPerWord + } = do + ppuAlonzoCommon <- toAlonzoCommonPParamsUpdate protocolParametersUpdate + d <- mapM (boundRationalEither "D") protocolUpdateDecentralization + let ppuAlonzo = + ppuAlonzoCommon + & ppuDL .~ noInlineMaybeToStrictMaybe d + & ppuCoinsPerUTxOWordL .~ + (CoinPerWord . toShelleyLovelace <$> + noInlineMaybeToStrictMaybe protocolUpdateUTxOCostPerWord) + pure ppuAlonzo + + +toBabbagePParamsUpdate :: BabbageEraPParams ledgerera + => ProtocolParametersUpdate + -> Either String (PParamsUpdate ledgerera) toBabbagePParamsUpdate - ProtocolParametersUpdate { - protocolUpdateProtocolVersion - , protocolUpdateMaxBlockHeaderSize - , protocolUpdateMaxBlockBodySize - , protocolUpdateMaxTxSize - , protocolUpdateTxFeeFixed - , protocolUpdateTxFeePerByte - , protocolUpdateStakeAddressDeposit - , protocolUpdateStakePoolDeposit - , protocolUpdateMinPoolCost - , protocolUpdatePoolRetireMaxEpoch - , protocolUpdateStakePoolTargetNum - , protocolUpdatePoolPledgeInfluence - , protocolUpdateMonetaryExpansion - , protocolUpdateTreasuryCut - , protocolUpdateCostModels - , protocolUpdatePrices - , protocolUpdateMaxTxExUnits - , protocolUpdateMaxBlockExUnits - , protocolUpdateMaxValueSize - , protocolUpdateCollateralPercent - , protocolUpdateMaxCollateralInputs - , protocolUpdateUTxOCostPerByte - } = - BabbagePParams { - _minfeeA = noInlineMaybeToStrictMaybe protocolUpdateTxFeePerByte - , _minfeeB = noInlineMaybeToStrictMaybe protocolUpdateTxFeeFixed - , _maxBBSize = noInlineMaybeToStrictMaybe protocolUpdateMaxBlockBodySize - , _maxTxSize = noInlineMaybeToStrictMaybe protocolUpdateMaxTxSize - , _maxBHSize = noInlineMaybeToStrictMaybe protocolUpdateMaxBlockHeaderSize - , _keyDeposit = toShelleyLovelace <$> - noInlineMaybeToStrictMaybe protocolUpdateStakeAddressDeposit - , _poolDeposit = toShelleyLovelace <$> - noInlineMaybeToStrictMaybe protocolUpdateStakePoolDeposit - , _eMax = noInlineMaybeToStrictMaybe protocolUpdatePoolRetireMaxEpoch - , _nOpt = noInlineMaybeToStrictMaybe protocolUpdateStakePoolTargetNum - , _a0 = noInlineMaybeToStrictMaybe $ Ledger.boundRational =<< - protocolUpdatePoolPledgeInfluence - , _rho = noInlineMaybeToStrictMaybe $ Ledger.boundRational =<< - protocolUpdateMonetaryExpansion - , _tau = noInlineMaybeToStrictMaybe $ Ledger.boundRational =<< - protocolUpdateTreasuryCut - , _protocolVersion = uncurry Ledger.ProtVer <$> - noInlineMaybeToStrictMaybe protocolUpdateProtocolVersion - , _minPoolCost = toShelleyLovelace <$> - noInlineMaybeToStrictMaybe protocolUpdateMinPoolCost - , _costmdls = if Map.null protocolUpdateCostModels - then Ledger.SNothing - else either (const Ledger.SNothing) Ledger.SJust - (toAlonzoCostModels protocolUpdateCostModels) - , _prices = noInlineMaybeToStrictMaybe $ - toAlonzoPrices =<< protocolUpdatePrices - , _maxTxExUnits = toAlonzoExUnits <$> - noInlineMaybeToStrictMaybe protocolUpdateMaxTxExUnits - , _maxBlockExUnits = toAlonzoExUnits <$> - noInlineMaybeToStrictMaybe protocolUpdateMaxBlockExUnits - , _maxValSize = noInlineMaybeToStrictMaybe protocolUpdateMaxValueSize - , _collateralPercentage = noInlineMaybeToStrictMaybe protocolUpdateCollateralPercent - , _maxCollateralInputs = noInlineMaybeToStrictMaybe protocolUpdateMaxCollateralInputs - , _coinsPerUTxOByte = toShelleyLovelace <$> - noInlineMaybeToStrictMaybe protocolUpdateUTxOCostPerByte - } - --- Conway uses the same PParams as Babbage. -toConwayPParamsUpdate :: ProtocolParametersUpdate - -> BabbagePParamsUpdate ledgerera + protocolParametersUpdate@ProtocolParametersUpdate { + protocolUpdateUTxOCostPerByte + } = do + ppuAlonzoCommon <- toAlonzoCommonPParamsUpdate protocolParametersUpdate + let ppuBabbage = + ppuAlonzoCommon + & ppuCoinsPerUTxOByteL .~ + (CoinPerByte . toShelleyLovelace <$> + noInlineMaybeToStrictMaybe protocolUpdateUTxOCostPerByte) + pure ppuBabbage + +requireParam :: String -> (a -> Either String b) -> Maybe a -> Either String b +requireParam paramName f = maybe (Left $ "Must specify " ++ paramName) f + +mkProtVer :: (Natural, Natural) -> Either String Ledger.ProtVer +mkProtVer (majorProtVer, minorProtVer) = + case Ledger.mkVersion majorProtVer of + Nothing -> Left $ "Major protocol version is invalid: " ++ show majorProtVer + Just v -> Right $ Ledger.ProtVer v minorProtVer + +boundRationalEither :: Ledger.BoundedRational b + => String + -> Rational + -> Either String b +boundRationalEither name r = + case Ledger.boundRational r of + Just br -> Right br + Nothing -> Left $ "Rational value for '" ++ name ++ "' is outside of bounds: " ++ show r + +-- Conway uses the same PParams as Babbage for now. +toConwayPParamsUpdate :: BabbageEraPParams ledgerera + => ProtocolParametersUpdate + -> Either String (PParamsUpdate ledgerera) toConwayPParamsUpdate = toBabbagePParamsUpdate -- ---------------------------------------------------------------------------- @@ -1124,7 +1079,7 @@ toConwayPParamsUpdate = toBabbagePParamsUpdate fromLedgerUpdate :: forall era ledgerera. ShelleyLedgerEra era ~ ledgerera - => Ledger.Crypto ledgerera ~ StandardCrypto + => Ledger.EraCrypto ledgerera ~ StandardCrypto => ShelleyBasedEra era -> Ledger.Update ledgerera -> UpdateProposal @@ -1134,7 +1089,7 @@ fromLedgerUpdate era (Ledger.Update ppup epochno) = fromLedgerProposedPPUpdates :: forall era ledgerera. ShelleyLedgerEra era ~ ledgerera - => Ledger.Crypto ledgerera ~ StandardCrypto + => Ledger.EraCrypto ledgerera ~ StandardCrypto => ShelleyBasedEra era -> Ledger.ProposedPPUpdates ledgerera -> Map (Hash GenesisKey) ProtocolParametersUpdate @@ -1145,8 +1100,8 @@ fromLedgerProposedPPUpdates era = fromLedgerPParamsUpdate :: ShelleyBasedEra era - -> Ledger.PParamsUpdate (ShelleyLedgerEra era) - -> ProtocolParametersUpdate + -> Ledger.PParamsUpdate (ShelleyLedgerEra era) + -> ProtocolParametersUpdate fromLedgerPParamsUpdate ShelleyBasedEraShelley = fromShelleyPParamsUpdate fromLedgerPParamsUpdate ShelleyBasedEraAllegra = fromShelleyPParamsUpdate fromLedgerPParamsUpdate ShelleyBasedEraMary = fromShelleyPParamsUpdate @@ -1155,56 +1110,35 @@ fromLedgerPParamsUpdate ShelleyBasedEraBabbage = fromBabbagePParamsUpdate fromLedgerPParamsUpdate ShelleyBasedEraConway = fromConwayPParamsUpdate -fromShelleyPParamsUpdate :: ShelleyPParamsUpdate ledgerera - -> ProtocolParametersUpdate -fromShelleyPParamsUpdate - ShelleyPParams { - _minfeeA - , _minfeeB - , _maxBBSize - , _maxTxSize - , _maxBHSize - , _keyDeposit - , _poolDeposit - , _eMax - , _nOpt - , _a0 - , _rho - , _tau - , _d - , _extraEntropy - , _protocolVersion - , _minUTxOValue - , _minPoolCost - } = + +fromShelleyCommonPParamsUpdate :: EraPParams ledgerera + => PParamsUpdate ledgerera + -> ProtocolParametersUpdate +fromShelleyCommonPParamsUpdate ppu = ProtocolParametersUpdate { - protocolUpdateProtocolVersion = (\(Ledger.ProtVer a b) -> (a,b)) <$> - strictMaybeToMaybe _protocolVersion - , protocolUpdateDecentralization = Ledger.unboundRational <$> - strictMaybeToMaybe _d - , protocolUpdateExtraPraosEntropy = fromLedgerNonce <$> - strictMaybeToMaybe _extraEntropy - , protocolUpdateMaxBlockHeaderSize = strictMaybeToMaybe _maxBHSize - , protocolUpdateMaxBlockBodySize = strictMaybeToMaybe _maxBBSize - , protocolUpdateMaxTxSize = strictMaybeToMaybe _maxTxSize - , protocolUpdateTxFeeFixed = strictMaybeToMaybe _minfeeB - , protocolUpdateTxFeePerByte = strictMaybeToMaybe _minfeeA - , protocolUpdateMinUTxOValue = fromShelleyLovelace <$> - strictMaybeToMaybe _minUTxOValue + protocolUpdateProtocolVersion = (\(Ledger.ProtVer a b) -> (Ledger.getVersion a,b)) <$> + strictMaybeToMaybe (ppu ^. ppuProtocolVersionL) + , protocolUpdateMaxBlockHeaderSize = strictMaybeToMaybe (ppu ^. ppuMaxBHSizeL) + , protocolUpdateMaxBlockBodySize = strictMaybeToMaybe (ppu ^. ppuMaxBBSizeL) + , protocolUpdateMaxTxSize = strictMaybeToMaybe (ppu ^. ppuMaxTxSizeL) + , protocolUpdateTxFeeFixed = fromShelleyLovelace <$> + strictMaybeToMaybe (ppu ^. ppuMinFeeBL) + , protocolUpdateTxFeePerByte = fromShelleyLovelace <$> + strictMaybeToMaybe (ppu ^. ppuMinFeeAL) , protocolUpdateStakeAddressDeposit = fromShelleyLovelace <$> - strictMaybeToMaybe _keyDeposit + strictMaybeToMaybe (ppu ^. ppuKeyDepositL) , protocolUpdateStakePoolDeposit = fromShelleyLovelace <$> - strictMaybeToMaybe _poolDeposit + strictMaybeToMaybe (ppu ^. ppuPoolDepositL) , protocolUpdateMinPoolCost = fromShelleyLovelace <$> - strictMaybeToMaybe _minPoolCost - , protocolUpdatePoolRetireMaxEpoch = strictMaybeToMaybe _eMax - , protocolUpdateStakePoolTargetNum = strictMaybeToMaybe _nOpt + strictMaybeToMaybe (ppu ^. ppuMinPoolCostL) + , protocolUpdatePoolRetireMaxEpoch = strictMaybeToMaybe (ppu ^. ppuEMaxL) + , protocolUpdateStakePoolTargetNum = strictMaybeToMaybe (ppu ^. ppuNOptL) , protocolUpdatePoolPledgeInfluence = Ledger.unboundRational <$> - strictMaybeToMaybe _a0 + strictMaybeToMaybe (ppu ^. ppuA0L) , protocolUpdateMonetaryExpansion = Ledger.unboundRational <$> - strictMaybeToMaybe _rho + strictMaybeToMaybe (ppu ^. ppuRhoL) , protocolUpdateTreasuryCut = Ledger.unboundRational <$> - strictMaybeToMaybe _tau + strictMaybeToMaybe (ppu ^. ppuTauL) , protocolUpdateUTxOCostPerWord = Nothing , protocolUpdateCostModels = mempty , protocolUpdatePrices = Nothing @@ -1214,151 +1148,68 @@ fromShelleyPParamsUpdate , protocolUpdateCollateralPercent = Nothing , protocolUpdateMaxCollateralInputs = Nothing , protocolUpdateUTxOCostPerByte = Nothing + , protocolUpdateDecentralization = Nothing + , protocolUpdateExtraPraosEntropy = Nothing + , protocolUpdateMinUTxOValue = Nothing } -fromAlonzoPParamsUpdate :: AlonzoPParamsUpdate ledgerera - -> ProtocolParametersUpdate -fromAlonzoPParamsUpdate - AlonzoPParams { - _minfeeA - , _minfeeB - , _maxBBSize - , _maxTxSize - , _maxBHSize - , _keyDeposit - , _poolDeposit - , _eMax - , _nOpt - , _a0 - , _rho - , _tau - , _d - , _extraEntropy - , _protocolVersion - , _minPoolCost - , _coinsPerUTxOWord - , _costmdls - , _prices - , _maxTxExUnits - , _maxBlockExUnits - , _maxValSize - , _collateralPercentage - , _maxCollateralInputs - } = - ProtocolParametersUpdate { - protocolUpdateProtocolVersion = (\(Ledger.ProtVer a b) -> (a,b)) <$> - strictMaybeToMaybe _protocolVersion - , protocolUpdateDecentralization = Ledger.unboundRational <$> - strictMaybeToMaybe _d +fromShelleyPParamsUpdate :: ( EraPParams ledgerera + , Ledger.AtMostEra Ledger.MaryEra ledgerera + , Ledger.AtMostEra Ledger.AlonzoEra ledgerera + ) + => PParamsUpdate ledgerera + -> ProtocolParametersUpdate +fromShelleyPParamsUpdate ppu = + (fromShelleyCommonPParamsUpdate ppu) { + protocolUpdateDecentralization = Ledger.unboundRational <$> + strictMaybeToMaybe (ppu ^. ppuDL) , protocolUpdateExtraPraosEntropy = fromLedgerNonce <$> - strictMaybeToMaybe _extraEntropy - , protocolUpdateMaxBlockHeaderSize = strictMaybeToMaybe _maxBHSize - , protocolUpdateMaxBlockBodySize = strictMaybeToMaybe _maxBBSize - , protocolUpdateMaxTxSize = strictMaybeToMaybe _maxTxSize - , protocolUpdateTxFeeFixed = strictMaybeToMaybe _minfeeB - , protocolUpdateTxFeePerByte = strictMaybeToMaybe _minfeeA - , protocolUpdateMinUTxOValue = Nothing - , protocolUpdateStakeAddressDeposit = fromShelleyLovelace <$> - strictMaybeToMaybe _keyDeposit - , protocolUpdateStakePoolDeposit = fromShelleyLovelace <$> - strictMaybeToMaybe _poolDeposit - , protocolUpdateMinPoolCost = fromShelleyLovelace <$> - strictMaybeToMaybe _minPoolCost - , protocolUpdatePoolRetireMaxEpoch = strictMaybeToMaybe _eMax - , protocolUpdateStakePoolTargetNum = strictMaybeToMaybe _nOpt - , protocolUpdatePoolPledgeInfluence = Ledger.unboundRational <$> - strictMaybeToMaybe _a0 - , protocolUpdateMonetaryExpansion = Ledger.unboundRational <$> - strictMaybeToMaybe _rho - , protocolUpdateTreasuryCut = Ledger.unboundRational <$> - strictMaybeToMaybe _tau - , protocolUpdateUTxOCostPerWord = fromShelleyLovelace <$> - strictMaybeToMaybe _coinsPerUTxOWord - , protocolUpdateCostModels = maybe mempty fromAlonzoCostModels - (strictMaybeToMaybe _costmdls) + strictMaybeToMaybe (ppu ^. ppuExtraEntropyL) + , protocolUpdateMinUTxOValue = fromShelleyLovelace <$> + strictMaybeToMaybe (ppu ^. ppuMinUTxOValueL) + } + +fromAlonzoCommonPParamsUpdate :: AlonzoEraPParams ledgerera + => PParamsUpdate ledgerera + -> ProtocolParametersUpdate +fromAlonzoCommonPParamsUpdate ppu = + (fromShelleyCommonPParamsUpdate ppu) { + protocolUpdateCostModels = maybe mempty fromAlonzoCostModels + (strictMaybeToMaybe (ppu ^. ppuCostModelsL)) , protocolUpdatePrices = fromAlonzoPrices <$> - strictMaybeToMaybe _prices + strictMaybeToMaybe (ppu ^. ppuPricesL) , protocolUpdateMaxTxExUnits = fromAlonzoExUnits <$> - strictMaybeToMaybe _maxTxExUnits + strictMaybeToMaybe (ppu ^. ppuMaxTxExUnitsL) , protocolUpdateMaxBlockExUnits = fromAlonzoExUnits <$> - strictMaybeToMaybe _maxBlockExUnits - , protocolUpdateMaxValueSize = strictMaybeToMaybe _maxValSize - , protocolUpdateCollateralPercent = strictMaybeToMaybe _collateralPercentage - , protocolUpdateMaxCollateralInputs = strictMaybeToMaybe _maxCollateralInputs + strictMaybeToMaybe (ppu ^. ppuMaxBlockExUnitsL) + , protocolUpdateMaxValueSize = strictMaybeToMaybe (ppu ^. ppuMaxValSizeL) + , protocolUpdateCollateralPercent = strictMaybeToMaybe (ppu ^. ppuCollateralPercentageL) + , protocolUpdateMaxCollateralInputs = strictMaybeToMaybe (ppu ^. ppuMaxCollateralInputsL) , protocolUpdateUTxOCostPerByte = Nothing } -fromBabbagePParamsUpdate :: BabbagePParamsUpdate ledgerera - -> ProtocolParametersUpdate -fromBabbagePParamsUpdate - BabbagePParams { - _minfeeA - , _minfeeB - , _maxBBSize - , _maxTxSize - , _maxBHSize - , _keyDeposit - , _poolDeposit - , _eMax - , _nOpt - , _a0 - , _rho - , _tau - , _protocolVersion - , _minPoolCost - , _coinsPerUTxOByte - , _costmdls - , _prices - , _maxTxExUnits - , _maxBlockExUnits - , _maxValSize - , _collateralPercentage - , _maxCollateralInputs - } = - ProtocolParametersUpdate { - protocolUpdateProtocolVersion = (\(Ledger.ProtVer a b) -> (a,b)) <$> - strictMaybeToMaybe _protocolVersion - , protocolUpdateDecentralization = Nothing - , protocolUpdateExtraPraosEntropy = Nothing - , protocolUpdateMaxBlockHeaderSize = strictMaybeToMaybe _maxBHSize - , protocolUpdateMaxBlockBodySize = strictMaybeToMaybe _maxBBSize - , protocolUpdateMaxTxSize = strictMaybeToMaybe _maxTxSize - , protocolUpdateTxFeeFixed = strictMaybeToMaybe _minfeeB - , protocolUpdateTxFeePerByte = strictMaybeToMaybe _minfeeA - , protocolUpdateMinUTxOValue = Nothing - , protocolUpdateStakeAddressDeposit = fromShelleyLovelace <$> - strictMaybeToMaybe _keyDeposit - , protocolUpdateStakePoolDeposit = fromShelleyLovelace <$> - strictMaybeToMaybe _poolDeposit - , protocolUpdateMinPoolCost = fromShelleyLovelace <$> - strictMaybeToMaybe _minPoolCost - , protocolUpdatePoolRetireMaxEpoch = strictMaybeToMaybe _eMax - , protocolUpdateStakePoolTargetNum = strictMaybeToMaybe _nOpt - , protocolUpdatePoolPledgeInfluence = Ledger.unboundRational <$> - strictMaybeToMaybe _a0 - , protocolUpdateMonetaryExpansion = Ledger.unboundRational <$> - strictMaybeToMaybe _rho - , protocolUpdateTreasuryCut = Ledger.unboundRational <$> - strictMaybeToMaybe _tau - , protocolUpdateUTxOCostPerWord = Nothing - , protocolUpdateCostModels = maybe mempty fromAlonzoCostModels - (strictMaybeToMaybe _costmdls) - , protocolUpdatePrices = fromAlonzoPrices <$> - strictMaybeToMaybe _prices - , protocolUpdateMaxTxExUnits = fromAlonzoExUnits <$> - strictMaybeToMaybe _maxTxExUnits - , protocolUpdateMaxBlockExUnits = fromAlonzoExUnits <$> - strictMaybeToMaybe _maxBlockExUnits - , protocolUpdateMaxValueSize = strictMaybeToMaybe _maxValSize - , protocolUpdateCollateralPercent = strictMaybeToMaybe _collateralPercentage - , protocolUpdateMaxCollateralInputs = strictMaybeToMaybe _maxCollateralInputs - , protocolUpdateUTxOCostPerByte = fromShelleyLovelace <$> - strictMaybeToMaybe _coinsPerUTxOByte +fromAlonzoPParamsUpdate :: Ledger.Crypto crypto + => PParamsUpdate (Ledger.AlonzoEra crypto) + -> ProtocolParametersUpdate +fromAlonzoPParamsUpdate ppu = + (fromShelleyCommonPParamsUpdate ppu) { + protocolUpdateUTxOCostPerWord = fromShelleyLovelace . unCoinPerWord <$> + strictMaybeToMaybe (ppu ^. ppuCoinsPerUTxOWordL) } -fromConwayPParamsUpdate :: BabbagePParamsUpdate ledgerera +fromBabbagePParamsUpdate :: BabbageEraPParams ledgerera + => PParamsUpdate ledgerera -> ProtocolParametersUpdate +fromBabbagePParamsUpdate ppu = + (fromAlonzoCommonPParamsUpdate ppu) { + protocolUpdateUTxOCostPerByte = fromShelleyLovelace . unCoinPerByte <$> + strictMaybeToMaybe (ppu ^. ppuCoinsPerUTxOByteL) + } + +fromConwayPParamsUpdate :: BabbageEraPParams ledgerera + => PParamsUpdate ledgerera + -> ProtocolParametersUpdate fromConwayPParamsUpdate = fromBabbagePParamsUpdate -- | Bundle cardano-api representation and ledger representation of protocol parameters together so @@ -1401,262 +1252,184 @@ unbundleProtocolParams (BundleAsShelleyBasedProtocolParameters _ pp _) = pp -- Conversion functions: protocol parameters to ledger types -- ---TODO: this has to be a Maybe or Either for some of the parameter validation. --- Both parameters that must be present or absent in specific eras, --- and parameter values that need validation, such as the Rational values +--TODO: Propagate the `Either String (PParams (ShelleyLedgerEra era))` to the use sites, +--rather than fail with `error` here. toLedgerPParams :: ShelleyBasedEra era -> ProtocolParameters -> Ledger.PParams (ShelleyLedgerEra era) -toLedgerPParams ShelleyBasedEraShelley = toShelleyPParams -toLedgerPParams ShelleyBasedEraAllegra = toShelleyPParams -toLedgerPParams ShelleyBasedEraMary = toShelleyPParams -toLedgerPParams ShelleyBasedEraAlonzo = toAlonzoPParams -toLedgerPParams ShelleyBasedEraBabbage = toBabbagePParams -toLedgerPParams ShelleyBasedEraConway = toConwayPParams - -toShelleyPParams :: ProtocolParameters -> ShelleyPParams ledgerera -toShelleyPParams ProtocolParameters { - protocolParamProtocolVersion, - protocolParamDecentralization, - protocolParamExtraPraosEntropy, - protocolParamMaxBlockHeaderSize, - protocolParamMaxBlockBodySize, - protocolParamMaxTxSize, - protocolParamTxFeeFixed, - protocolParamTxFeePerByte, - protocolParamMinUTxOValue = Just minUTxOValue, - protocolParamStakeAddressDeposit, - protocolParamStakePoolDeposit, - protocolParamMinPoolCost, - protocolParamPoolRetireMaxEpoch, - protocolParamStakePoolTargetNum, - protocolParamPoolPledgeInfluence, - protocolParamMonetaryExpansion, - protocolParamTreasuryCut - } = - ShelleyPParams - { _protocolVersion - = let (maj, minor) = protocolParamProtocolVersion - in Ledger.ProtVer maj minor - , _d = case protocolParamDecentralization of - -- The decentralization parameter is deprecated in Babbage - -- so we default to 0 if no dentralization parameter is found - -- in the api's 'ProtocolParameter' type. If we don't do this - -- we won't be able to construct an Alonzo tx using the Babbage - -- era's protocol parameter because our only other option is to - -- error. - Nothing -> minBound - Just pDecentral -> - fromMaybe - (error "toShelleyPParams: invalid Decentralization value") - (Ledger.boundRational pDecentral) - , _extraEntropy = toLedgerNonce protocolParamExtraPraosEntropy - , _maxBHSize = protocolParamMaxBlockHeaderSize - , _maxBBSize = protocolParamMaxBlockBodySize - , _maxTxSize = protocolParamMaxTxSize - , _minfeeB = protocolParamTxFeeFixed - , _minfeeA = protocolParamTxFeePerByte - , _minUTxOValue = toShelleyLovelace minUTxOValue - , _keyDeposit = toShelleyLovelace protocolParamStakeAddressDeposit - , _poolDeposit = toShelleyLovelace protocolParamStakePoolDeposit - , _minPoolCost = toShelleyLovelace protocolParamMinPoolCost - , _eMax = protocolParamPoolRetireMaxEpoch - , _nOpt = protocolParamStakePoolTargetNum - , _a0 = fromMaybe - (error "toShelleyPParams: invalid PoolPledgeInfluence value") - (Ledger.boundRational protocolParamPoolPledgeInfluence) - , _rho = fromMaybe - (error "toShelleyPParams: invalid MonetaryExpansion value") - (Ledger.boundRational protocolParamMonetaryExpansion) - , _tau = fromMaybe - (error "toShelleyPParams: invalid TreasuryCut value") - (Ledger.boundRational protocolParamTreasuryCut) - } -toShelleyPParams ProtocolParameters { protocolParamMinUTxOValue = Nothing } = - error "toShelleyPParams: must specify protocolParamMinUTxOValue" - -toAlonzoPParams :: ProtocolParameters -> AlonzoPParams ledgerera -toAlonzoPParams ProtocolParameters { - protocolParamProtocolVersion, - protocolParamDecentralization, - protocolParamExtraPraosEntropy, - protocolParamMaxBlockHeaderSize, - protocolParamMaxBlockBodySize, - protocolParamMaxTxSize, - protocolParamTxFeeFixed, - protocolParamTxFeePerByte, - protocolParamStakeAddressDeposit, - protocolParamStakePoolDeposit, - protocolParamMinPoolCost, - protocolParamPoolRetireMaxEpoch, - protocolParamStakePoolTargetNum, - protocolParamPoolPledgeInfluence, - protocolParamMonetaryExpansion, - protocolParamTreasuryCut, - protocolParamUTxOCostPerWord, - protocolParamCostModels, - protocolParamPrices = Just prices, - protocolParamMaxTxExUnits = Just maxTxExUnits, - protocolParamMaxBlockExUnits = Just maxBlockExUnits, - protocolParamMaxValueSize = Just maxValueSize, - protocolParamCollateralPercent = Just collateralPercentage, - protocolParamMaxCollateralInputs = Just maxCollateralInputs, - protocolParamUTxOCostPerByte - } = - let !coinsPerUTxOWord = fromMaybe - (error "toAlonzoPParams: must specify protocolParamUTxOCostPerWord or protocolParamUTxOCostPerByte") $ - protocolParamUTxOCostPerWord <|> ((* 8) <$> protocolParamUTxOCostPerByte) - in - AlonzoPParams { - _protocolVersion - = let (maj, minor) = protocolParamProtocolVersion - in Ledger.ProtVer maj minor - , _d = case protocolParamDecentralization of - -- The decentralization parameter is deprecated in Babbage - -- so we default to 0 if no dentralization parameter is found - -- in the api's 'ProtocolParameter' type. If we don't do this - -- we won't be able to construct an Alonzo tx using the Babbage - -- era's protocol parameter because our only other option is to - -- error. - Nothing -> minBound - Just pDecentral -> - fromMaybe - (error "toAlonzoPParams: invalid Decentralization value") - (Ledger.boundRational pDecentral) - , _extraEntropy = toLedgerNonce protocolParamExtraPraosEntropy - , _maxBHSize = protocolParamMaxBlockHeaderSize - , _maxBBSize = protocolParamMaxBlockBodySize - , _maxTxSize = protocolParamMaxTxSize - , _minfeeB = protocolParamTxFeeFixed - , _minfeeA = protocolParamTxFeePerByte - , _keyDeposit = toShelleyLovelace protocolParamStakeAddressDeposit - , _poolDeposit = toShelleyLovelace protocolParamStakePoolDeposit - , _minPoolCost = toShelleyLovelace protocolParamMinPoolCost - , _eMax = protocolParamPoolRetireMaxEpoch - , _nOpt = protocolParamStakePoolTargetNum - , _a0 = fromMaybe - (error "toAlonzoPParams: invalid PoolPledgeInfluence value") - (Ledger.boundRational protocolParamPoolPledgeInfluence) - , _rho = fromMaybe - (error "toAlonzoPParams: invalid MonetaryExpansion value") - (Ledger.boundRational protocolParamMonetaryExpansion) - , _tau = fromMaybe - (error "toAlonzoPParams: invalid TreasuryCut value") - (Ledger.boundRational protocolParamTreasuryCut) - - -- New params in Alonzo: - , _coinsPerUTxOWord = toShelleyLovelace coinsPerUTxOWord - , _costmdls = either - (\e -> error $ "toAlonzoPParams: invalid cost models, error: " <> e) - id - (toAlonzoCostModels protocolParamCostModels) - , _prices = fromMaybe - (error "toAlonzoPParams: invalid Price values") - (toAlonzoPrices prices) - , _maxTxExUnits = toAlonzoExUnits maxTxExUnits - , _maxBlockExUnits = toAlonzoExUnits maxBlockExUnits - , _maxValSize = maxValueSize - , _collateralPercentage = collateralPercentage - , _maxCollateralInputs = maxCollateralInputs - } -toAlonzoPParams ProtocolParameters { protocolParamUTxOCostPerWord = Nothing } = - error "toAlonzoPParams: must specify protocolParamUTxOCostPerWord" -toAlonzoPParams ProtocolParameters { protocolParamPrices = Nothing } = - error "toAlonzoPParams: must specify protocolParamPrices" -toAlonzoPParams ProtocolParameters { protocolParamMaxTxExUnits = Nothing } = - error "toAlonzoPParams: must specify protocolParamMaxTxExUnits" -toAlonzoPParams ProtocolParameters { protocolParamMaxBlockExUnits = Nothing } = - error "toAlonzoPParams: must specify protocolParamMaxBlockExUnits" -toAlonzoPParams ProtocolParameters { protocolParamMaxValueSize = Nothing } = - error "toAlonzoPParams: must specify protocolParamMaxValueSize" -toAlonzoPParams ProtocolParameters { protocolParamCollateralPercent = Nothing } = - error "toAlonzoPParams: must specify protocolParamCollateralPercent" -toAlonzoPParams ProtocolParameters { protocolParamMaxCollateralInputs = Nothing } = - error "toAlonzoPParams: must specify protocolParamMaxCollateralInputs" - - -toBabbagePParams :: ProtocolParameters -> BabbagePParams ledgerera -toBabbagePParams ProtocolParameters { - protocolParamProtocolVersion, - protocolParamMaxBlockHeaderSize, - protocolParamMaxBlockBodySize, - protocolParamMaxTxSize, - protocolParamTxFeeFixed, - protocolParamTxFeePerByte, - protocolParamStakeAddressDeposit, - protocolParamStakePoolDeposit, - protocolParamMinPoolCost, - protocolParamPoolRetireMaxEpoch, - protocolParamStakePoolTargetNum, - protocolParamPoolPledgeInfluence, - protocolParamMonetaryExpansion, - protocolParamTreasuryCut, - protocolParamUTxOCostPerByte = Just utxoCostPerByte, - protocolParamCostModels, - protocolParamPrices = Just prices, - protocolParamMaxTxExUnits = Just maxTxExUnits, - protocolParamMaxBlockExUnits = Just maxBlockExUnits, - protocolParamMaxValueSize = Just maxValueSize, - protocolParamCollateralPercent = Just collateralPercentage, - protocolParamMaxCollateralInputs = Just maxCollateralInputs - } = - BabbagePParams { - _protocolVersion - = let (maj, minor) = protocolParamProtocolVersion - in Ledger.ProtVer maj minor - , _maxBHSize = protocolParamMaxBlockHeaderSize - , _maxBBSize = protocolParamMaxBlockBodySize - , _maxTxSize = protocolParamMaxTxSize - , _minfeeB = protocolParamTxFeeFixed - , _minfeeA = protocolParamTxFeePerByte - , _keyDeposit = toShelleyLovelace protocolParamStakeAddressDeposit - , _poolDeposit = toShelleyLovelace protocolParamStakePoolDeposit - , _minPoolCost = toShelleyLovelace protocolParamMinPoolCost - , _eMax = protocolParamPoolRetireMaxEpoch - , _nOpt = protocolParamStakePoolTargetNum - , _a0 = fromMaybe - (error "toBabbagePParams: invalid PoolPledgeInfluence value") - (Ledger.boundRational protocolParamPoolPledgeInfluence) - , _rho = fromMaybe - (error "toBabbagePParams: invalid MonetaryExpansion value") - (Ledger.boundRational protocolParamMonetaryExpansion) - , _tau = fromMaybe - (error "toBabbagePParams: invalid TreasuryCut value") - (Ledger.boundRational protocolParamTreasuryCut) - - -- New params in Babbage. - , _coinsPerUTxOByte = toShelleyLovelace utxoCostPerByte - - , _costmdls = either - (\e -> error $ "toBabbagePParams: invalid cost models, error: " <> e) - id - (toAlonzoCostModels protocolParamCostModels) - , _prices = fromMaybe - (error "toBabbagePParams: invalid Price values") - (toAlonzoPrices prices) - , _maxTxExUnits = toAlonzoExUnits maxTxExUnits - , _maxBlockExUnits = toAlonzoExUnits maxBlockExUnits - , _maxValSize = maxValueSize - , _collateralPercentage = collateralPercentage - , _maxCollateralInputs = maxCollateralInputs - } -toBabbagePParams ProtocolParameters { protocolParamUTxOCostPerByte = Nothing } = - error "toBabbagePParams: must specify protocolParamUTxOCostPerByte" -toBabbagePParams ProtocolParameters { protocolParamPrices = Nothing } = - error "toBabbagePParams: must specify protocolParamPrices" -toBabbagePParams ProtocolParameters { protocolParamMaxTxExUnits = Nothing } = - error "toBabbagePParams: must specify protocolParamMaxTxExUnits" -toBabbagePParams ProtocolParameters { protocolParamMaxBlockExUnits = Nothing } = - error "toBabbagePParams: must specify protocolParamMaxBlockExUnits" -toBabbagePParams ProtocolParameters { protocolParamMaxValueSize = Nothing } = - error "toBabbagePParams: must specify protocolParamMaxValueSize" -toBabbagePParams ProtocolParameters { protocolParamCollateralPercent = Nothing } = - error "toBabbagePParams: must specify protocolParamCollateralPercent" -toBabbagePParams ProtocolParameters { protocolParamMaxCollateralInputs = Nothing } = - error "toBabbagePParams: must specify protocolParamMaxCollateralInputs" - -toConwayPParams :: ProtocolParameters -> BabbagePParams ledgerera +toLedgerPParams era = either error id . toLedgerPParamsEither era + +toLedgerPParamsEither :: ShelleyBasedEra era + -> ProtocolParameters + -> Either String (PParams (ShelleyLedgerEra era)) +toLedgerPParamsEither ShelleyBasedEraShelley = toShelleyPParams +toLedgerPParamsEither ShelleyBasedEraAllegra = toShelleyPParams +toLedgerPParamsEither ShelleyBasedEraMary = toShelleyPParams +toLedgerPParamsEither ShelleyBasedEraAlonzo = toAlonzoPParams +toLedgerPParamsEither ShelleyBasedEraBabbage = toBabbagePParams +toLedgerPParamsEither ShelleyBasedEraConway = toConwayPParams + + +toShelleyCommonPParams :: EraPParams ledgerera + => ProtocolParameters + -> Either String (PParams ledgerera) +toShelleyCommonPParams + ProtocolParameters { + protocolParamProtocolVersion + , protocolParamMaxBlockHeaderSize + , protocolParamMaxBlockBodySize + , protocolParamMaxTxSize + , protocolParamTxFeeFixed + , protocolParamTxFeePerByte + , protocolParamStakeAddressDeposit + , protocolParamStakePoolDeposit + , protocolParamMinPoolCost + , protocolParamPoolRetireMaxEpoch + , protocolParamStakePoolTargetNum + , protocolParamPoolPledgeInfluence + , protocolParamMonetaryExpansion + , protocolParamTreasuryCut + } = do + a0 <- boundRationalEither "A0" protocolParamPoolPledgeInfluence + rho <- boundRationalEither "Rho" protocolParamMonetaryExpansion + tau <- boundRationalEither "Tau" protocolParamTreasuryCut + protVer <- mkProtVer protocolParamProtocolVersion + let ppCommon = + emptyPParams + & ppMinFeeAL .~ toShelleyLovelace protocolParamTxFeePerByte + & ppMinFeeBL .~ toShelleyLovelace protocolParamTxFeeFixed + & ppMaxBBSizeL .~ protocolParamMaxBlockBodySize + & ppMaxTxSizeL .~ protocolParamMaxTxSize + & ppMaxBHSizeL .~ protocolParamMaxBlockHeaderSize + & ppKeyDepositL .~ toShelleyLovelace protocolParamStakeAddressDeposit + & ppPoolDepositL .~ toShelleyLovelace protocolParamStakePoolDeposit + & ppEMaxL .~ protocolParamPoolRetireMaxEpoch + & ppNOptL .~ protocolParamStakePoolTargetNum + & ppA0L .~ a0 + & ppRhoL .~ rho + & ppTauL .~ tau + & ppProtocolVersionL .~ protVer + & ppMinPoolCostL .~ toShelleyLovelace protocolParamMinPoolCost + pure ppCommon + +toShelleyPParams :: ( EraPParams ledgerera + , Ledger.AtMostEra Ledger.MaryEra ledgerera + , Ledger.AtMostEra Ledger.AlonzoEra ledgerera + ) + => ProtocolParameters + -> Either String (PParams ledgerera) +toShelleyPParams + protocolParameters@ProtocolParameters { + protocolParamDecentralization + , protocolParamExtraPraosEntropy + , protocolParamMinUTxOValue + } = do + ppCommon <- toShelleyCommonPParams protocolParameters + d <- case protocolParamDecentralization of + Nothing -> Left "Missing Decentralization parameter" + Just dr -> boundRationalEither "D" dr + minUTxOValue <- + maybe (Left "toShelleyPParams: must specify protocolParamMinUTxOValue") Right + protocolParamMinUTxOValue + let ppShelley = + ppCommon + & ppDL .~ d + & ppExtraEntropyL .~ toLedgerNonce protocolParamExtraPraosEntropy + & ppMinUTxOValueL .~ toShelleyLovelace minUTxOValue + pure ppShelley + + +toAlonzoCommonPParams :: AlonzoEraPParams ledgerera + => ProtocolParameters + -> Either String (PParams ledgerera) +toAlonzoCommonPParams + protocolParameters@ProtocolParameters { + protocolParamCostModels + , protocolParamPrices + , protocolParamMaxTxExUnits + , protocolParamMaxBlockExUnits + , protocolParamMaxValueSize + , protocolParamCollateralPercent + , protocolParamMaxCollateralInputs + } = do + ppShelleyCommon <- toShelleyCommonPParams protocolParameters + costModels <- toAlonzoCostModels protocolParamCostModels + prices <- + requireParam "protocolParamPrices" toAlonzoPrices protocolParamPrices + maxTxExUnits <- + requireParam "protocolParamMaxTxExUnits" Right protocolParamMaxTxExUnits + maxBlockExUnits <- + requireParam "protocolParamMaxBlockExUnits" Right protocolParamMaxBlockExUnits + maxValueSize <- + requireParam "protocolParamMaxBlockExUnits" Right protocolParamMaxValueSize + collateralPercent <- + requireParam "protocolParamCollateralPercent" Right protocolParamCollateralPercent + maxCollateralInputs <- + requireParam "protocolParamMaxCollateralInputs" Right protocolParamMaxCollateralInputs + let ppAlonzoCommon = + ppShelleyCommon + & ppCostModelsL .~ costModels + & ppPricesL .~ prices + & ppMaxTxExUnitsL .~ toAlonzoExUnits maxTxExUnits + & ppMaxBlockExUnitsL .~ toAlonzoExUnits maxBlockExUnits + & ppMaxValSizeL .~ maxValueSize + & ppCollateralPercentageL .~ collateralPercent + & ppMaxCollateralInputsL .~ maxCollateralInputs + pure ppAlonzoCommon + +toAlonzoPParams :: Ledger.Crypto crypto + => ProtocolParameters + -> Either String (PParams (Ledger.AlonzoEra crypto)) +toAlonzoPParams + protocolParameters@ProtocolParameters { + protocolParamDecentralization + , protocolParamUTxOCostPerWord + } = do + ppAlonzoCommon <- toAlonzoCommonPParams protocolParameters + -- QUESTION? This is strange, why do we need to construct Alonzo Tx with Babbage PParams? + -- This feels to me like an issue with the api design, as there should never be such an + -- incosistency, because PParams affect the validity of the transaction. + d <- case protocolParamDecentralization of + -- The decentralization parameter is deprecated in Babbage + -- so we default to 0 if no decentralization parameter is found + -- in the api's 'ProtocolParameter' type. If we don't do this + -- we won't be able to construct an Alonzo tx using the Babbage + -- era's protocol parameter because our only other option is to + -- error. + Nothing -> Right minBound + Just dParam -> boundRationalEither "D" dParam + -- This is the correct implementation that should be the used instead: + -- d <- requireParam "protocolParamDecentralization" + -- (boundRationalEither "D") + -- protocolParamDecentralization + utxoCostPerWord <- + requireParam "protocolParamUTxOCostPerWord" Right protocolParamUTxOCostPerWord + let ppAlonzo = + ppAlonzoCommon + & ppDL .~ d + & ppCoinsPerUTxOWordL .~ CoinPerWord (toShelleyLovelace utxoCostPerWord) + pure ppAlonzo + + +toBabbagePParams :: BabbageEraPParams ledgerera + => ProtocolParameters + -> Either String (PParams ledgerera) +toBabbagePParams + protocolParameters@ProtocolParameters { + protocolParamUTxOCostPerByte + } = do + ppAlonzoCommon <- toAlonzoCommonPParams protocolParameters + utxoCostPerByte <- + requireParam "protocolParamUTxOCostPerByte" Right protocolParamUTxOCostPerByte + let ppBabbage = + ppAlonzoCommon + & ppCoinsPerUTxOByteL .~ CoinPerByte (toShelleyLovelace utxoCostPerByte) + pure ppBabbage + +toConwayPParams :: BabbageEraPParams ledgerera + => ProtocolParameters + -> Either String (PParams ledgerera) toConwayPParams = toBabbagePParams -- ---------------------------------------------------------------------------- @@ -1675,174 +1448,90 @@ fromLedgerPParams ShelleyBasedEraBabbage = fromBabbagePParams fromLedgerPParams ShelleyBasedEraConway = fromConwayPParams -fromShelleyPParams :: ShelleyPParams ledgerera - -> ProtocolParameters -fromShelleyPParams - ShelleyPParams { - _minfeeA - , _minfeeB - , _maxBBSize - , _maxTxSize - , _maxBHSize - , _keyDeposit - , _poolDeposit - , _eMax - , _nOpt - , _a0 - , _rho - , _tau - , _d - , _extraEntropy - , _protocolVersion - , _minUTxOValue - , _minPoolCost - } = +fromShelleyCommonPParams :: EraPParams ledgerera + => PParams ledgerera + -> ProtocolParameters +fromShelleyCommonPParams pp = ProtocolParameters { - protocolParamProtocolVersion = (\(Ledger.ProtVer a b) -> (a,b)) - _protocolVersion - , protocolParamDecentralization = Just $ Ledger.unboundRational _d - , protocolParamExtraPraosEntropy = fromLedgerNonce _extraEntropy - , protocolParamMaxBlockHeaderSize = _maxBHSize - , protocolParamMaxBlockBodySize = _maxBBSize - , protocolParamMaxTxSize = _maxTxSize - , protocolParamTxFeeFixed = _minfeeB - , protocolParamTxFeePerByte = _minfeeA - , protocolParamMinUTxOValue = Just (fromShelleyLovelace _minUTxOValue) - , protocolParamStakeAddressDeposit = fromShelleyLovelace _keyDeposit - , protocolParamStakePoolDeposit = fromShelleyLovelace _poolDeposit - , protocolParamMinPoolCost = fromShelleyLovelace _minPoolCost - , protocolParamPoolRetireMaxEpoch = _eMax - , protocolParamStakePoolTargetNum = _nOpt - , protocolParamPoolPledgeInfluence = Ledger.unboundRational _a0 - , protocolParamMonetaryExpansion = Ledger.unboundRational _rho - , protocolParamTreasuryCut = Ledger.unboundRational _tau - , protocolParamUTxOCostPerWord = Nothing -- Only in Alonzo - , protocolParamCostModels = Map.empty -- Only from Alonzo onwards - , protocolParamPrices = Nothing -- Only from Alonzo onwards - , protocolParamMaxTxExUnits = Nothing -- Only from Alonzo onwards - , protocolParamMaxBlockExUnits = Nothing -- Only from Alonzo onwards - , protocolParamMaxValueSize = Nothing -- Only from Alonzo onwards - , protocolParamCollateralPercent = Nothing -- Only from Alonzo onwards - , protocolParamMaxCollateralInputs = Nothing -- Only from Alonzo onwards - , protocolParamUTxOCostPerByte = Nothing -- Only from babbage onwards + protocolParamProtocolVersion = case pp ^. ppProtocolVersionL of + Ledger.ProtVer a b -> (Ledger.getVersion a, b) + , protocolParamMaxBlockHeaderSize = pp ^. ppMaxBHSizeL + , protocolParamMaxBlockBodySize = pp ^. ppMaxBBSizeL + , protocolParamMaxTxSize = pp ^. ppMaxTxSizeL + , protocolParamTxFeeFixed = fromShelleyLovelace (pp ^. ppMinFeeBL) + , protocolParamTxFeePerByte = fromShelleyLovelace (pp ^. ppMinFeeAL) + , protocolParamStakeAddressDeposit = fromShelleyLovelace (pp ^. ppKeyDepositL) + , protocolParamStakePoolDeposit = fromShelleyLovelace (pp ^. ppPoolDepositL) + , protocolParamMinPoolCost = fromShelleyLovelace (pp ^. ppMinPoolCostL) + , protocolParamPoolRetireMaxEpoch = pp ^. ppEMaxL + , protocolParamStakePoolTargetNum = pp ^. ppNOptL + , protocolParamPoolPledgeInfluence = Ledger.unboundRational (pp ^. ppA0L) + , protocolParamMonetaryExpansion = Ledger.unboundRational (pp ^. ppRhoL) + , protocolParamTreasuryCut = Ledger.unboundRational (pp ^. ppTauL) + , protocolParamUTxOCostPerWord = Nothing -- Obsolete from Babbage onwards + , protocolParamCostModels = mempty -- Only from Alonzo onwards + , protocolParamPrices = Nothing -- Only from Alonzo onwards + , protocolParamMaxTxExUnits = Nothing -- Only from Alonzo onwards + , protocolParamMaxBlockExUnits = Nothing -- Only from Alonzo onwards + , protocolParamMaxValueSize = Nothing -- Only from Alonzo onwards + , protocolParamCollateralPercent = Nothing -- Only from Alonzo onwards + , protocolParamMaxCollateralInputs = Nothing -- Only from Alonzo onwards + , protocolParamUTxOCostPerByte = Nothing -- Only from Babbage onwards + , protocolParamDecentralization = Nothing -- Obsolete from Babbage onwards + , protocolParamExtraPraosEntropy = Nothing -- Obsolete from Alonzo onwards + , protocolParamMinUTxOValue = Nothing -- Obsolete from Alonzo onwards } +fromShelleyPParams :: ( EraPParams ledgerera + , Ledger.AtMostEra Ledger.MaryEra ledgerera + , Ledger.AtMostEra Ledger.AlonzoEra ledgerera + ) + => PParams ledgerera + -> ProtocolParameters +fromShelleyPParams pp = + (fromShelleyCommonPParams pp) { + protocolParamDecentralization = Just . Ledger.unboundRational $ pp ^. ppDL + , protocolParamExtraPraosEntropy = fromLedgerNonce $ pp ^. ppExtraEntropyL + , protocolParamMinUTxOValue = Just . fromShelleyLovelace $ pp ^. ppMinUTxOValueL + } -fromAlonzoPParams :: AlonzoPParams ledgerera -> ProtocolParameters -fromAlonzoPParams - AlonzoPParams { - _minfeeA - , _minfeeB - , _maxBBSize - , _maxTxSize - , _maxBHSize - , _keyDeposit - , _poolDeposit - , _eMax - , _nOpt - , _a0 - , _rho - , _tau - , _d - , _extraEntropy - , _protocolVersion - , _minPoolCost - , _coinsPerUTxOWord - , _costmdls - , _prices - , _maxTxExUnits - , _maxBlockExUnits - , _maxValSize - , _collateralPercentage - , _maxCollateralInputs - } = - ProtocolParameters { - protocolParamProtocolVersion = (\(Ledger.ProtVer a b) -> (a,b)) - _protocolVersion - , protocolParamDecentralization = Just $ Ledger.unboundRational _d - , protocolParamExtraPraosEntropy = fromLedgerNonce _extraEntropy - , protocolParamMaxBlockHeaderSize = _maxBHSize - , protocolParamMaxBlockBodySize = _maxBBSize - , protocolParamMaxTxSize = _maxTxSize - , protocolParamTxFeeFixed = _minfeeB - , protocolParamTxFeePerByte = _minfeeA - , protocolParamMinUTxOValue = Nothing - , protocolParamStakeAddressDeposit = fromShelleyLovelace _keyDeposit - , protocolParamStakePoolDeposit = fromShelleyLovelace _poolDeposit - , protocolParamMinPoolCost = fromShelleyLovelace _minPoolCost - , protocolParamPoolRetireMaxEpoch = _eMax - , protocolParamStakePoolTargetNum = _nOpt - , protocolParamPoolPledgeInfluence = Ledger.unboundRational _a0 - , protocolParamMonetaryExpansion = Ledger.unboundRational _rho - , protocolParamTreasuryCut = Ledger.unboundRational _tau - , protocolParamUTxOCostPerWord = Just (fromShelleyLovelace _coinsPerUTxOWord) - , protocolParamCostModels = fromAlonzoCostModels _costmdls - , protocolParamPrices = Just (fromAlonzoPrices _prices) - , protocolParamMaxTxExUnits = Just (fromAlonzoExUnits _maxTxExUnits) - , protocolParamMaxBlockExUnits = Just (fromAlonzoExUnits _maxBlockExUnits) - , protocolParamMaxValueSize = Just _maxValSize - , protocolParamCollateralPercent = Just _collateralPercentage - , protocolParamMaxCollateralInputs = Just _maxCollateralInputs - , protocolParamUTxOCostPerByte = Nothing -- Only from babbage onwards + +fromAlonzoCommonPParams :: AlonzoEraPParams ledgerera + => PParams ledgerera + -> ProtocolParameters +fromAlonzoCommonPParams pp = + (fromShelleyCommonPParams pp) { + protocolParamCostModels = fromAlonzoCostModels $ pp ^. ppCostModelsL + , protocolParamPrices = Just . fromAlonzoPrices $ pp ^. ppPricesL + , protocolParamMaxTxExUnits = Just . fromAlonzoExUnits $ pp ^. ppMaxTxExUnitsL + , protocolParamMaxBlockExUnits = Just . fromAlonzoExUnits $ pp ^. ppMaxBlockExUnitsL + , protocolParamMaxValueSize = Just $ pp ^. ppMaxValSizeL + , protocolParamCollateralPercent = Just $ pp ^. ppCollateralPercentageL + , protocolParamMaxCollateralInputs = Just $ pp ^. ppMaxCollateralInputsL } -fromBabbagePParams :: BabbagePParams ledgerera -> ProtocolParameters -fromBabbagePParams - BabbagePParams { - _minfeeA - , _minfeeB - , _maxBBSize - , _maxTxSize - , _maxBHSize - , _keyDeposit - , _poolDeposit - , _eMax - , _nOpt - , _a0 - , _rho - , _tau - , _protocolVersion - , _minPoolCost - , _coinsPerUTxOByte - , _costmdls - , _prices - , _maxTxExUnits - , _maxBlockExUnits - , _maxValSize - , _collateralPercentage - , _maxCollateralInputs - } = - ProtocolParameters { - protocolParamProtocolVersion = (\(Ledger.ProtVer a b) -> (a,b)) - _protocolVersion - , protocolParamDecentralization = Nothing - , protocolParamExtraPraosEntropy = Nothing - , protocolParamMaxBlockHeaderSize = _maxBHSize - , protocolParamMaxBlockBodySize = _maxBBSize - , protocolParamMaxTxSize = _maxTxSize - , protocolParamTxFeeFixed = _minfeeB - , protocolParamTxFeePerByte = _minfeeA - , protocolParamMinUTxOValue = Nothing - , protocolParamStakeAddressDeposit = fromShelleyLovelace _keyDeposit - , protocolParamStakePoolDeposit = fromShelleyLovelace _poolDeposit - , protocolParamMinPoolCost = fromShelleyLovelace _minPoolCost - , protocolParamPoolRetireMaxEpoch = _eMax - , protocolParamStakePoolTargetNum = _nOpt - , protocolParamPoolPledgeInfluence = Ledger.unboundRational _a0 - , protocolParamMonetaryExpansion = Ledger.unboundRational _rho - , protocolParamTreasuryCut = Ledger.unboundRational _tau - , protocolParamUTxOCostPerWord = Nothing -- Obsolete from babbage onwards - , protocolParamCostModels = fromAlonzoCostModels _costmdls - , protocolParamPrices = Just (fromAlonzoPrices _prices) - , protocolParamMaxTxExUnits = Just (fromAlonzoExUnits _maxTxExUnits) - , protocolParamMaxBlockExUnits = Just (fromAlonzoExUnits _maxBlockExUnits) - , protocolParamMaxValueSize = Just _maxValSize - , protocolParamCollateralPercent = Just _collateralPercentage - , protocolParamMaxCollateralInputs = Just _maxCollateralInputs - , protocolParamUTxOCostPerByte = Just (fromShelleyLovelace _coinsPerUTxOByte) + +fromAlonzoPParams :: Ledger.Crypto crypto + => PParams (Ledger.AlonzoEra crypto) + -> ProtocolParameters +fromAlonzoPParams pp = + (fromShelleyCommonPParams pp) { + protocolParamUTxOCostPerWord = Just . fromShelleyLovelace . unCoinPerWord $ + pp ^. ppCoinsPerUTxOWordL + } + +fromBabbagePParams :: BabbageEraPParams ledgerera + => PParams ledgerera + -> ProtocolParameters +fromBabbagePParams pp = + (fromAlonzoCommonPParams pp) { + protocolParamUTxOCostPerByte = Just . fromShelleyLovelace . unCoinPerByte $ + pp ^. ppCoinsPerUTxOByteL } -fromConwayPParams :: BabbagePParams ledgerera -> ProtocolParameters +fromConwayPParams :: BabbageEraPParams ledgerera + => PParams ledgerera + -> ProtocolParameters fromConwayPParams = fromBabbagePParams data ProtocolParametersError = diff --git a/cardano-cli/cardano-cli.cabal b/cardano-cli/cardano-cli.cabal index 907e21abcdd..a5c29f861f5 100644 --- a/cardano-cli/cardano-cli.cabal +++ b/cardano-cli/cardano-cli.cabal @@ -114,12 +114,12 @@ library , cardano-crypto-wrapper ^>= 1.5 , cardano-data ^>= 1.0 , cardano-git-rev - , cardano-ledger-alonzo ^>= 1.0 - , cardano-ledger-allegra ^>= 1.0 + , cardano-ledger-alonzo ^>= 1.1 + , cardano-ledger-allegra ^>= 1.1 , cardano-ledger-byron ^>= 1.0 - , cardano-ledger-core ^>= 1.0 - , cardano-ledger-mary ^>= 1.0 - , cardano-ledger-shelley ^>= 1.0 + , cardano-ledger-core ^>= 1.1 + , cardano-ledger-mary ^>= 1.1 + , cardano-ledger-shelley ^>= 1.1 , cardano-ping , cardano-prelude , cardano-protocol-tpraos ^>= 1.0 diff --git a/cardano-node/cardano-node.cabal b/cardano-node/cardano-node.cabal index 044723ffc7b..151411cd7a5 100644 --- a/cardano-node/cardano-node.cabal +++ b/cardano-node/cardano-node.cabal @@ -181,7 +181,7 @@ library , network-mux ^>= 0.3 , nothunks , optparse-applicative-fork - , ouroboros-consensus ^>= 0.2 + , ouroboros-consensus ^>= 0.3 , ouroboros-consensus-byron , ouroboros-consensus-cardano , ouroboros-consensus-diffusion From 183b1f516747e3e6258131089560c5c9be28af70 Mon Sep 17 00:00:00 2001 From: Alexey Kuleshevich Date: Fri, 3 Mar 2023 23:59:50 +0300 Subject: [PATCH 08/38] Genesis and Certificates are done --- cardano-api/src/Cardano/Api/Certificate.hs | 85 +++++++++++----------- 1 file changed, 44 insertions(+), 41 deletions(-) diff --git a/cardano-api/src/Cardano/Api/Certificate.hs b/cardano-api/src/Cardano/Api/Certificate.hs index 605ef81e9d3..b7a4df8f08e 100644 --- a/cardano-api/src/Cardano/Api/Certificate.hs +++ b/cardano-api/src/Cardano/Api/Certificate.hs @@ -1,6 +1,7 @@ {-# LANGUAGE DeriveAnyClass #-} {-# LANGUAGE DerivingStrategies #-} {-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE TypeApplications #-} {-# LANGUAGE TypeFamilies #-} -- | Certificates embedded in transactions @@ -56,6 +57,8 @@ import Cardano.Ledger.Crypto (StandardCrypto) import Cardano.Ledger.BaseTypes (maybeToStrictMaybe, strictMaybeToMaybe) import qualified Cardano.Ledger.BaseTypes as Shelley import qualified Cardano.Ledger.Coin as Shelley (toDeltaCoin) +import qualified Cardano.Ledger.Core as Shelley +import qualified Cardano.Ledger.Shelley as Shelley import Cardano.Ledger.Shelley.TxBody (MIRPot (..)) import qualified Cardano.Ledger.Shelley.TxBody as Shelley @@ -100,10 +103,10 @@ instance HasTypeProxy Certificate where proxyToAsType _ = AsCertificate instance ToCBOR Certificate where - toCBOR = toCBOR . toShelleyCertificate + toCBOR = Shelley.toEraCBOR @Shelley.Shelley . toShelleyCertificate instance FromCBOR Certificate where - fromCBOR = fromShelleyCertificate <$> fromCBOR + fromCBOR = fromShelleyCertificate <$> Shelley.fromEraCBOR @Shelley.Shelley instance HasTextEnvelope Certificate where textEnvelopeType _ = "CertificateShelley" @@ -247,7 +250,7 @@ toShelleyCertificate (GenesisKeyDelegationCertificate (GenesisDelegateKeyHash delegatekh) (VrfKeyHash vrfkh)) = Shelley.DCertGenesis $ - Shelley.GenesisDelegCert + Shelley.ConstitutionalDelegCert genesiskh delegatekh vrfkh @@ -306,7 +309,7 @@ fromShelleyCertificate (Shelley.DCertPool (Shelley.RetirePool poolid epochno)) = epochno fromShelleyCertificate (Shelley.DCertGenesis - (Shelley.GenesisDelegCert genesiskh delegatekh vrfkh)) = + (Shelley.ConstitutionalDelegCert genesiskh delegatekh vrfkh)) = GenesisKeyDelegationCertificate (GenesisKeyHash genesiskh) (GenesisDelegateKeyHash delegatekh) @@ -345,19 +348,19 @@ toShelleyPoolParams StakePoolParameters { --TODO: validate pool parameters such as the PoolMargin below, but also -- do simple client-side sanity checks, e.g. on the pool metadata url Shelley.PoolParams { - Shelley._poolId = poolkh - , Shelley._poolVrf = vrfkh - , Shelley._poolPledge = toShelleyLovelace stakePoolPledge - , Shelley._poolCost = toShelleyLovelace stakePoolCost - , Shelley._poolMargin = fromMaybe - (error "toShelleyPoolParams: invalid PoolMargin") - (Shelley.boundRational stakePoolMargin) - , Shelley._poolRAcnt = toShelleyStakeAddr stakePoolRewardAccount - , Shelley._poolOwners = Set.fromList - [ kh | StakeKeyHash kh <- stakePoolOwners ] - , Shelley._poolRelays = Seq.fromList - (map toShelleyStakePoolRelay stakePoolRelays) - , Shelley._poolMD = toShelleyPoolMetadata <$> + Shelley.ppId = poolkh + , Shelley.ppVrf = vrfkh + , Shelley.ppPledge = toShelleyLovelace stakePoolPledge + , Shelley.ppCost = toShelleyLovelace stakePoolCost + , Shelley.ppMargin = fromMaybe + (error "toShelleyPoolParams: invalid PoolMargin") + (Shelley.boundRational stakePoolMargin) + , Shelley.ppRewardAcnt = toShelleyStakeAddr stakePoolRewardAccount + , Shelley.ppOwners = Set.fromList + [ kh | StakeKeyHash kh <- stakePoolOwners ] + , Shelley.ppRelays = Seq.fromList + (map toShelleyStakePoolRelay stakePoolRelays) + , Shelley.ppMetadata = toShelleyPoolMetadata <$> maybeToStrictMaybe stakePoolMetadata } where @@ -383,8 +386,8 @@ toShelleyPoolParams StakePoolParameters { , stakePoolMetadataHash = StakePoolMetadataHash mdh } = Shelley.PoolMetadata { - Shelley._poolMDUrl = toShelleyUrl stakePoolMetadataURL - , Shelley._poolMDHash = Crypto.hashToBytes mdh + Shelley.pmUrl = toShelleyUrl stakePoolMetadataURL + , Shelley.pmHash = Crypto.hashToBytes mdh } toShelleyDnsName :: ByteString -> Shelley.DnsName @@ -401,28 +404,28 @@ fromShelleyPoolParams :: Shelley.PoolParams StandardCrypto -> StakePoolParameters fromShelleyPoolParams Shelley.PoolParams { - Shelley._poolId - , Shelley._poolVrf - , Shelley._poolPledge - , Shelley._poolCost - , Shelley._poolMargin - , Shelley._poolRAcnt - , Shelley._poolOwners - , Shelley._poolRelays - , Shelley._poolMD + Shelley.ppId + , Shelley.ppVrf + , Shelley.ppPledge + , Shelley.ppCost + , Shelley.ppMargin + , Shelley.ppRewardAcnt + , Shelley.ppOwners + , Shelley.ppRelays + , Shelley.ppMetadata } = StakePoolParameters { - stakePoolId = StakePoolKeyHash _poolId - , stakePoolVRF = VrfKeyHash _poolVrf - , stakePoolCost = fromShelleyLovelace _poolCost - , stakePoolMargin = Shelley.unboundRational _poolMargin - , stakePoolRewardAccount = fromShelleyStakeAddr _poolRAcnt - , stakePoolPledge = fromShelleyLovelace _poolPledge - , stakePoolOwners = map StakeKeyHash (Set.toList _poolOwners) + stakePoolId = StakePoolKeyHash ppId + , stakePoolVRF = VrfKeyHash ppVrf + , stakePoolCost = fromShelleyLovelace ppCost + , stakePoolMargin = Shelley.unboundRational ppMargin + , stakePoolRewardAccount = fromShelleyStakeAddr ppRewardAcnt + , stakePoolPledge = fromShelleyLovelace ppPledge + , stakePoolOwners = map StakeKeyHash (Set.toList ppOwners) , stakePoolRelays = map fromShelleyStakePoolRelay - (Foldable.toList _poolRelays) + (Foldable.toList ppRelays) , stakePoolMetadata = fromShelleyPoolMetadata <$> - strictMaybeToMaybe _poolMD + strictMaybeToMaybe ppMetadata } where fromShelleyStakePoolRelay :: Shelley.StakePoolRelay -> StakePoolRelay @@ -443,15 +446,15 @@ fromShelleyPoolParams fromShelleyPoolMetadata :: Shelley.PoolMetadata -> StakePoolMetadataReference fromShelleyPoolMetadata Shelley.PoolMetadata { - Shelley._poolMDUrl - , Shelley._poolMDHash + Shelley.pmUrl + , Shelley.pmHash } = StakePoolMetadataReference { - stakePoolMetadataURL = Shelley.urlToText _poolMDUrl + stakePoolMetadataURL = Shelley.urlToText pmUrl , stakePoolMetadataHash = StakePoolMetadataHash . fromMaybe (error "fromShelleyPoolMetadata: invalid hash. TODO: proper validation") . Crypto.hashFromBytes - $ _poolMDHash + $ pmHash } --TODO: change the ledger rep of the DNS name to use ShortByteString From 7c049e4d1a48d40de68a241ddff7b474329371b2 Mon Sep 17 00:00:00 2001 From: Alexey Kuleshevich Date: Thu, 9 Mar 2023 04:31:13 +0300 Subject: [PATCH 09/38] cabal.project: Update ledger --- cabal.project | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/cabal.project b/cabal.project index 7b7cb35fbed..47ef2f63686 100644 --- a/cabal.project +++ b/cabal.project @@ -140,8 +140,8 @@ source-repository-package source-repository-package type: git location: https://github.com/input-output-hk/cardano-ledger - tag: 94425510a75bd61336e8e819e2521799575d7185 - --sha256: 15afwiqkja60pd2g6zjpvf131px38kb8zi3hcrfkxpxfapnkgq5v + tag: c15a020ce254967779ce6d6a3b6bc7745c47d90c + --sha256: 0c2yrlbf3sw3xm08hq8h4zbvk8cia6dzd92pdx6a7ff777y4iy6a subdir: eras/alonzo/impl eras/alonzo/test-suite From bb7fe962a989f64a88c6b59b713e76d974e46967 Mon Sep 17 00:00:00 2001 From: Alexey Kuleshevich Date: Tue, 7 Mar 2023 02:26:36 +0300 Subject: [PATCH 10/38] TxBody is building! --- cardano-api/cardano-api.cabal | 3 +- cardano-api/src/Cardano/Api/TxBody.hs | 1150 +++++++++++-------------- 2 files changed, 508 insertions(+), 645 deletions(-) diff --git a/cardano-api/cardano-api.cabal b/cardano-api/cardano-api.cabal index f8884cd5df2..ec6086ea0da 100644 --- a/cardano-api/cardano-api.cabal +++ b/cardano-api/cardano-api.cabal @@ -121,10 +121,11 @@ library , cardano-data ^>= 1.0 , cardano-ledger-alonzo ^>= 1.1 , cardano-ledger-allegra ^>= 1.1 - , cardano-ledger-api >= 1.0 + , cardano-ledger-api >= 1.1 , cardano-ledger-babbage ^>= 1.1 , cardano-ledger-binary ^>= 1.0.1 , cardano-ledger-byron ^>= 1.0 + , cardano-ledger-conway ^>= 1.1 , cardano-ledger-core ^>= 1.1 , cardano-ledger-mary ^>= 1.1 , cardano-ledger-shelley ^>= 1.1 diff --git a/cardano-api/src/Cardano/Api/TxBody.hs b/cardano-api/src/Cardano/Api/TxBody.hs index 73312d0adf2..2fcf0255415 100644 --- a/cardano-api/src/Cardano/Api/TxBody.hs +++ b/cardano-api/src/Cardano/Api/TxBody.hs @@ -169,12 +169,13 @@ import qualified Data.ByteString.Char8 as BSC import qualified Data.ByteString.Lazy as LBS import Data.Foldable (for_, toList) import Data.Function (on) +import Data.Functor (($>)) import Data.List (intercalate, sortBy) import qualified Data.List as List import qualified Data.List.NonEmpty as NonEmpty import Data.Map.Strict (Map) import qualified Data.Map.Strict as Map -import Data.Maybe (catMaybes, fromMaybe, maybeToList) +import Data.Maybe (catMaybes, fromMaybe, mapMaybe, maybeToList) import Data.Scientific (toBoundedInteger) import qualified Data.Sequence.Strict as Seq import Data.Set (Set) @@ -185,69 +186,48 @@ import qualified Data.Text as Text import Data.Type.Equality (TestEquality (..), (:~:) (Refl)) import Data.Word (Word16, Word32, Word64) import GHC.Generics -import GHC.Records (HasField (..)) import Lens.Micro hiding (ix) +import Lens.Micro.Extras (view) import qualified Text.Parsec as Parsec import Text.Parsec (()) import qualified Text.Parsec.String as Parsec -import Cardano.Binary (Annotated (..), reAnnotate, recoverBytes) -import qualified Cardano.Binary as CBOR import qualified Cardano.Crypto.Hash.Class as Crypto -import qualified Cardano.Ledger.Serialization as CBOR (Sized, decodeNullMaybe, encodeNullMaybe, - mkSized, sizedValue) +import Cardano.Ledger.Binary (Annotated (..), reAnnotate, recoverBytes) +import qualified Cardano.Ledger.Binary as CBOR import Cardano.Slotting.Slot (SlotNo (..)) import qualified Cardano.Chain.Common as Byron import qualified Cardano.Chain.UTxO as Byron import qualified Cardano.Crypto.Hashing as Byron -import qualified Cardano.Ledger.Address as Shelley -import qualified Cardano.Ledger.AuxiliaryData as Ledger -import Cardano.Ledger.Babbage.TxBody (BabbageEraTxBody (..), - BabbageTxBody (BabbageTxBody), BabbageTxOut (BabbageTxOut)) -import Cardano.Ledger.BaseTypes (StrictMaybe (..), maybeToStrictMaybe) +import qualified Cardano.Ledger.Api as L + +import Cardano.Ledger.BaseTypes (StrictMaybe (..)) import qualified Cardano.Ledger.Block as Ledger -import qualified Cardano.Ledger.Coin as Ledger -import Cardano.Ledger.Core (EraAuxiliaryData) import qualified Cardano.Ledger.Core as Core import qualified Cardano.Ledger.Core as Ledger import qualified Cardano.Ledger.Credential as Shelley import Cardano.Ledger.Crypto (StandardCrypto) -import qualified Cardano.Ledger.Era as CC import qualified Cardano.Ledger.Keys as Shelley import qualified Cardano.Ledger.SafeHash as SafeHash -import qualified Cardano.Ledger.TxIn as Ledger -import Cardano.Ledger.Val (isZero) +import qualified Cardano.Ledger.TxIn as L +import Cardano.Ledger.Val as L (isZero) -import Cardano.Ledger.Shelley.API (ShelleyTxOut (ShelleyTxOut)) -import qualified Cardano.Ledger.Shelley.API as Ledger hiding (TxBody, TxOut) +import qualified Cardano.Ledger.Shelley.API as Ledger +import qualified Cardano.Ledger.Shelley.Delegation.Certificates as Shelley import qualified Cardano.Ledger.Shelley.Genesis as Shelley -import qualified Cardano.Ledger.Shelley.Metadata as Shelley -import qualified Cardano.Ledger.Shelley.Tx as Shelley -import qualified Cardano.Ledger.Shelley.TxBody as Shelley - -import Cardano.Ledger.Mary.Value (MaryValue) -import Cardano.Ledger.ShelleyMA.AuxiliaryData (MAAuxiliaryData (..)) -import qualified Cardano.Ledger.ShelleyMA.AuxiliaryData as Allegra -import Cardano.Ledger.ShelleyMA.TxBody (MATxBody (..)) -import qualified Cardano.Ledger.ShelleyMA.TxBody as Allegra -import qualified Cardano.Ledger.ShelleyMA.TxBody as Mary - -import Cardano.Ledger.Alonzo.Data (AlonzoAuxiliaryData (AlonzoAuxiliaryData)) -import qualified Cardano.Ledger.Alonzo.Data as Alonzo + +import Cardano.Ledger.Mary.Value as L (MaryValue (..), MultiAsset) + import qualified Cardano.Ledger.Alonzo.Language as Alonzo -import qualified Cardano.Ledger.Alonzo.PParams as Alonzo import qualified Cardano.Ledger.Alonzo.Scripts as Alonzo -import qualified Cardano.Ledger.Alonzo.Tx as Alonzo -import Cardano.Ledger.Alonzo.TxBody (AlonzoTxBody (AlonzoTxBody), - AlonzoTxOut (AlonzoTxOut)) -import qualified Cardano.Ledger.Alonzo.TxBody as Alonzo -import qualified Cardano.Ledger.Alonzo.TxWitness as Alonzo +import qualified Cardano.Ledger.Alonzo.Tx as Alonzo (hashScriptIntegrity) +import qualified Cardano.Ledger.Alonzo.TxWits as Alonzo -import qualified Cardano.Ledger.Babbage.PParams as Babbage import qualified Cardano.Ledger.Babbage.TxBody as Babbage -import qualified Cardano.Ledger.Conway.TxBody as Conway +import qualified Cardano.Ledger.Conway.Core as L +import qualified Cardano.Ledger.Conway.Delegation.Certificates as Conway import Ouroboros.Consensus.Shelley.Eras (StandardAllegra, StandardAlonzo, StandardBabbage, StandardConway, StandardMary, StandardShelley) @@ -287,19 +267,19 @@ data ScriptValidity deriving (Eq, Show) -instance ToCBOR ScriptValidity where - toCBOR = toCBOR . scriptValidityToIsValid +instance CBOR.EncCBOR ScriptValidity where + encCBOR = CBOR.encCBOR . scriptValidityToIsValid -instance FromCBOR ScriptValidity where - fromCBOR = isValidToScriptValidity <$> fromCBOR +instance CBOR.DecCBOR ScriptValidity where + decCBOR = isValidToScriptValidity <$> CBOR.decCBOR -scriptValidityToIsValid :: ScriptValidity -> Alonzo.IsValid -scriptValidityToIsValid ScriptInvalid = Alonzo.IsValid False -scriptValidityToIsValid ScriptValid = Alonzo.IsValid True +scriptValidityToIsValid :: ScriptValidity -> L.IsValid +scriptValidityToIsValid ScriptInvalid = L.IsValid False +scriptValidityToIsValid ScriptValid = L.IsValid True -isValidToScriptValidity :: Alonzo.IsValid -> ScriptValidity -isValidToScriptValidity (Alonzo.IsValid False) = ScriptInvalid -isValidToScriptValidity (Alonzo.IsValid True) = ScriptValid +isValidToScriptValidity :: L.IsValid -> ScriptValidity +isValidToScriptValidity (L.IsValid False) = ScriptInvalid +isValidToScriptValidity (L.IsValid True) = ScriptValid -- | A representation of whether the era supports tx script validity. -- @@ -351,7 +331,7 @@ scriptValidityToTxScriptValidity era scriptValidity = case txScriptValiditySuppo Nothing -> TxScriptValidityNone Just witness -> TxScriptValidity witness scriptValidity -txScriptValidityToIsValid :: TxScriptValidity era -> Alonzo.IsValid +txScriptValidityToIsValid :: TxScriptValidity era -> L.IsValid txScriptValidityToIsValid = scriptValidityToIsValid . txScriptValidityToScriptValidity -- ---------------------------------------------------------------------------- @@ -754,28 +734,29 @@ toShelleyTxOut era (TxOut _ (TxOutAdaOnly AdaOnlyInByronEra _) _ _) = case era of {} toShelleyTxOut _ (TxOut addr (TxOutAdaOnly AdaOnlyInShelleyEra value) _ _) = - ShelleyTxOut (toShelleyAddr addr) (toShelleyLovelace value) + L.mkBasicTxOut (toShelleyAddr addr) (toShelleyLovelace value) toShelleyTxOut _ (TxOut addr (TxOutAdaOnly AdaOnlyInAllegraEra value) _ _) = - ShelleyTxOut (toShelleyAddr addr) (toShelleyLovelace value) + L.mkBasicTxOut (toShelleyAddr addr) (toShelleyLovelace value) toShelleyTxOut _ (TxOut addr (TxOutValue MultiAssetInMaryEra value) _ _) = - ShelleyTxOut (toShelleyAddr addr) (toMaryValue value) + L.mkBasicTxOut (toShelleyAddr addr) (toMaryValue value) toShelleyTxOut _ (TxOut addr (TxOutValue MultiAssetInAlonzoEra value) txoutdata _) = - AlonzoTxOut (toShelleyAddr addr) (toMaryValue value) - (toAlonzoTxOutDataHash txoutdata) + L.mkBasicTxOut (toShelleyAddr addr) (toMaryValue value) + & L.dataHashTxOutL .~ toAlonzoTxOutDataHash txoutdata toShelleyTxOut era (TxOut addr (TxOutValue MultiAssetInBabbageEra value) txoutdata refScript) = let cEra = shelleyBasedToCardanoEra era - in BabbageTxOut (toShelleyAddr addr) (toMaryValue value) - (toBabbageTxOutDatum txoutdata) - (refScriptToShelleyScript cEra refScript) + in L.mkBasicTxOut (toShelleyAddr addr) (toMaryValue value) + & L.datumTxOutL .~ toBabbageTxOutDatum txoutdata + & L.referenceScriptTxOutL .~ refScriptToShelleyScript cEra refScript toShelleyTxOut era (TxOut addr (TxOutValue MultiAssetInConwayEra value) txoutdata refScript) = let cEra = shelleyBasedToCardanoEra era - in BabbageTxOut (toShelleyAddr addr) (toMaryValue value) - (toBabbageTxOutDatum txoutdata) (refScriptToShelleyScript cEra refScript) + in L.mkBasicTxOut (toShelleyAddr addr) (toMaryValue value) + & L.datumTxOutL .~ toBabbageTxOutDatum txoutdata + & L.referenceScriptTxOutL .~ refScriptToShelleyScript cEra refScript fromShelleyTxOut :: ShelleyLedgerEra era ~ ledgerera => ShelleyBasedEra era @@ -789,7 +770,8 @@ fromShelleyTxOut era ledgerTxOut = (fromShelleyLovelace value)) TxOutDatumNone ReferenceScriptNone where - ShelleyTxOut addr value = ledgerTxOut + addr = ledgerTxOut ^. L.addrTxOutL + value = ledgerTxOut ^. L.valueTxOutL ShelleyBasedEraAllegra -> TxOut (fromShelleyAddr era addr) @@ -797,7 +779,8 @@ fromShelleyTxOut era ledgerTxOut = (fromShelleyLovelace value)) TxOutDatumNone ReferenceScriptNone where - ShelleyTxOut addr value = ledgerTxOut + addr = ledgerTxOut ^. L.addrTxOutL + value = ledgerTxOut ^. L.valueTxOutL ShelleyBasedEraMary -> TxOut (fromShelleyAddr era addr) @@ -805,7 +788,8 @@ fromShelleyTxOut era ledgerTxOut = (fromMaryValue value)) TxOutDatumNone ReferenceScriptNone where - ShelleyTxOut addr value = ledgerTxOut + addr = ledgerTxOut ^. L.addrTxOutL + value = ledgerTxOut ^. L.valueTxOutL ShelleyBasedEraAlonzo -> TxOut (fromShelleyAddr era addr) @@ -814,7 +798,9 @@ fromShelleyTxOut era ledgerTxOut = (fromAlonzoTxOutDataHash ScriptDataInAlonzoEra datahash) ReferenceScriptNone where - AlonzoTxOut addr value datahash = ledgerTxOut + addr = ledgerTxOut ^. L.addrTxOutL + value = ledgerTxOut ^. L.valueTxOutL + datahash = ledgerTxOut ^. L.dataHashTxOutL ShelleyBasedEraBabbage -> TxOut (fromShelleyAddr era addr) @@ -829,7 +815,10 @@ fromShelleyTxOut era ledgerTxOut = SJust refScript -> fromShelleyScriptToReferenceScript ShelleyBasedEraBabbage refScript) where - BabbageTxOut addr value datum mRefScript = ledgerTxOut + addr = ledgerTxOut ^. L.addrTxOutL + value = ledgerTxOut ^. L.valueTxOutL + datum = ledgerTxOut ^. L.datumTxOutL + mRefScript = ledgerTxOut ^. L.referenceScriptTxOutL ShelleyBasedEraConway -> TxOut (fromShelleyAddr era addr) @@ -844,21 +833,24 @@ fromShelleyTxOut era ledgerTxOut = SJust refScript -> fromShelleyScriptToReferenceScript ShelleyBasedEraConway refScript) where - BabbageTxOut addr value datum mRefScript = ledgerTxOut + addr = ledgerTxOut ^. L.addrTxOutL + value = ledgerTxOut ^. L.valueTxOutL + datum = ledgerTxOut ^. L.datumTxOutL + mRefScript = ledgerTxOut ^. L.referenceScriptTxOutL -- TODO: If ledger creates an open type family for datums -- we can consolidate this function with the Babbage version toAlonzoTxOutDataHash :: TxOutDatum CtxUTxO AlonzoEra - -> StrictMaybe (Alonzo.DataHash StandardCrypto) + -> StrictMaybe (L.DataHash StandardCrypto) toAlonzoTxOutDataHash TxOutDatumNone = SNothing toAlonzoTxOutDataHash (TxOutDatumHash _ (ScriptDataHash dh)) = SJust dh toAlonzoTxOutDataHash (TxOutDatumInline inlineDatumSupp _sd) = case inlineDatumSupp :: ReferenceTxInsScriptsInlineDatumsSupportedInEra AlonzoEra of {} fromAlonzoTxOutDataHash :: ScriptDataSupportedInEra era - -> StrictMaybe (Alonzo.DataHash StandardCrypto) + -> StrictMaybe (L.DataHash StandardCrypto) -> TxOutDatum ctx era fromAlonzoTxOutDataHash _ SNothing = TxOutDatumNone fromAlonzoTxOutDataHash s (SJust dh) = TxOutDatumHash s (ScriptDataHash dh) @@ -866,14 +858,14 @@ fromAlonzoTxOutDataHash s (SJust dh) = TxOutDatumHash s (ScriptDataHash dh) -- TODO: If ledger creates an open type family for datums -- we can consolidate this function with the Alonzo version toBabbageTxOutDatum - :: Ledger.Crypto (ShelleyLedgerEra era) ~ StandardCrypto + :: (L.Era (ShelleyLedgerEra era), Ledger.EraCrypto (ShelleyLedgerEra era) ~ StandardCrypto) => TxOutDatum CtxUTxO era -> Babbage.Datum (ShelleyLedgerEra era) toBabbageTxOutDatum TxOutDatumNone = Babbage.NoDatum toBabbageTxOutDatum (TxOutDatumHash _ (ScriptDataHash dh)) = Babbage.DatumHash dh toBabbageTxOutDatum (TxOutDatumInline _ sd) = scriptDataToInlineDatum sd fromBabbageTxOutDatum - :: Ledger.Crypto ledgerera ~ StandardCrypto + :: (L.Era ledgerera, Ledger.EraCrypto ledgerera ~ StandardCrypto) => ScriptDataSupportedInEra era -> ReferenceTxInsScriptsInlineDatumsSupportedInEra era -> Babbage.Datum ledgerera @@ -1751,7 +1743,7 @@ data TxBody era where -- data (called the "redeemer") and the execution units. -> TxBodyScriptData era - -- The 'Ledger.AuxiliaryData' consists of one or several things, + -- The 'L.TxAuxData' consists of one or several things, -- depending on era: -- + transaction metadata (in Shelley and later) -- + auxiliary scripts (in Allegra and later) @@ -1759,7 +1751,7 @@ data TxBody era where -- extra script data has to be passed to scripts and hence is needed -- for validation. It is thus part of the witness data, not the -- auxiliary data. - -> Maybe (Ledger.AuxiliaryData (ShelleyLedgerEra era)) + -> Maybe (L.TxAuxData (ShelleyLedgerEra era)) -> TxScriptValidity era -- ^ Mark script as expected to pass or fail validation @@ -1777,12 +1769,12 @@ data TxBodyScriptData era where -> Alonzo.Redeemers (ShelleyLedgerEra era) -> TxBodyScriptData era -deriving instance Eq (TxBodyScriptData era) -deriving instance Show (TxBodyScriptData era) +deriving instance L.EraCrypto (ShelleyLedgerEra era) ~ StandardCrypto => Eq (TxBodyScriptData era) +deriving instance L.EraCrypto (ShelleyLedgerEra era) ~ StandardCrypto => Show (TxBodyScriptData era) -- The GADT in the ShelleyTxBody case requires a custom instance -instance Eq (TxBody era) where +instance L.EraCrypto (ShelleyLedgerEra era) ~ StandardCrypto => Eq (TxBody era) where (==) (ByronTxBody txbodyA) (ByronTxBody txbodyB) = txbodyA == txbodyB @@ -1824,7 +1816,7 @@ instance Eq (TxBody era) where -- The GADT in the ShelleyTxBody case requires a custom instance -instance Show (TxBody era) where +instance L.EraCrypto (ShelleyLedgerEra era) ~ StandardCrypto => Show (TxBody era) where showsPrec p (ByronTxBody txbody) = showParen (p >= 11) ( showString "ByronTxBody " @@ -1964,11 +1956,12 @@ instance IsCardanoEra era => SerialiseAsCBOR (TxBody era) where ByronEra -> ByronTxBody <$> CBOR.decodeFullAnnotatedBytes + (CBOR.byronProtVer) "Byron TxBody" - CBOR.fromCBORAnnotated + CBOR.decCBORAnnotated (LBS.fromStrict bs) - -- Use the same derialisation impl, but at different types: + -- Use the same deserialisation impl, but at different types: ShelleyEra -> deserialiseShelleyBasedTxBody ShelleyBasedEraShelley bs AllegraEra -> deserialiseShelleyBasedTxBody ShelleyBasedEraAllegra bs MaryEra -> deserialiseShelleyBasedTxBody ShelleyBasedEraMary bs @@ -1980,79 +1973,82 @@ instance IsCardanoEra era => SerialiseAsCBOR (TxBody era) where -- same, but they can be handled generally with one overloaded implementation. serialiseShelleyBasedTxBody :: forall era ledgerera. - ShelleyLedgerEra era ~ ledgerera - => ToCBOR (Ledger.TxBody ledgerera) - => ToCBOR (Ledger.Script ledgerera) - => ToCBOR (Alonzo.TxDats ledgerera) - => ToCBOR (Alonzo.Redeemers ledgerera) - => ToCBOR (Ledger.AuxiliaryData ledgerera) + L.Era ledgerera + => ShelleyLedgerEra era ~ ledgerera + => CBOR.EncCBOR (Ledger.TxBody ledgerera) + => CBOR.EncCBOR (Ledger.Script ledgerera) + => CBOR.EncCBOR (Alonzo.TxDats ledgerera) + => CBOR.EncCBOR (Alonzo.Redeemers ledgerera) + => CBOR.EncCBOR (L.TxAuxData ledgerera) => ShelleyBasedEra era -> Ledger.TxBody ledgerera -> [Ledger.Script ledgerera] -> TxBodyScriptData era - -> Maybe (Ledger.AuxiliaryData ledgerera) + -> Maybe (L.TxAuxData ledgerera) -> TxScriptValidity era -- ^ Mark script as expected to pass or fail validation -> ByteString serialiseShelleyBasedTxBody era txbody txscripts TxBodyNoScriptData txmetadata scriptValidity = -- Backwards compat for pre-Alonzo era tx body files case era of - ShelleyBasedEraShelley -> preAlonzo - ShelleyBasedEraAllegra -> preAlonzo - ShelleyBasedEraMary -> preAlonzo + ShelleyBasedEraShelley -> preAlonzo (L.eraProtVerLow @L.Shelley) + ShelleyBasedEraAllegra -> preAlonzo (L.eraProtVerLow @L.Allegra) + ShelleyBasedEraMary -> preAlonzo (L.eraProtVerLow @L.Mary) ShelleyBasedEraAlonzo -> - CBOR.serializeEncoding' + CBOR.serialize' (L.eraProtVerLow @L.Alonzo) $ CBOR.encodeListLen 4 - <> CBOR.toCBOR txbody - <> CBOR.toCBOR txscripts - <> CBOR.toCBOR (txScriptValidityToScriptValidity scriptValidity) - <> CBOR.encodeNullMaybe CBOR.toCBOR txmetadata + <> CBOR.encCBOR txbody + <> CBOR.encCBOR txscripts + <> CBOR.encCBOR (txScriptValidityToScriptValidity scriptValidity) + <> CBOR.encodeNullMaybe CBOR.encCBOR txmetadata ShelleyBasedEraBabbage -> - CBOR.serializeEncoding' + CBOR.serialize' (L.eraProtVerLow @L.Babbage) $ CBOR.encodeListLen 4 - <> CBOR.toCBOR txbody - <> CBOR.toCBOR txscripts - <> CBOR.toCBOR (txScriptValidityToScriptValidity scriptValidity) - <> CBOR.encodeNullMaybe CBOR.toCBOR txmetadata + <> CBOR.encCBOR txbody + <> CBOR.encCBOR txscripts + <> CBOR.encCBOR (txScriptValidityToScriptValidity scriptValidity) + <> CBOR.encodeNullMaybe CBOR.encCBOR txmetadata ShelleyBasedEraConway -> - CBOR.serializeEncoding' + CBOR.serialize' (L.eraProtVerLow @L.Babbage) $ CBOR.encodeListLen 4 - <> CBOR.toCBOR txbody - <> CBOR.toCBOR txscripts - <> CBOR.toCBOR (txScriptValidityToScriptValidity scriptValidity) - <> CBOR.encodeNullMaybe CBOR.toCBOR txmetadata + <> CBOR.encCBOR txbody + <> CBOR.encCBOR txscripts + <> CBOR.encCBOR (txScriptValidityToScriptValidity scriptValidity) + <> CBOR.encodeNullMaybe CBOR.encCBOR txmetadata where - preAlonzo = CBOR.serializeEncoding' + preAlonzo v = CBOR.serialize' v $ CBOR.encodeListLen 3 - <> CBOR.toCBOR txbody - <> CBOR.toCBOR txscripts - <> CBOR.encodeNullMaybe CBOR.toCBOR txmetadata + <> CBOR.encCBOR txbody + <> CBOR.encCBOR txscripts + <> CBOR.encodeNullMaybe CBOR.encCBOR txmetadata serialiseShelleyBasedTxBody _era txbody txscripts (TxBodyScriptData _ datums redeemers) - txmetadata txBodycriptValidity = - CBOR.serializeEncoding' $ + txmetadata txBodyScriptValidity = + CBOR.serialize' (L.eraProtVerLow @ledgerera) $ CBOR.encodeListLen 6 - <> CBOR.toCBOR txbody - <> CBOR.toCBOR txscripts - <> CBOR.toCBOR datums - <> CBOR.toCBOR redeemers - <> CBOR.toCBOR (txScriptValidityToScriptValidity txBodycriptValidity) - <> CBOR.encodeNullMaybe CBOR.toCBOR txmetadata + <> CBOR.encCBOR txbody + <> CBOR.encCBOR txscripts + <> CBOR.encCBOR datums + <> CBOR.encCBOR redeemers + <> CBOR.encCBOR (txScriptValidityToScriptValidity txBodyScriptValidity) + <> CBOR.encodeNullMaybe CBOR.encCBOR txmetadata deserialiseShelleyBasedTxBody :: forall era ledgerera. - ShelleyLedgerEra era ~ ledgerera - => FromCBOR (CBOR.Annotator (Ledger.TxBody ledgerera)) - => FromCBOR (CBOR.Annotator (Ledger.Script ledgerera)) - => FromCBOR (CBOR.Annotator (Alonzo.TxDats ledgerera)) - => FromCBOR (CBOR.Annotator (Alonzo.Redeemers ledgerera)) - => FromCBOR (CBOR.Annotator (Ledger.AuxiliaryData ledgerera)) + L.Era ledgerera + => ShelleyLedgerEra era ~ ledgerera + => CBOR.DecCBOR (CBOR.Annotator (Ledger.TxBody ledgerera)) + => CBOR.DecCBOR (CBOR.Annotator (Ledger.Script ledgerera)) + => CBOR.DecCBOR (CBOR.Annotator (Alonzo.TxDats ledgerera)) + => CBOR.DecCBOR (CBOR.Annotator (Alonzo.Redeemers ledgerera)) + => CBOR.DecCBOR (CBOR.Annotator (L.TxAuxData ledgerera)) => ShelleyBasedEra era -> ByteString -> Either CBOR.DecoderError (TxBody era) deserialiseShelleyBasedTxBody era bs = - CBOR.decodeAnnotator + CBOR.decodeFullAnnotator + (L.eraProtVerLow @ledgerera) "Shelley TxBody" decodeAnnotatedTuple (LBS.fromStrict bs) @@ -2064,8 +2060,8 @@ deserialiseShelleyBasedTxBody era bs = case len of -- Backwards compat for pre-Alonzo era tx body files 2 -> do - txbody <- fromCBOR - txmetadata <- CBOR.decodeNullMaybe fromCBOR + txbody <- CBOR.decCBOR + txmetadata <- CBOR.decodeNullMaybe CBOR.decCBOR return $ CBOR.Annotator $ \fbs -> ShelleyTxBody era (flip CBOR.runAnnotator fbs txbody) @@ -2074,9 +2070,9 @@ deserialiseShelleyBasedTxBody era bs = (fmap (flip CBOR.runAnnotator fbs) txmetadata) (flip CBOR.runAnnotator fbs (return TxScriptValidityNone)) 3 -> do - txbody <- fromCBOR - txscripts <- fromCBOR - txmetadata <- CBOR.decodeNullMaybe fromCBOR + txbody <- CBOR.decCBOR + txscripts <- CBOR.decCBOR + txmetadata <- CBOR.decodeNullMaybe CBOR.decCBOR return $ CBOR.Annotator $ \fbs -> ShelleyTxBody era (flip CBOR.runAnnotator fbs txbody) @@ -2094,10 +2090,10 @@ deserialiseShelleyBasedTxBody era bs = ] Just supported -> return supported - txbody <- fromCBOR - txscripts <- fromCBOR - scriptValidity <- fromCBOR - txmetadata <- CBOR.decodeNullMaybe fromCBOR + txbody <- CBOR.decCBOR + txscripts <- CBOR.decCBOR + scriptValidity <- CBOR.decCBOR + txmetadata <- CBOR.decodeNullMaybe CBOR.decCBOR return $ CBOR.Annotator $ \fbs -> ShelleyTxBody era (flip CBOR.runAnnotator fbs txbody) @@ -2124,12 +2120,12 @@ deserialiseShelleyBasedTxBody era bs = ] Just supported -> return supported - txbody <- fromCBOR - txscripts <- fromCBOR - datums <- fromCBOR - redeemers <- fromCBOR - scriptValidity <- fromCBOR - txmetadata <- CBOR.decodeNullMaybe fromCBOR + txbody <- CBOR.decCBOR + txscripts <- CBOR.decCBOR + datums <- CBOR.decCBOR + redeemers <- CBOR.decCBOR + scriptValidity <- CBOR.decCBOR + txmetadata <- CBOR.decodeNullMaybe CBOR.decCBOR let txscriptdata = CBOR.Annotator $ \fbs -> TxBodyScriptData sDataSupported @@ -2175,7 +2171,7 @@ getTxId (ShelleyTxBody era tx _ _ _ _) = where obtainConstraints :: ShelleyBasedEra era - -> ((Ledger.Crypto (ShelleyLedgerEra era) ~ StandardCrypto, Ledger.EraTxBody (ShelleyLedgerEra era)) => a) + -> ((Ledger.EraCrypto (ShelleyLedgerEra era) ~ StandardCrypto, Ledger.EraTxBody (ShelleyLedgerEra era)) => a) -> a obtainConstraints ShelleyBasedEraShelley f = f obtainConstraints ShelleyBasedEraAllegra f = f @@ -2185,7 +2181,7 @@ getTxId (ShelleyTxBody era tx _ _ _ _) = obtainConstraints ShelleyBasedEraConway f = f getTxIdShelley - :: Ledger.Crypto (ShelleyLedgerEra era) ~ StandardCrypto + :: Ledger.EraCrypto (ShelleyLedgerEra era) ~ StandardCrypto => Ledger.EraTxBody (ShelleyLedgerEra era) => ShelleyBasedEra era -> Ledger.TxBody (ShelleyLedgerEra era) -> TxId getTxIdShelley _ tx = @@ -2255,37 +2251,44 @@ createTransactionBody era txBodyContent = apiTotalCollateral = txTotalCollateral txBodyContent -- Ledger types - txins = convTxIns $ txIns txBodyContent collTxIns = convCollateralTxIns apiCollateralTxIns refTxIns = convReferenceInputs apiReferenceInputs returnCollateral = convReturnCollateral era apiReturnCollateral totalCollateral = convTotalCollateral apiTotalCollateral - txOuts' = convTxOuts era apiTxOuts - babbageTxOuts = convBabbageTxOuts era apiTxOuts certs = convCertificates $ txCertificates txBodyContent - witDrwls = convWithdrawals $ txWithdrawals txBodyContent - fee = convTransactionFee era $ txFee txBodyContent - auxData = convAuxiliaryData $ txMetadata txBodyContent - ledgerAuxData = toAuxiliaryData era (txMetadata txBodyContent) (txAuxScripts txBodyContent) + conwayCerts = convConwayCertificates $ txCertificates txBodyContent + txAuxData = toAuxiliaryData era (txMetadata txBodyContent) (txAuxScripts txBodyContent) scripts = convScripts apiScriptWitnesses validityInterval = convValidityInterval $ txValidityRange txBodyContent languages = convLanguages apiScriptWitnesses + mkTxBody :: ( L.EraTxBody (ShelleyLedgerEra era) + , L.EraTxAuxData (ShelleyLedgerEra era) + , L.EraCrypto (ShelleyLedgerEra era) ~ StandardCrypto) + => ShelleyBasedEra era + -> TxBodyContent BuildTx era + -> Maybe (L.TxAuxData (ShelleyLedgerEra era)) + -> L.TxBody (ShelleyLedgerEra era) + mkTxBody era' bc aux = + mkCommonTxBody + era' + (txIns bc) + (txOuts bc) + (txFee bc) + (txWithdrawals bc) + aux + in case era of ShelleyBasedEraShelley -> let (_, upperBound) = txValidityRange txBodyContent ttl = case upperBound of TxValidityNoUpperBound era' -> case era' of {} TxValidityUpperBound _ ttl' -> ttl' - ledgerTxBody = Ledger.ShelleyTxBody - txins - txOuts' - certs - witDrwls - fee - ttl - (convTxUpdateProposal era $ txUpdateProposal txBodyContent) - (convAuxiliaryDataToHash auxData) + update = convTxUpdateProposal era (txUpdateProposal txBodyContent) + ledgerTxBody = mkTxBody ShelleyBasedEraShelley txBodyContent txAuxData + & L.certsTxBodyL .~ certs + & L.ttlTxBodyL .~ ttl + & L.updateTxBodyL .~ update sData = convScriptData (shelleyBasedToCardanoEra era) apiTxOuts apiScriptWitnesses @@ -2293,43 +2296,34 @@ createTransactionBody era txBodyContent = ledgerTxBody scripts sData - (Just ledgerAuxData) + txAuxData apiScriptValidity ShelleyBasedEraAllegra -> - let ledgerTxBody = MATxBody - txins - txOuts' - certs - witDrwls - fee - validityInterval - (convTxUpdateProposal era $ txUpdateProposal txBodyContent) - (convAuxiliaryDataToHash auxData) - mempty -- No minting in Allegra! + let update = convTxUpdateProposal era (txUpdateProposal txBodyContent) + ledgerTxBody = mkTxBody ShelleyBasedEraAllegra txBodyContent txAuxData + & L.certsTxBodyL .~ certs + & L.updateTxBodyL .~ update + & L.vldtTxBodyL .~ validityInterval in ShelleyTxBody era ledgerTxBody scripts (convScriptData (shelleyBasedToCardanoEra era) apiTxOuts apiScriptWitnesses) - (Just ledgerAuxData) + txAuxData apiScriptValidity ShelleyBasedEraMary -> - let ledgerTxBody = MATxBody - txins - txOuts' - certs - witDrwls - fee - validityInterval - (convTxUpdateProposal era $ txUpdateProposal txBodyContent) - (convAuxiliaryDataToHash auxData) - (convMintValue apiMintValue) + let update = convTxUpdateProposal era (txUpdateProposal txBodyContent) + ledgerTxBody = mkTxBody ShelleyBasedEraMary txBodyContent txAuxData + & L.certsTxBodyL .~ certs + & L.updateTxBodyL .~ update + & L.vldtTxBodyL .~ validityInterval + & L.mintTxBodyL .~ convMintValue apiMintValue in ShelleyTxBody era ledgerTxBody scripts (convScriptData (shelleyBasedToCardanoEra era) apiTxOuts apiScriptWitnesses) - (Just ledgerAuxData) + txAuxData apiScriptValidity ShelleyBasedEraAlonzo -> let sData = convScriptData (shelleyBasedToCardanoEra era) apiTxOuts apiScriptWitnesses @@ -2344,25 +2338,23 @@ createTransactionBody era txBodyContent = datums languages - ledgerTxBody = AlonzoTxBody - txins - collTxIns - txOuts' - certs - witDrwls - fee - validityInterval - (convTxUpdateProposal era $ txUpdateProposal txBodyContent) - (convExtraKeyWitnesses apiExtraKeyWitnesses) - (convMintValue apiMintValue) - scriptIntegrityHash - (convAuxiliaryDataToHash auxData) - SNothing -- TODO: NetworkId for hardware wallets. We don't always want this + update = convTxUpdateProposal era (txUpdateProposal txBodyContent) + ledgerTxBody = mkTxBody ShelleyBasedEraAlonzo txBodyContent txAuxData + & L.certsTxBodyL .~ certs + & L.updateTxBodyL .~ update + & L.vldtTxBodyL .~ validityInterval + & L.collateralInputsTxBodyL .~ collTxIns + & L.reqSignerHashesTxBodyL .~ convExtraKeyWitnesses + apiExtraKeyWitnesses + & L.mintTxBodyL .~ convMintValue apiMintValue + & L.scriptIntegrityHashTxBodyL .~ scriptIntegrityHash + -- TODO: NetworkId for hardware wallets. We don't always want this + -- & L.networkIdTxBodyL .~ ... in ShelleyTxBody era ledgerTxBody scripts (convScriptData (shelleyBasedToCardanoEra era) apiTxOuts apiScriptWitnesses) - (Just ledgerAuxData) + txAuxData apiScriptValidity ShelleyBasedEraBabbage -> let sData = convScriptData (shelleyBasedToCardanoEra era) apiTxOuts apiScriptWitnesses @@ -2370,38 +2362,34 @@ createTransactionBody era txBodyContent = scriptIntegrityHash = case sData of TxBodyNoScriptData -> SNothing - TxBodyScriptData sDataSupported datums redeemers -> + TxBodyScriptData _sDataSupported datums redeemers -> getLedgerEraConstraint era - $ getHasFieldConstraints sDataSupported $ convPParamsToScriptIntegrityHash era apiProtocolParameters redeemers datums languages - - ledgerTxBody = BabbageTxBody - txins - collTxIns - refTxIns - babbageTxOuts - returnCollateral - totalCollateral - certs - witDrwls - fee - validityInterval - (convTxUpdateProposal era $ txUpdateProposal txBodyContent) - (convExtraKeyWitnesses apiExtraKeyWitnesses) - (convMintValue apiMintValue) - scriptIntegrityHash - (convAuxiliaryDataToHash auxData) - SNothing -- TODO: NetworkId for hardware wallets. We don't always want this + update = convTxUpdateProposal era (txUpdateProposal txBodyContent) + ledgerTxBody = mkTxBody ShelleyBasedEraBabbage txBodyContent txAuxData + & L.certsTxBodyL .~ certs + & L.updateTxBodyL .~ update + & L.vldtTxBodyL .~ validityInterval + & L.collateralInputsTxBodyL .~ collTxIns + & L.reqSignerHashesTxBodyL .~ convExtraKeyWitnesses + apiExtraKeyWitnesses + & L.mintTxBodyL .~ convMintValue apiMintValue + & L.scriptIntegrityHashTxBodyL .~ scriptIntegrityHash + & L.referenceInputsTxBodyL .~ refTxIns + & L.collateralReturnTxBodyL .~ returnCollateral + & L.totalCollateralTxBodyL .~ totalCollateral + -- TODO: NetworkId for hardware wallets. We don't always want this + -- & L.networkIdTxBodyL .~ ... in ShelleyTxBody era ledgerTxBody scripts sData - (Just ledgerAuxData) + txAuxData apiScriptValidity ShelleyBasedEraConway -> @@ -2410,38 +2398,32 @@ createTransactionBody era txBodyContent = scriptIntegrityHash = case sData of TxBodyNoScriptData -> SNothing - TxBodyScriptData sDataSupported datums redeemers -> + TxBodyScriptData _sDataSupported datums redeemers -> getLedgerEraConstraint era - $ getHasFieldConstraints sDataSupported $ convPParamsToScriptIntegrityHash era apiProtocolParameters redeemers datums languages - - ledgerTxBody = BabbageTxBody - txins - collTxIns - refTxIns - babbageTxOuts - returnCollateral - totalCollateral - certs - witDrwls - fee - validityInterval - (convTxUpdateProposal era $ txUpdateProposal txBodyContent) - (convExtraKeyWitnesses apiExtraKeyWitnesses) - (convMintValue apiMintValue) - scriptIntegrityHash - (convAuxiliaryDataToHash auxData) - SNothing -- TODO: NetworkId for hardware wallets. We don't always want this + ledgerTxBody = mkTxBody ShelleyBasedEraConway txBodyContent txAuxData + & L.conwayCertsTxBodyL .~ conwayCerts + & L.vldtTxBodyL .~ validityInterval + & L.collateralInputsTxBodyL .~ collTxIns + & L.reqSignerHashesTxBodyL .~ convExtraKeyWitnesses + apiExtraKeyWitnesses + & L.mintTxBodyL .~ convMintValue apiMintValue + & L.scriptIntegrityHashTxBodyL .~ scriptIntegrityHash + & L.referenceInputsTxBodyL .~ refTxIns + & L.collateralReturnTxBodyL .~ returnCollateral + & L.totalCollateralTxBodyL .~ totalCollateral + -- TODO: NetworkId for hardware wallets. We don't always want this + -- & L.networkIdTxBodyL .~ ... in ShelleyTxBody era ledgerTxBody scripts sData - (Just ledgerAuxData) + txAuxData apiScriptValidity validateTxBodyContent @@ -2577,17 +2559,17 @@ createAndValidateTransactionBody IsCardanoEra era => TxBodyContent BuildTx era -> Either TxBodyError (TxBody era) -createAndValidateTransactionBody = makeTransactionBody +createAndValidateTransactionBody = + case cardanoEraStyle (cardanoEra :: CardanoEra era) of + LegacyByronEra -> makeByronTransactionBody + ShelleyBasedEra era -> makeShelleyTransactionBody era {-# DEPRECATED makeTransactionBody "Use createAndValidateTransactionBody." #-} makeTransactionBody :: forall era. IsCardanoEra era => TxBodyContent BuildTx era -> Either TxBodyError (TxBody era) -makeTransactionBody = - case cardanoEraStyle (cardanoEra :: CardanoEra era) of - LegacyByronEra -> makeByronTransactionBody - ShelleyBasedEra era -> makeShelleyTransactionBody era +makeTransactionBody = createAndValidateTransactionBody pattern TxBody :: TxBodyContent ViewTx era -> TxBody era @@ -2604,7 +2586,7 @@ fromLedgerTxBody -> TxScriptValidity era -> Ledger.TxBody (ShelleyLedgerEra era) -> TxBodyScriptData era - -> Maybe (Ledger.AuxiliaryData (ShelleyLedgerEra era)) + -> Maybe (L.TxAuxData (ShelleyLedgerEra era)) -> TxBodyContent ViewTx era fromLedgerTxBody era scriptValidity body scriptdata mAux = TxBodyContent @@ -2642,12 +2624,12 @@ fromLedgerTxIns era body = inputs_ :: ShelleyBasedEra era -> Ledger.TxBody (ShelleyLedgerEra era) -> Set (Ledger.TxIn StandardCrypto) - inputs_ ShelleyBasedEraShelley = Shelley._inputs - inputs_ ShelleyBasedEraAllegra = Allegra.inputs' - inputs_ ShelleyBasedEraMary = Mary.inputs' - inputs_ ShelleyBasedEraAlonzo = Alonzo.inputs' - inputs_ ShelleyBasedEraBabbage = Babbage.inputs - inputs_ ShelleyBasedEraConway = Babbage.inputs + inputs_ ShelleyBasedEraShelley = view L.inputsTxBodyL + inputs_ ShelleyBasedEraAllegra = view L.inputsTxBodyL + inputs_ ShelleyBasedEraMary = view L.inputsTxBodyL + inputs_ ShelleyBasedEraAlonzo = view L.inputsTxBodyL + inputs_ ShelleyBasedEraBabbage = view L.inputsTxBodyL + inputs_ ShelleyBasedEraConway = view L.inputsTxBodyL fromLedgerTxInsCollateral @@ -2666,9 +2648,9 @@ fromLedgerTxInsCollateral era body = ShelleyBasedEraShelley -> [] ShelleyBasedEraAllegra -> [] ShelleyBasedEraMary -> [] - ShelleyBasedEraAlonzo -> toList $ Alonzo.collateral' body - ShelleyBasedEraBabbage -> toList $ Babbage.collateral body - ShelleyBasedEraConway -> toList $ Babbage.collateral body + ShelleyBasedEraAlonzo -> toList $ body ^. L.collateralInputsTxBodyL + ShelleyBasedEraBabbage -> toList $ body ^. L.collateralInputsTxBodyL + ShelleyBasedEraConway -> toList $ body ^. L.collateralInputsTxBodyL fromLedgerTxInsReference :: ShelleyBasedEra era -> Ledger.TxBody (ShelleyLedgerEra era) -> TxInsReference ViewTx era @@ -2676,13 +2658,14 @@ fromLedgerTxInsReference era txBody = case refInsScriptsAndInlineDatsSupportedInEra $ shelleyBasedToCardanoEra era of Nothing -> TxInsReferenceNone Just suppInEra -> - let ledgerRefInputs = obtainReferenceInputsHasFieldConstraint suppInEra $ txBody ^. referenceInputsTxBodyL + let ledgerRefInputs = + obtainReferenceInputsHasFieldConstraint suppInEra $ txBody ^. L.referenceInputsTxBodyL in TxInsReference suppInEra $ map fromShelleyTxIn . Set.toList $ ledgerRefInputs where obtainReferenceInputsHasFieldConstraint :: ReferenceTxInsScriptsInlineDatumsSupportedInEra era - -> ((CC.Crypto (ShelleyLedgerEra era) ~ StandardCrypto, BabbageEraTxBody (ShelleyLedgerEra era)) => a) + -> ((L.EraCrypto (ShelleyLedgerEra era) ~ StandardCrypto, L.BabbageEraTxBody (ShelleyLedgerEra era)) => a) -> a obtainReferenceInputsHasFieldConstraint ReferenceTxInsScriptsInlineDatumsInBabbageEra f = f obtainReferenceInputsHasFieldConstraint ReferenceTxInsScriptsInlineDatumsInConwayEra f = f @@ -2696,13 +2679,13 @@ fromLedgerTxOuts fromLedgerTxOuts era body scriptdata = case era of ShelleyBasedEraShelley -> - [ fromShelleyTxOut era txout | txout <- toList (Shelley._outputs body) ] + [ fromShelleyTxOut era txout | txout <- toList (body ^. L.outputsTxBodyL) ] ShelleyBasedEraAllegra -> - [ fromShelleyTxOut era txout | txout <- toList (Allegra.outputs' body) ] + [ fromShelleyTxOut era txout | txout <- toList (body ^. L.outputsTxBodyL) ] ShelleyBasedEraMary -> - [ fromShelleyTxOut era txout | txout <- toList (Mary.outputs' body) ] + [ fromShelleyTxOut era txout | txout <- toList (body ^. L.outputsTxBodyL) ] ShelleyBasedEraAlonzo -> [ fromAlonzoTxOut @@ -2711,7 +2694,7 @@ fromLedgerTxOuts era body scriptdata = txdatums txout | let txdatums = selectTxDatums scriptdata - , txout <- toList (Alonzo.outputs' body) ] + , txout <- toList (body ^. L.outputsTxBodyL) ] ShelleyBasedEraBabbage -> [ fromBabbageTxOut @@ -2719,19 +2702,20 @@ fromLedgerTxOuts era body scriptdata = ScriptDataInBabbageEra ReferenceTxInsScriptsInlineDatumsInBabbageEra txdatums - (CBOR.sizedValue txouts) + txouts | let txdatums = selectTxDatums scriptdata - , txouts <- toList (Babbage.outputs body) + , txouts <- toList (body ^. L.outputsTxBodyL) ] + ShelleyBasedEraConway -> [ fromBabbageTxOut MultiAssetInConwayEra ScriptDataInConwayEra ReferenceTxInsScriptsInlineDatumsInConwayEra txdatums - (CBOR.sizedValue txouts) + txouts | let txdatums = selectTxDatums scriptdata - , txouts <- toList (Conway.outputs body) + , txouts <- toList (body ^. L.outputsTxBodyL) ] where selectTxDatums TxBodyNoScriptData = Map.empty @@ -2739,24 +2723,23 @@ fromLedgerTxOuts era body scriptdata = fromAlonzoTxOut :: forall era ledgerera. IsShelleyBasedEra era - => Ledger.Era ledgerera - => Ledger.Crypto ledgerera ~ StandardCrypto + => L.AlonzoEraTxOut ledgerera + => Ledger.EraCrypto ledgerera ~ StandardCrypto => Ledger.Value ledgerera ~ MaryValue StandardCrypto => MultiAssetSupportedInEra era -> ScriptDataSupportedInEra era - -> Map (Alonzo.DataHash StandardCrypto) - (Alonzo.Data ledgerera) - -> AlonzoTxOut ledgerera + -> Map (L.DataHash StandardCrypto) + (L.Data ledgerera) + -> L.TxOut ledgerera -> TxOut CtxTx era -fromAlonzoTxOut multiAssetInEra scriptDataInEra txdatums - (AlonzoTxOut addr value datahash) = - TxOut (fromShelleyAddr shelleyBasedEra addr) - (TxOutValue multiAssetInEra (fromMaryValue value)) - (fromAlonzoTxOutDatum scriptDataInEra datahash) +fromAlonzoTxOut multiAssetInEra scriptDataInEra txdatums txOut = + TxOut (fromShelleyAddr shelleyBasedEra (txOut ^. L.addrTxOutL)) + (TxOutValue multiAssetInEra (fromMaryValue (txOut ^. L.valueTxOutL))) + (fromAlonzoTxOutDatum scriptDataInEra (txOut ^. L.dataHashTxOutL)) ReferenceScriptNone where fromAlonzoTxOutDatum :: ScriptDataSupportedInEra era - -> StrictMaybe (Alonzo.DataHash StandardCrypto) + -> StrictMaybe (L.DataHash StandardCrypto) -> TxOutDatum CtxTx era fromAlonzoTxOutDatum _ SNothing = TxOutDatumNone fromAlonzoTxOutDatum supported (SJust dh) @@ -2766,24 +2749,25 @@ fromAlonzoTxOut multiAssetInEra scriptDataInEra txdatums | otherwise = TxOutDatumHash supported (ScriptDataHash dh) fromBabbageTxOut - :: forall ledgerera era. Ledger.Era ledgerera + :: forall ledgerera era. + L.BabbageEraTxOut ledgerera => IsShelleyBasedEra era => ShelleyLedgerEra era ~ ledgerera - => Ledger.Crypto ledgerera ~ StandardCrypto + => Ledger.EraCrypto ledgerera ~ StandardCrypto => Ledger.Value ledgerera ~ MaryValue StandardCrypto => MultiAssetSupportedInEra era -> ScriptDataSupportedInEra era -> ReferenceTxInsScriptsInlineDatumsSupportedInEra era - -> Map (Alonzo.DataHash StandardCrypto) - (Alonzo.Data ledgerera) - -> BabbageTxOut ledgerera + -> Map (L.DataHash StandardCrypto) + (L.Data ledgerera) + -> L.TxOut ledgerera -> TxOut CtxTx era fromBabbageTxOut multiAssetInEra scriptDataInEra inlineDatumsInEra txdatums txout = TxOut - (fromShelleyAddr shelleyBasedEra addr) - (TxOutValue multiAssetInEra (fromMaryValue val)) + (fromShelleyAddr shelleyBasedEra (txout ^. L.addrTxOutL)) + (TxOutValue multiAssetInEra (fromMaryValue (txout ^. L.valueTxOutL))) babbageTxOutDatum - (case mRefScript of + (case txout ^. L.referenceScriptTxOutL of SNothing -> ReferenceScriptNone SJust rScript -> fromShelleyScriptToReferenceScript shelleyBasedEra rScript ) @@ -2792,20 +2776,19 @@ fromBabbageTxOut multiAssetInEra scriptDataInEra inlineDatumsInEra txdatums txou -- 'DatumHash' values using the datums included in the transaction. babbageTxOutDatum :: TxOutDatum CtxTx era babbageTxOutDatum = - case datum of - Babbage.NoDatum -> TxOutDatumNone - Babbage.DatumHash dh -> resolveDatumInTx dh - Babbage.Datum d -> + case txout ^. L.datumTxOutL of + L.NoDatum -> TxOutDatumNone + L.DatumHash dh -> resolveDatumInTx dh + L.Datum d -> TxOutDatumInline inlineDatumsInEra $ binaryDataToScriptData inlineDatumsInEra d - resolveDatumInTx :: Alonzo.DataHash StandardCrypto -> TxOutDatum CtxTx era + resolveDatumInTx :: L.DataHash StandardCrypto -> TxOutDatum CtxTx era resolveDatumInTx dh | Just d <- Map.lookup dh txdatums = TxOutDatumInTx' scriptDataInEra (ScriptDataHash dh) (fromAlonzoData d) | otherwise = TxOutDatumHash scriptDataInEra (ScriptDataHash dh) - (BabbageTxOut addr val datum mRefScript) = txout fromLedgerTxTotalCollateral @@ -2816,13 +2799,13 @@ fromLedgerTxTotalCollateral era txbody = case totalAndReturnCollateralSupportedInEra $ shelleyBasedToCardanoEra era of Nothing -> TxTotalCollateralNone Just supp -> - case obtainTotalCollateralHasFieldConstraint supp $ txbody ^. totalCollateralTxBodyL of + case obtainTotalCollateralHasFieldConstraint supp $ txbody ^. L.totalCollateralTxBodyL of SNothing -> TxTotalCollateralNone SJust totColl -> TxTotalCollateral supp $ fromShelleyLovelace totColl where obtainTotalCollateralHasFieldConstraint :: TxTotalAndReturnCollateralSupportedInEra era - -> (BabbageEraTxBody (ShelleyLedgerEra era) => a) + -> (L.BabbageEraTxBody (ShelleyLedgerEra era) => a) -> a obtainTotalCollateralHasFieldConstraint TxTotalAndReturnCollateralInBabbageEra f = f obtainTotalCollateralHasFieldConstraint TxTotalAndReturnCollateralInConwayEra f = f @@ -2835,17 +2818,16 @@ fromLedgerTxReturnCollateral era txbody = case totalAndReturnCollateralSupportedInEra $ shelleyBasedToCardanoEra era of Nothing -> TxReturnCollateralNone Just supp -> - case obtainCollateralReturnHasFieldConstraint supp $ txbody ^. collateralReturnTxBodyL of + case obtainCollateralReturnHasFieldConstraint supp $ txbody ^. L.collateralReturnTxBodyL of SNothing -> TxReturnCollateralNone SJust collReturnOut -> TxReturnCollateral supp $ fromShelleyTxOut era collReturnOut where obtainCollateralReturnHasFieldConstraint :: TxTotalAndReturnCollateralSupportedInEra era - -> (( Ledger.TxOut (ShelleyLedgerEra era) ~ BabbageTxOut (ShelleyLedgerEra era) - , CC.Crypto (ShelleyLedgerEra era) ~ StandardCrypto - , BabbageEraTxBody (ShelleyLedgerEra era) - ) => a) + -> ((L.EraCrypto (ShelleyLedgerEra era) ~ StandardCrypto + , L.BabbageEraTxBody (ShelleyLedgerEra era) + ) => a) -> a obtainCollateralReturnHasFieldConstraint TxTotalAndReturnCollateralInBabbageEra f = f obtainCollateralReturnHasFieldConstraint TxTotalAndReturnCollateralInConwayEra f = f @@ -2857,22 +2839,22 @@ fromLedgerTxFee era body = case era of ShelleyBasedEraShelley -> TxFeeExplicit TxFeesExplicitInShelleyEra $ - fromShelleyLovelace $ Shelley._txfee body + fromShelleyLovelace $ body ^. L.feeTxBodyL ShelleyBasedEraAllegra -> TxFeeExplicit TxFeesExplicitInAllegraEra $ - fromShelleyLovelace $ Allegra.txfee' body + fromShelleyLovelace $ body ^. L.feeTxBodyL ShelleyBasedEraMary -> TxFeeExplicit TxFeesExplicitInMaryEra $ - fromShelleyLovelace $ Mary.txfee' body + fromShelleyLovelace $ body ^. L.feeTxBodyL ShelleyBasedEraAlonzo -> TxFeeExplicit TxFeesExplicitInAlonzoEra $ - fromShelleyLovelace $ Alonzo.txfee' body + fromShelleyLovelace $ body ^. L.feeTxBodyL ShelleyBasedEraBabbage -> TxFeeExplicit TxFeesExplicitInBabbageEra $ - fromShelleyLovelace $ Babbage.txfee body + fromShelleyLovelace $ body ^. L.feeTxBodyL ShelleyBasedEraConway -> TxFeeExplicit TxFeesExplicitInConwayEra $ - fromShelleyLovelace $ Babbage.txfee body + fromShelleyLovelace $ body ^. L.feeTxBodyL fromLedgerTxValidityRange :: ShelleyBasedEra era @@ -2882,7 +2864,7 @@ fromLedgerTxValidityRange era body = case era of ShelleyBasedEraShelley -> ( TxValidityNoLowerBound - , TxValidityUpperBound ValidityUpperBoundInShelleyEra $ Shelley._ttl body + , TxValidityUpperBound ValidityUpperBoundInShelleyEra $ body ^. L.ttlTxBodyL ) ShelleyBasedEraAllegra -> @@ -2894,8 +2876,7 @@ fromLedgerTxValidityRange era body = SJust s -> TxValidityUpperBound ValidityUpperBoundInAllegraEra s ) where - Allegra.ValidityInterval{invalidBefore, invalidHereafter} = - Allegra.vldt' body + L.ValidityInterval{invalidBefore, invalidHereafter} = body ^. L.vldtTxBodyL ShelleyBasedEraMary -> ( case invalidBefore of @@ -2906,7 +2887,7 @@ fromLedgerTxValidityRange era body = SJust s -> TxValidityUpperBound ValidityUpperBoundInMaryEra s ) where - Mary.ValidityInterval{invalidBefore, invalidHereafter} = Mary.vldt' body + L.ValidityInterval{invalidBefore, invalidHereafter} = body ^. L.vldtTxBodyL ShelleyBasedEraAlonzo -> ( case invalidBefore of @@ -2917,7 +2898,7 @@ fromLedgerTxValidityRange era body = SJust s -> TxValidityUpperBound ValidityUpperBoundInAlonzoEra s ) where - Mary.ValidityInterval{invalidBefore, invalidHereafter} = Alonzo.vldt' body + L.ValidityInterval{invalidBefore, invalidHereafter} = body ^. L.vldtTxBodyL ShelleyBasedEraBabbage -> ( case invalidBefore of @@ -2928,7 +2909,7 @@ fromLedgerTxValidityRange era body = SJust s -> TxValidityUpperBound ValidityUpperBoundInBabbageEra s ) where - Mary.ValidityInterval{invalidBefore, invalidHereafter} = Babbage.txvldt body + L.ValidityInterval{invalidBefore, invalidHereafter} = body ^. L.vldtTxBodyL ShelleyBasedEraConway -> ( case invalidBefore of @@ -2939,38 +2920,41 @@ fromLedgerTxValidityRange era body = SJust s -> TxValidityUpperBound ValidityUpperBoundInConwayEra s ) where - Mary.ValidityInterval{invalidBefore, invalidHereafter} = Babbage.txvldt body + L.ValidityInterval{invalidBefore, invalidHereafter} = body ^. L.vldtTxBodyL fromLedgerAuxiliaryData :: ShelleyBasedEra era - -> Ledger.AuxiliaryData (ShelleyLedgerEra era) + -> L.TxAuxData (ShelleyLedgerEra era) -> (Map Word64 TxMetadataValue, [ScriptInEra era]) -fromLedgerAuxiliaryData ShelleyBasedEraShelley (Shelley.Metadata metadata) = +fromLedgerAuxiliaryData ShelleyBasedEraShelley (L.ShelleyTxAuxData metadata) = (fromShelleyMetadata metadata, []) -fromLedgerAuxiliaryData ShelleyBasedEraAllegra (MAAuxiliaryData ms ss) = +fromLedgerAuxiliaryData ShelleyBasedEraAllegra (L.AllegraTxAuxData ms ss) = ( fromShelleyMetadata ms , fromShelleyBasedScript ShelleyBasedEraAllegra <$> toList ss ) -fromLedgerAuxiliaryData ShelleyBasedEraMary (MAAuxiliaryData ms ss) = +fromLedgerAuxiliaryData ShelleyBasedEraMary (L.AllegraTxAuxData ms ss) = ( fromShelleyMetadata ms , fromShelleyBasedScript ShelleyBasedEraMary <$> toList ss ) -fromLedgerAuxiliaryData ShelleyBasedEraAlonzo (AlonzoAuxiliaryData ms ss) = - ( fromShelleyMetadata ms - , fromShelleyBasedScript ShelleyBasedEraAlonzo <$> toList ss +fromLedgerAuxiliaryData ShelleyBasedEraAlonzo txAuxData = + ( fromShelleyMetadata (L.atadMetadata txAuxData) + , fromShelleyBasedScript ShelleyBasedEraAlonzo <$> + toList (L.getAlonzoTxAuxDataScripts txAuxData) ) -fromLedgerAuxiliaryData ShelleyBasedEraBabbage (AlonzoAuxiliaryData ms ss) = - ( fromShelleyMetadata ms - , fromShelleyBasedScript ShelleyBasedEraBabbage <$> toList ss +fromLedgerAuxiliaryData ShelleyBasedEraBabbage txAuxData = + ( fromShelleyMetadata (L.atadMetadata txAuxData) + , fromShelleyBasedScript ShelleyBasedEraBabbage <$> + toList (L.getAlonzoTxAuxDataScripts txAuxData) ) -fromLedgerAuxiliaryData ShelleyBasedEraConway (AlonzoAuxiliaryData ms ss) = - ( fromShelleyMetadata ms - , fromShelleyBasedScript ShelleyBasedEraConway <$> toList ss +fromLedgerAuxiliaryData ShelleyBasedEraConway txAuxData = + ( fromShelleyMetadata (L.atadMetadata txAuxData) + , fromShelleyBasedScript ShelleyBasedEraConway <$> + toList (L.getAlonzoTxAuxDataScripts txAuxData) ) fromLedgerTxAuxiliaryData :: ShelleyBasedEra era - -> Maybe (Ledger.AuxiliaryData (ShelleyLedgerEra era)) + -> Maybe (L.TxAuxData (ShelleyLedgerEra era)) -> (TxMetadataInEra era, TxAuxScripts era) fromLedgerTxAuxiliaryData _ Nothing = (TxMetadataNone, TxAuxScriptsNone) fromLedgerTxAuxiliaryData era (Just auxData) = @@ -3046,7 +3030,7 @@ fromLedgerTxExtraKeyWitnesses sbe body = [ PaymentKeyHash (Shelley.coerceKeyRole keyhash) | keyhash <- Set.toList keyhashes ] where - keyhashes = Alonzo.reqSignerHashes body + keyhashes = body ^. L.reqSignerHashesTxBodyL ShelleyBasedEraBabbage | Set.null keyhashes -> TxExtraKeyWitnessesNone | otherwise -> TxExtraKeyWitnesses @@ -3054,7 +3038,7 @@ fromLedgerTxExtraKeyWitnesses sbe body = [ PaymentKeyHash (Shelley.coerceKeyRole keyhash) | keyhash <- Set.toList keyhashes ] where - keyhashes = Babbage.reqSignerHashes body + keyhashes = body ^. L.reqSignerHashesTxBodyL ShelleyBasedEraConway | Set.null keyhashes -> TxExtraKeyWitnessesNone | otherwise -> TxExtraKeyWitnesses @@ -3062,7 +3046,7 @@ fromLedgerTxExtraKeyWitnesses sbe body = [ PaymentKeyHash (Shelley.coerceKeyRole keyhash) | keyhash <- Set.toList keyhashes ] where - keyhashes = Babbage.reqSignerHashes body + keyhashes = body ^. L.reqSignerHashesTxBodyL fromLedgerTxWithdrawals :: ShelleyBasedEra era @@ -3071,48 +3055,48 @@ fromLedgerTxWithdrawals fromLedgerTxWithdrawals era body = case era of ShelleyBasedEraShelley - | null (Shelley.unWdrl withdrawals) -> TxWithdrawalsNone + | null (L.unWithdrawals withdrawals) -> TxWithdrawalsNone | otherwise -> TxWithdrawals WithdrawalsInShelleyEra $ fromShelleyWithdrawal withdrawals where - withdrawals = Shelley._wdrls body + withdrawals = body ^. L.withdrawalsTxBodyL ShelleyBasedEraAllegra - | null (Shelley.unWdrl withdrawals) -> TxWithdrawalsNone + | null (L.unWithdrawals withdrawals) -> TxWithdrawalsNone | otherwise -> TxWithdrawals WithdrawalsInAllegraEra $ fromShelleyWithdrawal withdrawals where - withdrawals = Allegra.wdrls' body + withdrawals = body ^. L.withdrawalsTxBodyL ShelleyBasedEraMary - | null (Shelley.unWdrl withdrawals) -> TxWithdrawalsNone + | null (L.unWithdrawals withdrawals) -> TxWithdrawalsNone | otherwise -> TxWithdrawals WithdrawalsInMaryEra $ fromShelleyWithdrawal withdrawals where - withdrawals = Mary.wdrls' body + withdrawals = body ^. L.withdrawalsTxBodyL ShelleyBasedEraAlonzo - | null (Shelley.unWdrl withdrawals) -> TxWithdrawalsNone + | null (L.unWithdrawals withdrawals) -> TxWithdrawalsNone | otherwise -> TxWithdrawals WithdrawalsInAlonzoEra $ fromShelleyWithdrawal withdrawals where - withdrawals = Alonzo.wdrls' body + withdrawals = body ^. L.withdrawalsTxBodyL ShelleyBasedEraBabbage - | null (Shelley.unWdrl withdrawals) -> TxWithdrawalsNone + | null (L.unWithdrawals withdrawals) -> TxWithdrawalsNone | otherwise -> TxWithdrawals WithdrawalsInBabbageEra $ fromShelleyWithdrawal withdrawals where - withdrawals = Babbage.wdrls' body + withdrawals = body ^. L.withdrawalsTxBodyL ShelleyBasedEraConway - | null (Shelley.unWdrl withdrawals) -> TxWithdrawalsNone + | null (L.unWithdrawals withdrawals) -> TxWithdrawalsNone | otherwise -> TxWithdrawals WithdrawalsInConwayEra $ fromShelleyWithdrawal withdrawals where - withdrawals = Babbage.wdrls' body + withdrawals = body ^. L.withdrawalsTxBodyL fromLedgerTxCertificates :: ShelleyBasedEra era @@ -3128,7 +3112,7 @@ fromLedgerTxCertificates era body = (map fromShelleyCertificate $ toList certificates) ViewTx where - certificates = Shelley._certs body + certificates = body ^. L.certsTxBodyL ShelleyBasedEraAllegra | null certificates -> TxCertificatesNone @@ -3138,7 +3122,7 @@ fromLedgerTxCertificates era body = (map fromShelleyCertificate $ toList certificates) ViewTx where - certificates = Allegra.certs' body + certificates = body ^. L.certsTxBodyL ShelleyBasedEraMary | null certificates -> TxCertificatesNone @@ -3148,7 +3132,7 @@ fromLedgerTxCertificates era body = (map fromShelleyCertificate $ toList certificates) ViewTx where - certificates = Mary.certs' body + certificates = body ^. L.certsTxBodyL ShelleyBasedEraAlonzo | null certificates -> TxCertificatesNone @@ -3158,7 +3142,7 @@ fromLedgerTxCertificates era body = (map fromShelleyCertificate $ toList certificates) ViewTx where - certificates = Alonzo.certs' body + certificates = body ^. L.certsTxBodyL ShelleyBasedEraBabbage | null certificates -> TxCertificatesNone @@ -3168,17 +3152,9 @@ fromLedgerTxCertificates era body = (map fromShelleyCertificate $ toList certificates) ViewTx where - certificates = Babbage.certs' body + certificates = body ^. L.certsTxBodyL - ShelleyBasedEraConway - | null certificates -> TxCertificatesNone - | otherwise -> - TxCertificates - CertificatesInConwayEra - (map fromShelleyCertificate $ toList certificates) - ViewTx - where - certificates = Babbage.certs' body + ShelleyBasedEraConway -> TxCertificatesNone fromLedgerTxUpdateProposal :: ShelleyBasedEra era @@ -3187,46 +3163,41 @@ fromLedgerTxUpdateProposal fromLedgerTxUpdateProposal era body = case era of ShelleyBasedEraShelley -> - case Shelley._txUpdate body of + case body ^. L.updateTxBodyL of SNothing -> TxUpdateProposalNone SJust p -> TxUpdateProposal UpdateProposalInShelleyEra (fromLedgerUpdate era p) ShelleyBasedEraAllegra -> - case Allegra.update' body of + case body ^. L.updateTxBodyL of SNothing -> TxUpdateProposalNone SJust p -> TxUpdateProposal UpdateProposalInAllegraEra (fromLedgerUpdate era p) ShelleyBasedEraMary -> - case Mary.update' body of + case body ^. L.updateTxBodyL of SNothing -> TxUpdateProposalNone SJust p -> TxUpdateProposal UpdateProposalInMaryEra (fromLedgerUpdate era p) ShelleyBasedEraAlonzo -> - case Alonzo.update' body of + case body ^. L.updateTxBodyL of SNothing -> TxUpdateProposalNone SJust p -> TxUpdateProposal UpdateProposalInAlonzoEra (fromLedgerUpdate era p) ShelleyBasedEraBabbage -> - case Babbage.update' body of + case body ^. L.updateTxBodyL of SNothing -> TxUpdateProposalNone SJust p -> TxUpdateProposal UpdateProposalInBabbageEra (fromLedgerUpdate era p) - ShelleyBasedEraConway -> - case Babbage.update' body of - SNothing -> TxUpdateProposalNone - SJust p -> - TxUpdateProposal UpdateProposalInConwayEra - (fromLedgerUpdate era p) + ShelleyBasedEraConway -> TxUpdateProposalNone fromLedgerTxMintValue :: ShelleyBasedEra era @@ -3236,33 +3207,16 @@ fromLedgerTxMintValue era body = case era of ShelleyBasedEraShelley -> TxMintNone ShelleyBasedEraAllegra -> TxMintNone - ShelleyBasedEraMary - | isZero mint -> TxMintNone - | otherwise -> TxMintValue MultiAssetInMaryEra - (fromMaryValue mint) ViewTx - where - mint = Mary.mint' body - - ShelleyBasedEraAlonzo - | isZero mint -> TxMintNone - | otherwise -> TxMintValue MultiAssetInAlonzoEra - (fromMaryValue mint) ViewTx - where - mint = Alonzo.mint' body - - ShelleyBasedEraBabbage - | isZero mint -> TxMintNone - | otherwise -> TxMintValue MultiAssetInBabbageEra - (fromMaryValue mint) ViewTx - where - mint = Babbage.mint' body - - ShelleyBasedEraConway - | isZero mint -> TxMintNone - | otherwise -> TxMintValue MultiAssetInConwayEra - (fromMaryValue mint) ViewTx + ShelleyBasedEraMary -> toMintValue body MultiAssetInMaryEra + ShelleyBasedEraAlonzo -> toMintValue body MultiAssetInAlonzoEra + ShelleyBasedEraBabbage -> toMintValue body MultiAssetInBabbageEra + ShelleyBasedEraConway -> toMintValue body MultiAssetInConwayEra + where + toMintValue txBody maInEra + | L.isZero mint = TxMintNone + | otherwise = TxMintValue maInEra (fromMaryValue mint) ViewTx where - mint = Babbage.mint' body + mint = MaryValue 0 (txBody ^. L.mintTxBodyL) makeByronTransactionBody :: TxBodyContent BuildTx ByronEra @@ -3279,7 +3233,7 @@ makeByronTransactionBody TxBodyContent { txIns, txOuts } = do outs' return $ ByronTxBody $ - reAnnotate $ + reAnnotate CBOR.byronProtVer $ Annotated (Byron.UnsafeTx ins'' outs'' (Byron.mkAttributes ())) () @@ -3330,7 +3284,7 @@ getByronTxBodyContent (Annotated Byron.UnsafeTx{txInputs, txOutputs} _) = txScriptValidity = TxScriptValidityNone } -convTxIns :: TxIns BuildTx era -> Set (Shelley.TxIn StandardCrypto) +convTxIns :: TxIns BuildTx era -> Set (L.TxIn StandardCrypto) convTxIns txIns = Set.fromList (map (toShelleyTxIn . fst) txIns) convCollateralTxIns :: TxInsCollateral era -> Set (Ledger.TxIn StandardCrypto) @@ -3342,11 +3296,11 @@ convCollateralTxIns txInsCollateral = convReturnCollateral :: ShelleyBasedEra era -> TxReturnCollateral ctx era - -> StrictMaybe (CBOR.Sized (Ledger.TxOut (ShelleyLedgerEra era))) + -> StrictMaybe (Ledger.TxOut (ShelleyLedgerEra era)) convReturnCollateral era txReturnCollateral = case txReturnCollateral of TxReturnCollateralNone -> SNothing - TxReturnCollateral _ colTxOut -> SJust $ getCBORConstraint era $ CBOR.mkSized $ toShelleyTxOutAny era colTxOut + TxReturnCollateral _ colTxOut -> SJust $ getCBORConstraint era $ toShelleyTxOutAny era colTxOut convTotalCollateral :: TxTotalCollateral era -> StrictMaybe Ledger.Coin convTotalCollateral txTotalCollateral = @@ -3359,13 +3313,6 @@ convTxOuts => ShelleyBasedEra era -> [TxOut ctx era] -> Seq.StrictSeq (Ledger.TxOut ledgerera) convTxOuts era txOuts = Seq.fromList $ map (toShelleyTxOutAny era) txOuts -convBabbageTxOuts - :: ShelleyBasedEra era - -> [TxOut ctx era] - -> Seq.StrictSeq (CBOR.Sized (Ledger.TxOut (ShelleyLedgerEra era))) -convBabbageTxOuts era txOuts = - getCBORConstraint era $ Seq.fromList (map (CBOR.mkSized . toShelleyTxOutAny era) txOuts) - convCertificates :: TxCertificates build era -> Seq.StrictSeq (Shelley.DCert StandardCrypto) convCertificates txCertificates = @@ -3373,10 +3320,24 @@ convCertificates txCertificates = TxCertificatesNone -> Seq.empty TxCertificates _ cs _ -> Seq.fromList (map toShelleyCertificate cs) -convWithdrawals :: TxWithdrawals build era -> Shelley.Wdrl StandardCrypto +convConwayCertificates + :: TxCertificates build era -> Seq.StrictSeq (Conway.ConwayDCert StandardCrypto) +convConwayCertificates txCertificates = + case txCertificates of + TxCertificatesNone -> Seq.empty + TxCertificates _ cs _ -> + Seq.fromList (mapMaybe (fromShelleyDCertMaybe . toShelleyCertificate) cs) + +fromShelleyDCertMaybe :: Shelley.DCert c -> Maybe (Conway.ConwayDCert c) +fromShelleyDCertMaybe (Shelley.DCertDeleg dc) = Just $ Conway.ConwayDCertDeleg dc +fromShelleyDCertMaybe (Shelley.DCertPool pc) = Just $ Conway.ConwayDCertPool pc +fromShelleyDCertMaybe (Shelley.DCertGenesis gdc) = Just $ Conway.ConwayDCertConstitutional gdc +fromShelleyDCertMaybe Shelley.DCertMir {} = Nothing + +convWithdrawals :: TxWithdrawals build era -> L.Withdrawals StandardCrypto convWithdrawals txWithdrawals = case txWithdrawals of - TxWithdrawalsNone -> Shelley.Wdrl Map.empty + TxWithdrawalsNone -> L.Withdrawals Map.empty TxWithdrawals _ ws -> toShelleyWithdrawal ws convTransactionFee :: ShelleyBasedEra era -> TxFee era -> Ledger.Coin @@ -3388,9 +3349,9 @@ convTransactionFee sbe txFee = convValidityInterval :: (TxValidityLowerBound era, TxValidityUpperBound era) - -> Allegra.ValidityInterval + -> L.ValidityInterval convValidityInterval (lowerBound, upperBound) = - Allegra.ValidityInterval + L.ValidityInterval { invalidBefore = case lowerBound of TxValidityNoLowerBound -> SNothing TxValidityLowerBound _ s -> SJust s @@ -3401,7 +3362,7 @@ convValidityInterval (lowerBound, upperBound) = convTxUpdateProposal :: forall era ledgerera. ShelleyLedgerEra era ~ ledgerera - => Ledger.Crypto ledgerera ~ StandardCrypto + => Ledger.EraCrypto ledgerera ~ StandardCrypto => ShelleyBasedEra era -> TxUpdateProposal era -> StrictMaybe (Ledger.Update ledgerera) @@ -3410,11 +3371,13 @@ convTxUpdateProposal era txUpdateProposal = TxUpdateProposalNone -> SNothing TxUpdateProposal _ p -> SJust (toLedgerUpdate era p) -convMintValue :: TxMintValue build era -> MaryValue StandardCrypto +convMintValue :: TxMintValue build era -> MultiAsset StandardCrypto convMintValue txMintValue = case txMintValue of TxMintNone -> mempty - TxMintValue _ v _ -> toMaryValue v + TxMintValue _ v _ -> + case toMaryValue v of + MaryValue _ ma -> ma convExtraKeyWitnesses :: TxExtraKeyWitnesses era -> Set (Shelley.KeyHash r' StandardCrypto) convExtraKeyWitnesses txExtraKeyWits = @@ -3424,24 +3387,6 @@ convExtraKeyWitnesses txExtraKeyWits = [ Shelley.coerceKeyRole kh | PaymentKeyHash kh <- khs ] -convAuxiliaryData - :: TxMetadataInEra era - -> Maybe (Ledger.AuxiliaryData StandardShelley) -convAuxiliaryData txMetadata - | Map.null ms = Nothing - | otherwise = return (toShelleyAuxiliaryData ms) - where - ms = case txMetadata of - TxMetadataNone -> Map.empty - TxMetadataInEra _ (TxMetadata ms') -> ms' - - -convAuxiliaryDataToHash - :: EraAuxiliaryData era => Maybe (Ledger.AuxiliaryData era) -> StrictMaybe (Ledger.AuxiliaryDataHash (CC.Crypto era)) -convAuxiliaryDataToHash txAuxData = - maybeToStrictMaybe - (Ledger.hashAuxiliaryData <$> txAuxData) - convScripts :: ShelleyLedgerEra era ~ ledgerera => [(ScriptWitnessIndex, AnyScriptWitness era)] @@ -3473,7 +3418,7 @@ convScriptData era txOuts scriptWitnesses = datums = Alonzo.TxDats $ Map.fromList - [ (Alonzo.hashData d', d') + [ (L.hashData d', d') | d <- scriptdata , let d' = toAlonzoData d ] @@ -3488,21 +3433,20 @@ convScriptData era txOuts scriptWitnesses = in TxBodyScriptData scriptDataInEra datums redeemers convPParamsToScriptIntegrityHash - :: Ledger.Era (ShelleyLedgerEra era) - => HasField "_costmdls" (Core.PParams (ShelleyLedgerEra era)) Alonzo.CostModels + :: L.AlonzoEraPParams (ShelleyLedgerEra era) => ShelleyBasedEra era -> BuildTxWith BuildTx (Maybe ProtocolParameters) -> Alonzo.Redeemers (ShelleyLedgerEra era) -> Alonzo.TxDats (ShelleyLedgerEra era) -> Set Alonzo.Language - -> StrictMaybe (Alonzo.ScriptIntegrityHash (Ledger.Crypto (ShelleyLedgerEra era))) + -> StrictMaybe (L.ScriptIntegrityHash (Ledger.EraCrypto (ShelleyLedgerEra era))) convPParamsToScriptIntegrityHash sbe txProtocolParams redeemers datums languages = case txProtocolParams of BuildTxWith Nothing -> SNothing BuildTxWith (Just pparams) -> Alonzo.hashScriptIntegrity (Set.map - (Alonzo.getLanguageView (toLedgerPParams sbe pparams)) + (L.getLanguageView (toLedgerPParams sbe pparams)) languages ) redeemers @@ -3532,14 +3476,6 @@ getCBORConstraint ShelleyBasedEraAlonzo f = f getCBORConstraint ShelleyBasedEraBabbage f = f getCBORConstraint ShelleyBasedEraConway f = f -getHasFieldConstraints - :: ScriptDataSupportedInEra era - -> (HasField "_costmdls" (Core.PParams (ShelleyLedgerEra era)) Alonzo.CostModels => a) - -> a -getHasFieldConstraints ScriptDataInAlonzoEra f = f -getHasFieldConstraints ScriptDataInBabbageEra f = f -getHasFieldConstraints ScriptDataInConwayEra f = f - getLedgerEraConstraint :: ShelleyBasedEra era -> (Ledger.Era (ShelleyLedgerEra era) => a) @@ -3551,6 +3487,28 @@ getLedgerEraConstraint ShelleyBasedEraAlonzo f = f getLedgerEraConstraint ShelleyBasedEraBabbage f = f getLedgerEraConstraint ShelleyBasedEraConway f = f +-- | A helper function that constructs a TxBody with all of the fields that are common for +-- all eras +mkCommonTxBody :: + ( L.EraTxBody (ShelleyLedgerEra era) + , L.EraTxAuxData (ShelleyLedgerEra era) + , L.EraCrypto (ShelleyLedgerEra era) ~ StandardCrypto + ) + => ShelleyBasedEra era + -> TxIns BuildTx era + -> [TxOut ctx era] + -> TxFee era + -> TxWithdrawals build era + -> Maybe (L.TxAuxData (ShelleyLedgerEra era)) + -> L.TxBody (ShelleyLedgerEra era) +mkCommonTxBody era txIns txOuts txFee txWithdrawals txAuxData = + L.mkBasicTxBody + & L.inputsTxBodyL .~ convTxIns txIns + & L.outputsTxBodyL .~ convTxOuts era txOuts + & L.feeTxBodyL .~ convTransactionFee era txFee + & L.withdrawalsTxBodyL .~ convWithdrawals txWithdrawals + & L.auxDataHashTxBodyL .~ maybe SNothing (SJust . Ledger.hashTxAuxData) txAuxData + makeShelleyTransactionBody :: ShelleyBasedEra era -> TxBodyContent BuildTx era @@ -3571,17 +3529,13 @@ makeShelleyTransactionBody era@ShelleyBasedEraShelley return $ ShelleyTxBody era - (Ledger.ShelleyTxBody - (convTxIns txIns) - (convTxOuts era txOuts) - (convCertificates txCertificates) - (convWithdrawals txWithdrawals) - (convTransactionFee era txFee) - (case upperBound of - TxValidityNoUpperBound era' -> case era' of {} - TxValidityUpperBound _ ttl -> ttl) - (convTxUpdateProposal era txUpdateProposal) - (convAuxiliaryDataToHash txAuxData)) + (mkCommonTxBody era txIns txOuts txFee txWithdrawals txAuxData + & L.certsTxBodyL .~ convCertificates txCertificates + & L.updateTxBodyL .~ convTxUpdateProposal era txUpdateProposal + & L.ttlTxBodyL .~ case upperBound of + TxValidityNoUpperBound era' -> case era' of {} + TxValidityUpperBound _ ttl -> ttl + ) scripts_ TxBodyNoScriptData txAuxData @@ -3594,14 +3548,8 @@ makeShelleyTransactionBody era@ShelleyBasedEraShelley <- collectTxBodyScriptWitnesses txbodycontent ] - txAuxData :: Maybe (Ledger.AuxiliaryData StandardShelley) - txAuxData - | Map.null ms = Nothing - | otherwise = Just (toShelleyAuxiliaryData ms) - where - ms = case txMetadata of - TxMetadataNone -> Map.empty - TxMetadataInEra _ (TxMetadata ms') -> ms' + txAuxData :: Maybe (L.TxAuxData StandardShelley) + txAuxData = toAuxiliaryData era txMetadata TxAuxScriptsNone makeShelleyTransactionBody era@ShelleyBasedEraAllegra txbodycontent@TxBodyContent { @@ -3620,16 +3568,11 @@ makeShelleyTransactionBody era@ShelleyBasedEraAllegra return $ ShelleyTxBody era - (MATxBody - (convTxIns txIns) - (Seq.fromList (map (toShelleyTxOutAny era) txOuts)) - (convCertificates txCertificates) - (convWithdrawals txWithdrawals) - (convTransactionFee era txFee) - (convValidityInterval (lowerBound, upperBound)) - (convTxUpdateProposal era txUpdateProposal) - (convAuxiliaryDataToHash txAuxData) - mempty) -- No minting in Allegra, only Mary + (mkCommonTxBody era txIns txOuts txFee txWithdrawals txAuxData + & L.certsTxBodyL .~ convCertificates txCertificates + & L.vldtTxBodyL .~ convValidityInterval (lowerBound, upperBound) + & L.updateTxBodyL .~ convTxUpdateProposal era txUpdateProposal + ) scripts_ TxBodyNoScriptData txAuxData @@ -3642,18 +3585,8 @@ makeShelleyTransactionBody era@ShelleyBasedEraAllegra <- collectTxBodyScriptWitnesses txbodycontent ] - txAuxData :: Maybe (Ledger.AuxiliaryData StandardAllegra) - txAuxData - | Map.null ms - , null ss = Nothing - | otherwise = Just (toAuxiliaryData era txMetadata txAuxScripts) - where - ms = case txMetadata of - TxMetadataNone -> Map.empty - TxMetadataInEra _ (TxMetadata ms') -> ms' - ss = case txAuxScripts of - TxAuxScriptsNone -> [] - TxAuxScripts _ ss' -> ss' + txAuxData :: Maybe (L.TxAuxData StandardAllegra) + txAuxData = toAuxiliaryData era txMetadata txAuxScripts makeShelleyTransactionBody era@ShelleyBasedEraMary txbodycontent@TxBodyContent { @@ -3673,16 +3606,12 @@ makeShelleyTransactionBody era@ShelleyBasedEraMary return $ ShelleyTxBody era - (MATxBody - (convTxIns txIns) - (Seq.fromList $ map (toShelleyTxOutAny era) txOuts) - (convCertificates txCertificates) - (convWithdrawals txWithdrawals) - (convTransactionFee era txFee) - (convValidityInterval (lowerBound, upperBound)) - (convTxUpdateProposal era txUpdateProposal) - (convAuxiliaryDataToHash txAuxData) - (convMintValue txMintValue)) + (mkCommonTxBody era txIns txOuts txFee txWithdrawals txAuxData + & L.certsTxBodyL .~ convCertificates txCertificates + & L.vldtTxBodyL .~ convValidityInterval (lowerBound, upperBound) + & L.updateTxBodyL .~ convTxUpdateProposal era txUpdateProposal + & L.mintTxBodyL .~ convMintValue txMintValue + ) scripts TxBodyNoScriptData txAuxData @@ -3695,18 +3624,8 @@ makeShelleyTransactionBody era@ShelleyBasedEraMary <- collectTxBodyScriptWitnesses txbodycontent ] - txAuxData :: Maybe (Ledger.AuxiliaryData StandardMary) - txAuxData - | Map.null ms - , null ss = Nothing - | otherwise = Just (toAuxiliaryData era txMetadata txAuxScripts) - where - ms = case txMetadata of - TxMetadataNone -> Map.empty - TxMetadataInEra _ (TxMetadata ms') -> ms' - ss = case txAuxScripts of - TxAuxScriptsNone -> [] - TxAuxScripts _ ss' -> ss' + txAuxData :: Maybe (L.TxAuxData StandardMary) + txAuxData = toAuxiliaryData era txMetadata txAuxScripts makeShelleyTransactionBody era@ShelleyBasedEraAlonzo txbodycontent@TxBodyContent { @@ -3730,21 +3649,18 @@ makeShelleyTransactionBody era@ShelleyBasedEraAlonzo return $ ShelleyTxBody era - (AlonzoTxBody - (convTxIns txIns) - (convCollateralTxIns txInsCollateral) - (convTxOuts era txOuts) - (convCertificates txCertificates) - (convWithdrawals txWithdrawals) - (convTransactionFee era txFee) - (convValidityInterval (lowerBound, upperBound)) - (convTxUpdateProposal era txUpdateProposal) - (convExtraKeyWitnesses txExtraKeyWits) - (convMintValue txMintValue) - (convPParamsToScriptIntegrityHash ShelleyBasedEraAlonzo - txProtocolParams redeemers datums languages) - (convAuxiliaryDataToHash txAuxData) - SNothing) -- TODO alonzo: support optional network id in TxBodyContent + (mkCommonTxBody era txIns txOuts txFee txWithdrawals txAuxData + & L.collateralInputsTxBodyL .~ convCollateralTxIns txInsCollateral + & L.certsTxBodyL .~ convCertificates txCertificates + & L.vldtTxBodyL .~ convValidityInterval (lowerBound, upperBound) + & L.updateTxBodyL .~ convTxUpdateProposal era txUpdateProposal + & L.reqSignerHashesTxBodyL .~ convExtraKeyWitnesses txExtraKeyWits + & L.mintTxBodyL .~ convMintValue txMintValue + & L.scriptIntegrityHashTxBodyL .~ convPParamsToScriptIntegrityHash + era txProtocolParams redeemers datums languages + -- TODO Alonzo: support optional network id in TxBodyContent + -- & L.networkIdTxBodyL .~ SNothing + ) scripts (TxBodyScriptData ScriptDataInAlonzoEra datums redeemers) txAuxData @@ -3763,7 +3679,7 @@ makeShelleyTransactionBody era@ShelleyBasedEraAlonzo datums = Alonzo.TxDats $ Map.fromList - [ (Alonzo.hashData d, d) + [ (L.hashData d, d) | d <- toAlonzoData <$> scriptdata ] @@ -3791,18 +3707,8 @@ makeShelleyTransactionBody era@ShelleyBasedEraAlonzo | (_, AnyScriptWitness (PlutusScriptWitness _ v _ _ _ _)) <- witnesses ] - txAuxData :: Maybe (Ledger.AuxiliaryData StandardAlonzo) - txAuxData - | Map.null ms - , null ss = Nothing - | otherwise = Just (toAuxiliaryData era txMetadata txAuxScripts) - where - ms = case txMetadata of - TxMetadataNone -> Map.empty - TxMetadataInEra _ (TxMetadata ms') -> ms' - ss = case txAuxScripts of - TxAuxScriptsNone -> [] - TxAuxScripts _ ss' -> ss' + txAuxData :: Maybe (L.TxAuxData StandardAlonzo) + txAuxData = toAuxiliaryData era txMetadata txAuxScripts makeShelleyTransactionBody era@ShelleyBasedEraBabbage txbodycontent@TxBodyContent { @@ -3829,28 +3735,24 @@ makeShelleyTransactionBody era@ShelleyBasedEraBabbage return $ ShelleyTxBody era - (BabbageTxBody - { Babbage.inputs = convTxIns txIns - , Babbage.collateral = + (mkCommonTxBody era txIns txOuts txFee txWithdrawals txAuxData + & L.collateralInputsTxBodyL .~ case txInsCollateral of TxInsCollateralNone -> Set.empty TxInsCollateral _ txins -> Set.fromList (map toShelleyTxIn txins) - , Babbage.referenceInputs = convReferenceInputs txInsReference - , Babbage.outputs = convBabbageTxOuts era txOuts - , Babbage.collateralReturn = convReturnCollateral era txReturnCollateral - , Babbage.totalCollateral = convTotalCollateral txTotalCollateral - , Babbage.txcerts = convCertificates txCertificates - , Babbage.txwdrls = convWithdrawals txWithdrawals - , Babbage.txfee = convTransactionFee era txFee - , Babbage.txvldt = convValidityInterval (lowerBound, upperBound) - , Babbage.txUpdates = convTxUpdateProposal era txUpdateProposal - , Babbage.reqSignerHashes = convExtraKeyWitnesses txExtraKeyWits - , Babbage.mint = convMintValue txMintValue - , Babbage.scriptIntegrityHash = convPParamsToScriptIntegrityHash + & L.referenceInputsTxBodyL .~ convReferenceInputs txInsReference + & L.collateralReturnTxBodyL .~ convReturnCollateral era txReturnCollateral + & L.totalCollateralTxBodyL .~ convTotalCollateral txTotalCollateral + & L.certsTxBodyL .~ convCertificates txCertificates + & L.vldtTxBodyL .~ convValidityInterval (lowerBound, upperBound) + & L.updateTxBodyL .~ convTxUpdateProposal era txUpdateProposal + & L.reqSignerHashesTxBodyL .~ convExtraKeyWitnesses txExtraKeyWits + & L.mintTxBodyL .~ convMintValue txMintValue + & L.scriptIntegrityHashTxBodyL .~ convPParamsToScriptIntegrityHash era txProtocolParams redeemers datums languages - , Babbage.adHash = convAuxiliaryDataToHash txAuxData - , Babbage.txnetworkid = SNothing - }) + -- TODO Babbage: support optional network id in TxBodyContent + -- & L.networkIdTxBodyL .~ SNothing + ) scripts (TxBodyScriptData ScriptDataInBabbageEra datums redeemers) @@ -3871,7 +3773,7 @@ makeShelleyTransactionBody era@ShelleyBasedEraBabbage datums = Alonzo.TxDats $ Map.fromList - [ (Alonzo.hashData d', d') + [ (L.hashData d', d') | d <- scriptdata , let d' = toAlonzoData d ] @@ -3905,18 +3807,8 @@ makeShelleyTransactionBody era@ShelleyBasedEraBabbage Just $ toAlonzoLanguage (AnyPlutusScriptVersion v) getScriptLanguage SimpleScriptWitness{} = Nothing - txAuxData :: Maybe (Ledger.AuxiliaryData StandardBabbage) - txAuxData - | Map.null ms - , null ss = Nothing - | otherwise = Just (toAuxiliaryData era txMetadata txAuxScripts) - where - ms = case txMetadata of - TxMetadataNone -> Map.empty - TxMetadataInEra _ (TxMetadata ms') -> ms' - ss = case txAuxScripts of - TxAuxScriptsNone -> [] - TxAuxScripts _ ss' -> ss' + txAuxData :: Maybe (L.TxAuxData StandardBabbage) + txAuxData = toAuxiliaryData era txMetadata txAuxScripts makeShelleyTransactionBody era@ShelleyBasedEraConway txbodycontent@TxBodyContent { @@ -3934,7 +3826,6 @@ makeShelleyTransactionBody era@ShelleyBasedEraConway txProtocolParams, txWithdrawals, txCertificates, - txUpdateProposal, txMintValue, txScriptValidity } = do @@ -3943,28 +3834,23 @@ makeShelleyTransactionBody era@ShelleyBasedEraConway return $ ShelleyTxBody era - (BabbageTxBody - { Conway.inputs = convTxIns txIns - , Conway.collateral = + (mkCommonTxBody era txIns txOuts txFee txWithdrawals txAuxData + & L.collateralInputsTxBodyL .~ case txInsCollateral of TxInsCollateralNone -> Set.empty TxInsCollateral _ txins -> Set.fromList (map toShelleyTxIn txins) - , Conway.referenceInputs = convReferenceInputs txInsReference - , Conway.outputs = convBabbageTxOuts era txOuts - , Conway.collateralReturn = convReturnCollateral era txReturnCollateral - , Conway.totalCollateral = convTotalCollateral txTotalCollateral - , Conway.txcerts = convCertificates txCertificates - , Conway.txwdrls = convWithdrawals txWithdrawals - , Conway.txfee = convTransactionFee era txFee - , Conway.txvldt = convValidityInterval (lowerBound, upperBound) - , Conway.txUpdates = convTxUpdateProposal era txUpdateProposal - , Conway.reqSignerHashes = convExtraKeyWitnesses txExtraKeyWits - , Conway.mint = convMintValue txMintValue - , Conway.scriptIntegrityHash = convPParamsToScriptIntegrityHash + & L.referenceInputsTxBodyL .~ convReferenceInputs txInsReference + & L.collateralReturnTxBodyL .~ convReturnCollateral era txReturnCollateral + & L.totalCollateralTxBodyL .~ convTotalCollateral txTotalCollateral + & L.conwayCertsTxBodyL .~ convConwayCertificates txCertificates + & L.vldtTxBodyL .~ convValidityInterval (lowerBound, upperBound) + & L.reqSignerHashesTxBodyL .~ convExtraKeyWitnesses txExtraKeyWits + & L.mintTxBodyL .~ convMintValue txMintValue + & L.scriptIntegrityHashTxBodyL .~ convPParamsToScriptIntegrityHash era txProtocolParams redeemers datums languages - , Conway.adHash = convAuxiliaryDataToHash txAuxData - , Conway.txnetworkid = SNothing - }) + -- TODO Conway: support optional network id in TxBodyContent + -- & L.networkIdTxBodyL .~ SNothing + ) scripts (TxBodyScriptData ScriptDataInConwayEra datums redeemers) @@ -3985,8 +3871,9 @@ makeShelleyTransactionBody era@ShelleyBasedEraConway datums = Alonzo.TxDats $ Map.fromList - [ (Alonzo.hashData d, d) - | d <- toAlonzoData <$> scriptdata + [ (L.hashData d', d') + | d <- scriptdata + , let d' = toAlonzoData d ] scriptdata :: [HashableScriptData] @@ -4018,18 +3905,9 @@ makeShelleyTransactionBody era@ShelleyBasedEraConway Just $ toAlonzoLanguage (AnyPlutusScriptVersion v) getScriptLanguage SimpleScriptWitness{} = Nothing - txAuxData :: Maybe (Ledger.AuxiliaryData StandardConway) - txAuxData - | Map.null ms - , null ss = Nothing - | otherwise = Just (toAuxiliaryData era txMetadata txAuxScripts) - where - ms = case txMetadata of - TxMetadataNone -> Map.empty - TxMetadataInEra _ (TxMetadata ms') -> ms' - ss = case txAuxScripts of - TxAuxScriptsNone -> [] - TxAuxScripts _ ss' -> ss' + txAuxData :: Maybe (L.TxAuxData StandardConway) + txAuxData = toAuxiliaryData era txMetadata txAuxScripts + -- | A variant of 'toShelleyTxOutAny that is used only internally to this module @@ -4045,30 +3923,32 @@ toShelleyTxOutAny era (TxOut _ (TxOutAdaOnly AdaOnlyInByronEra _) _ _) = case era of {} toShelleyTxOutAny _ (TxOut addr (TxOutAdaOnly AdaOnlyInShelleyEra value) _ _) = - ShelleyTxOut (toShelleyAddr addr) (toShelleyLovelace value) + L.mkBasicTxOut (toShelleyAddr addr) (toShelleyLovelace value) toShelleyTxOutAny _ (TxOut addr (TxOutAdaOnly AdaOnlyInAllegraEra value) _ _) = - ShelleyTxOut (toShelleyAddr addr) (toShelleyLovelace value) + L.mkBasicTxOut (toShelleyAddr addr) (toShelleyLovelace value) toShelleyTxOutAny _ (TxOut addr (TxOutValue MultiAssetInMaryEra value) _ _) = - ShelleyTxOut (toShelleyAddr addr) (toMaryValue value) + L.mkBasicTxOut (toShelleyAddr addr) (toMaryValue value) toShelleyTxOutAny _ (TxOut addr (TxOutValue MultiAssetInAlonzoEra value) txoutdata _) = - AlonzoTxOut (toShelleyAddr addr) (toMaryValue value) - (toAlonzoTxOutDataHash' txoutdata) + L.mkBasicTxOut (toShelleyAddr addr) (toMaryValue value) + & L.dataHashTxOutL .~ toAlonzoTxOutDataHash' txoutdata toShelleyTxOutAny era (TxOut addr (TxOutValue MultiAssetInBabbageEra value) txoutdata refScript) = let cEra = shelleyBasedToCardanoEra era - in BabbageTxOut (toShelleyAddr addr) (toMaryValue value) - (toBabbageTxOutDatum' txoutdata) (refScriptToShelleyScript cEra refScript) + in L.mkBasicTxOut (toShelleyAddr addr) (toMaryValue value) + & L.datumTxOutL .~ toBabbageTxOutDatum' txoutdata + & L.referenceScriptTxOutL .~ refScriptToShelleyScript cEra refScript toShelleyTxOutAny era (TxOut addr (TxOutValue MultiAssetInConwayEra value) txoutdata refScript) = let cEra = shelleyBasedToCardanoEra era - in BabbageTxOut (toShelleyAddr addr) (toMaryValue value) - (toBabbageTxOutDatum' txoutdata) (refScriptToShelleyScript cEra refScript) + in L.mkBasicTxOut (toShelleyAddr addr) (toMaryValue value) + & L.datumTxOutL .~ toBabbageTxOutDatum' txoutdata + & L.referenceScriptTxOutL .~ refScriptToShelleyScript cEra refScript toAlonzoTxOutDataHash' :: TxOutDatum ctx AlonzoEra - -> StrictMaybe (Alonzo.DataHash StandardCrypto) + -> StrictMaybe (L.DataHash StandardCrypto) toAlonzoTxOutDataHash' TxOutDatumNone = SNothing toAlonzoTxOutDataHash' (TxOutDatumHash _ (ScriptDataHash dh)) = SJust dh toAlonzoTxOutDataHash' (TxOutDatumInTx' _ (ScriptDataHash dh) _) = SJust dh @@ -4077,7 +3957,7 @@ toAlonzoTxOutDataHash' (TxOutDatumInline inlineDatumSupp _sd) = -- TODO: Consolidate with alonzo function and rename toBabbageTxOutDatum' - :: Ledger.Crypto (ShelleyLedgerEra era) ~ StandardCrypto + :: (L.Era (ShelleyLedgerEra era), Ledger.EraCrypto (ShelleyLedgerEra era) ~ StandardCrypto) => TxOutDatum ctx era -> Babbage.Datum (ShelleyLedgerEra era) toBabbageTxOutDatum' TxOutDatumNone = Babbage.NoDatum toBabbageTxOutDatum' (TxOutDatumHash _ (ScriptDataHash dh)) = Babbage.DatumHash dh @@ -4223,70 +4103,52 @@ orderStakeAddrs :: [(StakeAddress, x, v)] -> [(StakeAddress, x, v)] orderStakeAddrs = sortBy (compare `on` (\(k, _, _) -> k)) -toShelleyWithdrawal :: [(StakeAddress, Lovelace, a)] -> Shelley.Wdrl StandardCrypto +toShelleyWithdrawal :: [(StakeAddress, Lovelace, a)] -> L.Withdrawals StandardCrypto toShelleyWithdrawal withdrawals = - Shelley.Wdrl $ + L.Withdrawals $ Map.fromList [ (toShelleyStakeAddr stakeAddr, toShelleyLovelace value) | (stakeAddr, value, _) <- withdrawals ] fromShelleyWithdrawal - :: Shelley.Wdrl StandardCrypto + :: L.Withdrawals StandardCrypto -> [(StakeAddress, Lovelace, BuildTxWith ViewTx (Witness WitCtxStake era))] -fromShelleyWithdrawal (Shelley.Wdrl withdrawals) = +fromShelleyWithdrawal (L.Withdrawals withdrawals) = [ (fromShelleyStakeAddr stakeAddr, fromShelleyLovelace value, ViewTx) | (stakeAddr, value) <- Map.assocs withdrawals ] --- | In the Shelley era the auxiliary data consists only of the tx metadata -toShelleyAuxiliaryData :: Map Word64 TxMetadataValue - -> Ledger.AuxiliaryData StandardShelley -toShelleyAuxiliaryData m = - Shelley.Metadata - (toShelleyMetadata m) - -- | In the Allegra and Mary eras the auxiliary data consists of the tx metadata -- and the axiliary scripts. In the Alonzo and later eras the auxiliary data consists of the tx metadata -- and the axiliary scripts, and the axiliary script data. -- toAuxiliaryData - :: ShelleyLedgerEra era ~ ledgerera - => ShelleyBasedEra era + :: ShelleyBasedEra era -> TxMetadataInEra era -> TxAuxScripts era - -> Ledger.AuxiliaryData ledgerera + -> Maybe (L.TxAuxData (ShelleyLedgerEra era)) toAuxiliaryData sbe txMetadata txAuxScripts = - let m = case txMetadata of + let ms = case txMetadata of TxMetadataNone -> Map.empty - TxMetadataInEra _ (TxMetadata ms') -> ms' + TxMetadataInEra _ (TxMetadata ms') -> toShelleyMetadata ms' ss = case txAuxScripts of TxAuxScriptsNone -> [] - TxAuxScripts _ ss' -> ss' + TxAuxScripts _ ss' -> map toShelleyScript ss' in case sbe of ShelleyBasedEraShelley -> - Shelley.Metadata $ toShelleyMetadata m + guard (not (Map.null ms)) $> L.ShelleyTxAuxData ms ShelleyBasedEraAllegra -> - Allegra.MAAuxiliaryData - (toShelleyMetadata m) - (Seq.fromList (map toShelleyScript ss)) + guard (not (Map.null ms && null ss)) $> L.AllegraTxAuxData ms (Seq.fromList ss) ShelleyBasedEraMary -> - Allegra.MAAuxiliaryData - (toShelleyMetadata m) - (Seq.fromList (map toShelleyScript ss)) + guard (not (Map.null ms && null ss)) $> L.AllegraTxAuxData ms (Seq.fromList ss) ShelleyBasedEraAlonzo -> - Alonzo.AlonzoAuxiliaryData - (toShelleyMetadata m) - (Seq.fromList (map toShelleyScript ss)) + guard (not (Map.null ms && null ss)) $> L.mkAlonzoTxAuxData ms ss ShelleyBasedEraBabbage -> - Alonzo.AlonzoAuxiliaryData - (toShelleyMetadata m) - (Seq.fromList (map toShelleyScript ss)) + guard (not (Map.null ms && null ss)) $> L.mkAlonzoTxAuxData ms ss ShelleyBasedEraConway -> - Alonzo.AlonzoAuxiliaryData - (toShelleyMetadata m) - (Seq.fromList (map toShelleyScript ss)) + guard (not (Map.null ms && null ss)) $> L.mkAlonzoTxAuxData ms ss -- ---------------------------------------------------------------------------- -- Other utilities helpful with making transaction bodies @@ -4307,8 +4169,8 @@ genesisUTxOPseudoTxIn nw (GenesisUTxOKeyHash kh) = --TODO: should handle Byron UTxO case too. fromShelleyTxIn (Shelley.initialFundsPseudoTxIn addr) where - addr :: Shelley.Addr StandardCrypto - addr = Shelley.Addr + addr :: L.Addr StandardCrypto + addr = L.Addr (toShelleyNetwork nw) (Shelley.KeyHashObj kh) Shelley.StakeRefNull @@ -4316,8 +4178,8 @@ genesisUTxOPseudoTxIn nw (GenesisUTxOKeyHash kh) = calculateExecutionUnitsLovelace :: ExecutionUnitPrices -> ExecutionUnits -> Maybe Lovelace calculateExecutionUnitsLovelace euPrices eUnits = case toAlonzoPrices euPrices of - Nothing -> Nothing - Just prices -> + Left _ -> Nothing + Right prices -> return . fromShelleyLovelace $ Alonzo.txscriptfee prices (toAlonzoExUnits eUnits) -- ---------------------------------------------------------------------------- @@ -4327,15 +4189,15 @@ calculateExecutionUnitsLovelace euPrices eUnits = -- onchain within a transaction output. -- -scriptDataToInlineDatum :: HashableScriptData -> Babbage.Datum ledgerera +scriptDataToInlineDatum :: L.Era ledgerera => HashableScriptData -> L.Datum ledgerera scriptDataToInlineDatum d = - Babbage.Datum . Alonzo.dataToBinaryData $ toAlonzoData d + L.Datum . L.dataToBinaryData $ toAlonzoData d binaryDataToScriptData - :: ReferenceTxInsScriptsInlineDatumsSupportedInEra era - -> Alonzo.BinaryData ledgerera -> HashableScriptData + :: L.Era ledgerera + => ReferenceTxInsScriptsInlineDatumsSupportedInEra era + -> L.BinaryData ledgerera -> HashableScriptData binaryDataToScriptData ReferenceTxInsScriptsInlineDatumsInBabbageEra d = - fromAlonzoData $ Alonzo.binaryDataToData d + fromAlonzoData $ L.binaryDataToData d binaryDataToScriptData ReferenceTxInsScriptsInlineDatumsInConwayEra d = - fromAlonzoData $ Alonzo.binaryDataToData d - + fromAlonzoData $ L.binaryDataToData d From d726f3b4b3b1e59ab4c9de08aa63cf0da8ff8074 Mon Sep 17 00:00:00 2001 From: Alexey Kuleshevich Date: Wed, 8 Mar 2023 01:46:09 +0300 Subject: [PATCH 11/38] Tx is building --- cardano-api/src/Cardano/Api/Tx.hs | 303 ++++++++++++++---------------- 1 file changed, 142 insertions(+), 161 deletions(-) diff --git a/cardano-api/src/Cardano/Api/Tx.hs b/cardano-api/src/Cardano/Api/Tx.hs index 49831955702..536c27fdab7 100644 --- a/cardano-api/src/Cardano/Api/Tx.hs +++ b/cardano-api/src/Cardano/Api/Tx.hs @@ -53,18 +53,11 @@ import Data.ByteString (ByteString) import qualified Data.ByteString as BS import qualified Data.ByteString.Lazy as LBS -import Data.Functor.Identity (Identity) import qualified Data.Map.Strict as Map import qualified Data.Set as Set import Data.Type.Equality (TestEquality (..), (:~:) (Refl)) import qualified Data.Vector as Vector -import Formatting (build, formatToString) - --- --- Common types, consensus, network --- -import Cardano.Binary (Annotated (..)) -import qualified Cardano.Binary as CBOR +import Lens.Micro -- -- Crypto API used by consensus and Shelley (and should be used by Byron) @@ -85,6 +78,9 @@ import qualified Cardano.Crypto.Signing as Byron -- -- Shelley imports -- +import Cardano.Ledger.Binary (Annotated (..)) +import qualified Cardano.Ledger.Binary as CBOR + import Cardano.Ledger.BaseTypes (maybeToStrictMaybe, strictMaybeToMaybe) import Cardano.Ledger.Crypto (StandardCrypto) @@ -93,15 +89,8 @@ import qualified Cardano.Ledger.Keys as Shelley import qualified Cardano.Ledger.Keys.Bootstrap as Shelley import qualified Cardano.Ledger.SafeHash as Ledger -import qualified Cardano.Ledger.Shelley.API as Ledger (ShelleyTx (..)) -import qualified Cardano.Ledger.Shelley.Tx as Shelley - -import Cardano.Ledger.Alonzo (AlonzoScript) -import qualified Cardano.Ledger.Alonzo as Alonzo -import Cardano.Ledger.Alonzo.Tx (AlonzoTx (AlonzoTx)) -import qualified Cardano.Ledger.Alonzo.Tx as Alonzo -import Cardano.Ledger.Alonzo.TxWitness (TxWitness (TxWitness)) -import qualified Cardano.Ledger.Alonzo.TxWitness as Alonzo +import qualified Cardano.Ledger.Alonzo.Core as L +import qualified Cardano.Ledger.Api as L import Cardano.Api.Address import Cardano.Api.Certificate @@ -127,7 +116,7 @@ data Tx era where ShelleyTx :: ShelleyBasedEra era - -> Ledger.Tx (ShelleyLedgerEra era) + -> L.Tx (ShelleyLedgerEra era) -> Tx era @@ -238,7 +227,7 @@ instance IsCardanoEra era => SerialiseAsCBOR (Tx era) where ByronEra -> ByronTx <$> CBOR.decodeFullAnnotatedBytes - "Byron Tx" fromCBOR (LBS.fromStrict bs) + CBOR.byronProtVer "Byron Tx" CBOR.decCBOR (LBS.fromStrict bs) -- Use the same derialisation impl, but at different types: ShelleyEra -> deserialiseShelleyBasedTx @@ -257,15 +246,22 @@ instance IsCardanoEra era => SerialiseAsCBOR (Tx era) where -- | The serialisation format for the different Shelley-based eras are not the -- same, but they can be handled generally with one overloaded implementation. -- -serialiseShelleyBasedTx :: ToCBOR tx => tx -> ByteString -serialiseShelleyBasedTx = CBOR.serialize' - -deserialiseShelleyBasedTx :: FromCBOR (CBOR.Annotator tx) - => (tx -> tx') +serialiseShelleyBasedTx :: forall ledgerera . + L.Era ledgerera + => CBOR.EncCBOR (L.Tx ledgerera) + => L.Tx ledgerera + -> ByteString +serialiseShelleyBasedTx = CBOR.serialize' (L.eraProtVerLow @ledgerera) + +deserialiseShelleyBasedTx :: forall ledgerera tx' . + L.Era ledgerera + => CBOR.DecCBOR (CBOR.Annotator (L.Tx ledgerera)) + => (L.Tx ledgerera -> tx') -> ByteString -> Either CBOR.DecoderError tx' deserialiseShelleyBasedTx mkTx bs = - mkTx <$> CBOR.decodeAnnotator "Shelley Tx" fromCBOR (LBS.fromStrict bs) + mkTx <$> CBOR.decodeFullAnnotator + (L.eraProtVerLow @ledgerera) "Shelley Tx" CBOR.decCBOR (LBS.fromStrict bs) instance IsCardanoEra era => HasTextEnvelope (Tx era) where @@ -292,7 +288,7 @@ data KeyWitness era where ShelleyKeyWitness :: ShelleyBasedEra era - -> Shelley.WitVKey Shelley.Witness StandardCrypto + -> L.WitVKey Shelley.Witness StandardCrypto -> KeyWitness era @@ -404,24 +400,38 @@ pattern AsShelleyWitness :: AsType (KeyWitness ShelleyEra) pattern AsShelleyWitness = AsKeyWitness AsShelleyEra {-# COMPLETE AsShelleyWitness #-} +-- This could be a useful function in other places, so it would be nice to find a beter +-- home for it. +-- | Lookup the lower major protocol version for the shelley based era +eraProtVerLow :: ShelleyBasedEra era -> CBOR.Version +eraProtVerLow era = + case era of + ShelleyBasedEraShelley -> L.eraProtVerLow @L.Shelley + ShelleyBasedEraAllegra -> L.eraProtVerLow @L.Allegra + ShelleyBasedEraMary -> L.eraProtVerLow @L.Mary + ShelleyBasedEraAlonzo -> L.eraProtVerLow @L.Alonzo + ShelleyBasedEraBabbage -> L.eraProtVerLow @L.Babbage + ShelleyBasedEraConway -> L.eraProtVerLow @L.Conway + -- This custom instance differs from cardano-ledger -- because we want to be able to tell the difference between -- on disk witnesses for the cli's 'assemble' command. instance IsCardanoEra era => SerialiseAsCBOR (KeyWitness era) where - serialiseToCBOR (ByronKeyWitness wit) = CBOR.serialize' wit + serialiseToCBOR (ByronKeyWitness wit) = + CBOR.serialize' (CBOR.byronProtVer) wit - serialiseToCBOR (ShelleyKeyWitness _era wit) = - CBOR.serializeEncoding' $ + serialiseToCBOR (ShelleyKeyWitness era wit) = + CBOR.serialize' (eraProtVerLow era) $ encodeShelleyBasedKeyWitness wit - serialiseToCBOR (ShelleyBootstrapWitness _era wit) = - CBOR.serializeEncoding' $ + serialiseToCBOR (ShelleyBootstrapWitness era wit) = + CBOR.serialize' (eraProtVerLow era) $ encodeShelleyBasedBootstrapWitness wit deserialiseFromCBOR _ bs = case cardanoEra :: CardanoEra era of ByronEra -> - ByronKeyWitness <$> CBOR.decodeFull' bs + ByronKeyWitness <$> CBOR.decodeFull' CBOR.byronProtVer bs -- Use the same derialisation impl, but at different types: ShelleyEra -> decodeShelleyBasedWitness ShelleyBasedEraShelley bs @@ -432,29 +442,32 @@ instance IsCardanoEra era => SerialiseAsCBOR (KeyWitness era) where ConwayEra -> decodeShelleyBasedWitness ShelleyBasedEraConway bs -encodeShelleyBasedKeyWitness :: ToCBOR w => w -> CBOR.Encoding +encodeShelleyBasedKeyWitness :: CBOR.EncCBOR w => w -> CBOR.Encoding encodeShelleyBasedKeyWitness wit = - CBOR.encodeListLen 2 <> CBOR.encodeWord 0 <> toCBOR wit + CBOR.encodeListLen 2 <> CBOR.encodeWord 0 <> CBOR.encCBOR wit -encodeShelleyBasedBootstrapWitness :: ToCBOR w => w -> CBOR.Encoding +encodeShelleyBasedBootstrapWitness :: CBOR.EncCBOR w => w -> CBOR.Encoding encodeShelleyBasedBootstrapWitness wit = - CBOR.encodeListLen 2 <> CBOR.encodeWord 1 <> toCBOR wit + CBOR.encodeListLen 2 <> CBOR.encodeWord 1 <> CBOR.encCBOR wit decodeShelleyBasedWitness :: forall era. - ShelleyBasedEra era + L.Era (ShelleyLedgerEra era) + => ShelleyBasedEra era -> ByteString -> Either CBOR.DecoderError (KeyWitness era) decodeShelleyBasedWitness era = - CBOR.decodeAnnotator "Shelley Witness" decode . LBS.fromStrict + CBOR.decodeFullAnnotator (L.eraProtVerLow @(ShelleyLedgerEra era)) + "Shelley Witness" decode + . LBS.fromStrict where decode :: CBOR.Decoder s (CBOR.Annotator (KeyWitness era)) decode = do CBOR.decodeListLenOf 2 t <- CBOR.decodeWord case t of - 0 -> fmap (fmap (ShelleyKeyWitness era)) fromCBOR - 1 -> fmap (fmap (ShelleyBootstrapWitness era)) fromCBOR - _ -> fail . formatToString build $ CBOR.DecoderErrorUnknownTag + 0 -> fmap (fmap (ShelleyKeyWitness era)) CBOR.decCBOR + 1 -> fmap (fmap (ShelleyBootstrapWitness era)) CBOR.decCBOR + _ -> CBOR.cborError $ CBOR.DecoderErrorUnknownTag "Shelley Witness" (fromIntegral t) @@ -482,62 +495,51 @@ getTxBody :: forall era. Tx era -> TxBody era getTxBody (ByronTx Byron.ATxAux { Byron.aTaTx = txbody }) = ByronTxBody txbody -getTxBody (ShelleyTx era tx) = +getTxBody (ShelleyTx era tx') = case era of - ShelleyBasedEraShelley -> getShelleyTxBody tx - ShelleyBasedEraAllegra -> getShelleyTxBody tx - ShelleyBasedEraMary -> getShelleyTxBody tx + ShelleyBasedEraShelley -> getShelleyTxBody tx' + ShelleyBasedEraAllegra -> getShelleyTxBody tx' + ShelleyBasedEraMary -> getShelleyTxBody tx' ShelleyBasedEraAlonzo -> - getAlonzoTxBody ScriptDataInAlonzoEra TxScriptValiditySupportedInAlonzoEra tx + getAlonzoTxBody ScriptDataInAlonzoEra TxScriptValiditySupportedInAlonzoEra tx' ShelleyBasedEraBabbage -> - getAlonzoTxBody ScriptDataInBabbageEra TxScriptValiditySupportedInBabbageEra tx + getAlonzoTxBody ScriptDataInBabbageEra TxScriptValiditySupportedInBabbageEra tx' ShelleyBasedEraConway -> - getAlonzoTxBody ScriptDataInConwayEra TxScriptValiditySupportedInConwayEra tx + getAlonzoTxBody ScriptDataInConwayEra TxScriptValiditySupportedInConwayEra tx' where getShelleyTxBody :: forall ledgerera. ShelleyLedgerEra era ~ ledgerera - => Ledger.Witnesses ledgerera ~ Shelley.WitnessSetHKD Identity ledgerera => Ledger.EraTx ledgerera - => Ledger.ShelleyTx ledgerera + => L.Tx ledgerera -> TxBody era - getShelleyTxBody Ledger.ShelleyTx { - Shelley.body = txbody, - Shelley.auxiliaryData = txAuxiliaryData, - Shelley.wits = Shelley.WitnessSet - _addrWits - msigWits - _bootWits - } = - ShelleyTxBody era txbody - (Map.elems msigWits) + getShelleyTxBody tx = + let txBody = tx ^. L.bodyTxL + txAuxData = tx ^. L.auxDataTxL + scriptWits = tx ^. L.witsTxL . L.scriptTxWitsL + in ShelleyTxBody era txBody + (Map.elems scriptWits) TxBodyNoScriptData - (strictMaybeToMaybe txAuxiliaryData) + (strictMaybeToMaybe txAuxData) TxScriptValidityNone getAlonzoTxBody :: forall ledgerera. ShelleyLedgerEra era ~ ledgerera - => Ledger.Era ledgerera - => Ledger.Script ledgerera ~ AlonzoScript ledgerera + => L.AlonzoEraTx ledgerera => ScriptDataSupportedInEra era -> TxScriptValiditySupportedInEra era - -> AlonzoTx ledgerera + -> L.Tx ledgerera -> TxBody era - getAlonzoTxBody scriptDataInEra txScriptValidityInEra - AlonzoTx { - Alonzo.body = txbody, - Alonzo.wits = TxWitness - _addrWits - _bootWits - txscripts - txdats - redeemers, - Alonzo.auxiliaryData = auxiliaryData, - Alonzo.isValid = isValid - } = - ShelleyTxBody era txbody - (Map.elems txscripts) - (TxBodyScriptData scriptDataInEra txdats redeemers) - (strictMaybeToMaybe auxiliaryData) + getAlonzoTxBody scriptDataInEra txScriptValidityInEra tx = + let txBody = tx ^. L.bodyTxL + txAuxData = tx ^. L.auxDataTxL + scriptWits = tx ^. L.witsTxL . L.scriptTxWitsL + datsWits = tx ^. L.witsTxL . L.datsTxWitsL + redeemerWits = tx ^. L.witsTxL . L.rdmrsTxWitsL + isValid = tx ^. L.isValidTxL + in ShelleyTxBody era txBody + (Map.elems scriptWits) + (TxBodyScriptData scriptDataInEra datsWits redeemerWits) + (strictMaybeToMaybe txAuxData) (TxScriptValidity txScriptValidityInEra (isValidToScriptValidity isValid)) getTxWitnesses :: forall era. Tx era -> [KeyWitness era] @@ -547,48 +549,30 @@ getTxWitnesses (ByronTx Byron.ATxAux { Byron.aTaWitness = witnesses }) = . unAnnotated $ witnesses -getTxWitnesses (ShelleyTx era tx) = +getTxWitnesses (ShelleyTx era tx') = case era of - ShelleyBasedEraShelley -> getShelleyTxWitnesses tx - ShelleyBasedEraAllegra -> getShelleyTxWitnesses tx - ShelleyBasedEraMary -> getShelleyTxWitnesses tx - ShelleyBasedEraAlonzo -> getAlonzoTxWitnesses tx - ShelleyBasedEraBabbage -> getAlonzoTxWitnesses tx - ShelleyBasedEraConway -> getAlonzoTxWitnesses tx + ShelleyBasedEraShelley -> getShelleyTxWitnesses tx' + ShelleyBasedEraAllegra -> getShelleyTxWitnesses tx' + ShelleyBasedEraMary -> getShelleyTxWitnesses tx' + ShelleyBasedEraAlonzo -> getAlonzoTxWitnesses tx' + ShelleyBasedEraBabbage -> getAlonzoTxWitnesses tx' + ShelleyBasedEraConway -> getAlonzoTxWitnesses tx' where getShelleyTxWitnesses :: forall ledgerera. - Ledger.EraTx ledgerera - => Ledger.Crypto ledgerera ~ StandardCrypto - => Ledger.Witnesses ledgerera ~ Shelley.WitnessSetHKD Identity ledgerera - => Ledger.ShelleyTx ledgerera + L.EraTx ledgerera + => L.EraCrypto ledgerera ~ StandardCrypto + => L.Tx ledgerera -> [KeyWitness era] - getShelleyTxWitnesses Ledger.ShelleyTx { - Shelley.wits = - Shelley.WitnessSet - addrWits - _msigWits - bootWits - } = - map (ShelleyBootstrapWitness era) (Set.elems bootWits) - ++ map (ShelleyKeyWitness era) (Set.elems addrWits) + getShelleyTxWitnesses tx = + map (ShelleyBootstrapWitness era) (Set.elems (tx ^. L.witsTxL . L.bootAddrTxWitsL)) + ++ map (ShelleyKeyWitness era) (Set.elems (tx ^. L.witsTxL . L.addrTxWitsL)) getAlonzoTxWitnesses :: forall ledgerera. - Ledger.Crypto ledgerera ~ StandardCrypto - => Ledger.Script ledgerera ~ Alonzo.AlonzoScript ledgerera - => Ledger.Era ledgerera - => AlonzoTx ledgerera + L.EraCrypto ledgerera ~ StandardCrypto + => L.EraTx ledgerera + => L.Tx ledgerera -> [KeyWitness era] - getAlonzoTxWitnesses AlonzoTx { - Alonzo.wits = - TxWitness - addrWits - bootWits - _txscripts - _txdats - _txrdmrs - } = - map (ShelleyBootstrapWitness era) (Set.elems bootWits) - ++ map (ShelleyKeyWitness era) (Set.elems addrWits) + getAlonzoTxWitnesses = getShelleyTxWitnesses makeSignedTransaction :: forall era. [KeyWitness era] @@ -608,60 +592,57 @@ makeSignedTransaction witnesses (ShelleyTxBody era txbody scriptValidity ) = case era of - ShelleyBasedEraShelley -> makeShelleySignedTransaction txbody - ShelleyBasedEraAllegra -> makeShelleySignedTransaction txbody - ShelleyBasedEraMary -> makeShelleySignedTransaction txbody - ShelleyBasedEraAlonzo -> makeAlonzoSignedTransaction txbody - ShelleyBasedEraBabbage -> makeAlonzoSignedTransaction txbody - ShelleyBasedEraConway -> makeAlonzoSignedTransaction txbody + ShelleyBasedEraShelley -> shelleySignedTransaction + ShelleyBasedEraAllegra -> shelleySignedTransaction + ShelleyBasedEraMary -> shelleySignedTransaction + ShelleyBasedEraAlonzo -> alonzoSignedTransaction + ShelleyBasedEraBabbage -> alonzoSignedTransaction + ShelleyBasedEraConway -> alonzoSignedTransaction where - makeShelleySignedTransaction + txCommon :: forall ledgerera. ShelleyLedgerEra era ~ ledgerera - => Ledger.Crypto ledgerera ~ StandardCrypto - => Ledger.Witnesses ledgerera ~ Shelley.WitnessSetHKD Identity ledgerera - => Ledger.Tx ledgerera ~ Ledger.ShelleyTx ledgerera + => L.EraCrypto ledgerera ~ StandardCrypto + => L.EraTx ledgerera + => L.Tx ledgerera + txCommon = + L.mkBasicTx txbody + & L.witsTxL .~ + (L.mkBasicTxWits + & L.addrTxWitsL .~ Set.fromList [ w | ShelleyKeyWitness _ w <- witnesses ] + & L.scriptTxWitsL .~ + Map.fromList [ (Ledger.hashScript @ledgerera sw, sw) + | sw <- txscripts ] + & L.bootAddrTxWitsL .~ + Set.fromList [ w | ShelleyBootstrapWitness _ w <- witnesses ] + ) + & L.auxDataTxL .~ maybeToStrictMaybe txmetadata + + shelleySignedTransaction + :: forall ledgerera. + ShelleyLedgerEra era ~ ledgerera + => Ledger.EraCrypto ledgerera ~ StandardCrypto => Ledger.EraTx ledgerera - => Ledger.TxBody ledgerera - -> Tx era - makeShelleySignedTransaction txbody' = - ShelleyTx era $ - Ledger.ShelleyTx - txbody' - (Shelley.WitnessSet - (Set.fromList [ w | ShelleyKeyWitness _ w <- witnesses ]) - (Map.fromList [ (Ledger.hashScript @ledgerera sw, sw) - | sw <- txscripts ]) - (Set.fromList [ w | ShelleyBootstrapWitness _ w <- witnesses ])) - (maybeToStrictMaybe txmetadata) - - makeAlonzoSignedTransaction + => Tx era + shelleySignedTransaction = ShelleyTx era $ txCommon + + alonzoSignedTransaction :: forall ledgerera. ShelleyLedgerEra era ~ ledgerera - => Ledger.Crypto ledgerera ~ StandardCrypto - => Ledger.Tx ledgerera ~ AlonzoTx ledgerera - => Ledger.Script ledgerera ~ AlonzoScript ledgerera - => Ledger.EraScript ledgerera - => Ledger.TxBody ledgerera - -> Tx era - makeAlonzoSignedTransaction txbody' = - ShelleyTx era $ - AlonzoTx - txbody' - (TxWitness - (Set.fromList [ w | ShelleyKeyWitness _ w <- witnesses ]) - (Set.fromList [ w | ShelleyBootstrapWitness _ w <- witnesses ]) - (Map.fromList [ (Ledger.hashScript @ledgerera sw, sw) - | sw <- txscripts ]) - datums - redeemers) - (txScriptValidityToIsValid scriptValidity) - (maybeToStrictMaybe txmetadata) + => Ledger.EraCrypto ledgerera ~ StandardCrypto + => L.AlonzoEraTx ledgerera + => Tx era + alonzoSignedTransaction = + ShelleyTx era + (txCommon + & L.witsTxL . L.datsTxWitsL .~ datums + & L.witsTxL . L.rdmrsTxWitsL .~ redeemers + & L.isValidTxL .~ txScriptValidityToIsValid scriptValidity) where (datums, redeemers) = case txscriptdata of TxBodyScriptData _ ds rs -> (ds, rs) - TxBodyNoScriptData -> (mempty, Alonzo.Redeemers mempty) + TxBodyNoScriptData -> (mempty, L.Redeemers mempty) makeByronKeyWitness :: forall key. IsByronKey key @@ -785,7 +766,7 @@ makeShelleyBasedBootstrapWitness era nwOrAddr txbody (ByronSigningKey sk) = -- reconstruct the mini-Merkel tree that is a Byron address. The suffix -- bytes are the serialised address attributes. attributes = - CBOR.serialize' $ + CBOR.serialize' CBOR.byronProtVer $ Byron.mkAttributes Byron.AddrAttributes { Byron.aaVKDerivationPath = derivationPath, Byron.aaNetworkMagic = networkMagic @@ -863,7 +844,7 @@ makeShelleyKeyWitness (ShelleyTxBody era txbody _ _ _ _) = vk = getShelleyKeyWitnessVerificationKey sk signature = makeShelleySignature txhash sk in ShelleyKeyWitness era $ - Shelley.WitVKey vk signature + L.WitVKey vk signature makeShelleyKeyWitness ByronTxBody{} = case shelleyBasedEra :: ShelleyBasedEra era of {} From 4ec87619f4c927d164100dd021c8c7525fb6281d Mon Sep 17 00:00:00 2001 From: Alexey Kuleshevich Date: Wed, 8 Mar 2023 02:13:02 +0300 Subject: [PATCH 12/38] SerialiseLedgerCddl is done --- .../src/Cardano/Api/SerialiseLedgerCddl.hs | 16 +++++++++------- cardano-api/src/Cardano/Api/Tx.hs | 3 +++ 2 files changed, 12 insertions(+), 7 deletions(-) diff --git a/cardano-api/src/Cardano/Api/SerialiseLedgerCddl.hs b/cardano-api/src/Cardano/Api/SerialiseLedgerCddl.hs index 09f4f32c2cb..e395f5d3e29 100644 --- a/cardano-api/src/Cardano/Api/SerialiseLedgerCddl.hs +++ b/cardano-api/src/Cardano/Api/SerialiseLedgerCddl.hs @@ -42,8 +42,8 @@ import Data.Text (Text) import qualified Data.Text as Text import qualified Data.Text.Encoding as Text -import Cardano.Binary (DecoderError) -import qualified Cardano.Binary as CBOR +import Cardano.Ledger.Binary (DecoderError) +import qualified Cardano.Ledger.Binary as CBOR import Cardano.Api.Eras import Cardano.Api.Error @@ -158,7 +158,7 @@ deserialiseTx deserialiseTx era bs = case era of ByronEra -> ByronTx <$> CBOR.decodeFullAnnotatedBytes - "Byron Tx" fromCBOR (LBS.fromStrict bs) + CBOR.byronProtVer "Byron Tx" CBOR.decCBOR (LBS.fromStrict bs) _ -> deserialiseFromCBOR (AsTx ttoken) bs where ttoken :: AsType era @@ -173,8 +173,8 @@ serialiseWitnessLedgerCddl sbe kw = } where cddlSerialiseWitness :: KeyWitness era -> ByteString - cddlSerialiseWitness (ShelleyBootstrapWitness _ wit) = CBOR.serialize' wit - cddlSerialiseWitness (ShelleyKeyWitness _ wit) = CBOR.serialize' wit + cddlSerialiseWitness (ShelleyBootstrapWitness era wit) = CBOR.serialize' (eraProtVerLow era) wit + cddlSerialiseWitness (ShelleyKeyWitness era wit) = CBOR.serialize' (eraProtVerLow era) wit cddlSerialiseWitness ByronKeyWitness{} = case sbe of {} genDesc :: KeyWitness era -> Text @@ -201,11 +201,13 @@ deserialiseWitnessLedgerCddl era TextEnvelopeCddl{teCddlRawCBOR,teCddlDescriptio case teCddlDescription of "Key BootstrapWitness ShelleyEra" -> do w <- first TextEnvelopeCddlErrCBORDecodingError - $ CBOR.decodeAnnotator "Shelley Witness" fromCBOR (LBS.fromStrict teCddlRawCBOR) + $ CBOR.decodeFullAnnotator + (eraProtVerLow era) "Shelley Witness" CBOR.decCBOR (LBS.fromStrict teCddlRawCBOR) Right $ ShelleyBootstrapWitness era w "Key Witness ShelleyEra" -> do w <- first TextEnvelopeCddlErrCBORDecodingError - $ CBOR.decodeAnnotator"Shelley Witness" fromCBOR (LBS.fromStrict teCddlRawCBOR) + $ CBOR.decodeFullAnnotator + (eraProtVerLow era) "Shelley Witness" CBOR.decCBOR (LBS.fromStrict teCddlRawCBOR) Right $ ShelleyKeyWitness era w _ -> Left TextEnvelopeCddlUnknownKeyWitness diff --git a/cardano-api/src/Cardano/Api/Tx.hs b/cardano-api/src/Cardano/Api/Tx.hs index 536c27fdab7..70e5170d09f 100644 --- a/cardano-api/src/Cardano/Api/Tx.hs +++ b/cardano-api/src/Cardano/Api/Tx.hs @@ -45,6 +45,9 @@ module Cardano.Api.Tx ( -- * Data family instances AsType(AsTx, AsByronTx, AsShelleyTx, AsMaryTx, AsAllegraTx, AsAlonzoTx, AsKeyWitness, AsByronWitness, AsShelleyWitness), + + -- * Utils + eraProtVerLow, ) where import Data.Maybe From a59dd06f63c9db8aaab708b0b00a769b101217bc Mon Sep 17 00:00:00 2001 From: Alexey Kuleshevich Date: Wed, 8 Mar 2023 22:54:37 +0300 Subject: [PATCH 13/38] OperationalCertificates and LedgerEvents are done --- cardano-api/cardano-api.cabal | 2 +- cardano-api/src/Cardano/Api/LedgerEvent.hs | 78 +++++++------------ .../src/Cardano/Api/OperationalCertificate.hs | 5 +- 3 files changed, 32 insertions(+), 53 deletions(-) diff --git a/cardano-api/cardano-api.cabal b/cardano-api/cardano-api.cabal index ec6086ea0da..26764cb3f2d 100644 --- a/cardano-api/cardano-api.cabal +++ b/cardano-api/cardano-api.cabal @@ -129,7 +129,7 @@ library , cardano-ledger-core ^>= 1.1 , cardano-ledger-mary ^>= 1.1 , cardano-ledger-shelley ^>= 1.1 - , cardano-protocol-tpraos >= 1.0 + , cardano-protocol-tpraos >= 1.0.1 , cardano-slotting >= 0.1 , cardano-strict-containers ^>= 0.1 , cborg diff --git a/cardano-api/src/Cardano/Api/LedgerEvent.hs b/cardano-api/src/Cardano/Api/LedgerEvent.hs index 80a987018ba..170b8543dd2 100644 --- a/cardano-api/src/Cardano/Api/LedgerEvent.hs +++ b/cardano-api/src/Cardano/Api/LedgerEvent.hs @@ -23,37 +23,25 @@ import Cardano.Api.Certificate (Certificate) import Cardano.Api.Keys.Shelley (Hash (StakePoolKeyHash), StakePoolKey) import Cardano.Api.Value (Lovelace, fromShelleyDeltaLovelace, fromShelleyLovelace) import Cardano.Ledger.Alonzo (AlonzoEra) -import Cardano.Ledger.Alonzo.Rules - ( AlonzoBbodyEvent (..), - AlonzoUtxoEvent (..), - AlonzoUtxosEvent - ( FailedPlutusScriptsEvent, - SuccessfulPlutusScriptsEvent - ), - AlonzoUtxowEvent (..), - ) +import Cardano.Ledger.Alonzo.Rules (AlonzoBbodyEvent (..), AlonzoUtxoEvent (..), + AlonzoUtxosEvent (FailedPlutusScriptsEvent, SuccessfulPlutusScriptsEvent), + AlonzoUtxowEvent (..)) import Cardano.Ledger.Alonzo.TxInfo (PlutusDebug) import Cardano.Ledger.Babbage (BabbageEra) import qualified Cardano.Ledger.Coin as Ledger import qualified Cardano.Ledger.Core as Ledger.Core import qualified Cardano.Ledger.Credential as Ledger import Cardano.Ledger.Crypto (StandardCrypto) -import Cardano.Ledger.Era (Crypto) +import Cardano.Ledger.Core (EraCrypto) import qualified Cardano.Ledger.Keys as Ledger import Cardano.Ledger.Shelley.API (InstantaneousRewards (InstantaneousRewards)) -import Cardano.Ledger.Shelley.Rewards ( Reward ) -import Cardano.Ledger.Shelley.Rules.Bbody - ( ShelleyBbodyEvent (LedgersEvent), - ) -import Cardano.Ledger.Shelley.Rules.Epoch (ShelleyEpochEvent (..)) -import qualified Cardano.Ledger.Shelley.Rules.Ledger as Shelley (ShelleyLedgerEvent (UtxowEvent)) -import qualified Cardano.Ledger.Shelley.Rules.Ledgers as Shelley (ShelleyLedgersEvent (LedgerEvent)) -import Cardano.Ledger.Shelley.Rules.Mir (ShelleyMirEvent (..)) -import Cardano.Ledger.Shelley.Rules.NewEpoch (ShelleyNewEpochEvent (..)) -import Cardano.Ledger.Shelley.Rules.PoolReap (ShelleyPoolreapEvent (..)) -import Cardano.Ledger.Shelley.Rules.Rupd (RupdEvent (..)) -import Cardano.Ledger.Shelley.Rules.Tick (ShelleyTickEvent (NewEpochEvent)) -import Cardano.Ledger.Shelley.Rules.Utxow (ShelleyUtxowEvent (UtxoEvent)) +import Cardano.Ledger.Shelley.Rewards (Reward) +import Cardano.Ledger.Shelley.Rules (RupdEvent (..), ShelleyBbodyEvent (LedgersEvent), + ShelleyEpochEvent (..), ShelleyMirEvent (..), ShelleyNewEpochEvent (..), + ShelleyPoolreapEvent (..), ShelleyTickEvent (TickNewEpochEvent), + ShelleyUtxowEvent (UtxoEvent)) +import qualified Cardano.Ledger.Shelley.Rules as Shelley (ShelleyLedgerEvent (UtxowEvent), + ShelleyLedgersEvent (LedgerEvent)) import Control.State.Transition (Event) import Data.List.NonEmpty (NonEmpty) import Data.Map.Strict (Map) @@ -64,17 +52,9 @@ import Ouroboros.Consensus.Byron.Ledger.Block (ByronBlock) import Ouroboros.Consensus.Cardano.Block (HardForkBlock) import Ouroboros.Consensus.HardFork.Combinator.AcrossEras (getOneEraLedgerEvent) import Ouroboros.Consensus.Ledger.Basics (AuxLedgerEvent) -import Ouroboros.Consensus.Shelley.Ledger - ( LedgerState, - ShelleyBlock, - ShelleyLedgerEvent - ( ShelleyLedgerEventBBODY, - ShelleyLedgerEventTICK - ), - ) -import Ouroboros.Consensus.TypeFamilyWrappers - ( WrapLedgerEvent (unwrapLedgerEvent), - ) +import Ouroboros.Consensus.Shelley.Ledger (LedgerState, ShelleyBlock, + ShelleyLedgerEvent (ShelleyLedgerEventBBODY, ShelleyLedgerEventTICK)) +import Ouroboros.Consensus.TypeFamilyWrappers (WrapLedgerEvent (unwrapLedgerEvent)) data LedgerEvent = -- | The given pool is being registered for the first time on chain. @@ -101,13 +81,13 @@ instance ConvertLedgerEvent ByronBlock where toLedgerEvent _ = Nothing instance - ( Crypto ledgerera ~ StandardCrypto, + ( EraCrypto ledgerera ~ StandardCrypto, Event (Ledger.Core.EraRule "TICK" ledgerera) ~ ShelleyTickEvent ledgerera, Event (Ledger.Core.EraRule "NEWEPOCH" ledgerera) ~ ShelleyNewEpochEvent ledgerera, Event (Ledger.Core.EraRule "EPOCH" ledgerera) ~ ShelleyEpochEvent ledgerera, Event (Ledger.Core.EraRule "POOLREAP" ledgerera) ~ ShelleyPoolreapEvent ledgerera, Event (Ledger.Core.EraRule "MIR" ledgerera) ~ ShelleyMirEvent ledgerera, - Event (Ledger.Core.EraRule "RUPD" ledgerera) ~ RupdEvent (Crypto ledgerera) + Event (Ledger.Core.EraRule "RUPD" ledgerera) ~ RupdEvent StandardCrypto ) => ConvertLedgerEvent (ShelleyBlock protocol ledgerera) where @@ -135,13 +115,13 @@ instance All ConvertLedgerEvent xs => ConvertLedgerEvent (HardForkBlock xs) wher . unwrapLedgerEvent toLedgerEventShelley :: - ( Crypto ledgerera ~ StandardCrypto, + ( EraCrypto ledgerera ~ StandardCrypto, Event (Ledger.Core.EraRule "TICK" ledgerera) ~ ShelleyTickEvent ledgerera, Event (Ledger.Core.EraRule "NEWEPOCH" ledgerera) ~ ShelleyNewEpochEvent ledgerera, Event (Ledger.Core.EraRule "EPOCH" ledgerera) ~ ShelleyEpochEvent ledgerera, Event (Ledger.Core.EraRule "POOLREAP" ledgerera) ~ ShelleyPoolreapEvent ledgerera, Event (Ledger.Core.EraRule "MIR" ledgerera) ~ ShelleyMirEvent ledgerera, - Event (Ledger.Core.EraRule "RUPD" ledgerera) ~ RupdEvent (Crypto ledgerera) + Event (Ledger.Core.EraRule "RUPD" ledgerera) ~ RupdEvent StandardCrypto ) => WrapLedgerEvent (ShelleyBlock protocol ledgerera) -> Maybe LedgerEvent @@ -187,7 +167,7 @@ data PoolReapDetails = PoolReapDetails -------------------------------------------------------------------------------- pattern LERewardEvent :: - ( Crypto ledgerera ~ StandardCrypto, + ( EraCrypto ledgerera ~ StandardCrypto, Event (Ledger.Core.EraRule "TICK" ledgerera) ~ ShelleyTickEvent ledgerera, Event (Ledger.Core.EraRule "NEWEPOCH" ledgerera) ~ ShelleyNewEpochEvent ledgerera ) => @@ -196,23 +176,23 @@ pattern LERewardEvent :: AuxLedgerEvent (LedgerState (ShelleyBlock protocol ledgerera)) pattern LERewardEvent e m <- ShelleyLedgerEventTICK - (NewEpochEvent (TotalRewardEvent e (Map.mapKeys fromShelleyStakeCredential -> m))) + (TickNewEpochEvent (TotalRewardEvent e (Map.mapKeys fromShelleyStakeCredential -> m))) pattern LEDeltaRewardEvent :: - ( Crypto ledgerera ~ StandardCrypto, + ( EraCrypto ledgerera ~ StandardCrypto, Event (Ledger.Core.EraRule "TICK" ledgerera) ~ ShelleyTickEvent ledgerera, Event (Ledger.Core.EraRule "NEWEPOCH" ledgerera) ~ ShelleyNewEpochEvent ledgerera, - Event (Ledger.Core.EraRule "RUPD" ledgerera) ~ RupdEvent (Crypto ledgerera) + Event (Ledger.Core.EraRule "RUPD" ledgerera) ~ RupdEvent StandardCrypto ) => EpochNo -> Map StakeCredential (Set (Reward StandardCrypto)) -> AuxLedgerEvent (LedgerState (ShelleyBlock protocol ledgerera)) pattern LEDeltaRewardEvent e m <- ShelleyLedgerEventTICK - (NewEpochEvent (DeltaRewardEvent (RupdEvent e (Map.mapKeys fromShelleyStakeCredential -> m)))) + (TickNewEpochEvent (DeltaRewardEvent (RupdEvent e (Map.mapKeys fromShelleyStakeCredential -> m)))) pattern LEMirTransfer :: - ( Crypto ledgerera ~ StandardCrypto, + ( EraCrypto ledgerera ~ StandardCrypto, Event (Ledger.Core.EraRule "TICK" ledgerera) ~ ShelleyTickEvent ledgerera, Event (Ledger.Core.EraRule "NEWEPOCH" ledgerera) ~ ShelleyNewEpochEvent ledgerera, Event (Ledger.Core.EraRule "MIR" ledgerera) ~ ShelleyMirEvent ledgerera @@ -224,7 +204,7 @@ pattern LEMirTransfer :: AuxLedgerEvent (LedgerState (ShelleyBlock protocol ledgerera)) pattern LEMirTransfer rp tp rtt ttr <- ShelleyLedgerEventTICK - ( NewEpochEvent + ( TickNewEpochEvent ( MirEvent ( MirTransfer ( InstantaneousRewards @@ -238,7 +218,7 @@ pattern LEMirTransfer rp tp rtt ttr <- ) pattern LERetiredPools :: - ( Crypto ledgerera ~ StandardCrypto, + ( EraCrypto ledgerera ~ StandardCrypto, Event (Ledger.Core.EraRule "TICK" ledgerera) ~ ShelleyTickEvent ledgerera, Event (Ledger.Core.EraRule "NEWEPOCH" ledgerera) ~ ShelleyNewEpochEvent ledgerera, Event (Ledger.Core.EraRule "EPOCH" ledgerera) ~ ShelleyEpochEvent ledgerera, @@ -250,7 +230,7 @@ pattern LERetiredPools :: AuxLedgerEvent (LedgerState (ShelleyBlock protocol ledgerera)) pattern LERetiredPools r u e <- ShelleyLedgerEventTICK - ( NewEpochEvent + ( TickNewEpochEvent ( EpochEvent ( PoolReapEvent ( RetiredPools @@ -263,7 +243,7 @@ pattern LERetiredPools r u e <- ) pattern LEPlutusSuccess :: - ( Crypto ledgerera ~ StandardCrypto, + ( EraCrypto ledgerera ~ StandardCrypto, Event (Ledger.Core.EraRule "BBODY" ledgerera) ~ AlonzoBbodyEvent ledgerera, Event (Ledger.Core.EraRule "LEDGERS" ledgerera) ~ Shelley.ShelleyLedgersEvent ledgerera, Event (Ledger.Core.EraRule "LEDGER" ledgerera) ~ Shelley.ShelleyLedgerEvent ledgerera, @@ -293,7 +273,7 @@ pattern LEPlutusSuccess ds <- ) pattern LEPlutusFailure :: - ( Crypto ledgerera ~ StandardCrypto, + ( EraCrypto ledgerera ~ StandardCrypto, Event (Ledger.Core.EraRule "BBODY" ledgerera) ~ AlonzoBbodyEvent ledgerera, Event (Ledger.Core.EraRule "LEDGERS" ledgerera) ~ Shelley.ShelleyLedgersEvent ledgerera, Event (Ledger.Core.EraRule "LEDGER" ledgerera) ~ Shelley.ShelleyLedgerEvent ledgerera, diff --git a/cardano-api/src/Cardano/Api/OperationalCertificate.hs b/cardano-api/src/Cardano/Api/OperationalCertificate.hs index 88361940e59..ac699a3d0f4 100644 --- a/cardano-api/src/Cardano/Api/OperationalCertificate.hs +++ b/cardano-api/src/Cardano/Api/OperationalCertificate.hs @@ -22,7 +22,6 @@ import Data.Word import Cardano.Ledger.Crypto (StandardCrypto) import qualified Cardano.Ledger.Keys as Shelley -import qualified Cardano.Ledger.Serialization as CBOR (CBORGroup (..)) import Cardano.Api.Address import Cardano.Api.Certificate @@ -60,11 +59,11 @@ data OperationalCertificateIssueCounter = instance ToCBOR OperationalCertificate where toCBOR (OperationalCertificate ocert vkey) = - toCBOR (CBOR.CBORGroup ocert, vkey) + toCBOR (ocert, vkey) instance FromCBOR OperationalCertificate where fromCBOR = do - (CBOR.CBORGroup ocert, vkey) <- fromCBOR + (ocert, vkey) <- fromCBOR return (OperationalCertificate ocert vkey) instance ToCBOR OperationalCertificateIssueCounter where From 32cd1a46823c329e1eced5490eb0f980ec598b7e Mon Sep 17 00:00:00 2001 From: Alexey Kuleshevich Date: Wed, 8 Mar 2023 23:17:37 +0300 Subject: [PATCH 14/38] Query is done. Starting on Query --- cardano-api/src/Cardano/Api/LedgerEvent.hs | 33 ++++----- cardano-api/src/Cardano/Api/LedgerState.hs | 71 +++++++++---------- cardano-api/src/Cardano/Api/Query.hs | 79 +++++++++++----------- 3 files changed, 89 insertions(+), 94 deletions(-) diff --git a/cardano-api/src/Cardano/Api/LedgerEvent.hs b/cardano-api/src/Cardano/Api/LedgerEvent.hs index 170b8543dd2..d9741567f94 100644 --- a/cardano-api/src/Cardano/Api/LedgerEvent.hs +++ b/cardano-api/src/Cardano/Api/LedgerEvent.hs @@ -22,17 +22,17 @@ import Cardano.Api.Block (EpochNo) import Cardano.Api.Certificate (Certificate) import Cardano.Api.Keys.Shelley (Hash (StakePoolKeyHash), StakePoolKey) import Cardano.Api.Value (Lovelace, fromShelleyDeltaLovelace, fromShelleyLovelace) -import Cardano.Ledger.Alonzo (AlonzoEra) import Cardano.Ledger.Alonzo.Rules (AlonzoBbodyEvent (..), AlonzoUtxoEvent (..), AlonzoUtxosEvent (FailedPlutusScriptsEvent, SuccessfulPlutusScriptsEvent), AlonzoUtxowEvent (..)) import Cardano.Ledger.Alonzo.TxInfo (PlutusDebug) -import Cardano.Ledger.Babbage (BabbageEra) +import Cardano.Ledger.Api.Era (AllegraEra, AlonzoEra, BabbageEra, ConwayEra, MaryEra, + ShelleyEra) import qualified Cardano.Ledger.Coin as Ledger +import Cardano.Ledger.Core (EraCrypto) import qualified Cardano.Ledger.Core as Ledger.Core import qualified Cardano.Ledger.Credential as Ledger import Cardano.Ledger.Crypto (StandardCrypto) -import Cardano.Ledger.Core (EraCrypto) import qualified Cardano.Ledger.Keys as Ledger import Cardano.Ledger.Shelley.API (InstantaneousRewards (InstantaneousRewards)) import Cardano.Ledger.Shelley.Rewards (Reward) @@ -80,33 +80,30 @@ class ConvertLedgerEvent blk where instance ConvertLedgerEvent ByronBlock where toLedgerEvent _ = Nothing -instance - ( EraCrypto ledgerera ~ StandardCrypto, - Event (Ledger.Core.EraRule "TICK" ledgerera) ~ ShelleyTickEvent ledgerera, - Event (Ledger.Core.EraRule "NEWEPOCH" ledgerera) ~ ShelleyNewEpochEvent ledgerera, - Event (Ledger.Core.EraRule "EPOCH" ledgerera) ~ ShelleyEpochEvent ledgerera, - Event (Ledger.Core.EraRule "POOLREAP" ledgerera) ~ ShelleyPoolreapEvent ledgerera, - Event (Ledger.Core.EraRule "MIR" ledgerera) ~ ShelleyMirEvent ledgerera, - Event (Ledger.Core.EraRule "RUPD" ledgerera) ~ RupdEvent StandardCrypto - ) => - ConvertLedgerEvent (ShelleyBlock protocol ledgerera) - where +instance ConvertLedgerEvent (ShelleyBlock protocol (ShelleyEra StandardCrypto)) where + toLedgerEvent = toLedgerEventShelley + +instance ConvertLedgerEvent (ShelleyBlock protocol (MaryEra StandardCrypto)) where toLedgerEvent = toLedgerEventShelley -instance {-# OVERLAPPING #-} ConvertLedgerEvent (ShelleyBlock protocol (AlonzoEra StandardCrypto)) - where +instance ConvertLedgerEvent (ShelleyBlock protocol (AllegraEra StandardCrypto)) where + toLedgerEvent = toLedgerEventShelley + +instance ConvertLedgerEvent (ShelleyBlock protocol (AlonzoEra StandardCrypto)) where toLedgerEvent evt = case unwrapLedgerEvent evt of LEPlutusSuccess ds -> Just $ SuccessfulPlutusScript ds LEPlutusFailure ds -> Just $ FailedPlutusScript ds _ -> toLedgerEventShelley evt -instance {-# OVERLAPPING #-} ConvertLedgerEvent (ShelleyBlock protocol (BabbageEra StandardCrypto)) - where +instance ConvertLedgerEvent (ShelleyBlock protocol (BabbageEra StandardCrypto)) where toLedgerEvent evt = case unwrapLedgerEvent evt of LEPlutusSuccess ds -> Just $ SuccessfulPlutusScript ds LEPlutusFailure ds -> Just $ FailedPlutusScript ds _ -> toLedgerEventShelley evt +instance ConvertLedgerEvent (ShelleyBlock protocol (ConwayEra StandardCrypto)) where + toLedgerEvent _evt = Nothing -- LEDGER rule is defined anew in Conway + instance All ConvertLedgerEvent xs => ConvertLedgerEvent (HardForkBlock xs) where toLedgerEvent = hcollapse diff --git a/cardano-api/src/Cardano/Api/LedgerState.hs b/cardano-api/src/Cardano/Api/LedgerState.hs index 811db2dcbd1..42cc636ac14 100644 --- a/cardano-api/src/Cardano/Api/LedgerState.hs +++ b/cardano-api/src/Cardano/Api/LedgerState.hs @@ -83,7 +83,6 @@ import Data.Sequence (Seq) import qualified Data.Sequence as Seq import Data.Set (Set) import qualified Data.Set as Set -import Data.Sharing (FromSharedCBOR, Interns, Share) import Data.SOP.Strict (K (..), NP (..), fn, (:.:) (Comp)) import Data.Text (Text) import qualified Data.Text as Text @@ -127,19 +126,18 @@ import qualified Cardano.Crypto.VRF as Crypto import qualified Cardano.Crypto.VRF.Class as VRF import Cardano.Ledger.Alonzo.Genesis (AlonzoGenesis (..)) import Cardano.Ledger.BaseTypes (Globals (..), Nonce, UnitInterval, (⭒)) -import qualified Cardano.Ledger.BaseTypes as Shelley.Spec +import qualified Cardano.Ledger.BaseTypes as Ledger import qualified Cardano.Ledger.BHeaderView as Ledger -import Cardano.Ledger.Conway.Genesis (ConwayGenesis (..)) +import qualified Cardano.Ledger.Conway.Genesis as Conway (ConwayGenesis (..)) import qualified Cardano.Ledger.Core as Core -import qualified Cardano.Ledger.Core as Ledger -import qualified Cardano.Ledger.Credential as Shelley.Spec +import qualified Cardano.Ledger.Credential as Ledger import qualified Cardano.Ledger.Era -import qualified Cardano.Ledger.Keys as Shelley.Spec +import qualified Cardano.Ledger.Keys as Ledger import qualified Cardano.Ledger.Keys as SL import qualified Cardano.Ledger.PoolDistr as SL import Cardano.Ledger.SafeHash (HashAnnotated) import qualified Cardano.Ledger.Shelley.API as ShelleyAPI -import qualified Cardano.Ledger.Shelley.Genesis as Shelley.Spec +import qualified Cardano.Ledger.Shelley.Genesis as Ledger import qualified Cardano.Protocol.TPraos.API as TPraos import Cardano.Protocol.TPraos.BHeader (checkLeaderNatValue) import qualified Cardano.Protocol.TPraos.BHeader as TPraos @@ -731,17 +729,17 @@ genesisConfigToEnv genCfg = case genCfg of GenesisCardano _ bCfg sCfg _ _ - | Cardano.Crypto.ProtocolMagic.unProtocolMagicId (Cardano.Chain.Genesis.configProtocolMagicId bCfg) /= Shelley.Spec.sgNetworkMagic (scConfig sCfg) -> + | Cardano.Crypto.ProtocolMagic.unProtocolMagicId (Cardano.Chain.Genesis.configProtocolMagicId bCfg) /= Ledger.sgNetworkMagic (scConfig sCfg) -> Left . NECardanoConfig $ mconcat [ "ProtocolMagicId ", textShow (Cardano.Crypto.ProtocolMagic.unProtocolMagicId $ Cardano.Chain.Genesis.configProtocolMagicId bCfg) - , " /= ", textShow (Shelley.Spec.sgNetworkMagic $ scConfig sCfg) + , " /= ", textShow (Ledger.sgNetworkMagic $ scConfig sCfg) ] - | Cardano.Chain.Genesis.gdStartTime (Cardano.Chain.Genesis.configGenesisData bCfg) /= Shelley.Spec.sgSystemStart (scConfig sCfg) -> + | Cardano.Chain.Genesis.gdStartTime (Cardano.Chain.Genesis.configGenesisData bCfg) /= Ledger.sgSystemStart (scConfig sCfg) -> Left . NECardanoConfig $ mconcat [ "SystemStart ", textShow (Cardano.Chain.Genesis.gdStartTime $ Cardano.Chain.Genesis.configGenesisData bCfg) - , " /= ", textShow (Shelley.Spec.sgSystemStart $ scConfig sCfg) + , " /= ", textShow (Ledger.sgSystemStart $ scConfig sCfg) ] | otherwise -> let @@ -807,7 +805,7 @@ instance FromJSON NodeConfig where <*> o .: "RequiresNetworkMagic" <*> parseByronSoftwareVersion o <*> parseByronProtocolVersion o - <*> (Consensus.ProtocolTransitionParamsShelleyBased () + <*> (Consensus.ProtocolTransitionParamsShelleyBased undefined <$> parseShelleyHardForkEpoch o) <*> (Consensus.ProtocolTransitionParamsShelleyBased () <$> parseAllegraHardForkEpoch o) @@ -952,6 +950,8 @@ toLedgerStateEvents lr = (ledgerState, ledgerEvents) . WrapLedgerEvent @(HFC.HardForkBlock (Consensus.CardanoEras Shelley.StandardCrypto))) $ lrEvents lr +-- TODO: Fix ConwayGenesis in Ledger +type ConwayGenesis c = ShelleyAPI.GenDelegs c -- Usually only one constructor, but may have two when we are preparing for a HFC event. data GenesisConfig @@ -963,7 +963,7 @@ data GenesisConfig !(ConwayGenesis Shelley.StandardCrypto) data ShelleyConfig = ShelleyConfig - { scConfig :: !(Shelley.Spec.ShelleyGenesis Shelley.StandardShelley) + { scConfig :: !(Ledger.ShelleyGenesis Shelley.StandardCrypto) , scGenesisHash :: !GenesisHashShelley } @@ -1052,16 +1052,17 @@ mkProtocolInfoCardano (GenesisCardano dnc byronGenesis shelleyGenesis alonzoGene (ncShelleyToAllegra dnc) (ncAllegraToMary dnc) (Consensus.ProtocolTransitionParamsShelleyBased alonzoGenesis (ncMaryToAlonzo dnc)) - (Consensus.ProtocolTransitionParamsShelleyBased alonzoGenesis (ncAlonzoToBabbage dnc)) + -- (Consensus.ProtocolTransitionParamsShelleyBased alonzoGenesis (ncAlonzoToBabbage dnc)) + (Consensus.ProtocolTransitionParamsShelleyBased () (ncAlonzoToBabbage dnc)) (Consensus.ProtocolTransitionParamsShelleyBased conwayGenesis (ncBabbageToConway dnc)) -shelleyPraosNonce :: ShelleyConfig -> Shelley.Spec.Nonce -shelleyPraosNonce sCfg = Shelley.Spec.Nonce (Cardano.Crypto.Hash.Class.castHash . unGenesisHashShelley $ scGenesisHash sCfg) +shelleyPraosNonce :: ShelleyConfig -> Ledger.Nonce +shelleyPraosNonce sCfg = Ledger.Nonce (Cardano.Crypto.Hash.Class.castHash . unGenesisHashShelley $ scGenesisHash sCfg) -shelleyProtVer :: NodeConfig -> Shelley.Spec.ProtVer +shelleyProtVer :: NodeConfig -> Ledger.ProtVer shelleyProtVer dnc = let bver = ncByronProtocolVersion dnc in - Shelley.Spec.ProtVer + Ledger.ProtVer (fromIntegral $ Cardano.Chain.Update.pvMajor bver) (fromIntegral $ Cardano.Chain.Update.pvMinor bver) @@ -1293,7 +1294,7 @@ renderHash :: Cardano.Crypto.Hash.Class.Hash Cardano.Crypto.Hash.Blake2b.Blake2b renderHash h = Text.decodeUtf8 $ Base16.encode (Cardano.Crypto.Hash.Class.hashToBytes h) newtype StakeCred - = StakeCred { _unStakeCred :: Shelley.Spec.Credential 'Shelley.Spec.Staking Consensus.StandardCrypto } + = StakeCred { _unStakeCred :: Ledger.Credential 'Ledger.Staking Consensus.StandardCrypto } deriving (Eq, Ord) data Env = Env @@ -1450,10 +1451,9 @@ instance Error LeadershipError where nextEpochEligibleLeadershipSlots :: forall era. ( HasField "_d" (Core.PParams (ShelleyLedgerEra era)) UnitInterval - , HashAnnotated (Core.TxBody (ShelleyLedgerEra era)) Core.EraIndependentTxBody (Ledger.Crypto (ShelleyLedgerEra era)) + , HashAnnotated (Core.TxBody (ShelleyLedgerEra era)) Core.EraIndependentTxBody (Ledger.EraCrypto (ShelleyLedgerEra era)) ) => Ledger.Era (ShelleyLedgerEra era) - => Share (Core.TxOut (ShelleyLedgerEra era)) ~ Interns (Shelley.Spec.Credential 'Shelley.Spec.Staking (Cardano.Ledger.Era.Crypto (ShelleyLedgerEra era))) => FromCBOR (Consensus.ChainDepState (Api.ConsensusProtocol era)) => Consensus.PraosProtocolSupportsNode (Api.ConsensusProtocol era) => ShelleyBasedEra era @@ -1483,7 +1483,7 @@ nextEpochEligibleLeadershipSlots sbe sGen serCurrEpochState ptclState poolid (Vr -- k is the security parameter -- f is the active slot coefficient let stabilityWindowR :: Rational - stabilityWindowR = fromIntegral (3 * sgSecurityParam sGen) / Shelley.Spec.unboundRational (sgActiveSlotsCoeff sGen) + stabilityWindowR = fromIntegral (3 * sgSecurityParam sGen) / Ledger.unboundRational (sgActiveSlotsCoeff sGen) stabilityWindowSlots :: SlotNo stabilityWindowSlots = fromIntegral @Word64 $ floor $ fromRational @Double stabilityWindowR stableStakeDistribSlot = currentEpochLastSlot - stabilityWindowSlots @@ -1521,7 +1521,7 @@ nextEpochEligibleLeadershipSlots sbe sGen serCurrEpochState ptclState poolid (Vr $ decodeCurrentEpochState serCurrEpochState let snapshot :: ShelleyAPI.SnapShot Shelley.StandardCrypto - snapshot = ShelleyAPI._pstakeMark $ obtainIsStandardCrypto sbe $ ShelleyAPI.esSnapshots cEstate + snapshot = ShelleyAPI.ssStakeMark $ obtainIsStandardCrypto sbe $ ShelleyAPI.esSnapshots cEstate markSnapshotPoolDistr :: Map (SL.KeyHash 'SL.StakePool Shelley.StandardCrypto) (SL.IndividualPoolStake Shelley.StandardCrypto) markSnapshotPoolDistr = ShelleyAPI.unPoolDistr . ShelleyAPI.calculatePoolDistr $ snapshot @@ -1539,7 +1539,7 @@ nextEpochEligibleLeadershipSlots sbe sGen serCurrEpochState ptclState poolid (Vr where globals = constructGlobals sGen eInfo (unbundleProtocolParams bpp) - f :: Shelley.Spec.ActiveSlotCoeff + f :: Ledger.ActiveSlotCoeff f = activeSlotCoeff globals @@ -1560,7 +1560,7 @@ nextEpochEligibleLeadershipSlots sbe sGen serCurrEpochState ptclState poolid (Vr -- We need the certified natural value from the VRF, active slot coefficient -- and the stake proportion of the stake pool. isLeadingSlotsTPraos :: forall v. () - => Crypto.Signable v Shelley.Spec.Seed + => Crypto.Signable v Ledger.Seed => Crypto.VRFAlgorithm v => Crypto.ContextVRF v ~ () => Set SlotNo @@ -1568,7 +1568,7 @@ isLeadingSlotsTPraos :: forall v. () -> Map (SL.KeyHash 'SL.StakePool Shelley.StandardCrypto) (SL.IndividualPoolStake Shelley.StandardCrypto) -> Consensus.Nonce -> Crypto.SignKeyVRF v - -> Shelley.Spec.ActiveSlotCoeff + -> Ledger.ActiveSlotCoeff -> Either LeadershipError (Set SlotNo) isLeadingSlotsTPraos slotRangeOfInterest poolid snapshotPoolDistr eNonce vrfSkey activeSlotCoeff' = do let StakePoolKeyHash poolHash = poolid @@ -1588,7 +1588,7 @@ isLeadingSlotsPraos :: () -> Map (SL.KeyHash 'SL.StakePool Shelley.StandardCrypto) (SL.IndividualPoolStake Shelley.StandardCrypto) -> Consensus.Nonce -> SL.SignKeyVRF Shelley.StandardCrypto - -> Shelley.Spec.ActiveSlotCoeff + -> Ledger.ActiveSlotCoeff -> Either LeadershipError (Set SlotNo) isLeadingSlotsPraos slotRangeOfInterest poolid snapshotPoolDistr eNonce vrfSkey activeSlotCoeff' = do let StakePoolKeyHash poolHash = poolid @@ -1605,7 +1605,7 @@ isLeadingSlotsPraos slotRangeOfInterest poolid snapshotPoolDistr eNonce vrfSkey obtainIsStandardCrypto :: ShelleyLedgerEra era ~ ledgerera => ShelleyBasedEra era - -> (Cardano.Ledger.Era.Crypto ledgerera ~ Shelley.StandardCrypto => a) + -> (Ledger.EraCrypto ledgerera ~ Shelley.StandardCrypto => a) -> a obtainIsStandardCrypto ShelleyBasedEraShelley f = f obtainIsStandardCrypto ShelleyBasedEraAllegra f = f @@ -1621,11 +1621,10 @@ obtainDecodeEpochStateConstraints -> (( FromCBOR (Core.PParams ledgerera) , FromCBOR (State (Core.EraRule "PPUP" ledgerera)) , FromCBOR (Core.Value ledgerera) - , FromSharedCBOR (Core.TxOut ledgerera) , HashAnnotated (Core.TxBody ledgerera) Core.EraIndependentTxBody - (Ledger.Crypto (ShelleyLedgerEra era)) + (Ledger.EraCrypto (ShelleyLedgerEra era)) ) => a) -> a obtainDecodeEpochStateConstraints ShelleyBasedEraShelley f = f obtainDecodeEpochStateConstraints ShelleyBasedEraAllegra f = f @@ -1641,9 +1640,8 @@ currentEpochEligibleLeadershipSlots :: forall era ledgerera. () => Ledger.Era ledgerera => Consensus.PraosProtocolSupportsNode (Api.ConsensusProtocol era) => HasField "_d" (Core.PParams ledgerera) UnitInterval - -- => Crypto.Signable (Crypto.VRF (Ledger.Crypto ledgerera)) Shelley.Spec.Seed - -- => Share (Core.TxOut (ShelleyLedgerEra era)) ~ Interns (Shelley.Spec.Credential 'Shelley.Spec.Staking (Cardano.Ledger.Era.Crypto (ShelleyLedgerEra era))) - -- => Ledger.Crypto ledgerera ~ Shelley.StandardCrypto + -- => Crypto.Signable (Crypto.VRF (Ledger.EraCrypto ledgerera)) Ledger.Seed + -- => Ledger.EraCrypto ledgerera ~ Shelley.StandardCrypto => FromCBOR (Consensus.ChainDepState (Api.ConsensusProtocol era)) -- => Consensus.ChainDepState (ConsensusProtocol era) ~ Consensus.ChainDepState (ConsensusProtocol era) => ShelleyBasedEra era @@ -1689,7 +1687,7 @@ currentEpochEligibleLeadershipSlots sbe sGen eInfo bpp ptclState poolid (VrfSign where globals = constructGlobals sGen eInfo (unbundleProtocolParams bpp) - f :: Shelley.Spec.ActiveSlotCoeff + f :: Ledger.ActiveSlotCoeff f = activeSlotCoeff globals constructGlobals @@ -1699,4 +1697,7 @@ constructGlobals -> Globals constructGlobals sGen eInfo pParams = let majorPParamsVer = fst $ protocolParamProtocolVersion pParams - in Shelley.Spec.mkShelleyGlobals sGen eInfo majorPParamsVer + in Ledger.mkShelleyGlobals sGen eInfo $ + case Ledger.mkVersion majorPParamsVer of + Nothing -> error $ "Invalid version: " ++ show majorPParamsVer + Just version -> version diff --git a/cardano-api/src/Cardano/Api/Query.hs b/cardano-api/src/Cardano/Api/Query.hs index b53a5372f98..f7a6d61c5bd 100644 --- a/cardano-api/src/Cardano/Api/Query.hs +++ b/cardano-api/src/Cardano/Api/Query.hs @@ -8,6 +8,7 @@ {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE StandaloneDeriving #-} {-# LANGUAGE TupleSections #-} +{-# LANGUAGE TypeApplications #-} {-# LANGUAGE UndecidableInstances #-} -- The Shelley ledger uses promoted data kinds which we have to use, but we do @@ -90,7 +91,6 @@ import qualified Data.Map.Strict as Map import Data.Maybe (mapMaybe) import Data.Set (Set) import qualified Data.Set as Set -import Data.Sharing (FromSharedCBOR, Interns, Share) import Data.SOP.Strict (SListI) import Data.Text (Text) import qualified Data.Text as Text @@ -116,17 +116,17 @@ import qualified Ouroboros.Consensus.Shelley.Ledger as Consensus import Ouroboros.Network.Block (Serialised (..)) import Ouroboros.Network.NodeToClient.Version (NodeToClientVersion (..)) -import Cardano.Binary import Cardano.Slotting.EpochInfo (hoistEpochInfo) import Cardano.Slotting.Slot (WithOrigin (..)) import Cardano.Slotting.Time (SystemStart (..)) import qualified Cardano.Chain.Update.Validation.Interface as Byron.Update -import qualified Cardano.Ledger.Core as Core -import qualified Cardano.Ledger.Era as Ledger import qualified Control.State.Transition.Extended as Ledger +import Cardano.Ledger.Binary +import qualified Cardano.Ledger.Binary.Plain as Plain import qualified Cardano.Ledger.Shelley.API as Shelley +import qualified Cardano.Ledger.Shelley.Core as Core import qualified Cardano.Ledger.Shelley.LedgerState as Shelley import Cardano.Api.Address @@ -377,23 +377,23 @@ decodeDebugLedgerState :: forall era. () => SerialisedDebugLedgerState era -> Either LBS.ByteString (DebugLedgerState era) decodeDebugLedgerState (SerialisedDebugLedgerState (Serialised ls)) = - first (const ls) (decodeFull ls) + first (const ls) (Plain.decodeFull ls) data DebugLedgerState era where DebugLedgerState :: ShelleyLedgerEra era ~ ledgerera => Shelley.NewEpochState ledgerera -> DebugLedgerState era instance ( Typeable era - , Ledger.Era (ShelleyLedgerEra era) + , Core.EraTxOut (ShelleyLedgerEra era) + , Core.EraGovernance (ShelleyLedgerEra era) , FromCBOR (Core.PParams (ShelleyLedgerEra era)) - , FromCBOR (Shelley.StashedAVVMAddresses (ShelleyLedgerEra era)) + , DecCBOR (Shelley.StashedAVVMAddresses (ShelleyLedgerEra era)) , FromCBOR (Core.Value (ShelleyLedgerEra era)) , FromCBOR (Ledger.State (Core.EraRule "PPUP" (ShelleyLedgerEra era))) - , Share (Core.TxOut (ShelleyLedgerEra era)) ~ Interns (Shelley.Credential 'Shelley.Staking (Ledger.Crypto (ShelleyLedgerEra era))) - , FromSharedCBOR (Core.TxOut (ShelleyLedgerEra era)) - , HashAnnotated (Core.TxBody (ShelleyLedgerEra era)) Core.EraIndependentTxBody (Ledger.Crypto (ShelleyLedgerEra era)) + , HashAnnotated (Core.TxBody (ShelleyLedgerEra era)) Core.EraIndependentTxBody (Core.EraCrypto (ShelleyLedgerEra era)) ) => FromCBOR (DebugLedgerState era) where - fromCBOR = DebugLedgerState <$> (fromCBOR :: Decoder s (Shelley.NewEpochState (ShelleyLedgerEra era))) + fromCBOR = DebugLedgerState <$> + (fromCBOR :: Plain.Decoder s (Shelley.NewEpochState (ShelleyLedgerEra era))) -- TODO: Shelley based era class! instance ( IsShelleyBasedEra era @@ -402,7 +402,6 @@ instance ( IsShelleyBasedEra era , ToJSON (Core.PParams ledgerera) , ToJSON (Core.PParamsUpdate ledgerera) , ToJSON (Core.TxOut ledgerera) - , Share (Core.TxOut (ShelleyLedgerEra era)) ~ Interns (Shelley.Credential 'Shelley.Staking (Ledger.Crypto (ShelleyLedgerEra era))) ) => ToJSON (DebugLedgerState era) where toJSON = object . toDebugLedgerStatePair toEncoding = Aeson.pairs . mconcat . toDebugLedgerStatePair @@ -410,9 +409,6 @@ instance ( IsShelleyBasedEra era toDebugLedgerStatePair :: ( ShelleyLedgerEra era ~ ledgerera , Consensus.ShelleyBasedEra ledgerera - , ToJSON (Core.PParams ledgerera) - , ToJSON (Core.PParamsUpdate ledgerera) - , ToJSON (Core.TxOut ledgerera) , Aeson.KeyValue a ) => DebugLedgerState era -> [a] toDebugLedgerStatePair (DebugLedgerState newEpochS) = @@ -438,7 +434,7 @@ decodeProtocolState :: FromCBOR (Consensus.ChainDepState (ConsensusProtocol era)) => ProtocolState era -> Either (LBS.ByteString, DecoderError) (Consensus.ChainDepState (ConsensusProtocol era)) -decodeProtocolState (ProtocolState (Serialised pbs)) = first (pbs,) $ decodeFull pbs +decodeProtocolState (ProtocolState (Serialised pbs)) = first (pbs,) $ Plain.decodeFull pbs newtype SerialisedCurrentEpochState era = SerialisedCurrentEpochState (Serialised (Shelley.EpochState (ShelleyLedgerEra era))) @@ -446,55 +442,56 @@ newtype SerialisedCurrentEpochState era newtype CurrentEpochState era = CurrentEpochState (Shelley.EpochState (ShelleyLedgerEra era)) decodeCurrentEpochState - :: forall era. ( Ledger.Era (ShelleyLedgerEra era) - , HashAnnotated (Core.TxBody (ShelleyLedgerEra era)) Core.EraIndependentTxBody (Ledger.Crypto (ShelleyLedgerEra era)) - ) - => FromSharedCBOR (Core.TxOut (ShelleyLedgerEra era)) - => Share (Core.TxOut (ShelleyLedgerEra era)) ~ Interns (Shelley.Credential 'Shelley.Staking (Ledger.Crypto (ShelleyLedgerEra era))) - => FromCBOR (Core.PParams (ShelleyLedgerEra era)) - => FromCBOR (Core.Value (ShelleyLedgerEra era)) - => FromCBOR (Ledger.State (Core.EraRule "PPUP" (ShelleyLedgerEra era))) + :: forall era. + ( Core.EraTxOut (ShelleyLedgerEra era) + , Core.EraGovernance (ShelleyLedgerEra era) + ) => SerialisedCurrentEpochState era -> Either DecoderError (CurrentEpochState era) -decodeCurrentEpochState (SerialisedCurrentEpochState (Serialised ls)) = CurrentEpochState <$> decodeFull ls +decodeCurrentEpochState (SerialisedCurrentEpochState (Serialised ls)) = + CurrentEpochState <$> Plain.decodeFull ls newtype SerialisedPoolState era - = SerialisedPoolState (Serialised (Shelley.PState (Ledger.Crypto (ShelleyLedgerEra era)))) + = SerialisedPoolState (Serialised (Shelley.PState (Core.EraCrypto (ShelleyLedgerEra era)))) -newtype PoolState era = PoolState (Shelley.PState (Ledger.Crypto (ShelleyLedgerEra era))) +newtype PoolState era = PoolState (Shelley.PState (Core.EraCrypto (ShelleyLedgerEra era))) decodePoolState :: forall era. () - => FromCBOR (Shelley.PState (Ledger.Crypto (ShelleyLedgerEra era))) + => Core.Era (ShelleyLedgerEra era) + => DecCBOR (Shelley.PState (Core.EraCrypto (ShelleyLedgerEra era))) => SerialisedPoolState era -> Either DecoderError (PoolState era) -decodePoolState (SerialisedPoolState (Serialised ls)) = PoolState <$> decodeFull ls +decodePoolState (SerialisedPoolState (Serialised ls)) = + PoolState <$> decodeFull (Core.eraProtVerLow @(ShelleyLedgerEra era)) ls newtype SerialisedPoolDistribution era - = SerialisedPoolDistribution (Serialised (Shelley.PoolDistr (Ledger.Crypto (ShelleyLedgerEra era)))) + = SerialisedPoolDistribution (Serialised (Shelley.PoolDistr (Core.EraCrypto (ShelleyLedgerEra era)))) newtype PoolDistribution era = PoolDistribution - { unPoolDistr :: Shelley.PoolDistr (Ledger.Crypto (ShelleyLedgerEra era)) + { unPoolDistr :: Shelley.PoolDistr (Core.EraCrypto (ShelleyLedgerEra era)) } decodePoolDistribution :: forall era. () - => FromCBOR (Shelley.PoolDistr (Ledger.Crypto (ShelleyLedgerEra era))) + => Core.Era (ShelleyLedgerEra era) + => DecCBOR (Shelley.PoolDistr (Core.EraCrypto (ShelleyLedgerEra era))) => SerialisedPoolDistribution era -> Either DecoderError (PoolDistribution era) -decodePoolDistribution (SerialisedPoolDistribution (Serialised ls)) = PoolDistribution <$> decodeFull ls +decodePoolDistribution (SerialisedPoolDistribution (Serialised ls)) = + PoolDistribution <$> decodeFull (Core.eraProtVerLow @(ShelleyLedgerEra era)) ls newtype SerialisedStakeSnapshots era - = SerialisedStakeSnapshots (Serialised (Consensus.StakeSnapshots (Ledger.Crypto (ShelleyLedgerEra era)))) + = SerialisedStakeSnapshots (Serialised (Consensus.StakeSnapshots (Core.EraCrypto (ShelleyLedgerEra era)))) -newtype StakeSnapshot era = StakeSnapshot (Consensus.StakeSnapshots (Ledger.Crypto (ShelleyLedgerEra era))) +newtype StakeSnapshot era = StakeSnapshot (Consensus.StakeSnapshots (Core.EraCrypto (ShelleyLedgerEra era))) decodeStakeSnapshot :: forall era. () - => FromCBOR (Consensus.StakeSnapshots (Ledger.Crypto (ShelleyLedgerEra era))) + => FromCBOR (Consensus.StakeSnapshots (Core.EraCrypto (ShelleyLedgerEra era))) => SerialisedStakeSnapshots era -> Either DecoderError (StakeSnapshot era) -decodeStakeSnapshot (SerialisedStakeSnapshots (Serialised ls)) = StakeSnapshot <$> decodeFull ls +decodeStakeSnapshot (SerialisedStakeSnapshots (Serialised ls)) = StakeSnapshot <$> Plain.decodeFull ls toShelleyAddrSet :: CardanoEra era -> Set AddressAny @@ -510,7 +507,7 @@ toShelleyAddrSet era = toLedgerUTxO :: ShelleyLedgerEra era ~ ledgerera - => Ledger.Crypto ledgerera ~ StandardCrypto + => Core.EraCrypto ledgerera ~ StandardCrypto => ShelleyBasedEra era -> UTxO era -> Shelley.UTxO ledgerera @@ -522,7 +519,7 @@ toLedgerUTxO era (UTxO utxo) = $ utxo fromLedgerUTxO :: ShelleyLedgerEra era ~ ledgerera - => Ledger.Crypto ledgerera ~ StandardCrypto + => Core.EraCrypto ledgerera ~ StandardCrypto => ShelleyBasedEra era -> Shelley.UTxO ledgerera -> UTxO era @@ -615,7 +612,7 @@ toConsensusQuery (QueryInEra erainmode (QueryInShelleyBasedEra era q)) = toConsensusQueryShelleyBased :: forall era ledgerera mode protocol block xs result. ConsensusBlockForEra era ~ Consensus.ShelleyBlock protocol ledgerera - => Ledger.Crypto ledgerera ~ Consensus.StandardCrypto + => Core.EraCrypto ledgerera ~ Consensus.StandardCrypto => ConsensusBlockForMode mode ~ block => block ~ Consensus.HardForkBlock xs => EraInMode era mode @@ -845,7 +842,7 @@ fromConsensusQueryResult (QueryInEra ConwayEraInCardanoMode fromConsensusQueryResultShelleyBased :: forall era ledgerera protocol result result'. ShelleyLedgerEra era ~ ledgerera - => Ledger.Crypto ledgerera ~ Consensus.StandardCrypto + => Core.EraCrypto ledgerera ~ Consensus.StandardCrypto => ConsensusProtocol era ~ protocol => ShelleyBasedEra era -> QueryInShelleyBasedEra era result From 65ce34019d38ee6e2998434ae4688ee939224c3a Mon Sep 17 00:00:00 2001 From: Alexey Kuleshevich Date: Fri, 10 Mar 2023 00:36:14 +0300 Subject: [PATCH 15/38] LedgerState is done --- cardano-api/src/Cardano/Api/LedgerState.hs | 58 +++++++++------------- 1 file changed, 23 insertions(+), 35 deletions(-) diff --git a/cardano-api/src/Cardano/Api/LedgerState.hs b/cardano-api/src/Cardano/Api/LedgerState.hs index 42cc636ac14..74157cca67f 100644 --- a/cardano-api/src/Cardano/Api/LedgerState.hs +++ b/cardano-api/src/Cardano/Api/LedgerState.hs @@ -62,7 +62,6 @@ import Control.Monad (when) import Control.Monad.Trans.Class import Control.Monad.Trans.Except import Control.Monad.Trans.Except.Extra (firstExceptT, handleIOExceptT, hoistEither, left) -import Control.State.Transition import Data.Aeson as Aeson import Data.Aeson.Types (Parser) import Data.Bifunctor @@ -77,7 +76,7 @@ import Data.Foldable import Data.IORef import Data.Map.Strict (Map) import qualified Data.Map.Strict as Map -import Data.Maybe (mapMaybe) +import Data.Maybe (fromMaybe, mapMaybe) import Data.Proxy (Proxy (Proxy)) import Data.Sequence (Seq) import qualified Data.Sequence as Seq @@ -92,7 +91,7 @@ import Data.Text.Lazy.Builder (toLazyText) import Data.Word import qualified Data.Yaml as Yaml import Formatting.Buildable (build) -import GHC.Records (HasField (..)) +import Lens.Micro ((^.)) import Network.TypedProtocol.Pipelined (Nat (..)) import System.FilePath @@ -114,7 +113,6 @@ import Cardano.Api.Query (CurrentEpochState (..), PoolDistribution (un ProtocolState, SerialisedCurrentEpochState (..), SerialisedPoolDistribution, decodeCurrentEpochState, decodePoolDistribution, decodeProtocolState) import Cardano.Api.Utils (textShow) -import Cardano.Binary (DecoderError, FromCBOR) import qualified Cardano.Chain.Genesis import qualified Cardano.Chain.Update import Cardano.Crypto (ProtocolMagicId (unProtocolMagicId), RequiresNetworkMagic (..)) @@ -125,18 +123,16 @@ import qualified Cardano.Crypto.ProtocolMagic import qualified Cardano.Crypto.VRF as Crypto import qualified Cardano.Crypto.VRF.Class as VRF import Cardano.Ledger.Alonzo.Genesis (AlonzoGenesis (..)) -import Cardano.Ledger.BaseTypes (Globals (..), Nonce, UnitInterval, (⭒)) +import Cardano.Ledger.BaseTypes (Globals (..), Nonce, (⭒)) import qualified Cardano.Ledger.BaseTypes as Ledger import qualified Cardano.Ledger.BHeaderView as Ledger -import qualified Cardano.Ledger.Conway.Genesis as Conway (ConwayGenesis (..)) -import qualified Cardano.Ledger.Core as Core +import Cardano.Ledger.Binary (DecCBOR, DecoderError, FromCBOR, mkVersion) import qualified Cardano.Ledger.Credential as Ledger -import qualified Cardano.Ledger.Era import qualified Cardano.Ledger.Keys as Ledger import qualified Cardano.Ledger.Keys as SL import qualified Cardano.Ledger.PoolDistr as SL -import Cardano.Ledger.SafeHash (HashAnnotated) import qualified Cardano.Ledger.Shelley.API as ShelleyAPI +import qualified Cardano.Ledger.Shelley.Core as Core import qualified Cardano.Ledger.Shelley.Genesis as Ledger import qualified Cardano.Protocol.TPraos.API as TPraos import Cardano.Protocol.TPraos.BHeader (checkLeaderNatValue) @@ -1052,7 +1048,6 @@ mkProtocolInfoCardano (GenesisCardano dnc byronGenesis shelleyGenesis alonzoGene (ncShelleyToAllegra dnc) (ncAllegraToMary dnc) (Consensus.ProtocolTransitionParamsShelleyBased alonzoGenesis (ncMaryToAlonzo dnc)) - -- (Consensus.ProtocolTransitionParamsShelleyBased alonzoGenesis (ncAlonzoToBabbage dnc)) (Consensus.ProtocolTransitionParamsShelleyBased () (ncAlonzoToBabbage dnc)) (Consensus.ProtocolTransitionParamsShelleyBased conwayGenesis (ncBabbageToConway dnc)) @@ -1061,10 +1056,11 @@ shelleyPraosNonce sCfg = Ledger.Nonce (Cardano.Crypto.Hash.Class.castHash . unGe shelleyProtVer :: NodeConfig -> Ledger.ProtVer shelleyProtVer dnc = - let bver = ncByronProtocolVersion dnc in - Ledger.ProtVer - (fromIntegral $ Cardano.Chain.Update.pvMajor bver) - (fromIntegral $ Cardano.Chain.Update.pvMinor bver) + let bver = ncByronProtocolVersion dnc + majVer = Cardano.Chain.Update.pvMajor bver + in Ledger.ProtVer + (fromMaybe (error $ "Invalid major version: " ++ show majVer) $ mkVersion majVer) + (fromIntegral $ Cardano.Chain.Update.pvMinor bver) readCardanoGenesisConfig :: NodeConfig @@ -1449,11 +1445,9 @@ instance Error LeadershipError where displayError LeaderErrCandidateNonceStillEvolving = "Candidate nonce is still evolving" nextEpochEligibleLeadershipSlots - :: forall era. - ( HasField "_d" (Core.PParams (ShelleyLedgerEra era)) UnitInterval - , HashAnnotated (Core.TxBody (ShelleyLedgerEra era)) Core.EraIndependentTxBody (Ledger.EraCrypto (ShelleyLedgerEra era)) - ) - => Ledger.Era (ShelleyLedgerEra era) + :: forall era. () + => Core.EraTxOut (ShelleyLedgerEra era) + => Core.EraGovernance (ShelleyLedgerEra era) => FromCBOR (Consensus.ChainDepState (Api.ConsensusProtocol era)) => Consensus.PraosProtocolSupportsNode (Api.ConsensusProtocol era) => ShelleyBasedEra era @@ -1525,8 +1519,9 @@ nextEpochEligibleLeadershipSlots sbe sGen serCurrEpochState ptclState poolid (Vr markSnapshotPoolDistr :: Map (SL.KeyHash 'SL.StakePool Shelley.StandardCrypto) (SL.IndividualPoolStake Shelley.StandardCrypto) markSnapshotPoolDistr = ShelleyAPI.unPoolDistr . ShelleyAPI.calculatePoolDistr $ snapshot - let slotRangeOfInterest = Set.filter - (not . Ledger.isOverlaySlot firstSlotOfEpoch (getField @"_d" (unbundleLedgerShelleyBasedProtocolParams sbe bpp))) + let pp = unbundleLedgerShelleyBasedProtocolParams pParams + slotRangeOfInterest = Set.filter + (not . Ledger.isOverlaySlot firstSlotOfEpoch (pp ^. Core.ppDG)) $ Set.fromList [firstSlotOfEpoch .. lastSlotofEpoch] case sbe of @@ -1605,7 +1600,7 @@ isLeadingSlotsPraos slotRangeOfInterest poolid snapshotPoolDistr eNonce vrfSkey obtainIsStandardCrypto :: ShelleyLedgerEra era ~ ledgerera => ShelleyBasedEra era - -> (Ledger.EraCrypto ledgerera ~ Shelley.StandardCrypto => a) + -> (Core.EraCrypto ledgerera ~ Shelley.StandardCrypto => a) -> a obtainIsStandardCrypto ShelleyBasedEraShelley f = f obtainIsStandardCrypto ShelleyBasedEraAllegra f = f @@ -1619,12 +1614,8 @@ obtainDecodeEpochStateConstraints :: ShelleyLedgerEra era ~ ledgerera => ShelleyBasedEra era -> (( FromCBOR (Core.PParams ledgerera) - , FromCBOR (State (Core.EraRule "PPUP" ledgerera)) - , FromCBOR (Core.Value ledgerera) - , HashAnnotated - (Core.TxBody ledgerera) - Core.EraIndependentTxBody - (Ledger.EraCrypto (ShelleyLedgerEra era)) + , FromCBOR (Core.GovernanceState ledgerera) + , DecCBOR (Core.Value ledgerera) ) => a) -> a obtainDecodeEpochStateConstraints ShelleyBasedEraShelley f = f obtainDecodeEpochStateConstraints ShelleyBasedEraAllegra f = f @@ -1637,13 +1628,9 @@ obtainDecodeEpochStateConstraints ShelleyBasedEraConway f = f -- expected to mint a block. currentEpochEligibleLeadershipSlots :: forall era ledgerera. () => ShelleyLedgerEra era ~ ledgerera - => Ledger.Era ledgerera + => Core.EraPParams ledgerera => Consensus.PraosProtocolSupportsNode (Api.ConsensusProtocol era) - => HasField "_d" (Core.PParams ledgerera) UnitInterval - -- => Crypto.Signable (Crypto.VRF (Ledger.EraCrypto ledgerera)) Ledger.Seed - -- => Ledger.EraCrypto ledgerera ~ Shelley.StandardCrypto => FromCBOR (Consensus.ChainDepState (Api.ConsensusProtocol era)) - -- => Consensus.ChainDepState (ConsensusProtocol era) ~ Consensus.ChainDepState (ConsensusProtocol era) => ShelleyBasedEra era -> ShelleyGenesis Shelley.StandardShelley -> EpochInfo (Either Text) @@ -1672,8 +1659,9 @@ currentEpochEligibleLeadershipSlots sbe sGen eInfo bpp ptclState poolid (VrfSign $ obtainDecodeEpochStateConstraints sbe $ decodePoolDistribution serPoolDistr - let slotRangeOfInterest = Set.filter - (not . Ledger.isOverlaySlot firstSlotOfEpoch (getField @"_d" (unbundleLedgerShelleyBasedProtocolParams sbe bpp))) + let pp = unbundleLedgerShelleyBasedProtocolParams sbe bpp + slotRangeOfInterest = Set.filter + (not . Ledger.isOverlaySlot firstSlotOfEpoch (pp ^. Core.ppDG)) $ Set.fromList [firstSlotOfEpoch .. lastSlotofEpoch] case sbe of From 440b0ef7ec7c019bde71465890d9399161bbb2f7 Mon Sep 17 00:00:00 2001 From: Alexey Kuleshevich Date: Fri, 10 Mar 2023 01:17:24 +0300 Subject: [PATCH 16/38] WIP fees --- cardano-api/src/Cardano/Api/Fees.hs | 40 ++++++++++------------ cardano-api/src/Cardano/Api/LedgerState.hs | 2 +- cardano-api/src/Cardano/Api/Script.hs | 13 +++---- 3 files changed, 27 insertions(+), 28 deletions(-) diff --git a/cardano-api/src/Cardano/Api/Fees.hs b/cardano-api/src/Cardano/Api/Fees.hs index e6208cb4a05..5e83abe9ae4 100644 --- a/cardano-api/src/Cardano/Api/Fees.hs +++ b/cardano-api/src/Cardano/Api/Fees.hs @@ -68,29 +68,27 @@ import qualified Cardano.Ledger.Coin as Ledger import Cardano.Ledger.Core (EraTx (sizeTxF)) import qualified Cardano.Ledger.Core as Ledger import qualified Cardano.Ledger.Crypto as Ledger -import qualified Cardano.Ledger.Era as Ledger.Era (Crypto) + import qualified Cardano.Ledger.Keys as Ledger import Cardano.Ledger.Mary.Value (MaryValue) -import qualified Cardano.Ledger.Shelley.API as Ledger (CLI) import qualified Cardano.Ledger.Shelley.API.Wallet as Ledger (evaluateTransactionBalance, evaluateTransactionFee) import qualified Cardano.Ledger.Shelley.API.Wallet as Shelley -import Cardano.Ledger.Shelley.PParams (ShelleyPParamsHKD (..)) import Cardano.Ledger.Shelley.TxBody (ShelleyEraTxBody) import qualified Cardano.Ledger.Alonzo as Alonzo import qualified Cardano.Ledger.Alonzo.Language as Alonzo -import Cardano.Ledger.Alonzo.PParams (AlonzoPParamsHKD (..)) import qualified Cardano.Ledger.Alonzo.Scripts as Alonzo +import qualified Cardano.Ledger.Alonzo.Scripts as L import qualified Cardano.Ledger.Alonzo.Tools as Alonzo import qualified Cardano.Ledger.Alonzo.Tx as Alonzo import qualified Cardano.Ledger.Alonzo.TxInfo as Alonzo -import qualified Cardano.Ledger.Alonzo.TxWitness as Alonzo +import qualified Cardano.Ledger.Alonzo.TxWits as Alonzo +import qualified Cardano.Ledger.Api.Scripts as L import qualified Cardano.Ledger.Babbage as Babbage -import Cardano.Ledger.Babbage.PParams (BabbagePParamsHKD (..)) import qualified Cardano.Ledger.Conway as Conway import qualified Ouroboros.Consensus.HardFork.History as Consensus @@ -253,8 +251,8 @@ evaluateTransactionFee bpparams txbody keywitcount _byronwitcount = where evalShelleyBasedEra :: forall ledgerera. ShelleyLedgerEra era ~ ledgerera - => Ledger.CLI ledgerera - => Ledger.Tx ledgerera + => ShelleyBasedEra era + -> Ledger.Tx ledgerera -> Lovelace evalShelleyBasedEra tx = fromShelleyLovelace $ @@ -267,7 +265,7 @@ evaluateTransactionFee bpparams txbody keywitcount _byronwitcount = withLedgerConstraints :: ShelleyLedgerEra era ~ ledgerera => ShelleyBasedEra era - -> ( Ledger.CLI ledgerera + -> ( () -- Ledger.CLI ledgerera => a) -> a withLedgerConstraints ShelleyBasedEraShelley f = f @@ -630,30 +628,30 @@ evaluateTransactionExecutionUnits systemstart epochInfo bpp utxo txbody = -> ScriptExecutionError fromAlonzoScriptExecutionError failure = case failure of - Alonzo.UnknownTxIn txin -> ScriptErrorMissingTxIn txin' + L.UnknownTxIn txin -> ScriptErrorMissingTxIn txin' where txin' = fromShelleyTxIn txin - Alonzo.InvalidTxIn txin -> ScriptErrorTxInWithoutDatum txin' + L.InvalidTxIn txin -> ScriptErrorTxInWithoutDatum txin' where txin' = fromShelleyTxIn txin - Alonzo.MissingDatum dh -> ScriptErrorWrongDatum (ScriptDataHash dh) - Alonzo.ValidationFailedV1 err logs -> ScriptErrorEvaluationFailed err logs - Alonzo.ValidationFailedV2 err logs -> ScriptErrorEvaluationFailed err logs - Alonzo.IncompatibleBudget _ -> ScriptErrorExecutionUnitsOverflow + L.MissingDatum dh -> ScriptErrorWrongDatum (ScriptDataHash dh) + L.ValidationFailedV1 err logs -> ScriptErrorEvaluationFailed err logs + L.ValidationFailedV2 err logs -> ScriptErrorEvaluationFailed err logs + L.IncompatibleBudget _ -> ScriptErrorExecutionUnitsOverflow -- This is only possible for spending scripts and occurs when -- we attempt to spend a key witnessed tx input with a Plutus -- script witness. - Alonzo.RedeemerNotNeeded rdmrPtr scriptHash -> + L.RedeemerNotNeeded rdmrPtr scriptHash -> ScriptErrorNotPlutusWitnessedTxIn (fromAlonzoRdmrPtr rdmrPtr) (fromShelleyScriptHash scriptHash) - Alonzo.RedeemerPointsToUnknownScriptHash rdmrPtr -> + L.RedeemerPointsToUnknownScriptHash rdmrPtr -> ScriptErrorRedeemerPointsToUnknownScriptHash $ fromAlonzoRdmrPtr rdmrPtr -- This should not occur while using cardano-cli because we zip together -- the Plutus script and the use site (txin, certificate etc). Therefore -- the redeemer pointer will always point to a Plutus script. - Alonzo.MissingScript rdmrPtr resolveable -> ScriptErrorMissingScript rdmrPtr resolveable + L.MissingScript rdmrPtr resolveable -> ScriptErrorMissingScript rdmrPtr resolveable - Alonzo.NoCostModelInLedgerState l -> ScriptErrorMissingCostModel l + L.NoCostModelInLedgerState l -> ScriptErrorMissingCostModel l obtainHasFieldConstraint @@ -762,8 +760,8 @@ evaluateTransactionBalance bpp poolids utxo withLedgerConstraints ShelleyBasedEraConway _ f = f MultiAssetInConwayEra type LedgerEraConstraints ledgerera = - ( Ledger.Era.Crypto ledgerera ~ Ledger.StandardCrypto - , Ledger.CLI ledgerera + ( Ledger.EraCrypto ledgerera ~ Ledger.StandardCrypto + -- , Ledger.CLI ledgerera ) type LedgerAdaOnlyConstraints ledgerera = diff --git a/cardano-api/src/Cardano/Api/LedgerState.hs b/cardano-api/src/Cardano/Api/LedgerState.hs index 74157cca67f..68ab0e055a5 100644 --- a/cardano-api/src/Cardano/Api/LedgerState.hs +++ b/cardano-api/src/Cardano/Api/LedgerState.hs @@ -1519,7 +1519,7 @@ nextEpochEligibleLeadershipSlots sbe sGen serCurrEpochState ptclState poolid (Vr markSnapshotPoolDistr :: Map (SL.KeyHash 'SL.StakePool Shelley.StandardCrypto) (SL.IndividualPoolStake Shelley.StandardCrypto) markSnapshotPoolDistr = ShelleyAPI.unPoolDistr . ShelleyAPI.calculatePoolDistr $ snapshot - let pp = unbundleLedgerShelleyBasedProtocolParams pParams + let pp = unbundleLedgerShelleyBasedProtocolParams sbe bpp slotRangeOfInterest = Set.filter (not . Ledger.isOverlaySlot firstSlotOfEpoch (pp ^. Core.ppDG)) $ Set.fromList [firstSlotOfEpoch .. lastSlotofEpoch] diff --git a/cardano-api/src/Cardano/Api/Script.hs b/cardano-api/src/Cardano/Api/Script.hs index 7380879e8a8..1017853ed41 100644 --- a/cardano-api/src/Cardano/Api/Script.hs +++ b/cardano-api/src/Cardano/Api/Script.hs @@ -147,7 +147,7 @@ import Ouroboros.Consensus.Shelley.Eras (StandardCrypto) import qualified Cardano.Ledger.Alonzo.Language as Alonzo import qualified Cardano.Ledger.Alonzo.Scripts as Alonzo -import qualified Cardano.Ledger.Binary as Binary (decCBOR, decodeFullAnnotator, shelleyProtVer) +import qualified Cardano.Ledger.Binary as Binary (decCBOR, decodeFullAnnotator) import qualified PlutusLedgerApi.Test.Examples as Plutus @@ -398,7 +398,7 @@ instance HasTypeProxy lang => HasTypeProxy (Script lang) where instance IsScriptLanguage lang => SerialiseAsCBOR (Script lang) where serialiseToCBOR (SimpleScript s) = - CBOR.serialize' (toAllegraTimelock s :: Timelock.Timelock StandardCrypto) + CBOR.serialize' (toAllegraTimelock s :: Timelock.Timelock (ShelleyLedgerEra AllegraEra)) serialiseToCBOR (PlutusScript PlutusScriptV1 s) = CBOR.serialize' s @@ -409,8 +409,9 @@ instance IsScriptLanguage lang => SerialiseAsCBOR (Script lang) where deserialiseFromCBOR _ bs = case scriptLanguage :: ScriptLanguage lang of SimpleScriptLanguage -> - SimpleScript . fromAllegraTimelock - <$> CBOR.decodeAnnotator "Script" fromCBOR (LBS.fromStrict bs) + let version = Ledger.eraProtVerLow @(ShelleyLedgerEra AllegraEra) + in SimpleScript . fromAllegraTimelock @(ShelleyLedgerEra AllegraEra) + <$> Binary.decodeFullAnnotator version "Script" Binary.decCBOR (LBS.fromStrict bs) PlutusScriptLanguage PlutusScriptV1 -> PlutusScript PlutusScriptV1 @@ -912,7 +913,7 @@ hashScript (SimpleScript s) = -- Later ledger eras have to be compatible anyway. ScriptHash . Ledger.hashScript @(ShelleyLedgerEra AllegraEra) - . (toAllegraTimelock :: SimpleScript -> Timelock.Timelock StandardCrypto) + . (toAllegraTimelock :: SimpleScript -> Timelock.Timelock (ShelleyLedgerEra AllegraEra)) $ s hashScript (PlutusScript PlutusScriptV1 (PlutusScriptSerialised script)) = @@ -1138,7 +1139,7 @@ fromShelleyMultiSig = go -- | Conversion for the 'Timelock.Timelock' language that is shared between the -- Allegra and Mary eras. -- -toAllegraTimelock :: forall era lang. +toAllegraTimelock :: forall era. (Era era, EraCrypto era ~ StandardCrypto) => SimpleScript -> Timelock.Timelock era toAllegraTimelock = go From be73fc01873cc58a0c075832daabb68910cc8bca Mon Sep 17 00:00:00 2001 From: Alexey Kuleshevich Date: Fri, 10 Mar 2023 01:24:28 +0300 Subject: [PATCH 17/38] cabal.project: update ledger --- cabal.project | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/cabal.project b/cabal.project index 47ef2f63686..9487bf69bc6 100644 --- a/cabal.project +++ b/cabal.project @@ -140,8 +140,8 @@ source-repository-package source-repository-package type: git location: https://github.com/input-output-hk/cardano-ledger - tag: c15a020ce254967779ce6d6a3b6bc7745c47d90c - --sha256: 0c2yrlbf3sw3xm08hq8h4zbvk8cia6dzd92pdx6a7ff777y4iy6a + tag: 39d83188c872a51825bdad0875920bca78513024 + --sha256: 1q682fcqd20sdc4lwqjhcqi7fvlx5b5xrl9v39vim7mvrykskgd9 subdir: eras/alonzo/impl eras/alonzo/test-suite From d8a875f4051b03e60bef6e2e450c43f9dca81814 Mon Sep 17 00:00:00 2001 From: Alexey Kuleshevich Date: Wed, 15 Mar 2023 01:10:54 +0300 Subject: [PATCH 18/38] Fees are building --- cardano-api/src/Cardano/Api/Fees.hs | 142 +++++++----------- .../src/Cardano/Api/ProtocolParameters.hs | 2 +- 2 files changed, 58 insertions(+), 86 deletions(-) diff --git a/cardano-api/src/Cardano/Api/Fees.hs b/cardano-api/src/Cardano/Api/Fees.hs index 5e83abe9ae4..005613b5a1a 100644 --- a/cardano-api/src/Cardano/Api/Fees.hs +++ b/cardano-api/src/Cardano/Api/Fees.hs @@ -51,45 +51,37 @@ import qualified Data.Map.Strict as Map import Data.Maybe (catMaybes, fromMaybe, maybeToList) import Data.Ratio import Data.Set (Set) -import qualified Data.Set as Set import qualified Data.Text as Text -import GHC.Records (HasField (..)) import Lens.Micro ((^.)) import Numeric.Natural import Prettyprinter import Prettyprinter.Render.String import qualified Cardano.Binary as CBOR -import qualified Cardano.Ledger.BaseTypes as Ledger import qualified Cardano.Chain.Common as Byron import qualified Cardano.Ledger.Coin as Ledger import Cardano.Ledger.Core (EraTx (sizeTxF)) -import qualified Cardano.Ledger.Core as Ledger import qualified Cardano.Ledger.Crypto as Ledger - -import qualified Cardano.Ledger.Keys as Ledger +import Cardano.Ledger.UTxO as Ledger (EraUTxO) import Cardano.Ledger.Mary.Value (MaryValue) import qualified Cardano.Ledger.Shelley.API.Wallet as Ledger (evaluateTransactionBalance, evaluateTransactionFee) -import qualified Cardano.Ledger.Shelley.API.Wallet as Shelley import Cardano.Ledger.Shelley.TxBody (ShelleyEraTxBody) -import qualified Cardano.Ledger.Alonzo as Alonzo import qualified Cardano.Ledger.Alonzo.Language as Alonzo import qualified Cardano.Ledger.Alonzo.Scripts as Alonzo import qualified Cardano.Ledger.Alonzo.Scripts as L -import qualified Cardano.Ledger.Alonzo.Tools as Alonzo import qualified Cardano.Ledger.Alonzo.Tx as Alonzo import qualified Cardano.Ledger.Alonzo.TxInfo as Alonzo import qualified Cardano.Ledger.Alonzo.TxWits as Alonzo -import qualified Cardano.Ledger.Api.Scripts as L +import qualified Cardano.Ledger.Api as L -import qualified Cardano.Ledger.Babbage as Babbage import qualified Cardano.Ledger.Conway as Conway +import qualified Cardano.Ledger.Conway.Core as Ledger import qualified Ouroboros.Consensus.HardFork.History as Consensus @@ -129,23 +121,22 @@ transactionFee txFeeFixed txFeePerByte tx = let a = toInteger txFeePerByte b = toInteger txFeeFixed in case tx of - ShelleyTx _ tx' -> let x = obtainHasField shelleyBasedEra $ tx' ^. sizeTxF + ShelleyTx _ tx' -> let x = obtainEraTx shelleyBasedEra $ tx' ^. sizeTxF in Lovelace (a * x + b) --TODO: This can be made to work for Byron txs too. Do that: fill in this case -- and remove the IsShelleyBasedEra constraint. ByronTx _ -> case shelleyBasedEra :: ShelleyBasedEra ByronEra of {} where - obtainHasField + obtainEraTx :: ShelleyBasedEra era - -> ( EraTx (ShelleyLedgerEra era) - => a) + -> (EraTx (ShelleyLedgerEra era) => a) -> a - obtainHasField ShelleyBasedEraShelley f = f - obtainHasField ShelleyBasedEraAllegra f = f - obtainHasField ShelleyBasedEraMary f = f - obtainHasField ShelleyBasedEraAlonzo f = f - obtainHasField ShelleyBasedEraBabbage f = f - obtainHasField ShelleyBasedEraConway f = f + obtainEraTx ShelleyBasedEraShelley f = f + obtainEraTx ShelleyBasedEraAllegra f = f + obtainEraTx ShelleyBasedEraMary f = f + obtainEraTx ShelleyBasedEraAlonzo f = f + obtainEraTx ShelleyBasedEraBabbage f = f + obtainEraTx ShelleyBasedEraConway f = f {-# DEPRECATED transactionFee "Use 'evaluateTransactionFee' instead" #-} @@ -251,8 +242,8 @@ evaluateTransactionFee bpparams txbody keywitcount _byronwitcount = where evalShelleyBasedEra :: forall ledgerera. ShelleyLedgerEra era ~ ledgerera - => ShelleyBasedEra era - -> Ledger.Tx ledgerera + => EraTx ledgerera + => Ledger.Tx ledgerera -> Lovelace evalShelleyBasedEra tx = fromShelleyLovelace $ @@ -265,8 +256,7 @@ evaluateTransactionFee bpparams txbody keywitcount _byronwitcount = withLedgerConstraints :: ShelleyLedgerEra era ~ ledgerera => ShelleyBasedEra era - -> ( () -- Ledger.CLI ledgerera - => a) + -> (EraTx ledgerera => a) -> a withLedgerConstraints ShelleyBasedEraShelley f = f withLedgerConstraints ShelleyBasedEraAllegra f = f @@ -519,15 +509,11 @@ evaluateTransactionExecutionUnits systemstart epochInfo bpp utxo txbody = ShelleyBasedEraAlonzo -> evalAlonzo sbe tx' ShelleyBasedEraBabbage -> case collateralSupportedInEra $ shelleyBasedToCardanoEra sbe of - Just supp -> obtainHasFieldConstraint supp $ evalBabbage sbe tx' + Just supp -> obtainBabbageEraPParams supp $ evalBabbage sbe tx' Nothing -> return mempty ShelleyBasedEraConway -> case collateralSupportedInEra $ shelleyBasedToCardanoEra sbe of - Just supp -> obtainHasFieldConstraint supp $ evalConway sbe tx' - Nothing -> return mempty - ShelleyBasedEraConway -> - case collateralSupportedInEra $ shelleyBasedToCardanoEra era of - Just supp -> obtainHasFieldConstraint supp $ evalConway era tx' + Just supp -> obtainBabbageEraPParams supp $ evalConway sbe tx' Nothing -> return mempty where LedgerEpochInfo ledgerEpochInfo = epochInfo @@ -539,20 +525,15 @@ evaluateTransactionExecutionUnits systemstart epochInfo bpp utxo txbody = evalPreAlonzo = Right Map.empty - evalAlonzo :: forall ledgerera. - ShelleyLedgerEra era ~ ledgerera - => ledgerera ~ Alonzo.AlonzoEra Ledger.StandardCrypto - => HasField "_maxTxExUnits" (Ledger.PParams ledgerera) Alonzo.ExUnits - => HasField"_protocolVersion" (Ledger.PParams ledgerera) Ledger.ProtVer - => LedgerEraConstraints ledgerera + evalAlonzo :: ShelleyLedgerEra era ~ L.Alonzo => ShelleyBasedEra era - -> Ledger.Tx ledgerera + -> Ledger.Tx L.Alonzo -> Either TransactionValidityError (Map ScriptWitnessIndex (Either ScriptExecutionError ExecutionUnits)) evalAlonzo era tx = do - cModelArray <- toAlonzoCostModelsArray (protocolParamCostModels (unbundleProtocolParams bpp)) - case Alonzo.evaluateTransactionExecutionUnits + cModelArray <- toAlonzoCostModelsArray (protocolParamCostModels (unbundleProtocolParams bpp)) + case L.evaluateTransactionExecutionUnits (unbundleLedgerShelleyBasedProtocolParams era bpp) tx (toLedgerUTxO era utxo) @@ -562,19 +543,16 @@ evaluateTransactionExecutionUnits systemstart epochInfo bpp utxo txbody = of Left err -> Left (TransactionValidityTranslationError err) Right exmap -> Right (fromLedgerScriptExUnitsMap exmap) - evalBabbage :: forall ledgerera. - ShelleyLedgerEra era ~ ledgerera - => ledgerera ~ Babbage.BabbageEra Ledger.StandardCrypto - => HasField "_maxTxExUnits" (Ledger.PParams ledgerera) Alonzo.ExUnits - => HasField"_protocolVersion" (Ledger.PParams ledgerera) Ledger.ProtVer - => ShelleyBasedEra era - -> Ledger.Tx ledgerera - -> Either TransactionValidityError - (Map ScriptWitnessIndex - (Either ScriptExecutionError ExecutionUnits)) + evalBabbage :: ShelleyLedgerEra era ~ L.Babbage + => Ledger.EraPParams L.Babbage + => ShelleyBasedEra era + -> Ledger.Tx L.Babbage + -> Either TransactionValidityError + (Map ScriptWitnessIndex + (Either ScriptExecutionError ExecutionUnits)) evalBabbage era tx = do costModelsArray <- toAlonzoCostModelsArray (protocolParamCostModels (unbundleProtocolParams bpp)) - case Alonzo.evaluateTransactionExecutionUnits + case L.evaluateTransactionExecutionUnits (unbundleLedgerShelleyBasedProtocolParams era bpp) tx (toLedgerUTxO era utxo) @@ -587,17 +565,16 @@ evaluateTransactionExecutionUnits systemstart epochInfo bpp utxo txbody = evalConway :: forall ledgerera. ShelleyLedgerEra era ~ ledgerera => ledgerera ~ Conway.ConwayEra Ledger.StandardCrypto - => HasField "_maxTxExUnits" (Ledger.PParams ledgerera) Alonzo.ExUnits - => HasField"_protocolVersion" (Ledger.PParams ledgerera) Ledger.ProtVer + => Ledger.AlonzoEraPParams ledgerera => ShelleyBasedEra era -> Ledger.Tx ledgerera -> Either TransactionValidityError (Map ScriptWitnessIndex (Either ScriptExecutionError ExecutionUnits)) evalConway era tx = do - costModelsArray <- toAlonzoCostModelsArray (protocolParamCostModels pparams) - case Alonzo.evaluateTransactionExecutionUnits - (toLedgerPParams era pparams) + costModelsArray <- toAlonzoCostModelsArray (protocolParamCostModels (unbundleProtocolParams bpp)) + case L.evaluateTransactionExecutionUnits + (unbundleLedgerShelleyBasedProtocolParams era bpp) tx (toLedgerUTxO era utxo) ledgerEpochInfo @@ -611,11 +588,12 @@ evaluateTransactionExecutionUnits systemstart epochInfo bpp utxo txbody = :: Map AnyPlutusScriptVersion CostModel -> Either TransactionValidityError (Array.Array Alonzo.Language Alonzo.CostModel) toAlonzoCostModelsArray costmodels = do - Alonzo.CostModels cModels <- first (TransactionValidityCostModelError costmodels) $ toAlonzoCostModels costmodels + L.CostModels cModels _ _ <- + first (TransactionValidityCostModelError costmodels) $ toAlonzoCostModels costmodels return $ Array.array (minBound, maxBound) (Map.toList cModels) fromLedgerScriptExUnitsMap - :: Map Alonzo.RdmrPtr (Either (Alonzo.TransactionScriptFailure Ledger.StandardCrypto) + :: Map Alonzo.RdmrPtr (Either (L.TransactionScriptFailure Ledger.StandardCrypto) Alonzo.ExUnits) -> Map ScriptWitnessIndex (Either ScriptExecutionError ExecutionUnits) fromLedgerScriptExUnitsMap exmap = @@ -624,7 +602,7 @@ evaluateTransactionExecutionUnits systemstart epochInfo bpp utxo txbody = bimap fromAlonzoScriptExecutionError fromAlonzoExUnits exunitsOrFailure) | (rdmrptr, exunitsOrFailure) <- Map.toList exmap ] - fromAlonzoScriptExecutionError :: Alonzo.TransactionScriptFailure Ledger.StandardCrypto + fromAlonzoScriptExecutionError :: L.TransactionScriptFailure Ledger.StandardCrypto -> ScriptExecutionError fromAlonzoScriptExecutionError failure = case failure of @@ -633,8 +611,10 @@ evaluateTransactionExecutionUnits systemstart epochInfo bpp utxo txbody = L.InvalidTxIn txin -> ScriptErrorTxInWithoutDatum txin' where txin' = fromShelleyTxIn txin L.MissingDatum dh -> ScriptErrorWrongDatum (ScriptDataHash dh) - L.ValidationFailedV1 err logs -> ScriptErrorEvaluationFailed err logs - L.ValidationFailedV2 err logs -> ScriptErrorEvaluationFailed err logs + L.ValidationFailure (L.ValidationFailedV1 err logs _) -> + ScriptErrorEvaluationFailed err logs + L.ValidationFailure (L.ValidationFailedV2 err logs _) -> + ScriptErrorEvaluationFailed err logs L.IncompatibleBudget _ -> ScriptErrorExecutionUnitsOverflow -- This is only possible for spending scripts and occurs when @@ -654,13 +634,13 @@ evaluateTransactionExecutionUnits systemstart epochInfo bpp utxo txbody = L.NoCostModelInLedgerState l -> ScriptErrorMissingCostModel l - obtainHasFieldConstraint + obtainBabbageEraPParams :: ShelleyLedgerEra era ~ ledgerera => CollateralSupportedInEra era - -> (HasField "_maxTxExUnits" (Ledger.PParams ledgerera) Alonzo.ExUnits => a) -> a - obtainHasFieldConstraint CollateralInAlonzoEra f = f - obtainHasFieldConstraint CollateralInBabbageEra f = f - obtainHasFieldConstraint CollateralInConwayEra f = f + -> (Ledger.EraPParams ledgerera => a) -> a + obtainBabbageEraPParams CollateralInAlonzoEra f = f + obtainBabbageEraPParams CollateralInBabbageEra f = f + obtainBabbageEraPParams CollateralInConwayEra f = f -- ---------------------------------------------------------------------------- -- Transaction balance @@ -702,8 +682,7 @@ evaluateTransactionBalance bpp poolids utxo getShelleyEraTxBodyConstraint ShelleyBasedEraBabbage x = x getShelleyEraTxBodyConstraint ShelleyBasedEraConway x = x - isNewPool :: Ledger.KeyHash Ledger.StakePool Ledger.StandardCrypto -> Bool - isNewPool kh = StakePoolKeyHash kh `Set.notMember` poolids + dpstate = error "Unimplemented. Requires a new Query" evalMultiAsset :: forall ledgerera. ShelleyLedgerEra era ~ ledgerera @@ -716,8 +695,8 @@ evaluateTransactionBalance bpp poolids utxo TxOutValue evidence . fromMaryValue $ Ledger.evaluateTransactionBalance (unbundleLedgerShelleyBasedProtocolParams era bpp) + dpstate (toLedgerUTxO era utxo) - isNewPool txbody evalAdaOnly :: forall ledgerera. @@ -731,8 +710,8 @@ evaluateTransactionBalance bpp poolids utxo TxOutAdaOnly evidence . fromShelleyLovelace $ Ledger.evaluateTransactionBalance (unbundleLedgerShelleyBasedProtocolParams era bpp) + dpstate (toLedgerUTxO era utxo) - isNewPool txbody -- Conjur up all the necessary class instances and evidence @@ -761,7 +740,7 @@ evaluateTransactionBalance bpp poolids utxo type LedgerEraConstraints ledgerera = ( Ledger.EraCrypto ledgerera ~ Ledger.StandardCrypto - -- , Ledger.CLI ledgerera + , Ledger.EraUTxO ledgerera ) type LedgerAdaOnlyConstraints ledgerera = @@ -772,11 +751,7 @@ type LedgerMultiAssetConstraints ledgerera = ) type LedgerPParamsConstraints ledgerera = - ( HasField "_minfeeA" (Ledger.PParams ledgerera) Natural - , HasField "_minfeeB" (Ledger.PParams ledgerera) Natural - , HasField "_keyDeposit" (Ledger.PParams ledgerera) Ledger.Coin - , HasField "_poolDeposit" (Ledger.PParams ledgerera) Ledger.Coin - ) + Ledger.EraPParams ledgerera type LedgerTxBodyConstraints ledgerera = ( Ledger.EraTx ledgerera @@ -1363,23 +1338,20 @@ calculateMinimumUTxO era txout@(TxOut _ v _ _) bpp = ShelleyBasedEraMary -> calcMinUTxOAllegraMary ShelleyBasedEraAlonzo -> let lTxOut = toShelleyTxOutAny era txout - minUTxO = Shelley.evaluateMinLovelaceOutput (unbundleLedgerShelleyBasedProtocolParams era bpp) lTxOut + babPParams = unbundleLedgerShelleyBasedProtocolParams era bpp + minUTxO = L.getMinCoinTxOut babPParams lTxOut val = fromShelleyLovelace minUTxO in Right val ShelleyBasedEraBabbage -> let lTxOut = toShelleyTxOutAny era txout - minUTxO = Shelley.evaluateMinLovelaceOutput (unbundleLedgerShelleyBasedProtocolParams era bpp) lTxOut - val = fromShelleyLovelace minUTxO - in Right val - ShelleyBasedEraConway -> - let lTxOut = toShelleyTxOutAny era txout - minUTxO = Shelley.evaluateMinLovelaceOutput (unbundleLedgerShelleyBasedProtocolParams era bpp) lTxOut + babPParams = unbundleLedgerShelleyBasedProtocolParams era bpp + minUTxO = L.getMinCoinTxOut babPParams lTxOut val = fromShelleyLovelace minUTxO in Right val ShelleyBasedEraConway -> let lTxOut = toShelleyTxOutAny era txout - babPParams = toConwayPParams pparams' - minUTxO = Shelley.evaluateMinLovelaceOutput babPParams lTxOut + babPParams = unbundleLedgerShelleyBasedProtocolParams era bpp + minUTxO = L.getMinCoinTxOut babPParams lTxOut val = fromShelleyLovelace minUTxO in Right val where diff --git a/cardano-api/src/Cardano/Api/ProtocolParameters.hs b/cardano-api/src/Cardano/Api/ProtocolParameters.hs index b592f3b61d0..a09e7b3f827 100644 --- a/cardano-api/src/Cardano/Api/ProtocolParameters.hs +++ b/cardano-api/src/Cardano/Api/ProtocolParameters.hs @@ -775,7 +775,7 @@ fromAlonzoPrices Alonzo.Prices{Alonzo.prSteps, Alonzo.prMem} = -- Script cost models -- -newtype CostModel = CostModel [Integer] --(Map Text Integer) +newtype CostModel = CostModel [Integer] --TODO: decide if we need a Map or a list: (Map Text Integer) deriving (Eq, Show) deriving newtype (ToJSON, FromJSON) deriving newtype (ToCBOR, FromCBOR) From c4684461120b81d8d229092cfb99f9ea88600475 Mon Sep 17 00:00:00 2001 From: Alexey Kuleshevich Date: Wed, 15 Mar 2023 01:11:12 +0300 Subject: [PATCH 19/38] Fees are building --- cardano-api/src/Cardano/Api.hs | 1 - 1 file changed, 1 deletion(-) diff --git a/cardano-api/src/Cardano/Api.hs b/cardano-api/src/Cardano/Api.hs index 2b7fbb61e96..35b783131be 100644 --- a/cardano-api/src/Cardano/Api.hs +++ b/cardano-api/src/Cardano/Api.hs @@ -421,7 +421,6 @@ module Cardano.Api ( ExecutionUnits(..), ExecutionUnitPrices(..), CostModel(..), - validateCostModel, -- ** Script addresses -- | Making addresses from scripts. From 37e62e398bcb04b4747fb6cadeb37df33dbb234a Mon Sep 17 00:00:00 2001 From: Alexey Kuleshevich Date: Wed, 15 Mar 2023 01:13:14 +0300 Subject: [PATCH 20/38] api lib is building --- cardano-api/src/Cardano/Api/Shelley.hs | 1 - 1 file changed, 1 deletion(-) diff --git a/cardano-api/src/Cardano/Api/Shelley.hs b/cardano-api/src/Cardano/Api/Shelley.hs index c77df8331fb..6a550e426f1 100644 --- a/cardano-api/src/Cardano/Api/Shelley.hs +++ b/cardano-api/src/Cardano/Api/Shelley.hs @@ -240,7 +240,6 @@ module Cardano.Api.Shelley fromAlonzoCostModels, --TODO: arrange not to export these toShelleyNetwork, - fromShelleyPParams, ) where From d16e8cf0bdc6627c4f39bef04ed6d3d088b04c80 Mon Sep 17 00:00:00 2001 From: Alexey Kuleshevich Date: Wed, 15 Mar 2023 01:22:28 +0300 Subject: [PATCH 21/38] Generators are building --- cardano-api/gen/Test/Gen/Cardano/Api.hs | 28 +++++++++++-------- cardano-api/gen/Test/Gen/Cardano/Api/Typed.hs | 8 +++--- 2 files changed, 20 insertions(+), 16 deletions(-) diff --git a/cardano-api/gen/Test/Gen/Cardano/Api.hs b/cardano-api/gen/Test/Gen/Cardano/Api.hs index a018368de2a..abd8b557c9e 100644 --- a/cardano-api/gen/Test/Gen/Cardano/Api.hs +++ b/cardano-api/gen/Test/Gen/Cardano/Api.hs @@ -21,18 +21,19 @@ import qualified Cardano.Ledger.Alonzo.Language as Alonzo import qualified Cardano.Ledger.Alonzo.Scripts as Alonzo import qualified Cardano.Ledger.BaseTypes as Ledger import qualified Cardano.Ledger.Coin as Ledger -import Cardano.Ledger.Shelley.Metadata (Metadata (..), Metadatum (..)) +import qualified Cardano.Ledger.Alonzo.Core as Ledger +import Cardano.Ledger.Shelley.TxAuxData (ShelleyTxAuxData (..), Metadatum (..)) import Hedgehog (Gen, Range) import qualified Hedgehog.Gen as Gen import qualified Hedgehog.Internal.Range as Range -genMetadata :: Gen (Metadata era) +genMetadata :: Ledger.Era era => Gen (ShelleyTxAuxData era) genMetadata = do numberOfIndices <- Gen.integral (Range.linear 1 15) let indices = map (\i -> fromIntegral i :: Word64) [1..numberOfIndices] mData <- Gen.list (Range.singleton numberOfIndices) genMetadatum - return . Metadata . Map.fromList $ zip indices mData + return . ShelleyTxAuxData . Map.fromList $ zip indices mData genMetadatum :: Gen Metadatum genMetadatum = do @@ -91,7 +92,10 @@ genCostModels = do case Alonzo.mkCostModel lang cModel of Left err -> error $ "genCostModels: " <> show err Right alonzoCostModel -> - Alonzo.CostModels . conv <$> Gen.list (Range.linear 1 3) (return alonzoCostModel) + Alonzo.CostModels + <$> (conv <$> Gen.list (Range.linear 1 3) (return alonzoCostModel)) + <*> pure mempty + <*> pure mempty where conv :: [Alonzo.CostModel] -> Map.Map Alonzo.Language Alonzo.CostModel conv [] = mempty @@ -110,12 +114,12 @@ genAlonzoGenesis = do maxCollateralInputs' <- Gen.integral (Range.linear 0 10) return Alonzo.AlonzoGenesis - { Alonzo.coinsPerUTxOWord = coinsPerUTxOWord - , Alonzo.costmdls = Alonzo.CostModels mempty - , Alonzo.prices = prices' - , Alonzo.maxTxExUnits = maxTxExUnits' - , Alonzo.maxBlockExUnits = maxBlockExUnits' - , Alonzo.maxValSize = maxValSize' - , Alonzo.collateralPercentage = collateralPercentage' - , Alonzo.maxCollateralInputs = maxCollateralInputs' + { Alonzo.agCoinsPerUTxOWord = Ledger.CoinPerWord coinsPerUTxOWord + , Alonzo.agCostModels = Alonzo.CostModels mempty mempty mempty + , Alonzo.agPrices = prices' + , Alonzo.agMaxTxExUnits = maxTxExUnits' + , Alonzo.agMaxBlockExUnits = maxBlockExUnits' + , Alonzo.agMaxValSize = maxValSize' + , Alonzo.agCollateralPercentage = collateralPercentage' + , Alonzo.agMaxCollateralInputs = maxCollateralInputs' } diff --git a/cardano-api/gen/Test/Gen/Cardano/Api/Typed.hs b/cardano-api/gen/Test/Gen/Cardano/Api/Typed.hs index ad7e4a4e525..10dfc8b4ecc 100644 --- a/cardano-api/gen/Test/Gen/Cardano/Api/Typed.hs +++ b/cardano-api/gen/Test/Gen/Cardano/Api/Typed.hs @@ -800,8 +800,8 @@ genProtocolParameters = <*> genNat <*> genNat <*> genNat - <*> genNat - <*> genNat + <*> genLovelace + <*> genLovelace <*> Gen.maybe genLovelace <*> genLovelace <*> genLovelace @@ -831,8 +831,8 @@ genProtocolParametersUpdate = do protocolUpdateMaxBlockHeaderSize <- Gen.maybe genNat protocolUpdateMaxBlockBodySize <- Gen.maybe genNat protocolUpdateMaxTxSize <- Gen.maybe genNat - protocolUpdateTxFeeFixed <- Gen.maybe genNat - protocolUpdateTxFeePerByte <- Gen.maybe genNat + protocolUpdateTxFeeFixed <- Gen.maybe genLovelace + protocolUpdateTxFeePerByte <- Gen.maybe genLovelace protocolUpdateMinUTxOValue <- Gen.maybe genLovelace protocolUpdateStakeAddressDeposit <- Gen.maybe genLovelace protocolUpdateStakePoolDeposit <- Gen.maybe genLovelace From a5415553ec9847ffc96128851fe9f6b11e3c2020 Mon Sep 17 00:00:00 2001 From: Alexey Kuleshevich Date: Wed, 15 Mar 2023 01:39:23 +0300 Subject: [PATCH 22/38] cardano-api builds --- cardano-api/cardano-api.cabal | 7 ++++--- cardano-api/test/Test/Cardano/Api/Genesis.hs | 17 ++++++++--------- cardano-api/test/Test/Cardano/Api/Ledger.hs | 15 ++++++++------- .../test/Test/Cardano/Api/Typed/Script.hs | 5 ++++- 4 files changed, 24 insertions(+), 20 deletions(-) diff --git a/cardano-api/cardano-api.cabal b/cardano-api/cardano-api.cabal index 26764cb3f2d..759813f7f65 100644 --- a/cardano-api/cardano-api.cabal +++ b/cardano-api/cardano-api.cabal @@ -174,7 +174,6 @@ library , typed-protocols ^>= 0.1 , unordered-containers >= 0.2.11 , vector - , vector-map ^>= 1.0 , yaml library gen @@ -222,15 +221,17 @@ test-suite cardano-api-test , cardano-crypto-class ^>= 2.1 , cardano-crypto-test ^>= 1.5 , cardano-crypto-tests ^>= 2.1 - , cardano-ledger-core ^>= 1.1 + , cardano-ledger-api ^>= 1.1 + , cardano-ledger-core:{cardano-ledger-core, testlib} ^>= 1.1 , cardano-ledger-shelley ^>= 1.1 , cardano-ledger-shelley-test ^>= 1.0 , cardano-slotting ^>= 0.1 , containers , hedgehog , hedgehog-extras ^>= 0.4 + , hedgehog-quickcheck , mtl - , ouroboros-consensus + , microlens , ouroboros-consensus-shelley , QuickCheck , tasty diff --git a/cardano-api/test/Test/Cardano/Api/Genesis.hs b/cardano-api/test/Test/Cardano/Api/Genesis.hs index 842956a842f..fdc298f1c33 100644 --- a/cardano-api/test/Test/Cardano/Api/Genesis.hs +++ b/cardano-api/test/Test/Cardano/Api/Genesis.hs @@ -12,24 +12,24 @@ import Cardano.Api.Shelley (ShelleyGenesis (..)) import Data.ListMap (ListMap (ListMap)) import qualified Data.Map.Strict as Map import Data.Time.Clock.POSIX (posixSecondsToUTCTime) +import Lens.Micro import Cardano.Slotting.Slot (EpochSize (..)) -import Ouroboros.Consensus.Shelley.Eras (StandardCrypto, StandardShelley) +import Ouroboros.Consensus.Shelley.Eras (StandardCrypto) import Ouroboros.Consensus.Shelley.Node (emptyGenesisStaking) -import Ouroboros.Consensus.Util.Time import Cardano.Ledger.Address (Addr (..)) import Cardano.Ledger.BaseTypes (Network (..)) import Cardano.Ledger.Coin (Coin (..)) +import Cardano.Ledger.Core import Cardano.Ledger.Credential (Credential (..), PaymentCredential, StakeCredential, StakeReference (..)) import Cardano.Ledger.Keys (GenDelegPair (..), Hash, KeyHash (..), KeyRole (..), VerKeyVRF) -import Cardano.Ledger.Shelley.PParams (emptyPParams, ShelleyPParamsHKD (..)) import Test.Cardano.Ledger.Shelley.Utils (unsafeBoundRational) -exampleShelleyGenesis :: ShelleyGenesis StandardShelley +exampleShelleyGenesis :: ShelleyGenesis StandardCrypto exampleShelleyGenesis = ShelleyGenesis { sgSystemStart = posixSecondsToUTCTime $ realToFrac (1234566789 :: Integer) @@ -40,14 +40,13 @@ exampleShelleyGenesis = , sgEpochLength = EpochSize 1215 , sgSlotsPerKESPeriod = 8541 , sgMaxKESEvolutions = 28899 - , sgSlotLength = secondsToNominalDiffTime 8 + , sgSlotLength = 8 , sgUpdateQuorum = 16991 , sgMaxLovelaceSupply = 71 , sgProtocolParams = emptyPParams - { _d = unsafeBoundRational 1.9e-2 - , _maxBBSize = 239857 - , _maxBHSize = 217569 - } + & ppDL .~ unsafeBoundRational 1.9e-2 + & ppMaxBBSizeL .~ 239857 + & ppMaxBHSizeL .~ 217569 , sgGenDelegs = Map.fromList [( genesisVerKeyHash , GenDelegPair delegVerKeyHash delegVrfKeyHash) diff --git a/cardano-api/test/Test/Cardano/Api/Ledger.hs b/cardano-api/test/Test/Cardano/Api/Ledger.hs index 7efda9962fc..24e4776711d 100644 --- a/cardano-api/test/Test/Cardano/Api/Ledger.hs +++ b/cardano-api/test/Test/Cardano/Api/Ledger.hs @@ -11,7 +11,7 @@ import Cardano.Api.Shelley import Control.Monad.Identity import Cardano.Ledger.Address (deserialiseAddr, serialiseAddr) -import qualified Cardano.Ledger.Alonzo.Data as Alonzo +import qualified Cardano.Ledger.Api as L import Cardano.Ledger.Crypto import Cardano.Ledger.SafeHash @@ -21,10 +21,11 @@ import qualified Hedgehog as H import qualified Hedgehog.Extras.Aeson as H import Hedgehog.Internal.Property import Test.Cardano.Api.Genesis (exampleShelleyGenesis) -import Test.Cardano.Ledger.Shelley.Serialisation.Generators.Genesis (genAddress) +import Test.Cardano.Ledger.Core.Arbitrary () import Test.Gen.Cardano.Api.Typed import Test.Tasty (TestTree, testGroup) import Test.Tasty.Hedgehog (testPropertyNamed) +import Hedgehog.Gen.QuickCheck (arbitrary) prop_golden_ShelleyGenesis :: Property prop_golden_ShelleyGenesis = H.goldenTestJsonValuePretty exampleShelleyGenesis "test/Golden/ShelleyGenesis" @@ -35,7 +36,7 @@ prop_golden_ShelleyGenesis = H.goldenTestJsonValuePretty exampleShelleyGenesis " prop_roundtrip_Address_CBOR :: Property prop_roundtrip_Address_CBOR = H.property $ do -- If this fails, FundPair and ShelleyGenesis can also fail. - addr <- H.forAll (genAddress @StandardCrypto) + addr <- H.forAll (arbitrary @(L.Addr StandardCrypto)) H.tripping addr serialiseAddr deserialiseAddr -- prop_original_scriptdata_bytes_preserved and prop_roundtrip_scriptdata_plutusdata @@ -52,13 +53,13 @@ prop_original_scriptdata_bytes_preserved = H.property $ do Left e -> failWith Nothing $ show e Right hScriptData -> do let ScriptDataHash apiHash = hashScriptDataBytes hScriptData - ledgerAlonzoData = toAlonzoData hScriptData :: Alonzo.Data StandardAlonzo - -- We check that our hashScriptDataBytes is equivalent to `Alonzo.hashData` + ledgerAlonzoData = toAlonzoData hScriptData :: L.Data StandardAlonzo + -- We check that our hashScriptDataBytes is equivalent to `L.hashData` -- This test will let us know if our 'hashScriptDataBytes' is ever broken - Alonzo.hashData ledgerAlonzoData === apiHash + L.hashData ledgerAlonzoData === apiHash -- We also check that the original bytes are the same after the calling - -- toAlonzoData :: HashableScriptData -> Alonzo.Data ledgerera. + -- toAlonzoData :: HashableScriptData -> L.Data ledgerera. originalBytes ledgerAlonzoData === getOriginalScriptDataBytes hScriptData prop_roundtrip_scriptdata_plutusdata :: Property diff --git a/cardano-api/test/Test/Cardano/Api/Typed/Script.hs b/cardano-api/test/Test/Cardano/Api/Typed/Script.hs index 8c69cc8040b..a16921c7231 100644 --- a/cardano-api/test/Test/Cardano/Api/Typed/Script.hs +++ b/cardano-api/test/Test/Cardano/Api/Typed/Script.hs @@ -1,9 +1,12 @@ +{-# LANGUAGE TypeApplications #-} + module Test.Cardano.Api.Typed.Script ( tests ) where import Cardano.Api import Cardano.Api.Shelley +import qualified Cardano.Ledger.Api.Era as L import Data.Aeson import Hedgehog (Property, (===)) import Hedgehog.Extras.Aeson @@ -114,7 +117,7 @@ prop_roundtrip_ScriptData :: Property prop_roundtrip_ScriptData = H.property $ do sData <- H.forAll genHashableScriptData - sData === fromAlonzoData (toAlonzoData sData) + sData === fromAlonzoData (toAlonzoData @L.Alonzo sData) -- ----------------------------------------------------------------------------- From a055cb83502886521abb4738116a7440ea652b96 Mon Sep 17 00:00:00 2001 From: Alexey Kuleshevich Date: Wed, 15 Mar 2023 01:43:06 +0300 Subject: [PATCH 23/38] cardano-api builds --- cardano-api/gen/Test/Gen/Cardano/Api.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/cardano-api/gen/Test/Gen/Cardano/Api.hs b/cardano-api/gen/Test/Gen/Cardano/Api.hs index abd8b557c9e..4f0a47a540c 100644 --- a/cardano-api/gen/Test/Gen/Cardano/Api.hs +++ b/cardano-api/gen/Test/Gen/Cardano/Api.hs @@ -115,7 +115,7 @@ genAlonzoGenesis = do return Alonzo.AlonzoGenesis { Alonzo.agCoinsPerUTxOWord = Ledger.CoinPerWord coinsPerUTxOWord - , Alonzo.agCostModels = Alonzo.CostModels mempty mempty mempty + , Alonzo.agCostModels = Alonzo.CostModels mempty mempty mempty , Alonzo.agPrices = prices' , Alonzo.agMaxTxExUnits = maxTxExUnits' , Alonzo.agMaxBlockExUnits = maxBlockExUnits' From e7ea0242ea9be6c862d5d1c474c8970e16878f15 Mon Sep 17 00:00:00 2001 From: Alexey Kuleshevich Date: Wed, 15 Mar 2023 03:57:09 +0300 Subject: [PATCH 24/38] Brought back TxMetadata serialization --- .../src/Cardano/Api/ProtocolParameters.hs | 2 +- cardano-api/src/Cardano/Api/TxMetadata.hs | 33 +++++++++---------- .../src/Cardano/CLI/Shelley/Orphans.hs | 17 ++-------- .../src/Cardano/CLI/Shelley/Parsers.hs | 16 ++++----- 4 files changed, 27 insertions(+), 41 deletions(-) diff --git a/cardano-api/src/Cardano/Api/ProtocolParameters.hs b/cardano-api/src/Cardano/Api/ProtocolParameters.hs index a09e7b3f827..c740100ec3e 100644 --- a/cardano-api/src/Cardano/Api/ProtocolParameters.hs +++ b/cardano-api/src/Cardano/Api/ProtocolParameters.hs @@ -200,7 +200,7 @@ data ProtocolParameters = -- protocolParamTxFeeFixed :: Lovelace, - -- | The linear factor for the minimum fee calculation. + -- | Per byte linear factor for the minimum fee calculation. -- protocolParamTxFeePerByte :: Lovelace, diff --git a/cardano-api/src/Cardano/Api/TxMetadata.hs b/cardano-api/src/Cardano/Api/TxMetadata.hs index 1c18aed6aeb..fbdf667ccfe 100644 --- a/cardano-api/src/Cardano/Api/TxMetadata.hs +++ b/cardano-api/src/Cardano/Api/TxMetadata.hs @@ -43,6 +43,8 @@ module Cardano.Api.TxMetadata ( import Cardano.Api.Eras import Cardano.Api.Error import Cardano.Api.HasTypeProxy +import Cardano.Api.SerialiseCBOR (SerialiseAsCBOR (..)) +import qualified Cardano.Ledger.Binary as CBOR import qualified Cardano.Ledger.Shelley.TxAuxData as Shelley import Control.Applicative (Alternative (..)) import Control.Monad (guard, when) @@ -102,23 +104,20 @@ instance HasTypeProxy TxMetadata where data AsType TxMetadata = AsTxMetadata proxyToAsType _ = AsTxMetadata --- instance SerialiseAsCBOR TxMetadata where --- serialiseToCBOR = --- CBOR.serialize' --- . (Shelley.Metadata :: Map Word64 Shelley.Metadatum -> Shelley.Metadata ()) --- -- The Shelley (Metadata era) is always polymorphic in era, --- -- so we pick the unit type. --- . toShelleyMetadata --- . (\(TxMetadata m) -> m) - --- deserialiseFromCBOR AsTxMetadata bs = --- TxMetadata --- . fromShelleyMetadata --- . (\(Shelley.Metadata m) -> m) --- <$> (CBOR.decodeAnnotator "TxMetadata" fromCBOR (LBS.fromStrict bs) --- :: Either CBOR.DecoderError (Shelley.Metadata ())) --- -- The Shelley (Metadata era) is always polymorphic in era, --- -- so we pick the unit type. +instance SerialiseAsCBOR TxMetadata where + serialiseToCBOR = + -- This is a workaround. There is a tiny chance that serialization could change + -- for Metadata in the future, depending on the era it is being used in. For now + -- we can pretend like it is the same for all eras starting with Shelley + CBOR.serialize' CBOR.shelleyProtVer + . toShelleyMetadata + . (\(TxMetadata m) -> m) + + deserialiseFromCBOR AsTxMetadata bs = + TxMetadata + . fromShelleyMetadata + <$> (CBOR.decodeFullDecoder' CBOR.shelleyProtVer "TxMetadata" CBOR.decCBOR bs + :: Either CBOR.DecoderError (Map Word64 Shelley.Metadatum)) makeTransactionMetadata :: Map Word64 TxMetadataValue -> TxMetadata makeTransactionMetadata = TxMetadata diff --git a/cardano-cli/src/Cardano/CLI/Shelley/Orphans.hs b/cardano-cli/src/Cardano/CLI/Shelley/Orphans.hs index a621dc032db..690260a6303 100644 --- a/cardano-cli/src/Cardano/CLI/Shelley/Orphans.hs +++ b/cardano-cli/src/Cardano/CLI/Shelley/Orphans.hs @@ -17,20 +17,17 @@ module Cardano.CLI.Shelley.Orphans () where import Cardano.Api.Orphans () import qualified Cardano.Ledger.AuxiliaryData as Ledger import qualified Cardano.Ledger.Credential as Ledger -import Cardano.Ledger.Conway.Genesis (ConwayGenesis (..)) +import qualified Cardano.Ledger.EpochBoundary as Ledger import qualified Cardano.Ledger.Crypto as CC (Crypto) import qualified Cardano.Ledger.Mary.Value as Ledger.Mary import qualified Cardano.Ledger.PoolDistr as Ledger -import qualified Cardano.Ledger.Shelley.EpochBoundary as Ledger import qualified Cardano.Ledger.Shelley.PoolRank as Ledger -import Cardano.Ledger.TxIn (TxId (..)) import qualified Cardano.Protocol.TPraos.API as Ledger import Cardano.Protocol.TPraos.BHeader (HashHeader (..)) import qualified Cardano.Protocol.TPraos.Rules.Prtcl as Ledger import qualified Cardano.Protocol.TPraos.Rules.Tickn as Ledger import qualified Cardano.Slotting.Slot as Cardano -import qualified Control.SetAlgebra as SetAlgebra (BiMap, forwards) -import Data.Aeson (FromJSON (..), KeyValue ((.=)), ToJSON (..), ToJSONKey) +import Data.Aeson (FromJSON (..), KeyValue ((.=)), ToJSON (..)) import qualified Data.Aeson as Aeson import qualified Data.ByteString.Base16 as Base16 import qualified Data.ByteString.Short as SBS @@ -73,8 +70,6 @@ deriving newtype instance FromJSON BlockNo -- Simple newtype wrappers JSON conversion -- -deriving newtype instance CC.Crypto crypto => ToJSON (TxId crypto) - deriving newtype instance CC.Crypto crypto => ToJSON (ShelleyHash crypto) deriving newtype instance CC.Crypto crypto => ToJSON (HashHeader crypto) @@ -92,9 +87,6 @@ deriving instance ToJSON (Ledger.ChainDepState StandardCrypto) deriving newtype instance ToJSON (Ledger.Mary.PolicyID StandardCrypto) -instance (ToJSONKey k, ToJSON v) => ToJSON (SetAlgebra.BiMap v k v) where - toJSON = toJSON . SetAlgebra.forwards -- to normal Map - instance ToJSON (TPraosState StandardCrypto) where toJSON s = Aeson.object [ "lastSlot" .= Consensus.tpraosStateLastSlot s @@ -117,8 +109,3 @@ instance ToJSON (Cardano.WithOrigin Cardano.SlotNo) where toJSON = \case Cardano.Origin -> Aeson.String "origin" Cardano.At (Cardano.SlotNo n) -> toJSON n - --- This instance should be exported from ledger but is currently not, -instance CC.Crypto c => ToJSON (ConwayGenesis c) where - toJSON (ConwayGenesis genDelegs) = - Aeson.object ["genDelegs" .= toJSON genDelegs] diff --git a/cardano-cli/src/Cardano/CLI/Shelley/Parsers.hs b/cardano-cli/src/Cardano/CLI/Shelley/Parsers.hs index 39d7f9c0edc..de6e80f7122 100644 --- a/cardano-cli/src/Cardano/CLI/Shelley/Parsers.hs +++ b/cardano-cli/src/Cardano/CLI/Shelley/Parsers.hs @@ -2948,7 +2948,7 @@ pProtocolParametersUpdate = <*> optional pMaxBodySize <*> optional pMaxTransactionSize <*> optional pMinFeeConstantFactor - <*> optional pMinFeeLinearFactor + <*> optional pMinFeePerByteFactor <*> optional pMinUTxOValue <*> optional pKeyRegistDeposit <*> optional pPoolDeposit @@ -2977,17 +2977,17 @@ pCostModels = <> Opt.completer (Opt.bashCompleter "file") ) -pMinFeeLinearFactor :: Parser Natural -pMinFeeLinearFactor = - Opt.option Opt.auto +pMinFeePerByteFactor :: Parser Lovelace +pMinFeePerByteFactor = + Opt.option (readerFromParsecParser parseLovelace) ( Opt.long "min-fee-linear" - <> Opt.metavar "NATURAL" - <> Opt.help "The linear factor for the minimum fee calculation." + <> Opt.metavar "LOVELACE" + <> Opt.help "The linear factor per byte for the minimum fee calculation." ) -pMinFeeConstantFactor :: Parser Natural +pMinFeeConstantFactor :: Parser Lovelace pMinFeeConstantFactor = - Opt.option Opt.auto + Opt.option (readerFromParsecParser parseLovelace) ( Opt.long "min-fee-constant" <> Opt.metavar "LOVELACE" <> Opt.help "The constant factor for the minimum fee calculation." From 9bab3e419e066b6f86e0be73f1447f37de82afd7 Mon Sep 17 00:00:00 2001 From: Alexey Kuleshevich Date: Wed, 15 Mar 2023 22:50:31 +0300 Subject: [PATCH 25/38] cardano-node:Fix Queries --- cardano-node/src/Cardano/Node/Queries.hs | 6 +++--- 1 file changed, 3 insertions(+), 3 deletions(-) diff --git a/cardano-node/src/Cardano/Node/Queries.hs b/cardano-node/src/Cardano/Node/Queries.hs index 0cbc240fbfe..0484502c918 100644 --- a/cardano-node/src/Cardano/Node/Queries.hs +++ b/cardano-node/src/Cardano/Node/Queries.hs @@ -41,7 +41,6 @@ import Data.ByteString (ByteString) import Data.IORef (IORef, newIORef, readIORef, writeIORef) import qualified Data.Map.Strict as Map import Data.SOP.Strict -import qualified Data.UMap as UM import Data.Word (Word64) import qualified Cardano.Chain.Block as Byron @@ -56,6 +55,7 @@ import qualified Cardano.Ledger.SafeHash as Ledger import qualified Cardano.Ledger.Shelley.LedgerState as Shelley import qualified Cardano.Ledger.Shelley.UTxO as Shelley import qualified Cardano.Ledger.TxIn as Ledger +import qualified Cardano.Ledger.UMapCompact as UM import Ouroboros.Consensus.Block (ForgeStateInfo, ForgeStateUpdateError) import Ouroboros.Consensus.Byron.Ledger.Block (ByronBlock) @@ -242,7 +242,7 @@ instance LedgerQueries Byron.ByronBlock where instance LedgerQueries (Shelley.ShelleyBlock protocol era) where ledgerUtxoSize = (\(Shelley.UTxO xs)-> Map.size xs) - . Shelley._utxo + . Shelley.utxosUtxo . Shelley.lsUTxOState . Shelley.esLState . Shelley.nesEs @@ -250,7 +250,7 @@ instance LedgerQueries (Shelley.ShelleyBlock protocol era) where ledgerDelegMapSize = UM.size . UM.Delegations - . Shelley._unified + . Shelley.dsUnified . Shelley.dpsDState . Shelley.lsDPState . Shelley.esLState From 5ab4e1643076e42007fe600410722db8f1a1eaf1 Mon Sep 17 00:00:00 2001 From: Alexey Kuleshevich Date: Thu, 16 Mar 2023 01:53:31 +0300 Subject: [PATCH 26/38] Fix spelling `withdrawl` -> `withdrawal` --- cardano-cli/ChangeLog.md | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/cardano-cli/ChangeLog.md b/cardano-cli/ChangeLog.md index 677990ccec3..0fd6c2493d1 100644 --- a/cardano-cli/ChangeLog.md +++ b/cardano-cli/ChangeLog.md @@ -166,7 +166,7 @@ None - Allow provision of optional datums to a transaction using the CLI option `--tx-out-datum-embed-value`. This mechanism can for example be used to provide the actual script locking an output, for use when spending it. (#3171) -- Fix the use of withdrawls using the `transaction build` command. (#3317) +- Fix the use of withdrawals using the `transaction build` command. (#3317) - Allow extended payment keys to be specified as a Plutus required signer. (#3319) @@ -189,7 +189,7 @@ None everywhere for consistency. (#3181) - Allow the `tx build` command to spend the entirety of a UTxO and create no change output. (#3188) -- Add withdrawls to the `tx view` command. (#2613) +- Add withdrawals to the `tx view` command. (#2613) ## 1.29.0 -- August 2021 - Add a "tx build" command to the CLI. This command takes care of calculating From 0a3b4d35781014699f833101c18ca3848a2ab003 Mon Sep 17 00:00:00 2001 From: Alexey Kuleshevich Date: Thu, 16 Mar 2023 03:32:39 +0300 Subject: [PATCH 27/38] Some progress on cardano-node --- cardano-node/cardano-node.cabal | 9 +- .../src/Cardano/Node/Protocol/Cardano.hs | 26 ++++-- .../src/Cardano/Node/Protocol/Shelley.hs | 10 +- .../src/Cardano/Node/Tracing/Era/Shelley.hs | 82 +++++++---------- .../Tracing/OrphanInstances/Network.hs | 14 +-- .../Tracing/OrphanInstances/Shelley.hs | 91 +++++++++---------- 6 files changed, 111 insertions(+), 121 deletions(-) diff --git a/cardano-node/cardano-node.cabal b/cardano-node/cardano-node.cabal index 151411cd7a5..30ba3830e3c 100644 --- a/cardano-node/cardano-node.cabal +++ b/cardano-node/cardano-node.cabal @@ -142,17 +142,14 @@ library , cardano-git-rev , cardano-crypto-class , cardano-crypto-wrapper - , cardano-ledger-core - , cardano-ledger-byron - , cardano-ledger-conway - , cardano-ledger-shelley - , cardano-ledger-shelley-ma , cardano-ledger-alonzo + , cardano-ledger-allegra , cardano-ledger-babbage , cardano-ledger-byron + , cardano-ledger-conway , cardano-ledger-core , cardano-ledger-shelley - , cardano-ledger-shelley-ma + , cardano-ledger-mary , cardano-prelude , cardano-protocol-tpraos ^>= 1.0 , cardano-slotting ^>= 0.1 diff --git a/cardano-node/src/Cardano/Node/Protocol/Cardano.hs b/cardano-node/src/Cardano/Node/Protocol/Cardano.hs index 5bfd87c8b57..0c9fa64e4a9 100644 --- a/cardano-node/src/Cardano/Node/Protocol/Cardano.hs +++ b/cardano-node/src/Cardano/Node/Protocol/Cardano.hs @@ -1,8 +1,10 @@ +{-# LANGUAGE DataKinds #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE GADTs #-} {-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeApplications #-} {-# OPTIONS_GHC -Wno-orphans #-} @@ -36,6 +38,10 @@ import Cardano.Node.Types import Cardano.Tracing.OrphanInstances.Byron () import Cardano.Tracing.OrphanInstances.Shelley () +import Cardano.Ledger.BaseTypes (natVersion) +import Cardano.Ledger.Conway.Genesis (ConwayGenesis (cgGenDelegs)) +import Cardano.Ledger.Shelley.Translation (emptyFromByronTranslationContext) + import qualified Cardano.Node.Protocol.Alonzo as Alonzo import qualified Cardano.Node.Protocol.Byron as Byron import qualified Cardano.Node.Protocol.Conway as Conway @@ -182,7 +188,7 @@ mkSomeConsensusProtocolCardano NodeByronProtocolConfiguration { -- is in the Shelley era. That is, it is the version of protocol -- /after/ Shelley, i.e. Allegra. shelleyProtVer = - ProtVer 3 0, + ProtVer (natVersion @3) 0, shelleyMaxTxCapacityOverrides = TxLimits.mkOverrides TxLimits.noOverridesMeasure } @@ -192,7 +198,7 @@ mkSomeConsensusProtocolCardano NodeByronProtocolConfiguration { -- is in the Allegra era. That is, it is the version of protocol -- /after/ Allegra, i.e. Mary. allegraProtVer = - ProtVer 4 0, + ProtVer (natVersion @4) 0, allegraMaxTxCapacityOverrides = TxLimits.mkOverrides TxLimits.noOverridesMeasure } @@ -201,7 +207,7 @@ mkSomeConsensusProtocolCardano NodeByronProtocolConfiguration { -- version that this node will declare that it understands, when it -- is in the Mary era. That is, it is the version of protocol -- /after/ Mary, i.e. Alonzo. - maryProtVer = ProtVer 5 0, + maryProtVer = ProtVer (natVersion @5) 0, maryMaxTxCapacityOverrides = TxLimits.mkOverrides TxLimits.noOverridesMeasure } @@ -215,7 +221,7 @@ mkSomeConsensusProtocolCardano NodeByronProtocolConfiguration { -- this is a HACK so that we can distinguish between others -- versions of the node that are broadcasting major version 7. -- We intentionally broadcast 7.0 starting in Babbage. - alonzoProtVer = ProtVer 7 2, + alonzoProtVer = ProtVer (natVersion @7) 2, alonzoMaxTxCapacityOverrides = TxLimits.mkOverrides TxLimits.noOverridesMeasure } @@ -224,7 +230,7 @@ mkSomeConsensusProtocolCardano NodeByronProtocolConfiguration { -- version that this node will declare that it understands, when it -- is in the Babbage era. Since Babbage is currently the last known -- protocol version then this is also the Babbage protocol version. - Praos.babbageProtVer = ProtVer 8 0, + Praos.babbageProtVer = ProtVer (natVersion @8) 0, Praos.babbageMaxTxCapacityOverrides = TxLimits.mkOverrides TxLimits.noOverridesMeasure } @@ -235,8 +241,8 @@ mkSomeConsensusProtocolCardano NodeByronProtocolConfiguration { -- protocol version then this is also the Babbage protocol version. Praos.conwayProtVer = if npcTestEnableDevelopmentHardForkEras - then ProtVer 9 0 - else ProtVer 8 0, + then ProtVer (natVersion @9) 0 + else ProtVer (natVersion @8) 0, Praos.conwayMaxTxCapacityOverrides = TxLimits.mkOverrides TxLimits.noOverridesMeasure } @@ -244,7 +250,7 @@ mkSomeConsensusProtocolCardano NodeByronProtocolConfiguration { -- The comments below also apply for the Shelley -> Allegra and Allegra -> Mary hard forks. -- Byron to Shelley hard fork parameters Consensus.ProtocolTransitionParamsShelleyBased { - transitionTranslationContext = (), + transitionTranslationContext = emptyFromByronTranslationContext, transitionTrigger = -- What will trigger the Byron -> Shelley hard fork? case npcTestShelleyHardForkAtEpoch of @@ -302,7 +308,7 @@ mkSomeConsensusProtocolCardano NodeByronProtocolConfiguration { } -- Alonzo to Babbage hard fork parameters Consensus.ProtocolTransitionParamsShelleyBased { - transitionTranslationContext = alonzoGenesis, + transitionTranslationContext = (), transitionTrigger = case npcTestBabbageHardForkAtEpoch of Nothing -> Consensus.TriggerHardForkAtVersion @@ -312,7 +318,7 @@ mkSomeConsensusProtocolCardano NodeByronProtocolConfiguration { } -- Alonzo to Conway hard fork parameters Consensus.ProtocolTransitionParamsShelleyBased { - transitionTranslationContext = conwayGenesis, + transitionTranslationContext = cgGenDelegs conwayGenesis, transitionTrigger = case npcTestConwayHardForkAtEpoch of Nothing -> Consensus.TriggerHardForkAtVersion diff --git a/cardano-node/src/Cardano/Node/Protocol/Shelley.hs b/cardano-node/src/Cardano/Node/Protocol/Shelley.hs index 110c4768910..b7846325d5c 100644 --- a/cardano-node/src/Cardano/Node/Protocol/Shelley.hs +++ b/cardano-node/src/Cardano/Node/Protocol/Shelley.hs @@ -2,6 +2,7 @@ {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeApplications #-} module Cardano.Node.Protocol.Shelley ( mkSomeConsensusProtocolShelley @@ -40,11 +41,10 @@ import Cardano.Ledger.Keys (coerceKeyRole) import qualified Ouroboros.Consensus.Cardano as Consensus import qualified Ouroboros.Consensus.Mempool.Capacity as TxLimits import Ouroboros.Consensus.Protocol.Praos.Common (PraosCanBeLeader (..)) -import Ouroboros.Consensus.Shelley.Eras (StandardShelley) import Ouroboros.Consensus.Shelley.Node (Nonce (..), ProtocolParamsShelley (..), ProtocolParamsShelleyBased (..), ShelleyLeaderCredentials (..)) -import Cardano.Ledger.BaseTypes (ProtVer (..)) +import Cardano.Ledger.BaseTypes (ProtVer (..), natVersion) import qualified Cardano.Ledger.Shelley.Genesis as Shelley import Cardano.Api.Orphans () @@ -97,7 +97,7 @@ mkSomeConsensusProtocolShelley NodeShelleyProtocolConfiguration { } Consensus.ProtocolParamsShelley { shelleyProtVer = - ProtVer 2 0, + ProtVer (natVersion @2) 0, shelleyMaxTxCapacityOverrides = TxLimits.mkOverrides TxLimits.noOverridesMeasure } @@ -108,7 +108,7 @@ genesisHashToPraosNonce (GenesisHash h) = Nonce (Crypto.castHash h) readGenesis :: GenesisFile -> Maybe GenesisHash -> ExceptT GenesisReadError IO - (ShelleyGenesis StandardShelley, GenesisHash) + (ShelleyGenesis StandardCrypto, GenesisHash) readGenesis = readGenesisAny readGenesisAny :: FromJSON genesis @@ -132,7 +132,7 @@ readGenesisAny (GenesisFile file) mbExpectedGenesisHash = do -> throwError (GenesisHashMismatch actual expected) _ -> return () -validateGenesis :: ShelleyGenesis StandardShelley +validateGenesis :: ShelleyGenesis StandardCrypto -> ExceptT GenesisValidationError IO () validateGenesis genesis = firstExceptT GenesisValidationErrors . hoistEither $ diff --git a/cardano-node/src/Cardano/Node/Tracing/Era/Shelley.hs b/cardano-node/src/Cardano/Node/Tracing/Era/Shelley.hs index c558a186811..a9047f8215f 100644 --- a/cardano-node/src/Cardano/Node/Tracing/Era/Shelley.hs +++ b/cardano-node/src/Cardano/Node/Tracing/Era/Shelley.hs @@ -56,42 +56,24 @@ import qualified Cardano.Ledger.Alonzo.Tx as Alonzo import qualified Cardano.Ledger.AuxiliaryData as Core import Cardano.Ledger.BaseTypes (activeSlotLog, strictMaybeToMaybe) import Cardano.Ledger.Chain -import qualified Cardano.Ledger.Core as Core hiding (Crypto) +import qualified Cardano.Ledger.Core as Core import qualified Cardano.Ledger.Core as Ledger import qualified Cardano.Ledger.Crypto as Core import qualified Cardano.Ledger.SafeHash as SafeHash -import qualified Cardano.Ledger.ShelleyMA.Timelocks as MA +import qualified Cardano.Ledger.Allegra.Scripts as Allegra -- TODO: this should be exposed via Cardano.Api import Cardano.Ledger.Shelley.API -import Cardano.Ledger.Shelley.Rules.Bbody -import Cardano.Ledger.Shelley.Rules.Deleg -import Cardano.Ledger.Shelley.Rules.Delegs -import Cardano.Ledger.Shelley.Rules.Delpl -import Cardano.Ledger.Shelley.Rules.Epoch -import Cardano.Ledger.Shelley.Rules.Ledger -import Cardano.Ledger.Shelley.Rules.Ledgers -import Cardano.Ledger.Shelley.Rules.Mir -import Cardano.Ledger.Shelley.Rules.NewEpoch -import Cardano.Ledger.Shelley.Rules.Newpp -import Cardano.Ledger.Shelley.Rules.Pool -import Cardano.Ledger.Shelley.Rules.PoolReap -import Cardano.Ledger.Shelley.Rules.Ppup -import Cardano.Ledger.Shelley.Rules.Rupd -import Cardano.Ledger.Shelley.Rules.Snap -import Cardano.Ledger.Shelley.Rules.Tick -import Cardano.Ledger.Shelley.Rules.Upec -import Cardano.Ledger.Shelley.Rules.Utxo -import Cardano.Ledger.Shelley.Rules.Utxow +import Cardano.Ledger.Shelley.Rules import Cardano.Ledger.Alonzo.Rules (AlonzoBbodyPredFailure, AlonzoUtxoPredFailure, AlonzoUtxosPredFailure, AlonzoUtxowPredFailure (..)) import qualified Cardano.Ledger.Alonzo.Rules as Alonzo import Cardano.Ledger.Babbage.Rules (BabbageUtxoPredFailure, BabbageUtxowPredFailure) import qualified Cardano.Ledger.Babbage.Rules as Babbage -import Cardano.Ledger.ShelleyMA.Rules (ShelleyMAUtxoPredFailure) -import qualified Cardano.Ledger.ShelleyMA.Rules as MA +import Cardano.Ledger.Allegra.Rules (AllegraUtxoPredFailure) +import qualified Cardano.Ledger.Allegra.Rules as Allegra import Cardano.Protocol.TPraos.API (ChainTransitionError (ChainTransitionError)) import Cardano.Protocol.TPraos.OCert (KESPeriod (KESPeriod)) import Cardano.Protocol.TPraos.Rules.Prtcl @@ -262,7 +244,7 @@ instance ( ShelleyBasedEra era instance ( ShelleyBasedEra era - , ToJSON (Core.AuxiliaryDataHash (Ledger.Crypto era)) + , ToJSON (Core.AuxiliaryDataHash (Ledger.EraCrypto era)) , LogFormatting (PredicateFailure (ShelleyUTXO era)) , LogFormatting (PredicateFailure (ShelleyUTXOW era)) , LogFormatting (PredicateFailure (Core.EraRule "DELEGS" era)) @@ -274,7 +256,8 @@ instance ( ShelleyBasedEra era instance ( ShelleyBasedEra era , ToJSON (Ledger.Value era) , ToJSON (Ledger.TxOut era) - , Ledger.Crypto era ~ StandardCrypto + , Ledger.EraCrypto era ~ StandardCrypto + , LogFormatting (PPUPPredFailure era) , LogFormatting (PredicateFailure (Ledger.EraRule "PPUP" era)) , LogFormatting (PredicateFailure (Ledger.EraRule "UTXO" era)) ) => LogFormatting (AlonzoUtxowPredFailure era) where @@ -344,8 +327,8 @@ renderScriptPurpose (Alonzo.Certifying cert) = instance ( ShelleyBasedEra era - , Ledger.Crypto era ~ StandardCrypto - , ToJSON (Core.AuxiliaryDataHash (Ledger.Crypto era)) + , Ledger.EraCrypto era ~ StandardCrypto + , ToJSON (Core.AuxiliaryDataHash (Ledger.EraCrypto era)) , LogFormatting (PredicateFailure (ShelleyUTXO era)) , LogFormatting (PredicateFailure (Core.EraRule "UTXO" era)) ) => LogFormatting (ShelleyUtxowPredFailure era) where @@ -394,6 +377,7 @@ instance ( ShelleyBasedEra era instance ( ShelleyBasedEra era , ToJSON (Core.Value era) , ToJSON (Core.TxOut era) + , LogFormatting (PPUPPredFailure era) , LogFormatting (PredicateFailure (Core.EraRule "PPUP" era)) ) => LogFormatting (ShelleyUtxoPredFailure era) where @@ -454,46 +438,47 @@ instance ( ShelleyBasedEra era instance ( ShelleyBasedEra era , ToJSON (Core.Value era) , ToJSON (Core.TxOut era) - , ToJSON MA.ValidityInterval + , ToJSON Allegra.ValidityInterval + , LogFormatting (PPUPPredFailure era) , LogFormatting (PredicateFailure (Core.EraRule "PPUP" era)) - ) => LogFormatting (ShelleyMAUtxoPredFailure era) where - forMachine _dtal (MA.BadInputsUTxO badInputs) = + ) => LogFormatting (AllegraUtxoPredFailure era) where + forMachine _dtal (Allegra.BadInputsUTxO badInputs) = mconcat [ "kind" .= String "BadInputsUTxO" , "badInputs" .= badInputs , "error" .= renderBadInputsUTxOErr badInputs ] - forMachine _dtal (MA.OutsideValidityIntervalUTxO validityInterval slot) = + forMachine _dtal (Allegra.OutsideValidityIntervalUTxO validityInterval slot) = mconcat [ "kind" .= String "ExpiredUTxO" , "validityInterval" .= validityInterval , "slot" .= slot ] - forMachine _dtal (MA.MaxTxSizeUTxO txsize maxtxsize) = + forMachine _dtal (Allegra.MaxTxSizeUTxO txsize maxtxsize) = mconcat [ "kind" .= String "MaxTxSizeUTxO" , "size" .= txsize , "maxSize" .= maxtxsize ] - forMachine _dtal MA.InputSetEmptyUTxO = + forMachine _dtal Allegra.InputSetEmptyUTxO = mconcat [ "kind" .= String "InputSetEmptyUTxO" ] - forMachine _dtal (MA.FeeTooSmallUTxO minfee txfee) = + forMachine _dtal (Allegra.FeeTooSmallUTxO minfee txfee) = mconcat [ "kind" .= String "FeeTooSmallUTxO" , "minimum" .= minfee , "fee" .= txfee ] - forMachine _dtal (MA.ValueNotConservedUTxO consumed produced) = + forMachine _dtal (Allegra.ValueNotConservedUTxO consumed produced) = mconcat [ "kind" .= String "ValueNotConservedUTxO" , "consumed" .= consumed , "produced" .= produced , "error" .= renderValueNotConservedErr consumed produced ] - forMachine _dtal (MA.WrongNetwork network addrs) = + forMachine _dtal (Allegra.WrongNetwork network addrs) = mconcat [ "kind" .= String "WrongNetwork" , "network" .= network , "addrs" .= addrs ] - forMachine _dtal (MA.WrongNetworkWithdrawal network addrs) = + forMachine _dtal (Allegra.WrongNetworkWithdrawal network addrs) = mconcat [ "kind" .= String "WrongNetworkWithdrawal" , "network" .= network , "addrs" .= addrs ] -- TODO: Add the minimum allowed UTxO value to OutputTooSmallUTxO - forMachine _dtal (MA.OutputTooSmallUTxO badOutputs) = + forMachine _dtal (Allegra.OutputTooSmallUTxO badOutputs) = mconcat [ "kind" .= String "OutputTooSmallUTxO" , "outputs" .= badOutputs , "error" .= String @@ -503,15 +488,15 @@ instance ( ShelleyBasedEra era ] ) ] - forMachine dtal (MA.UpdateFailure f) = forMachine dtal f - forMachine _dtal (MA.OutputBootAddrAttrsTooBig badOutputs) = + forMachine dtal (Allegra.UpdateFailure f) = forMachine dtal f + forMachine _dtal (Allegra.OutputBootAddrAttrsTooBig badOutputs) = mconcat [ "kind" .= String "OutputBootAddrAttrsTooBig" , "outputs" .= badOutputs , "error" .= String "The Byron address attributes are too big" ] - forMachine _dtal MA.TriesToForgeADA = + forMachine _dtal Allegra.TriesToForgeADA = mconcat [ "kind" .= String "TriesToForgeADA" ] - forMachine _dtal (MA.OutputTooBigUTxO badOutputs) = + forMachine _dtal (Allegra.OutputTooBigUTxO badOutputs) = mconcat [ "kind" .= String "OutputTooBigUTxO" , "outputs" .= badOutputs , "error" .= String "Too many asset ids in the tx output" @@ -526,7 +511,7 @@ renderValueNotConservedErr :: Show val => val -> val -> Value renderValueNotConservedErr consumed produced = String $ "This transaction consumed " <> textShow consumed <> " but produced " <> textShow produced -instance Core.Crypto (Ledger.Crypto era) => LogFormatting (ShelleyPpupPredFailure era) where +instance Core.Crypto (Ledger.EraCrypto era) => LogFormatting (ShelleyPpupPredFailure era) where forMachine _dtal (NonGenesisUpdatePPUP proposalKeys genesisKeys) = mconcat [ "kind" .= String "NonGenesisUpdatePPUP" , "keys" .= proposalKeys Set.\\ genesisKeys ] @@ -558,12 +543,12 @@ instance ( ShelleyBasedEra era instance ( LogFormatting (PredicateFailure (Core.EraRule "POOL" era)) , LogFormatting (PredicateFailure (Core.EraRule "DELEG" era)) - , Crypto.HashAlgorithm (Core.HASH (Ledger.Crypto era)) + , Crypto.HashAlgorithm (Core.HASH (Ledger.EraCrypto era)) ) => LogFormatting (ShelleyDelplPredFailure era) where forMachine dtal (PoolFailure f) = forMachine dtal f forMachine dtal (DelegFailure f) = forMachine dtal f -instance Crypto.HashAlgorithm (Core.HASH (Ledger.Crypto era)) +instance Crypto.HashAlgorithm (Core.HASH (Ledger.EraCrypto era)) => LogFormatting (ShelleyDelegPredFailure era) where forMachine _dtal (StakeKeyAlreadyRegisteredDELEG alreadyRegistered) = mconcat [ "kind" .= String "StakeKeyAlreadyRegisteredDELEG" @@ -716,6 +701,7 @@ instance ( LogFormatting (PredicateFailure (Core.EraRule "EPOCH" era)) instance ( LogFormatting (PredicateFailure (Core.EraRule "POOLREAP" era)) , LogFormatting (PredicateFailure (Core.EraRule "SNAP" era)) , LogFormatting (PredicateFailure (Core.EraRule "UPEC" era)) + , LogFormatting (UpecPredFailure era) ) => LogFormatting (ShelleyEpochPredFailure era) where forMachine dtal (PoolReapFailure f) = forMachine dtal f forMachine dtal (SnapFailure f) = forMachine dtal f @@ -972,8 +958,9 @@ instance ( ShelleyBasedEra era forMachine _dtal Alonzo.NoCollateralInputs = mconcat [ "kind" .= String "NoCollateralInputs" ] -instance ( ToJSON (Alonzo.CollectError (Ledger.Crypto era)) +instance ( ToJSON (Alonzo.CollectError (Ledger.EraCrypto era)) , LogFormatting (PredicateFailure (Ledger.EraRule "PPUP" era)) + , LogFormatting (PPUPPredFailure era) ) => LogFormatting (AlonzoUtxosPredFailure era) where forMachine _ (Alonzo.ValidationTagMismatch isValidating reason) = mconcat [ "kind" .= String "ValidationTagMismatch" @@ -1020,9 +1007,10 @@ instance ( Ledger.Era era instance ( Ledger.Era era , ShelleyBasedEra era - , Ledger.Crypto era ~ StandardCrypto + , Ledger.EraCrypto era ~ StandardCrypto , ToJSON (Ledger.Value era) , ToJSON (Ledger.TxOut era) + , LogFormatting (PPUPPredFailure era) , LogFormatting (ShelleyUtxowPredFailure era) , LogFormatting (PredicateFailure (Ledger.EraRule "PPUP" era)) , LogFormatting (PredicateFailure (Ledger.EraRule "UTXO" era)) diff --git a/cardano-node/src/Cardano/Tracing/OrphanInstances/Network.hs b/cardano-node/src/Cardano/Tracing/OrphanInstances/Network.hs index da9ede66eea..17cef572e19 100644 --- a/cardano-node/src/Cardano/Tracing/OrphanInstances/Network.hs +++ b/cardano-node/src/Cardano/Tracing/OrphanInstances/Network.hs @@ -372,7 +372,7 @@ instance HasSeverityAnnotation (WithMuxBearer peer MuxTrace) where MuxTraceStartEagerly _ _ -> Info MuxTraceStartOnDemand _ _ -> Info MuxTraceStartedOnDemand _ _ -> Info - MuxTraceShutdown -> Debug + -- MuxTraceShutdown -> Debug MuxTraceTerminating {} -> Debug MuxTraceTCPInfo {} -> Debug @@ -456,7 +456,7 @@ instance HasSeverityAnnotation (ConnectionManagerTrace addr (ConnectionHandlerTr TrShutdown -> Info TrConnectionExists {} -> Info TrForbiddenConnection {} -> Info - TrImpossibleConnection {} -> Info + -- TrImpossibleConnection {} -> Info TrConnectionFailure {} -> Info TrConnectionNotFound {} -> Debug TrForbiddenOperation {} -> Info @@ -1901,11 +1901,11 @@ instance (Show addr, Show versionNumber, Show agreedOptions, ToObject addr, [ "kind" .= String "ForbiddenConnection" , "connectionId" .= toJSON connId ] - TrImpossibleConnection connId -> - mconcat - [ "kind" .= String "ImpossibleConnection" - , "connectionId" .= toJSON connId - ] + -- TrImpossibleConnection connId -> + -- mconcat + -- [ "kind" .= String "ImpossibleConnection" + -- , "connectionId" .= toJSON connId + -- ] TrConnectionFailure connId -> mconcat [ "kind" .= String "ConnectionFailure" diff --git a/cardano-node/src/Cardano/Tracing/OrphanInstances/Shelley.hs b/cardano-node/src/Cardano/Tracing/OrphanInstances/Shelley.hs index 97e4cd4a5c4..59f224ddc7e 100644 --- a/cardano-node/src/Cardano/Tracing/OrphanInstances/Shelley.hs +++ b/cardano-node/src/Cardano/Tracing/OrphanInstances/Shelley.hs @@ -52,17 +52,17 @@ import Ouroboros.Consensus.Shelley.Ledger.Inspect import qualified Ouroboros.Consensus.Shelley.Protocol.Praos as Praos import qualified Cardano.Crypto.Hash.Class as Crypto +import qualified Cardano.Ledger.Allegra.Scripts as Allegra import qualified Cardano.Ledger.Alonzo.PlutusScriptApi as Alonzo import qualified Cardano.Ledger.Alonzo.Tx as Alonzo import qualified Cardano.Ledger.Alonzo.TxInfo as Alonzo import qualified Cardano.Ledger.AuxiliaryData as Core import Cardano.Ledger.BaseTypes (activeSlotLog, strictMaybeToMaybe) import Cardano.Ledger.Chain -import qualified Cardano.Ledger.Core as Core hiding (Crypto) +import qualified Cardano.Ledger.Core as Core import qualified Cardano.Ledger.Core as Ledger import qualified Cardano.Ledger.Crypto as Core import qualified Cardano.Ledger.SafeHash as SafeHash -import qualified Cardano.Ledger.ShelleyMA.Timelocks as MA import Cardano.Protocol.TPraos.BHeader (LastAppliedBlock, labBlockNo) import Cardano.Protocol.TPraos.Rules.OCert import Cardano.Protocol.TPraos.Rules.Overlay @@ -72,32 +72,15 @@ import Cardano.Protocol.TPraos.Rules.Updn -- TODO: this should be exposed via Cardano.Api import Cardano.Ledger.Shelley.API +import Cardano.Ledger.Allegra.Rules (AllegraUtxoPredFailure) +import qualified Cardano.Ledger.Allegra.Rules as Allegra import Cardano.Ledger.Alonzo.Rules (AlonzoBbodyPredFailure (..), AlonzoUtxoPredFailure, AlonzoUtxosPredFailure, AlonzoUtxowPredFailure (..)) import qualified Cardano.Ledger.Alonzo.Rules as Alonzo import Cardano.Ledger.Babbage.Rules (BabbageUtxoPredFailure, BabbageUtxowPredFailure) import qualified Cardano.Ledger.Babbage.Rules as Babbage -import Cardano.Ledger.Shelley.Rules.Bbody -import Cardano.Ledger.Shelley.Rules.Deleg -import Cardano.Ledger.Shelley.Rules.Delegs -import Cardano.Ledger.Shelley.Rules.Delpl -import Cardano.Ledger.Shelley.Rules.Epoch -import Cardano.Ledger.Shelley.Rules.Ledger -import Cardano.Ledger.Shelley.Rules.Ledgers -import Cardano.Ledger.Shelley.Rules.Mir -import Cardano.Ledger.Shelley.Rules.NewEpoch -import Cardano.Ledger.Shelley.Rules.Newpp -import Cardano.Ledger.Shelley.Rules.Pool -import Cardano.Ledger.Shelley.Rules.PoolReap -import Cardano.Ledger.Shelley.Rules.Ppup -import Cardano.Ledger.Shelley.Rules.Rupd -import Cardano.Ledger.Shelley.Rules.Snap -import Cardano.Ledger.Shelley.Rules.Tick -import Cardano.Ledger.Shelley.Rules.Upec -import Cardano.Ledger.Shelley.Rules.Utxo -import Cardano.Ledger.Shelley.Rules.Utxow -import Cardano.Ledger.ShelleyMA.Rules (ShelleyMAUtxoPredFailure) -import qualified Cardano.Ledger.ShelleyMA.Rules as MA +import qualified Cardano.Ledger.Conway.Rules as Conway +import Cardano.Ledger.Shelley.Rules import Cardano.Protocol.TPraos.API (ChainTransitionError (ChainTransitionError)) import Cardano.Protocol.TPraos.OCert (KESPeriod (KESPeriod)) import Cardano.Protocol.TPraos.Rules.Prtcl @@ -262,12 +245,24 @@ instance ( ShelleyBasedEra era toObject verb (UtxowFailure f) = toObject verb f toObject verb (DelegsFailure f) = toObject verb f +instance ( ShelleyBasedEra era + , ToObject (PredicateFailure (ShelleyUTXO era)) + , ToObject (PredicateFailure (ShelleyUTXOW era)) + , ToObject (PredicateFailure (Core.EraRule "DELEGS" era)) + , ToObject (PredicateFailure (Core.EraRule "UTXOW" era)) + , ToObject (PredicateFailure (Core.EraRule "TALLY" era)) + ) => ToObject (Conway.ConwayLedgerPredFailure era) where + toObject verb (Conway.ConwayUtxowFailure f) = toObject verb f + toObject verb (Conway.ConwayDelegsFailure f) = toObject verb f + toObject verb (Conway.ConwayTallyFailure f) = toObject verb f + instance ( ShelleyBasedEra era , ToJSON (Ledger.Value era) , ToJSON (Ledger.TxOut era) , ToObject (PredicateFailure (Ledger.EraRule "PPUP" era)) + , ToObject (PPUPPredFailure era) , ToObject (PredicateFailure (Ledger.EraRule "UTXO" era)) - , Ledger.Crypto era ~ StandardCrypto + , Ledger.EraCrypto era ~ StandardCrypto ) => ToObject (AlonzoUtxowPredFailure era) where toObject v (ShelleyInAlonzoUtxowPredFailure utxoPredFail) = toObject v utxoPredFail @@ -380,6 +375,7 @@ instance ( ShelleyBasedEra era , ToJSON (Core.Value era) , ToJSON (Core.TxOut era) , ToObject (PredicateFailure (Core.EraRule "PPUP" era)) + , ToObject (PPUPPredFailure era) ) => ToObject (ShelleyUtxoPredFailure era) where toObject _verb (BadInputsUTxO badInputs) = @@ -437,11 +433,11 @@ instance ( ShelleyBasedEra era ] -instance ToJSON MA.ValidityInterval where +instance ToJSON Allegra.ValidityInterval where toJSON vi = Aeson.object $ - [ "invalidBefore" .= x | x <- mbfield (MA.invalidBefore vi) ] - ++ [ "invalidHereafter" .= x | x <- mbfield (MA.invalidHereafter vi) ] + [ "invalidBefore" .= x | x <- mbfield (Allegra.invalidBefore vi) ] + ++ [ "invalidHereafter" .= x | x <- mbfield (Allegra.invalidHereafter vi) ] where mbfield SNothing = [] mbfield (SJust x) = [x] @@ -450,44 +446,45 @@ instance ( ShelleyBasedEra era , ToJSON (Core.Value era) , ToJSON (Core.TxOut era) , ToObject (PredicateFailure (Core.EraRule "PPUP" era)) - ) => ToObject (ShelleyMAUtxoPredFailure era) where - toObject _verb (MA.BadInputsUTxO badInputs) = + , ToObject (PPUPPredFailure era) + ) => ToObject (AllegraUtxoPredFailure era) where + toObject _verb (Allegra.BadInputsUTxO badInputs) = mconcat [ "kind" .= String "BadInputsUTxO" , "badInputs" .= badInputs , "error" .= renderBadInputsUTxOErr badInputs ] - toObject _verb (MA.OutsideValidityIntervalUTxO validityInterval slot) = + toObject _verb (Allegra.OutsideValidityIntervalUTxO validityInterval slot) = mconcat [ "kind" .= String "ExpiredUTxO" , "validityInterval" .= validityInterval , "slot" .= slot ] - toObject _verb (MA.MaxTxSizeUTxO txsize maxtxsize) = + toObject _verb (Allegra.MaxTxSizeUTxO txsize maxtxsize) = mconcat [ "kind" .= String "MaxTxSizeUTxO" , "size" .= txsize , "maxSize" .= maxtxsize ] - toObject _verb MA.InputSetEmptyUTxO = + toObject _verb Allegra.InputSetEmptyUTxO = mconcat [ "kind" .= String "InputSetEmptyUTxO" ] - toObject _verb (MA.FeeTooSmallUTxO minfee txfee) = + toObject _verb (Allegra.FeeTooSmallUTxO minfee txfee) = mconcat [ "kind" .= String "FeeTooSmallUTxO" , "minimum" .= minfee , "fee" .= txfee ] - toObject _verb (MA.ValueNotConservedUTxO consumed produced) = + toObject _verb (Allegra.ValueNotConservedUTxO consumed produced) = mconcat [ "kind" .= String "ValueNotConservedUTxO" , "consumed" .= consumed , "produced" .= produced , "error" .= renderValueNotConservedErr consumed produced ] - toObject _verb (MA.WrongNetwork network addrs) = + toObject _verb (Allegra.WrongNetwork network addrs) = mconcat [ "kind" .= String "WrongNetwork" , "network" .= network , "addrs" .= addrs ] - toObject _verb (MA.WrongNetworkWithdrawal network addrs) = + toObject _verb (Allegra.WrongNetworkWithdrawal network addrs) = mconcat [ "kind" .= String "WrongNetworkWithdrawal" , "network" .= network , "addrs" .= addrs ] -- TODO: Add the minimum allowed UTxO value to OutputTooSmallUTxO - toObject _verb (MA.OutputTooSmallUTxO badOutputs) = + toObject _verb (Allegra.OutputTooSmallUTxO badOutputs) = mconcat [ "kind" .= String "OutputTooSmallUTxO" , "outputs" .= badOutputs , "error" .= String @@ -497,15 +494,15 @@ instance ( ShelleyBasedEra era ] ) ] - toObject verb (MA.UpdateFailure f) = toObject verb f - toObject _verb (MA.OutputBootAddrAttrsTooBig badOutputs) = + toObject verb (Allegra.UpdateFailure f) = toObject verb f + toObject _verb (Allegra.OutputBootAddrAttrsTooBig badOutputs) = mconcat [ "kind" .= String "OutputBootAddrAttrsTooBig" , "outputs" .= badOutputs , "error" .= String "The Byron address attributes are too big" ] - toObject _verb MA.TriesToForgeADA = + toObject _verb Allegra.TriesToForgeADA = mconcat [ "kind" .= String "TriesToForgeADA" ] - toObject _verb (MA.OutputTooBigUTxO badOutputs) = + toObject _verb (Allegra.OutputTooBigUTxO badOutputs) = mconcat [ "kind" .= String "OutputTooBigUTxO" , "outputs" .= badOutputs , "error" .= String "Too many asset ids in the tx output" @@ -708,6 +705,7 @@ instance ( ToObject (PredicateFailure (Core.EraRule "EPOCH" era)) instance ( ToObject (PredicateFailure (Core.EraRule "POOLREAP" era)) , ToObject (PredicateFailure (Core.EraRule "SNAP" era)) , ToObject (PredicateFailure (Core.EraRule "UPEC" era)) + , ToObject (UpecPredFailure era) ) => ToObject (ShelleyEpochPredFailure era) where toObject verb (PoolReapFailure f) = toObject verb f toObject verb (SnapFailure f) = toObject verb f @@ -891,6 +889,7 @@ instance ( Ledger.Era era , ToJSON (Ledger.Value era) , ToJSON (Ledger.TxOut era) , ToObject (PredicateFailure (Ledger.EraRule "UTXOS" era)) + , ToObject (PPUPPredFailure era) , ShelleyBasedEra era ) => ToObject (AlonzoUtxoPredFailure era) where toObject _verb (Alonzo.BadInputsUTxO badInputs) = @@ -990,8 +989,9 @@ instance ( Ledger.Era era toObject _verb Alonzo.NoCollateralInputs = mconcat [ "kind" .= String "NoCollateralInputs" ] -instance ( ToJSON (Alonzo.CollectError (Ledger.Crypto era)) +instance ( ToJSON (Alonzo.CollectError (Ledger.EraCrypto era)) , ToObject (PredicateFailure (Ledger.EraRule "PPUP" era)) + , ToObject (PPUPPredFailure era) ) =>ToObject (AlonzoUtxosPredFailure era) where toObject _ (Alonzo.ValidationTagMismatch isValidating reason) = mconcat [ "kind" .= String "ValidationTagMismatch" @@ -1096,6 +1096,7 @@ instance ( ToJSON (Ledger.Value era) , ShelleyBasedEra era , ToObject (ShelleyUtxowPredFailure era) , ToObject (PredicateFailure (Ledger.EraRule "UTXOS" era)) + , ToObject (PPUPPredFailure era) ) => ToObject (BabbageUtxoPredFailure era) where toObject v err = case err of @@ -1114,10 +1115,10 @@ instance ( ToJSON (Ledger.Value era) instance ( Ledger.Era era , ShelleyBasedEra era - , Ledger.Crypto era ~ StandardCrypto + , Ledger.EraCrypto era ~ StandardCrypto , ToJSON (Ledger.Value era) , ToJSON (Ledger.TxOut era) - , ToObject (ShelleyUtxowPredFailure era) + , ToObject (PPUPPredFailure era) , ToObject (PredicateFailure (Ledger.EraRule "PPUP" era)) , ToObject (PredicateFailure (Ledger.EraRule "UTXO" era)) ) => ToObject (BabbageUtxowPredFailure era) where @@ -1239,5 +1240,3 @@ showLastAppBlockNo wOblk = case withOriginToMaybe wOblk of -- Common to cardano-cli deriving newtype instance Core.Crypto crypto => ToJSON (Core.AuxiliaryDataHash crypto) - -deriving newtype instance Core.Crypto crypto => ToJSON (TxId crypto) From 58997afe6425070c05578a5c9e107e8e1e99bd0a Mon Sep 17 00:00:00 2001 From: Alexey Kuleshevich Date: Thu, 16 Mar 2023 04:04:58 +0300 Subject: [PATCH 28/38] cardano-node builds --- .../src/Cardano/Node/Configuration/Logging.hs | 5 ++- .../src/Cardano/Node/Tracing/Era/Shelley.hs | 40 ++++++++++++++----- .../Cardano/Node/Tracing/Tracers/Diffusion.hs | 4 +- .../src/Cardano/Node/Tracing/Tracers/P2P.hs | 12 +++--- .../Cardano/Node/Tracing/Tracers/Startup.hs | 1 + .../Tracing/OrphanInstances/Shelley.hs | 22 ++++++---- 6 files changed, 58 insertions(+), 26 deletions(-) diff --git a/cardano-node/src/Cardano/Node/Configuration/Logging.hs b/cardano-node/src/Cardano/Node/Configuration/Logging.hs index f770864aa4c..8c4fb4b104c 100644 --- a/cardano-node/src/Cardano/Node/Configuration/Logging.hs +++ b/cardano-node/src/Cardano/Node/Configuration/Logging.hs @@ -367,7 +367,10 @@ nodeBasicInfo nc (SomeConsensusProtocol whichP pForInfo) nodeStartTime' = do getGenesisValues era config = let genesis = shelleyLedgerGenesis $ shelleyLedgerConfig config in [ ("systemStartTime", textShow (SL.sgSystemStart genesis)) - , ("slotLength" <> era, textShow (WCT.getSlotLength . WCT.mkSlotLength $ SL.sgSlotLength genesis)) + , ("slotLength" <> era, textShow (WCT.getSlotLength + . WCT.mkSlotLength + . SL.fromNominalDiffTimeMicro + $ SL.sgSlotLength genesis)) , ("epochLength" <> era, textShow (unEpochSize . SL.sgEpochLength $ genesis)) , ("slotsPerKESPeriod" <> era, textShow (SL.sgSlotsPerKESPeriod genesis)) ] diff --git a/cardano-node/src/Cardano/Node/Tracing/Era/Shelley.hs b/cardano-node/src/Cardano/Node/Tracing/Era/Shelley.hs index a9047f8215f..d1f668a14ba 100644 --- a/cardano-node/src/Cardano/Node/Tracing/Era/Shelley.hs +++ b/cardano-node/src/Cardano/Node/Tracing/Era/Shelley.hs @@ -51,6 +51,7 @@ import Cardano.Protocol.TPraos.Rules.Overlay import Cardano.Protocol.TPraos.Rules.Updn (UpdnPredicateFailure) +import qualified Cardano.Ledger.Allegra.Scripts as Allegra import qualified Cardano.Ledger.Alonzo.PlutusScriptApi as Alonzo import qualified Cardano.Ledger.Alonzo.Tx as Alonzo import qualified Cardano.Ledger.AuxiliaryData as Core @@ -60,20 +61,21 @@ import qualified Cardano.Ledger.Core as Core import qualified Cardano.Ledger.Core as Ledger import qualified Cardano.Ledger.Crypto as Core import qualified Cardano.Ledger.SafeHash as SafeHash -import qualified Cardano.Ledger.Allegra.Scripts as Allegra -- TODO: this should be exposed via Cardano.Api import Cardano.Ledger.Shelley.API import Cardano.Ledger.Shelley.Rules +import Cardano.Ledger.Allegra.Rules (AllegraUtxoPredFailure) +import qualified Cardano.Ledger.Allegra.Rules as Allegra +import Cardano.Ledger.Conway.Governance -- (govActionIdToText) import Cardano.Ledger.Alonzo.Rules (AlonzoBbodyPredFailure, AlonzoUtxoPredFailure, AlonzoUtxosPredFailure, AlonzoUtxowPredFailure (..)) import qualified Cardano.Ledger.Alonzo.Rules as Alonzo import Cardano.Ledger.Babbage.Rules (BabbageUtxoPredFailure, BabbageUtxowPredFailure) import qualified Cardano.Ledger.Babbage.Rules as Babbage -import Cardano.Ledger.Allegra.Rules (AllegraUtxoPredFailure) -import qualified Cardano.Ledger.Allegra.Rules as Allegra +import qualified Cardano.Ledger.Conway.Rules as Conway import Cardano.Protocol.TPraos.API (ChainTransitionError (ChainTransitionError)) import Cardano.Protocol.TPraos.OCert (KESPeriod (KESPeriod)) import Cardano.Protocol.TPraos.Rules.Prtcl @@ -258,7 +260,6 @@ instance ( ShelleyBasedEra era , ToJSON (Ledger.TxOut era) , Ledger.EraCrypto era ~ StandardCrypto , LogFormatting (PPUPPredFailure era) - , LogFormatting (PredicateFailure (Ledger.EraRule "PPUP" era)) , LogFormatting (PredicateFailure (Ledger.EraRule "UTXO" era)) ) => LogFormatting (AlonzoUtxowPredFailure era) where forMachine dtal (ShelleyInAlonzoUtxowPredFailure utxoPredFail) = @@ -378,7 +379,6 @@ instance ( ShelleyBasedEra era , ToJSON (Core.Value era) , ToJSON (Core.TxOut era) , LogFormatting (PPUPPredFailure era) - , LogFormatting (PredicateFailure (Core.EraRule "PPUP" era)) ) => LogFormatting (ShelleyUtxoPredFailure era) where forMachine _dtal (BadInputsUTxO badInputs) = @@ -440,7 +440,6 @@ instance ( ShelleyBasedEra era , ToJSON (Core.TxOut era) , ToJSON Allegra.ValidityInterval , LogFormatting (PPUPPredFailure era) - , LogFormatting (PredicateFailure (Core.EraRule "PPUP" era)) ) => LogFormatting (AllegraUtxoPredFailure era) where forMachine _dtal (Allegra.BadInputsUTxO badInputs) = mconcat [ "kind" .= String "BadInputsUTxO" @@ -700,7 +699,6 @@ instance ( LogFormatting (PredicateFailure (Core.EraRule "EPOCH" era)) instance ( LogFormatting (PredicateFailure (Core.EraRule "POOLREAP" era)) , LogFormatting (PredicateFailure (Core.EraRule "SNAP" era)) - , LogFormatting (PredicateFailure (Core.EraRule "UPEC" era)) , LogFormatting (UpecPredFailure era) ) => LogFormatting (ShelleyEpochPredFailure era) where forMachine dtal (PoolReapFailure f) = forMachine dtal f @@ -959,7 +957,6 @@ instance ( ShelleyBasedEra era mconcat [ "kind" .= String "NoCollateralInputs" ] instance ( ToJSON (Alonzo.CollectError (Ledger.EraCrypto era)) - , LogFormatting (PredicateFailure (Ledger.EraRule "PPUP" era)) , LogFormatting (PPUPPredFailure era) ) => LogFormatting (AlonzoUtxosPredFailure era) where forMachine _ (Alonzo.ValidationTagMismatch isValidating reason) = @@ -1012,7 +1009,6 @@ instance ( Ledger.Era era , ToJSON (Ledger.TxOut era) , LogFormatting (PPUPPredFailure era) , LogFormatting (ShelleyUtxowPredFailure era) - , LogFormatting (PredicateFailure (Ledger.EraRule "PPUP" era)) , LogFormatting (PredicateFailure (Ledger.EraRule "UTXO" era)) ) => LogFormatting (BabbageUtxowPredFailure era) where forMachine v err = @@ -1030,6 +1026,32 @@ instance ( Ledger.Era era mconcat [ "kind" .= String "MalformedReferenceScripts" , "scripts" .= s ] +-------------------------------------------------------------------------------- +-- Babbage related +-------------------------------------------------------------------------------- + +instance ( ShelleyBasedEra era + , LogFormatting (PredicateFailure (Core.EraRule "DELEGS" era)) + , LogFormatting (PredicateFailure (Core.EraRule "UTXOW" era)) + , LogFormatting (PredicateFailure (Core.EraRule "TALLY" era)) + ) => LogFormatting (Conway.ConwayLedgerPredFailure era) where + forMachine v (Conway.ConwayUtxowFailure f) = forMachine v f + forMachine v (Conway.ConwayDelegsFailure f) = forMachine v f + forMachine v (Conway.ConwayTallyFailure f) = forMachine v f + +instance ( ShelleyBasedEra era + ) => LogFormatting (Conway.ConwayTallyPredFailure era) where + forMachine = undefined + -- forMachine _ (Conway.VoterDoesNotHaveRole credential voteRole) = + -- mconcat [ "kind" .= String "VoterDoesNotHaveRole" + -- , "credential" .= textShow credential + -- , "voteRole" .= textShow voteRole + -- ] + -- forMachine _ (Conway.GovernanceActionDoesNotExist govActionId) = + -- mconcat [ "kind" .= String "GovernanceActionDoesNotExist" + -- , "credential" .= govActionIdToText govActionId + -- ] + instance Core.Crypto crypto => LogFormatting (Praos.PraosValidationErr crypto) where forMachine _ err' = diff --git a/cardano-node/src/Cardano/Node/Tracing/Tracers/Diffusion.hs b/cardano-node/src/Cardano/Node/Tracing/Tracers/Diffusion.hs index 58740fc56bf..3fe8a45be02 100644 --- a/cardano-node/src/Cardano/Node/Tracing/Tracers/Diffusion.hs +++ b/cardano-node/src/Cardano/Node/Tracing/Tracers/Diffusion.hs @@ -106,8 +106,8 @@ instance MetaTrace MuxTrace where Namespace [] ["StartedOnDemand"] namespaceFor MuxTraceTerminating {} = Namespace [] ["Terminating"] - namespaceFor MuxTraceShutdown {} = - Namespace [] ["Shutdown"] + -- namespaceFor MuxTraceShutdown {} = + -- Namespace [] ["Shutdown"] namespaceFor MuxTraceTCPInfo {} = Namespace [] ["TCPInfo"] diff --git a/cardano-node/src/Cardano/Node/Tracing/Tracers/P2P.hs b/cardano-node/src/Cardano/Node/Tracing/Tracers/P2P.hs index 6fde78b029b..aa248ee0849 100644 --- a/cardano-node/src/Cardano/Node/Tracing/Tracers/P2P.hs +++ b/cardano-node/src/Cardano/Node/Tracing/Tracers/P2P.hs @@ -760,11 +760,11 @@ instance (Show addr, Show versionNumber, Show agreedOptions, LogFormatting addr, [ "kind" .= String "ForbiddenConnection" , "connectionId" .= toJSON connId ] - forMachine _dtal (TrImpossibleConnection connId) = - mconcat - [ "kind" .= String "ImpossibleConnection" - , "connectionId" .= toJSON connId - ] + -- forMachine _dtal (TrImpossibleConnection connId) = + -- mconcat + -- [ "kind" .= String "ImpossibleConnection" + -- , "connectionId" .= toJSON connId + -- ] forMachine _dtal (TrConnectionFailure connId) = mconcat [ "kind" .= String "ConnectionFailure" @@ -882,7 +882,7 @@ instance MetaTrace (ConnectionManagerTrace addr namespaceFor TrShutdown {} = Namespace [] ["Shutdown"] namespaceFor TrConnectionExists {} = Namespace [] ["ConnectionExists"] namespaceFor TrForbiddenConnection {} = Namespace [] ["ForbiddenConnection"] - namespaceFor TrImpossibleConnection {} = Namespace [] ["ImpossibleConnection"] + -- namespaceFor TrImpossibleConnection {} = Namespace [] ["ImpossibleConnection"] namespaceFor TrConnectionFailure {} = Namespace [] ["ConnectionFailure"] namespaceFor TrConnectionNotFound {} = Namespace [] ["ConnectionNotFound"] namespaceFor TrForbiddenOperation {} = Namespace [] ["ForbiddenOperation"] diff --git a/cardano-node/src/Cardano/Node/Tracing/Tracers/Startup.hs b/cardano-node/src/Cardano/Node/Tracing/Tracers/Startup.hs index d1a7594f21d..6d3a23c2145 100644 --- a/cardano-node/src/Cardano/Node/Tracing/Tracers/Startup.hs +++ b/cardano-node/src/Cardano/Node/Tracing/Tracers/Startup.hs @@ -104,6 +104,7 @@ getStartupInfo nc (SomeConsensusProtocol whichP pForInfo) fp = do bisEra = era , bisSystemStartTime = SL.sgSystemStart genesis , bisSlotLength = WCT.getSlotLength . WCT.mkSlotLength + . SL.fromNominalDiffTimeMicro $ SL.sgSlotLength genesis , bisEpochLength = unEpochSize . SL.sgEpochLength $ genesis , bisSlotsPerKESPeriod = SL.sgSlotsPerKESPeriod genesis diff --git a/cardano-node/src/Cardano/Tracing/OrphanInstances/Shelley.hs b/cardano-node/src/Cardano/Tracing/OrphanInstances/Shelley.hs index 59f224ddc7e..3f81f266190 100644 --- a/cardano-node/src/Cardano/Tracing/OrphanInstances/Shelley.hs +++ b/cardano-node/src/Cardano/Tracing/OrphanInstances/Shelley.hs @@ -79,6 +79,7 @@ import Cardano.Ledger.Alonzo.Rules (AlonzoBbodyPredFailure (..), Alonz import qualified Cardano.Ledger.Alonzo.Rules as Alonzo import Cardano.Ledger.Babbage.Rules (BabbageUtxoPredFailure, BabbageUtxowPredFailure) import qualified Cardano.Ledger.Babbage.Rules as Babbage +import Cardano.Ledger.Conway.Governance -- (govActionIdToText) import qualified Cardano.Ledger.Conway.Rules as Conway import Cardano.Ledger.Shelley.Rules import Cardano.Protocol.TPraos.API (ChainTransitionError (ChainTransitionError)) @@ -246,8 +247,6 @@ instance ( ShelleyBasedEra era toObject verb (DelegsFailure f) = toObject verb f instance ( ShelleyBasedEra era - , ToObject (PredicateFailure (ShelleyUTXO era)) - , ToObject (PredicateFailure (ShelleyUTXOW era)) , ToObject (PredicateFailure (Core.EraRule "DELEGS" era)) , ToObject (PredicateFailure (Core.EraRule "UTXOW" era)) , ToObject (PredicateFailure (Core.EraRule "TALLY" era)) @@ -256,10 +255,22 @@ instance ( ShelleyBasedEra era toObject verb (Conway.ConwayDelegsFailure f) = toObject verb f toObject verb (Conway.ConwayTallyFailure f) = toObject verb f +instance ( ShelleyBasedEra era + ) => ToObject (Conway.ConwayTallyPredFailure era) where + toObject = undefined + -- toObject _ (Conway.VoterDoesNotHaveRole credential voteRole) = + -- mconcat [ "kind" .= String "VoterDoesNotHaveRole" + -- , "credential" .= textShow credential + -- , "voteRole" .= textShow voteRole + -- ] + -- toObject _ (Conway.GovernanceActionDoesNotExist govActionId) = + -- mconcat [ "kind" .= String "GovernanceActionDoesNotExist" + -- , "credential" .= govActionIdToText govActionId + -- ] + instance ( ShelleyBasedEra era , ToJSON (Ledger.Value era) , ToJSON (Ledger.TxOut era) - , ToObject (PredicateFailure (Ledger.EraRule "PPUP" era)) , ToObject (PPUPPredFailure era) , ToObject (PredicateFailure (Ledger.EraRule "UTXO" era)) , Ledger.EraCrypto era ~ StandardCrypto @@ -374,7 +385,6 @@ instance ( ShelleyBasedEra era instance ( ShelleyBasedEra era , ToJSON (Core.Value era) , ToJSON (Core.TxOut era) - , ToObject (PredicateFailure (Core.EraRule "PPUP" era)) , ToObject (PPUPPredFailure era) ) => ToObject (ShelleyUtxoPredFailure era) where @@ -445,7 +455,6 @@ instance ToJSON Allegra.ValidityInterval where instance ( ShelleyBasedEra era , ToJSON (Core.Value era) , ToJSON (Core.TxOut era) - , ToObject (PredicateFailure (Core.EraRule "PPUP" era)) , ToObject (PPUPPredFailure era) ) => ToObject (AllegraUtxoPredFailure era) where toObject _verb (Allegra.BadInputsUTxO badInputs) = @@ -704,7 +713,6 @@ instance ( ToObject (PredicateFailure (Core.EraRule "EPOCH" era)) instance ( ToObject (PredicateFailure (Core.EraRule "POOLREAP" era)) , ToObject (PredicateFailure (Core.EraRule "SNAP" era)) - , ToObject (PredicateFailure (Core.EraRule "UPEC" era)) , ToObject (UpecPredFailure era) ) => ToObject (ShelleyEpochPredFailure era) where toObject verb (PoolReapFailure f) = toObject verb f @@ -990,7 +998,6 @@ instance ( Ledger.Era era mconcat [ "kind" .= String "NoCollateralInputs" ] instance ( ToJSON (Alonzo.CollectError (Ledger.EraCrypto era)) - , ToObject (PredicateFailure (Ledger.EraRule "PPUP" era)) , ToObject (PPUPPredFailure era) ) =>ToObject (AlonzoUtxosPredFailure era) where toObject _ (Alonzo.ValidationTagMismatch isValidating reason) = @@ -1119,7 +1126,6 @@ instance ( Ledger.Era era , ToJSON (Ledger.Value era) , ToJSON (Ledger.TxOut era) , ToObject (PPUPPredFailure era) - , ToObject (PredicateFailure (Ledger.EraRule "PPUP" era)) , ToObject (PredicateFailure (Ledger.EraRule "UTXO" era)) ) => ToObject (BabbageUtxowPredFailure era) where toObject v err = From d1b454858ff0e11e1b36231a5b05b3c20bac4cc6 Mon Sep 17 00:00:00 2001 From: Alexey Kuleshevich Date: Thu, 23 Mar 2023 02:55:32 +0300 Subject: [PATCH 29/38] Fixed evaluateTransactionExecutionUnits and fixup evaluateTransactionBalance --- cabal.project | 17 ++++++++--- cardano-api/cardano-api.cabal | 5 ++-- cardano-api/src/Cardano/Api/Fees.hs | 45 ++++++++++++----------------- 3 files changed, 33 insertions(+), 34 deletions(-) diff --git a/cabal.project b/cabal.project index 9487bf69bc6..c12c80f901f 100644 --- a/cabal.project +++ b/cabal.project @@ -113,8 +113,8 @@ allow-newer: source-repository-package type: git location: https://github.com/input-output-hk/ouroboros-network - tag: f6bc60dff6a4a7c49ec909d2db80a6277c177d0b - --sha256: 09mp5ivjlvkix9f2vab046832as7mfqdhylvp9qc75g1mw8i2vnr + tag: 7f6afd7ba652bd20d5aaf31a9450dddda7e2f0bd + --sha256: 0wlvgiiyqp14xd7d49h9709dg2dv7wk1b44kbdy596mg8g3v93nw subdir: monoidal-synchronisation network-mux @@ -130,6 +130,15 @@ source-repository-package ouroboros-consensus-cardano-tools ouroboros-consensus-diffusion +source-repository-package + type: git + location: https://github.com/input-output-hk/fs-sim + tag: 13a1cfa5a82740c5723fb0a279b3f32f98c8b494 + --sha256: 1q783gsb0hh4i0slvfwp5nppi8h425pkvj0kqr2lpl06y7y2gq41 + subdir: + fs-api + fs-sim + -- Waiting for proper Windows ghc-9.2 release. source-repository-package type: git @@ -140,8 +149,8 @@ source-repository-package source-repository-package type: git location: https://github.com/input-output-hk/cardano-ledger - tag: 39d83188c872a51825bdad0875920bca78513024 - --sha256: 1q682fcqd20sdc4lwqjhcqi7fvlx5b5xrl9v39vim7mvrykskgd9 + tag: 79ac5fb0600c8b84c05742ab052018236c225927 + --sha256: 17hanlp66syjszx6dbd9v1hkm7hbmx7ppv5xjgr17xdsjr9j5zwh subdir: eras/alonzo/impl eras/alonzo/test-suite diff --git a/cardano-api/cardano-api.cabal b/cardano-api/cardano-api.cabal index 759813f7f65..4b376a82ffa 100644 --- a/cardano-api/cardano-api.cabal +++ b/cardano-api/cardano-api.cabal @@ -109,7 +109,6 @@ library build-depends: aeson >= 1.5.6.0 , aeson-pretty >= 0.8.5 , attoparsec - , array , base16-bytestring >= 1.0 , base58-bytestring , bech32 >= 1.1.0 @@ -123,7 +122,7 @@ library , cardano-ledger-allegra ^>= 1.1 , cardano-ledger-api >= 1.1 , cardano-ledger-babbage ^>= 1.1 - , cardano-ledger-binary ^>= 1.0.1 + , cardano-ledger-binary ^>= 1.1 , cardano-ledger-byron ^>= 1.0 , cardano-ledger-conway ^>= 1.1 , cardano-ledger-core ^>= 1.1 @@ -224,7 +223,7 @@ test-suite cardano-api-test , cardano-ledger-api ^>= 1.1 , cardano-ledger-core:{cardano-ledger-core, testlib} ^>= 1.1 , cardano-ledger-shelley ^>= 1.1 - , cardano-ledger-shelley-test ^>= 1.0 + , cardano-ledger-shelley-test ^>= 1.1 , cardano-slotting ^>= 0.1 , containers , hedgehog diff --git a/cardano-api/src/Cardano/Api/Fees.hs b/cardano-api/src/Cardano/Api/Fees.hs index 005613b5a1a..915eabbf027 100644 --- a/cardano-api/src/Cardano/Api/Fees.hs +++ b/cardano-api/src/Cardano/Api/Fees.hs @@ -42,7 +42,6 @@ module Cardano.Api.Fees ( ) where import Control.Monad (forM_) -import qualified Data.Array as Array import Data.Bifunctor (bimap, first) import qualified Data.ByteString as BS import Data.ByteString.Short (ShortByteString) @@ -51,6 +50,7 @@ import qualified Data.Map.Strict as Map import Data.Maybe (catMaybes, fromMaybe, maybeToList) import Data.Ratio import Data.Set (Set) +import qualified Data.Set as Set import qualified Data.Text as Text import Lens.Micro ((^.)) import Numeric.Natural @@ -64,17 +64,16 @@ import qualified Cardano.Chain.Common as Byron import qualified Cardano.Ledger.Coin as Ledger import Cardano.Ledger.Core (EraTx (sizeTxF)) import qualified Cardano.Ledger.Crypto as Ledger +import qualified Cardano.Ledger.Keys as Ledger import Cardano.Ledger.UTxO as Ledger (EraUTxO) import Cardano.Ledger.Mary.Value (MaryValue) -import qualified Cardano.Ledger.Shelley.API.Wallet as Ledger (evaluateTransactionBalance, - evaluateTransactionFee) +import qualified Cardano.Ledger.Shelley.API.Wallet as Ledger (evaluateTransactionFee) import Cardano.Ledger.Shelley.TxBody (ShelleyEraTxBody) import qualified Cardano.Ledger.Alonzo.Language as Alonzo import qualified Cardano.Ledger.Alonzo.Scripts as Alonzo -import qualified Cardano.Ledger.Alonzo.Scripts as L import qualified Cardano.Ledger.Alonzo.Tx as Alonzo import qualified Cardano.Ledger.Alonzo.TxInfo as Alonzo import qualified Cardano.Ledger.Alonzo.TxWits as Alonzo @@ -532,14 +531,12 @@ evaluateTransactionExecutionUnits systemstart epochInfo bpp utxo txbody = (Map ScriptWitnessIndex (Either ScriptExecutionError ExecutionUnits)) evalAlonzo era tx = do - cModelArray <- toAlonzoCostModelsArray (protocolParamCostModels (unbundleProtocolParams bpp)) - case L.evaluateTransactionExecutionUnits + case L.evalTxExUnits (unbundleLedgerShelleyBasedProtocolParams era bpp) tx (toLedgerUTxO era utxo) ledgerEpochInfo systemstart - cModelArray of Left err -> Left (TransactionValidityTranslationError err) Right exmap -> Right (fromLedgerScriptExUnitsMap exmap) @@ -551,14 +548,12 @@ evaluateTransactionExecutionUnits systemstart epochInfo bpp utxo txbody = (Map ScriptWitnessIndex (Either ScriptExecutionError ExecutionUnits)) evalBabbage era tx = do - costModelsArray <- toAlonzoCostModelsArray (protocolParamCostModels (unbundleProtocolParams bpp)) - case L.evaluateTransactionExecutionUnits + case L.evalTxExUnits (unbundleLedgerShelleyBasedProtocolParams era bpp) tx (toLedgerUTxO era utxo) ledgerEpochInfo systemstart - costModelsArray of Left err -> Left (TransactionValidityTranslationError err) Right exmap -> Right (fromLedgerScriptExUnitsMap exmap) @@ -572,26 +567,15 @@ evaluateTransactionExecutionUnits systemstart epochInfo bpp utxo txbody = (Map ScriptWitnessIndex (Either ScriptExecutionError ExecutionUnits)) evalConway era tx = do - costModelsArray <- toAlonzoCostModelsArray (protocolParamCostModels (unbundleProtocolParams bpp)) - case L.evaluateTransactionExecutionUnits + case L.evalTxExUnits (unbundleLedgerShelleyBasedProtocolParams era bpp) tx (toLedgerUTxO era utxo) ledgerEpochInfo systemstart - costModelsArray of Left err -> Left (TransactionValidityTranslationError err) Right exmap -> Right (fromLedgerScriptExUnitsMap exmap) - - toAlonzoCostModelsArray - :: Map AnyPlutusScriptVersion CostModel - -> Either TransactionValidityError (Array.Array Alonzo.Language Alonzo.CostModel) - toAlonzoCostModelsArray costmodels = do - L.CostModels cModels _ _ <- - first (TransactionValidityCostModelError costmodels) $ toAlonzoCostModels costmodels - return $ Array.array (minBound, maxBound) (Map.toList cModels) - fromLedgerScriptExUnitsMap :: Map Alonzo.RdmrPtr (Either (L.TransactionScriptFailure Ledger.StandardCrypto) Alonzo.ExUnits) @@ -682,7 +666,12 @@ evaluateTransactionBalance bpp poolids utxo getShelleyEraTxBodyConstraint ShelleyBasedEraBabbage x = x getShelleyEraTxBodyConstraint ShelleyBasedEraConway x = x - dpstate = error "Unimplemented. Requires a new Query" + isRegPool :: Ledger.KeyHash Ledger.StakePool Ledger.StandardCrypto -> Bool + isRegPool kh = StakePoolKeyHash kh `Set.member` poolids + + -- FIXME: Add deposit map as an argument and implement a depsit loookup query in + -- consensus and cardano-cli + lookupDelegDeposit _cred = Nothing evalMultiAsset :: forall ledgerera. ShelleyLedgerEra era ~ ledgerera @@ -693,9 +682,10 @@ evaluateTransactionBalance bpp poolids utxo -> TxOutValue era evalMultiAsset evidence = TxOutValue evidence . fromMaryValue $ - Ledger.evaluateTransactionBalance + L.evalBalanceTxBody (unbundleLedgerShelleyBasedProtocolParams era bpp) - dpstate + lookupDelegDeposit + isRegPool (toLedgerUTxO era utxo) txbody @@ -708,9 +698,10 @@ evaluateTransactionBalance bpp poolids utxo -> TxOutValue era evalAdaOnly evidence = TxOutAdaOnly evidence . fromShelleyLovelace - $ Ledger.evaluateTransactionBalance + $ L.evalBalanceTxBody (unbundleLedgerShelleyBasedProtocolParams era bpp) - dpstate + lookupDelegDeposit + isRegPool (toLedgerUTxO era utxo) txbody From 63955a6b6079b7a59707e9e2a3edf07d24cd39d1 Mon Sep 17 00:00:00 2001 From: Alexey Kuleshevich Date: Thu, 23 Mar 2023 03:19:06 +0300 Subject: [PATCH 30/38] Get cardano-node to build --- cardano-node/src/Cardano/Node/Orphans.hs | 9 ------- .../src/Cardano/Node/Tracing/Era/Shelley.hs | 19 +++++++------- .../Cardano/Node/Tracing/Tracers/Diffusion.hs | 6 +++-- .../Tracing/OrphanInstances/Network.hs | 3 ++- .../Tracing/OrphanInstances/Shelley.hs | 26 +++++++------------ 5 files changed, 25 insertions(+), 38 deletions(-) diff --git a/cardano-node/src/Cardano/Node/Orphans.hs b/cardano-node/src/Cardano/Node/Orphans.hs index 638c61e9c3b..2ac49a58db3 100644 --- a/cardano-node/src/Cardano/Node/Orphans.hs +++ b/cardano-node/src/Cardano/Node/Orphans.hs @@ -13,8 +13,6 @@ import qualified Data.Text as Text import Cardano.BM.Data.Tracer (TracingVerbosity (..)) import qualified Cardano.Chain.Update as Update -import qualified Cardano.Ledger.CompactAddress as Ledger -import Cardano.Ledger.Crypto (StandardCrypto) import Ouroboros.Network.NodeToNode (AcceptedConnectionsLimit (..)) import Ouroboros.Network.SizeInBytes (SizeInBytes (..)) @@ -36,13 +34,6 @@ deriving instance Show TracingVerbosity instance PrintfArg SizeInBytes where formatArg (SizeInBytes s) = formatArg s -instance ToJSON (Ledger.CompactAddr StandardCrypto) where - toJSON = toJSON . Ledger.decompactAddr - ---Not currently needed, but if we do need it, this is the general instance. ---instance (ToJSON a, Ledger.Compactible a) => ToJSON (Ledger.CompactForm a) where --- toJSON = toJSON . Ledger.fromCompact - instance FromJSON Update.ApplicationName where parseJSON (String x) = pure $ Update.ApplicationName x parseJSON invalid = diff --git a/cardano-node/src/Cardano/Node/Tracing/Era/Shelley.hs b/cardano-node/src/Cardano/Node/Tracing/Era/Shelley.hs index d1f668a14ba..4dad8ec3973 100644 --- a/cardano-node/src/Cardano/Node/Tracing/Era/Shelley.hs +++ b/cardano-node/src/Cardano/Node/Tracing/Era/Shelley.hs @@ -1041,16 +1041,15 @@ instance ( ShelleyBasedEra era instance ( ShelleyBasedEra era ) => LogFormatting (Conway.ConwayTallyPredFailure era) where - forMachine = undefined - -- forMachine _ (Conway.VoterDoesNotHaveRole credential voteRole) = - -- mconcat [ "kind" .= String "VoterDoesNotHaveRole" - -- , "credential" .= textShow credential - -- , "voteRole" .= textShow voteRole - -- ] - -- forMachine _ (Conway.GovernanceActionDoesNotExist govActionId) = - -- mconcat [ "kind" .= String "GovernanceActionDoesNotExist" - -- , "credential" .= govActionIdToText govActionId - -- ] + forMachine _ (Conway.VoterDoesNotHaveRole credential voteRole) = + mconcat [ "kind" .= String "VoterDoesNotHaveRole" + , "credential" .= textShow credential + , "voteRole" .= textShow voteRole + ] + forMachine _ (Conway.GovernanceActionDoesNotExist govActionId) = + mconcat [ "kind" .= String "GovernanceActionDoesNotExist" + , "credential" .= govActionIdToText govActionId + ] instance Core.Crypto crypto => LogFormatting (Praos.PraosValidationErr crypto) where diff --git a/cardano-node/src/Cardano/Node/Tracing/Tracers/Diffusion.hs b/cardano-node/src/Cardano/Node/Tracing/Tracers/Diffusion.hs index 3fe8a45be02..a591b70bc97 100644 --- a/cardano-node/src/Cardano/Node/Tracing/Tracers/Diffusion.hs +++ b/cardano-node/src/Cardano/Node/Tracing/Tracers/Diffusion.hs @@ -106,8 +106,10 @@ instance MetaTrace MuxTrace where Namespace [] ["StartedOnDemand"] namespaceFor MuxTraceTerminating {} = Namespace [] ["Terminating"] - -- namespaceFor MuxTraceShutdown {} = - -- Namespace [] ["Shutdown"] + namespaceFor MuxTraceStopping = + Namespace [] ["Stopping"] + namespaceFor MuxTraceStopped = + Namespace [] ["Stopped"] namespaceFor MuxTraceTCPInfo {} = Namespace [] ["TCPInfo"] diff --git a/cardano-node/src/Cardano/Tracing/OrphanInstances/Network.hs b/cardano-node/src/Cardano/Tracing/OrphanInstances/Network.hs index 17cef572e19..c1a7cec4610 100644 --- a/cardano-node/src/Cardano/Tracing/OrphanInstances/Network.hs +++ b/cardano-node/src/Cardano/Tracing/OrphanInstances/Network.hs @@ -372,8 +372,9 @@ instance HasSeverityAnnotation (WithMuxBearer peer MuxTrace) where MuxTraceStartEagerly _ _ -> Info MuxTraceStartOnDemand _ _ -> Info MuxTraceStartedOnDemand _ _ -> Info - -- MuxTraceShutdown -> Debug MuxTraceTerminating {} -> Debug + MuxTraceStopping -> Debug + MuxTraceStopped -> Debug MuxTraceTCPInfo {} -> Debug instance HasPrivacyAnnotation (TraceLocalRootPeers RemoteAddress exception) diff --git a/cardano-node/src/Cardano/Tracing/OrphanInstances/Shelley.hs b/cardano-node/src/Cardano/Tracing/OrphanInstances/Shelley.hs index 3f81f266190..ae2e4e760f1 100644 --- a/cardano-node/src/Cardano/Tracing/OrphanInstances/Shelley.hs +++ b/cardano-node/src/Cardano/Tracing/OrphanInstances/Shelley.hs @@ -56,7 +56,6 @@ import qualified Cardano.Ledger.Allegra.Scripts as Allegra import qualified Cardano.Ledger.Alonzo.PlutusScriptApi as Alonzo import qualified Cardano.Ledger.Alonzo.Tx as Alonzo import qualified Cardano.Ledger.Alonzo.TxInfo as Alonzo -import qualified Cardano.Ledger.AuxiliaryData as Core import Cardano.Ledger.BaseTypes (activeSlotLog, strictMaybeToMaybe) import Cardano.Ledger.Chain import qualified Cardano.Ledger.Core as Core @@ -79,7 +78,7 @@ import Cardano.Ledger.Alonzo.Rules (AlonzoBbodyPredFailure (..), Alonz import qualified Cardano.Ledger.Alonzo.Rules as Alonzo import Cardano.Ledger.Babbage.Rules (BabbageUtxoPredFailure, BabbageUtxowPredFailure) import qualified Cardano.Ledger.Babbage.Rules as Babbage -import Cardano.Ledger.Conway.Governance -- (govActionIdToText) +import Cardano.Ledger.Conway.Governance (govActionIdToText) import qualified Cardano.Ledger.Conway.Rules as Conway import Cardano.Ledger.Shelley.Rules import Cardano.Protocol.TPraos.API (ChainTransitionError (ChainTransitionError)) @@ -257,16 +256,15 @@ instance ( ShelleyBasedEra era instance ( ShelleyBasedEra era ) => ToObject (Conway.ConwayTallyPredFailure era) where - toObject = undefined - -- toObject _ (Conway.VoterDoesNotHaveRole credential voteRole) = - -- mconcat [ "kind" .= String "VoterDoesNotHaveRole" - -- , "credential" .= textShow credential - -- , "voteRole" .= textShow voteRole - -- ] - -- toObject _ (Conway.GovernanceActionDoesNotExist govActionId) = - -- mconcat [ "kind" .= String "GovernanceActionDoesNotExist" - -- , "credential" .= govActionIdToText govActionId - -- ] + toObject _ (Conway.VoterDoesNotHaveRole credential voteRole) = + mconcat [ "kind" .= String "VoterDoesNotHaveRole" + , "credential" .= textShow credential + , "voteRole" .= textShow voteRole + ] + toObject _ (Conway.GovernanceActionDoesNotExist govActionId) = + mconcat [ "kind" .= String "GovernanceActionDoesNotExist" + , "credential" .= govActionIdToText govActionId + ] instance ( ShelleyBasedEra era , ToJSON (Ledger.Value era) @@ -1242,7 +1240,3 @@ showLastAppBlockNo :: WithOrigin (LastAppliedBlock crypto) -> Text showLastAppBlockNo wOblk = case withOriginToMaybe wOblk of Nothing -> "Genesis Block" Just blk -> textShow . unBlockNo $ labBlockNo blk - --- Common to cardano-cli - -deriving newtype instance Core.Crypto crypto => ToJSON (Core.AuxiliaryDataHash crypto) From 8db4c0d2b567b868656c95a0ea92c1d4b2b87765 Mon Sep 17 00:00:00 2001 From: Alexey Kuleshevich Date: Thu, 23 Mar 2023 04:24:59 +0300 Subject: [PATCH 31/38] Some work on cardano-cli --- .../src/Cardano/Benchmarking/Script/Env.hs | 7 ++- .../src/Cardano/TxGenerator/Types.hs | 3 +- cardano-api/src/Cardano/Api/Fees.hs | 9 ++- cardano-api/src/Cardano/Api/LedgerState.hs | 6 +- cardano-api/src/Cardano/Api/Query.hs | 7 --- cardano-cli/cardano-cli.cabal | 3 + .../src/Cardano/CLI/Byron/Delegation.hs | 8 +-- cardano-cli/src/Cardano/CLI/Byron/Tx.hs | 5 +- cardano-cli/src/Cardano/CLI/Helpers.hs | 7 ++- .../src/Cardano/CLI/Shelley/Orphans.hs | 17 ----- .../src/Cardano/CLI/Shelley/Run/Genesis.hs | 63 +++++++++---------- .../src/Cardano/CLI/Shelley/Run/Governance.hs | 8 +-- .../src/Cardano/CLI/Shelley/Run/Query.hs | 42 +++++-------- 13 files changed, 78 insertions(+), 107 deletions(-) diff --git a/bench/tx-generator/src/Cardano/Benchmarking/Script/Env.hs b/bench/tx-generator/src/Cardano/Benchmarking/Script/Env.hs index 395d7b45a2d..9f48853792e 100644 --- a/bench/tx-generator/src/Cardano/Benchmarking/Script/Env.hs +++ b/bench/tx-generator/src/Cardano/Benchmarking/Script/Env.hs @@ -60,6 +60,7 @@ import Cardano.Benchmarking.OuroborosImports (NetworkId, PaymentKey, S SigningKey, StandardShelley) import Cardano.Benchmarking.Script.Types import Cardano.Benchmarking.Wallet +import Cardano.Ledger.Crypto (StandardCrypto) import Cardano.Node.Protocol.Types (SomeConsensusProtocol) import Ouroboros.Network.NodeToClient (IOManager) @@ -69,7 +70,7 @@ import Cardano.TxGenerator.Types (TxGenError (..)) data Env = Env { protoParams :: Maybe ProtocolParameterMode , benchTracers :: Maybe Tracer.BenchTracers - , envGenesis :: Maybe (ShelleyGenesis StandardShelley) + , envGenesis :: Maybe (ShelleyGenesis StandardCrypto) , envProtocol :: Maybe SomeConsensusProtocol , envNetworkId :: Maybe NetworkId , envSocketPath :: Maybe FilePath @@ -125,7 +126,7 @@ setProtoParamMode val = modifyEnv (\e -> e { protoParams = pure val }) setBenchTracers :: Tracer.BenchTracers -> ActionM () setBenchTracers val = modifyEnv (\e -> e { benchTracers = pure val }) -setEnvGenesis :: ShelleyGenesis StandardShelley -> ActionM () +setEnvGenesis :: ShelleyGenesis StandardCrypto -> ActionM () setEnvGenesis val = modifyEnv (\e -> e { envGenesis = pure val }) setEnvKeys :: String -> SigningKey PaymentKey -> ActionM () @@ -168,7 +169,7 @@ getProtoParamMode = getEnvVal protoParams "ProtocolParameterMode" getBenchTracers :: ActionM Tracer.BenchTracers getBenchTracers = getEnvVal benchTracers "BenchTracers" -getEnvGenesis :: ActionM (ShelleyGenesis StandardShelley) +getEnvGenesis :: ActionM (ShelleyGenesis StandardCrypto) getEnvGenesis = getEnvVal envGenesis "Genesis" getEnvKeys :: String -> ActionM (SigningKey PaymentKey) diff --git a/bench/tx-generator/src/Cardano/TxGenerator/Types.hs b/bench/tx-generator/src/Cardano/TxGenerator/Types.hs index 1935a1dee39..288b53cb1a1 100644 --- a/bench/tx-generator/src/Cardano/TxGenerator/Types.hs +++ b/bench/tx-generator/src/Cardano/TxGenerator/Types.hs @@ -16,6 +16,7 @@ import GHC.Natural import Cardano.Api import Cardano.Api.Shelley (ProtocolParameters) +import Cardano.Ledger.Crypto (StandardCrypto) import qualified Cardano.Ledger.Shelley.API as Ledger (ShelleyGenesis) import Ouroboros.Consensus.Shelley.Eras (StandardShelley) -- import Cardano.Node.Protocol.Types (SomeConsensusProtocol) @@ -23,7 +24,7 @@ import Ouroboros.Consensus.Shelley.Eras (StandardShelley) import Cardano.TxGenerator.Fund (Fund) -- convenience alias for use trhougout the API -type ShelleyGenesis = Ledger.ShelleyGenesis StandardShelley +type ShelleyGenesis = Ledger.ShelleyGenesis StandardCrypto -- some type aliases to keep compatibility with code in Cardano.Benchmarking type NumberOfInputsPerTx = Int diff --git a/cardano-api/src/Cardano/Api/Fees.hs b/cardano-api/src/Cardano/Api/Fees.hs index 915eabbf027..67392ec9b9d 100644 --- a/cardano-api/src/Cardano/Api/Fees.hs +++ b/cardano-api/src/Cardano/Api/Fees.hs @@ -53,7 +53,6 @@ import Data.Set (Set) import qualified Data.Set as Set import qualified Data.Text as Text import Lens.Micro ((^.)) -import Numeric.Natural import Prettyprinter import Prettyprinter.Render.String @@ -112,8 +111,8 @@ import Cardano.Api.Value -- transactionFee :: forall era. IsShelleyBasedEra era - => Natural -- ^ The fixed tx fee - -> Natural -- ^ The tx fee per byte + => Lovelace -- ^ The fixed tx fee + -> Lovelace -- ^ The tx fee per byte -> Tx era -> Lovelace transactionFee txFeeFixed txFeePerByte tx = @@ -154,8 +153,8 @@ transactionFee txFeeFixed txFeePerByte tx = estimateTransactionFee :: forall era. IsShelleyBasedEra era => NetworkId - -> Natural -- ^ The fixed tx fee - -> Natural -- ^ The tx fee per byte + -> Lovelace -- ^ The fixed tx fee + -> Lovelace -- ^ The tx fee per byte -> Tx era -> Int -- ^ The number of extra UTxO transaction inputs -> Int -- ^ The number of extra transaction outputs diff --git a/cardano-api/src/Cardano/Api/LedgerState.hs b/cardano-api/src/Cardano/Api/LedgerState.hs index 68ab0e055a5..ea704dc2e35 100644 --- a/cardano-api/src/Cardano/Api/LedgerState.hs +++ b/cardano-api/src/Cardano/Api/LedgerState.hs @@ -1451,7 +1451,7 @@ nextEpochEligibleLeadershipSlots => FromCBOR (Consensus.ChainDepState (Api.ConsensusProtocol era)) => Consensus.PraosProtocolSupportsNode (Api.ConsensusProtocol era) => ShelleyBasedEra era - -> ShelleyGenesis Shelley.StandardShelley + -> ShelleyGenesis Shelley.StandardCrypto -> SerialisedCurrentEpochState era -- ^ We need the mark stake distribution in order to predict -- the following epoch's leadership schedule @@ -1632,7 +1632,7 @@ currentEpochEligibleLeadershipSlots :: forall era ledgerera. () => Consensus.PraosProtocolSupportsNode (Api.ConsensusProtocol era) => FromCBOR (Consensus.ChainDepState (Api.ConsensusProtocol era)) => ShelleyBasedEra era - -> ShelleyGenesis Shelley.StandardShelley + -> ShelleyGenesis Shelley.StandardCrypto -> EpochInfo (Either Text) -> BundledProtocolParameters era -> ProtocolState era @@ -1679,7 +1679,7 @@ currentEpochEligibleLeadershipSlots sbe sGen eInfo bpp ptclState poolid (VrfSign f = activeSlotCoeff globals constructGlobals - :: ShelleyGenesis Shelley.StandardShelley + :: ShelleyGenesis Shelley.StandardCrypto -> EpochInfo (Either Text) -> ProtocolParameters -> Globals diff --git a/cardano-api/src/Cardano/Api/Query.hs b/cardano-api/src/Cardano/Api/Query.hs index f7a6d61c5bd..ca92a472f00 100644 --- a/cardano-api/src/Cardano/Api/Query.hs +++ b/cardano-api/src/Cardano/Api/Query.hs @@ -121,7 +121,6 @@ import Cardano.Slotting.Slot (WithOrigin (..)) import Cardano.Slotting.Time (SystemStart (..)) import qualified Cardano.Chain.Update.Validation.Interface as Byron.Update -import qualified Control.State.Transition.Extended as Ledger import Cardano.Ledger.Binary import qualified Cardano.Ledger.Binary.Plain as Plain @@ -139,13 +138,11 @@ import Cardano.Api.IPC.Version import Cardano.Api.Keys.Shelley import Cardano.Api.Modes import Cardano.Api.NetworkId -import Cardano.Api.Orphans () import Cardano.Api.ProtocolParameters import Cardano.Api.TxBody import Cardano.Api.Value import Data.Word (Word64) -import Cardano.Ledger.SafeHash (HashAnnotated) import qualified Data.Aeson.KeyMap as KeyMap -- ---------------------------------------------------------------------------- @@ -386,11 +383,7 @@ instance ( Typeable era , Core.EraTxOut (ShelleyLedgerEra era) , Core.EraGovernance (ShelleyLedgerEra era) - , FromCBOR (Core.PParams (ShelleyLedgerEra era)) , DecCBOR (Shelley.StashedAVVMAddresses (ShelleyLedgerEra era)) - , FromCBOR (Core.Value (ShelleyLedgerEra era)) - , FromCBOR (Ledger.State (Core.EraRule "PPUP" (ShelleyLedgerEra era))) - , HashAnnotated (Core.TxBody (ShelleyLedgerEra era)) Core.EraIndependentTxBody (Core.EraCrypto (ShelleyLedgerEra era)) ) => FromCBOR (DebugLedgerState era) where fromCBOR = DebugLedgerState <$> (fromCBOR :: Plain.Decoder s (Shelley.NewEpochState (ShelleyLedgerEra era))) diff --git a/cardano-cli/cardano-cli.cabal b/cardano-cli/cardano-cli.cabal index a5c29f861f5..c51087c0efb 100644 --- a/cardano-cli/cardano-cli.cabal +++ b/cardano-cli/cardano-cli.cabal @@ -117,7 +117,9 @@ library , cardano-ledger-alonzo ^>= 1.1 , cardano-ledger-allegra ^>= 1.1 , cardano-ledger-byron ^>= 1.0 + , cardano-ledger-binary >= 1.0 , cardano-ledger-core ^>= 1.1 + , cardano-ledger-conway ^>= 1.1 , cardano-ledger-mary ^>= 1.1 , cardano-ledger-shelley ^>= 1.1 , cardano-ping @@ -136,6 +138,7 @@ library , io-classes , iproute , mtl + , microlens , network , optparse-applicative-fork , ouroboros-consensus diff --git a/cardano-cli/src/Cardano/CLI/Byron/Delegation.hs b/cardano-cli/src/Cardano/CLI/Byron/Delegation.hs index a2c14d83910..f24872f5770 100644 --- a/cardano-cli/src/Cardano/CLI/Byron/Delegation.hs +++ b/cardano-cli/src/Cardano/CLI/Byron/Delegation.hs @@ -21,7 +21,7 @@ import Formatting (Format, sformat) import Cardano.Api.Byron -import Cardano.Binary (Annotated (..), serialize') +import Cardano.Ledger.Binary (Annotated (..), serialize', byronProtVer) import qualified Cardano.Chain.Delegation as Dlg import Cardano.Chain.Slotting (EpochNumber) import Cardano.Crypto (ProtocolMagicId) @@ -103,7 +103,7 @@ checkDlgCert cert magic issuerVK' delegateVK' = ] where magic' :: Annotated ProtocolMagicId ByteString - magic' = Annotated magic (serialize' magic) + magic' = Annotated magic (serialize' byronProtVer magic) epoch :: EpochNumber epoch = unAnnotated $ Dlg.aEpoch cert @@ -112,8 +112,8 @@ checkDlgCert cert magic issuerVK' delegateVK' = cert' = let unannotated = cert { Dlg.aEpoch = Annotated epoch () , Dlg.annotation = () } - in unannotated { Dlg.annotation = serialize' unannotated - , Dlg.aEpoch = Annotated epoch (serialize' epoch) } + in unannotated { Dlg.annotation = serialize' byronProtVer unannotated + , Dlg.aEpoch = Annotated epoch (serialize' byronProtVer epoch) } vkF :: forall r. Format r (Crypto.VerificationKey -> r) vkF = Crypto.fullVerificationKeyF diff --git a/cardano-cli/src/Cardano/CLI/Byron/Tx.hs b/cardano-cli/src/Cardano/CLI/Byron/Tx.hs index 0c721f4ca2e..a4e16beb915 100644 --- a/cardano-cli/src/Cardano/CLI/Byron/Tx.hs +++ b/cardano-cli/src/Cardano/CLI/Byron/Tx.hs @@ -42,6 +42,7 @@ import Formatting (sformat, (%)) import Cardano.Api import qualified Cardano.Binary as Binary +import qualified Cardano.Ledger.Binary.Decoding as LedgerBinary import qualified Cardano.Chain.Common as Common import Cardano.Chain.Genesis as Genesis @@ -255,8 +256,8 @@ fromCborTxAux lbs = <$> Binary.decodeFullDecoder "Cardano.Chain.UTxO.TxAux.fromCborTxAux" Binary.fromCBOR lbs where - annotationBytes :: Functor f => LB.ByteString -> f Binary.ByteSpan -> f B.ByteString - annotationBytes bytes = fmap (LB.toStrict . Binary.slice bytes) + annotationBytes :: Functor f => LB.ByteString -> f LedgerBinary.ByteSpan -> f B.ByteString + annotationBytes bytes = fmap (LB.toStrict . LedgerBinary.slice bytes) toCborTxAux :: UTxO.ATxAux ByteString -> LB.ByteString toCborTxAux = LB.fromStrict . UTxO.aTaAnnotation -- The ByteString anotation is the CBOR encoded version. diff --git a/cardano-cli/src/Cardano/CLI/Helpers.hs b/cardano-cli/src/Cardano/CLI/Helpers.hs index 511b631989e..03414091f5b 100644 --- a/cardano-cli/src/Cardano/CLI/Helpers.hs +++ b/cardano-cli/src/Cardano/CLI/Helpers.hs @@ -38,12 +38,13 @@ import System.Console.ANSI import qualified System.Directory as IO import qualified System.IO as IO -import Cardano.Binary (Decoder, fromCBOR) -import Cardano.Chain.Block (fromCBORABlockOrBoundary) +import Cardano.Chain.Block (decCBORABlockOrBoundary) import qualified Cardano.Chain.Delegation as Delegation import qualified Cardano.Chain.Update as Update import qualified Cardano.Chain.UTxO as UTxO import Cardano.CLI.Types +import Cardano.Ledger.Binary (byronProtVer, toPlainDecoder) +import Cardano.Ledger.Binary.Plain (Decoder, fromCBOR) data HelpersError = CBORPrettyPrintError !DeserialiseFailure @@ -112,7 +113,7 @@ validateCBOR :: CBORObject -> LB.ByteString -> Either HelpersError Text validateCBOR cborObject bs = case cborObject of CBORBlockByron epochSlots -> do - void $ decodeCBOR bs (fromCBORABlockOrBoundary epochSlots) + void $ decodeCBOR bs (toPlainDecoder byronProtVer (decCBORABlockOrBoundary epochSlots)) Right "Valid Byron block." CBORDelegationCertificateByron -> do diff --git a/cardano-cli/src/Cardano/CLI/Shelley/Orphans.hs b/cardano-cli/src/Cardano/CLI/Shelley/Orphans.hs index 690260a6303..24427521b15 100644 --- a/cardano-cli/src/Cardano/CLI/Shelley/Orphans.hs +++ b/cardano-cli/src/Cardano/CLI/Shelley/Orphans.hs @@ -15,13 +15,7 @@ module Cardano.CLI.Shelley.Orphans () where import Cardano.Api.Orphans () -import qualified Cardano.Ledger.AuxiliaryData as Ledger -import qualified Cardano.Ledger.Credential as Ledger -import qualified Cardano.Ledger.EpochBoundary as Ledger import qualified Cardano.Ledger.Crypto as CC (Crypto) -import qualified Cardano.Ledger.Mary.Value as Ledger.Mary -import qualified Cardano.Ledger.PoolDistr as Ledger -import qualified Cardano.Ledger.Shelley.PoolRank as Ledger import qualified Cardano.Protocol.TPraos.API as Ledger import Cardano.Protocol.TPraos.BHeader (HashHeader (..)) import qualified Cardano.Protocol.TPraos.Rules.Prtcl as Ledger @@ -32,7 +26,6 @@ import qualified Data.Aeson as Aeson import qualified Data.ByteString.Base16 as Base16 import qualified Data.ByteString.Short as SBS import qualified Data.Text.Encoding as Text -import qualified Data.VMap as VMap import Ouroboros.Consensus.Byron.Ledger.Block (ByronHash (..)) import Ouroboros.Consensus.HardFork.Combinator (OneEraHash (..)) import Ouroboros.Consensus.Protocol.Praos (PraosState) @@ -73,20 +66,10 @@ deriving newtype instance FromJSON BlockNo deriving newtype instance CC.Crypto crypto => ToJSON (ShelleyHash crypto) deriving newtype instance CC.Crypto crypto => ToJSON (HashHeader crypto) -deriving newtype instance ToJSON (Ledger.AuxiliaryDataHash StandardCrypto) -deriving newtype instance ToJSON Ledger.LogWeight -deriving newtype instance ToJSON (Ledger.PoolDistr StandardCrypto) - -deriving newtype instance ToJSON (Ledger.Stake StandardCrypto) - -deriving instance ToJSON (Ledger.StakeReference StandardCrypto) - deriving instance ToJSON (Ledger.PrtclState StandardCrypto) deriving instance ToJSON Ledger.TicknState deriving instance ToJSON (Ledger.ChainDepState StandardCrypto) -deriving newtype instance ToJSON (Ledger.Mary.PolicyID StandardCrypto) - instance ToJSON (TPraosState StandardCrypto) where toJSON s = Aeson.object [ "lastSlot" .= Consensus.tpraosStateLastSlot s diff --git a/cardano-cli/src/Cardano/CLI/Shelley/Run/Genesis.hs b/cardano-cli/src/Cardano/CLI/Shelley/Run/Genesis.hs index ab54da7f573..a0e8d58495b 100644 --- a/cardano-cli/src/Cardano/CLI/Shelley/Run/Genesis.hs +++ b/cardano-cli/src/Cardano/CLI/Shelley/Run/Genesis.hs @@ -63,16 +63,16 @@ import Data.String (fromString) import Data.Text (Text) import qualified Data.Text as Text import qualified Data.Text.IO as Text -import Data.Time.Clock (NominalDiffTime, UTCTime, addUTCTime, getCurrentTime, - secondsToNominalDiffTime) +import Data.Time.Clock (NominalDiffTime, UTCTime, addUTCTime, getCurrentTime) import Data.Word (Word64) import GHC.Generics (Generic) +import Lens.Micro ((^.)) import qualified System.IO as IO import qualified System.Random as Random import System.Random (StdGen) import Text.Read (readMaybe) -import Cardano.Binary (Annotated (Annotated), ToCBOR (..)) +import Cardano.Ledger.Binary (Annotated (Annotated), ToCBOR (..)) import qualified Cardano.Crypto as CC import Cardano.Crypto.Hash (HashAlgorithm) @@ -94,17 +94,16 @@ import Cardano.Api.Byron (toByronLovelace, toByronProtocolMagicId, toByronRequiresNetworkMagic) import Cardano.Api.Shelley -import Ouroboros.Consensus.Shelley.Eras (StandardShelley) import Ouroboros.Consensus.Shelley.Node (ShelleyGenesisStaking (..)) import qualified Cardano.Ledger.Alonzo.Genesis as Alonzo import qualified Cardano.Ledger.BaseTypes as Ledger import Cardano.Ledger.Coin (Coin (..)) -import Cardano.Ledger.Conway.Genesis () import qualified Cardano.Ledger.Conway.Genesis as Conway +import Cardano.Ledger.Core (ppMinUTxOValueL) import qualified Cardano.Ledger.Keys as Ledger import qualified Cardano.Ledger.Shelley.API as Ledger -import qualified Cardano.Ledger.Shelley.PParams as Shelley +import Cardano.Ledger.Shelley.Genesis (secondsToNominalDiffTimeMicro) import Cardano.Ledger.Crypto (ADDRHASH, Crypto, StandardCrypto) import Cardano.Ledger.Era () @@ -566,14 +565,14 @@ runGenesisCreateCardano (GenesisDir rootdir) , sgEpochLength = EpochSize $ floor $ (fromIntegral (unBlockCount mSecurity) * 10) / mSlotCoeff , sgMaxLovelaceSupply = 45000000000000000 , sgSystemStart = getSystemStart start - , sgSlotLength = secondsToNominalDiffTime $ MkFixed (fromIntegral slotLength) * 1000000000 + , sgSlotLength = secondsToNominalDiffTimeMicro $ MkFixed (fromIntegral slotLength) * 1000000 } shelleyGenesisTemplate <- liftIO $ overrideShelleyGenesis . fromRight (error "shelley genesis template not found") <$> readAndDecodeShelleyGenesis shelleyGenesisT alonzoGenesis <- readAlonzoGenesis alonzoGenesisT conwayGenesis <- readConwayGenesis conwayGenesisT (delegateMap, vrfKeys, kesKeys, opCerts) <- liftIO $ generateShelleyNodeSecrets shelleyDelegateKeys shelleyGenesisvkeys let - shelleyGenesis :: ShelleyGenesis StandardShelley + shelleyGenesis :: ShelleyGenesis StandardCrypto shelleyGenesis = updateTemplate start delegateMap Nothing [] mempty 0 [] [] shelleyGenesisTemplate liftIO $ do @@ -752,8 +751,8 @@ runGenesisCreateStaked (GenesisDir rootdir) stuffedUtxoAddrs <- liftIO $ Lazy.replicateM (fromIntegral numStuffedUtxo) genStuffedAddress - let stake = second Ledger._poolId . mkDelegationMapEntry <$> delegations - stakePools = [ (Ledger._poolId poolParams', poolParams') | poolParams' <- snd . mkDelegationMapEntry <$> delegations ] + let stake = second Ledger.ppId . mkDelegationMapEntry <$> delegations + stakePools = [ (Ledger.ppId poolParams', poolParams') | poolParams' <- snd . mkDelegationMapEntry <$> delegations ] delegAddrs = dInitialUtxoAddr <$> delegations !shelleyGenesis = updateCreateStakedOutputTemplate @@ -916,16 +915,16 @@ buildPoolParams nw dir index specifiedRelays = do . newExceptT $ readFileTextEnvelope (AsVerificationKey AsStakeKey) poolRewardVKF pure Ledger.PoolParams - { Ledger._poolId = Ledger.hashKey poolColdVK - , Ledger._poolVrf = Ledger.hashVerKeyVRF poolVrfVK - , Ledger._poolPledge = Ledger.Coin 0 - , Ledger._poolCost = Ledger.Coin 0 - , Ledger._poolMargin = minBound - , Ledger._poolRAcnt = + { Ledger.ppId = Ledger.hashKey poolColdVK + , Ledger.ppVrf = Ledger.hashVerKeyVRF poolVrfVK + , Ledger.ppPledge = Ledger.Coin 0 + , Ledger.ppCost = Ledger.Coin 0 + , Ledger.ppMargin = minBound + , Ledger.ppRewardAcnt = toShelleyStakeAddr $ makeStakeAddress nw $ StakeCredentialByKey (verificationKeyHash rewardsSVK) - , Ledger._poolOwners = mempty - , Ledger._poolRelays = lookupPoolRelay specifiedRelays - , Ledger._poolMD = Ledger.SNothing + , Ledger.ppOwners = mempty + , Ledger.ppRelays = lookupPoolRelay specifiedRelays + , Ledger.ppMetadata = Ledger.SNothing } where lookupPoolRelay @@ -997,8 +996,8 @@ getCurrentTimePlus30 = -- and if not found creates a default Shelley genesis. readShelleyGenesisWithDefault :: FilePath - -> (ShelleyGenesis StandardShelley -> ShelleyGenesis StandardShelley) - -> ExceptT ShelleyGenesisCmdError IO (ShelleyGenesis StandardShelley) + -> (ShelleyGenesis StandardCrypto -> ShelleyGenesis StandardCrypto) + -> ExceptT ShelleyGenesisCmdError IO (ShelleyGenesis StandardCrypto) readShelleyGenesisWithDefault fpath adjustDefaults = do newExceptT (readAndDecodeShelleyGenesis fpath) `catchError` \err -> @@ -1007,7 +1006,7 @@ readShelleyGenesisWithDefault fpath adjustDefaults = do | isDoesNotExistError ioe -> writeDefault _ -> left err where - defaults :: ShelleyGenesis StandardShelley + defaults :: ShelleyGenesis StandardCrypto defaults = adjustDefaults shelleyGenesisDefaults writeDefault = do @@ -1017,7 +1016,7 @@ readShelleyGenesisWithDefault fpath adjustDefaults = do readAndDecodeShelleyGenesis :: FilePath - -> IO (Either ShelleyGenesisCmdError (ShelleyGenesis StandardShelley)) + -> IO (Either ShelleyGenesisCmdError (ShelleyGenesis StandardCrypto)) readAndDecodeShelleyGenesis fpath = runExceptT $ do lbs <- handleIOExceptT (ShelleyGenesisCmdGenesisFileReadError . FileIOError fpath) $ LBS.readFile fpath firstExceptT (ShelleyGenesisCmdGenesisFileDecodeError fpath . Text.pack) @@ -1032,8 +1031,8 @@ updateTemplate -> Lovelace -- ^ Number of UTxO Addresses for delegation -> [AddressInEra ShelleyEra] -- ^ UTxO Addresses for delegation -> [AddressInEra ShelleyEra] -- ^ Stuffed UTxO addresses - -> ShelleyGenesis StandardShelley -- ^ Template from which to build a genesis - -> ShelleyGenesis StandardShelley -- ^ Updated genesis + -> ShelleyGenesis StandardCrypto -- ^ Template from which to build a genesis + -> ShelleyGenesis StandardCrypto -- ^ Updated genesis updateTemplate (SystemStart start) genDelegMap mAmountNonDeleg utxoAddrsNonDeleg poolSpecs (Lovelace amountDeleg) utxoAddrsDeleg stuffedUtxoAddrs @@ -1053,9 +1052,9 @@ updateTemplate (SystemStart start) , sgStaking = ShelleyGenesisStaking { sgsPools = ListMap.fromList - [ (Ledger._poolId poolParams, poolParams) + [ (Ledger.ppId poolParams, poolParams) | poolParams <- Map.elems poolSpecs ] - , sgsStake = ListMap.fromMap $ Ledger._poolId <$> poolSpecs + , sgsStake = ListMap.fromMap $ Ledger.ppId <$> poolSpecs } , sgProtocolParams = pparamsFromTemplate } @@ -1089,7 +1088,7 @@ updateTemplate (SystemStart start) mkStuffedUtxo :: [AddressInEra ShelleyEra] -> [(AddressInEra ShelleyEra, Lovelace)] mkStuffedUtxo xs = (, Lovelace minUtxoVal) <$> xs - where Coin minUtxoVal = Shelley._minUTxOValue $ sgProtocolParams template + where Coin minUtxoVal = sgProtocolParams template ^. ppMinUTxOValueL shelleyDelKeys = Map.fromList @@ -1113,8 +1112,8 @@ updateCreateStakedOutputTemplate -> Int -- ^ Number of UTxO address for delegationg -> [AddressInEra ShelleyEra] -- ^ UTxO address for delegationg -> [AddressInEra ShelleyEra] -- ^ Stuffed UTxO addresses - -> ShelleyGenesis StandardShelley -- ^ Template from which to build a genesis - -> ShelleyGenesis StandardShelley -- ^ Updated genesis + -> ShelleyGenesis StandardCrypto -- ^ Template from which to build a genesis + -> ShelleyGenesis StandardCrypto -- ^ Updated genesis updateCreateStakedOutputTemplate (SystemStart start) genDelegMap mAmountNonDeleg nUtxoAddrsNonDeleg utxoAddrsNonDeleg pools stake @@ -1160,7 +1159,7 @@ updateCreateStakedOutputTemplate mkStuffedUtxo :: [AddressInEra ShelleyEra] -> [(AddressInEra ShelleyEra, Lovelace)] mkStuffedUtxo xs = (, Lovelace minUtxoVal) <$> xs - where Coin minUtxoVal = Shelley._minUTxOValue $ sgProtocolParams template + where Coin minUtxoVal = sgProtocolParams template ^. ppMinUTxOValueL shelleyDelKeys = Map.fromList [ (gh, Ledger.GenDelegPair gdh h) @@ -1370,7 +1369,7 @@ renderProtocolParamsError (ProtocolParamsErrorGenesis err) = readProtocolParametersSourceSpec :: ProtocolParamsSourceSpec -> ExceptT ProtocolParamsError IO ProtocolParameters readProtocolParametersSourceSpec (ParamsFromGenesis (GenesisFile f)) = - fromShelleyPParams . sgProtocolParams + fromLedgerPParams ShelleyBasedEraShelley . sgProtocolParams <$> firstExceptT ProtocolParamsErrorGenesis (readShelleyGenesisWithDefault f id) readProtocolParametersSourceSpec (ParamsFromFile f) = readProtocolParameters f diff --git a/cardano-cli/src/Cardano/CLI/Shelley/Run/Governance.hs b/cardano-cli/src/Cardano/CLI/Shelley/Run/Governance.hs index beb79fb7847..4a855f87eb9 100644 --- a/cardano-cli/src/Cardano/CLI/Shelley/Run/Governance.hs +++ b/cardano-cli/src/Cardano/CLI/Shelley/Run/Governance.hs @@ -11,7 +11,6 @@ import Control.Monad.Trans.Except.Extra (firstExceptT, handleIOExceptT import Data.Aeson (eitherDecode) import qualified Data.ByteString.Lazy as LB import Data.Function ((&)) -import qualified Data.List as List import Data.Text (Text) import qualified Data.Text as Text @@ -23,7 +22,6 @@ import Cardano.CLI.Shelley.Key (VerificationKeyOrHashOrFile, import Cardano.CLI.Shelley.Parsers import Cardano.CLI.Types -import Cardano.Ledger.Alonzo.Scripts (CostModels (..)) import qualified Cardano.Ledger.Shelley.TxBody as Shelley @@ -162,9 +160,11 @@ runGovernanceUpdateProposal (OutputFile upFile) eNo genVerKeyFiles upPprams mCos cModels <- pure (eitherDecode costModelsBs) & onLeft (left . ShelleyGovernanceCmdCostModelsJsonDecodeErr fp . Text.pack) - when (List.null (unCostModels cModels)) $ left (ShelleyGovernanceCmdEmptyCostModel fp) + let costModels = fromAlonzoCostModels cModels - return $ upPprams {protocolUpdateCostModels = fromAlonzoCostModels cModels} + when (null costModels) $ left (ShelleyGovernanceCmdEmptyCostModel fp) + + return $ upPprams {protocolUpdateCostModels = costModels} when (finalUpPprams == mempty) $ left ShelleyGovernanceCmdEmptyUpdateProposalError diff --git a/cardano-cli/src/Cardano/CLI/Shelley/Run/Query.hs b/cardano-cli/src/Cardano/CLI/Shelley/Run/Query.hs index 95c89058cf0..b2d12b4db16 100644 --- a/cardano-cli/src/Cardano/CLI/Shelley/Run/Query.hs +++ b/cardano-cli/src/Cardano/CLI/Shelley/Run/Query.hs @@ -43,7 +43,6 @@ import Data.Coerce (coerce) import Data.List (nub) import qualified Data.Map.Strict as Map import qualified Data.Set as Set -import Data.Sharing (Interns, Share) import qualified Data.Text as Text import qualified Data.Text.Encoding as Text import qualified Data.Text.IO as T @@ -63,7 +62,6 @@ import Cardano.CLI.Pretty import Cardano.CLI.Shelley.Commands import Cardano.CLI.Shelley.Key (VerificationKeyOrHashOrFile, readVerificationKeyOrHashOrFile) -import Cardano.CLI.Shelley.Orphans () import qualified Cardano.CLI.Shelley.Output as O import Cardano.CLI.Shelley.Run.Genesis (ShelleyGenesisCmdError, readAndDecodeShelleyGenesis) @@ -71,19 +69,13 @@ import Cardano.CLI.Types import Cardano.Crypto.Hash (hashToBytesAsHex) import qualified Cardano.Crypto.Hash.Blake2b as Blake2b import qualified Cardano.Crypto.VRF as Crypto -import qualified Cardano.Ledger.Alonzo.PParams as Alonzo -import Cardano.Ledger.BaseTypes (Seed, UnitInterval) +import Cardano.Ledger.BaseTypes (Seed) import qualified Cardano.Ledger.Core as Core -import qualified Cardano.Ledger.Credential as Ledger import qualified Cardano.Ledger.Crypto as Crypto -import qualified Cardano.Ledger.Era as Era -import qualified Cardano.Ledger.Era as Ledger import Cardano.Ledger.Keys (KeyHash (..), KeyRole (..)) import Cardano.Ledger.SafeHash (HashAnnotated) -import Cardano.Ledger.Shelley.LedgerState (PState (_fPParams, _pParams, _retiring)) +import Cardano.Ledger.Shelley.LedgerState (PState (psFutureStakePoolParams, psStakePoolParams, psRetiring)) import qualified Cardano.Ledger.Shelley.LedgerState as SL -import qualified Cardano.Ledger.Shelley.PParams as Shelley -import Cardano.Ledger.Shelley.Scripts () import Cardano.Slotting.EpochInfo (EpochInfo (..), epochInfoSlotToUTCTime, hoistEpochInfo) import Ouroboros.Consensus.BlockchainTime.WallClock.Types (RelativeTime (..), @@ -111,7 +103,6 @@ import Data.Proxy (Proxy (..)) import Data.Set (Set) import Data.Text (Text) import Data.Text.Lazy (toStrict) -import GHC.Records (HasField) {- HLINT ignore "Move brackets to avoid $" -} {- HLINT ignore "Redundant flip" -} @@ -901,7 +892,7 @@ writeLedgerState mOutFile qState@(SerialisedDebugLedgerState serLedgerState) = writeStakeSnapshots :: forall era ledgerera. () => ShelleyLedgerEra era ~ ledgerera - => Era.Crypto ledgerera ~ StandardCrypto + => Core.EraCrypto ledgerera ~ StandardCrypto => Maybe OutputFile -> SerialisedStakeSnapshots era -> ExceptT ShelleyQueryCmdError IO () @@ -913,27 +904,28 @@ writeStakeSnapshots mOutFile qState = do liftIO . maybe LBS.putStrLn (LBS.writeFile . unOutputFile) mOutFile $ encodePretty snapshot -- | This function obtains the pool parameters, equivalent to the following jq query on the output of query ledger-state --- .nesEs.esLState._delegationState._pstate._pParams. +-- .nesEs.esLState.lsDPState.dpsPState.psStakePoolParams. writePoolState :: forall era ledgerera. () => ShelleyLedgerEra era ~ ledgerera - => Era.Crypto ledgerera ~ StandardCrypto - => Ledger.Era ledgerera + => Core.EraCrypto ledgerera ~ StandardCrypto + => Core.Era ledgerera => SerialisedPoolState era -> ExceptT ShelleyQueryCmdError IO () writePoolState serialisedCurrentEpochState = do PoolState poolState <- pure (decodePoolState serialisedCurrentEpochState) & onLeft (left . ShelleyQueryCmdPoolStateDecodeError) - let hks = Set.toList $ Set.fromList $ Map.keys (_pParams poolState) <> Map.keys (_fPParams poolState) <> Map.keys (_retiring poolState) + let hks = Set.toList $ Set.fromList $ Map.keys (psStakePoolParams poolState) + <> Map.keys (psFutureStakePoolParams poolState) <> Map.keys (psRetiring poolState) let poolStates :: Map (KeyHash 'StakePool StandardCrypto) (Params StandardCrypto) poolStates = Map.fromList $ hks <&> ( \hk -> ( hk , Params - { poolParameters = Map.lookup hk (SL._pParams poolState) - , futurePoolParameters = Map.lookup hk (SL._fPParams poolState) - , retiringEpoch = Map.lookup hk (SL._retiring poolState) + { poolParameters = Map.lookup hk (SL.psStakePoolParams poolState) + , futurePoolParameters = Map.lookup hk (SL.psFutureStakePoolParams poolState) + , retiringEpoch = Map.lookup hk (SL.psRetiring poolState) } ) ) @@ -1423,8 +1415,8 @@ obtainLedgerEraClassConstraints => Api.ShelleyBasedEra era -> (( ToJSON (DebugLedgerState era) , FromCBOR (DebugLedgerState era) - , Era.Crypto ledgerera ~ StandardCrypto - , Ledger.Era (ShelleyLedgerEra era) + , Core.EraCrypto ledgerera ~ StandardCrypto + , Core.Era (ShelleyLedgerEra era) ) => a) -> a obtainLedgerEraClassConstraints ShelleyBasedEraShelley f = f obtainLedgerEraClassConstraints ShelleyBasedEraAllegra f = f @@ -1438,13 +1430,11 @@ eligibleLeaderSlotsConstaints :: ShelleyLedgerEra era ~ ledgerera => ShelleyBasedEra era -> (( ShelleyLedgerEra era ~ ledgerera - , Ledger.Crypto ledgerera ~ StandardCrypto + , Core.EraCrypto ledgerera ~ StandardCrypto , Consensus.PraosProtocolSupportsNode (ConsensusProtocol era) , FromCBOR (Consensus.ChainDepState (ConsensusProtocol era)) - , Era.Era ledgerera - , HasField "_d" (Core.PParams (ShelleyLedgerEra era)) UnitInterval - , Crypto.Signable (Crypto.VRF (Ledger.Crypto ledgerera)) Seed - , Share (Core.TxOut (ShelleyLedgerEra era)) ~ Interns (Ledger.Credential 'Staking StandardCrypto) + , Core.Era ledgerera + , Crypto.Signable (Crypto.VRF (Core.EraCrypto ledgerera)) Seed , Crypto.ADDRHASH (Consensus.PraosProtocolSupportsNodeCrypto (ConsensusProtocol era)) ~ Blake2b.Blake2b_224 , HashAnnotated (Core.TxBody (ShelleyLedgerEra era)) From 00de306b9573cd2205f780175730c3a7301edfb1 Mon Sep 17 00:00:00 2001 From: Alexey Kuleshevich Date: Thu, 23 Mar 2023 04:37:32 +0300 Subject: [PATCH 32/38] Fixups --- cardano-api/src/Cardano/Api/ProtocolParameters.hs | 3 +-- cardano-api/src/Cardano/Api/Tx.hs | 6 +++--- cardano-node/src/Cardano/Node/Tracing/Era/Shelley.hs | 4 ++-- cardano-node/src/Cardano/Node/Tracing/Tracers/P2P.hs | 6 ------ cardano-node/src/Cardano/Tracing/OrphanInstances/Network.hs | 6 ------ cardano-node/src/Cardano/Tracing/OrphanInstances/Shelley.hs | 2 +- 6 files changed, 7 insertions(+), 20 deletions(-) diff --git a/cardano-api/src/Cardano/Api/ProtocolParameters.hs b/cardano-api/src/Cardano/Api/ProtocolParameters.hs index c740100ec3e..56928db4845 100644 --- a/cardano-api/src/Cardano/Api/ProtocolParameters.hs +++ b/cardano-api/src/Cardano/Api/ProtocolParameters.hs @@ -1,4 +1,3 @@ -{-# LANGUAGE BangPatterns #-} {-# LANGUAGE DeriveAnyClass #-} {-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE DerivingVia #-} @@ -1050,7 +1049,7 @@ toBabbagePParamsUpdate pure ppuBabbage requireParam :: String -> (a -> Either String b) -> Maybe a -> Either String b -requireParam paramName f = maybe (Left $ "Must specify " ++ paramName) f +requireParam paramName = maybe (Left $ "Must specify " ++ paramName) mkProtVer :: (Natural, Natural) -> Either String Ledger.ProtVer mkProtVer (majorProtVer, minorProtVer) = diff --git a/cardano-api/src/Cardano/Api/Tx.hs b/cardano-api/src/Cardano/Api/Tx.hs index 70e5170d09f..f766c064627 100644 --- a/cardano-api/src/Cardano/Api/Tx.hs +++ b/cardano-api/src/Cardano/Api/Tx.hs @@ -421,10 +421,10 @@ eraProtVerLow era = -- on disk witnesses for the cli's 'assemble' command. instance IsCardanoEra era => SerialiseAsCBOR (KeyWitness era) where serialiseToCBOR (ByronKeyWitness wit) = - CBOR.serialize' (CBOR.byronProtVer) wit + CBOR.serialize' CBOR.byronProtVer wit serialiseToCBOR (ShelleyKeyWitness era wit) = - CBOR.serialize' (eraProtVerLow era) $ + CBOR.serialize' (eraProtVerLow era) $ encodeShelleyBasedKeyWitness wit serialiseToCBOR (ShelleyBootstrapWitness era wit) = @@ -627,7 +627,7 @@ makeSignedTransaction witnesses (ShelleyTxBody era txbody => Ledger.EraCrypto ledgerera ~ StandardCrypto => Ledger.EraTx ledgerera => Tx era - shelleySignedTransaction = ShelleyTx era $ txCommon + shelleySignedTransaction = ShelleyTx era txCommon alonzoSignedTransaction :: forall ledgerera. diff --git a/cardano-node/src/Cardano/Node/Tracing/Era/Shelley.hs b/cardano-node/src/Cardano/Node/Tracing/Era/Shelley.hs index 4dad8ec3973..103510ba1ac 100644 --- a/cardano-node/src/Cardano/Node/Tracing/Era/Shelley.hs +++ b/cardano-node/src/Cardano/Node/Tracing/Era/Shelley.hs @@ -69,7 +69,7 @@ import Cardano.Ledger.Shelley.Rules import Cardano.Ledger.Allegra.Rules (AllegraUtxoPredFailure) import qualified Cardano.Ledger.Allegra.Rules as Allegra -import Cardano.Ledger.Conway.Governance -- (govActionIdToText) +import Cardano.Ledger.Conway.Governance (govActionIdToText) import Cardano.Ledger.Alonzo.Rules (AlonzoBbodyPredFailure, AlonzoUtxoPredFailure, AlonzoUtxosPredFailure, AlonzoUtxowPredFailure (..)) import qualified Cardano.Ledger.Alonzo.Rules as Alonzo @@ -1048,7 +1048,7 @@ instance ( ShelleyBasedEra era ] forMachine _ (Conway.GovernanceActionDoesNotExist govActionId) = mconcat [ "kind" .= String "GovernanceActionDoesNotExist" - , "credential" .= govActionIdToText govActionId + , "govActionId" .= govActionIdToText govActionId ] diff --git a/cardano-node/src/Cardano/Node/Tracing/Tracers/P2P.hs b/cardano-node/src/Cardano/Node/Tracing/Tracers/P2P.hs index aa248ee0849..7ca3b29fa3c 100644 --- a/cardano-node/src/Cardano/Node/Tracing/Tracers/P2P.hs +++ b/cardano-node/src/Cardano/Node/Tracing/Tracers/P2P.hs @@ -760,11 +760,6 @@ instance (Show addr, Show versionNumber, Show agreedOptions, LogFormatting addr, [ "kind" .= String "ForbiddenConnection" , "connectionId" .= toJSON connId ] - -- forMachine _dtal (TrImpossibleConnection connId) = - -- mconcat - -- [ "kind" .= String "ImpossibleConnection" - -- , "connectionId" .= toJSON connId - -- ] forMachine _dtal (TrConnectionFailure connId) = mconcat [ "kind" .= String "ConnectionFailure" @@ -882,7 +877,6 @@ instance MetaTrace (ConnectionManagerTrace addr namespaceFor TrShutdown {} = Namespace [] ["Shutdown"] namespaceFor TrConnectionExists {} = Namespace [] ["ConnectionExists"] namespaceFor TrForbiddenConnection {} = Namespace [] ["ForbiddenConnection"] - -- namespaceFor TrImpossibleConnection {} = Namespace [] ["ImpossibleConnection"] namespaceFor TrConnectionFailure {} = Namespace [] ["ConnectionFailure"] namespaceFor TrConnectionNotFound {} = Namespace [] ["ConnectionNotFound"] namespaceFor TrForbiddenOperation {} = Namespace [] ["ForbiddenOperation"] diff --git a/cardano-node/src/Cardano/Tracing/OrphanInstances/Network.hs b/cardano-node/src/Cardano/Tracing/OrphanInstances/Network.hs index c1a7cec4610..ea7a680c140 100644 --- a/cardano-node/src/Cardano/Tracing/OrphanInstances/Network.hs +++ b/cardano-node/src/Cardano/Tracing/OrphanInstances/Network.hs @@ -457,7 +457,6 @@ instance HasSeverityAnnotation (ConnectionManagerTrace addr (ConnectionHandlerTr TrShutdown -> Info TrConnectionExists {} -> Info TrForbiddenConnection {} -> Info - -- TrImpossibleConnection {} -> Info TrConnectionFailure {} -> Info TrConnectionNotFound {} -> Debug TrForbiddenOperation {} -> Info @@ -1902,11 +1901,6 @@ instance (Show addr, Show versionNumber, Show agreedOptions, ToObject addr, [ "kind" .= String "ForbiddenConnection" , "connectionId" .= toJSON connId ] - -- TrImpossibleConnection connId -> - -- mconcat - -- [ "kind" .= String "ImpossibleConnection" - -- , "connectionId" .= toJSON connId - -- ] TrConnectionFailure connId -> mconcat [ "kind" .= String "ConnectionFailure" diff --git a/cardano-node/src/Cardano/Tracing/OrphanInstances/Shelley.hs b/cardano-node/src/Cardano/Tracing/OrphanInstances/Shelley.hs index ae2e4e760f1..4d12983d48e 100644 --- a/cardano-node/src/Cardano/Tracing/OrphanInstances/Shelley.hs +++ b/cardano-node/src/Cardano/Tracing/OrphanInstances/Shelley.hs @@ -263,7 +263,7 @@ instance ( ShelleyBasedEra era ] toObject _ (Conway.GovernanceActionDoesNotExist govActionId) = mconcat [ "kind" .= String "GovernanceActionDoesNotExist" - , "credential" .= govActionIdToText govActionId + , "govActionId" .= govActionIdToText govActionId ] instance ( ShelleyBasedEra era From 1d8b9e3a446d36530848cabaf961836b18b80f59 Mon Sep 17 00:00:00 2001 From: Alexey Kuleshevich Date: Thu, 23 Mar 2023 04:51:50 +0300 Subject: [PATCH 33/38] Fix cardano-api and cardano-cli test suites and get rid of warnings ``` Test suite cardano-node-test: RUNNING... cardano-node-test: : commitBuffer: invalid argument (invalid character) ``` --- cabal.project | 8 ++++---- cardano-api/src/Cardano/Api/Query.hs | 3 --- cardano-api/test/Golden/ShelleyGenesis | 2 +- cardano-api/test/cardano-api-test.hs | 11 +++++++++++ cardano-node/cardano-node.cabal | 2 -- cardano-node/test/cardano-node-test.hs | 26 ++++++++++++++++++-------- 6 files changed, 34 insertions(+), 18 deletions(-) diff --git a/cabal.project b/cabal.project index c12c80f901f..97044f80a80 100644 --- a/cabal.project +++ b/cabal.project @@ -43,14 +43,14 @@ packages: program-options ghc-options: -Werror --- package cardano-api --- ghc-options: -Werror +package cardano-api + ghc-options: -Werror -- package cardano-cli -- ghc-options: -Werror --- package cardano-node --- -- ghc-options: -Werror +package cardano-node + ghc-options: -Werror -- package cardano-node-chairman -- ghc-options: -Werror diff --git a/cardano-api/src/Cardano/Api/Query.hs b/cardano-api/src/Cardano/Api/Query.hs index ca92a472f00..45f19f3c32e 100644 --- a/cardano-api/src/Cardano/Api/Query.hs +++ b/cardano-api/src/Cardano/Api/Query.hs @@ -392,9 +392,6 @@ instance instance ( IsShelleyBasedEra era , ShelleyLedgerEra era ~ ledgerera , Consensus.ShelleyBasedEra ledgerera - , ToJSON (Core.PParams ledgerera) - , ToJSON (Core.PParamsUpdate ledgerera) - , ToJSON (Core.TxOut ledgerera) ) => ToJSON (DebugLedgerState era) where toJSON = object . toDebugLedgerStatePair toEncoding = Aeson.pairs . mconcat . toDebugLedgerStatePair diff --git a/cardano-api/test/Golden/ShelleyGenesis b/cardano-api/test/Golden/ShelleyGenesis index f4313e5a6f9..e681db0ac35 100644 --- a/cardano-api/test/Golden/ShelleyGenesis +++ b/cardano-api/test/Golden/ShelleyGenesis @@ -4,7 +4,7 @@ "poolDeposit": 0, "protocolVersion": { "minor": 0, - "major": 0 + "major": 2 }, "minUTxOValue": 0, "decentralisationParam": 1.9e-2, diff --git a/cardano-api/test/cardano-api-test.hs b/cardano-api/test/cardano-api-test.hs index 59a0dbb5930..373d9b83fc2 100644 --- a/cardano-api/test/cardano-api-test.hs +++ b/cardano-api/test/cardano-api-test.hs @@ -1,3 +1,12 @@ +module Main where + +import System.IO ( + BufferMode (LineBuffering), + hSetBuffering, + hSetEncoding, + stdout, + utf8, + ) import Cardano.Crypto.Libsodium (sodiumInit) @@ -23,6 +32,8 @@ main :: IO () main = do -- TODO: Remove sodiumInit: https://github.com/input-output-hk/cardano-base/issues/175 sodiumInit + hSetBuffering stdout LineBuffering + hSetEncoding stdout utf8 defaultMain tests tests :: TestTree diff --git a/cardano-node/cardano-node.cabal b/cardano-node/cardano-node.cabal index 30ba3830e3c..f00e04a8cb7 100644 --- a/cardano-node/cardano-node.cabal +++ b/cardano-node/cardano-node.cabal @@ -138,7 +138,6 @@ library , base16-bytestring , bytestring , cardano-api - , cardano-data ^>= 1.0 , cardano-git-rev , cardano-crypto-class , cardano-crypto-wrapper @@ -149,7 +148,6 @@ library , cardano-ledger-conway , cardano-ledger-core , cardano-ledger-shelley - , cardano-ledger-mary , cardano-prelude , cardano-protocol-tpraos ^>= 1.0 , cardano-slotting ^>= 0.1 diff --git a/cardano-node/test/cardano-node-test.hs b/cardano-node/test/cardano-node-test.hs index 358b3ea6cff..d9623dd0431 100644 --- a/cardano-node/test/cardano-node-test.hs +++ b/cardano-node/test/cardano-node-test.hs @@ -5,6 +5,13 @@ #endif import Hedgehog.Main (defaultMain) +import System.IO ( + BufferMode (LineBuffering), + hSetBuffering, + hSetEncoding, + stdout, + utf8, + ) #ifdef UNIX import qualified Test.Cardano.Node.FilePermissions @@ -13,15 +20,18 @@ import qualified Test.Cardano.Node.Json import qualified Test.Cardano.Node.POM main :: IO () -main = defaultMain +main = do + hSetBuffering stdout LineBuffering + hSetEncoding stdout utf8 + defaultMain #ifdef UNIX - [ Test.Cardano.Node.Json.tests - , Test.Cardano.Node.POM.tests - , Test.Cardano.Node.FilePermissions.tests - ] + [ Test.Cardano.Node.Json.tests + , Test.Cardano.Node.POM.tests + , Test.Cardano.Node.FilePermissions.tests + ] #else - [ Test.Cardano.Node.Json.tests - , Test.Cardano.Node.POM.tests - ] + [ Test.Cardano.Node.Json.tests + , Test.Cardano.Node.POM.tests + ] #endif From 30c04bbad2ee08607160236d04852d993efe1d31 Mon Sep 17 00:00:00 2001 From: Alexey Kuleshevich Date: Thu, 23 Mar 2023 05:22:35 +0300 Subject: [PATCH 34/38] cardano-client-demo builds --- cardano-client-demo/StakeCredentialHistory.hs | 32 +++++++++---------- cardano-client-demo/cardano-client-demo.cabal | 8 ++--- .../Tracing/OrphanInstances/Shelley.hs | 14 +------- 3 files changed, 19 insertions(+), 35 deletions(-) diff --git a/cardano-client-demo/StakeCredentialHistory.hs b/cardano-client-demo/StakeCredentialHistory.hs index 4fc95f40204..39ba88f0cd1 100644 --- a/cardano-client-demo/StakeCredentialHistory.hs +++ b/cardano-client-demo/StakeCredentialHistory.hs @@ -8,25 +8,22 @@ import Cardano.Api import Cardano.Api.Shelley -import Cardano.Ledger.Address (getRewardAcnt) -import Cardano.Ledger.Alonzo.PParams (AlonzoPParamsHKD (..)) -import Cardano.Ledger.Babbage.PParams (BabbagePParamsHKD (..)) +import Cardano.Ledger.Address (decodeRewardAcnt) import qualified Cardano.Ledger.BaseTypes as L import Cardano.Ledger.Compactible (Compactible (..)) import qualified Cardano.Ledger.Core as LC import qualified Cardano.Ledger.Shelley.API as L import qualified Cardano.Ledger.Shelley.Rewards as L import qualified Cardano.Ledger.Shelley.RewardUpdate as L -import qualified Cardano.Ledger.UnifiedMap as UM +import qualified Cardano.Ledger.UMapCompact as UM import Ouroboros.Consensus.Shelley.Eras (StandardCrypto) import qualified Ouroboros.Consensus.Shelley.Ledger as Shelley import qualified Codec.Binary.Bech32 as Bech32 import Control.Monad.Trans.Except (runExceptT) -import qualified Data.Binary.Get as B +import Control.Monad.Trans.Fail.String import qualified Data.ByteString as BS import qualified Data.ByteString.Base16 as Base16 -import qualified Data.ByteString.Lazy as BSL import Data.Char (ord) import Data.Foldable (toList) import Data.List (intercalate) @@ -34,9 +31,8 @@ import qualified Data.Map.Strict as Map import Data.Maybe (mapMaybe) import Data.Set (Set) import qualified Data.Text as T -import qualified Data.UMap as UM import qualified Data.VMap as VMap -import GHC.Records (HasField (..)) +import Lens.Micro ((^.)) import Options.Applicative (Parser, (<**>), (<|>)) import qualified Options.Applicative as Opt @@ -56,7 +52,7 @@ startingState = State , lastRewStartEpoch = EpochNo 0 , lastRewEndEpoch = EpochNo 0 , lastEra = "byron" - , lastProtocolVer = L.ProtVer 0 0 + , lastProtocolVer = L.ProtVer (L.natVersion @0) 0 } data IsOwner = IsOwnerYes | IsOwnerNo @@ -155,9 +151,7 @@ msg ev = putStrLn (message ev) show t <> "-" <> (tail . init $ show kh) <> "-" <> show (fromShelleyLovelace love) decodeStakeAddress :: BS.ByteString -> Either String (L.RewardAcnt StandardCrypto) -decodeStakeAddress bs = case B.runGetOrFail getRewardAcnt (BSL.fromStrict bs) of - Left (_remaining, _offset, message) -> Left message - Right (_remaining, _offset, result) -> Right result +decodeStakeAddress bs = runFail $ decodeRewardAcnt bs decodeStakeAddressAsHex :: String -> Either String (L.Credential 'L.Staking StandardCrypto) decodeStakeAddressAsHex s = do @@ -261,11 +255,15 @@ main = do (Block (BlockHeader slotNo _blockHeaderHash (BlockNo _blockNoI)) transactions) _era) state -> do - let getGoSnapshot = L.unStake . L._stake . L._pstakeGo . L.esSnapshots . L.nesEs - getBalances = UM.unUnify . UM.Rewards . L._unified . L.dpsDState . L.lsDPState . L.esLState . L.nesEs - getPV :: HasField "_protocolVersion" (LC.PParams era) L.ProtVer => - L.NewEpochState era -> L.ProtVer - getPV = getField @"_protocolVersion" . L.esPp . L.nesEs + let getGoSnapshot = L.unStake . L.ssStake . L.ssStakeGo . L.esSnapshots . L.nesEs + getBalances = UM.rewView + . L.dsUnified + . L.dpsDState + . L.lsDPState + . L.esLState + . L.nesEs + getPV :: LC.EraPParams era => L.NewEpochState era -> L.ProtVer + getPV nes = L.esPp (L.nesEs nes) ^. LC.ppProtocolVersionL -- in non-byron eras, get the necessary components of the ledger state diff --git a/cardano-client-demo/cardano-client-demo.cabal b/cardano-client-demo/cardano-client-demo.cabal index 1ac7b086821..d69aae0be5b 100644 --- a/cardano-client-demo/cardano-client-demo.cabal +++ b/cardano-client-demo/cardano-client-demo.cabal @@ -96,18 +96,16 @@ executable stake-credential-history -Wredundant-constraints -Wunused-packages build-depends: base16-bytestring, - binary, bech32, bytestring, - cardano-ledger-alonzo, cardano-api, - cardano-data, - cardano-ledger-babbage, cardano-ledger-core, cardano-ledger-shelley, - vector-map, containers, + FailT, + microlens, optparse-applicative, ouroboros-consensus-shelley, text, transformers, + vector-map, diff --git a/cardano-node/src/Cardano/Tracing/OrphanInstances/Shelley.hs b/cardano-node/src/Cardano/Tracing/OrphanInstances/Shelley.hs index 4d12983d48e..d4649bfae03 100644 --- a/cardano-node/src/Cardano/Tracing/OrphanInstances/Shelley.hs +++ b/cardano-node/src/Cardano/Tracing/OrphanInstances/Shelley.hs @@ -267,8 +267,6 @@ instance ( ShelleyBasedEra era ] instance ( ShelleyBasedEra era - , ToJSON (Ledger.Value era) - , ToJSON (Ledger.TxOut era) , ToObject (PPUPPredFailure era) , ToObject (PredicateFailure (Ledger.EraRule "UTXO" era)) , Ledger.EraCrypto era ~ StandardCrypto @@ -381,8 +379,6 @@ instance ( ShelleyBasedEra era ] instance ( ShelleyBasedEra era - , ToJSON (Core.Value era) - , ToJSON (Core.TxOut era) , ToObject (PPUPPredFailure era) ) => ToObject (ShelleyUtxoPredFailure era) where @@ -451,8 +447,6 @@ instance ToJSON Allegra.ValidityInterval where mbfield (SJust x) = [x] instance ( ShelleyBasedEra era - , ToJSON (Core.Value era) - , ToJSON (Core.TxOut era) , ToObject (PPUPPredFailure era) ) => ToObject (AllegraUtxoPredFailure era) where toObject _verb (Allegra.BadInputsUTxO badInputs) = @@ -892,8 +886,6 @@ instance ToObject (ShelleyUpecPredFailure era) where instance ( Ledger.Era era - , ToJSON (Ledger.Value era) - , ToJSON (Ledger.TxOut era) , ToObject (PredicateFailure (Ledger.EraRule "UTXOS" era)) , ToObject (PPUPPredFailure era) , ShelleyBasedEra era @@ -1096,9 +1088,7 @@ instance ( Ledger.Era era -- Babbage related -------------------------------------------------------------------------------- -instance ( ToJSON (Ledger.Value era) - , ToJSON (Ledger.TxOut era) - , ShelleyBasedEra era +instance ( ShelleyBasedEra era , ToObject (ShelleyUtxowPredFailure era) , ToObject (PredicateFailure (Ledger.EraRule "UTXOS" era)) , ToObject (PPUPPredFailure era) @@ -1121,8 +1111,6 @@ instance ( ToJSON (Ledger.Value era) instance ( Ledger.Era era , ShelleyBasedEra era , Ledger.EraCrypto era ~ StandardCrypto - , ToJSON (Ledger.Value era) - , ToJSON (Ledger.TxOut era) , ToObject (PPUPPredFailure era) , ToObject (PredicateFailure (Ledger.EraRule "UTXO" era)) ) => ToObject (BabbageUtxowPredFailure era) where From 7149b716647a7cd2b22dde3f8290331f864b6c7f Mon Sep 17 00:00:00 2001 From: Alexey Kuleshevich Date: Thu, 23 Mar 2023 17:19:21 +0300 Subject: [PATCH 35/38] Fix building tx-generator --- .../src/Cardano/Benchmarking/Script/Env.hs | 2 +- .../src/Cardano/TxGenerator/Setup/Plutus.hs | 3 +- .../src/Cardano/TxGenerator/Types.hs | 1 - bench/tx-generator/tx-generator.cabal | 1 + cabal.project | 4 +- cardano-api/src/Cardano/Api/LedgerState.hs | 104 +++++++++--------- .../src/Cardano/Api/ProtocolParameters.hs | 2 +- cardano-api/src/Cardano/Api/Query.hs | 32 +++--- cardano-api/test/cardano-api-test.hs | 8 +- cardano-cli/cardano-cli.cabal | 3 +- cardano-cli/src/Cardano/CLI/Byron/Parsers.hs | 2 +- cardano-cli/test/cardano-cli-test.hs | 8 +- cardano-node/test/cardano-node-test.hs | 8 +- cardano-testnet/test/Main.hs | 3 + 14 files changed, 89 insertions(+), 92 deletions(-) diff --git a/bench/tx-generator/src/Cardano/Benchmarking/Script/Env.hs b/bench/tx-generator/src/Cardano/Benchmarking/Script/Env.hs index 9f48853792e..ffe9c9ff44a 100644 --- a/bench/tx-generator/src/Cardano/Benchmarking/Script/Env.hs +++ b/bench/tx-generator/src/Cardano/Benchmarking/Script/Env.hs @@ -57,7 +57,7 @@ import Prelude import Cardano.Benchmarking.GeneratorTx import qualified Cardano.Benchmarking.LogTypes as Tracer import Cardano.Benchmarking.OuroborosImports (NetworkId, PaymentKey, ShelleyGenesis, - SigningKey, StandardShelley) + SigningKey) import Cardano.Benchmarking.Script.Types import Cardano.Benchmarking.Wallet import Cardano.Ledger.Crypto (StandardCrypto) diff --git a/bench/tx-generator/src/Cardano/TxGenerator/Setup/Plutus.hs b/bench/tx-generator/src/Cardano/TxGenerator/Setup/Plutus.hs index 2ede993c547..6a06e6592c7 100644 --- a/bench/tx-generator/src/Cardano/TxGenerator/Setup/Plutus.hs +++ b/bench/tx-generator/src/Cardano/TxGenerator/Setup/Plutus.hs @@ -176,5 +176,4 @@ preExecutePlutusV2 protocolVersion_ (PlutusScript _ (PlutusScriptSerialised scri -- However, we're bound to the type `Cardano.Api.ProtocolParameters.CostModel` which -- might be changed from a key-value map to something providing stronger guarantees. flattenCostModel :: CostModel -> [Integer] -flattenCostModel (CostModel cm) - = snd <$> Map.toAscList cm +flattenCostModel (CostModel cm) = cm diff --git a/bench/tx-generator/src/Cardano/TxGenerator/Types.hs b/bench/tx-generator/src/Cardano/TxGenerator/Types.hs index 288b53cb1a1..a0f3b673f81 100644 --- a/bench/tx-generator/src/Cardano/TxGenerator/Types.hs +++ b/bench/tx-generator/src/Cardano/TxGenerator/Types.hs @@ -18,7 +18,6 @@ import Cardano.Api import Cardano.Api.Shelley (ProtocolParameters) import Cardano.Ledger.Crypto (StandardCrypto) import qualified Cardano.Ledger.Shelley.API as Ledger (ShelleyGenesis) -import Ouroboros.Consensus.Shelley.Eras (StandardShelley) -- import Cardano.Node.Protocol.Types (SomeConsensusProtocol) import Cardano.TxGenerator.Fund (Fund) diff --git a/bench/tx-generator/tx-generator.cabal b/bench/tx-generator/tx-generator.cabal index 031cf7cd637..61b443e98ca 100644 --- a/bench/tx-generator/tx-generator.cabal +++ b/bench/tx-generator/tx-generator.cabal @@ -98,6 +98,7 @@ library , cardano-git-rev , cardano-ledger-alonzo , cardano-ledger-byron + , cardano-ledger-core , cardano-node , cardano-prelude , contra-tracer diff --git a/cabal.project b/cabal.project index 97044f80a80..fea81252f2a 100644 --- a/cabal.project +++ b/cabal.project @@ -149,8 +149,8 @@ source-repository-package source-repository-package type: git location: https://github.com/input-output-hk/cardano-ledger - tag: 79ac5fb0600c8b84c05742ab052018236c225927 - --sha256: 17hanlp66syjszx6dbd9v1hkm7hbmx7ppv5xjgr17xdsjr9j5zwh + tag: 9a586179d788aaa8d80dd6513810a7b399c3cd72 + --sha256: 15xg2hs36gc2gm6nqwvas1dznba74lsp4n2rf1izi2nvc6n24qs0 subdir: eras/alonzo/impl eras/alonzo/test-suite diff --git a/cardano-api/src/Cardano/Api/LedgerState.hs b/cardano-api/src/Cardano/Api/LedgerState.hs index ea704dc2e35..e5b268ba908 100644 --- a/cardano-api/src/Cardano/Api/LedgerState.hs +++ b/cardano-api/src/Cardano/Api/LedgerState.hs @@ -126,7 +126,7 @@ import Cardano.Ledger.Alonzo.Genesis (AlonzoGenesis (..)) import Cardano.Ledger.BaseTypes (Globals (..), Nonce, (⭒)) import qualified Cardano.Ledger.BaseTypes as Ledger import qualified Cardano.Ledger.BHeaderView as Ledger -import Cardano.Ledger.Binary (DecCBOR, DecoderError, FromCBOR, mkVersion) +import Cardano.Ledger.Binary (DecoderError, FromCBOR, mkVersion) import qualified Cardano.Ledger.Credential as Ledger import qualified Cardano.Ledger.Keys as Ledger import qualified Cardano.Ledger.Keys as SL @@ -1446,8 +1446,8 @@ instance Error LeadershipError where nextEpochEligibleLeadershipSlots :: forall era. () - => Core.EraTxOut (ShelleyLedgerEra era) - => Core.EraGovernance (ShelleyLedgerEra era) + -- => Core.EraTxOut (ShelleyLedgerEra era) + -- => Core.EraGovernance (ShelleyLedgerEra era) => FromCBOR (Consensus.ChainDepState (Api.ConsensusProtocol era)) => Consensus.PraosProtocolSupportsNode (Api.ConsensusProtocol era) => ShelleyBasedEra era @@ -1510,27 +1510,41 @@ nextEpochEligibleLeadershipSlots sbe sGen serCurrEpochState ptclState poolid (Vr -- Then we get the "mark" snapshot. This snapshot will be used for the next -- epoch's leadership schedule. - CurrentEpochState cEstate <- first LeaderErrDecodeProtocolEpochStateFailure - $ obtainDecodeEpochStateConstraints sbe - $ decodeCurrentEpochState serCurrEpochState + -- CurrentEpochState cEstate <- first LeaderErrDecodeProtocolEpochStateFailure + -- $ obtainDecodeEpochStateConstraints sbe + -- $ decodeCurrentEpochState serCurrEpochState + CurrentEpochState cEstate <- first LeaderErrDecodeProtocolEpochStateFailure $ + decodeCurrentEpochState sbe serCurrEpochState let snapshot :: ShelleyAPI.SnapShot Shelley.StandardCrypto snapshot = ShelleyAPI.ssStakeMark $ obtainIsStandardCrypto sbe $ ShelleyAPI.esSnapshots cEstate markSnapshotPoolDistr :: Map (SL.KeyHash 'SL.StakePool Shelley.StandardCrypto) (SL.IndividualPoolStake Shelley.StandardCrypto) markSnapshotPoolDistr = ShelleyAPI.unPoolDistr . ShelleyAPI.calculatePoolDistr $ snapshot - let pp = unbundleLedgerShelleyBasedProtocolParams sbe bpp - slotRangeOfInterest = Set.filter + let slotRangeOfInterest :: Core.EraPParams ledgerera => Core.PParams ledgerera -> Set SlotNo + slotRangeOfInterest pp = Set.filter (not . Ledger.isOverlaySlot firstSlotOfEpoch (pp ^. Core.ppDG)) $ Set.fromList [firstSlotOfEpoch .. lastSlotofEpoch] case sbe of - ShelleyBasedEraShelley -> isLeadingSlotsTPraos slotRangeOfInterest poolid markSnapshotPoolDistr nextEpochsNonce vrfSkey f - ShelleyBasedEraAllegra -> isLeadingSlotsTPraos slotRangeOfInterest poolid markSnapshotPoolDistr nextEpochsNonce vrfSkey f - ShelleyBasedEraMary -> isLeadingSlotsTPraos slotRangeOfInterest poolid markSnapshotPoolDistr nextEpochsNonce vrfSkey f - ShelleyBasedEraAlonzo -> isLeadingSlotsTPraos slotRangeOfInterest poolid markSnapshotPoolDistr nextEpochsNonce vrfSkey f - ShelleyBasedEraBabbage -> isLeadingSlotsPraos slotRangeOfInterest poolid markSnapshotPoolDistr nextEpochsNonce vrfSkey f - ShelleyBasedEraConway -> isLeadingSlotsPraos slotRangeOfInterest poolid markSnapshotPoolDistr nextEpochsNonce vrfSkey f + ShelleyBasedEraShelley -> + let pp = unbundleLedgerShelleyBasedProtocolParams ShelleyBasedEraShelley bpp + in isLeadingSlotsTPraos (slotRangeOfInterest pp) poolid markSnapshotPoolDistr nextEpochsNonce vrfSkey f + ShelleyBasedEraAllegra -> + let pp = unbundleLedgerShelleyBasedProtocolParams ShelleyBasedEraAllegra bpp + in isLeadingSlotsTPraos (slotRangeOfInterest pp) poolid markSnapshotPoolDistr nextEpochsNonce vrfSkey f + ShelleyBasedEraMary -> + let pp = unbundleLedgerShelleyBasedProtocolParams ShelleyBasedEraMary bpp + in isLeadingSlotsTPraos (slotRangeOfInterest pp) poolid markSnapshotPoolDistr nextEpochsNonce vrfSkey f + ShelleyBasedEraAlonzo -> + let pp = unbundleLedgerShelleyBasedProtocolParams ShelleyBasedEraAlonzo bpp + in isLeadingSlotsTPraos (slotRangeOfInterest pp) poolid markSnapshotPoolDistr nextEpochsNonce vrfSkey f + ShelleyBasedEraBabbage -> + let pp = unbundleLedgerShelleyBasedProtocolParams ShelleyBasedEraBabbage bpp + in isLeadingSlotsPraos (slotRangeOfInterest pp) poolid markSnapshotPoolDistr nextEpochsNonce vrfSkey f + ShelleyBasedEraConway -> + let pp = unbundleLedgerShelleyBasedProtocolParams ShelleyBasedEraConway bpp + in isLeadingSlotsPraos (slotRangeOfInterest pp) poolid markSnapshotPoolDistr nextEpochsNonce vrfSkey f where globals = constructGlobals sGen eInfo (unbundleProtocolParams bpp) @@ -1538,18 +1552,6 @@ nextEpochEligibleLeadershipSlots sbe sGen serCurrEpochState ptclState poolid (Vr f = activeSlotCoeff globals ---getFromCbor --- :: ShelleyBasedEra era --- -> (( FromCBOR (Consensus.ChainDepState (ConsensusProtocol era)) --- , FromCBOR (ChainDepStateProtocol era) --- ) => a) --- -> a ---getFromCbor ShelleyBasedEraShelley f = f ---getFromCbor ShelleyBasedEraAllegra f = f ---getFromCbor ShelleyBasedEraMary f = f ---getFromCbor ShelleyBasedEraAlonzo f = f ---getFromCbor ShelleyBasedEraBabbage f = f - -- | Return slots a given stake pool operator is leading. -- See Leader Value Calculation in the Shelley ledger specification. -- We need the certified natural value from the VRF, active slot coefficient @@ -1610,27 +1612,12 @@ obtainIsStandardCrypto ShelleyBasedEraBabbage f = f obtainIsStandardCrypto ShelleyBasedEraConway f = f -obtainDecodeEpochStateConstraints - :: ShelleyLedgerEra era ~ ledgerera - => ShelleyBasedEra era - -> (( FromCBOR (Core.PParams ledgerera) - , FromCBOR (Core.GovernanceState ledgerera) - , DecCBOR (Core.Value ledgerera) - ) => a) -> a -obtainDecodeEpochStateConstraints ShelleyBasedEraShelley f = f -obtainDecodeEpochStateConstraints ShelleyBasedEraAllegra f = f -obtainDecodeEpochStateConstraints ShelleyBasedEraMary f = f -obtainDecodeEpochStateConstraints ShelleyBasedEraAlonzo f = f -obtainDecodeEpochStateConstraints ShelleyBasedEraBabbage f = f -obtainDecodeEpochStateConstraints ShelleyBasedEraConway f = f - -- | Return the slots at which a particular stake pool operator is -- expected to mint a block. -currentEpochEligibleLeadershipSlots :: forall era ledgerera. () - => ShelleyLedgerEra era ~ ledgerera - => Core.EraPParams ledgerera +currentEpochEligibleLeadershipSlots :: forall era. () => Consensus.PraosProtocolSupportsNode (Api.ConsensusProtocol era) => FromCBOR (Consensus.ChainDepState (Api.ConsensusProtocol era)) + => Shelley.EraCrypto (ShelleyLedgerEra era) ~ Shelley.StandardCrypto => ShelleyBasedEra era -> ShelleyGenesis Shelley.StandardCrypto -> EpochInfo (Either Text) @@ -1656,21 +1643,32 @@ currentEpochEligibleLeadershipSlots sbe sGen eInfo bpp ptclState poolid (VrfSign setSnapshotPoolDistr <- first LeaderErrDecodeProtocolEpochStateFailure . fmap (SL.unPoolDistr . unPoolDistr) - $ obtainDecodeEpochStateConstraints sbe - $ decodePoolDistribution serPoolDistr + $ decodePoolDistribution sbe serPoolDistr - let pp = unbundleLedgerShelleyBasedProtocolParams sbe bpp - slotRangeOfInterest = Set.filter + let slotRangeOfInterest :: Core.EraPParams ledgerera => Core.PParams ledgerera -> Set SlotNo + slotRangeOfInterest pp = Set.filter (not . Ledger.isOverlaySlot firstSlotOfEpoch (pp ^. Core.ppDG)) $ Set.fromList [firstSlotOfEpoch .. lastSlotofEpoch] case sbe of - ShelleyBasedEraShelley -> isLeadingSlotsTPraos slotRangeOfInterest poolid setSnapshotPoolDistr epochNonce vrkSkey f - ShelleyBasedEraAllegra -> isLeadingSlotsTPraos slotRangeOfInterest poolid setSnapshotPoolDistr epochNonce vrkSkey f - ShelleyBasedEraMary -> isLeadingSlotsTPraos slotRangeOfInterest poolid setSnapshotPoolDistr epochNonce vrkSkey f - ShelleyBasedEraAlonzo -> isLeadingSlotsTPraos slotRangeOfInterest poolid setSnapshotPoolDistr epochNonce vrkSkey f - ShelleyBasedEraBabbage -> isLeadingSlotsPraos slotRangeOfInterest poolid setSnapshotPoolDistr epochNonce vrkSkey f - ShelleyBasedEraConway -> isLeadingSlotsPraos slotRangeOfInterest poolid setSnapshotPoolDistr epochNonce vrkSkey f + ShelleyBasedEraShelley -> + let pp = unbundleLedgerShelleyBasedProtocolParams ShelleyBasedEraShelley bpp + in isLeadingSlotsTPraos (slotRangeOfInterest pp) poolid setSnapshotPoolDistr epochNonce vrkSkey f + ShelleyBasedEraAllegra -> + let pp = unbundleLedgerShelleyBasedProtocolParams ShelleyBasedEraAllegra bpp + in isLeadingSlotsTPraos (slotRangeOfInterest pp) poolid setSnapshotPoolDistr epochNonce vrkSkey f + ShelleyBasedEraMary -> + let pp = unbundleLedgerShelleyBasedProtocolParams ShelleyBasedEraMary bpp + in isLeadingSlotsTPraos (slotRangeOfInterest pp) poolid setSnapshotPoolDistr epochNonce vrkSkey f + ShelleyBasedEraAlonzo -> + let pp = unbundleLedgerShelleyBasedProtocolParams ShelleyBasedEraAlonzo bpp + in isLeadingSlotsTPraos (slotRangeOfInterest pp) poolid setSnapshotPoolDistr epochNonce vrkSkey f + ShelleyBasedEraBabbage -> + let pp = unbundleLedgerShelleyBasedProtocolParams ShelleyBasedEraBabbage bpp + in isLeadingSlotsPraos (slotRangeOfInterest pp) poolid setSnapshotPoolDistr epochNonce vrkSkey f + ShelleyBasedEraConway -> + let pp = unbundleLedgerShelleyBasedProtocolParams ShelleyBasedEraConway bpp + in isLeadingSlotsPraos (slotRangeOfInterest pp) poolid setSnapshotPoolDistr epochNonce vrkSkey f where globals = constructGlobals sGen eInfo (unbundleProtocolParams bpp) diff --git a/cardano-api/src/Cardano/Api/ProtocolParameters.hs b/cardano-api/src/Cardano/Api/ProtocolParameters.hs index 56928db4845..94cdeaa18a7 100644 --- a/cardano-api/src/Cardano/Api/ProtocolParameters.hs +++ b/cardano-api/src/Cardano/Api/ProtocolParameters.hs @@ -774,7 +774,7 @@ fromAlonzoPrices Alonzo.Prices{Alonzo.prSteps, Alonzo.prMem} = -- Script cost models -- -newtype CostModel = CostModel [Integer] --TODO: decide if we need a Map or a list: (Map Text Integer) +newtype CostModel = CostModel [Integer] deriving (Eq, Show) deriving newtype (ToJSON, FromJSON) deriving newtype (ToCBOR, FromCBOR) diff --git a/cardano-api/src/Cardano/Api/Query.hs b/cardano-api/src/Cardano/Api/Query.hs index 45f19f3c32e..3937f4cde12 100644 --- a/cardano-api/src/Cardano/Api/Query.hs +++ b/cardano-api/src/Cardano/Api/Query.hs @@ -124,6 +124,7 @@ import qualified Cardano.Chain.Update.Validation.Interface as Byron.Update import Cardano.Ledger.Binary import qualified Cardano.Ledger.Binary.Plain as Plain +import Cardano.Ledger.Crypto (Crypto) import qualified Cardano.Ledger.Shelley.API as Shelley import qualified Cardano.Ledger.Shelley.Core as Core import qualified Cardano.Ledger.Shelley.LedgerState as Shelley @@ -140,6 +141,7 @@ import Cardano.Api.Modes import Cardano.Api.NetworkId import Cardano.Api.ProtocolParameters import Cardano.Api.TxBody +import Cardano.Api.Tx (eraProtVerLow) import Cardano.Api.Value import Data.Word (Word64) @@ -432,14 +434,19 @@ newtype SerialisedCurrentEpochState era newtype CurrentEpochState era = CurrentEpochState (Shelley.EpochState (ShelleyLedgerEra era)) decodeCurrentEpochState - :: forall era. - ( Core.EraTxOut (ShelleyLedgerEra era) - , Core.EraGovernance (ShelleyLedgerEra era) - ) - => SerialisedCurrentEpochState era + :: ShelleyBasedEra era + -> SerialisedCurrentEpochState era -> Either DecoderError (CurrentEpochState era) -decodeCurrentEpochState (SerialisedCurrentEpochState (Serialised ls)) = - CurrentEpochState <$> Plain.decodeFull ls +decodeCurrentEpochState sbe (SerialisedCurrentEpochState (Serialised ls)) = + CurrentEpochState <$> + case sbe of + ShelleyBasedEraShelley -> Plain.decodeFull ls + ShelleyBasedEraAllegra -> Plain.decodeFull ls + ShelleyBasedEraMary -> Plain.decodeFull ls + ShelleyBasedEraAlonzo -> Plain.decodeFull ls + ShelleyBasedEraBabbage -> Plain.decodeFull ls + ShelleyBasedEraConway -> Plain.decodeFull ls + newtype SerialisedPoolState era = SerialisedPoolState (Serialised (Shelley.PState (Core.EraCrypto (ShelleyLedgerEra era)))) @@ -463,13 +470,12 @@ newtype PoolDistribution era = PoolDistribution } decodePoolDistribution - :: forall era. () - => Core.Era (ShelleyLedgerEra era) - => DecCBOR (Shelley.PoolDistr (Core.EraCrypto (ShelleyLedgerEra era))) - => SerialisedPoolDistribution era + :: forall era. (Crypto (Core.EraCrypto (ShelleyLedgerEra era))) + => ShelleyBasedEra era + -> SerialisedPoolDistribution era -> Either DecoderError (PoolDistribution era) -decodePoolDistribution (SerialisedPoolDistribution (Serialised ls)) = - PoolDistribution <$> decodeFull (Core.eraProtVerLow @(ShelleyLedgerEra era)) ls +decodePoolDistribution sbe (SerialisedPoolDistribution (Serialised ls)) = + PoolDistribution <$> decodeFull (eraProtVerLow sbe) ls newtype SerialisedStakeSnapshots era = SerialisedStakeSnapshots (Serialised (Consensus.StakeSnapshots (Core.EraCrypto (ShelleyLedgerEra era)))) diff --git a/cardano-api/test/cardano-api-test.hs b/cardano-api/test/cardano-api-test.hs index 373d9b83fc2..5e6c369cb94 100644 --- a/cardano-api/test/cardano-api-test.hs +++ b/cardano-api/test/cardano-api-test.hs @@ -1,12 +1,6 @@ module Main where -import System.IO ( - BufferMode (LineBuffering), - hSetBuffering, - hSetEncoding, - stdout, - utf8, - ) +import System.IO (BufferMode (LineBuffering), hSetBuffering, hSetEncoding, stdout, utf8) import Cardano.Crypto.Libsodium (sodiumInit) diff --git a/cardano-cli/cardano-cli.cabal b/cardano-cli/cardano-cli.cabal index c51087c0efb..5cc210556b0 100644 --- a/cardano-cli/cardano-cli.cabal +++ b/cardano-cli/cardano-cli.cabal @@ -152,7 +152,6 @@ library , prettyprinter , prettyprinter-ansi-terminal , random - , set-algebra ^>= 1.0 , split , strict-stm , text @@ -235,7 +234,7 @@ test-suite cardano-cli-golden , bytestring , cardano-api , cardano-cli - , cardano-crypto-wrapper ^>= 1.5 + , cardano-crypto-wrapper ^>= 1.5.1 , cardano-ledger-byron ^>= 1.0 , cardano-prelude , cborg diff --git a/cardano-cli/src/Cardano/CLI/Byron/Parsers.hs b/cardano-cli/src/Cardano/CLI/Byron/Parsers.hs index b85056d6566..3a146f079a8 100644 --- a/cardano-cli/src/Cardano/CLI/Byron/Parsers.hs +++ b/cardano-cli/src/Cardano/CLI/Byron/Parsers.hs @@ -41,7 +41,7 @@ import GHC.Word (Word8) import Options.Applicative import qualified Options.Applicative as Opt -import Cardano.Binary (Annotated (..)) +import Cardano.Ledger.Binary (Annotated (..)) import Cardano.Crypto (RequiresNetworkMagic (..)) import Cardano.Crypto.Hashing (hashRaw) diff --git a/cardano-cli/test/cardano-cli-test.hs b/cardano-cli/test/cardano-cli-test.hs index 4f23e5571b3..0ed5f0867b1 100644 --- a/cardano-cli/test/cardano-cli-test.hs +++ b/cardano-cli/test/cardano-cli-test.hs @@ -1,5 +1,6 @@ +module Main where -import Hedgehog.Main (defaultMain) +import System.IO (BufferMode (LineBuffering), hSetBuffering, hSetEncoding, stdout, utf8) import qualified Test.Cli.CliIntermediateFormat import qualified Test.Cli.FilePermissions @@ -15,9 +16,12 @@ import qualified Test.Cli.Shelley.Run.Query import qualified Test.Config.Mainnet import Hedgehog.Extras.Stock.OS (isWin32) +import Hedgehog.Main (defaultMain) main :: IO () -main = +main = do + hSetBuffering stdout LineBuffering + hSetEncoding stdout utf8 defaultMain [ Test.Cli.CliIntermediateFormat.tests , Test.Cli.FilePermissions.tests diff --git a/cardano-node/test/cardano-node-test.hs b/cardano-node/test/cardano-node-test.hs index d9623dd0431..bc7b3e15721 100644 --- a/cardano-node/test/cardano-node-test.hs +++ b/cardano-node/test/cardano-node-test.hs @@ -5,13 +5,7 @@ #endif import Hedgehog.Main (defaultMain) -import System.IO ( - BufferMode (LineBuffering), - hSetBuffering, - hSetEncoding, - stdout, - utf8, - ) +import System.IO (BufferMode (LineBuffering), hSetBuffering, hSetEncoding, stdout, utf8) #ifdef UNIX import qualified Test.Cardano.Node.FilePermissions diff --git a/cardano-testnet/test/Main.hs b/cardano-testnet/test/Main.hs index 4f839553d6b..12beee3b2fe 100644 --- a/cardano-testnet/test/Main.hs +++ b/cardano-testnet/test/Main.hs @@ -5,6 +5,7 @@ module Main ) where import Prelude +import System.IO (BufferMode (LineBuffering), hSetBuffering, hSetEncoding, stdout, utf8) import Test.Tasty (TestTree) import qualified System.Environment as E @@ -47,6 +48,8 @@ ingredients = T.defaultIngredients main :: IO () main = do + hSetBuffering stdout LineBuffering + hSetEncoding stdout utf8 args <- E.getArgs E.withArgs args $ tests >>= T.defaultMainWithIngredients ingredients From cc87149be0fb5689091b2ca82e1cbe79ac4184c4 Mon Sep 17 00:00:00 2001 From: Alexey Kuleshevich Date: Thu, 23 Mar 2023 17:59:08 +0300 Subject: [PATCH 36/38] Remove redundant constraints --- cardano-node/src/Cardano/Node/Tracing/Era/Shelley.hs | 10 ---------- 1 file changed, 10 deletions(-) diff --git a/cardano-node/src/Cardano/Node/Tracing/Era/Shelley.hs b/cardano-node/src/Cardano/Node/Tracing/Era/Shelley.hs index 103510ba1ac..6337b02492f 100644 --- a/cardano-node/src/Cardano/Node/Tracing/Era/Shelley.hs +++ b/cardano-node/src/Cardano/Node/Tracing/Era/Shelley.hs @@ -256,8 +256,6 @@ instance ( ShelleyBasedEra era forMachine dtal (DelegsFailure f) = forMachine dtal f instance ( ShelleyBasedEra era - , ToJSON (Ledger.Value era) - , ToJSON (Ledger.TxOut era) , Ledger.EraCrypto era ~ StandardCrypto , LogFormatting (PPUPPredFailure era) , LogFormatting (PredicateFailure (Ledger.EraRule "UTXO" era)) @@ -376,8 +374,6 @@ instance ( ShelleyBasedEra era ] instance ( ShelleyBasedEra era - , ToJSON (Core.Value era) - , ToJSON (Core.TxOut era) , LogFormatting (PPUPPredFailure era) ) => LogFormatting (ShelleyUtxoPredFailure era) where @@ -436,8 +432,6 @@ instance ( ShelleyBasedEra era ] instance ( ShelleyBasedEra era - , ToJSON (Core.Value era) - , ToJSON (Core.TxOut era) , ToJSON Allegra.ValidityInterval , LogFormatting (PPUPPredFailure era) ) => LogFormatting (AllegraUtxoPredFailure era) where @@ -855,8 +849,6 @@ instance LogFormatting (ShelleyUpecPredFailure era) where -- Alonzo related -------------------------------------------------------------------------------- instance ( ShelleyBasedEra era - , ToJSON (Ledger.Value era) - , ToJSON (Ledger.TxOut era) , LogFormatting (PredicateFailure (Ledger.EraRule "UTXOS" era)) ) => LogFormatting (AlonzoUtxoPredFailure era) where forMachine _dtal (Alonzo.BadInputsUTxO badInputs) = @@ -1005,8 +997,6 @@ instance ( Ledger.Era era instance ( Ledger.Era era , ShelleyBasedEra era , Ledger.EraCrypto era ~ StandardCrypto - , ToJSON (Ledger.Value era) - , ToJSON (Ledger.TxOut era) , LogFormatting (PPUPPredFailure era) , LogFormatting (ShelleyUtxowPredFailure era) , LogFormatting (PredicateFailure (Ledger.EraRule "UTXO" era)) From ab4ea91cf3e8789e9434d7dab5fb51ca50783664 Mon Sep 17 00:00:00 2001 From: Samuel Leathers Date: Thu, 23 Mar 2023 15:05:53 -0400 Subject: [PATCH 37/38] increase version to 8.0.0 --- bench/cardano-topology/cardano-topology.cabal | 2 +- cardano-api/cardano-api.cabal | 2 +- cardano-cli/cardano-cli.cabal | 2 +- cardano-node-chairman/cardano-node-chairman.cabal | 2 +- cardano-node/cardano-node.cabal | 2 +- cardano-testnet/cardano-testnet.cabal | 2 +- docker-compose.yml | 4 ++-- 7 files changed, 8 insertions(+), 8 deletions(-) diff --git a/bench/cardano-topology/cardano-topology.cabal b/bench/cardano-topology/cardano-topology.cabal index c0bfc32bbdd..f98edfc13ee 100644 --- a/bench/cardano-topology/cardano-topology.cabal +++ b/bench/cardano-topology/cardano-topology.cabal @@ -1,7 +1,7 @@ cabal-version: 3.0 name: cardano-topology -version: 1.36.0 +version: 8.0.0 synopsis: A cardano topology generator description: A cardano topology generator. category: Cardano, diff --git a/cardano-api/cardano-api.cabal b/cardano-api/cardano-api.cabal index 4b376a82ffa..1f50468d26c 100644 --- a/cardano-api/cardano-api.cabal +++ b/cardano-api/cardano-api.cabal @@ -1,7 +1,7 @@ cabal-version: 3.0 name: cardano-api -version: 1.36.0 +version: 8.0.0 synopsis: The cardano api description: The cardano api. category: Cardano, diff --git a/cardano-cli/cardano-cli.cabal b/cardano-cli/cardano-cli.cabal index 5cc210556b0..871f4b0c677 100644 --- a/cardano-cli/cardano-cli.cabal +++ b/cardano-cli/cardano-cli.cabal @@ -1,7 +1,7 @@ cabal-version: 3.0 name: cardano-cli -version: 1.36.0 +version: 8.0.0 synopsis: The Cardano command-line interface description: The Cardano command-line interface. copyright: 2020-2023 Input Output Global Inc (IOG). diff --git a/cardano-node-chairman/cardano-node-chairman.cabal b/cardano-node-chairman/cardano-node-chairman.cabal index a1125ba0060..b81d6340dcc 100644 --- a/cardano-node-chairman/cardano-node-chairman.cabal +++ b/cardano-node-chairman/cardano-node-chairman.cabal @@ -1,7 +1,7 @@ cabal-version: 3.0 name: cardano-node-chairman -version: 1.36.0 +version: 8.0.0 synopsis: The cardano full node description: The cardano full node. category: Cardano, diff --git a/cardano-node/cardano-node.cabal b/cardano-node/cardano-node.cabal index f00e04a8cb7..a1c4bad563c 100644 --- a/cardano-node/cardano-node.cabal +++ b/cardano-node/cardano-node.cabal @@ -1,7 +1,7 @@ cabal-version: 3.0 name: cardano-node -version: 1.36.0 +version: 8.0.0 synopsis: The cardano full node description: The cardano full node. category: Cardano, diff --git a/cardano-testnet/cardano-testnet.cabal b/cardano-testnet/cardano-testnet.cabal index 156fd7c933d..b4654ad0843 100644 --- a/cardano-testnet/cardano-testnet.cabal +++ b/cardano-testnet/cardano-testnet.cabal @@ -1,7 +1,7 @@ cabal-version: 3.0 name: cardano-testnet -version: 1.36.0 +version: 8.0.0 synopsis: The cardano full node description: The cardano full node. copyright: 2021-2023 Input Output Global Inc (IOG). diff --git a/docker-compose.yml b/docker-compose.yml index 4f8d8c2e57d..1ccce6237ea 100644 --- a/docker-compose.yml +++ b/docker-compose.yml @@ -2,7 +2,7 @@ version: "3.5" services: cardano-node: - image: inputoutput/cardano-node:${CARDANO_NODE_VERSION:-1.36.0} + image: inputoutput/cardano-node:${CARDANO_NODE_VERSION:-8.0.0} environment: - NETWORK=${NETWORK:-mainnet} volumes: @@ -15,7 +15,7 @@ services: max-file: "10" cardano-submit-api: - image: inputoutput/cardano-submit-api:${CARDANO_SUBMIT_API_VERSION:-1.36.0} + image: inputoutput/cardano-submit-api:${CARDANO_SUBMIT_API_VERSION:-8.0.0} environment: - NETWORK=${NETWORK:-mainnet} depends_on: From f272577cfe8d7e6268e48c997809ea298874c310 Mon Sep 17 00:00:00 2001 From: Alexey Kuleshevich Date: Tue, 28 Mar 2023 04:11:22 +0300 Subject: [PATCH 38/38] cabal.project: update to latest ledger with few necessary bug fixes --- cabal.project | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/cabal.project b/cabal.project index fea81252f2a..c922639960a 100644 --- a/cabal.project +++ b/cabal.project @@ -149,8 +149,8 @@ source-repository-package source-repository-package type: git location: https://github.com/input-output-hk/cardano-ledger - tag: 9a586179d788aaa8d80dd6513810a7b399c3cd72 - --sha256: 15xg2hs36gc2gm6nqwvas1dznba74lsp4n2rf1izi2nvc6n24qs0 + tag: 5fe9e9e02622cb1d7794b8dbd068a7bc7122aa74 + --sha256: 08m4wxsdg5nn1ilvamdxss24ipkb5gkmqw2q2fsh6ng3sy0bfzy2 subdir: eras/alonzo/impl eras/alonzo/test-suite