Skip to content

Commit

Permalink
ProtocolParameters.hs: add function to validate cost model size
Browse files Browse the repository at this point in the history
  • Loading branch information
smelc committed Jan 15, 2025
1 parent 6632c4c commit 1b71664
Showing 1 changed file with 51 additions and 0 deletions.
51 changes: 51 additions & 0 deletions cardano-api/internal/Cardano/Api/ProtocolParameters.hs
Original file line number Diff line number Diff line change
Expand Up @@ -136,6 +136,9 @@ import qualified Cardano.Ledger.Plutus.Language as Plutus
import qualified Cardano.Ledger.Shelley.API as Ledger
import Cardano.Slotting.Slot (EpochNo (..))
import PlutusLedgerApi.Common (CostModelApplyError)
import qualified PlutusLedgerApi.V1.ParamName as PlutusV1
import qualified PlutusLedgerApi.V2.ParamName as PlutusV2
import qualified PlutusLedgerApi.V3.ParamName as PlutusV3

import Control.Monad
import Data.Aeson (FromJSON (..), ToJSON (..), object, withObject, (.!=), (.:), (.:?),
Expand Down Expand Up @@ -1051,6 +1054,40 @@ toAlonzoCostModel (CostModel m) l = first (PpceInvalidCostModel (CostModel m)) $
fromAlonzoCostModel :: Alonzo.CostModel -> CostModel
fromAlonzoCostModel m = CostModel $ Alonzo.getCostModelParams m

validateCostModelSize
:: Maybe (ShelleyBasedEra era)
-> Plutus.Language
-> [Int64]
-> Either CostModelNotEnoughParametersError CostModel
validateCostModelSize mSbe lang model
| actual < expected = Left $ CostModelNotEnoughParametersError lang expected actual
| actual == expected = Right $ CostModel model
| otherwise =
-- Since the number of parameters can increase in future versions of the Plutus language,
-- we are fine having too many parameters. This allows for easier testing.
Right $ CostModel model
where
actual = length model
expected = languageToMinimumParameterCount lang
allValues :: forall a. (Bounded a, Enum a) => [a]
allValues = [minBound :: a .. maxBound]
languageToMinimumParameterCount :: Plutus.Language -> Int
languageToMinimumParameterCount = \case
Plutus.PlutusV1 -> length $ allValues @PlutusV1.ParamName -- 166
Plutus.PlutusV2 ->
let nParamNames = length $ allValues @PlutusV2.ParamName -- 185
in case mSbe of
Nothing ->
-- We don't know the era, so we can't know the exact number of parameters that is expected,
-- so we need to be lenient
nParamNames - 10
Just sbe ->
caseShelleyToBabbageOrConwayEraOnwards
(const $ nParamNames - 10) -- Ten parameters were added to V2 in Conway, need to remove them here
(const nParamNames)
sbe
Plutus.PlutusV3 -> length $ allValues @PlutusV3.ParamName -- 297

-- ----------------------------------------------------------------------------
-- Proposals embedded in transactions to update protocol parameters
--
Expand Down Expand Up @@ -1853,6 +1890,11 @@ data ProtocolParametersConversionError
| PpceMissingParameter !ProtocolParameterName
deriving (Eq, Show, Data)

-- | @CostModelNotEnoughParametersError lang minimum actual@ is returned when the observed number of
-- protocol parameters for @lang@ is @actual@ and that number is below the @minimum@ expected number of parameters.
data CostModelNotEnoughParametersError
= CostModelNotEnoughParametersError Plutus.Language Int Int

type ProtocolParameterName = String

type ProtocolParameterVersion = Natural
Expand All @@ -1867,3 +1909,12 @@ instance Error ProtocolParametersConversionError where
"Invalid cost model: " <> pretty @Text (display err) <> " Cost model: " <> pshow cm
PpceMissingParameter name ->
"Missing parameter: " <> pretty name

instance Error CostModelNotEnoughParametersError where
prettyError (CostModelNotEnoughParametersError lang minimum' actual) =
"Not enough parameters for language "
<> pretty (Plutus.languageToText lang)
<> ". Expected at least "
<> pretty minimum'
<> " parameters but got "
<> pretty actual

0 comments on commit 1b71664

Please sign in to comment.