Complete the round trip tests for protocol params and updates

Extend the generators for the new Alonzo era fields. Add a CBOR round
trip test for UpdateProposals.

Fix some bugs in the JSON serialisation for the new Alonzo fields in the
ProtocolParameters type, as found by the round trip test.

cardano-api/src/Cardano/Api.hs

@@ -297,6 +297,7 @@ module Cardano.Api (
     SimpleScriptVersion(..),
     PlutusScriptVersion(..),
     AnyScriptLanguage(..),
+    AnyPlutusScriptVersion(..),
     IsScriptLanguage(..),
     IsSimpleScriptLanguage(..),
 
@@ -357,6 +358,9 @@ module Cardano.Api (
 
     -- * Script execution units
     ExecutionUnits(..),
+    ExecutionUnitPrices(..),
+    CostModel(..),
+    validateCostModel,
 
     -- ** Script addresses
     -- | Making addresses from scripts.

cardano-api/src/Cardano/Api/ProtocolParameters.hs

@@ -57,7 +57,7 @@ import           Data.ByteString (ByteString)
 import           Data.Map.Strict (Map)
 import qualified Data.Map.Strict as Map
 import           Data.String (IsString)
-import           Data.Scientific (Scientific)
+import qualified Data.Scientific as Scientific
 import           Data.Text (Text)
 import           GHC.Generics
 import           Numeric.Natural
@@ -66,6 +66,7 @@ import           Control.Monad
 
 import           Data.Aeson (FromJSON (..), ToJSON (..), object, withObject,
                    (.!=), (.:), (.:?), (.=))
+import qualified Data.Aeson as Aeson
 import           Data.Bifunctor (bimap)
 
 import qualified Cardano.Binary as CBOR
@@ -300,10 +301,10 @@ instance FromJSON ProtocolParameters where
         <*> o .: "monetaryExpansion"
         <*> o .: "treasuryCut"
         <*> o .:? "utxoCostPerWord"
-        <*> o .:? "costModel" .!= Map.empty
+        <*> o .:? "costModels" .!= Map.empty
         <*> o .:? "executionUnitPrices"
-        <*> o .:? "maxTxExecUnits"
-        <*> o .:? "maxBlockExecUnits"
+        <*> o .:? "maxTxExecutionUnits"
+        <*> o .:? "maxBlockExecutionUnits"
         <*> o .:? "maxValueSize"
         <*> o .:? "collateralPercentage"
         <*> o .:? "maxCollateralInputs"
@@ -315,25 +316,22 @@ instance ToJSON ProtocolParameters where
       , "stakePoolTargetNum"  .= protocolParamStakePoolTargetNum
       , "minUTxOValue"        .= protocolParamMinUTxOValue
       , "poolRetireMaxEpoch"  .= protocolParamPoolRetireMaxEpoch
-      , "decentralization"    .= (fromRational protocolParamDecentralization
-                                            :: Scientific)
+      , "decentralization"    .= toRationalJSON protocolParamDecentralization
       , "stakePoolDeposit"    .= protocolParamStakePoolDeposit
       , "maxBlockHeaderSize"  .= protocolParamMaxBlockHeaderSize
       , "maxBlockBodySize"    .= protocolParamMaxBlockBodySize
       , "maxTxSize"           .= protocolParamMaxTxSize
-      , "treasuryCut"         .= (fromRational protocolParamTreasuryCut
-                                            :: Scientific)
+      , "treasuryCut"         .= toRationalJSON protocolParamTreasuryCut
       , "minPoolCost"         .= protocolParamMinPoolCost
-      , "monetaryExpansion"   .= (fromRational protocolParamMonetaryExpansion
-                                            :: Scientific)
+      , "monetaryExpansion"   .= toRationalJSON protocolParamMonetaryExpansion
       , "stakeAddressDeposit" .= protocolParamStakeAddressDeposit
-      , "poolPledgeInfluence" .= (fromRational protocolParamPoolPledgeInfluence
-                                            :: Scientific)
+      , "poolPledgeInfluence" .= toRationalJSON protocolParamPoolPledgeInfluence
       , "protocolVersion"     .= let (major, minor) = protocolParamProtocolVersion
                                   in object ["major" .= major, "minor" .= minor]
       , "txFeeFixed"          .= protocolParamTxFeeFixed
       , "txFeePerByte"        .= protocolParamTxFeePerByte
       -- Alonzo era:
+      , "utxoCostPerWord"        .= protocolParamUTxOCostPerWord
       , "costModels"             .= protocolParamCostModels
       , "executionUnitPrices"    .= protocolParamPrices
       , "maxTxExecutionUnits"    .= protocolParamMaxTxExUnits
@@ -342,6 +340,19 @@ instance ToJSON ProtocolParameters where
       , "collateralPercentage"   .= protocolParamCollateralPercent
       , "maxCollateralInputs"    .= protocolParamMaxCollateralInputs
       ]
+    where
+      -- Rationals and JSON are an awkward mix. We cannot convert rationals
+      -- like @1/3@ to JSON numbers. But _most_ of the numbers we want to use
+      -- in practice have simple decimal representations. Our solution here is
+      -- to use simple decimal representations where we can and representation
+      -- in a @{"numerator": 1, "denominator": 3}@ style otherwise.
+      --
+      toRationalJSON :: Rational -> Aeson.Value
+      toRationalJSON r =
+        case Scientific.fromRationalRepetend (Just 5) r of
+          Right (s, Nothing) -> toJSON s
+          _                  -> toJSON r
+
 
 -- ----------------------------------------------------------------------------
 -- Updates to the protocol paramaters
@@ -821,6 +832,8 @@ makeShelleyUpdateProposal :: ProtocolParametersUpdate
                           -> UpdateProposal
 makeShelleyUpdateProposal params genesisKeyHashes =
     --TODO decide how to handle parameter validation
+    --     for example we need to validate the Rational values can convert
+    --     into the UnitInterval type ok.
     UpdateProposal (Map.fromList [ (kh, params) | kh <- genesisKeyHashes ])
 
 

cardano-api/src/Cardano/Api/TxBody.hs

@@ -2096,7 +2096,8 @@ makeShelleyTransactionBody era@ShelleyBasedEraAlonzo
     case txProtocolParams of
       BuildTxWith Nothing | not (Set.null languages)
         -> Left TxBodyMissingProtocolParams
-      _ -> return ()
+      _ -> return () --TODO alonzo: validate protocol params for the Alonzo era.
+                     --             All the necessary params must be provided.
 
     return $
       ShelleyTxBody era

cardano-api/test/Test/Cardano/Api/Typed/CBOR.hs

@@ -147,6 +147,11 @@ prop_roundtrip_script_PlutusScriptV1_CBOR =
   roundtrip_CBOR (AsScript AsPlutusScriptV1)
                  (genScript (PlutusScriptLanguage PlutusScriptV1))
 
+prop_roundtrip_UpdateProposal_CBOR :: Property
+prop_roundtrip_UpdateProposal_CBOR =
+  roundtrip_CBOR AsUpdateProposal genUpdateProposal
+
+
 -- -----------------------------------------------------------------------------
 
 roundtrip_CBOR

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

@@ -36,6 +36,8 @@ module Test.Cardano.Api.Typed.Gen
   , genValue
   , genValueDefault
   , genVerificationKey
+  , genUpdateProposal
+  , genProtocolParametersUpdate
   ) where
 
 import           Cardano.Api
