Skip to content

Commit 3d6de33

Browse files
smelcsmelc
committed
ProtocolParameters.hs: propagate new error behavior
1 parent 1b71664 commit 3d6de33

File tree

1 file changed

+115
-82
lines changed

1 file changed

+115
-82
lines changed

‎cardano-api/internal/Cardano/Api/ProtocolParameters.hs

+115-82
Original file line numberDiff line numberDiff line change
@@ -146,11 +146,12 @@ import Data.Aeson (FromJSON (..), ToJSON (..), object, withObject, (.!
146146
import Data.Bifunctor (bimap, first)
147147
import Data.ByteString (ByteString)
148148
import Data.Data (Data)
149+
import Data.Either (partitionEithers)
149150
import Data.Either.Combinators (maybeToRight)
150151
import Data.Int (Int64)
151152
import Data.Map.Strict (Map)
152153
import qualified Data.Map.Strict as Map
153-
import Data.Maybe (isJust)
154+
import Data.Maybe (fromMaybe, isJust)
154155
import Data.Maybe.Strict (StrictMaybe (..))
155156
import Data.String (IsString)
156157
import Data.Text (Text)
@@ -1006,7 +1007,12 @@ newtype CostModels = CostModels {unCostModels :: Map AnyPlutusScriptVersion Cost
10061007
deriving (Eq, Show)
10071008

10081009
instance FromJSON CostModels where
1009-
parseJSON v = CostModels . fromAlonzoCostModels <$> parseJSON v
1010+
parseJSON v =
1011+
case sequence parsed of
1012+
Left err -> fail $ displayError err
1013+
Right costModels -> CostModels <$> costModels
1014+
where
1015+
parsed = fromAlonzoCostModels <$> parseJSON v
10101016

10111017
instance ToJSON CostModels where
10121018
toJSON (CostModels costModels) =
@@ -1030,12 +1036,15 @@ toAlonzoCostModels m = do
10301036

10311037
fromAlonzoCostModels
10321038
:: Plutus.CostModels
1033-
-> Map AnyPlutusScriptVersion CostModel
1039+
-> Either CostModelNotEnoughParametersError (Map AnyPlutusScriptVersion CostModel)
10341040
fromAlonzoCostModels cModels =
1035-
fromList
1036-
. map (bimap fromAlonzoScriptLanguage fromAlonzoCostModel)
1037-
$ toList
1038-
$ Plutus.costModelsValid cModels
1041+
case Map.toList errs of
1042+
[] -> Right $ Map.mapKeys fromAlonzoScriptLanguage models -- All models are valid
1043+
((lang, err) : _) -> Left err -- Take first error
1044+
where
1045+
(errs, models) = Map.mapEither id entries
1046+
entries :: Map Plutus.Language (Either CostModelNotEnoughParametersError CostModel)
1047+
entries = Map.map fromAlonzoCostModel $ Plutus.costModelsValid cModels
10391048

10401049
toAlonzoScriptLanguage :: AnyPlutusScriptVersion -> Plutus.Language
10411050
toAlonzoScriptLanguage (AnyPlutusScriptVersion PlutusScriptV1) = Plutus.PlutusV1
@@ -1051,8 +1060,11 @@ toAlonzoCostModel
10511060
:: CostModel -> Plutus.Language -> Either ProtocolParametersConversionError Alonzo.CostModel
10521061
toAlonzoCostModel (CostModel m) l = first (PpceInvalidCostModel (CostModel m)) $ Alonzo.mkCostModel l m
10531062

1054-
fromAlonzoCostModel :: Alonzo.CostModel -> CostModel
1055-
fromAlonzoCostModel m = CostModel $ Alonzo.getCostModelParams m
1063+
fromAlonzoCostModel :: Alonzo.CostModel -> Either CostModelNotEnoughParametersError CostModel
1064+
fromAlonzoCostModel m = validateCostModelSize Nothing lang params
1065+
where
1066+
params = Alonzo.getCostModelParams m
1067+
lang = Alonzo.getCostModelLanguage m
10561068

10571069
validateCostModelSize
10581070
:: Maybe (ShelleyBasedEra era)
@@ -1365,13 +1377,15 @@ fromLedgerProposedPPUpdates sbe =
13651377
fromLedgerPParamsUpdate
13661378
:: ShelleyBasedEra era
13671379
-> Ledger.PParamsUpdate (ShelleyLedgerEra era)
1368-
-> ProtocolParametersUpdate
1369-
fromLedgerPParamsUpdate ShelleyBasedEraShelley = fromShelleyPParamsUpdate
1370-
fromLedgerPParamsUpdate ShelleyBasedEraAllegra = fromShelleyPParamsUpdate
1371-
fromLedgerPParamsUpdate ShelleyBasedEraMary = fromShelleyPParamsUpdate
1372-
fromLedgerPParamsUpdate ShelleyBasedEraAlonzo = fromAlonzoPParamsUpdate
1373-
fromLedgerPParamsUpdate ShelleyBasedEraBabbage = fromBabbagePParamsUpdate
1374-
fromLedgerPParamsUpdate ShelleyBasedEraConway = fromConwayPParamsUpdate
1380+
-> Either CostModelNotEnoughParametersError ProtocolParametersUpdate
1381+
fromLedgerPParamsUpdate era ppu =
1382+
case era of
1383+
ShelleyBasedEraShelley -> pure $ fromShelleyPParamsUpdate ppu
1384+
ShelleyBasedEraAllegra -> pure $ fromShelleyPParamsUpdate ppu
1385+
ShelleyBasedEraMary -> pure $ fromShelleyPParamsUpdate ppu
1386+
ShelleyBasedEraAlonzo -> fromAlonzoPParamsUpdate ppu
1387+
ShelleyBasedEraBabbage -> fromBabbagePParamsUpdate ppu
1388+
ShelleyBasedEraConway -> fromConwayPParamsUpdate ppu
13751389

13761390
fromShelleyCommonPParamsUpdate
13771391
:: EraPParams ledgerera
@@ -1431,64 +1445,74 @@ fromShelleyPParamsUpdate ppu =
14311445
fromAlonzoCommonPParamsUpdate
14321446
:: AlonzoEraPParams ledgerera
14331447
=> PParamsUpdate ledgerera
1434-
-> ProtocolParametersUpdate
1448+
-> Either CostModelNotEnoughParametersError ProtocolParametersUpdate
14351449
fromAlonzoCommonPParamsUpdate ppu =
1436-
(fromShelleyCommonPParamsUpdate ppu)
1437-
{ protocolUpdateCostModels =
1438-
maybe
1439-
mempty
1440-
fromAlonzoCostModels
1441-
(strictMaybeToMaybe (ppu ^. ppuCostModelsL))
1442-
, protocolUpdatePrices =
1443-
fromAlonzoPrices
1444-
<$> strictMaybeToMaybe (ppu ^. ppuPricesL)
1445-
, protocolUpdateMaxTxExUnits =
1446-
fromAlonzoExUnits
1447-
<$> strictMaybeToMaybe (ppu ^. ppuMaxTxExUnitsL)
1448-
, protocolUpdateMaxBlockExUnits =
1449-
fromAlonzoExUnits
1450-
<$> strictMaybeToMaybe (ppu ^. ppuMaxBlockExUnitsL)
1451-
, protocolUpdateMaxValueSize = strictMaybeToMaybe (ppu ^. ppuMaxValSizeL)
1452-
, protocolUpdateCollateralPercent = strictMaybeToMaybe (ppu ^. ppuCollateralPercentageL)
1453-
, protocolUpdateMaxCollateralInputs = strictMaybeToMaybe (ppu ^. ppuMaxCollateralInputsL)
1454-
, protocolUpdateUTxOCostPerByte = Nothing
1455-
}
1450+
case costModels of
1451+
Left err -> Left err
1452+
Right mCostModelMap ->
1453+
Right $
1454+
(fromShelleyCommonPParamsUpdate ppu)
1455+
{ protocolUpdateCostModels = fromMaybe mempty mCostModelMap
1456+
, protocolUpdatePrices =
1457+
fromAlonzoPrices
1458+
<$> strictMaybeToMaybe (ppu ^. ppuPricesL)
1459+
, protocolUpdateMaxTxExUnits =
1460+
fromAlonzoExUnits
1461+
<$> strictMaybeToMaybe (ppu ^. ppuMaxTxExUnitsL)
1462+
, protocolUpdateMaxBlockExUnits =
1463+
fromAlonzoExUnits
1464+
<$> strictMaybeToMaybe (ppu ^. ppuMaxBlockExUnitsL)
1465+
, protocolUpdateMaxValueSize = strictMaybeToMaybe (ppu ^. ppuMaxValSizeL)
1466+
, protocolUpdateCollateralPercent = strictMaybeToMaybe (ppu ^. ppuCollateralPercentageL)
1467+
, protocolUpdateMaxCollateralInputs = strictMaybeToMaybe (ppu ^. ppuMaxCollateralInputsL)
1468+
, protocolUpdateUTxOCostPerByte = Nothing
1469+
}
1470+
where
1471+
mCostModels :: Maybe (Plutus.CostModels)
1472+
mCostModels = strictMaybeToMaybe (ppu ^. ppuCostModelsL)
1473+
costModels :: Either
1474+
CostModelNotEnoughParametersError
1475+
(Maybe (Map AnyPlutusScriptVersion CostModel))
1476+
costModels = sequence $ fromAlonzoCostModels <$> mCostModels
14561477

14571478
fromAlonzoPParamsUpdate
14581479
:: Ledger.Crypto crypto
14591480
=> PParamsUpdate (Ledger.AlonzoEra crypto)
1460-
-> ProtocolParametersUpdate
1481+
-> Either CostModelNotEnoughParametersError ProtocolParametersUpdate
14611482
fromAlonzoPParamsUpdate ppu =
1462-
(fromAlonzoCommonPParamsUpdate ppu)
1463-
{ protocolUpdateProtocolVersion =
1464-
(\(Ledger.ProtVer a b) -> (Ledger.getVersion a, b))
1465-
<$> strictMaybeToMaybe (ppu ^. ppuProtocolVersionL)
1466-
}
1483+
(fromAlonzoCommonPParamsUpdate ppu) <&> \ppu' ->
1484+
ppu'
1485+
{ protocolUpdateProtocolVersion =
1486+
(\(Ledger.ProtVer a b) -> (Ledger.getVersion a, b))
1487+
<$> strictMaybeToMaybe (ppu ^. ppuProtocolVersionL)
1488+
}
14671489

14681490
fromBabbageCommonPParamsUpdate
14691491
:: BabbageEraPParams ledgerera
14701492
=> PParamsUpdate ledgerera
1471-
-> ProtocolParametersUpdate
1493+
-> Either CostModelNotEnoughParametersError ProtocolParametersUpdate
14721494
fromBabbageCommonPParamsUpdate ppu =
1473-
(fromAlonzoCommonPParamsUpdate ppu)
1474-
{ protocolUpdateUTxOCostPerByte = unCoinPerByte <$> strictMaybeToMaybe (ppu ^. ppuCoinsPerUTxOByteL)
1475-
}
1495+
(fromAlonzoCommonPParamsUpdate ppu) <&> \ppu' ->
1496+
ppu'
1497+
{ protocolUpdateUTxOCostPerByte = unCoinPerByte <$> strictMaybeToMaybe (ppu ^. ppuCoinsPerUTxOByteL)
1498+
}
14761499

14771500
fromBabbagePParamsUpdate
14781501
:: Ledger.Crypto crypto
14791502
=> PParamsUpdate (Ledger.BabbageEra crypto)
1480-
-> ProtocolParametersUpdate
1503+
-> Either CostModelNotEnoughParametersError ProtocolParametersUpdate
14811504
fromBabbagePParamsUpdate ppu =
1482-
(fromBabbageCommonPParamsUpdate ppu)
1483-
{ protocolUpdateProtocolVersion =
1484-
(\(Ledger.ProtVer a b) -> (Ledger.getVersion a, b))
1485-
<$> strictMaybeToMaybe (ppu ^. ppuProtocolVersionL)
1486-
}
1505+
(fromBabbageCommonPParamsUpdate ppu) <&> \ppu' ->
1506+
ppu'
1507+
{ protocolUpdateProtocolVersion =
1508+
(\(Ledger.ProtVer a b) -> (Ledger.getVersion a, b))
1509+
<$> strictMaybeToMaybe (ppu ^. ppuProtocolVersionL)
1510+
}
14871511

14881512
fromConwayPParamsUpdate
14891513
:: BabbageEraPParams ledgerera
14901514
=> PParamsUpdate ledgerera
1491-
-> ProtocolParametersUpdate
1515+
-> Either CostModelNotEnoughParametersError ProtocolParametersUpdate
14921516
fromConwayPParamsUpdate = fromBabbageCommonPParamsUpdate
14931517

14941518
-- ----------------------------------------------------------------------------
@@ -1666,13 +1690,15 @@ toConwayPParams = toBabbagePParams
16661690
fromLedgerPParams
16671691
:: ShelleyBasedEra era
16681692
-> Ledger.PParams (ShelleyLedgerEra era)
1669-
-> ProtocolParameters
1670-
fromLedgerPParams ShelleyBasedEraShelley = fromShelleyPParams
1671-
fromLedgerPParams ShelleyBasedEraAllegra = fromShelleyPParams
1672-
fromLedgerPParams ShelleyBasedEraMary = fromShelleyPParams
1673-
fromLedgerPParams ShelleyBasedEraAlonzo = fromExactlyAlonzoPParams
1674-
fromLedgerPParams ShelleyBasedEraBabbage = fromBabbagePParams
1675-
fromLedgerPParams ShelleyBasedEraConway = fromConwayPParams
1693+
-> Either CostModelNotEnoughParametersError ProtocolParameters
1694+
fromLedgerPParams sbe pp =
1695+
case sbe of
1696+
ShelleyBasedEraShelley -> pure $ fromShelleyPParams pp
1697+
ShelleyBasedEraAllegra -> pure $ fromShelleyPParams pp
1698+
ShelleyBasedEraMary -> pure $ fromShelleyPParams pp
1699+
ShelleyBasedEraAlonzo -> fromExactlyAlonzoPParams pp
1700+
ShelleyBasedEraBabbage -> fromBabbagePParams pp
1701+
ShelleyBasedEraConway -> fromConwayPParams pp
16761702

16771703
{-# DEPRECATED
16781704
fromShelleyCommonPParams
@@ -1737,18 +1763,23 @@ fromShelleyPParams pp =
17371763
fromAlonzoPParams
17381764
:: AlonzoEraPParams ledgerera
17391765
=> PParams ledgerera
1740-
-> ProtocolParameters
1766+
-> Either CostModelNotEnoughParametersError ProtocolParameters
17411767
fromAlonzoPParams pp =
1742-
(fromShelleyCommonPParams pp)
1743-
{ protocolParamCostModels = fromAlonzoCostModels $ pp ^. ppCostModelsL
1744-
, protocolParamDecentralization = Just . Ledger.unboundRational $ pp ^. ppDG
1745-
, protocolParamPrices = Just . fromAlonzoPrices $ pp ^. ppPricesL
1746-
, protocolParamMaxTxExUnits = Just . fromAlonzoExUnits $ pp ^. ppMaxTxExUnitsL
1747-
, protocolParamMaxBlockExUnits = Just . fromAlonzoExUnits $ pp ^. ppMaxBlockExUnitsL
1748-
, protocolParamMaxValueSize = Just $ pp ^. ppMaxValSizeL
1749-
, protocolParamCollateralPercent = Just $ pp ^. ppCollateralPercentageL
1750-
, protocolParamMaxCollateralInputs = Just $ pp ^. ppMaxCollateralInputsL
1751-
}
1768+
ppCostModels <&> \costModels ->
1769+
base
1770+
{ protocolParamCostModels = costModels
1771+
, protocolParamDecentralization = Just . Ledger.unboundRational $ pp ^. ppDG
1772+
, protocolParamPrices = Just . fromAlonzoPrices $ pp ^. ppPricesL
1773+
, protocolParamMaxTxExUnits = Just . fromAlonzoExUnits $ pp ^. ppMaxTxExUnitsL
1774+
, protocolParamMaxBlockExUnits = Just . fromAlonzoExUnits $ pp ^. ppMaxBlockExUnitsL
1775+
, protocolParamMaxValueSize = Just $ pp ^. ppMaxValSizeL
1776+
, protocolParamCollateralPercent = Just $ pp ^. ppCollateralPercentageL
1777+
, protocolParamMaxCollateralInputs = Just $ pp ^. ppMaxCollateralInputsL
1778+
}
1779+
where
1780+
base = fromShelleyCommonPParams pp
1781+
ppCostModels :: Either CostModelNotEnoughParametersError (Map AnyPlutusScriptVersion CostModel)
1782+
ppCostModels = fromAlonzoCostModels $ pp ^. ppCostModelsL
17521783

17531784
{-# DEPRECATED
17541785
fromExactlyAlonzoPParams
@@ -1757,11 +1788,12 @@ fromAlonzoPParams pp =
17571788
fromExactlyAlonzoPParams
17581789
:: (AlonzoEraPParams ledgerera, Ledger.ExactEra Ledger.AlonzoEra ledgerera)
17591790
=> PParams ledgerera
1760-
-> ProtocolParameters
1791+
-> Either CostModelNotEnoughParametersError ProtocolParameters
17611792
fromExactlyAlonzoPParams pp =
1762-
(fromAlonzoPParams pp)
1763-
{ protocolParamUTxOCostPerByte = Just . unCoinPerWord $ pp ^. ppCoinsPerUTxOWordL
1764-
}
1793+
(fromAlonzoPParams pp) <&> \pp' ->
1794+
pp'
1795+
{ protocolParamUTxOCostPerByte = Just . unCoinPerWord $ pp ^. ppCoinsPerUTxOWordL
1796+
}
17651797

17661798
{-# DEPRECATED
17671799
fromBabbagePParams
@@ -1770,12 +1802,13 @@ fromExactlyAlonzoPParams pp =
17701802
fromBabbagePParams
17711803
:: BabbageEraPParams ledgerera
17721804
=> PParams ledgerera
1773-
-> ProtocolParameters
1805+
-> Either CostModelNotEnoughParametersError ProtocolParameters
17741806
fromBabbagePParams pp =
1775-
(fromAlonzoPParams pp)
1776-
{ protocolParamUTxOCostPerByte = Just . unCoinPerByte $ pp ^. ppCoinsPerUTxOByteL
1777-
, protocolParamDecentralization = Nothing
1778-
}
1807+
(fromAlonzoPParams pp) <&> \pp' ->
1808+
pp'
1809+
{ protocolParamUTxOCostPerByte = Just . unCoinPerByte $ pp ^. ppCoinsPerUTxOByteL
1810+
, protocolParamDecentralization = Nothing
1811+
}
17791812

17801813
{-# DEPRECATED
17811814
fromConwayPParams
@@ -1784,7 +1817,7 @@ fromBabbagePParams pp =
17841817
fromConwayPParams
17851818
:: BabbageEraPParams ledgerera
17861819
=> PParams ledgerera
1787-
-> ProtocolParameters
1820+
-> Either CostModelNotEnoughParametersError ProtocolParameters
17881821
fromConwayPParams = fromBabbagePParams
17891822

17901823
{-# DEPRECATED

0 commit comments

Comments
 (0)