ProtocolParameters.hs

{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE DataKinds #-}

{--
Due to the changes to "cardano-api" listed below it was decided to move
cardano-api's `ProtocolParameters` here and maintain it.

cardano-api
- Issue:
- - Remove cardano-api's ProtocolParameters (it has been deprecated for a while)
- - https://github.com/IntersectMBO/cardano-api/issues/384#issuecomment-2678888478
- PR:
- - "Remove ProtocolParameters"
- - `ProtocolParameters` had been deprecated in favor the ledger's PParams type.
-   We are now removing ProtocolParameters altogether.
- - https://github.com/IntersectMBO/cardano-api/pull/729
--}

module Cardano.TxGenerator.ProtocolParameters
  ( -- * The updatable protocol parameters
    ProtocolParameters (..)
  , LedgerProtocolParameters (..)
  , convertToLedgerProtocolParameters
  , toLedgerPParams
  , fromLedgerPParams
  )
where

--------------------------------------------------------------------------------

import           Cardano.Api (AnyPlutusScriptVersion (..), CostModel, ExecutionUnitPrices (..),
                   ExecutionUnits, LedgerProtocolParameters (..),
                   PlutusScriptVersion (PlutusScriptV1, PlutusScriptV2, PlutusScriptV3, PlutusScriptV4), PraosNonce,
                   ProtocolParametersConversionError (..),
                   ShelleyBasedEra (ShelleyBasedEraAllegra, ShelleyBasedEraAlonzo, ShelleyBasedEraBabbage, ShelleyBasedEraConway, ShelleyBasedEraMary, ShelleyBasedEraShelley, ShelleyBasedEraDijkstra),
                   ShelleyLedgerEra, fromAlonzoCostModels, fromAlonzoExUnits, fromAlonzoPrices,
                   makePraosNonce, toAlonzoCostModels, toAlonzoExUnits, toAlonzoPrices,
                   toLedgerNonce)

import qualified Cardano.Binary as CBOR
import qualified Cardano.Crypto.Hash.Class as Crypto
import qualified Cardano.Ledger.Api.Era as Ledger
import           Cardano.Ledger.Api.PParams
import qualified Cardano.Ledger.Babbage.Core as Ledger
import qualified Cardano.Ledger.BaseTypes as Ledger
import qualified Cardano.Ledger.Coin as L
import qualified Cardano.Ledger.Plutus.Language as Plutus
import qualified Cardano.Ledger.Compactible as L

import           Data.Aeson ((.!=), (.:), (.:?), (.=))
import qualified Data.Aeson as Aeson
import qualified Data.Aeson.KeyMap as KeyMap
import           Data.Either.Combinators (maybeToRight)
import           Data.Int (Int64)
import qualified Data.Map.Strict as Map
import qualified Data.Scientific as Scientific
import qualified Data.Text as Text
import           Data.Word (Word16)
import           GHC.Generics
import           Lens.Micro ((&), (.~), (^.))
import           Numeric.Natural (Natural)

-- Era based ledger protocol parameters.
--------------------------------------------------------------------------------

convertToLedgerProtocolParameters
  :: ShelleyBasedEra era
  -> ProtocolParameters
  -> Either ProtocolParametersConversionError (LedgerProtocolParameters era)
convertToLedgerProtocolParameters sbe pp =
  LedgerProtocolParameters <$> toLedgerPParams sbe pp

-- Era based Ledger protocol parameters update.
--------------------------------------------------------------------------------

-- | The values of the set of /updatable/ protocol parameters. At any
-- particular point on the chain there is a current set of parameters in use.
--
-- There are also parameters fixed in the Genesis file. See 'GenesisParameters'.

data ProtocolParameters
  = ProtocolParameters
  { protocolParamProtocolVersion :: (Natural, Natural)
  -- ^ Protocol version, major and minor. Updating the major version is
  -- used to trigger hard forks.
  --                              (Major  , Minor  )
  , protocolParamDecentralization :: Maybe Rational
  -- ^ The decentralization parameter. This is fraction of slots that
  -- belong to the BFT overlay schedule, rather than the Praos schedule.
  -- So 1 means fully centralised, while 0 means fully decentralised.
  --
  -- This is the \"d\" parameter from the design document.
  --
  -- /Deprecated in Babbage/
  , protocolParamExtraPraosEntropy :: Maybe PraosNonce
  -- ^ Extra entropy for the Praos per-epoch nonce.
  --
  -- This can be used to add extra entropy during the decentralisation
  -- process. If the extra entropy can be demonstrated to be generated
  -- randomly then this method can be used to show that the initial
  -- federated operators did not subtly bias the initial schedule so that
  -- they retain undue influence after decentralisation.
  , protocolParamMaxBlockHeaderSize :: Natural
  -- ^ The maximum permitted size of a block header.
  --
  -- This must be at least as big as the largest legitimate block headers
  -- but should not be too much larger, to help prevent DoS attacks.
  --
  -- Caution: setting this to be smaller than legitimate block headers is
  -- a sure way to brick the system!
  , protocolParamMaxBlockBodySize :: Natural
  -- ^ The maximum permitted size of the block body (that is, the block
  -- payload, without the block header).
  --
  -- This should be picked with the Praos network delta security parameter
  -- in mind. Making this too large can severely weaken the Praos
  -- consensus properties.
  --
  -- Caution: setting this to be smaller than a transaction that can
  -- change the protocol parameters is a sure way to brick the system!
  , protocolParamMaxTxSize :: Natural
  -- ^ The maximum permitted size of a transaction.
  --
  -- Typically this should not be too high a fraction of the block size,
  -- otherwise wastage from block fragmentation becomes a problem, and
  -- the current implementation does not use any sophisticated box packing
  -- algorithm.
  , protocolParamTxFeeFixed :: L.Coin
  -- ^ The constant factor for the minimum fee calculation.
  , protocolParamTxFeePerByte :: L.Coin
  -- ^ Per byte linear factor for the minimum fee calculation.
  , protocolParamMinUTxOValue :: Maybe L.Coin
  -- ^ The minimum permitted value for new UTxO entries, ie for
  -- transaction outputs.
  , protocolParamStakeAddressDeposit :: L.Coin
  -- ^ The deposit required to register a stake address.
  , protocolParamStakePoolDeposit :: L.Coin
  -- ^ The deposit required to register a stake pool.
  , protocolParamMinPoolCost :: L.Coin
  -- ^ The minimum value that stake pools are permitted to declare for
  -- their cost parameter.
  , protocolParamPoolRetireMaxEpoch :: Ledger.EpochInterval
  -- ^ The maximum number of epochs into the future that stake pools
  -- are permitted to schedule a retirement.
  , protocolParamStakePoolTargetNum :: Word16
  -- ^ The equilibrium target number of stake pools.
  --
  -- This is the \"k\" incentives parameter from the design document.
  , protocolParamPoolPledgeInfluence :: Rational
  -- ^ The influence of the pledge in stake pool rewards.
  --
  -- This is the \"a_0\" incentives parameter from the design document.
  , protocolParamMonetaryExpansion :: Rational
  -- ^ The monetary expansion rate. This determines the fraction of the
  -- reserves that are added to the fee pot each epoch.
  --
  -- This is the \"rho\" incentives parameter from the design document.
  , protocolParamTreasuryCut :: Rational
  -- ^ The fraction of the fee pot each epoch that goes to the treasury.
  --
  -- This is the \"tau\" incentives parameter from the design document.
  , protocolParamCostModels :: Map.Map AnyPlutusScriptVersion CostModel
  -- ^ Cost models for script languages that use them.
  --
  -- /Introduced in Alonzo/
  , protocolParamPrices :: Maybe ExecutionUnitPrices
  -- ^ Price of execution units for script languages that use them.
  --
  -- /Introduced in Alonzo/
  , protocolParamMaxTxExUnits :: Maybe ExecutionUnits
  -- ^ Max total script execution resources units allowed per tx
  --
  -- /Introduced in Alonzo/
  , protocolParamMaxBlockExUnits :: Maybe ExecutionUnits
  -- ^ Max total script execution resources units allowed per block
  --
  -- /Introduced in Alonzo/
  , protocolParamMaxValueSize :: Maybe Natural
  -- ^ Max size of a Value in a tx output.
  --
  -- /Introduced in Alonzo/
  , protocolParamCollateralPercent :: Maybe Natural
  -- ^ The percentage of the script contribution to the txfee that must be
  -- provided as collateral inputs when including Plutus scripts.
  --
  -- /Introduced in Alonzo/
  , protocolParamMaxCollateralInputs :: Maybe Natural
  -- ^ The maximum number of collateral inputs allowed in a transaction.
  --
  -- /Introduced in Alonzo/
  , protocolParamUTxOCostPerByte :: Maybe L.Coin
  -- ^ Cost in ada per byte of UTxO storage.
  --
  -- /Introduced in Babbage/
  }
  deriving (Eq, Generic, Show)

instance Aeson.FromJSON ProtocolParameters where
  parseJSON =
    Aeson.withObject "ProtocolParameters" $ \o -> do
      v <- o .: "protocolVersion"
      ProtocolParameters
        <$> ((,) <$> v .: "major" <*> v .: "minor")
        <*> o .:? "decentralization"
        <*> o .: "extraPraosEntropy"
        <*> o .: "maxBlockHeaderSize"
        <*> o .: "maxBlockBodySize"
        <*> o .: "maxTxSize"
        <*> o .: "txFeeFixed"
        <*> o .: "txFeePerByte"
        <*> o .: "minUTxOValue"
        <*> o .: "stakeAddressDeposit"
        <*> o .: "stakePoolDeposit"
        <*> o .: "minPoolCost"
        <*> o .: "poolRetireMaxEpoch"
        <*> o .: "stakePoolTargetNum"
        <*> o .: "poolPledgeInfluence"
        <*> o .: "monetaryExpansion"
        <*> o .: "treasuryCut"
        <*> (fmap unCostModels <$> o .:? "costModels") .!= Map.empty
        <*> o .:? "executionUnitPrices"
        <*> o .:? "maxTxExecutionUnits"
        <*> o .:? "maxBlockExecutionUnits"
        <*> o .:? "maxValueSize"
        <*> o .:? "collateralPercentage"
        <*> o .:? "maxCollateralInputs"
        <*> o .:? "utxoCostPerByte"

-- To avoid defining `CostModel` and `CostModels` again here.
unCostModels :: Map.Map Plutus.Language [Int64]
             -> Map.Map AnyPlutusScriptVersion CostModel
unCostModels = Map.mapKeys fromPlutusLanguageName . Map.map toApiCostModel

-- Yes, goes to-from CBOR to make the copy-pasta work without `unCostModels` =).
toApiCostModel :: [Int64] -> CostModel
toApiCostModel int64s = CBOR.unsafeDeserialize' (CBOR.serialize' int64s)

