diff --git a/cardano-api/gen/Test/Gen/Cardano/Api/Typed.hs b/cardano-api/gen/Test/Gen/Cardano/Api/Typed.hs index fcaf932d0c..9341bb8859 100644 --- a/cardano-api/gen/Test/Gen/Cardano/Api/Typed.hs +++ b/cardano-api/gen/Test/Gen/Cardano/Api/Typed.hs @@ -260,38 +260,38 @@ genSimpleScript = -- plutus scripts as well as valid plutus scripts. genPlutusScript :: PlutusScriptVersion lang -> Gen (PlutusScript lang) genPlutusScript l = - case l of - PlutusScriptV1 -> do + case l of + PlutusScriptV1 -> do PlutusScript _ s <- genPlutusV1Script return s - PlutusScriptV2 -> do + PlutusScriptV2 -> do PlutusScript _ s <- genPlutusV2Script return s - PlutusScriptV3 -> do + PlutusScriptV3 -> do PlutusScript _ s <- genPlutusV3Script return s genValidPlutusScript :: PlutusScriptVersion lang -> Gen (PlutusScript lang) genValidPlutusScript l = - case l of - PlutusScriptV1 -> do + case l of + PlutusScriptV1 -> do PlutusScript _ s <- genValidPlutusV1Script return s - PlutusScriptV2 -> do + PlutusScriptV2 -> do PlutusScript _ s <- genValidPlutusV2Script return s - PlutusScriptV3 -> do + PlutusScriptV3 -> do PlutusScript _ s <- genValidPlutusV3Script return s genPlutusV1Script :: Gen (Script PlutusScriptV1) -genPlutusV1Script = do +genPlutusV1Script = do v1Script <- Gen.element [v1Loop2024PlutusScriptHexDoubleEncoded,v1Loop2024PlutusScriptHex] let v1ScriptBytes = Base16.decodeLenient v1Script return . PlutusScript PlutusScriptV1 . PlutusScriptSerialised $ SBS.toShort v1ScriptBytes genValidPlutusV1Script :: Gen (Script PlutusScriptV1) -genValidPlutusV1Script = do +genValidPlutusV1Script = do v1Script <- Gen.element [v1Loop2024PlutusScriptHex] let v1ScriptBytes = Base16.decodeLenient v1Script return . PlutusScript PlutusScriptV1 . PlutusScriptSerialised $ SBS.toShort v1ScriptBytes @@ -310,14 +310,14 @@ genValidPlutusV2Script = do genPlutusV3Script :: Gen (Script PlutusScriptV3) genPlutusV3Script = do - v3AlwaysSucceedsPlutusScriptHex + v3AlwaysSucceedsPlutusScriptHex <- Gen.element [v3AlwaysSucceedsPlutusScriptDoubleEncoded, v3AlwaysSucceedsPlutusScript] let v3ScriptBytes = Base16.decodeLenient v3AlwaysSucceedsPlutusScriptHex return . PlutusScript PlutusScriptV3 . PlutusScriptSerialised $ SBS.toShort v3ScriptBytes genValidPlutusV3Script :: Gen (Script PlutusScriptV3) genValidPlutusV3Script = do - v3AlwaysSucceedsPlutusScriptHex + v3AlwaysSucceedsPlutusScriptHex <- Gen.element [v3AlwaysSucceedsPlutusScript] let v3ScriptBytes = Base16.decodeLenient v3AlwaysSucceedsPlutusScriptHex return . PlutusScript PlutusScriptV3 . PlutusScriptSerialised $ SBS.toShort v3ScriptBytes @@ -1341,18 +1341,12 @@ genProposals :: Applicative (BuildTxWith build) => ConwayEraOnwards era -> Gen (TxProposalProcedures build era) genProposals w = conwayEraOnwardsConstraints w $ do - proposals <- Gen.list (Range.constant 0 10) (genProposal w) - proposalsToBeWitnessed <- Gen.subsequence proposals - -- We're generating also some extra proposals, purposely not included in the proposals list, which results - -- in an invalid state of 'TxProposalProcedures'. - -- We're doing it for the complete representation of possible values space of TxProposalProcedures. - -- Proposal procedures code in cardano-api should handle such invalid values just fine. - extraProposals <- Gen.list (Range.constant 0 10) (genProposal w) + proposals <- Gen.list (Range.constant 0 15) (genProposal w) let sbe = convert w - proposalsWithWitnesses <- - forM (extraProposals <> proposalsToBeWitnessed) $ \proposal -> - (proposal,) <$> genScriptWitnessForStake sbe - pure $ TxProposalProcedures (fromList proposals) (pure $ fromList proposalsWithWitnesses) + proposalsWithMaybeWitnesses <- + forM proposals $ \proposal -> + (proposal,) <$> Gen.maybe (genScriptWitnessForStake sbe) + pure $ mkTxProposalProcedures proposalsWithMaybeWitnesses genProposal :: ConwayEraOnwards era -> Gen (L.ProposalProcedure (ShelleyLedgerEra era)) genProposal w = diff --git a/cardano-api/internal/Cardano/Api/Experimental/Tx.hs b/cardano-api/internal/Cardano/Api/Experimental/Tx.hs index 9f4dfe972c..4ff146856f 100644 --- a/cardano-api/internal/Cardano/Api/Experimental/Tx.hs +++ b/cardano-api/internal/Cardano/Api/Experimental/Tx.hs @@ -3,6 +3,7 @@ {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE GADTs #-} +{-# LANGUAGE LambdaCase #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeApplications #-} @@ -41,6 +42,7 @@ import Cardano.Ledger.Hashes import qualified Cardano.Ledger.Keys as L import qualified Cardano.Ledger.SafeHash as L +import Data.Maybe import qualified Data.Set as Set import GHC.Exts (IsList (..)) import GHC.Stack @@ -153,7 +155,13 @@ eraSpecificLedgerTxBody ConwayEra ledgerbody bc = in return $ ledgerbody & L.proposalProceduresTxBodyL - .~ convProposalProcedures (maybe TxProposalProceduresNone unFeatured propProcedures) + .~ fromMaybe + mempty + ( propProcedures + >>= \case + Featured _ TxProposalProceduresNone -> Nothing + Featured _ (TxProposalProcedures pp _) -> Just pp + ) & L.votingProceduresTxBodyL .~ convVotingProcedures (maybe TxVotingProceduresNone unFeatured voteProcedures) & L.treasuryDonationTxBodyL .~ maybe (L.Coin 0) unFeatured treasuryDonation diff --git a/cardano-api/internal/Cardano/Api/Fees.hs b/cardano-api/internal/Cardano/Api/Fees.hs index 59383ec32b..a0f76578b0 100644 --- a/cardano-api/internal/Cardano/Api/Fees.hs +++ b/cardano-api/internal/Cardano/Api/Fees.hs @@ -250,7 +250,14 @@ estimateBalancedTxBody proposalProcedures :: OSet.OSet (L.ProposalProcedure (ShelleyLedgerEra era)) proposalProcedures = maryEraOnwardsConstraints w $ - maybe mempty (convProposalProcedures . unFeatured) (txProposalProcedures txbodycontent1) + maybe mempty (unTxProposalProcedures . unFeatured) (txProposalProcedures txbodycontent1) + where + unTxProposalProcedures + :: TxProposalProcedures BuildTx era + -> OSet.OSet (L.ProposalProcedure (ShelleyLedgerEra era)) + unTxProposalProcedures = \case + TxProposalProceduresNone -> OSet.empty + TxProposalProcedures ps _ -> ps totalDeposits :: L.Coin totalDeposits = @@ -1542,13 +1549,14 @@ substituteExecutionUnits (Featured era (TxVotingProcedures vProcedures (BuildTxWith $ fromList substitutedExecutionUnits))) mapScriptWitnessesProposals - :: Maybe (Featured ConwayEraOnwards era (TxProposalProcedures build era)) + :: Applicative (BuildTxWith build) + => Maybe (Featured ConwayEraOnwards era (TxProposalProcedures build era)) -> Either (TxBodyErrorAutoBalance era) (Maybe (Featured ConwayEraOnwards era (TxProposalProcedures build era))) mapScriptWitnessesProposals Nothing = return Nothing mapScriptWitnessesProposals (Just (Featured _ TxProposalProceduresNone)) = return Nothing - mapScriptWitnessesProposals (Just (Featured _ (TxProposalProcedures _ ViewTx))) = return Nothing + mapScriptWitnessesProposals (Just (Featured _ (TxProposalProcedures _ ViewTx))) = return Nothing -- TODO why it's not returning the original proposal? mapScriptWitnessesProposals (Just (Featured era txpp@(TxProposalProcedures osetProposalProcedures (BuildTxWith _)))) = do let eSubstitutedExecutionUnits = [ (proposal, updatedWitness) @@ -1557,13 +1565,19 @@ substituteExecutionUnits ] substitutedExecutionUnits <- traverseScriptWitnesses eSubstitutedExecutionUnits + -- join again with osetProposalProcedures, just in case anything was left there + let allUpdatedProposals = + [ (proposal, mWitness) + | proposal <- toList osetProposalProcedures + , -- substituteExecUnits has only distinct proposals, so we can safely use lookup to find the first match + let mWitness = lookup proposal substitutedExecutionUnits + ] - return $ - Just - ( Featured - era - (TxProposalProcedures osetProposalProcedures (BuildTxWith $ fromList substitutedExecutionUnits)) - ) + pure $ + Just $ + Featured era $ + conwayEraOnwardsConstraints era $ + mkTxProposalProcedures allUpdatedProposals mapScriptWitnessesMinting :: TxMintValue BuildTx era diff --git a/cardano-api/internal/Cardano/Api/Tx/Body.hs b/cardano-api/internal/Cardano/Api/Tx/Body.hs index ed05f19315..4781f5bbc5 100644 --- a/cardano-api/internal/Cardano/Api/Tx/Body.hs +++ b/cardano-api/internal/Cardano/Api/Tx/Body.hs @@ -145,10 +145,10 @@ module Cardano.Api.Tx.Body , TxVotingProcedures (..) , mkTxVotingProcedures , indexTxVotingProcedures - , TxProposalProcedures (..) + , TxProposalProcedures (TxProposalProceduresNone) + , pattern TxProposalProcedures , mkTxProposalProcedures , indexTxProposalProcedures - , convProposalProcedures -- ** Building vs viewing transactions , BuildTxWith (..) @@ -287,6 +287,7 @@ import Ouroboros.Consensus.Shelley.Eras (StandardAllegra, StandardAlon StandardConway, StandardMary, StandardShelley) import Control.Applicative +import Control.Arrow ((&&&)) import Control.Monad import Data.Aeson (object, withObject, (.:), (.:?), (.=)) import qualified Data.Aeson as Aeson @@ -324,6 +325,7 @@ import Data.Typeable import Data.Word (Word16, Word32, Word64) import GHC.Exts (IsList (..)) import GHC.Stack +import GHC.TypeNats (type (<=)) import Lens.Micro hiding (ix) import Lens.Micro.Extras (view) import qualified Text.Parsec as Parsec @@ -1471,7 +1473,7 @@ data TxProposalProcedures build era where TxProposalProceduresNone :: TxProposalProcedures build era -- | Create Tx proposal procedures. Prefer 'mkTxProposalProcedures' smart constructor to using this constructor -- directly. - TxProposalProcedures + UnsafeTxProposalProcedures :: Ledger.EraPParams (ShelleyLedgerEra era) => OSet (L.ProposalProcedure (ShelleyLedgerEra era)) -- ^ a set of proposals @@ -1484,6 +1486,17 @@ deriving instance Eq (TxProposalProcedures build era) deriving instance Show (TxProposalProcedures build era) +{-# COMPLETE TxProposalProceduresNone, TxProposalProcedures #-} + +pattern TxProposalProcedures + :: Applicative (BuildTxWith build) + => Ledger.EraPParams (ShelleyLedgerEra era) + => OSet (L.ProposalProcedure (ShelleyLedgerEra era)) + -> BuildTxWith build (Map (L.ProposalProcedure (ShelleyLedgerEra era)) (ScriptWitness WitCtxStake era)) + -> TxProposalProcedures build era +pattern TxProposalProcedures oset wits <- + (convProposalProcedures &&& id -> (oset, UnsafeTxProposalProcedures _ wits)) + -- | A smart constructor for 'TxProposalProcedures'. It makes sure that the value produced is consistent - the -- witnessed proposals are also present in the first constructor parameter. mkTxProposalProcedures @@ -1497,7 +1510,7 @@ mkTxProposalProcedures proposalsWithWitnessesList = do bimap toList toList $ Foldable.foldl' partitionProposals mempty proposalsWithWitnessesList shelleyBasedEraConstraints (shelleyBasedEra @era) $ - TxProposalProcedures (fromList proposals) (pure $ fromList proposalsWithWitnesses) + UnsafeTxProposalProcedures (fromList proposals) (pure $ fromList proposalsWithWitnesses) where partitionProposals (ps, pws) (p, Nothing) = (DList.snoc ps p, pws) -- add a proposal to the list @@ -1509,7 +1522,7 @@ indexTxProposalProcedures :: TxProposalProcedures BuildTx era -> [(ScriptWitnessIndex, L.ProposalProcedure (ShelleyLedgerEra era), ScriptWitness WitCtxStake era)] indexTxProposalProcedures TxProposalProceduresNone = [] -indexTxProposalProcedures txpp@(TxProposalProcedures _ (BuildTxWith witnesses)) = do +indexTxProposalProcedures txpp@(UnsafeTxProposalProcedures _ (BuildTxWith witnesses)) = do let allProposalsList = toList $ convProposalProcedures txpp [ (ScriptWitnessIndexProposing $ fromIntegral ix, proposal, scriptWitness) | (proposal, scriptWitness) <- toList witnesses @@ -2227,9 +2240,8 @@ fromLedgerProposalProcedures sbe body = forShelleyBasedEraInEonMaybe sbe $ \w -> conwayEraOnwardsConstraints w $ Featured w $ - TxProposalProcedures - (body ^. L.proposalProceduresTxBodyL) - ViewTx + mkTxProposalProcedures + (fmap (,Nothing) . toList $ body ^. L.proposalProceduresTxBodyL) fromLedgerVotingProcedures :: () @@ -2825,7 +2837,7 @@ convReferenceInputs txInsReference = convProposalProcedures :: TxProposalProcedures build era -> OSet (L.ProposalProcedure (ShelleyLedgerEra era)) convProposalProcedures TxProposalProceduresNone = OSet.empty -convProposalProcedures (TxProposalProcedures pp bWits) = do +convProposalProcedures (UnsafeTxProposalProcedures pp bWits) = do let wits = fromMaybe mempty $ buildTxWithToMaybe bWits pp |>< fromList (Map.keys wits) diff --git a/cardano-api/internal/Cardano/Api/Tx/Compatible.hs b/cardano-api/internal/Cardano/Api/Tx/Compatible.hs index 4928309b99..bf1da1a65b 100644 --- a/cardano-api/internal/Cardano/Api/Tx/Compatible.hs +++ b/cardano-api/internal/Cardano/Api/Tx/Compatible.hs @@ -83,13 +83,14 @@ createCompatibleSignedTx sbe ins outs witnesses txFee' anyProtocolUpdate anyVote txb & L.updateTxBodyL .~ SJust ledgerPParamsUpdate pure (updateTxBody, []) - NoPParamsUpdate _ -> do + NoPParamsUpdate _ -> pure (mempty, []) - ProposalProcedures conwayOnwards proposalProcedures -> do - let proposals = convProposalProcedures proposalProcedures - proposalWitnesses = + ProposalProcedures _ TxProposalProceduresNone -> + pure (mempty, []) + ProposalProcedures conwayOnwards tpp@(TxProposalProcedures proposals _) -> do + let proposalWitnesses = [ (ix, AnyScriptWitness witness) - | (ix, _, witness) <- indexTxProposalProcedures proposalProcedures + | (ix, _, witness) <- indexTxProposalProcedures tpp ] referenceInputs = [ toShelleyTxIn txIn diff --git a/cardano-api/src/Cardano/Api.hs b/cardano-api/src/Cardano/Api.hs index dfae71c4ca..cc2281f75b 100644 --- a/cardano-api/src/Cardano/Api.hs +++ b/cardano-api/src/Cardano/Api.hs @@ -399,9 +399,9 @@ module Cardano.Api , indexTxMintValue , TxVotingProcedures (..) , mkTxVotingProcedures - , TxProposalProcedures (..) + , TxProposalProcedures (TxProposalProceduresNone) + , pattern TxProposalProcedures , mkTxProposalProcedures - , convProposalProcedures -- ** Building vs viewing transactions , BuildTxWith (..) diff --git a/cardano-api/test/cardano-api-test/Test/Cardano/Api/TxBody.hs b/cardano-api/test/cardano-api-test/Test/Cardano/Api/TxBody.hs index f2a2a994d6..ea2cc1d34f 100644 --- a/cardano-api/test/cardano-api-test/Test/Cardano/Api/TxBody.hs +++ b/cardano-api/test/cardano-api-test/Test/Cardano/Api/TxBody.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE GADTs #-} {-# LANGUAGE LambdaCase #-} {-# LANGUAGE OverloadedLists #-} @@ -102,10 +103,11 @@ prop_roundtrip_txbodycontent_conway_fields = H.property $ do getVotingProcedures TxVotingProceduresNone = Nothing getVotingProcedures (TxVotingProcedures vps _) = Just vps getProposalProcedures - :: TxProposalProcedures build era + :: Applicative (BuildTxWith build) + => TxProposalProcedures build era -> Maybe [L.ProposalProcedure (ShelleyLedgerEra era)] getProposalProcedures TxProposalProceduresNone = Nothing - getProposalProcedures txpp@(TxProposalProcedures _ _) = Just . toList $ convProposalProcedures txpp + getProposalProcedures (TxProposalProcedures pp _) = Just $ toList pp tests :: TestTree tests =