@@ -45,7 +47,6 @@ import           Cardano.Api.Shelley
 import           Cardano.Prelude
 
 import           Control.Monad.Fail (fail)
-import qualified Data.Map.Strict as Map
 import           Data.String
 import qualified Data.ByteString as BS
 import qualified Data.ByteString.Short as SBS
@@ -55,7 +56,6 @@ import qualified Cardano.Crypto.Hash as Crypto
 import qualified Cardano.Crypto.Seed as Crypto
 import qualified Shelley.Spec.Ledger.TxBody as Ledger (EraIndependentTxBody)
 
-
 import           Hedgehog (Gen, Range)
 import qualified Hedgehog.Gen as Gen
 import qualified Hedgehog.Range as Range
@@ -513,27 +513,13 @@ genTxCertificates era =
 
 genTxUpdateProposal :: CardanoEra era -> Gen (TxUpdateProposal era)
 genTxUpdateProposal era =
-  case era of
-    ByronEra -> pure TxUpdateProposalNone
-    ShelleyEra ->
-      Gen.choice
-        [ pure TxUpdateProposalNone
-        , pure (TxUpdateProposal UpdateProposalInShelleyEra emptyUpdateProposal) -- TODO: Generate proposals
-        ]
-    AllegraEra ->
+  case updateProposalSupportedInEra era of
+    Nothing -> pure TxUpdateProposalNone
+    Just supported ->
       Gen.choice
         [ pure TxUpdateProposalNone
-        , pure (TxUpdateProposal UpdateProposalInAllegraEra emptyUpdateProposal) -- TODO: Generate proposals
+        , TxUpdateProposal supported <$> genUpdateProposal
         ]
-    MaryEra ->
-      Gen.choice
-        [ pure TxUpdateProposalNone
-        , pure (TxUpdateProposal UpdateProposalInMaryEra emptyUpdateProposal) -- TODO: Generate proposals
-        ]
-    AlonzoEra -> panic "genTxUpdateProposal: Alonzo not implemented yet"
-  where
-    emptyUpdateProposal :: UpdateProposal
-    emptyUpdateProposal = UpdateProposal Map.empty (EpochNo 0)
 
 genTxMintValue :: CardanoEra era -> Gen (TxMintValue BuildTx era)
 genTxMintValue era =