fromPlutusLanguageName :: Plutus.Language -> AnyPlutusScriptVersion
fromPlutusLanguageName Plutus.PlutusV1 = AnyPlutusScriptVersion PlutusScriptV1
fromPlutusLanguageName Plutus.PlutusV2 = AnyPlutusScriptVersion PlutusScriptV2
fromPlutusLanguageName Plutus.PlutusV3 = AnyPlutusScriptVersion PlutusScriptV3
fromPlutusLanguageName Plutus.PlutusV4 = AnyPlutusScriptVersion PlutusScriptV4

instance Aeson.ToJSON ProtocolParameters where
  toJSON ProtocolParameters{..} =
    Aeson.object
      [ "extraPraosEntropy" .= protocolParamExtraPraosEntropy
      , "stakePoolTargetNum" .= protocolParamStakePoolTargetNum
      , "minUTxOValue" .= protocolParamMinUTxOValue
      , "poolRetireMaxEpoch" .= protocolParamPoolRetireMaxEpoch
      , "decentralization" .= (toRationalJSON <$> protocolParamDecentralization)
      , "stakePoolDeposit" .= protocolParamStakePoolDeposit
      , "maxBlockHeaderSize" .= protocolParamMaxBlockHeaderSize
      , "maxBlockBodySize" .= protocolParamMaxBlockBodySize
      , "maxTxSize" .= protocolParamMaxTxSize
      , "treasuryCut" .= toRationalJSON protocolParamTreasuryCut
      , "minPoolCost" .= protocolParamMinPoolCost
      , "monetaryExpansion" .= toRationalJSON protocolParamMonetaryExpansion
      , "stakeAddressDeposit" .= protocolParamStakeAddressDeposit
      , "poolPledgeInfluence" .= toRationalJSON protocolParamPoolPledgeInfluence
      , "protocolVersion"
          .= let (major, minor) = protocolParamProtocolVersion
              in Aeson.object ["major" .= major, "minor" .= minor]
      , "txFeeFixed" .= protocolParamTxFeeFixed
      , "txFeePerByte" .= protocolParamTxFeePerByte
      , -- Alonzo era:
{-- DIFF: To avoid defining `CostModel` and `CostModels` again here.
        "costModels" .= CostModels protocolParamCostModels
--}
        ("costModels", costModelToAesonValue protocolParamCostModels)
      , "executionUnitPrices" .= protocolParamPrices
      , "maxTxExecutionUnits" .= protocolParamMaxTxExUnits
      , "maxBlockExecutionUnits" .= protocolParamMaxBlockExUnits
      , "maxValueSize" .= protocolParamMaxValueSize
      , "collateralPercentage" .= protocolParamCollateralPercent
      , "maxCollateralInputs" .= protocolParamMaxCollateralInputs
      , -- Babbage era:
        "utxoCostPerByte" .= protocolParamUTxOCostPerByte
      ]

