From 15dfd1bfc74fff016c4d260ad900ea664f285f15 Mon Sep 17 00:00:00 2001 From: Mateusz Galazyn Date: Tue, 30 Jul 2024 11:17:06 +0200 Subject: [PATCH] Fix missing script proposals in transaction building --- cardano-api/internal/Cardano/Api/Fees.hs | 7 +- cardano-api/internal/Cardano/Api/Tx/Body.hs | 78 +++++++++++---------- 2 files changed, 43 insertions(+), 42 deletions(-) diff --git a/cardano-api/internal/Cardano/Api/Fees.hs b/cardano-api/internal/Cardano/Api/Fees.hs index f6339fb80b..5ab103068c 100644 --- a/cardano-api/internal/Cardano/Api/Fees.hs +++ b/cardano-api/internal/Cardano/Api/Fees.hs @@ -251,10 +251,9 @@ estimateBalancedTxBody proposalProcedures :: OSet.OSet (L.ProposalProcedure (ShelleyLedgerEra era)) proposalProcedures = - case unFeatured <$> txProposalProcedures txbodycontent1 of - Nothing -> OSet.empty - Just TxProposalProceduresNone -> OSet.empty - Just (TxProposalProcedures procedures _) -> procedures + maryEraOnwardsConstraints w $ + maybe mempty (convProposalProcedures . unFeatured) $ + txProposalProcedures txbodycontent1 totalDeposits :: L.Coin totalDeposits = diff --git a/cardano-api/internal/Cardano/Api/Tx/Body.hs b/cardano-api/internal/Cardano/Api/Tx/Body.hs index 6a47494cb5..8dc0e19e8f 100644 --- a/cardano-api/internal/Cardano/Api/Tx/Body.hs +++ b/cardano-api/internal/Cardano/Api/Tx/Body.hs @@ -16,8 +16,6 @@ {-# LANGUAGE TypeOperators #-} {-# LANGUAGE ViewPatterns #-} -{- HLINT ignore "Redundant bracket" -} - -- | Transaction bodies module Cardano.Api.Tx.Body ( parseTxId @@ -56,6 +54,7 @@ module Cardano.Api.Tx.Body , setTxCertificates , setTxUpdateProposal , setTxProposalProcedures + , convProposalProcedures , setTxVotingProcedures , setTxMintValue , setTxScriptValidity @@ -236,12 +235,11 @@ import Control.Monad (guard, unless) import Data.Aeson (object, withObject, (.:), (.:?), (.=)) import qualified Data.Aeson as Aeson import qualified Data.Aeson.Key as Aeson -import qualified Data.Aeson.KeyMap as KeyMap import qualified Data.Aeson.Types as Aeson import Data.Bifunctor (Bifunctor (..)) import Data.ByteString (ByteString) import qualified Data.ByteString.Char8 as BSC -import Data.Foldable (for_, toList) +import Data.Foldable (for_) import Data.Function (on) import Data.Functor (($>)) import Data.List (sortBy) @@ -262,6 +260,7 @@ import Data.Text (Text) import qualified Data.Text as Text import Data.Type.Equality (TestEquality (..), (:~:) (Refl)) import Data.Word (Word16, Word32, Word64) +import GHC.Exts (IsList (..)) import Lens.Micro hiding (ix) import Lens.Micro.Extras (view) import qualified Text.Parsec as Parsec @@ -894,7 +893,7 @@ instance IsShelleyBasedEra era => FromJSON (TxOutValue era) where A.mkAdaValue (shelleyToAllegraEraToShelleyBasedEra shelleyToAlleg) ll ) ( \w -> do - let l = KeyMap.toList o + let l = toList o vals <- mapM decodeAssetId l pure $ shelleyBasedEraConstraints (maryEraOnwardsToShelleyBasedEra w) $ @@ -920,7 +919,7 @@ instance IsShelleyBasedEra era => FromJSON (TxOutValue era) where decodeAssets :: Aeson.Object -> Aeson.Parser [(AssetName, Quantity)] decodeAssets assetNameHm = - let l = KeyMap.toList assetNameHm + let l = toList assetNameHm in mapM (\(aName, q) -> (,) <$> parseAssetName aName <*> decodeQuantity q) l parseAssetName :: Aeson.Key -> Aeson.Parser AssetName @@ -1588,10 +1587,11 @@ validateTxBodyContent } = let witnesses = collectTxBodyScriptWitnesses sbe txBodContent languages = - Set.fromList + fromList [ toAlonzoLanguage (AnyPlutusScriptVersion v) | (_, AnyScriptWitness (PlutusScriptWitness _ v _ _ _ _)) <- witnesses ] + :: Set Plutus.Language in case sbe of ShelleyBasedEraShelley -> do validateTxIns txIns @@ -1829,7 +1829,7 @@ fromLedgerTxIns -> [(TxIn, BuildTxWith ViewTx (Witness WitCtxTxIn era))] fromLedgerTxIns sbe body = [ (fromShelleyTxIn input, ViewTx) - | input <- Set.toList (inputs_ sbe body) + | input <- toList (inputs_ sbe body) ] where inputs_ @@ -1859,7 +1859,7 @@ fromLedgerTxInsReference fromLedgerTxInsReference sbe txBody = caseShelleyToAlonzoOrBabbageEraOnwards (const TxInsReferenceNone) - (\w -> TxInsReference w $ map fromShelleyTxIn . Set.toList $ txBody ^. L.referenceInputsTxBodyL) + (\w -> TxInsReference w $ map fromShelleyTxIn . toList $ txBody ^. L.referenceInputsTxBodyL) sbe fromLedgerTxOuts @@ -2080,7 +2080,7 @@ fromLedgerTxExtraKeyWitnesses sbe body = TxExtraKeyWitnesses w [ PaymentKeyHash (Shelley.coerceKeyRole keyhash) - | keyhash <- Set.toList $ body ^. L.reqSignerHashesTxBodyL + | keyhash <- toList $ body ^. L.reqSignerHashesTxBodyL ] ) sbe @@ -2176,13 +2176,13 @@ classifyRangeError txout = TxOut (AddressInEra (ShelleyAddressInEra sbe) ShelleyAddress{}) _ _ _ -> case sbe of {} convTxIns :: TxIns BuildTx era -> Set (L.TxIn StandardCrypto) -convTxIns txIns = Set.fromList (map (toShelleyTxIn . fst) txIns) +convTxIns txIns = fromList (map (toShelleyTxIn . fst) txIns) convCollateralTxIns :: TxInsCollateral era -> Set (Ledger.TxIn StandardCrypto) convCollateralTxIns txInsCollateral = case txInsCollateral of TxInsCollateralNone -> Set.empty - TxInsCollateral _ txins -> Set.fromList (map toShelleyTxIn txins) + TxInsCollateral _ txins -> fromList (map toShelleyTxIn txins) convReturnCollateral :: ShelleyBasedEra era @@ -2205,7 +2205,7 @@ convTxOuts => ShelleyBasedEra era -> [TxOut ctx era] -> Seq.StrictSeq (Ledger.TxOut ledgerera) -convTxOuts sbe txOuts = Seq.fromList $ map (toShelleyTxOutAny sbe) txOuts +convTxOuts sbe txOuts = fromList $ map (toShelleyTxOutAny sbe) txOuts convCertificates :: ShelleyBasedEra era @@ -2213,7 +2213,7 @@ convCertificates -> Seq.StrictSeq (Shelley.TxCert (ShelleyLedgerEra era)) convCertificates _ = \case TxCertificatesNone -> Seq.empty - TxCertificates _ cs _ -> Seq.fromList (map toShelleyCertificate cs) + TxCertificates _ cs _ -> fromList (map toShelleyCertificate cs) convWithdrawals :: TxWithdrawals build era -> L.Withdrawals StandardCrypto convWithdrawals txWithdrawals = @@ -2266,7 +2266,7 @@ convExtraKeyWitnesses txExtraKeyWits = case txExtraKeyWits of TxExtraKeyWitnessesNone -> Set.empty TxExtraKeyWitnesses _ khs -> - Set.fromList + fromList [ Shelley.asWitness kh | PaymentKeyHash kh <- khs ] @@ -2294,7 +2294,7 @@ convScriptData sbe txOuts scriptWitnesses = ( \w -> let redeemers = Alonzo.Redeemers $ - Map.fromList + fromList [ (i, (toAlonzoData d, toAlonzoExUnits e)) | ( idx , AnyScriptWitness @@ -2306,7 +2306,7 @@ convScriptData sbe txOuts scriptWitnesses = datums = Alonzo.TxDats $ - Map.fromList + fromList [ (L.hashData d', d') | d <- scriptdata , let d' = toAlonzoData d @@ -2350,7 +2350,7 @@ convPParamsToScriptIntegrityHash w txProtocolParams redeemers datums languages = convLanguages :: [(ScriptWitnessIndex, AnyScriptWitness era)] -> Set Plutus.Language convLanguages witnesses = - Set.fromList + fromList [ toAlonzoLanguage (AnyPlutusScriptVersion v) | (_, AnyScriptWitness (PlutusScriptWitness _ v _ _ _ _)) <- witnesses ] @@ -2359,12 +2359,14 @@ convReferenceInputs :: TxInsReference build era -> Set (Ledger.TxIn StandardCryp convReferenceInputs txInsReference = case txInsReference of TxInsReferenceNone -> mempty - TxInsReference _ refTxins -> Set.fromList $ map toShelleyTxIn refTxins + TxInsReference _ refTxins -> fromList $ map toShelleyTxIn refTxins convProposalProcedures :: TxProposalProcedures build era -> OSet (L.ProposalProcedure (ShelleyLedgerEra era)) convProposalProcedures TxProposalProceduresNone = OSet.empty -convProposalProcedures (TxProposalProcedures procedures _) = procedures +convProposalProcedures (TxProposalProcedures procedures ViewTx) = procedures +convProposalProcedures (TxProposalProcedures procedures (BuildTxWith proposalProceduresWithWitnesses)) = + procedures <> fromList (Map.keys proposalProceduresWithWitnesses) convVotingProcedures :: TxVotingProcedures build era -> L.VotingProcedures (ShelleyLedgerEra era) convVotingProcedures txVotingProcedures = @@ -2604,7 +2606,7 @@ makeShelleyTransactionBody datums :: Alonzo.TxDats StandardAlonzo datums = Alonzo.TxDats $ - Map.fromList + fromList [ (L.hashData d, d) | d <- toAlonzoData <$> scriptdata ] @@ -2630,7 +2632,7 @@ makeShelleyTransactionBody redeemers :: Alonzo.Redeemers StandardAlonzo redeemers = Alonzo.Redeemers $ - Map.fromList + fromList [ (i, (toAlonzoData d, toAlonzoExUnits e)) | ( idx , AnyScriptWitness @@ -2642,7 +2644,7 @@ makeShelleyTransactionBody languages :: Set Plutus.Language languages = - Set.fromList + fromList [ toAlonzoLanguage (AnyPlutusScriptVersion v) | (_, AnyScriptWitness (PlutusScriptWitness _ v _ _ _ _)) <- witnesses ] @@ -2684,7 +2686,7 @@ makeShelleyTransactionBody & A.collateralInputsTxBodyL azOn .~ case txInsCollateral of TxInsCollateralNone -> Set.empty - TxInsCollateral _ txins -> Set.fromList (map toShelleyTxIn txins) + TxInsCollateral _ txins -> fromList (map toShelleyTxIn txins) & A.referenceInputsTxBodyL bOn .~ convReferenceInputs txInsReference & A.collateralReturnTxBodyL bOn .~ convReturnCollateral sbe txReturnCollateral & A.totalCollateralTxBodyL bOn .~ convTotalCollateral txTotalCollateral @@ -2729,7 +2731,7 @@ makeShelleyTransactionBody datums :: Alonzo.TxDats StandardBabbage datums = Alonzo.TxDats $ - Map.fromList + fromList [ (L.hashData d', d') | d <- scriptdata , let d' = toAlonzoData d @@ -2756,7 +2758,7 @@ makeShelleyTransactionBody redeemers :: Alonzo.Redeemers StandardBabbage redeemers = Alonzo.Redeemers $ - Map.fromList + fromList [ (i, (toAlonzoData d, toAlonzoExUnits e)) | ( idx , AnyScriptWitness @@ -2768,7 +2770,7 @@ makeShelleyTransactionBody languages :: Set Plutus.Language languages = - Set.fromList $ + fromList $ catMaybes [ getScriptLanguage sw | (_, AnyScriptWitness sw) <- witnesses @@ -2818,7 +2820,7 @@ makeShelleyTransactionBody & A.collateralInputsTxBodyL azOn .~ case txInsCollateral of TxInsCollateralNone -> Set.empty - TxInsCollateral _ txins -> Set.fromList (map toShelleyTxIn txins) + TxInsCollateral _ txins -> fromList (map toShelleyTxIn txins) & A.referenceInputsTxBodyL bOn .~ convReferenceInputs txInsReference & A.collateralReturnTxBodyL bOn .~ convReturnCollateral sbe txReturnCollateral & A.totalCollateralTxBodyL bOn .~ convTotalCollateral txTotalCollateral @@ -2833,8 +2835,8 @@ makeShelleyTransactionBody & A.proposalProceduresTxBodyL cOn .~ convProposalProcedures (maybe TxProposalProceduresNone unFeatured txProposalProcedures) & A.currentTreasuryValueTxBodyL cOn - .~ (Ledger.maybeToStrictMaybe (unFeatured <$> txCurrentTreasuryValue)) - & A.treasuryDonationTxBodyL cOn .~ (maybe (L.Coin 0) unFeatured txTreasuryDonation) + .~ Ledger.maybeToStrictMaybe (unFeatured <$> txCurrentTreasuryValue) + & A.treasuryDonationTxBodyL cOn .~ maybe (L.Coin 0) unFeatured txTreasuryDonation -- TODO Conway: support optional network id in TxBodyContent -- & L.networkIdTxBodyL .~ SNothing ) @@ -2868,7 +2870,7 @@ makeShelleyTransactionBody datums :: Alonzo.TxDats StandardConway datums = Alonzo.TxDats $ - Map.fromList + fromList [ (L.hashData d, d) | d <- toAlonzoData <$> scriptdata ] @@ -2894,7 +2896,7 @@ makeShelleyTransactionBody redeemers :: Alonzo.Redeemers StandardConway redeemers = Alonzo.Redeemers $ - Map.fromList + fromList [ (i, (toAlonzoData d, toAlonzoExUnits e)) | ( idx , AnyScriptWitness @@ -2906,7 +2908,7 @@ makeShelleyTransactionBody languages :: Set Plutus.Language languages = - Set.fromList $ + fromList $ catMaybes [ getScriptLanguage sw | (_, AnyScriptWitness sw) <- witnesses @@ -3179,7 +3181,7 @@ collectTxBodyScriptWitnesses scriptWitnessesVoting TxVotingProceduresNone = [] scriptWitnessesVoting (TxVotingProcedures (L.VotingProcedures votes) (BuildTxWith witnesses)) = [ (ScriptWitnessIndexVoting ix, AnyScriptWitness witness) - | let voterList = Map.toList votes + | let voterList = toList votes , (ix, (voter, _)) <- zip [0 ..] voterList , witness <- maybeToList (Map.lookup voter witnesses) ] @@ -3192,7 +3194,7 @@ collectTxBodyScriptWitnesses | Map.null mScriptWitnesses = [] | otherwise = [ (ScriptWitnessIndexProposing ix, AnyScriptWitness witness) - | let proposalsList = Set.toList $ OSet.toSet proposalProcedures + | let proposalsList = toList $ OSet.toSet proposalProcedures , (ix, proposal) <- zip [0 ..] proposalsList , witness <- maybeToList (Map.lookup proposal mScriptWitnesses) ] @@ -3213,7 +3215,7 @@ orderStakeAddrs = sortBy (compare `on` (\(k, _, _) -> k)) toShelleyWithdrawal :: [(StakeAddress, L.Coin, a)] -> L.Withdrawals StandardCrypto toShelleyWithdrawal withdrawals = L.Withdrawals $ - Map.fromList + fromList [ (toShelleyStakeAddr stakeAddr, value) | (stakeAddr, value, _) <- withdrawals ] @@ -3245,9 +3247,9 @@ toAuxiliaryData sbe txMetadata txAuxScripts = ShelleyBasedEraShelley -> guard (not (Map.null ms)) $> L.ShelleyTxAuxData ms ShelleyBasedEraAllegra -> - guard (not (Map.null ms && null ss)) $> L.AllegraTxAuxData ms (Seq.fromList ss) + guard (not (Map.null ms && null ss)) $> L.AllegraTxAuxData ms (fromList ss) ShelleyBasedEraMary -> - guard (not (Map.null ms && null ss)) $> L.AllegraTxAuxData ms (Seq.fromList ss) + guard (not (Map.null ms && null ss)) $> L.AllegraTxAuxData ms (fromList ss) ShelleyBasedEraAlonzo -> guard (not (Map.null ms && null ss)) $> L.mkAlonzoTxAuxData ms ss ShelleyBasedEraBabbage ->