Skip to content

Commit cd62068

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

File tree

1 file changed

+134
-92
lines changed

1 file changed

+134
-92
lines changed

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

+134-92
Original file line numberDiff line numberDiff line change
@@ -54,6 +54,7 @@ module Cardano.Api.ProtocolParameters
5454
-- * Errors
5555
, ProtocolParametersError (..)
5656
, ProtocolParametersConversionError (..)
57+
, CostModelNotEnoughParametersError (..)
5758

5859
-- * PraosNonce
5960
, PraosNonce
@@ -143,14 +144,14 @@ import qualified PlutusLedgerApi.V3.ParamName as PlutusV3
143144
import Control.Monad
144145
import Data.Aeson (FromJSON (..), ToJSON (..), object, withObject, (.!=), (.:), (.:?),
145146
(.=))
146-
import Data.Bifunctor (bimap, first)
147+
import Data.Bifunctor (first)
147148
import Data.ByteString (ByteString)
148149
import Data.Data (Data)
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,11 @@ 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 = do
1011+
pModels <- parseJSON v
1012+
case fromAlonzoCostModels pModels of
1013+
Left err -> fail $ displayError err
1014+
Right costModels -> return $ CostModels costModels
10101015

10111016
instance ToJSON CostModels where
10121017
toJSON (CostModels costModels) =
@@ -1030,12 +1035,15 @@ toAlonzoCostModels m = do
10301035

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

10401048
toAlonzoScriptLanguage :: AnyPlutusScriptVersion -> Plutus.Language
10411049
toAlonzoScriptLanguage (AnyPlutusScriptVersion PlutusScriptV1) = Plutus.PlutusV1
@@ -1051,8 +1059,11 @@ toAlonzoCostModel
10511059
:: CostModel -> Plutus.Language -> Either ProtocolParametersConversionError Alonzo.CostModel
10521060
toAlonzoCostModel (CostModel m) l = first (PpceInvalidCostModel (CostModel m)) $ Alonzo.mkCostModel l m
10531061

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

10571068
validateCostModelSize
10581069
:: Maybe (ShelleyBasedEra era)
@@ -1076,14 +1087,15 @@ validateCostModelSize mSbe lang model
10761087
Plutus.PlutusV1 -> length $ allValues @PlutusV1.ParamName -- 166
10771088
Plutus.PlutusV2 ->
10781089
let nParamNames = length $ allValues @PlutusV2.ParamName -- 185
1090+
lessTen = nParamNames - 10
10791091
in case mSbe of
10801092
Nothing ->
10811093
-- We don't know the era, so we can't know the exact number of parameters that is expected,
10821094
-- so we need to be lenient
1083-
nParamNames - 10
1095+
lessTen
10841096
Just sbe ->
10851097
caseShelleyToBabbageOrConwayEraOnwards
1086-
(const $ nParamNames - 10) -- Ten parameters were added to V2 in Conway, need to remove them here
1098+
(const lessTen) -- Ten parameters were added to V2 in Conway, need to remove them here
10871099
(const nParamNames)
10881100
sbe
10891101
Plutus.PlutusV3 -> length $ allValues @PlutusV3.ParamName -- 297
@@ -1346,32 +1358,41 @@ fromLedgerUpdate
13461358
=> Ledger.EraCrypto ledgerera ~ StandardCrypto
13471359
=> ShelleyBasedEra era
13481360
-> Ledger.Update ledgerera
1349-
-> UpdateProposal
1361+
-> Either CostModelNotEnoughParametersError UpdateProposal
13501362
fromLedgerUpdate sbe (Ledger.Update ppup epochno) =
1351-
UpdateProposal (fromLedgerProposedPPUpdates sbe ppup) epochno
1363+
UpdateProposal <$> fromLedgerProposedPPUpdates sbe ppup <*> pure epochno
13521364