-- Yes, uses CBOR and Aeson to make it work without redefining `CostModels`.
costModelToAesonValue :: Map.Map AnyPlutusScriptVersion CostModel -> Aeson.Value
costModelToAesonValue costModels = Aeson.Object $ KeyMap.fromMapText $ Map.fromList $
  map
    (\(k,v) ->
      ( Text.pack $ show $ toPlutusLanguageName k
      , let int64s = (CBOR.unsafeDeserialize' $ CBOR.serialize' v :: [Int64])
        in Aeson.toJSON int64s
      )
    )
    (Map.toList costModels)

toPlutusLanguageName :: AnyPlutusScriptVersion -> Plutus.Language
toPlutusLanguageName (AnyPlutusScriptVersion PlutusScriptV1) = Plutus.PlutusV1
toPlutusLanguageName (AnyPlutusScriptVersion PlutusScriptV2) = Plutus.PlutusV2
toPlutusLanguageName (AnyPlutusScriptVersion PlutusScriptV3) = Plutus.PlutusV3
toPlutusLanguageName (AnyPlutusScriptVersion PlutusScriptV4) = Plutus.PlutusV4

-- Praos nonce.
--------------------------------------------------------------------------------

-- Duplicated from "cardano-api" module "Cardano.Api.Internal.ProtocolParameters"
fromLedgerNonce :: Ledger.Nonce -> Maybe PraosNonce
fromLedgerNonce Ledger.NeutralNonce = Nothing
{-- DIFF: Avoids defining `PraosNonce` again.
fromLedgerNonce (Ledger.Nonce h) = Just (PraosNonce (Crypto.castHash h))
--}
-- Converts to ByteSring and back.
fromLedgerNonce (Ledger.Nonce h) = Just (makePraosNonce $ Crypto.hashToBytes (Crypto.castHash h))

