Skip to content

Commit

Permalink
Fix missing script proposals in transaction building
Browse files Browse the repository at this point in the history
  • Loading branch information
@carbolymer
carbolymer committed Jul 30, 2024
1 parent aee2131 commit 15dfd1b
Show file tree
Hide file tree
Showing 2 changed files with 43 additions and 42 deletions.
7 changes: 3 additions & 4 deletions cardano-api/internal/Cardano/Api/Fees.hs
View file
Original file line number Diff line number Diff line change
Expand Up @@ -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 =
Expand Down
78 changes: 40 additions & 38 deletions cardano-api/internal/Cardano/Api/Tx/Body.hs
View file
Original file line number Diff line number Diff line change
Expand Up @@ -16,8 +16,6 @@
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE ViewPatterns #-}

{- HLINT ignore "Redundant bracket" -}

-- | Transaction bodies
module Cardano.Api.Tx.Body
( parseTxId
Expand Down Expand Up @@ -56,6 +54,7 @@ module Cardano.Api.Tx.Body
, setTxCertificates
, setTxUpdateProposal
, setTxProposalProcedures
, convProposalProcedures
, setTxVotingProcedures
, setTxMintValue
, setTxScriptValidity
Expand Down Expand Up @@ -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)
Expand All @@ -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
Expand Down Expand Up @@ -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) $
Expand All @@ -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
Expand Down Expand Up @@ -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
Expand Down Expand Up @@ -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_
Expand Down Expand Up @@ -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
Expand Down Expand Up @@ -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
Expand Down Expand Up @@ -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
Expand All @@ -2205,15 +2205,15 @@ 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
-> TxCertificates build era
-> 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 =
Expand Down Expand Up @@ -2266,7 +2266,7 @@ convExtraKeyWitnesses txExtraKeyWits =
case txExtraKeyWits of
TxExtraKeyWitnessesNone -> Set.empty
TxExtraKeyWitnesses _ khs ->
Set.fromList
fromList
[ Shelley.asWitness kh
| PaymentKeyHash kh <- khs
]
Expand Down Expand Up @@ -2294,7 +2294,7 @@ convScriptData sbe txOuts scriptWitnesses =
( \w ->
let redeemers =
Alonzo.Redeemers $
Map.fromList
fromList
[ (i, (toAlonzoData d, toAlonzoExUnits e))
| ( idx
, AnyScriptWitness
Expand All @@ -2306,7 +2306,7 @@ convScriptData sbe txOuts scriptWitnesses =

datums =
Alonzo.TxDats $
Map.fromList
fromList
[ (L.hashData d', d')
| d <- scriptdata
, let d' = toAlonzoData d
Expand Down Expand Up @@ -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
]
Expand All @@ -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 =
Expand Down Expand Up @@ -2604,7 +2606,7 @@ makeShelleyTransactionBody
datums :: Alonzo.TxDats StandardAlonzo
datums =
Alonzo.TxDats $
Map.fromList
fromList
[ (L.hashData d, d)
| d <- toAlonzoData <$> scriptdata
]
Expand All @@ -2630,7 +2632,7 @@ makeShelleyTransactionBody
redeemers :: Alonzo.Redeemers StandardAlonzo
redeemers =
Alonzo.Redeemers $
Map.fromList
fromList
[ (i, (toAlonzoData d, toAlonzoExUnits e))
| ( idx
, AnyScriptWitness
Expand All @@ -2642,7 +2644,7 @@ makeShelleyTransactionBody

languages :: Set Plutus.Language
languages =
Set.fromList
fromList
[ toAlonzoLanguage (AnyPlutusScriptVersion v)
| (_, AnyScriptWitness (PlutusScriptWitness _ v _ _ _ _)) <- witnesses
]
Expand Down Expand Up @@ -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
Expand Down Expand Up @@ -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
Expand All @@ -2756,7 +2758,7 @@ makeShelleyTransactionBody
redeemers :: Alonzo.Redeemers StandardBabbage
redeemers =
Alonzo.Redeemers $
Map.fromList
fromList
[ (i, (toAlonzoData d, toAlonzoExUnits e))
| ( idx
, AnyScriptWitness
Expand All @@ -2768,7 +2770,7 @@ makeShelleyTransactionBody

languages :: Set Plutus.Language
languages =
Set.fromList $
fromList $
catMaybes
[ getScriptLanguage sw
| (_, AnyScriptWitness sw) <- witnesses
Expand Down Expand Up @@ -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
Expand All @@ -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
)
Expand Down Expand Up @@ -2868,7 +2870,7 @@ makeShelleyTransactionBody
datums :: Alonzo.TxDats StandardConway
datums =
Alonzo.TxDats $
Map.fromList
fromList
[ (L.hashData d, d)
| d <- toAlonzoData <$> scriptdata
]
Expand All @@ -2894,7 +2896,7 @@ makeShelleyTransactionBody
redeemers :: Alonzo.Redeemers StandardConway
redeemers =
Alonzo.Redeemers $
Map.fromList
fromList
[ (i, (toAlonzoData d, toAlonzoExUnits e))
| ( idx
, AnyScriptWitness
Expand All @@ -2906,7 +2908,7 @@ makeShelleyTransactionBody

languages :: Set Plutus.Language
languages =
Set.fromList $
fromList $
catMaybes
[ getScriptLanguage sw
| (_, AnyScriptWitness sw) <- witnesses
Expand Down Expand Up @@ -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)
]
Expand All @@ -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)
]
Expand All @@ -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
]
Expand Down Expand Up @@ -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 ->
Expand Down

0 comments on commit 15dfd1b

Please sign in to comment.