Skip to content

Commit

Permalink
ProtocolParameters.hs: propagate new error behavior
Browse files Browse the repository at this point in the history
  • Loading branch information
@smelc
smelc committed Jan 15, 2025
1 parent 1b71664 commit 3d6de33
Showing 1 changed file with 115 additions and 82 deletions.
197 changes: 115 additions & 82 deletions cardano-api/internal/Cardano/Api/ProtocolParameters.hs
View file
Original file line number Diff line number Diff line change
Expand Up @@ -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)
Expand Down Expand Up @@ -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) =
Expand All @@ -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
Expand All @@ -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)
Expand Down Expand Up @@ -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
Expand Down Expand Up @@ -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)

Check warning

Code scanning / HLint

Redundant bracket Warning

cardano-api/internal/Cardano/Api/ProtocolParameters.hs:1478:24-42: Warning: Redundant bracket
  
Found:
  (Plutus.CostModels)
  
Perhaps:
  Plutus.CostModels
mCostModels = strictMaybeToMaybe (ppu ^. ppuCostModelsL)
costModels :: Either
CostModelNotEnoughParametersError
(Maybe (Map AnyPlutusScriptVersion CostModel))
costModels = sequence $ fromAlonzoCostModels <$> mCostModels

Check warning

Code scanning / HLint

Use mapM Warning

cardano-api/internal/Cardano/Api/ProtocolParameters.hs:1484:16-62: Warning: Use mapM
  
Found:
  sequence $ fromAlonzoCostModels <$> mCostModels
  
Perhaps:
  mapM 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' ->

Check notice

Code scanning / HLint

Redundant bracket Note

cardano-api/internal/Cardano/Api/ProtocolParameters.hs:1491:3-37: Suggestion: Redundant bracket
  
Found:
  (fromAlonzoCommonPParamsUpdate ppu)
    <&>
      \\ ppu'
        -> ppu'
             {protocolUpdateProtocolVersion = (\\ (Ledger.ProtVer a b)
                                                 -> (Ledger.getVersion a, b))
                                                <$> strictMaybeToMaybe (ppu ^. ppuProtocolVersionL)}
  
Perhaps:
  fromAlonzoCommonPParamsUpdate ppu
    <&>
      \\ ppu'
        -> ppu'
             {protocolUpdateProtocolVersion = (\\ (Ledger.ProtVer a b)
                                                 -> (Ledger.getVersion a, b))
                                                <$> strictMaybeToMaybe (ppu ^. ppuProtocolVersionL)}
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' ->

Check notice

Code scanning / HLint

Redundant bracket Note

cardano-api/internal/Cardano/Api/ProtocolParameters.hs:1503:3-37: Suggestion: Redundant bracket
  
Found:
  (fromAlonzoCommonPParamsUpdate ppu)
    <&>
      \\ ppu'
        -> ppu'
             {protocolUpdateUTxOCostPerByte = unCoinPerByte
                                                <$> strictMaybeToMaybe (ppu ^. ppuCoinsPerUTxOByteL)}
  
Perhaps:
  fromAlonzoCommonPParamsUpdate ppu
    <&>
      \\ ppu'
        -> ppu'
             {protocolUpdateUTxOCostPerByte = unCoinPerByte
                                                <$> strictMaybeToMaybe (ppu ^. ppuCoinsPerUTxOByteL)}
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' ->

Check notice

Code scanning / HLint

Redundant bracket Note

cardano-api/internal/Cardano/Api/ProtocolParameters.hs:1513:3-38: Suggestion: Redundant bracket
  
Found:
  (fromBabbageCommonPParamsUpdate ppu)
    <&>
      \\ ppu'
        -> ppu'
             {protocolUpdateProtocolVersion = (\\ (Ledger.ProtVer a b)
                                                 -> (Ledger.getVersion a, b))
                                                <$> strictMaybeToMaybe (ppu ^. ppuProtocolVersionL)}
  
Perhaps:
  fromBabbageCommonPParamsUpdate ppu
    <&>
      \\ ppu'
        -> ppu'
             {protocolUpdateProtocolVersion = (\\ (Ledger.ProtVer a b)
                                                 -> (Ledger.getVersion a, b))
                                                <$> strictMaybeToMaybe (ppu ^. ppuProtocolVersionL)}
ppu'
{ protocolUpdateProtocolVersion =
(\(Ledger.ProtVer a b) -> (Ledger.getVersion a, b))
<$> strictMaybeToMaybe (ppu ^. ppuProtocolVersionL)
}

fromConwayPParamsUpdate
:: BabbageEraPParams ledgerera
=> PParamsUpdate ledgerera
-> ProtocolParametersUpdate
-> Either CostModelNotEnoughParametersError ProtocolParametersUpdate
fromConwayPParamsUpdate = fromBabbageCommonPParamsUpdate

-- ----------------------------------------------------------------------------
Expand Down Expand Up @@ -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
Expand Down Expand Up @@ -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
Expand All @@ -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' ->

Check notice

Code scanning / HLint

Redundant bracket Note

cardano-api/internal/Cardano/Api/ProtocolParameters.hs:1801:3-24: Suggestion: Redundant bracket
  
Found:
  (fromAlonzoPParams pp)
    <&>
      \\ pp'
        -> pp'
             {protocolParamUTxOCostPerByte = Just . unCoinPerWord
                                               $ pp ^. ppCoinsPerUTxOWordL}
  
Perhaps:
  fromAlonzoPParams pp
    <&>
      \\ pp'
        -> pp'
             {protocolParamUTxOCostPerByte = Just . unCoinPerWord
                                               $ pp ^. ppCoinsPerUTxOWordL}
pp'
{ protocolParamUTxOCostPerByte = Just . unCoinPerWord $ pp ^. ppCoinsPerUTxOWordL
}

{-# DEPRECATED
fromBabbagePParams
Expand All @@ -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' ->

Check notice

Code scanning / HLint

Redundant bracket Note

cardano-api/internal/Cardano/Api/ProtocolParameters.hs:1815:3-24: Suggestion: Redundant bracket
  
Found:
  (fromAlonzoPParams pp)
    <&>
      \\ pp'
        -> pp'
             {protocolParamUTxOCostPerByte = Just . unCoinPerByte
                                               $ pp ^. ppCoinsPerUTxOByteL,
              protocolParamDecentralization = Nothing}
  
Perhaps:
  fromAlonzoPParams pp
    <&>
      \\ pp'
        -> pp'
             {protocolParamUTxOCostPerByte = Just . unCoinPerByte
                                               $ pp ^. ppCoinsPerUTxOByteL,
              protocolParamDecentralization = Nothing}
pp'
{ protocolParamUTxOCostPerByte = Just . unCoinPerByte $ pp ^. ppCoinsPerUTxOByteL
, protocolParamDecentralization = Nothing
}

{-# DEPRECATED
fromConwayPParams
Expand All @@ -1784,7 +1817,7 @@ fromBabbagePParams pp =
fromConwayPParams
:: BabbageEraPParams ledgerera
=> PParams ledgerera
-> ProtocolParameters
-> Either CostModelNotEnoughParametersError ProtocolParameters
fromConwayPParams = fromBabbagePParams

{-# DEPRECATED
Expand Down

0 comments on commit 3d6de33

Please sign in to comment.