-- Conversion functions: updates to ledger types.
--------------------------------------------------------------------------------

-- Duplicated from "cardano-api" module "Cardano.Api.Internal.ProtocolParameters"
requireParam
  :: String
  -> (a -> Either ProtocolParametersConversionError b)
  -> Maybe a
  -> Either ProtocolParametersConversionError b
requireParam paramName = maybe (Left $ PpceMissingParameter paramName)

-- Duplicated from "cardano-api" module "Cardano.Api.Internal.ProtocolParameters"
mkProtVer :: (Natural, Natural) -> Either ProtocolParametersConversionError Ledger.ProtVer
mkProtVer (majorProtVer, minorProtVer) =
  maybeToRight (PpceVersionInvalid majorProtVer) $
    (`Ledger.ProtVer` minorProtVer) <$> Ledger.mkVersion majorProtVer

-- Duplicated from "cardano-api" module "Cardano.Api.Internal.ProtocolParameters"
boundRationalEither
  :: Ledger.BoundedRational b
  => String
  -> Rational
  -> Either ProtocolParametersConversionError b
boundRationalEither name r = maybeToRight (PpceOutOfBounds name r) $ Ledger.boundRational r

-- Conversion functions: protocol parameters to ledger types.
--------------------------------------------------------------------------------

-- Was removed in "cardano-api" module "Cardano.Api.Internal.ProtocolParameters"
toLedgerPParams
  :: ShelleyBasedEra era
  -> ProtocolParameters
  -> Either ProtocolParametersConversionError (Ledger.PParams (ShelleyLedgerEra era))