13531365
fromLedgerProposedPPUpdates
13541366
:: forall era ledgerera
13551367
. ShelleyLedgerEra era ~ ledgerera
13561368
=> Ledger.EraCrypto ledgerera ~ StandardCrypto
13571369
=> ShelleyBasedEra era
13581370
-> Ledger.ProposedPPUpdates ledgerera
1359-
-> Map (Hash GenesisKey) ProtocolParametersUpdate
1360-
fromLedgerProposedPPUpdates sbe =
1361-
Map.map (fromLedgerPParamsUpdate sbe)
1362-
. Map.mapKeysMonotonic GenesisKeyHash
1363-
. (\(Ledger.ProposedPPUpdates ppup) -> ppup)
1371+
-> Either
1372+
CostModelNotEnoughParametersError
1373+
(Map (Hash GenesisKey) ProtocolParametersUpdate)
1374+
fromLedgerProposedPPUpdates sbe (Ledger.ProposedPPUpdates ppus) =
1375+
case Map.toList errs of
1376+
[] -> Right maps
1377+
((_, err) : _) -> Left err
1378+
where
1379+
(errs, maps) =
1380+
Map.map (fromLedgerPParamsUpdate sbe) ppus
1381+
& Map.mapKeysMonotonic GenesisKeyHash
1382+
& Map.mapEither id
13641383

13651384
fromLedgerPParamsUpdate
13661385
:: ShelleyBasedEra era
13671386
-> 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
1387+
-> Either CostModelNotEnoughParametersError ProtocolParametersUpdate
1388+
fromLedgerPParamsUpdate era ppu =
1389+
case era of
1390+
ShelleyBasedEraShelley -> pure $ fromShelleyPParamsUpdate ppu
1391+
ShelleyBasedEraAllegra -> pure $ fromShelleyPParamsUpdate ppu
1392+
ShelleyBasedEraMary -> pure $ fromShelleyPParamsUpdate ppu
1393+
ShelleyBasedEraAlonzo -> fromAlonzoPParamsUpdate ppu
1394+
ShelleyBasedEraBabbage -> fromBabbagePParamsUpdate ppu
1395+
ShelleyBasedEraConway -> fromConwayPParamsUpdate ppu
13751396

13761397
fromShelleyCommonPParamsUpdate
13771398
:: EraPParams ledgerera
@@ -1431,64 +1452,75 @@ fromShelleyPParamsUpdate ppu =
14311452
fromAlonzoCommonPParamsUpdate
14321453
:: AlonzoEraPParams ledgerera
14331454
=> PParamsUpdate ledgerera
1434-
-> ProtocolParametersUpdate
1455+
-> Either CostModelNotEnoughParametersError ProtocolParametersUpdate
14351456
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-
}
1457+
case costModels of
1458+
Left err -> Left err
1459+
Right mCostModelMap ->
1460+
Right $
1461+
(fromShelleyCommonPParamsUpdate ppu)
1462+
{ protocolUpdateCostModels = fromMaybe mempty mCostModelMap
1463+
, protocolUpdatePrices =
1464+
fromAlonzoPrices
1465+
<$> strictMaybeToMaybe (ppu ^. ppuPricesL)
1466+
, protocolUpdateMaxTxExUnits =
1467+
fromAlonzoExUnits
1468+
<$> strictMaybeToMaybe (ppu ^. ppuMaxTxExUnitsL)
1469+
, protocolUpdateMaxBlockExUnits =
1470+
fromAlonzoExUnits
1471+
<$> strictMaybeToMaybe (ppu ^. ppuMaxBlockExUnitsL)
1472+
, protocolUpdateMaxValueSize = strictMaybeToMaybe (ppu ^. ppuMaxValSizeL)
1473+
, protocolUpdateCollateralPercent = strictMaybeToMaybe (ppu ^. ppuCollateralPercentageL)
1474+
, protocolUpdateMaxCollateralInputs = strictMaybeToMaybe (ppu ^. ppuMaxCollateralInputsL)
1475+
, protocolUpdateUTxOCostPerByte = Nothing
1476+
}
1477+
where
1478+
mCostModels :: Maybe (Plutus.CostModels)
1479+
mCostModels = strictMaybeToMaybe (ppu ^. ppuCostModelsL)
1480+
costModels
1481+
:: Either
1482+
CostModelNotEnoughParametersError
1483+
(Maybe (Map AnyPlutusScriptVersion CostModel))
1484+
costModels = sequence $ fromAlonzoCostModels <$> mCostModels
14561485

14571486
fromAlonzoPParamsUpdate
14581487
:: Ledger.Crypto crypto
14591488
=> PParamsUpdate (Ledger.AlonzoEra crypto)
1460-
-> ProtocolParametersUpdate
1489+
-> Either CostModelNotEnoughParametersError ProtocolParametersUpdate
14611490
fromAlonzoPParamsUpdate ppu =
1462-
(fromAlonzoCommonPParamsUpdate ppu)
1463-
{ protocolUpdateProtocolVersion =
1464-
(\(Ledger.ProtVer a b) -> (Ledger.getVersion a, b))
1465-
<$> strictMaybeToMaybe (ppu ^. ppuProtocolVersionL)
1466-
}
1491+
(fromAlonzoCommonPParamsUpdate ppu) <&> \ppu' ->
1492+
ppu'
1493+
{ protocolUpdateProtocolVersion =
1494+
(\(Ledger.ProtVer a b) -> (Ledger.getVersion a, b))
1495+
<$> strictMaybeToMaybe (ppu ^. ppuProtocolVersionL)
1496+
}
14671497

14681498
fromBabbageCommonPParamsUpdate
14691499
:: BabbageEraPParams ledgerera
14701500
=> PParamsUpdate ledgerera
1471-
-> ProtocolParametersUpdate
1501+
-> Either CostModelNotEnoughParametersError ProtocolParametersUpdate
14721502
fromBabbageCommonPParamsUpdate ppu =
1473-
(fromAlonzoCommonPParamsUpdate ppu)
1474-
{ protocolUpdateUTxOCostPerByte = unCoinPerByte <$> strictMaybeToMaybe (ppu ^. ppuCoinsPerUTxOByteL)
1475-
}
1503+
(fromAlonzoCommonPParamsUpdate ppu) <&> \ppu' ->
1504+
ppu'
1505+
{ protocolUpdateUTxOCostPerByte = unCoinPerByte <$> strictMaybeToMaybe (ppu ^. ppuCoinsPerUTxOByteL)
1506+
}
14761507

14771508
fromBabbagePParamsUpdate
14781509
:: Ledger.Crypto crypto
14791510
=> PParamsUpdate (Ledger.BabbageEra crypto)
1480-
-> ProtocolParametersUpdate
1511+
-> Either CostModelNotEnoughParametersError ProtocolParametersUpdate
14811512
fromBabbagePParamsUpdate ppu =
1482-
(fromBabbageCommonPParamsUpdate ppu)
1483-
{ protocolUpdateProtocolVersion =
1484-
(\(Ledger.ProtVer a b) -> (Ledger.getVersion a, b))
1485-
<$> strictMaybeToMaybe (ppu ^. ppuProtocolVersionL)
1486-
}
1513+
(fromBabbageCommonPParamsUpdate ppu) <&> \ppu' ->
1514+
ppu'
1515+
{ protocolUpdateProtocolVersion =
1516+
(\(Ledger.ProtVer a b) -> (Ledger.getVersion a, b))
1517+
<$> strictMaybeToMaybe (ppu ^. ppuProtocolVersionL)
1518+
}
14871519

14881520
fromConwayPParamsUpdate
14891521
:: BabbageEraPParams ledgerera
14901522
=> PParamsUpdate ledgerera
1491-
-> ProtocolParametersUpdate
1523+
-> Either CostModelNotEnoughParametersError ProtocolParametersUpdate
14921524
fromConwayPParamsUpdate = fromBabbageCommonPParamsUpdate
14931525

14941526
-- ----------------------------------------------------------------------------
@@ -1666,13 +1698,15 @@ toConwayPParams = toBabbagePParams
16661698
fromLedgerPParams
16671699
:: ShelleyBasedEra era
16681700
-> 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
1701+
-> Either CostModelNotEnoughParametersError ProtocolParameters
1702+
fromLedgerPParams sbe pp =
1703+
case sbe of
1704+
ShelleyBasedEraShelley -> pure $ fromShelleyPParams pp
1705+
ShelleyBasedEraAllegra -> pure $ fromShelleyPParams pp
1706+
ShelleyBasedEraMary -> pure $ fromShelleyPParams pp
1707+
ShelleyBasedEraAlonzo -> fromExactlyAlonzoPParams pp
1708+
ShelleyBasedEraBabbage -> fromBabbagePParams pp
1709+
ShelleyBasedEraConway -> fromConwayPParams pp
16761710

