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 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/bench/tx-generator/src/Cardano/Benchmarking/Script/Env.hs b/bench/tx-generator/src/Cardano/Benchmarking/Script/Env.hs index 395d7b45a2d..ffe9c9ff44a 100644 --- a/bench/tx-generator/src/Cardano/Benchmarking/Script/Env.hs +++ b/bench/tx-generator/src/Cardano/Benchmarking/Script/Env.hs @@ -57,9 +57,10 @@ 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) 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/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 1935a1dee39..a0f3b673f81 100644 --- a/bench/tx-generator/src/Cardano/TxGenerator/Types.hs +++ b/bench/tx-generator/src/Cardano/TxGenerator/Types.hs @@ -16,14 +16,14 @@ 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) 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/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 97971e8fd63..c922639960a 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 +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-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 @@ -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. @@ -108,3 +108,76 @@ 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: 7f6afd7ba652bd20d5aaf31a9450dddda7e2f0bd + --sha256: 0wlvgiiyqp14xd7d49h9709dg2dv7wk1b44kbdy596mg8g3v93nw + 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-network-protocols + 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 + 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: 5fe9e9e02622cb1d7794b8dbd068a7bc7122aa74 + --sha256: 08m4wxsdg5nn1ilvamdxss24ipkb5gkmqw2q2fsh6ng3sy0bfzy2 + 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 65cd169de19..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, @@ -109,24 +109,28 @@ 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 , 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.1 + , cardano-ledger-allegra ^>= 1.1 + , cardano-ledger-api >= 1.1 + , cardano-ledger-babbage ^>= 1.1 + , cardano-ledger-binary ^>= 1.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 + , cardano-protocol-tpraos >= 1.0.1 , cardano-slotting >= 0.1 + , cardano-strict-containers ^>= 0.1 , cborg , contra-tracer , containers @@ -160,11 +164,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 +173,6 @@ library , typed-protocols ^>= 0.1 , unordered-containers >= 0.2.11 , vector - , vector-map ^>= 0.1 , yaml library gen @@ -193,14 +193,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.1 + , cardano-ledger-alonzo-test + , cardano-ledger-byron-test ^>= 1.5 + , cardano-ledger-core ^>= 1.1 + , cardano-ledger-shelley ^>= 1.1 , containers , hedgehog , text @@ -215,23 +215,24 @@ 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-api ^>= 1.1 + , cardano-ledger-core:{cardano-ledger-core, testlib} ^>= 1.1 + , cardano-ledger-shelley ^>= 1.1 + , cardano-ledger-shelley-test ^>= 1.1 , cardano-slotting ^>= 0.1 , containers , hedgehog , hedgehog-extras ^>= 0.4 + , hedgehog-quickcheck , mtl - , ouroboros-consensus + , microlens , ouroboros-consensus-shelley , QuickCheck - , cardano-ledger-shelley ^>= 0.1 - , cardano-ledger-shelley-test ^>= 0.1 , tasty , tasty-hedgehog , tasty-quickcheck diff --git a/cardano-api/gen/Test/Gen/Cardano/Api.hs b/cardano-api/gen/Test/Gen/Cardano/Api.hs index a018368de2a..4f0a47a540c 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 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. 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 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/Fees.hs b/cardano-api/src/Cardano/Api/Fees.hs index 47e62fd373e..67392ec9b9d 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) @@ -53,45 +52,34 @@ 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.Era as Ledger.Era (Crypto) 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 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 qualified Cardano.Ledger.Shelley.API.Wallet as Ledger (evaluateTransactionFee) 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.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 as L -import qualified Cardano.Ledger.Babbage as Babbage -import Cardano.Ledger.Babbage.PParams (BabbagePParamsHKD (..)) import qualified Cardano.Ledger.Conway as Conway +import qualified Cardano.Ledger.Conway.Core as Ledger import qualified Ouroboros.Consensus.HardFork.History as Consensus @@ -123,31 +111,30 @@ 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 = 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" #-} @@ -166,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 @@ -253,7 +240,7 @@ evaluateTransactionFee bpparams txbody keywitcount _byronwitcount = where evalShelleyBasedEra :: forall ledgerera. ShelleyLedgerEra era ~ ledgerera - => Ledger.CLI ledgerera + => EraTx ledgerera => Ledger.Tx ledgerera -> Lovelace evalShelleyBasedEra tx = @@ -267,8 +254,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 @@ -521,11 +507,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' + Just supp -> obtainBabbageEraPParams supp $ evalConway sbe tx' Nothing -> return mempty where LedgerEpochInfo ledgerEpochInfo = epochInfo @@ -537,83 +523,60 @@ 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 + case L.evalTxExUnits (unbundleLedgerShelleyBasedProtocolParams era bpp) tx (toLedgerUTxO era utxo) ledgerEpochInfo systemstart - cModelArray 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.evalTxExUnits (unbundleLedgerShelleyBasedProtocolParams era bpp) tx (toLedgerUTxO era utxo) ledgerEpochInfo systemstart - costModelsArray of Left err -> Left (TransactionValidityTranslationError err) Right exmap -> Right (fromLedgerScriptExUnitsMap exmap) 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 (unbundleProtocolParams bpp)) - case Alonzo.evaluateTransactionExecutionUnits - (toLedgerPParams era (unbundleProtocolParams bpp)) + 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 - Alonzo.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 = @@ -622,43 +585,45 @@ 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 - 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.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 -- 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 + 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 @@ -700,8 +665,12 @@ 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 + 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 @@ -712,10 +681,11 @@ evaluateTransactionBalance bpp poolids utxo -> TxOutValue era evalMultiAsset evidence = TxOutValue evidence . fromMaryValue $ - Ledger.evaluateTransactionBalance + L.evalBalanceTxBody (unbundleLedgerShelleyBasedProtocolParams era bpp) + lookupDelegDeposit + isRegPool (toLedgerUTxO era utxo) - isNewPool txbody evalAdaOnly :: forall ledgerera. @@ -727,10 +697,11 @@ evaluateTransactionBalance bpp poolids utxo -> TxOutValue era evalAdaOnly evidence = TxOutAdaOnly evidence . fromShelleyLovelace - $ Ledger.evaluateTransactionBalance + $ L.evalBalanceTxBody (unbundleLedgerShelleyBasedProtocolParams era bpp) + lookupDelegDeposit + isRegPool (toLedgerUTxO era utxo) - isNewPool txbody -- Conjur up all the necessary class instances and evidence @@ -758,8 +729,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.EraUTxO ledgerera ) type LedgerAdaOnlyConstraints ledgerera = @@ -770,11 +741,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 @@ -1361,17 +1328,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 + babPParams = unbundleLedgerShelleyBasedProtocolParams era bpp + minUTxO = L.getMinCoinTxOut babPParams 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 where 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 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/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/LedgerEvent.hs b/cardano-api/src/Cardano/Api/LedgerEvent.hs index 80a987018ba..d9741567f94 100644 --- a/cardano-api/src/Cardano/Api/LedgerEvent.hs +++ b/cardano-api/src/Cardano/Api/LedgerEvent.hs @@ -22,38 +22,26 @@ 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.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.Era (Crypto) 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. @@ -100,33 +80,30 @@ class ConvertLedgerEvent blk where instance ConvertLedgerEvent ByronBlock where toLedgerEvent _ = Nothing -instance - ( Crypto 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) - ) => - 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 @@ -135,13 +112,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 +164,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 +173,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 +201,7 @@ pattern LEMirTransfer :: AuxLedgerEvent (LedgerState (ShelleyBlock protocol ledgerera)) pattern LEMirTransfer rp tp rtt ttr <- ShelleyLedgerEventTICK - ( NewEpochEvent + ( TickNewEpochEvent ( MirEvent ( MirTransfer ( InstantaneousRewards @@ -238,7 +215,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 +227,7 @@ pattern LERetiredPools :: AuxLedgerEvent (LedgerState (ShelleyBlock protocol ledgerera)) pattern LERetiredPools r u e <- ShelleyLedgerEventTICK - ( NewEpochEvent + ( TickNewEpochEvent ( EpochEvent ( PoolReapEvent ( RetiredPools @@ -263,7 +240,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 +270,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/LedgerState.hs b/cardano-api/src/Cardano/Api/LedgerState.hs index 811db2dcbd1..e5b268ba908 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,13 +76,12 @@ 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 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 @@ -93,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 @@ -115,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 (..)) @@ -126,20 +123,17 @@ 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 qualified Cardano.Ledger.BaseTypes as Shelley.Spec +import Cardano.Ledger.BaseTypes (Globals (..), Nonce, (â­’)) +import qualified Cardano.Ledger.BaseTypes as Ledger import qualified Cardano.Ledger.BHeaderView as Ledger -import Cardano.Ledger.Conway.Genesis (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.Era -import qualified Cardano.Ledger.Keys as Shelley.Spec +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 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.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) import qualified Cardano.Protocol.TPraos.BHeader as TPraos @@ -731,17 +725,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 +801,7 @@ instance FromJSON NodeConfig where <*> o .: "RequiresNetworkMagic" <*> parseByronSoftwareVersion o <*> parseByronProtocolVersion o - <*> (Consensus.ProtocolTransitionParamsShelleyBased () + <*> (Consensus.ProtocolTransitionParamsShelleyBased undefined <$> parseShelleyHardForkEpoch o) <*> (Consensus.ProtocolTransitionParamsShelleyBased () <$> parseAllegraHardForkEpoch o) @@ -952,6 +946,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 +959,7 @@ data GenesisConfig !(ConwayGenesis Shelley.StandardCrypto) data ShelleyConfig = ShelleyConfig - { scConfig :: !(Shelley.Spec.ShelleyGenesis Shelley.StandardShelley) + { scConfig :: !(Ledger.ShelleyGenesis Shelley.StandardCrypto) , scGenesisHash :: !GenesisHashShelley } @@ -1052,18 +1048,19 @@ 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)) -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 - (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 @@ -1293,7 +1290,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 @@ -1448,16 +1445,13 @@ 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.Crypto (ShelleyLedgerEra era)) - ) - => Ledger.Era (ShelleyLedgerEra era) - => Share (Core.TxOut (ShelleyLedgerEra era)) ~ Interns (Shelley.Spec.Credential 'Shelley.Spec.Staking (Cardano.Ledger.Era.Crypto (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 - -> ShelleyGenesis Shelley.StandardShelley + -> ShelleyGenesis Shelley.StandardCrypto -> SerialisedCurrentEpochState era -- ^ We need the mark stake distribution in order to predict -- the following epoch's leadership schedule @@ -1483,7 +1477,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 @@ -1516,51 +1510,54 @@ 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._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 - let slotRangeOfInterest = Set.filter - (not . Ledger.isOverlaySlot firstSlotOfEpoch (getField @"_d" (unbundleLedgerShelleyBasedProtocolParams sbe bpp))) + 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) - f :: Shelley.Spec.ActiveSlotCoeff + f :: Ledger.ActiveSlotCoeff 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 -- 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 +1565,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 +1585,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 +1602,7 @@ isLeadingSlotsPraos slotRangeOfInterest poolid snapshotPoolDistr eNonce vrfSkey obtainIsStandardCrypto :: ShelleyLedgerEra era ~ ledgerera => ShelleyBasedEra era - -> (Cardano.Ledger.Era.Crypto ledgerera ~ Shelley.StandardCrypto => a) + -> (Core.EraCrypto ledgerera ~ Shelley.StandardCrypto => a) -> a obtainIsStandardCrypto ShelleyBasedEraShelley f = f obtainIsStandardCrypto ShelleyBasedEraAllegra f = f @@ -1615,39 +1612,14 @@ obtainIsStandardCrypto ShelleyBasedEraBabbage f = f obtainIsStandardCrypto ShelleyBasedEraConway f = f -obtainDecodeEpochStateConstraints - :: ShelleyLedgerEra era ~ ledgerera - => ShelleyBasedEra era - -> (( 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)) - ) => 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 - => Ledger.Era ledgerera +currentEpochEligibleLeadershipSlots :: forall era. () => 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 => FromCBOR (Consensus.ChainDepState (Api.ConsensusProtocol era)) - -- => Consensus.ChainDepState (ConsensusProtocol era) ~ Consensus.ChainDepState (ConsensusProtocol era) + => Shelley.EraCrypto (ShelleyLedgerEra era) ~ Shelley.StandardCrypto => ShelleyBasedEra era - -> ShelleyGenesis Shelley.StandardShelley + -> ShelleyGenesis Shelley.StandardCrypto -> EpochInfo (Either Text) -> BundledProtocolParameters era -> ProtocolState era @@ -1671,32 +1643,47 @@ currentEpochEligibleLeadershipSlots sbe sGen eInfo bpp ptclState poolid (VrfSign setSnapshotPoolDistr <- first LeaderErrDecodeProtocolEpochStateFailure . fmap (SL.unPoolDistr . unPoolDistr) - $ obtainDecodeEpochStateConstraints sbe - $ decodePoolDistribution serPoolDistr + $ decodePoolDistribution sbe serPoolDistr - let slotRangeOfInterest = Set.filter - (not . Ledger.isOverlaySlot firstSlotOfEpoch (getField @"_d" (unbundleLedgerShelleyBasedProtocolParams sbe bpp))) + 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) - f :: Shelley.Spec.ActiveSlotCoeff + f :: Ledger.ActiveSlotCoeff f = activeSlotCoeff globals constructGlobals - :: ShelleyGenesis Shelley.StandardShelley + :: ShelleyGenesis Shelley.StandardCrypto -> EpochInfo (Either Text) -> ProtocolParameters -> 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/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 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/ProtocolParameters.hs b/cardano-api/src/Cardano/Api/ProtocolParameters.hs index 02acaec2479..94cdeaa18a7 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 #-} @@ -41,7 +40,6 @@ module Cardano.Api.ProtocolParameters ( ExecutionUnits(..), ExecutionUnitPrices(..), CostModel(..), - validateCostModel, fromAlonzoCostModels, -- * Update proposals to change the protocol parameters @@ -55,8 +53,11 @@ module Cardano.Api.ProtocolParameters ( toLedgerProposedPPUpdates, fromLedgerProposedPPUpdates, toLedgerPParams, + toLedgerPParamsEither, + toLedgerPParamsUpdate, + toLedgerPParamsUpdateEither, fromLedgerPParams, - fromShelleyPParams, + fromLedgerPParamsUpdate, toAlonzoPrices, fromAlonzoPrices, toAlonzoScriptLanguage, @@ -64,15 +65,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 +78,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 +90,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 +103,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 +197,11 @@ data ProtocolParameters = -- | The constant factor for the minimum fee calculation. -- - protocolParamTxFeeFixed :: Natural, + protocolParamTxFeeFixed :: Lovelace, - -- | The linear factor for the minimum fee calculation. + -- | Per byte 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 +432,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 +750,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 +774,11 @@ fromAlonzoPrices Alonzo.Prices{Alonzo.prSteps, Alonzo.prMem} = -- Script cost models -- -newtype CostModel = CostModel (Map Text Integer) +newtype CostModel = CostModel [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 +794,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 +805,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 +873,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 +883,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 +892,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 +928,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 = maybe (Left $ "Must specify " ++ paramName) + +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 +1078,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 +1088,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 +1099,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 +1109,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 +1147,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 +1251,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 +1447,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-api/src/Cardano/Api/Query.hs b/cardano-api/src/Cardano/Api/Query.hs index b53a5372f98..3937f4cde12 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 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 import Cardano.Api.Address @@ -139,13 +139,12 @@ 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.Tx (eraProtVerLow) import Cardano.Api.Value import Data.Word (Word64) -import Cardano.Ledger.SafeHash (HashAnnotated) import qualified Data.Aeson.KeyMap as KeyMap -- ---------------------------------------------------------------------------- @@ -377,32 +376,24 @@ 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) - , FromCBOR (Core.PParams (ShelleyLedgerEra era)) - , FromCBOR (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)) + , Core.EraTxOut (ShelleyLedgerEra era) + , Core.EraGovernance (ShelleyLedgerEra era) + , DecCBOR (Shelley.StashedAVVMAddresses (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 , ShelleyLedgerEra era ~ ledgerera , Consensus.ShelleyBasedEra ledgerera - , 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 +401,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 +426,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 +434,60 @@ 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))) - => SerialisedCurrentEpochState era + :: ShelleyBasedEra era + -> SerialisedCurrentEpochState era -> Either DecoderError (CurrentEpochState era) -decodeCurrentEpochState (SerialisedCurrentEpochState (Serialised ls)) = CurrentEpochState <$> 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 (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))) - => SerialisedPoolDistribution era + :: forall era. (Crypto (Core.EraCrypto (ShelleyLedgerEra era))) + => ShelleyBasedEra era + -> SerialisedPoolDistribution era -> Either DecoderError (PoolDistribution era) -decodePoolDistribution (SerialisedPoolDistribution (Serialised ls)) = PoolDistribution <$> decodeFull ls +decodePoolDistribution sbe (SerialisedPoolDistribution (Serialised ls)) = + PoolDistribution <$> decodeFull (eraProtVerLow sbe) 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 +503,7 @@ toShelleyAddrSet era = toLedgerUTxO :: ShelleyLedgerEra era ~ ledgerera - => Ledger.Crypto ledgerera ~ StandardCrypto + => Core.EraCrypto ledgerera ~ StandardCrypto => ShelleyBasedEra era -> UTxO era -> Shelley.UTxO ledgerera @@ -522,7 +515,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 +608,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 +838,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 diff --git a/cardano-api/src/Cardano/Api/Script.hs b/cardano-api/src/Cardano/Api/Script.hs index e06b8c646cc..1017853ed41 100644 --- a/cardano-api/src/Cardano/Api/Script.hs +++ b/cardano-api/src/Cardano/Api/Script.hs @@ -137,15 +137,17 @@ 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 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 import qualified Cardano.Ledger.Alonzo.Scripts as Alonzo +import qualified Cardano.Ledger.Binary as Binary (decCBOR, decodeFullAnnotator) import qualified PlutusLedgerApi.Test.Examples as Plutus @@ -396,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 @@ -407,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 @@ -910,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)) = @@ -1106,10 +1109,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 +1125,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 +1139,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. + (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 +1156,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/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/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/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 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/Tx.hs b/cardano-api/src/Cardano/Api/Tx.hs index 49831955702..f766c064627 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 @@ -53,18 +56,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 +81,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 +92,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 +119,7 @@ data Tx era where ShelleyTx :: ShelleyBasedEra era - -> Ledger.Tx (ShelleyLedgerEra era) + -> L.Tx (ShelleyLedgerEra era) -> Tx era @@ -238,7 +230,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 +249,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 +291,7 @@ data KeyWitness era where ShelleyKeyWitness :: ShelleyBasedEra era - -> Shelley.WitVKey Shelley.Witness StandardCrypto + -> L.WitVKey Shelley.Witness StandardCrypto -> KeyWitness era @@ -404,24 +403,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 +445,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 +498,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 +552,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 +595,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 +769,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 +847,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 {} 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 diff --git a/cardano-api/src/Cardano/Api/TxMetadata.hs b/cardano-api/src/Cardano/Api/TxMetadata.hs index 7b8c1ab7de4..fbdf667ccfe 100644 --- a/cardano-api/src/Cardano/Api/TxMetadata.hs +++ b/cardano-api/src/Cardano/Api/TxMetadata.hs @@ -43,9 +43,9 @@ 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 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) import qualified Data.Aeson as Aeson @@ -106,21 +106,18 @@ instance HasTypeProxy TxMetadata where 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. + -- 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 - . (\(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. + <$> (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-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 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/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) -- ----------------------------------------------------------------------------- diff --git a/cardano-api/test/cardano-api-test.hs b/cardano-api/test/cardano-api-test.hs index 59a0dbb5930..5e6c369cb94 100644 --- a/cardano-api/test/cardano-api-test.hs +++ b/cardano-api/test/cardano-api-test.hs @@ -1,3 +1,6 @@ +module Main where + +import System.IO (BufferMode (LineBuffering), hSetBuffering, hSetEncoding, stdout, utf8) import Cardano.Crypto.Libsodium (sodiumInit) @@ -23,6 +26,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-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 diff --git a/cardano-cli/cardano-cli.cabal b/cardano-cli/cardano-cli.cabal index 4b00a8ac298..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). @@ -110,19 +110,21 @@ 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.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 , 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 @@ -136,6 +138,7 @@ library , io-classes , iproute , mtl + , microlens , network , optparse-applicative-fork , ouroboros-consensus @@ -149,7 +152,6 @@ library , prettyprinter , prettyprinter-ansi-terminal , random - , set-algebra ^>= 0.1 , split , strict-stm , text @@ -159,7 +161,7 @@ library , unliftio-core , utf8-string , vector - , vector-map ^>= 0.1 + , vector-map ^>= 1.0 , yaml executable cardano-cli @@ -170,7 +172,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 +234,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.1 + , cardano-ledger-byron ^>= 1.0 , cardano-prelude , cborg , containers 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/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/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 a621dc032db..24427521b15 100644 --- a/cardano-cli/src/Cardano/CLI/Shelley/Orphans.hs +++ b/cardano-cli/src/Cardano/CLI/Shelley/Orphans.hs @@ -15,27 +15,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.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 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,28 +63,13 @@ 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) -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 (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 +92,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." 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)) 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-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 eadc1babc4e..d69aae0be5b 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 @@ -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-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 0c7a6893acd..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, @@ -138,25 +138,20 @@ library , base16-bytestring , bytestring , cardano-api - , cardano-data >= 0.1 , 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-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 +173,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.3 , 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-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/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/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/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 diff --git a/cardano-node/src/Cardano/Node/Tracing/Era/Shelley.hs b/cardano-node/src/Cardano/Node/Tracing/Era/Shelley.hs index c558a186811..6337b02492f 100644 --- a/cardano-node/src/Cardano/Node/Tracing/Era/Shelley.hs +++ b/cardano-node/src/Cardano/Node/Tracing/Era/Shelley.hs @@ -51,47 +51,31 @@ 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 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 -- 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.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.ShelleyMA.Rules (ShelleyMAUtxoPredFailure) -import qualified Cardano.Ledger.ShelleyMA.Rules as MA +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 @@ -262,7 +246,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)) @@ -272,10 +256,8 @@ instance ( ShelleyBasedEra era forMachine dtal (DelegsFailure f) = forMachine dtal f instance ( ShelleyBasedEra era - , ToJSON (Ledger.Value era) - , ToJSON (Ledger.TxOut era) - , Ledger.Crypto era ~ StandardCrypto - , LogFormatting (PredicateFailure (Ledger.EraRule "PPUP" era)) + , Ledger.EraCrypto era ~ StandardCrypto + , LogFormatting (PPUPPredFailure era) , LogFormatting (PredicateFailure (Ledger.EraRule "UTXO" era)) ) => LogFormatting (AlonzoUtxowPredFailure era) where forMachine dtal (ShelleyInAlonzoUtxowPredFailure utxoPredFail) = @@ -344,8 +326,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 @@ -392,9 +374,7 @@ instance ( ShelleyBasedEra era ] instance ( ShelleyBasedEra era - , ToJSON (Core.Value era) - , ToJSON (Core.TxOut era) - , LogFormatting (PredicateFailure (Core.EraRule "PPUP" era)) + , LogFormatting (PPUPPredFailure era) ) => LogFormatting (ShelleyUtxoPredFailure era) where forMachine _dtal (BadInputsUTxO badInputs) = @@ -452,48 +432,46 @@ instance ( ShelleyBasedEra era ] instance ( ShelleyBasedEra era - , ToJSON (Core.Value era) - , ToJSON (Core.TxOut era) - , ToJSON MA.ValidityInterval - , LogFormatting (PredicateFailure (Core.EraRule "PPUP" era)) - ) => LogFormatting (ShelleyMAUtxoPredFailure era) where - forMachine _dtal (MA.BadInputsUTxO badInputs) = + , ToJSON Allegra.ValidityInterval + , LogFormatting (PPUPPredFailure era) + ) => 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 +481,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 +504,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 +536,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" @@ -715,7 +693,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 @@ -871,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) = @@ -972,8 +948,8 @@ instance ( ShelleyBasedEra era forMachine _dtal Alonzo.NoCollateralInputs = mconcat [ "kind" .= String "NoCollateralInputs" ] -instance ( ToJSON (Alonzo.CollectError (Ledger.Crypto era)) - , LogFormatting (PredicateFailure (Ledger.EraRule "PPUP" era)) +instance ( ToJSON (Alonzo.CollectError (Ledger.EraCrypto era)) + , LogFormatting (PPUPPredFailure era) ) => LogFormatting (AlonzoUtxosPredFailure era) where forMachine _ (Alonzo.ValidationTagMismatch isValidating reason) = mconcat [ "kind" .= String "ValidationTagMismatch" @@ -1020,11 +996,9 @@ instance ( Ledger.Era era instance ( Ledger.Era era , ShelleyBasedEra era - , Ledger.Crypto era ~ StandardCrypto - , ToJSON (Ledger.Value era) - , ToJSON (Ledger.TxOut era) + , Ledger.EraCrypto era ~ StandardCrypto + , 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 = @@ -1042,6 +1016,31 @@ 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 _ (Conway.VoterDoesNotHaveRole credential voteRole) = + mconcat [ "kind" .= String "VoterDoesNotHaveRole" + , "credential" .= textShow credential + , "voteRole" .= textShow voteRole + ] + forMachine _ (Conway.GovernanceActionDoesNotExist govActionId) = + mconcat [ "kind" .= String "GovernanceActionDoesNotExist" + , "govActionId" .= 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..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/Node/Tracing/Tracers/P2P.hs b/cardano-node/src/Cardano/Node/Tracing/Tracers/P2P.hs index 6fde78b029b..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/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/Network.hs b/cardano-node/src/Cardano/Tracing/OrphanInstances/Network.hs index da9ede66eea..ea7a680c140 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) @@ -456,7 +457,6 @@ instance HasSeverityAnnotation (ConnectionManagerTrace addr (ConnectionHandlerTr TrShutdown -> Info TrConnectionExists {} -> Info TrForbiddenConnection {} -> Info - TrImpossibleConnection {} -> Info TrConnectionFailure {} -> Info TrConnectionNotFound {} -> Debug TrForbiddenOperation {} -> Info @@ -1901,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 97e4cd4a5c4..d4649bfae03 100644 --- a/cardano-node/src/Cardano/Tracing/OrphanInstances/Shelley.hs +++ b/cardano-node/src/Cardano/Tracing/OrphanInstances/Shelley.hs @@ -52,17 +52,16 @@ 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 +71,16 @@ 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 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)) import Cardano.Protocol.TPraos.OCert (KESPeriod (KESPeriod)) import Cardano.Protocol.TPraos.Rules.Prtcl @@ -263,11 +246,30 @@ instance ( ShelleyBasedEra era toObject verb (DelegsFailure f) = toObject verb f instance ( ShelleyBasedEra era - , ToJSON (Ledger.Value era) - , ToJSON (Ledger.TxOut era) - , ToObject (PredicateFailure (Ledger.EraRule "PPUP" 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 + ) => ToObject (Conway.ConwayTallyPredFailure era) where + toObject _ (Conway.VoterDoesNotHaveRole credential voteRole) = + mconcat [ "kind" .= String "VoterDoesNotHaveRole" + , "credential" .= textShow credential + , "voteRole" .= textShow voteRole + ] + toObject _ (Conway.GovernanceActionDoesNotExist govActionId) = + mconcat [ "kind" .= String "GovernanceActionDoesNotExist" + , "govActionId" .= govActionIdToText govActionId + ] + +instance ( ShelleyBasedEra 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 @@ -377,9 +379,7 @@ 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 toObject _verb (BadInputsUTxO badInputs) = @@ -437,57 +437,55 @@ 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] 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 +495,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" @@ -707,7 +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 @@ -888,9 +886,8 @@ 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 ) => ToObject (AlonzoUtxoPredFailure era) where toObject _verb (Alonzo.BadInputsUTxO badInputs) = @@ -990,8 +987,8 @@ instance ( Ledger.Era era toObject _verb Alonzo.NoCollateralInputs = mconcat [ "kind" .= String "NoCollateralInputs" ] -instance ( ToJSON (Alonzo.CollectError (Ledger.Crypto era)) - , ToObject (PredicateFailure (Ledger.EraRule "PPUP" era)) +instance ( ToJSON (Alonzo.CollectError (Ledger.EraCrypto era)) + , ToObject (PPUPPredFailure era) ) =>ToObject (AlonzoUtxosPredFailure era) where toObject _ (Alonzo.ValidationTagMismatch isValidating reason) = mconcat [ "kind" .= String "ValidationTagMismatch" @@ -1091,11 +1088,10 @@ 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) ) => ToObject (BabbageUtxoPredFailure era) where toObject v err = case err of @@ -1114,11 +1110,8 @@ instance ( ToJSON (Ledger.Value era) instance ( Ledger.Era era , ShelleyBasedEra era - , Ledger.Crypto era ~ StandardCrypto - , ToJSON (Ledger.Value era) - , ToJSON (Ledger.TxOut era) - , ToObject (ShelleyUtxowPredFailure era) - , ToObject (PredicateFailure (Ledger.EraRule "PPUP" era)) + , Ledger.EraCrypto era ~ StandardCrypto + , ToObject (PPUPPredFailure era) , ToObject (PredicateFailure (Ledger.EraRule "UTXO" era)) ) => ToObject (BabbageUtxowPredFailure era) where toObject v err = @@ -1235,9 +1228,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) - -deriving newtype instance Core.Crypto crypto => ToJSON (TxId crypto) diff --git a/cardano-node/test/cardano-node-test.hs b/cardano-node/test/cardano-node-test.hs index 358b3ea6cff..bc7b3e15721 100644 --- a/cardano-node/test/cardano-node-test.hs +++ b/cardano-node/test/cardano-node-test.hs @@ -5,6 +5,7 @@ #endif import Hedgehog.Main (defaultMain) +import System.IO (BufferMode (LineBuffering), hSetBuffering, hSetEncoding, stdout, utf8) #ifdef UNIX import qualified Test.Cardano.Node.FilePermissions @@ -13,15 +14,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 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 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/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 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: