Skip to content

Commit

Permalink
Merge pull request #40 from input-output-hk/newhoggy/generate-protoco…
Browse files Browse the repository at this point in the history
…lUpdateUTxOCostPerByte-in-genProtocolParametersUpdate-era-dependently-4

Generate fields only if they make sense for the given era
  • Loading branch information
newhoggy authored Jun 7, 2023
2 parents 8487100 + cc83938 commit 1abeff1
Show file tree
Hide file tree
Showing 6 changed files with 217 additions and 47 deletions.
1 change: 1 addition & 0 deletions cardano-api/cardano-api.cabal
Original file line number Diff line number Diff line change
Expand Up @@ -57,6 +57,7 @@ library internal
Cardano.Api.EraCast
Cardano.Api.Eras
Cardano.Api.Error
Cardano.Api.Feature
Cardano.Api.Fees
Cardano.Api.Genesis
Cardano.Api.GenesisParameters
Expand Down
111 changes: 65 additions & 46 deletions cardano-api/gen/Test/Gen/Cardano/Api/Typed.hs
Original file line number Diff line number Diff line change
Expand Up @@ -7,7 +7,9 @@
{-# LANGUAGE TypeApplications #-}

module Test.Gen.Cardano.Api.Typed
( genAddressByron
( genFeatureValueInEra

, genAddressByron
, genAddressInEra
, genAddressShelley
, genCertificate
Expand Down Expand Up @@ -119,11 +121,12 @@ import Cardano.Api hiding (txIns)
import qualified Cardano.Api as Api
import Cardano.Api.Byron (KeyWitness (ByronKeyWitness),
WitnessNetworkIdOrByronAddress (..))
import Cardano.Api.Feature
import Cardano.Api.Script (scriptInEraToRefScript)
import Cardano.Api.Shelley (GovernancePoll (..), GovernancePollAnswer (..), Hash (..),
KESPeriod (KESPeriod),
OperationalCertificateIssueCounter (OperationalCertificateIssueCounter),
PlutusScript (PlutusScriptSerialised), ProtocolParameters (ProtocolParameters),
PlutusScript (PlutusScriptSerialised), ProtocolParameters (..),
ReferenceScript (..), ReferenceTxInsScriptsInlineDatumsSupportedInEra (..),
StakeCredential (StakeCredentialByKey), StakePoolKey,
refInsScriptsAndInlineDatsSupportedInEra)
Expand All @@ -137,7 +140,7 @@ import qualified Cardano.Ledger.Alonzo.Scripts as Alonzo
import Cardano.Ledger.SafeHash (unsafeMakeSafeHash)
import qualified Cardano.Ledger.Shelley.TxBody as Ledger (EraIndependentTxBody)

import Control.Applicative (optional)
import Control.Applicative (Alternative (..), optional)
import Data.ByteString (ByteString)
import qualified Data.ByteString as BS
import qualified Data.ByteString.Short as SBS
Expand All @@ -160,6 +163,7 @@ import qualified Hedgehog.Gen as Gen
import qualified Hedgehog.Range as Range

{- HLINT ignore "Reduce duplication" -}
{- HLINT ignore "Use let" -}

genAddressByron :: Gen (Address ByronAddr)
genAddressByron = makeByronAddress <$> genNetworkId
Expand Down Expand Up @@ -634,7 +638,7 @@ genTxBodyContent era = do
txMetadata <- genTxMetadataInEra era
txAuxScripts <- genTxAuxScripts era
let txExtraKeyWits = TxExtraKeyWitnessesNone --TODO: Alonzo era: Generate witness key hashes
txProtocolParams <- BuildTxWith <$> Gen.maybe genValidProtocolParameters
txProtocolParams <- BuildTxWith <$> Gen.maybe (genValidProtocolParameters era)
txWithdrawals <- genTxWithdrawals era
txCertificates <- genTxCertificates era
txUpdateProposal <- genTxUpdateProposal era
Expand Down Expand Up @@ -703,6 +707,17 @@ genTxBody era = do
Left err -> fail (displayError err)
Right txBody -> pure txBody

-- | Generate a 'FeatureValue' for the given 'CardanoEra' with the provided generator.
genFeatureValueInEra :: ()
=> FeatureInEra feature
=> Alternative f
=> f a
-> CardanoEra era
-> f (FeatureValue feature era a)
genFeatureValueInEra gen =
featureInEra (pure NoFeatureValue) $ \witness ->
pure NoFeatureValue <|> fmap (FeatureValue witness) gen

genTxScriptValidity :: CardanoEra era -> Gen (TxScriptValidity era)
genTxScriptValidity era = case txScriptValiditySupportedInCardanoEra era of
Nothing -> pure TxScriptValidityNone
Expand Down Expand Up @@ -831,41 +846,42 @@ genPraosNonce = makePraosNonce <$> Gen.bytes (Range.linear 0 32)
genMaybePraosNonce :: Gen (Maybe PraosNonce)
genMaybePraosNonce = Gen.maybe genPraosNonce

genProtocolParameters :: Gen ProtocolParameters
genProtocolParameters =
ProtocolParameters
<$> ((,) <$> genNat <*> genNat)
<*> Gen.maybe genRational
<*> genMaybePraosNonce
<*> genNat
<*> genNat
<*> genNat
<*> genLovelace
<*> genLovelace
<*> Gen.maybe genLovelace
<*> genLovelace
<*> genLovelace
<*> genLovelace
<*> genEpochNo
<*> genNat
<*> genRationalInt64
<*> genRational
<*> genRational
<*> Gen.maybe genLovelace
<*> return mempty
--TODO: Babbage figure out how to deal with
-- asymmetric cost model JSON instances
<*> Gen.maybe genExecutionUnitPrices
<*> Gen.maybe genExecutionUnits
<*> Gen.maybe genExecutionUnits
<*> Gen.maybe genNat
<*> Gen.maybe genNat
<*> Gen.maybe genNat
<*> Gen.maybe genLovelace
genProtocolParameters :: CardanoEra era -> Gen ProtocolParameters
genProtocolParameters era = do
protocolParamProtocolVersion <- (,) <$> genNat <*> genNat
protocolParamDecentralization <- Gen.maybe genRational
protocolParamExtraPraosEntropy <- genMaybePraosNonce
protocolParamMaxBlockHeaderSize <- genNat
protocolParamMaxBlockBodySize <- genNat
protocolParamMaxTxSize <- genNat
protocolParamTxFeeFixed <- genLovelace
protocolParamTxFeePerByte <- genLovelace
protocolParamMinUTxOValue <- Gen.maybe genLovelace
protocolParamStakeAddressDeposit <- genLovelace
protocolParamStakePoolDeposit <- genLovelace
protocolParamMinPoolCost <- genLovelace
protocolParamPoolRetireMaxEpoch <- genEpochNo
protocolParamStakePoolTargetNum <- genNat
protocolParamPoolPledgeInfluence <- genRationalInt64
protocolParamMonetaryExpansion <- genRational
protocolParamTreasuryCut <- genRational
protocolParamUTxOCostPerWord <- featureInEra @ProtocolUTxOCostPerWordFeature (pure Nothing) (const (Just <$> genLovelace)) era
protocolParamCostModels <- pure mempty
--TODO: Babbage figure out how to deal with
-- asymmetric cost model JSON instances
protocolParamPrices <- Gen.maybe genExecutionUnitPrices
protocolParamMaxTxExUnits <- Gen.maybe genExecutionUnits
protocolParamMaxBlockExUnits <- Gen.maybe genExecutionUnits
protocolParamMaxValueSize <- Gen.maybe genNat
protocolParamCollateralPercent <- Gen.maybe genNat
protocolParamMaxCollateralInputs <- Gen.maybe genNat
protocolParamUTxOCostPerByte <- featureInEra @ProtocolUTxOCostPerByteFeature (pure Nothing) (const (Just <$> genLovelace)) era

pure ProtocolParameters {..}

-- | Generate valid protocol parameters which pass validations in Cardano.Api.ProtocolParameters
genValidProtocolParameters :: Gen ProtocolParameters
genValidProtocolParameters =
genValidProtocolParameters :: CardanoEra era -> Gen ProtocolParameters
genValidProtocolParameters era =
ProtocolParameters
<$> ((,) <$> genNat <*> genNat)
<*> Gen.maybe genRational
Expand All @@ -885,7 +901,7 @@ genValidProtocolParameters =
<*> genRational
<*> genRational
-- 'Just' is required by checks in Cardano.Api.ProtocolParameters
<*> fmap Just genLovelace
<*> featureInEra @ProtocolUTxOCostPerWordFeature (pure Nothing) (const (Just <$> genLovelace)) era
<*> return mempty
--TODO: Babbage figure out how to deal with
-- asymmetric cost model JSON instances
Expand All @@ -896,10 +912,10 @@ genValidProtocolParameters =
<*> fmap Just genNat
<*> fmap Just genNat
<*> fmap Just genNat
<*> fmap Just genLovelace
<*> featureInEra @ProtocolUTxOCostPerByteFeature (pure Nothing) (const (Just <$> genLovelace)) era

genProtocolParametersUpdate :: Gen ProtocolParametersUpdate
genProtocolParametersUpdate = do
genProtocolParametersUpdate :: CardanoEra era -> Gen ProtocolParametersUpdate
genProtocolParametersUpdate era = do
protocolUpdateProtocolVersion <- Gen.maybe ((,) <$> genNat <*> genNat)
protocolUpdateDecentralization <- Gen.maybe genRational
protocolUpdateExtraPraosEntropy <- Gen.maybe genMaybePraosNonce
Expand All @@ -917,7 +933,7 @@ genProtocolParametersUpdate = do
protocolUpdatePoolPledgeInfluence <- Gen.maybe genRationalInt64
protocolUpdateMonetaryExpansion <- Gen.maybe genRational
protocolUpdateTreasuryCut <- Gen.maybe genRational
protocolUpdateUTxOCostPerWord <- Gen.maybe genLovelace
protocolUpdateUTxOCostPerWord <- featureInEra @ProtocolUTxOCostPerWordFeature (pure Nothing) (const (Just <$> genLovelace)) era
let protocolUpdateCostModels = mempty -- genCostModels
--TODO: Babbage figure out how to deal with
-- asymmetric cost model JSON instances
Expand All @@ -927,16 +943,19 @@ genProtocolParametersUpdate = do
protocolUpdateMaxValueSize <- Gen.maybe genNat
protocolUpdateCollateralPercent <- Gen.maybe genNat
protocolUpdateMaxCollateralInputs <- Gen.maybe genNat
protocolUpdateUTxOCostPerByte <- Gen.maybe genLovelace
protocolUpdateUTxOCostPerByte <- featureInEra @ProtocolUTxOCostPerByteFeature (pure Nothing) (const (Just <$> genLovelace)) era

pure ProtocolParametersUpdate{..}


genUpdateProposal :: CardanoEra era -> Gen UpdateProposal
genUpdateProposal _era = -- TODO Make era specific
genUpdateProposal era =
UpdateProposal
<$> Gen.map (Range.constant 1 3)
((,) <$> genVerificationKeyHash AsGenesisKey
<*> genProtocolParametersUpdate)
( (,)
<$> genVerificationKeyHash AsGenesisKey
<*> genProtocolParametersUpdate era
)
<*> genEpochNo

genCostModel :: Gen Alonzo.CostModel
Expand Down
88 changes: 88 additions & 0 deletions cardano-api/internal/Cardano/Api/Feature.hs
Original file line number Diff line number Diff line change
@@ -0,0 +1,88 @@
{-# LANGUAGE GADTs #-}
{-# LANGUAGE KindSignatures #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE StandaloneDeriving #-}

module Cardano.Api.Feature
( FeatureValue (..)
, FeatureInEra(..)
, featureInShelleyBasedEra
, valueOrDefault
, asFeatureValue
, asFeatureValueInShelleyBasedEra
, isFeatureValue
) where

import Cardano.Api.Eras

import Data.Kind

-- | A class for features that are supported in some eras but not others.
class FeatureInEra (feature :: Type -> Type) where
-- | Determine the value to use for a feature in a given 'CardanoEra'.
-- Note that the negative case is the first argument, and the positive case is the second as per
-- the 'either' function convention.
featureInEra :: ()
=> a -- ^ Value to use if the feature is not supported in the era
-> (feature era -> a) -- ^ Function to get thealue to use if the feature is supported in the era
-> CardanoEra era -- ^ Era to check
-> a -- ^ The value to use

-- | Determine the value to use for a feature in a given 'ShelleyBasedEra'.
featureInShelleyBasedEra :: ()
=> FeatureInEra feature
=> a
-> (feature era -> a)
-> ShelleyBasedEra era
-> a
featureInShelleyBasedEra no yes = featureInEra no yes . shelleyBasedToCardanoEra

-- | A value of type @'FeatureValue' feature era a@ is either:
data FeatureValue feature era a where
-- | A value is available for this feature in this era
FeatureValue
:: feature era
-- ^ The witness that the feature is supported in this era
-> a
-- ^ The value to use
-> FeatureValue feature era a

-- | No value is available for this feature in this era
NoFeatureValue
:: FeatureValue feature era a

deriving instance (Eq a, Eq (feature era)) => Eq (FeatureValue feature era a)
deriving instance (Show a, Show (feature era)) => Show (FeatureValue feature era a)

-- | Determine if a value is defined.
--
-- If the value is not defined, it could be because the feature is not supported or
-- because the feature is supported but the value is not available.
isFeatureValue :: FeatureValue feature era a -> Bool
isFeatureValue = \case
NoFeatureValue -> False
FeatureValue _ _ -> True

-- | Get the value if it is defined, otherwise return the default value.
valueOrDefault :: a -> FeatureValue feature era a -> a
valueOrDefault defaultValue = \case
NoFeatureValue -> defaultValue
FeatureValue _ a -> a

-- | Attempt to construct a 'FeatureValue' from a value and era.
-- If the feature is not supported in the era, then 'NoFeatureValue' is returned.
asFeatureValue :: ()
=> FeatureInEra feature
=> a
-> CardanoEra era
-> FeatureValue feature era a
asFeatureValue value = featureInEra NoFeatureValue (`FeatureValue` value)

-- | Attempt to construct a 'FeatureValue' from a value and a shelley-based-era.
asFeatureValueInShelleyBasedEra :: ()
=> FeatureInEra feature
=> a
-> ShelleyBasedEra era
-> FeatureValue feature era a
asFeatureValueInShelleyBasedEra value = asFeatureValue value . shelleyBasedToCardanoEra
53 changes: 53 additions & 0 deletions cardano-api/internal/Cardano/Api/ProtocolParameters.hs
Original file line number Diff line number Diff line change
Expand Up @@ -8,6 +8,7 @@
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE StandaloneDeriving #-}
{-# LANGUAGE TypeFamilies #-}

{- HLINT ignore "Redundant ==" -}
Expand Down Expand Up @@ -70,11 +71,17 @@ module Cardano.Api.ProtocolParameters (

-- * Data family instances
AsType(..),

-- ** Era-dependent protocol features
ProtocolUTxOCostPerByteFeature(..),
ProtocolUTxOCostPerWordFeature(..),

) where

import Cardano.Api.Address
import Cardano.Api.Eras
import Cardano.Api.Error
import Cardano.Api.Feature
import Cardano.Api.Hash
import Cardano.Api.HasTypeProxy
import Cardano.Api.Json (toRationalJSON)
Expand Down Expand Up @@ -667,6 +674,52 @@ instance FromCBOR ProtocolParametersUpdate where
<*> fromCBOR
<*> fromCBOR

-- ----------------------------------------------------------------------------
-- Features
--

-- | A representation of whether the era supports the 'UTxO Cost Per Byte'
-- protocol parameter.
--
-- The Babbage and subsequent eras support such a protocol parameter.
--
data ProtocolUTxOCostPerByteFeature era where
ProtocolUTxOCostPerByteInBabbageEra :: ProtocolUTxOCostPerByteFeature BabbageEra
ProtocolUTxOCostPerByteInConwayEra :: ProtocolUTxOCostPerByteFeature ConwayEra

deriving instance Eq (ProtocolUTxOCostPerByteFeature era)
deriving instance Show (ProtocolUTxOCostPerByteFeature era)

instance FeatureInEra ProtocolUTxOCostPerByteFeature where
featureInEra no yes = \case
ByronEra -> no
ShelleyEra -> no
AllegraEra -> no
MaryEra -> no
AlonzoEra -> no
BabbageEra -> yes ProtocolUTxOCostPerByteInBabbageEra
ConwayEra -> yes ProtocolUTxOCostPerByteInConwayEra

-- | A representation of whether the era supports the 'UTxO Cost Per Word'
-- protocol parameter.
--
-- The Babbage and subsequent eras support such a protocol parameter.
--
data ProtocolUTxOCostPerWordFeature era where
ProtocolUpdateUTxOCostPerWordInAlonzoEra :: ProtocolUTxOCostPerWordFeature AlonzoEra

deriving instance Eq (ProtocolUTxOCostPerWordFeature era)
deriving instance Show (ProtocolUTxOCostPerWordFeature era)

instance FeatureInEra ProtocolUTxOCostPerWordFeature where
featureInEra no yes = \case
ByronEra -> no
ShelleyEra -> no
AllegraEra -> no
MaryEra -> no
AlonzoEra -> yes ProtocolUpdateUTxOCostPerWordInAlonzoEra
BabbageEra -> no
ConwayEra -> no

-- ----------------------------------------------------------------------------
-- Praos nonce
Expand Down
Loading

0 comments on commit 1abeff1

Please sign in to comment.