toLedgerPParams ShelleyBasedEraShelley = toShelleyPParams
toLedgerPParams ShelleyBasedEraAllegra = toShelleyPParams
toLedgerPParams ShelleyBasedEraMary = toShelleyPParams
toLedgerPParams ShelleyBasedEraAlonzo = toAlonzoPParams
toLedgerPParams ShelleyBasedEraBabbage = toBabbagePParams
toLedgerPParams ShelleyBasedEraConway = toConwayPParams
toLedgerPParams ShelleyBasedEraDijkstra = toConwayPParams

-- Was removed in "cardano-api" module "Cardano.Api.Internal.ProtocolParameters"
toShelleyCommonPParams
  :: EraPParams ledgerera
  => ProtocolParameters
  -> Either ProtocolParametersConversionError (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
            & ppTxFeePerByteL .~ (CoinPerByte . L.compactCoinOrError $ protocolParamTxFeePerByte)
            & ppTxFeeFixedL .~ protocolParamTxFeeFixed
            & ppMaxBBSizeL .~ fromIntegral protocolParamMaxBlockBodySize
            & ppMaxTxSizeL .~ fromIntegral protocolParamMaxTxSize
            & ppMaxBHSizeL .~ fromIntegral protocolParamMaxBlockHeaderSize
            & ppKeyDepositL .~ protocolParamStakeAddressDeposit
            & ppPoolDepositL .~ protocolParamStakePoolDeposit
            & ppEMaxL .~ protocolParamPoolRetireMaxEpoch
            & ppNOptL .~ protocolParamStakePoolTargetNum
            & ppA0L .~ a0
            & ppRhoL .~ rho
            & ppTauL .~ tau
            & ppProtocolVersionL .~ protVer
            & ppMinPoolCostL .~ protocolParamMinPoolCost
    pure ppCommon

-- Was removed in "cardano-api" module "Cardano.Api.Internal.ProtocolParameters"
toShelleyPParams
  :: ( EraPParams ledgerera
     , Ledger.AtMostEra "Mary" ledgerera
     , Ledger.AtMostEra "Alonzo" ledgerera
     )
  => ProtocolParameters
  -> Either ProtocolParametersConversionError (PParams ledgerera)
toShelleyPParams
  protocolParameters@ProtocolParameters
    { protocolParamDecentralization
    , protocolParamExtraPraosEntropy
    , protocolParamMinUTxOValue
    } = do
    ppCommon <- toShelleyCommonPParams protocolParameters
    d <-
      boundRationalEither "D"
        =<< maybeToRight (PpceMissingParameter "decentralization") protocolParamDecentralization
    minUTxOValue <-
      maybeToRight (PpceMissingParameter "protocolParamMinUTxOValue") protocolParamMinUTxOValue
    let ppShelley =
          ppCommon
            & ppDL .~ d
            & ppExtraEntropyL .~ toLedgerNonce protocolParamExtraPraosEntropy
            & ppMinUTxOValueL .~ minUTxOValue
    pure ppShelley

-- Was removed in "cardano-api" module "Cardano.Api.Internal.ProtocolParameters"
toAlonzoCommonPParams
  :: AlonzoEraPParams ledgerera
  => ProtocolParameters
  -> Either ProtocolParametersConversionError (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 .~ (fromIntegral maxValueSize)
            & ppCollateralPercentageL .~ (fromIntegral collateralPercent)
            & ppMaxCollateralInputsL .~ (fromIntegral maxCollateralInputs)
    pure ppAlonzoCommon

-- Was removed in "cardano-api" module "Cardano.Api.Internal.ProtocolParameters"
toAlonzoPParams
  :: ProtocolParameters
  -> Either ProtocolParametersConversionError (PParams Ledger.AlonzoEra)
toAlonzoPParams
  protocolParameters@ProtocolParameters
    { protocolParamDecentralization
    } = do
    ppAlonzoCommon <- toAlonzoCommonPParams protocolParameters
    d <-
      requireParam
        "protocolParamDecentralization"
        (boundRationalEither "D")
        protocolParamDecentralization
    let ppAlonzo =
          ppAlonzoCommon
            & ppDL .~ d
    pure ppAlonzo

-- Was removed in "cardano-api" module "Cardano.Api.Internal.ProtocolParameters"
toBabbagePParams
  :: BabbageEraPParams ledgerera
  => ProtocolParameters
  -> Either ProtocolParametersConversionError (PParams ledgerera)
toBabbagePParams
  protocolParameters@ProtocolParameters
    { protocolParamUTxOCostPerByte
    } = do
    ppAlonzoCommon <- toAlonzoCommonPParams protocolParameters
    utxoCostPerByte <-
      requireParam "protocolParamUTxOCostPerByte" Right protocolParamUTxOCostPerByte
    let ppBabbage =
          ppAlonzoCommon
            & ppCoinsPerUTxOByteL .~ CoinPerByte (L.compactCoinOrError utxoCostPerByte)
    pure ppBabbage

-- Was removed in "cardano-api" module "Cardano.Api.Internal.ProtocolParameters"
toConwayPParams
  :: BabbageEraPParams ledgerera
  => ProtocolParameters
  -> Either ProtocolParametersConversionError (PParams ledgerera)
toConwayPParams = toBabbagePParams

-- Conversion functions: protocol parameters from ledger types.
--------------------------------------------------------------------------------

fromLedgerPParams
  :: ShelleyBasedEra era
  -> Ledger.PParams (ShelleyLedgerEra era)
  -> ProtocolParameters
fromLedgerPParams ShelleyBasedEraShelley = fromShelleyPParams
fromLedgerPParams ShelleyBasedEraAllegra = fromShelleyPParams
fromLedgerPParams ShelleyBasedEraMary = fromShelleyPParams
fromLedgerPParams ShelleyBasedEraAlonzo = fromExactlyAlonzoPParams
fromLedgerPParams ShelleyBasedEraBabbage = fromBabbagePParams
fromLedgerPParams ShelleyBasedEraConway = fromConwayPParams
fromLedgerPParams ShelleyBasedEraDijkstra = fromConwayPParams

fromShelleyCommonPParams
  :: EraPParams ledgerera
  => PParams ledgerera
  -> ProtocolParameters
fromShelleyCommonPParams pp =
  ProtocolParameters
    { protocolParamProtocolVersion = case pp ^. ppProtocolVersionL of
        Ledger.ProtVer a b -> (Ledger.getVersion a, b)
    , protocolParamMaxBlockHeaderSize = fromIntegral $ pp ^. ppMaxBHSizeL
    , protocolParamMaxBlockBodySize = fromIntegral $ pp ^. ppMaxBBSizeL
    , protocolParamMaxTxSize = fromIntegral $ pp ^. ppMaxTxSizeL
    , protocolParamTxFeeFixed = pp ^. ppTxFeeFixedL
    , protocolParamTxFeePerByte = L.fromCompact . L.unCoinPerByte $ pp ^. ppTxFeePerByteL
    , protocolParamStakeAddressDeposit = pp ^. ppKeyDepositL
    , protocolParamStakePoolDeposit = pp ^. ppPoolDepositL
    , protocolParamMinPoolCost = pp ^. ppMinPoolCostL
    , protocolParamPoolRetireMaxEpoch = pp ^. ppEMaxL
    , protocolParamStakePoolTargetNum = pp ^. ppNOptL
    , protocolParamPoolPledgeInfluence = Ledger.unboundRational (pp ^. ppA0L)
    , protocolParamMonetaryExpansion = Ledger.unboundRational (pp ^. ppRhoL)
    , protocolParamTreasuryCut = Ledger.unboundRational (pp ^. ppTauL)
    , 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 "Mary" ledgerera
     , Ledger.AtMostEra "Alonzo" ledgerera
     )
  => PParams ledgerera
  -> ProtocolParameters
fromShelleyPParams pp =
  (fromShelleyCommonPParams pp)
    { protocolParamDecentralization = Just . Ledger.unboundRational $ pp ^. ppDL
    , protocolParamExtraPraosEntropy = fromLedgerNonce $ pp ^. ppExtraEntropyL
    , protocolParamMinUTxOValue = Just $ pp ^. ppMinUTxOValueL
    }

fromAlonzoPParams
  :: AlonzoEraPParams ledgerera
  => PParams ledgerera
  -> ProtocolParameters
fromAlonzoPParams pp =
  (fromShelleyCommonPParams pp)
    { protocolParamCostModels = fromAlonzoCostModels $ pp ^. ppCostModelsL
    , protocolParamDecentralization = Just . Ledger.unboundRational $ pp ^. ppDG
    , protocolParamPrices = Just . fromAlonzoPrices $ pp ^. ppPricesL
    , protocolParamMaxTxExUnits = Just . fromAlonzoExUnits $ pp ^. ppMaxTxExUnitsL
    , protocolParamMaxBlockExUnits = Just . fromAlonzoExUnits $ pp ^. ppMaxBlockExUnitsL
    , protocolParamMaxValueSize = Just $ fromIntegral (pp ^. ppMaxValSizeL)
    , protocolParamCollateralPercent = Just $ fromIntegral (pp ^. ppCollateralPercentageL)
    , protocolParamMaxCollateralInputs = Just $ fromIntegral (pp ^. ppMaxCollateralInputsL)
    }

fromExactlyAlonzoPParams
  :: (AlonzoEraPParams ledgerera, Ledger.ExactEra Ledger.AlonzoEra ledgerera)
  => PParams ledgerera
  -> ProtocolParameters
fromExactlyAlonzoPParams pp =
  (fromAlonzoPParams pp)
    { protocolParamUTxOCostPerByte = Just . unCoinPerWord $ pp ^. ppCoinsPerUTxOWordL
    }

fromBabbagePParams
  :: BabbageEraPParams ledgerera
  => PParams ledgerera
  -> ProtocolParameters
fromBabbagePParams pp =
  (fromAlonzoPParams pp)
    { protocolParamUTxOCostPerByte = Just . L.fromCompact . unCoinPerByte $ pp ^. ppCoinsPerUTxOByteL
    , protocolParamDecentralization = Nothing
    }

fromConwayPParams
  :: BabbageEraPParams ledgerera
  => PParams ledgerera
  -> ProtocolParameters
fromConwayPParams = fromBabbagePParams

--------------------------------------------------------------------------------
-- From module Cardano.Api.Internal.Json
--------------------------------------------------------------------------------

-- Rationals and JSON are an awkward mix. We cannot convert rationals
-- like @1/3@ to JSON numbers. But _most_ of the numbers we want to use
-- in practice have simple decimal representations. Our solution here is
-- to use simple decimal representations where we can and representation
-- in a @{"numerator": 1, "denominator": 3}@ style otherwise.
--
toRationalJSON :: Rational -> Aeson.Value
toRationalJSON r =
  case Scientific.fromRationalRepetendLimited 20 r of
    Right (s, Nothing) -> Aeson.toJSON s
    _ -> Aeson.toJSON r