From 3d6de33d017dddcc328378868253ea6b900a7c2c Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Cl=C3=A9ment=20Hurlin?= Date: Wed, 15 Jan 2025 16:29:27 +0100 Subject: [PATCH] ProtocolParameters.hs: propagate new error behavior --- .../Cardano/Api/ProtocolParameters.hs | 197 ++++++++++-------- 1 file changed, 115 insertions(+), 82 deletions(-) diff --git a/cardano-api/internal/Cardano/Api/ProtocolParameters.hs b/cardano-api/internal/Cardano/Api/ProtocolParameters.hs index b901a3670..95c0c837f 100644 --- a/cardano-api/internal/Cardano/Api/ProtocolParameters.hs +++ b/cardano-api/internal/Cardano/Api/ProtocolParameters.hs @@ -146,11 +146,12 @@ import Data.Aeson (FromJSON (..), ToJSON (..), object, withObject, (.! import Data.Bifunctor (bimap, first) import Data.ByteString (ByteString) import Data.Data (Data) +import Data.Either (partitionEithers) import Data.Either.Combinators (maybeToRight) import Data.Int (Int64) import Data.Map.Strict (Map) import qualified Data.Map.Strict as Map -import Data.Maybe (isJust) +import Data.Maybe (fromMaybe, isJust) import Data.Maybe.Strict (StrictMaybe (..)) import Data.String (IsString) import Data.Text (Text) @@ -1006,7 +1007,12 @@ newtype CostModels = CostModels {unCostModels :: Map AnyPlutusScriptVersion Cost deriving (Eq, Show) instance FromJSON CostModels where - parseJSON v = CostModels . fromAlonzoCostModels <$> parseJSON v + parseJSON v = + case sequence parsed of + Left err -> fail $ displayError err + Right costModels -> CostModels <$> costModels + where + parsed = fromAlonzoCostModels <$> parseJSON v instance ToJSON CostModels where toJSON (CostModels costModels) = @@ -1030,12 +1036,15 @@ toAlonzoCostModels m = do fromAlonzoCostModels :: Plutus.CostModels - -> Map AnyPlutusScriptVersion CostModel + -> Either CostModelNotEnoughParametersError (Map AnyPlutusScriptVersion CostModel) fromAlonzoCostModels cModels = - fromList - . map (bimap fromAlonzoScriptLanguage fromAlonzoCostModel) - $ toList - $ Plutus.costModelsValid cModels + case Map.toList errs of + [] -> Right $ Map.mapKeys fromAlonzoScriptLanguage models -- All models are valid + ((lang, err) : _) -> Left err -- Take first error + where + (errs, models) = Map.mapEither id entries + entries :: Map Plutus.Language (Either CostModelNotEnoughParametersError CostModel) + entries = Map.map fromAlonzoCostModel $ Plutus.costModelsValid cModels toAlonzoScriptLanguage :: AnyPlutusScriptVersion -> Plutus.Language toAlonzoScriptLanguage (AnyPlutusScriptVersion PlutusScriptV1) = Plutus.PlutusV1 @@ -1051,8 +1060,11 @@ toAlonzoCostModel :: CostModel -> Plutus.Language -> Either ProtocolParametersConversionError Alonzo.CostModel toAlonzoCostModel (CostModel m) l = first (PpceInvalidCostModel (CostModel m)) $ Alonzo.mkCostModel l m -fromAlonzoCostModel :: Alonzo.CostModel -> CostModel -fromAlonzoCostModel m = CostModel $ Alonzo.getCostModelParams m +fromAlonzoCostModel :: Alonzo.CostModel -> Either CostModelNotEnoughParametersError CostModel +fromAlonzoCostModel m = validateCostModelSize Nothing lang params + where + params = Alonzo.getCostModelParams m + lang = Alonzo.getCostModelLanguage m validateCostModelSize :: Maybe (ShelleyBasedEra era) @@ -1365,13 +1377,15 @@ fromLedgerProposedPPUpdates sbe = fromLedgerPParamsUpdate :: ShelleyBasedEra era -> Ledger.PParamsUpdate (ShelleyLedgerEra era) - -> ProtocolParametersUpdate -fromLedgerPParamsUpdate ShelleyBasedEraShelley = fromShelleyPParamsUpdate -fromLedgerPParamsUpdate ShelleyBasedEraAllegra = fromShelleyPParamsUpdate -fromLedgerPParamsUpdate ShelleyBasedEraMary = fromShelleyPParamsUpdate -fromLedgerPParamsUpdate ShelleyBasedEraAlonzo = fromAlonzoPParamsUpdate -fromLedgerPParamsUpdate ShelleyBasedEraBabbage = fromBabbagePParamsUpdate -fromLedgerPParamsUpdate ShelleyBasedEraConway = fromConwayPParamsUpdate + -> Either CostModelNotEnoughParametersError ProtocolParametersUpdate +fromLedgerPParamsUpdate era ppu = + case era of + ShelleyBasedEraShelley -> pure $ fromShelleyPParamsUpdate ppu + ShelleyBasedEraAllegra -> pure $ fromShelleyPParamsUpdate ppu + ShelleyBasedEraMary -> pure $ fromShelleyPParamsUpdate ppu + ShelleyBasedEraAlonzo -> fromAlonzoPParamsUpdate ppu + ShelleyBasedEraBabbage -> fromBabbagePParamsUpdate ppu + ShelleyBasedEraConway -> fromConwayPParamsUpdate ppu fromShelleyCommonPParamsUpdate :: EraPParams ledgerera @@ -1431,64 +1445,74 @@ fromShelleyPParamsUpdate ppu = fromAlonzoCommonPParamsUpdate :: AlonzoEraPParams ledgerera => PParamsUpdate ledgerera - -> ProtocolParametersUpdate + -> Either CostModelNotEnoughParametersError ProtocolParametersUpdate fromAlonzoCommonPParamsUpdate ppu = - (fromShelleyCommonPParamsUpdate ppu) - { protocolUpdateCostModels = - maybe - mempty - fromAlonzoCostModels - (strictMaybeToMaybe (ppu ^. ppuCostModelsL)) - , protocolUpdatePrices = - fromAlonzoPrices - <$> strictMaybeToMaybe (ppu ^. ppuPricesL) - , protocolUpdateMaxTxExUnits = - fromAlonzoExUnits - <$> strictMaybeToMaybe (ppu ^. ppuMaxTxExUnitsL) - , protocolUpdateMaxBlockExUnits = - fromAlonzoExUnits - <$> strictMaybeToMaybe (ppu ^. ppuMaxBlockExUnitsL) - , protocolUpdateMaxValueSize = strictMaybeToMaybe (ppu ^. ppuMaxValSizeL) - , protocolUpdateCollateralPercent = strictMaybeToMaybe (ppu ^. ppuCollateralPercentageL) - , protocolUpdateMaxCollateralInputs = strictMaybeToMaybe (ppu ^. ppuMaxCollateralInputsL) - , protocolUpdateUTxOCostPerByte = Nothing - } + case costModels of + Left err -> Left err + Right mCostModelMap -> + Right $ + (fromShelleyCommonPParamsUpdate ppu) + { protocolUpdateCostModels = fromMaybe mempty mCostModelMap + , protocolUpdatePrices = + fromAlonzoPrices + <$> strictMaybeToMaybe (ppu ^. ppuPricesL) + , protocolUpdateMaxTxExUnits = + fromAlonzoExUnits + <$> strictMaybeToMaybe (ppu ^. ppuMaxTxExUnitsL) + , protocolUpdateMaxBlockExUnits = + fromAlonzoExUnits + <$> strictMaybeToMaybe (ppu ^. ppuMaxBlockExUnitsL) + , protocolUpdateMaxValueSize = strictMaybeToMaybe (ppu ^. ppuMaxValSizeL) + , protocolUpdateCollateralPercent = strictMaybeToMaybe (ppu ^. ppuCollateralPercentageL) + , protocolUpdateMaxCollateralInputs = strictMaybeToMaybe (ppu ^. ppuMaxCollateralInputsL) + , protocolUpdateUTxOCostPerByte = Nothing + } + where + mCostModels :: Maybe (Plutus.CostModels) + mCostModels = strictMaybeToMaybe (ppu ^. ppuCostModelsL) + costModels :: Either + CostModelNotEnoughParametersError + (Maybe (Map AnyPlutusScriptVersion CostModel)) + costModels = sequence $ fromAlonzoCostModels <$> mCostModels fromAlonzoPParamsUpdate :: Ledger.Crypto crypto => PParamsUpdate (Ledger.AlonzoEra crypto) - -> ProtocolParametersUpdate + -> Either CostModelNotEnoughParametersError ProtocolParametersUpdate fromAlonzoPParamsUpdate ppu = - (fromAlonzoCommonPParamsUpdate ppu) - { protocolUpdateProtocolVersion = - (\(Ledger.ProtVer a b) -> (Ledger.getVersion a, b)) - <$> strictMaybeToMaybe (ppu ^. ppuProtocolVersionL) - } + (fromAlonzoCommonPParamsUpdate ppu) <&> \ppu' -> + ppu' + { protocolUpdateProtocolVersion = + (\(Ledger.ProtVer a b) -> (Ledger.getVersion a, b)) + <$> strictMaybeToMaybe (ppu ^. ppuProtocolVersionL) + } fromBabbageCommonPParamsUpdate :: BabbageEraPParams ledgerera => PParamsUpdate ledgerera - -> ProtocolParametersUpdate + -> Either CostModelNotEnoughParametersError ProtocolParametersUpdate fromBabbageCommonPParamsUpdate ppu = - (fromAlonzoCommonPParamsUpdate ppu) - { protocolUpdateUTxOCostPerByte = unCoinPerByte <$> strictMaybeToMaybe (ppu ^. ppuCoinsPerUTxOByteL) - } + (fromAlonzoCommonPParamsUpdate ppu) <&> \ppu' -> + ppu' + { protocolUpdateUTxOCostPerByte = unCoinPerByte <$> strictMaybeToMaybe (ppu ^. ppuCoinsPerUTxOByteL) + } fromBabbagePParamsUpdate :: Ledger.Crypto crypto => PParamsUpdate (Ledger.BabbageEra crypto) - -> ProtocolParametersUpdate + -> Either CostModelNotEnoughParametersError ProtocolParametersUpdate fromBabbagePParamsUpdate ppu = - (fromBabbageCommonPParamsUpdate ppu) - { protocolUpdateProtocolVersion = - (\(Ledger.ProtVer a b) -> (Ledger.getVersion a, b)) - <$> strictMaybeToMaybe (ppu ^. ppuProtocolVersionL) - } + (fromBabbageCommonPParamsUpdate ppu) <&> \ppu' -> + ppu' + { protocolUpdateProtocolVersion = + (\(Ledger.ProtVer a b) -> (Ledger.getVersion a, b)) + <$> strictMaybeToMaybe (ppu ^. ppuProtocolVersionL) + } fromConwayPParamsUpdate :: BabbageEraPParams ledgerera => PParamsUpdate ledgerera - -> ProtocolParametersUpdate + -> Either CostModelNotEnoughParametersError ProtocolParametersUpdate fromConwayPParamsUpdate = fromBabbageCommonPParamsUpdate -- ---------------------------------------------------------------------------- @@ -1666,13 +1690,15 @@ toConwayPParams = toBabbagePParams 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 + -> Either CostModelNotEnoughParametersError ProtocolParameters +fromLedgerPParams sbe pp = + case sbe of + ShelleyBasedEraShelley -> pure $ fromShelleyPParams pp + ShelleyBasedEraAllegra -> pure $ fromShelleyPParams pp + ShelleyBasedEraMary -> pure $ fromShelleyPParams pp + ShelleyBasedEraAlonzo -> fromExactlyAlonzoPParams pp + ShelleyBasedEraBabbage -> fromBabbagePParams pp + ShelleyBasedEraConway -> fromConwayPParams pp {-# DEPRECATED fromShelleyCommonPParams @@ -1737,18 +1763,23 @@ fromShelleyPParams pp = fromAlonzoPParams :: AlonzoEraPParams ledgerera => PParams ledgerera - -> ProtocolParameters + -> Either CostModelNotEnoughParametersError 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 $ pp ^. ppMaxValSizeL - , protocolParamCollateralPercent = Just $ pp ^. ppCollateralPercentageL - , protocolParamMaxCollateralInputs = Just $ pp ^. ppMaxCollateralInputsL - } + ppCostModels <&> \costModels -> + base + { protocolParamCostModels = costModels + , protocolParamDecentralization = Just . Ledger.unboundRational $ pp ^. ppDG + , 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 + } + where + base = fromShelleyCommonPParams pp + ppCostModels :: Either CostModelNotEnoughParametersError (Map AnyPlutusScriptVersion CostModel) + ppCostModels = fromAlonzoCostModels $ pp ^. ppCostModelsL {-# DEPRECATED fromExactlyAlonzoPParams @@ -1757,11 +1788,12 @@ fromAlonzoPParams pp = fromExactlyAlonzoPParams :: (AlonzoEraPParams ledgerera, Ledger.ExactEra Ledger.AlonzoEra ledgerera) => PParams ledgerera - -> ProtocolParameters + -> Either CostModelNotEnoughParametersError ProtocolParameters fromExactlyAlonzoPParams pp = - (fromAlonzoPParams pp) - { protocolParamUTxOCostPerByte = Just . unCoinPerWord $ pp ^. ppCoinsPerUTxOWordL - } + (fromAlonzoPParams pp) <&> \pp' -> + pp' + { protocolParamUTxOCostPerByte = Just . unCoinPerWord $ pp ^. ppCoinsPerUTxOWordL + } {-# DEPRECATED fromBabbagePParams @@ -1770,12 +1802,13 @@ fromExactlyAlonzoPParams pp = fromBabbagePParams :: BabbageEraPParams ledgerera => PParams ledgerera - -> ProtocolParameters + -> Either CostModelNotEnoughParametersError ProtocolParameters fromBabbagePParams pp = - (fromAlonzoPParams pp) - { protocolParamUTxOCostPerByte = Just . unCoinPerByte $ pp ^. ppCoinsPerUTxOByteL - , protocolParamDecentralization = Nothing - } + (fromAlonzoPParams pp) <&> \pp' -> + pp' + { protocolParamUTxOCostPerByte = Just . unCoinPerByte $ pp ^. ppCoinsPerUTxOByteL + , protocolParamDecentralization = Nothing + } {-# DEPRECATED fromConwayPParams @@ -1784,7 +1817,7 @@ fromBabbagePParams pp = fromConwayPParams :: BabbageEraPParams ledgerera => PParams ledgerera - -> ProtocolParameters + -> Either CostModelNotEnoughParametersError ProtocolParameters fromConwayPParams = fromBabbagePParams {-# DEPRECATED