Direct CBOR serialisation instance for UpdateProposal

Previously we serialised UpdateProposal to CBOR using the underlying CBOR instance for the Shelley.Update type. We can no longer do this because our strategy in the API for the protocol params is to use a single representation across all eras, rather than an era-dependent representation. This means that no single era from the underlying ledger can represent all the protocol params. Thus for serialisation we need a direct instance, rather than going via the ledger types. This requires To/FromCBOR instances for ProtocolParametersUpdate, which entail To/FromCBOR instances for a few other types. Co-authored-by: John Ky <john.ky@iohk.io>
IntersectMBO · Jun 8, 2021 · ff26e10 · ff26e10
1 parent 9588c4d
commit ff26e10
Show file tree

Hide file tree

Showing 3 changed files with 114 additions and 11 deletions.
diff --git a/cardano-api/src/Cardano/Api/ProtocolParameters.hs b/cardano-api/src/Cardano/Api/ProtocolParameters.hs
@@ -1,3 +1,4 @@
+{-# LANGUAGE DeriveAnyClass #-}
 {-# LANGUAGE DeriveGeneric #-}
 {-# LANGUAGE DerivingVia #-}
 {-# LANGUAGE GeneralizedNewtypeDeriving #-}
@@ -53,7 +54,6 @@ module Cardano.Api.ProtocolParameters (
 import           Prelude
 
 import           Data.ByteString (ByteString)
-import qualified Data.ByteString.Lazy.Char8 as LBS
 import           Data.Map.Strict (Map)
 import qualified Data.Map.Strict as Map
 import           Data.String (IsString)
@@ -575,6 +575,65 @@ instance Monoid ProtocolParametersUpdate where
       , protocolUpdateMaxCollateralInputs = Nothing
       }
 
+instance ToCBOR ProtocolParametersUpdate where
+    toCBOR ProtocolParametersUpdate{..} =
+        CBOR.encodeListLen 25
+     <> toCBOR protocolUpdateProtocolVersion
+     <> toCBOR protocolUpdateDecentralization
+     <> toCBOR protocolUpdateExtraPraosEntropy
+     <> toCBOR protocolUpdateMaxBlockHeaderSize
+     <> toCBOR protocolUpdateMaxBlockBodySize
+     <> toCBOR protocolUpdateMaxTxSize
+     <> toCBOR protocolUpdateTxFeeFixed
+     <> toCBOR protocolUpdateTxFeePerByte
+     <> toCBOR protocolUpdateMinUTxOValue
+     <> toCBOR protocolUpdateStakeAddressDeposit
+     <> toCBOR protocolUpdateStakePoolDeposit
+     <> toCBOR protocolUpdateMinPoolCost
+     <> toCBOR protocolUpdatePoolRetireMaxEpoch
+     <> toCBOR protocolUpdateStakePoolTargetNum
+     <> toCBOR protocolUpdatePoolPledgeInfluence
+     <> toCBOR protocolUpdateMonetaryExpansion
+     <> toCBOR protocolUpdateTreasuryCut
+     <> toCBOR protocolUpdateUTxOCostPerWord
+     <> toCBOR protocolUpdateCostModels
+     <> toCBOR protocolUpdatePrices
+     <> toCBOR protocolUpdateMaxTxExUnits
+     <> toCBOR protocolUpdateMaxBlockExUnits
+     <> toCBOR protocolUpdateMaxValueSize
+     <> toCBOR protocolUpdateCollateralPercent
+     <> toCBOR protocolUpdateMaxCollateralInputs
+
+instance FromCBOR ProtocolParametersUpdate where
+    fromCBOR = do
+      CBOR.enforceSize "ProtocolParametersUpdate" 25
+      ProtocolParametersUpdate
+        <$> fromCBOR
+        <*> fromCBOR
+        <*> fromCBOR
+        <*> fromCBOR
+        <*> fromCBOR
+        <*> fromCBOR
+        <*> fromCBOR
+        <*> fromCBOR
+        <*> fromCBOR
+        <*> fromCBOR
+        <*> fromCBOR
+        <*> fromCBOR
+        <*> fromCBOR
+        <*> fromCBOR
+        <*> fromCBOR
+        <*> fromCBOR
+        <*> fromCBOR
+        <*> fromCBOR
+        <*> fromCBOR
+        <*> fromCBOR
+        <*> fromCBOR
+        <*> fromCBOR
+        <*> fromCBOR
+        <*> fromCBOR
+        <*> fromCBOR
+
 
 -- ----------------------------------------------------------------------------
 -- Praos nonce
@@ -626,6 +685,19 @@ data ExecutionUnitPrices =
      }
   deriving (Eq, Show)
 
+instance ToCBOR ExecutionUnitPrices where
+  toCBOR ExecutionUnitPrices{priceExecutionSteps, priceExecutionMemory} =
+      CBOR.encodeListLen 2
+   <> toCBOR priceExecutionSteps
+   <> toCBOR priceExecutionMemory
+
+instance FromCBOR ExecutionUnitPrices where
+  fromCBOR = do
+    CBOR.enforceSize "ExecutionUnitPrices" 2
+    ExecutionUnitPrices
+      <$> fromCBOR
+      <*> fromCBOR
+
 instance ToJSON ExecutionUnitPrices where
   toJSON ExecutionUnitPrices{priceExecutionSteps, priceExecutionMemory} =
     object [ "priceSteps"  .= priceExecutionSteps
@@ -661,6 +733,7 @@ fromAlonzoPrices Alonzo.Prices{Alonzo.prSteps, Alonzo.prMem} =
 newtype CostModel = CostModel (Map Text Integer)
   deriving (Eq, Show)
   deriving newtype (ToJSON, FromJSON)
+  deriving newtype (ToCBOR, FromCBOR)
 
 validateCostModel :: PlutusScriptVersion lang
                   -> CostModel
@@ -720,6 +793,7 @@ data UpdateProposal =
        !(Map (Hash GenesisKey) ProtocolParametersUpdate)
        !EpochNo
     deriving stock (Eq, Show)
+    deriving anyclass SerialiseAsCBOR
 
 instance HasTypeProxy UpdateProposal where
     data AsType UpdateProposal = AsUpdateProposal
@@ -728,14 +802,18 @@ instance HasTypeProxy UpdateProposal where
 instance HasTextEnvelope UpdateProposal where
     textEnvelopeType _ = "UpdateProposalShelley"
 
-instance SerialiseAsCBOR UpdateProposal where
-    --TODO alonzo: we can no longer use this Shelley-specific encoding
-    serialiseToCBOR = CBOR.serializeEncoding'
-                    . toCBOR
-                    . toLedgerUpdate ShelleyBasedEraShelley
-    deserialiseFromCBOR _ bs =
-      fromLedgerUpdate ShelleyBasedEraShelley <$> CBOR.decodeFull (LBS.fromStrict bs)
-
+instance ToCBOR UpdateProposal where
+    toCBOR (UpdateProposal ppup epochno) =
+        CBOR.encodeListLen 2
+     <> toCBOR ppup
+     <> toCBOR epochno
+
+instance FromCBOR UpdateProposal where
+    fromCBOR = do
+      CBOR.enforceSize "ProtocolParametersUpdate" 2
+      UpdateProposal
+        <$> fromCBOR
+        <*> fromCBOR
 
 makeShelleyUpdateProposal :: ProtocolParametersUpdate
                           -> [Hash GenesisKey]

diff --git a/cardano-api/src/Cardano/Api/Script.hs b/cardano-api/src/Cardano/Api/Script.hs
@@ -290,6 +290,17 @@ instance Bounded AnyPlutusScriptVersion where
     minBound = AnyPlutusScriptVersion PlutusScriptV1
     maxBound = AnyPlutusScriptVersion PlutusScriptV1
 
+instance ToCBOR AnyPlutusScriptVersion where
+    toCBOR = toCBOR . fromEnum
+
+instance FromCBOR AnyPlutusScriptVersion where
+    fromCBOR = do
+      n <- fromCBOR
+      if n >= fromEnum (minBound :: AnyPlutusScriptVersion) &&
+         n <= fromEnum (maxBound :: AnyPlutusScriptVersion)
+        then return $! toEnum n
+        else fail "plutus script version out of bounds"
+
 instance ToJSON AnyPlutusScriptVersion where
     toJSON (AnyPlutusScriptVersion PlutusScriptV1) =
       Aeson.String "PlutusScriptV1"
@@ -742,6 +753,19 @@ data ExecutionUnits =
      }
   deriving (Eq, Show)
 
+instance ToCBOR ExecutionUnits where
+  toCBOR ExecutionUnits{executionSteps, executionMemory} =
+      CBOR.encodeListLen 2
+   <> toCBOR executionSteps
+   <> toCBOR executionMemory
+
+instance FromCBOR ExecutionUnits where
+  fromCBOR = do
+    CBOR.enforceSize "ExecutionUnits" 2
+    ExecutionUnits
+      <$> fromCBOR
+      <*> fromCBOR
+
 instance ToJSON ExecutionUnits where
   toJSON ExecutionUnits{executionSteps, executionMemory} =
     object [ "steps"  .= executionSteps

diff --git a/cardano-api/src/Cardano/Api/Value.hs b/cardano-api/src/Cardano/Api/Value.hs
@@ -76,6 +76,7 @@ import           Cardano.Ledger.Crypto (StandardCrypto)
 
 import           Cardano.Api.HasTypeProxy
 import           Cardano.Api.Script
+import           Cardano.Api.SerialiseCBOR
 import           Cardano.Api.SerialiseRaw
 import           Cardano.Api.SerialiseUsing
 
@@ -85,8 +86,8 @@ import           Cardano.Api.SerialiseUsing
 --
 
 newtype Lovelace = Lovelace Integer
-  deriving stock (Show)
-  deriving newtype (Eq, Ord, Enum, Num, ToJSON, FromJSON)
+  deriving stock (Eq, Ord, Show)
+  deriving newtype (Enum, Num, ToJSON, FromJSON, ToCBOR, FromCBOR)
 
 instance Semigroup Lovelace where
   Lovelace a <> Lovelace b = Lovelace (a + b)