diff --git a/cardano-api/internal/Cardano/Api/Governance/Poll.hs b/cardano-api/internal/Cardano/Api/Governance/Poll.hs index 7e4063e5c2..2d58e06b8a 100644 --- 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 index 2627375931..2696616c35 100644 --- 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