Disallow empty fields in ConwayTxBodyRaw (#3712)

* Disallow empty fields in ConwayTxBodyRaw - Fix `ConwayTxBodyRaw` decoder to disallow empty - `certsTxBodyL` - `withdrawalsTxBodyL` - `mintTxBodyL` - `collateralInputsTxBodyL` - `reqSignerHashesTxBodyL` - `referenceInputsTxBodyL` - `votingProceduresTxBodyL` - `proposalProceduresTxBodyL` - Add `fieldGuarded` to conditionally construct a `Field` - Fix the related CDDL for Conway
IntersectMBO · Sep 6, 2023 · 27ac9d2 · 27ac9d2
1 parent 70fc0d2
commit 27ac9d2
Show file tree

Hide file tree

Showing 10 changed files with 104 additions and 30 deletions.
diff --git a/eras/conway/impl/CHANGELOG.md b/eras/conway/impl/CHANGELOG.md
@@ -2,6 +2,15 @@
 
 ## 1.9.0.0
 
+* Fix `ConwayTxBodyRaw` decoder to disallow empty `Field`s #3712
+  * `certsTxBodyL`
+  * `withdrawalsTxBodyL`
+  * `mintTxBodyL`
+  * `collateralInputsTxBodyL`
+  * `reqSignerHashesTxBodyL`
+  * `referenceInputsTxBodyL`
+  * `votingProceduresTxBodyL`
+  * `proposalProceduresTxBodyL`
 * Add `reorderActions`, `actionPriority`
 * Remove `ensProtVer` field from `EnactState`: #3705
 * Move `ConwayEraTxBody` to `Cardano.Ledger.Conway.TxBody`

diff --git a/eras/conway/impl/cardano-ledger-conway.cabal b/eras/conway/impl/cardano-ledger-conway.cabal
@@ -69,7 +69,7 @@ library
         aeson,
         bytestring,
         cardano-crypto-class,
-        cardano-ledger-binary >=1.1,
+        cardano-ledger-binary >=1.1.3,
         cardano-ledger-allegra >=1.1,
         cardano-ledger-alonzo ^>=1.4.1,
         cardano-ledger-babbage >=1.4.1,

diff --git a/eras/conway/impl/src/Cardano/Ledger/Conway/TxBody.hs b/eras/conway/impl/src/Cardano/Ledger/Conway/TxBody.hs
@@ -70,6 +70,7 @@ import Cardano.Ledger.Binary.Coders (
   encode,
   encodeKeyedStrictMaybe,
   field,
+  fieldGuarded,
   ofield,
   (!>),
  )
@@ -180,35 +181,77 @@ instance
         ofield
           (\x tx -> tx {ctbrVldt = (ctbrVldt tx) {invalidHereafter = x}})
           From
-      bodyFields 4 = field (\x tx -> tx {ctbrCerts = x}) From
-      bodyFields 5 = field (\x tx -> tx {ctbrWithdrawals = x}) From
+      bodyFields 4 =
+        fieldGuarded
+          (emptyFailure "Certificates" "non-empty")
+          null
+          (\x tx -> tx {ctbrCerts = x})
+          From
+      bodyFields 5 =
+        fieldGuarded
+          (emptyFailure "Withdrawals" "non-empty")
+          (null . unWithdrawals)
+          (\x tx -> tx {ctbrWithdrawals = x})
+          From
       bodyFields 7 = ofield (\x tx -> tx {ctbrAuxDataHash = x}) From
       bodyFields 8 =
         ofield
           (\x tx -> tx {ctbrVldt = (ctbrVldt tx) {invalidBefore = x}})
           From
-      bodyFields 9 = field (\x tx -> tx {ctbrMint = x}) From
+      bodyFields 9 =
+        fieldGuarded
+          (emptyFailure "Mint" "non-empty")
+          (== mempty)
+          (\x tx -> tx {ctbrMint = x})
+          From
       bodyFields 11 = ofield (\x tx -> tx {ctbrScriptIntegrityHash = x}) From
-      bodyFields 13 = field (\x tx -> tx {ctbrCollateralInputs = x}) From
-      bodyFields 14 = field (\x tx -> tx {ctbrReqSignerHashes = x}) From
+      bodyFields 13 =
+        fieldGuarded
+          (emptyFailure "Collateral Inputs" "non-empty")
+          null
+          (\x tx -> tx {ctbrCollateralInputs = x})
+          From
+      bodyFields 14 =
+        fieldGuarded
+          (emptyFailure "Required Signer Hashes" "non-empty")
+          null
+          (\x tx -> tx {ctbrReqSignerHashes = x})
+          From
       bodyFields 15 = ofield (\x tx -> tx {ctbrTxNetworkId = x}) From
       bodyFields 16 = ofield (\x tx -> tx {ctbrCollateralReturn = x}) From
       bodyFields 17 = ofield (\x tx -> tx {ctbrTotalCollateral = x}) From
-      bodyFields 18 = field (\x tx -> tx {ctbrReferenceInputs = x}) From
-      bodyFields 19 = field (\x tx -> tx {ctbrVotingProcedures = x}) From
-      bodyFields 20 = field (\x tx -> tx {ctbrProposalProcedures = x}) From
+      bodyFields 18 =
+        fieldGuarded
+          (emptyFailure "Reference Inputs" "non-empty")
+          null
+          (\x tx -> tx {ctbrReferenceInputs = x})
+          From
+      bodyFields 19 =
+        fieldGuarded
+          (emptyFailure "VotingProcedures" "non-empty")
+          (null . unVotingProcedures)
+          (\x tx -> tx {ctbrVotingProcedures = x})
+          From
+      bodyFields 20 =
+        fieldGuarded
+          (emptyFailure "ProposalProcedures" "non-empty")
+          null
+          (\x tx -> tx {ctbrProposalProcedures = x})
+          From
       bodyFields 21 = ofield (\x tx -> tx {ctbrCurrentTreasuryValue = x}) From
       bodyFields 22 =
         ofield
           (\x tx -> tx {ctbrTreasuryDonation = fromSMaybe zero x})
-          (D (decodePositiveCoin "'treasuryWithdrawal' must be non-zero when supplied"))
+          (D (decodePositiveCoin $ emptyFailure "Treasury Donation" "non-zero"))
       bodyFields n = field (\_ t -> t) (Invalid n)
       requiredFields :: [(Word, String)]
       requiredFields =
         [ (0, "inputs")
         , (1, "outputs")
         , (2, "fee")
         ]
+      emptyFailure fieldName requirement =
+        "TxBody: '" <> fieldName <> "' must be " <> requirement <> " when supplied"
 
 newtype ConwayTxBody era = TxBodyConstr (MemoBytes ConwayTxBodyRaw era)
   deriving (Generic, SafeToHash, ToCBOR)

diff --git a/eras/conway/test-suite/cddl-files/conway.cddl b/eras/conway/test-suite/cddl-files/conway.cddl
@@ -51,26 +51,26 @@ major_protocol_version = 1..next_major_protocol_version
 protocol_version = (major_protocol_version, uint)
 
 transaction_body =
-  { 0 : set<transaction_input>      ; inputs
+  { 0 : set<transaction_input>             ; inputs
   , 1 : [* transaction_output]
-  , 2 : coin                        ; fee
-  , ? 3 : uint                      ; time to live
-  , ? 4 : [* certificate]
+  , 2 : coin                               ; fee
+  , ? 3 : uint                             ; time to live
+  , ? 4 : [+ certificate]
   , ? 5 : withdrawals
   , ? 7 : auxiliary_data_hash
-  , ? 8 : uint                      ; validity interval start
+  , ? 8 : uint                             ; validity interval start
   , ? 9 : mint
   , ? 11 : script_data_hash
-  , ? 13 : set<transaction_input>   ; collateral inputs
+  , ? 13 : nonempty_set<transaction_input> ; collateral inputs
   , ? 14 : required_signers
   , ? 15 : network_id
-  , ? 16 : transaction_output       ; collateral return
-  , ? 17 : coin                     ; total collateral
-  , ? 18 : set<transaction_input>   ; reference inputs
-  , ? 19 : voting_procedures        ; New; Voting procedures
-  , ? 20 : [* proposal_procedure]   ; New; Proposal procedures
-  , ? 21 : coin                     ; New; current treasury value
-  , ? 22 : positive_coin            ; New; donation
+  , ? 16 : transaction_output              ; collateral return
+  , ? 17 : coin                            ; total collateral
+  , ? 18 : nonempty_set<transaction_input> ; reference inputs
+  , ? 19 : voting_procedures               ; New; Voting procedures
+  , ? 20 : [+ proposal_procedure]          ; New; Proposal procedures
+  , ? 21 : coin                            ; New; current treasury value
+  , ? 22 : positive_coin                   ; New; donation
   }
 
 voting_procedures = { + voter => { + gov_action_id => voting_procedure } }
@@ -146,7 +146,7 @@ gov_action_id =
   , gov_action_index : uint
   ]
 
-required_signers = set<$addr_keyhash>
+required_signers = nonempty_set<$addr_keyhash>
 
 transaction_input = [ transaction_id : $hash32
                     , index : uint
@@ -370,7 +370,7 @@ relay =
 pool_metadata = [url, pool_metadata_hash]
 url = tstr .size (0..64)
 
-withdrawals = { * reward_account => coin }
+withdrawals = { + reward_account => coin }
 
 protocol_param_update =
   { ? 0:  uint                   ; minfee A

diff --git a/eras/conway/test-suite/cddl-files/mock/extras.cddl b/eras/conway/test-suite/cddl-files/mock/extras.cddl
@@ -1,6 +1,8 @@
 set<a> = [a]
   ; real set is [* a]
 
+nonempty_set<a> = [+ a]
+
 unit_interval = #6.30([1, 2])
   ; real unit_interval is: #6.30([uint, uint])
   ; but this produces numbers outside the unit interval

diff --git a/eras/conway/test-suite/cddl-files/real/extras.cddl b/eras/conway/test-suite/cddl-files/real/extras.cddl
@@ -1,4 +1,6 @@
-finite_set<a> = [* a ]
+finite_set<a> = [* a]
+
+nonempty_finite_set<a> = [+ a]
 
 unit_interval = #6.30([uint, uint])
 

diff --git a/eras/conway/test-suite/test/Tests.hs b/eras/conway/test-suite/test/Tests.hs
@@ -19,7 +19,7 @@ defaultTests =
   testGroup
     "Conway tests"
     [ Roundtrip.allprops @Conway
-    , CDDL.tests 5
+    , CDDL.tests 10
     , Babbage.txInfoTests (Proxy @Conway)
     , Conway.txInfoTests (Proxy @Conway)
     , govSnapshotProps

diff --git a/libs/cardano-ledger-binary/CHANGELOG.md b/libs/cardano-ledger-binary/CHANGELOG.md
@@ -1,8 +1,8 @@
 # Version history for `cardano-ledger-binary`
 
-## 1.1.2.1
+## 1.1.3.0
 
-*
+* Add `fieldGuarded` to be able to conditionally construct a `Field` #3712
 
 ## 1.1.2.0
 

diff --git a/libs/cardano-ledger-binary/cardano-ledger-binary.cabal b/libs/cardano-ledger-binary/cardano-ledger-binary.cabal
@@ -1,6 +1,6 @@
 cabal-version: 3.0
 name:          cardano-ledger-binary
-version:       1.1.2.1
+version:       1.1.3.0
 license:       Apache-2.0
 maintainer:    [email protected]
 author:        IOHK

diff --git a/libs/cardano-ledger-binary/src/Cardano/Ledger/Binary/Decoding/Coders.hs b/libs/cardano-ledger-binary/src/Cardano/Ledger/Binary/Decoding/Coders.hs
@@ -35,6 +35,7 @@ module Cardano.Ledger.Binary.Decoding.Coders (
   ofield,
   invalidField,
   field,
+  fieldGuarded,
   fieldA,
   fieldAA,
 
@@ -68,6 +69,7 @@ import Cardano.Ledger.Binary.Version (Version)
 #if ! MIN_VERSION_base(4,18,0)
 import Control.Applicative (liftA2)
 #endif
+import Control.Monad (when)
 import qualified Data.Map.Strict as Map
 import Data.Maybe.Strict (StrictMaybe (..))
 import Data.Set (Set, insert, member)
@@ -130,6 +132,22 @@ data Field t where
 field :: (x -> t -> t) -> Decode ('Closed d) x -> Field t
 field update dec = Field update (decode dec)
 
+{-# INLINE fieldGuarded #-}
+fieldGuarded ::
+  -- | The message to use if the condition fails
+  String ->
+  -- | The condition to guard against
+  (x -> Bool) ->
+  (x -> t -> t) ->
+  Decode ('Closed d) x ->
+  Field t
+fieldGuarded failMsg check update dec =
+  Field
+    update
+    ( decode dec >>= \x ->
+        x <$ when (check x) (fail failMsg)
+    )
+
 {-# INLINE ofield #-}
 ofield :: (StrictMaybe x -> t -> t) -> Decode ('Closed d) x -> Field t
 ofield update dec = Field update (SJust <$> decode dec)