Typesafe protocol paramters

cardano-api/gen/Test/Gen/Cardano/Api/Typed.hs

@@ -840,7 +840,10 @@ genPraosNonce = makePraosNonce <$> Gen.bytes (Range.linear 0 32)
 genMaybePraosNonce :: Gen (Maybe PraosNonce)
 genMaybePraosNonce = Gen.maybe genPraosNonce
 
-genProtocolParameters :: CardanoEra era -> Gen ProtocolParameters
+genFeatureValue :: FeatureInEra feature => CardanoEra era -> Gen a -> Gen (FeatureValue feature era a)
+genFeatureValue era g = featureInEra (pure NoFeatureValue) (\w -> fmap (FeatureValue w) g) era
+
+genProtocolParameters :: CardanoEra era -> Gen (ProtocolParameters era)
 genProtocolParameters era = do
   protocolParamProtocolVersion <- (,) <$> genNat <*> genNat
   protocolParamDecentralization <- Gen.maybe genRational
@@ -859,7 +862,7 @@ genProtocolParameters era = do
   protocolParamPoolPledgeInfluence <- genRationalInt64
   protocolParamMonetaryExpansion <- genRational
   protocolParamTreasuryCut <- genRational
-  protocolParamUTxOCostPerWord <- featureInEra @ProtocolUTxOCostPerWordFeature (pure Nothing) (const (Just <$> genLovelace)) era
+  protocolParamUTxOCostPerWord <- genFeatureValue era genLovelace
   protocolParamCostModels <- pure mempty
   --TODO: Babbage figure out how to deal with
   -- asymmetric cost model JSON instances
@@ -869,12 +872,12 @@ genProtocolParameters era = do
   protocolParamMaxValueSize <- Gen.maybe genNat
   protocolParamCollateralPercent <- Gen.maybe genNat
   protocolParamMaxCollateralInputs <- Gen.maybe genNat
-  protocolParamUTxOCostPerByte <- featureInEra @ProtocolUTxOCostPerByteFeature (pure Nothing) (const (Just <$> genLovelace)) era
+  protocolParamUTxOCostPerByte <- genFeatureValue era genLovelace
 
   pure ProtocolParameters {..}
 
 -- | Generate valid protocol parameters which pass validations in Cardano.Api.ProtocolParameters
-genValidProtocolParameters :: CardanoEra era -> Gen ProtocolParameters
+genValidProtocolParameters :: CardanoEra era -> Gen (ProtocolParameters era)
 genValidProtocolParameters era =
   ProtocolParameters
     <$> ((,) <$> genNat <*> genNat)
@@ -895,7 +898,7 @@ genValidProtocolParameters era =
     <*> genRational
     <*> genRational
     -- 'Just' is required by checks in Cardano.Api.ProtocolParameters
-    <*> featureInEra @ProtocolUTxOCostPerWordFeature (pure Nothing) (const (Just <$> genLovelace)) era
+    <*> genFeatureValue era genLovelace
     <*> return mempty
     --TODO: Babbage figure out how to deal with
     -- asymmetric cost model JSON instances
@@ -906,7 +909,7 @@ genValidProtocolParameters era =
     <*> fmap Just genNat
     <*> fmap Just genNat
     <*> fmap Just genNat
-    <*> featureInEra @ProtocolUTxOCostPerByteFeature (pure Nothing) (const (Just <$> genLovelace)) era
+    <*> genFeatureValue era genLovelace
 
 genProtocolParametersUpdate :: CardanoEra era -> Gen ProtocolParametersUpdate
 genProtocolParametersUpdate era = do

cardano-api/internal/Cardano/Api/Convenience/Construction.hs

@@ -41,7 +41,7 @@ constructBalancedTx
   -> AddressInEra era -- ^ Change address
   -> Maybe Word       -- ^ Override key witnesses
   -> UTxO era         -- ^ Just the transaction inputs, not the entire 'UTxO'.
-  -> ProtocolParameters
+  -> ProtocolParameters era
   -> LedgerEpochInfo
   -> SystemStart
   -> Set PoolId       -- ^ The set of registered stake pools

cardano-api/internal/Cardano/Api/Convenience/Query.hs