@@ -630,6 +616,10 @@ genTx era =
 genVerificationKey :: Key keyrole => AsType keyrole -> Gen (VerificationKey keyrole)
 genVerificationKey roletoken = getVerificationKey <$> genSigningKey roletoken
 
+genVerificationKeyHash :: Key keyrole => AsType keyrole -> Gen (Hash keyrole)
+genVerificationKeyHash roletoken =
+  verificationKeyHash <$> genVerificationKey roletoken
+
 genByronKeyWitness :: Gen (KeyWitness ByronEra)
 genByronKeyWitness = do
   pmId <- genProtocolMagicId
@@ -689,7 +679,14 @@ genNat :: Gen Natural
 genNat = Gen.integral (Range.linear 0 10)
 
 genRational :: Gen Rational
-genRational = Gen.realFrac_ (Range.linearFrac 0 1)
+genRational =
+    (\d -> ratioToRational (1 % d)) <$> genDenominator
+  where
+    genDenominator :: Gen Word64
+    genDenominator = Gen.integral (Range.linear 1 maxBound)
+
+    ratioToRational :: Ratio Word64 -> Rational
+    ratioToRational = toRational
 
 genEpochNo :: Gen EpochNo
 genEpochNo = EpochNo <$> Gen.word64 (Range.linear 0 10)
@@ -720,13 +717,73 @@ genProtocolParameters =
     <*> genRational
     <*> genRational
     <*> genRational
-    -- TODO alonzo: Add proper support for these generators.
-    <*> return Nothing
-    <*> return mempty
-    <*> return Nothing
-    <*> return Nothing
-    <*> return Nothing
-    <*> return Nothing
-    <*> return Nothing
-    <*> return Nothing
+    <*> Gen.maybe genLovelace
+    <*> genCostModels
+    <*> Gen.maybe genExecutionUnitPrices
+    <*> Gen.maybe genExecutionUnits
+    <*> Gen.maybe genExecutionUnits
+    <*> Gen.maybe genNat
+    <*> Gen.maybe genNat
+    <*> Gen.maybe genNat
+
+genProtocolParametersUpdate :: Gen ProtocolParametersUpdate
+genProtocolParametersUpdate =
+  ProtocolParametersUpdate
+    <$> Gen.maybe ((,) <$> genNat <*> genNat)
+    <*> Gen.maybe genRational
+    <*> Gen.maybe genMaybePraosNonce
+    <*> Gen.maybe genNat
+    <*> Gen.maybe genNat
+    <*> Gen.maybe genNat
+    <*> Gen.maybe genNat
+    <*> Gen.maybe genNat
+    <*> Gen.maybe genLovelace
+    <*> Gen.maybe genLovelace
+    <*> Gen.maybe genLovelace
+    <*> Gen.maybe genLovelace
+    <*> Gen.maybe genEpochNo
+    <*> Gen.maybe genNat
+    <*> Gen.maybe genRational
+    <*> Gen.maybe genRational
+    <*> Gen.maybe genRational
+    <*> Gen.maybe genLovelace
+    <*> genCostModels
+    <*> Gen.maybe genExecutionUnitPrices
+    <*> Gen.maybe genExecutionUnits
+    <*> Gen.maybe genExecutionUnits
+    <*> Gen.maybe genNat
+    <*> Gen.maybe genNat
+    <*> Gen.maybe genNat
+
+
+genUpdateProposal :: Gen UpdateProposal
+genUpdateProposal =
+  UpdateProposal
+    <$> Gen.map (Range.constant 1 3)
+                ((,) <$> genVerificationKeyHash AsGenesisKey
+                     <*> genProtocolParametersUpdate)
+    <*> genEpochNo
+
+genCostModel :: Gen CostModel
+genCostModel =
+  CostModel
+    <$> Gen.map (Range.constant 1 10)
+                ((,) <$> Gen.text (Range.constant 1 10) Gen.alphaNum
+                     <*> Gen.integral (Range.linear 0 5000))
+
+genCostModels :: Gen (Map AnyPlutusScriptVersion CostModel)
+genCostModels =
+    Gen.map (Range.linear 0 (length plutusScriptVersions))
+            ((,) <$> Gen.element plutusScriptVersions
+                 <*> genCostModel)
+  where
+    plutusScriptVersions :: [AnyPlutusScriptVersion]
+    plutusScriptVersions = [minBound..maxBound]
+
+genExecutionUnits :: Gen ExecutionUnits
+genExecutionUnits = ExecutionUnits <$> Gen.integral (Range.constant 0 1000)
+                                   <*> Gen.integral (Range.constant 0 1000)
+
+genExecutionUnitPrices :: Gen ExecutionUnitPrices
+genExecutionUnitPrices = ExecutionUnitPrices <$> genLovelace <*> genLovelace