Remove ProtocolParametersUpdate

cardano-api/cardano-api.cabal

@@ -316,6 +316,7 @@ library gen
     Test.Gen.Cardano.Api.Era
     Test.Gen.Cardano.Api.Experimental
     Test.Gen.Cardano.Api.Hardcoded
+    Test.Gen.Cardano.Api.Internal.Shared
     Test.Gen.Cardano.Api.Metadata
     Test.Gen.Cardano.Api.ProtocolParameters
     Test.Gen.Cardano.Api.Typed

cardano-api/gen/Test/Gen/Cardano/Api/Internal/Shared.hs

@@ -0,0 +1,72 @@
+{-# LANGUAGE DataKinds #-}
+{-# LANGUAGE EmptyCase #-}
+{-# LANGUAGE FlexibleContexts #-}
+{-# LANGUAGE GADTs #-}
+{-# LANGUAGE NamedFieldPuns #-}
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE RankNTypes #-}
+{-# LANGUAGE RecordWildCards #-}
+{-# LANGUAGE ScopedTypeVariables #-}
+{-# LANGUAGE TupleSections #-}
+{-# LANGUAGE TypeApplications #-}
+{-# OPTIONS_GHC -Wno-deprecations #-}
+
+module Test.Gen.Cardano.Api.Internal.Shared
+  ( genCostModels
+  , genEpochNo
+  , genSeed
+  , genSigningKey
+  , genVerificationKey
+  , genVerificationKeyHash
+  )
+where
+
+import Cardano.Api
+import Cardano.Api.Ledger ()
+
+import Cardano.Crypto.DSIGN.Class qualified as Crypto
+import Cardano.Crypto.Seed qualified as Crypto
+import Cardano.Ledger.Alonzo.Scripts qualified as Alonzo
+
+import Test.Cardano.Ledger.Alonzo.Arbitrary ()
+import Test.Cardano.Ledger.Conway.Arbitrary ()
+
+import Hedgehog
+import Hedgehog.Gen as Gen
+import Hedgehog.Gen.QuickCheck qualified as Q
+import Hedgehog.Range as Range
+
+genEpochNo :: Gen EpochNo
+genEpochNo = EpochNo <$> Gen.word64 (Range.linear 0 10)
+
+genCostModels :: MonadGen m => m Alonzo.CostModels
+genCostModels = Q.arbitrary
+
+genVerificationKeyHash
+  :: ()
+  => HasTypeProxy keyrole
+  => Key keyrole
+  => AsType keyrole
+  -> Gen (Hash keyrole)
+genVerificationKeyHash roletoken =
+  verificationKeyHash <$> genVerificationKey roletoken
+
+genVerificationKey
+  :: ()
+  => HasTypeProxy keyrole
+  => Key keyrole
+  => AsType keyrole
+  -> Gen (VerificationKey keyrole)
+genVerificationKey roletoken = getVerificationKey <$> genSigningKey roletoken
+
+genSigningKey :: Key keyrole => AsType keyrole -> Gen (SigningKey keyrole)
+genSigningKey roletoken = do
+  seed <- genSeed (fromIntegral seedSize)
+  let sk = deterministicSigningKey roletoken seed
+  return sk
+ where
+  seedSize :: Word
+  seedSize = deterministicSigningKeySeedSize roletoken
+
+genSeed :: Int -> Gen Crypto.Seed
+genSeed n = Crypto.mkSeedFromBytes <$> Gen.bytes (Range.singleton n)

cardano-api/gen/Test/Gen/Cardano/Api/ProtocolParameters.hs

@@ -1,16 +1,21 @@
+{-# LANGUAGE GADTs #-}
+
 module Test.Gen.Cardano.Api.ProtocolParameters where
 
 import Cardano.Api
 import Cardano.Api.Ledger
 
-import Test.Gen.Cardano.Api.Typed (genCostModels)
+import Data.Maybe
+
+import Test.Gen.Cardano.Api.Internal.Shared
 
 import Test.Cardano.Ledger.Alonzo.Arbitrary ()
 import Test.Cardano.Ledger.Conway.Arbitrary ()
 
-import Hedgehog (MonadGen)
+import Hedgehog (Gen, MonadGen)
 import Hedgehog.Gen qualified as Gen
 import Hedgehog.Gen.QuickCheck qualified as Q
+import Hedgehog.Range qualified as Range
 
 genStrictMaybe :: MonadGen m => m a -> m (StrictMaybe a)
 genStrictMaybe gen =
@@ -52,7 +57,7 @@ genShelleyToAlonzoPParams =
 genAlonzoOnwardsPParams :: MonadGen m => m (AlonzoOnwardsPParams era)
 genAlonzoOnwardsPParams =
   AlonzoOnwardsPParams
-    <$> genStrictMaybe genCostModels
+    <$> pure SNothing -- Cost models don't roundtrip through CBOR
     <*> genStrictMaybe Q.arbitrary
     <*> genStrictMaybe Q.arbitrary
     <*> genStrictMaybe Q.arbitrary
@@ -76,6 +81,41 @@ genIntroducedInConwayPParams =
     <*> genStrictMaybe Q.arbitrary
     <*> genStrictMaybe Q.arbitrary
 
+genTxUpdateProposal :: CardanoEra era -> Gen (TxUpdateProposal era)
+genTxUpdateProposal sbe =
+  Gen.choice $
+    catMaybes
+      [ Just $ pure TxUpdateProposalNone
+      , forEraInEon sbe Nothing $ \w ->
+          Just $ TxUpdateProposal w <$> genUpdateProposal (toCardanoEra w)
+      ]
+
+genUpdateProposal :: CardanoEra era -> Gen (UpdateProposal era)
+genUpdateProposal era =
+  UpdateProposal
+    <$> Gen.map
+      (Range.constant 1 3)
+      ( (,)
+          <$> genVerificationKeyHash AsGenesisKey
+          <*> genEraBasedProtocolParametersUpdate era
+      )
+    <*> genEpochNo
+
+genEraBasedProtocolParametersUpdate
+  :: MonadGen m
+  => CardanoEra era
+  -> m (EraBasedProtocolParametersUpdate era)
+genEraBasedProtocolParametersUpdate era =
+  case era of
+    ByronEra -> error ""
+    ShelleyEra -> genShelleyEraBasedProtocolParametersUpdate
+    AllegraEra -> genAllegraEraBasedProtocolParametersUpdate
+    MaryEra -> genMaryEraBasedProtocolParametersUpdate
+    AlonzoEra -> genAlonzoEraBasedProtocolParametersUpdate
+    BabbageEra -> genBabbageEraBasedProtocolParametersUpdate
+    ConwayEra -> genConwayEraBasedProtocolParametersUpdate
+    DijkstraEra -> error "Dijkstra era should never be used with genEraBasedProtocolParametersUpdate"
+
 genShelleyEraBasedProtocolParametersUpdate
   :: MonadGen m => m (EraBasedProtocolParametersUpdate ShelleyEra)
 genShelleyEraBasedProtocolParametersUpdate =

cardano-api/gen/Test/Gen/Cardano/Api/Typed.hs

@@ -5,7 +5,6 @@
 {-# LANGUAGE NamedFieldPuns #-}
 {-# LANGUAGE OverloadedStrings #-}
 {-# LANGUAGE RankNTypes #-}
-{-# LANGUAGE RecordWildCards #-}
 {-# LANGUAGE ScopedTypeVariables #-}
 {-# LANGUAGE TupleSections #-}
 {-# LANGUAGE TypeApplications #-}
@@ -28,6 +27,7 @@ module Test.Gen.Cardano.Api.Typed
   , genCostModel
   , genCostModels
   , genMaybePraosNonce
+  , genTxUpdateProposal
   , genPraosNonce
   , genValidProtocolParameters
   , genValueNestedRep
@@ -107,15 +107,12 @@ module Test.Gen.Cardano.Api.Typed
   , genValueDefault
   , genVerificationKey
   , genVerificationKeyHash
-  , genUpdateProposal
-  , genProtocolParametersUpdate
   , genTxOutDatumHashTxContext
   , genTxOutDatumHashUTxOContext
   , genTxOutValue
   , genTxReturnCollateral
   , genTxScriptValidity
   , genTxTotalCollateral
-  , genTxUpdateProposal
   , genTxValidityLowerBound
   , genTxValidityUpperBound
   , genTxWithdrawals
@@ -165,12 +162,9 @@ import Cardano.Api.Parser.Text qualified as P
 import Cardano.Api.Tx qualified as A
 
 import Cardano.Binary qualified as CBOR
-import Cardano.Crypto.DSIGN.Class qualified as Crypto
 import Cardano.Crypto.Hash qualified as Crypto
 import Cardano.Crypto.Hash.Class qualified as CRYPTO
-import Cardano.Crypto.Seed qualified as Crypto
 import Cardano.Ledger.Alonzo.Scripts qualified as Alonzo
-import Cardano.Ledger.BaseTypes qualified as Ledger
 import Cardano.Ledger.Core qualified as Ledger
 import Cardano.Ledger.Hashes (unsafeMakeSafeHash)
 import Cardano.Ledger.Plutus.Language qualified as L
@@ -187,14 +181,16 @@ import Data.Maybe
 import Data.Ratio (Ratio, (%))
 import Data.String
 import Data.Typeable
-import Data.Word (Word16, Word32, Word64)
+import Data.Word (Word32, Word64)
 import GHC.Exts (IsList (..))
 import GHC.Stack
 import Numeric.Natural (Natural)
 
 import Test.Gen.Cardano.Api.Era (conwayEraOnwardsTestConstraints, shelleyBasedEraTestConstraints)
 import Test.Gen.Cardano.Api.Hardcoded
+import Test.Gen.Cardano.Api.Internal.Shared
 import Test.Gen.Cardano.Api.Metadata (genTxMetadata)
+import Test.Gen.Cardano.Api.ProtocolParameters (genTxUpdateProposal)
 
 import Test.Cardano.Chain.UTxO.Gen (genVKWitness)
 import Test.Cardano.Crypto.Gen (genProtocolMagicId)
@@ -655,15 +651,6 @@ genPaymentCredential = do
   vKey <- genVerificationKey AsPaymentKey
   return . PaymentCredentialByKey $ verificationKeyHash vKey
 
-genSigningKey :: Key keyrole => AsType keyrole -> Gen (SigningKey keyrole)
-genSigningKey roletoken = do
-  seed <- genSeed (fromIntegral seedSize)
-  let sk = deterministicSigningKey roletoken seed
-  return sk
- where
-  seedSize :: Word
-  seedSize = deterministicSigningKeySeedSize roletoken
-
 genStakeAddress :: Gen StakeAddress
 genStakeAddress = makeStakeAddress <$> genNetworkId <*> genStakeCredential
 
@@ -955,15 +942,6 @@ genMirCertificateRequirements w =
   shelleyToBabbageEraConstraints w $
     MirCertificateRequirements w <$> Q.arbitrary <*> Q.arbitrary
 
-genTxUpdateProposal :: CardanoEra era -> Gen (TxUpdateProposal era)
-genTxUpdateProposal sbe =
-  Gen.choice $
-    catMaybes
-      [ Just $ pure TxUpdateProposalNone
-      , forEraInEon sbe Nothing $ \w ->
-          Just $ TxUpdateProposal w <$> genUpdateProposal (toCardanoEra w)
-      ]
-
 genTxMintValue :: CardanoEra era -> Gen (TxMintValue BuildTx era)
 genTxMintValue =
   inEonForEra
@@ -1125,7 +1103,7 @@ genValidTxBody sbe =
   Gen.mapMaybe
     ( \content ->
         either (const Nothing) (Just . (,content)) $
-          createAndValidateTransactionBody sbe content
+          createTransactionBody sbe content
     )
     (genTxBodyContent sbe)
 
@@ -1183,23 +1161,6 @@ genWitnesses sbe = do
   keyWits <- Gen.list (Range.constant 0 10) (genShelleyKeyWitness sbe)
   return $ bsWits ++ keyWits
 
-genVerificationKey
-  :: ()
-  => HasTypeProxy keyrole
-  => Key keyrole
-  => AsType keyrole
-  -> Gen (VerificationKey keyrole)
-genVerificationKey roletoken = getVerificationKey <$> genSigningKey roletoken
-
-genVerificationKeyHash
-  :: ()
-  => HasTypeProxy keyrole
-  => Key keyrole
-  => AsType keyrole
-  -> Gen (Hash keyrole)
-genVerificationKeyHash roletoken =
-  verificationKeyHash <$> genVerificationKey roletoken
-
 genByronKeyWitness :: Gen (KeyWitness ByronEra)
 genByronKeyWitness = do
   pmId <- genProtocolMagicId
@@ -1260,18 +1221,9 @@ genCardanoKeyWitness
   -> Gen (KeyWitness era)
 genCardanoKeyWitness = genShelleyWitness
 
-genSeed :: Int -> Gen Crypto.Seed
-genSeed n = Crypto.mkSeedFromBytes <$> Gen.bytes (Range.singleton n)
-
 genNat :: Gen Natural
 genNat = Gen.integral (Range.linear 0 10)
 
-genWord16 :: Gen Word16
-genWord16 = Gen.integral (Range.linear 0 10)
-
-genWord32 :: Gen Word32
-genWord32 = Gen.integral (Range.linear 0 10)
-
 genRational :: Gen Rational
 genRational =
   (\d -> ratioToRational (1 % d)) <$> genDenominator
@@ -1294,12 +1246,6 @@ genRationalInt64 =
   ratioToRational :: Ratio Int64 -> Rational
   ratioToRational = toRational
 
-genEpochNo :: Gen EpochNo
-genEpochNo = EpochNo <$> Gen.word64 (Range.linear 0 10)
-
-genEpochInterval :: Gen Ledger.EpochInterval
-genEpochInterval = Ledger.EpochInterval <$> Gen.word32 (Range.linear 0 10)
-
 genPraosNonce :: Gen PraosNonce
 genPraosNonce = makePraosNonce <$> Gen.bytes (Range.linear 0 32)
 
@@ -1313,56 +1259,9 @@ genValidProtocolParameters sbe =
   shelleyBasedEraTestConstraints sbe $
     LedgerProtocolParameters <$> Q.arbitrary
 
-genProtocolParametersUpdate :: CardanoEra era -> Gen ProtocolParametersUpdate
-genProtocolParametersUpdate era = do
-  protocolUpdateProtocolVersion <- Gen.maybe ((,) <$> genNat <*> genNat)
-  protocolUpdateDecentralization <- Gen.maybe genRational
-  protocolUpdateExtraPraosEntropy <- Gen.maybe genMaybePraosNonce
-  protocolUpdateMaxBlockHeaderSize <- Gen.maybe genWord16
-  protocolUpdateMaxBlockBodySize <- Gen.maybe genWord32
-  protocolUpdateMaxTxSize <- Gen.maybe genWord32
-  protocolUpdateTxFeeFixed <- Gen.maybe genLovelace
-  protocolUpdateTxFeePerByte <- Gen.maybe genLovelace
-  protocolUpdateMinUTxOValue <- Gen.maybe genLovelace
-  protocolUpdateStakeAddressDeposit <- Gen.maybe genLovelace
-  protocolUpdateStakePoolDeposit <- Gen.maybe genLovelace
-  protocolUpdateMinPoolCost <- Gen.maybe genLovelace
-  protocolUpdatePoolRetireMaxEpoch <- Gen.maybe genEpochInterval
-  protocolUpdateStakePoolTargetNum <- Gen.maybe genWord16
-  protocolUpdatePoolPledgeInfluence <- Gen.maybe genRationalInt64
-  protocolUpdateMonetaryExpansion <- Gen.maybe genRational
-  protocolUpdateTreasuryCut <- Gen.maybe genRational
-  let protocolUpdateCostModels = mempty -- genCostModels
-  -- TODO: Babbage figure out how to deal with
-  -- asymmetric cost model JSON instances
-  protocolUpdatePrices <- Gen.maybe genExecutionUnitPrices
-  protocolUpdateMaxTxExUnits <- Gen.maybe genExecutionUnits
-  protocolUpdateMaxBlockExUnits <- Gen.maybe genExecutionUnits
-  protocolUpdateMaxValueSize <- Gen.maybe genWord32
-  protocolUpdateCollateralPercent <- Gen.maybe genWord16
-  protocolUpdateMaxCollateralInputs <- Gen.maybe genWord16
-  protocolUpdateUTxOCostPerByte <-
-    inEonForEra @BabbageEraOnwards (pure Nothing) (const (Just <$> genLovelace)) era
-
-  pure ProtocolParametersUpdate{..}
-
-genUpdateProposal :: CardanoEra era -> Gen UpdateProposal
-genUpdateProposal era =
-  UpdateProposal
-    <$> Gen.map
-      (Range.constant 1 3)
-      ( (,)
-          <$> genVerificationKeyHash AsGenesisKey
-          <*> genProtocolParametersUpdate era
-      )
-    <*> genEpochNo
-
 genCostModel :: MonadGen m => m Alonzo.CostModel
 genCostModel = Q.arbitrary
 
-genCostModels :: MonadGen m => m Alonzo.CostModels
-genCostModels = Q.arbitrary
-
 genExecutionUnits :: Gen ExecutionUnits
 genExecutionUnits =
   ExecutionUnits

cardano-api/src/Cardano/Api/Compatible/Tx.hs

@@ -50,7 +50,7 @@ import Lens.Micro hiding (ix)
 data AnyProtocolUpdate era where
   ProtocolUpdate
     :: ShelleyToBabbageEra era
-    -> UpdateProposal
+    -> UpdateProposal era
     -> AnyProtocolUpdate era
   ProposalProcedures
     :: ConwayEraOnwards era
@@ -84,8 +84,8 @@ createCompatibleTx sbe ins outs txFee' anyProtocolUpdate anyVote txCertificates'
     (updateTxBody, extraScriptWitnesses) <-
       case anyProtocolUpdate of
         ProtocolUpdate shelleyToBabbageEra updateProposal -> do
-          ledgerPParamsUpdate <- toLedgerUpdate sbe updateProposal
-          let updateTxBody :: Endo (L.TxBody L.TopTx (ShelleyLedgerEra era)) =
+          let ledgerPParamsUpdate = toLedgerUpdate sbe updateProposal
+              updateTxBody :: Endo (L.TxBody L.TopTx (ShelleyLedgerEra era)) =
                 shelleyToBabbageEraConstraints shelleyToBabbageEra $
                   Endo $ \txb ->
                     txb & L.updateTxBodyL .~ SJust ledgerPParamsUpdate