Adapt callers outside ProtocolParameters

IntersectMBO · Jan 16, 2025 · 2a1154b · 2a1154b
1 parent cd62068
commit 2a1154b
Show file tree

Hide file tree

Showing 2 changed files with 46 additions and 42 deletions.
diff --git a/cardano-api/internal/Cardano/Api/Governance/Poll.hs b/cardano-api/internal/Cardano/Api/Governance/Poll.hs
@@ -7,7 +7,6 @@
 {-# LANGUAGE ScopedTypeVariables #-}
 {-# LANGUAGE TypeApplications #-}
 {-# LANGUAGE TypeFamilies #-}
-{-# LANGUAGE ViewPatterns #-}
 
 -- | An API for driving on-chain poll for SPOs.
 --
@@ -37,8 +36,10 @@ module Cardano.Api.Governance.Poll
   )
 where
 
+import           Cardano.Api.Pretty
+import           Cardano.Api.Error
+import           Cardano.Api.ProtocolParameters
 import           Cardano.Api.Eon.ShelleyBasedEra
-import           Cardano.Api.Eras
 import           Cardano.Api.Hash
 import           Cardano.Api.HasTypeProxy
 import           Cardano.Api.Keys.Shelley
@@ -58,6 +59,7 @@ import           Cardano.Ledger.Crypto (HASH, StandardCrypto)
 
 import           Control.Arrow (left)
 import           Control.Monad (foldM, when)
+import           Data.Bifunctor (first)
 import           Data.Either.Combinators (maybeToRight)
 import           Data.Function ((&))
 import qualified Data.Map.Strict as Map
@@ -279,6 +281,7 @@ data GovernancePollError
   | ErrGovernancePollUnauthenticated
   | ErrGovernancePollMalformedAnswer DecoderError
   | ErrGovernancePollInvalidAnswer GovernancePollInvalidAnswerError
+  | ErrGovernancePollCostModelNotEnoughParameters CostModelNotEnoughParametersError
   deriving Show
 
 data GovernancePollInvalidAnswerError = GovernancePollInvalidAnswerError
@@ -331,6 +334,9 @@ renderGovernancePollError err =
             | (ix, answer) <- invalidAnswerAcceptableAnswers invalidAnswer
             ]
         ]
+    ErrGovernancePollCostModelNotEnoughParameters err' ->
+      -- TODO can be simplified?
+      Text.pack $ docToString $ prettyError err'
 
 -- | Verify a poll against a given transaction and returns the signatories
 -- (verification key only) when valid.
@@ -341,12 +347,14 @@ verifyPollAnswer
   :: GovernancePoll
   -> InAnyShelleyBasedEra Tx
   -> Either GovernancePollError [Hash PaymentKey]
-verifyPollAnswer poll (InAnyShelleyBasedEra _era (getTxBody -> TxBody body)) = do
-  answer <- extractPollAnswer (txMetadata body)
+verifyPollAnswer poll (InAnyShelleyBasedEra _era tx) = do
+  content <- first ErrGovernancePollCostModelNotEnoughParameters $ getTxBodyContent body
+  answer <- extractPollAnswer (txMetadata content)
   answer `hasMatchingHash` hashGovernancePoll poll
   answer `isAmongAcceptableChoices` govPollAnswers poll
-  extraKeyWitnesses (txExtraKeyWits body)
+  extraKeyWitnesses (txExtraKeyWits content)
  where
+  body = getTxBody tx
   extractPollAnswer = \case
     TxMetadataNone ->
       Left ErrGovernancePollNoAnswer

diff --git a/cardano-api/internal/Cardano/Api/Tx/Body.hs b/cardano-api/internal/Cardano/Api/Tx/Body.hs
@@ -14,14 +14,12 @@
 {-# LANGUAGE TypeApplications #-}
 {-# LANGUAGE TypeFamilies #-}
 {-# LANGUAGE TypeOperators #-}
-{-# LANGUAGE ViewPatterns #-}
 
 -- | Transaction bodies
 module Cardano.Api.Tx.Body
   ( parseTxId
 
     -- * Transaction bodies
-  , TxBody (.., TxBody)
   , createTransactionBody
   , createAndValidateTransactionBody
   , TxBodyContent (..)
@@ -2148,12 +2146,8 @@ createAndValidateTransactionBody
   -> Either TxBodyError (TxBody era)
 createAndValidateTransactionBody = makeShelleyTransactionBody
 
-pattern TxBody :: TxBodyContent ViewTx era -> TxBody era
-pattern TxBody txbodycontent <- (getTxBodyContent -> txbodycontent)
-
-{-# COMPLETE TxBody #-}
-
-getTxBodyContent :: TxBody era -> TxBodyContent ViewTx era
+getTxBodyContent
+  :: TxBody era -> Either CostModelNotEnoughParametersError (TxBodyContent ViewTx era)
 getTxBodyContent = \case
   ShelleyTxBody sbe body _scripts scriptdata mAux scriptValidity ->
     fromLedgerTxBody sbe scriptValidity body scriptdata mAux
@@ -2164,34 +2158,36 @@ fromLedgerTxBody
   -> Ledger.TxBody (ShelleyLedgerEra era)
   -> TxBodyScriptData era
   -> Maybe (L.TxAuxData (ShelleyLedgerEra era))
-  -> TxBodyContent ViewTx era
+  -> Either CostModelNotEnoughParametersError (TxBodyContent ViewTx era)
 fromLedgerTxBody sbe scriptValidity body scriptdata mAux =
-  TxBodyContent
-    { txIns = fromLedgerTxIns sbe body
-    , txInsCollateral = fromLedgerTxInsCollateral sbe body
-    , txInsReference = fromLedgerTxInsReference sbe body
-    , txOuts = fromLedgerTxOuts sbe body scriptdata
-    , txTotalCollateral = fromLedgerTxTotalCollateral sbe body
-    , txReturnCollateral = fromLedgerTxReturnCollateral sbe body
-    , txFee = fromLedgerTxFee sbe body
-    , txValidityLowerBound = fromLedgerTxValidityLowerBound sbe (A.TxBody body)
-    , txValidityUpperBound = fromLedgerTxValidityUpperBound sbe (A.TxBody body)
-    , txWithdrawals = fromLedgerTxWithdrawals sbe body
-    , txCertificates = fromLedgerTxCertificates sbe body
-    , txUpdateProposal = maybeFromLedgerTxUpdateProposal sbe body
-    , txMintValue = fromLedgerTxMintValue sbe body
-    , txExtraKeyWits = fromLedgerTxExtraKeyWitnesses sbe body
-    , txProtocolParams = ViewTx
-    , txMetadata
-    , txAuxScripts
-    , txScriptValidity = scriptValidity
-    , txProposalProcedures = fromLedgerProposalProcedures sbe body
-    , txVotingProcedures = fromLedgerVotingProcedures sbe body
-    , txCurrentTreasuryValue = fromLedgerCurrentTreasuryValue sbe body
-    , txTreasuryDonation = fromLedgerTreasuryDonation sbe body
-    }
+  txUpdateProposal <&> \txup ->
+    TxBodyContent
+      { txIns = fromLedgerTxIns sbe body
+      , txInsCollateral = fromLedgerTxInsCollateral sbe body
+      , txInsReference = fromLedgerTxInsReference sbe body
+      , txOuts = fromLedgerTxOuts sbe body scriptdata
+      , txTotalCollateral = fromLedgerTxTotalCollateral sbe body
+      , txReturnCollateral = fromLedgerTxReturnCollateral sbe body
+      , txFee = fromLedgerTxFee sbe body
+      , txValidityLowerBound = fromLedgerTxValidityLowerBound sbe (A.TxBody body)
+      , txValidityUpperBound = fromLedgerTxValidityUpperBound sbe (A.TxBody body)
+      , txWithdrawals = fromLedgerTxWithdrawals sbe body
+      , txCertificates = fromLedgerTxCertificates sbe body
+      , txUpdateProposal = txup
+      , txMintValue = fromLedgerTxMintValue sbe body
+      , txExtraKeyWits = fromLedgerTxExtraKeyWitnesses sbe body
+      , txProtocolParams = ViewTx
+      , txMetadata
+      , txAuxScripts
+      , txScriptValidity = scriptValidity
+      , txProposalProcedures = fromLedgerProposalProcedures sbe body
+      , txVotingProcedures = fromLedgerVotingProcedures sbe body
+      , txCurrentTreasuryValue = fromLedgerCurrentTreasuryValue sbe body
+      , txTreasuryDonation = fromLedgerTreasuryDonation sbe body
+      }
  where
   (txMetadata, txAuxScripts) = fromLedgerTxAuxiliaryData sbe mAux
+  txUpdateProposal = maybeFromLedgerTxUpdateProposal sbe body
 
 fromLedgerProposalProcedures
   :: ShelleyBasedEra era
@@ -2544,15 +2540,15 @@ maybeFromLedgerTxUpdateProposal
   :: ()
   => ShelleyBasedEra era
   -> Ledger.TxBody (ShelleyLedgerEra era)
-  -> TxUpdateProposal era
+  -> Either CostModelNotEnoughParametersError (TxUpdateProposal era)
 maybeFromLedgerTxUpdateProposal sbe body =
   caseShelleyToBabbageOrConwayEraOnwards
     ( \w ->
         case body ^. L.updateTxBodyL of
-          SNothing -> TxUpdateProposalNone
-          SJust p -> TxUpdateProposal w (fromLedgerUpdate sbe p)
+          SNothing -> pure TxUpdateProposalNone
+          SJust p -> TxUpdateProposal w <$> (fromLedgerUpdate sbe p)
     )
-    (const TxUpdateProposalNone)
+    (const $ pure TxUpdateProposalNone)
     sbe
 
 fromLedgerTxMintValue