@@ -69,7 +69,7 @@ queryStateForBalancedTx
   -> [TxIn]
   -> [Certificate]
   -> IO (Either QueryConvenienceError ( UTxO era
-                                      , ProtocolParameters
+                                      , ProtocolParameters era
                                       , EraHistory CardanoMode
                                       , SystemStart
                                       , Set PoolId

cardano-api/internal/Cardano/Api/EraCast.hs

@@ -3,6 +3,7 @@
 
 module Cardano.Api.EraCast
   ( EraCast(..)
+  , EraCastLossy(..)
   , EraCastError(..)
   ) where
 
@@ -26,3 +27,9 @@ class EraCast (f :: Type -> Type) where
           => CardanoEra toEra
           -> f fromEra
           -> Either EraCastError (f toEra)
+
+class EraCastLossy (f :: Type -> Type) where
+  eraCastLossy :: ()
+    => CardanoEra toEra
+    -> f fromEra
+    -> f toEra

cardano-api/internal/Cardano/Api/Feature.hs

@@ -1,21 +1,28 @@
+{-# LANGUAGE FlexibleInstances #-}
 {-# LANGUAGE GADTs #-}
 {-# LANGUAGE KindSignatures #-}
 {-# LANGUAGE LambdaCase #-}
 {-# LANGUAGE ScopedTypeVariables #-}
 {-# LANGUAGE StandaloneDeriving #-}
+{-# LANGUAGE TypeApplications #-}
 
 module Cardano.Api.Feature
   ( FeatureValue (..)
   , FeatureInEra(..)
+  , Flip(..)
   , featureInShelleyBasedEra
   , valueOrDefault
   , asFeatureValue
   , asFeatureValueInShelleyBasedEra
-  , isFeatureValue
+  , existsFeatureValue  , eraCastLossyFeatureValue
+  , (.:?^)
   ) where
 
+import           Cardano.Api.EraCast
 import           Cardano.Api.Eras
 
+import qualified Data.Aeson.KeyMap as KM
+import           Data.Aeson.Types
 import           Data.Kind
 
 -- | A class for features that are supported in some eras but not others.
@@ -55,12 +62,62 @@ data FeatureValue feature era a where
 deriving instance (Eq a, Eq (feature era)) => Eq (FeatureValue feature era a)
 deriving instance (Show a, Show (feature era)) => Show (FeatureValue feature era a)
 
+instance ToJSON a => ToJSON (FeatureValue feature era a) where
+  toJSON v =
+    toJSON $
+      case v of
+        NoFeatureValue -> Nothing
+        FeatureValue _ a -> Just a
+
+instance (IsCardanoEra era, FromJSON a, FeatureInEra feature) => FromJSON (FeatureValue feature era a) where
+  parseJSON v =
+    featureInEra
+      (pure NoFeatureValue)
+      (\fe -> FeatureValue fe <$> parseJSON v)
+      cardanoEra
+
+newtype Flip t a b = Flip { unFlip :: t b a }
+
+instance FeatureInEra feature => EraCastLossy (Flip (FeatureValue feature) a) where
+  eraCastLossy era (Flip fv) = Flip $ eraCastLossyFeatureValue era fv
+
+eraCastLossyFeatureValue :: ()
+  => FeatureInEra feature
+  => CardanoEra toEra
+  -> FeatureValue feature fromEra a
+  -> FeatureValue feature toEra a
+eraCastLossyFeatureValue era fv =
+  case fv of
+    FeatureValue _ a -> featureInEra NoFeatureValue (\fe -> FeatureValue fe a) era
+    NoFeatureValue -> NoFeatureValue
+
+
+(.:?^) :: (IsCardanoEra era, FromJSON a, FeatureInEra feature) => Object -> Key -> Parser (FeatureValue feature era a)
+(.:?^) = explicitParseFieldFeatureValue' parseJSON
+
+-- | Variant of '.:!' with explicit parser function.
+explicitParseFieldFeatureValue' :: ()
+  => IsCardanoEra era
+  => FeatureInEra feature
+  => (Value -> Parser a)
+  -> Object
+  -> Key
+  -> Parser (FeatureValue feature era a)
+explicitParseFieldFeatureValue' p obj key =
+  case KM.lookup key obj of
+    Nothing -> pure NoFeatureValue
+    Just v ->
+      featureInEra
+        (fail "")
+        (\fe -> FeatureValue fe <$> p v)
+        cardanoEra
+
 -- | Determine if a value is defined.
 --
 -- If the value is not defined, it could be because the feature is not supported or
 -- because the feature is supported but the value is not available.
-isFeatureValue :: FeatureValue feature era a -> Bool
-isFeatureValue = \case
+existsFeatureValue :: FeatureValue feature era a -> Bool
+existsFeatureValue = \case
   NoFeatureValue -> False
   FeatureValue _ _ -> True
 

cardano-api/internal/Cardano/Api/Fees.hs

@@ -902,7 +902,7 @@ makeTransactionBodyAutoBalance
      IsShelleyBasedEra era
   => SystemStart
   -> LedgerEpochInfo
-  -> ProtocolParameters
+  -> ProtocolParameters era
   -> Set PoolId       -- ^ The set of registered stake pools, that are being
                       --   unregistered in this transaction.
   -> Map StakeCredential Lovelace
@@ -1063,7 +1063,7 @@ makeTransactionBodyAutoBalance systemstart history pparams poolids stakeDelegDep
    -- TODO: Bug Jared to expose a function from the ledger that returns total and return collateral.
    calcReturnAndTotalCollateral
      :: Lovelace -- ^ Fee
-     -> ProtocolParameters
+     -> ProtocolParameters era -- ^ Protocol parameters
      -> TxInsCollateral era -- ^ From the initial TxBodyContent
      -> TxReturnCollateral CtxTx era -- ^ From the initial TxBodyContent
      -> TxTotalCollateral era -- ^ From the initial TxBodyContent

cardano-api/internal/Cardano/Api/GenesisParameters.hs

@@ -16,7 +16,9 @@ module Cardano.Api.GenesisParameters (
 
   ) where
 
-import           Cardano.Api.Eras (ShelleyBasedEra (ShelleyBasedEraShelley))
+import           Cardano.Api.EraCast
+import           Cardano.Api.Eras (ShelleyBasedEra (ShelleyBasedEraShelley),
+                   shelleyBasedToCardanoEra)
 import           Cardano.Api.NetworkId
 import           Cardano.Api.ProtocolParameters
 import           Cardano.Api.Value
@@ -33,7 +35,7 @@ import           Data.Time (NominalDiffTime, UTCTime)
 -- Genesis parameters
 --
 
-data GenesisParameters =
+data GenesisParameters era =
      GenesisParameters {
 
        -- | The reference time the system started. The time of slot zero.
@@ -92,16 +94,16 @@ data GenesisParameters =
 
        -- | The initial values of the updateable 'ProtocolParameters'.
        --
-       protocolInitialUpdateableProtocolParameters :: ProtocolParameters
+       protocolInitialUpdateableProtocolParameters :: ProtocolParameters era
      }
 
 
 -- ----------------------------------------------------------------------------
 -- Conversion functions
 --
 
-fromShelleyGenesis :: Shelley.ShelleyGenesis Ledger.StandardCrypto -> GenesisParameters
-fromShelleyGenesis
+fromShelleyGenesis :: ShelleyBasedEra era -> Shelley.ShelleyGenesis Ledger.StandardCrypto -> GenesisParameters era
+fromShelleyGenesis sbe
     Shelley.ShelleyGenesis {
       Shelley.sgSystemStart
     , Shelley.sgNetworkMagic
@@ -133,7 +135,5 @@ fromShelleyGenesis
     , protocolParamUpdateQuorum           = fromIntegral sgUpdateQuorum
     , protocolParamMaxLovelaceSupply      = Lovelace
                                               (fromIntegral sgMaxLovelaceSupply)
-    , protocolInitialUpdateableProtocolParameters = fromLedgerPParams
-                                                      ShelleyBasedEraShelley
-                                                      sgProtocolParams
+    , protocolInitialUpdateableProtocolParameters = eraCastLossy (shelleyBasedToCardanoEra sbe) (fromLedgerPParams ShelleyBasedEraShelley sgProtocolParams)
     }

cardano-api/internal/Cardano/Api/LedgerState.hs

@@ -1656,7 +1656,7 @@ currentEpochEligibleLeadershipSlots sbe sGen eInfo bpp ptclState poolid (VrfSign
 constructGlobals
   :: ShelleyGenesis Shelley.StandardCrypto
   -> EpochInfo (Either Text)
-  -> ProtocolParameters
+  -> ProtocolParameters era
   -> Globals
 constructGlobals sGen eInfo pParams =
   let majorPParamsVer = fst $ protocolParamProtocolVersion pParams