16771711
{-# DEPRECATED
16781712
fromShelleyCommonPParams
@@ -1737,18 +1771,23 @@ fromShelleyPParams pp =
17371771
fromAlonzoPParams
17381772
:: AlonzoEraPParams ledgerera
17391773
=> PParams ledgerera
1740-
-> ProtocolParameters
1774+
-> Either CostModelNotEnoughParametersError ProtocolParameters
17411775
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-
}
1776+
ppCostModels <&> \costModels ->
1777+
base
1778+
{ protocolParamCostModels = costModels
1779+
, protocolParamDecentralization = Just . Ledger.unboundRational $ pp ^. ppDG
1780+
, protocolParamPrices = Just . fromAlonzoPrices $ pp ^. ppPricesL
1781+
, protocolParamMaxTxExUnits = Just . fromAlonzoExUnits $ pp ^. ppMaxTxExUnitsL
1782+
, protocolParamMaxBlockExUnits = Just . fromAlonzoExUnits $ pp ^. ppMaxBlockExUnitsL
1783+
, protocolParamMaxValueSize = Just $ pp ^. ppMaxValSizeL
1784+
, protocolParamCollateralPercent = Just $ pp ^. ppCollateralPercentageL
1785+
, protocolParamMaxCollateralInputs = Just $ pp ^. ppMaxCollateralInputsL
1786+
}
1787+
where
1788+
base = fromShelleyCommonPParams pp
1789+
ppCostModels :: Either CostModelNotEnoughParametersError (Map AnyPlutusScriptVersion CostModel)
1790+
ppCostModels = fromAlonzoCostModels $ pp ^. ppCostModelsL
17521791

17531792
{-# DEPRECATED
17541793
fromExactlyAlonzoPParams
@@ -1757,11 +1796,12 @@ fromAlonzoPParams pp =
17571796
fromExactlyAlonzoPParams
17581797
:: (AlonzoEraPParams ledgerera, Ledger.ExactEra Ledger.AlonzoEra ledgerera)
17591798
=> PParams ledgerera
1760-
-> ProtocolParameters
1799+
-> Either CostModelNotEnoughParametersError ProtocolParameters
17611800
fromExactlyAlonzoPParams pp =
1762-
(fromAlonzoPParams pp)
1763-
{ protocolParamUTxOCostPerByte = Just . unCoinPerWord $ pp ^. ppCoinsPerUTxOWordL
1764-
}
1801+
(fromAlonzoPParams pp) <&> \pp' ->
1802+
pp'
1803+
{ protocolParamUTxOCostPerByte = Just . unCoinPerWord $ pp ^. ppCoinsPerUTxOWordL
1804+
}
17651805

17661806
{-# DEPRECATED
17671807
fromBabbagePParams
@@ -1770,12 +1810,13 @@ fromExactlyAlonzoPParams pp =
17701810
fromBabbagePParams
17711811
:: BabbageEraPParams ledgerera
17721812
=> PParams ledgerera
1773-
-> ProtocolParameters
1813+
-> Either CostModelNotEnoughParametersError ProtocolParameters
17741814
fromBabbagePParams pp =
1775-
(fromAlonzoPParams pp)
1776-
{ protocolParamUTxOCostPerByte = Just . unCoinPerByte $ pp ^. ppCoinsPerUTxOByteL
1777-
, protocolParamDecentralization = Nothing
1778-
}
1815+
(fromAlonzoPParams pp) <&> \pp' ->
1816+
pp'
1817+
{ protocolParamUTxOCostPerByte = Just . unCoinPerByte $ pp ^. ppCoinsPerUTxOByteL
1818+
, protocolParamDecentralization = Nothing
1819+
}
17791820

17801821
{-# DEPRECATED
17811822
fromConwayPParams
@@ -1784,7 +1825,7 @@ fromBabbagePParams pp =
17841825
fromConwayPParams
17851826
:: BabbageEraPParams ledgerera
17861827
=> PParams ledgerera
1787-
-> ProtocolParameters
1828+
-> Either CostModelNotEnoughParametersError ProtocolParameters
17881829
fromConwayPParams = fromBabbagePParams
17891830

17901831
{-# DEPRECATED
@@ -1894,6 +1935,7 @@ data ProtocolParametersConversionError
18941935
-- protocol parameters for @lang@ is @actual@ and that number is below the @minimum@ expected number of parameters.
18951936
data CostModelNotEnoughParametersError
18961937
= CostModelNotEnoughParametersError Plutus.Language Int Int
1938+
deriving Show
18971939

18981940
type ProtocolParameterName = String
18991941

0 commit comments

Comments
 (0)