diff --git a/cardano-api/cardano-api.cabal b/cardano-api/cardano-api.cabal index 3b7f4d2187..4187f3e20d 100644 --- a/cardano-api/cardano-api.cabal +++ b/cardano-api/cardano-api.cabal @@ -194,7 +194,6 @@ library internal data-default-class, deepseq, directory, - dlist, either, errors, filepath, 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/Fees.hs b/cardano-api/internal/Cardano/Api/Fees.hs index 65cbbb1f34..530998fd18 100644 --- a/cardano-api/internal/Cardano/Api/Fees.hs +++ b/cardano-api/internal/Cardano/Api/Fees.hs @@ -1535,28 +1535,25 @@ substituteExecutionUnits (Featured era (TxVotingProcedures vProcedures (BuildTxWith $ fromList substitutedExecutionUnits))) mapScriptWitnessesProposals - :: Maybe (Featured ConwayEraOnwards era (TxProposalProcedures build era)) + :: Maybe (Featured ConwayEraOnwards era (TxProposalProcedures BuildTx era)) -> Either (TxBodyErrorAutoBalance era) - (Maybe (Featured ConwayEraOnwards era (TxProposalProcedures build era))) + (Maybe (Featured ConwayEraOnwards era (TxProposalProcedures BuildTx era))) mapScriptWitnessesProposals Nothing = return Nothing - mapScriptWitnessesProposals (Just (Featured _ TxProposalProceduresNone)) = return Nothing - mapScriptWitnessesProposals (Just (Featured _ (TxProposalProcedures _ ViewTx))) = return Nothing - mapScriptWitnessesProposals (Just (Featured era txpp@(TxProposalProcedures osetProposalProcedures (BuildTxWith _)))) = do + mapScriptWitnessesProposals (Just (Featured era txpp)) = do let eSubstitutedExecutionUnits = [ (proposal, updatedWitness) | (ix, proposal, scriptWitness) <- indexTxProposalProcedures txpp , let updatedWitness = substituteExecUnits ix scriptWitness ] - substitutedExecutionUnits <- traverseScriptWitnesses eSubstitutedExecutionUnits - return $ - Just - ( Featured - era - (TxProposalProcedures osetProposalProcedures (BuildTxWith $ fromList substitutedExecutionUnits)) - ) + pure $ + Just $ + Featured era $ + conwayEraOnwardsConstraints era $ + mkTxProposalProcedures $ + second Just <$> substitutedExecutionUnits 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 633e2539f3..a62c5dbd2f 100644 --- a/cardano-api/internal/Cardano/Api/Tx/Body.hs +++ b/cardano-api/internal/Cardano/Api/Tx/Body.hs @@ -296,9 +296,7 @@ import Data.Bifunctor (Bifunctor (..)) import Data.ByteString (ByteString) import qualified Data.ByteString.Base16 as Base16 import qualified Data.ByteString.Char8 as BSC -import qualified Data.DList as DList import Data.Foldable (for_) -import qualified Data.Foldable as Foldable import Data.Function (on) import Data.Functor (($>)) import Data.List (sortBy) @@ -309,7 +307,7 @@ import Data.Map.Strict (Map) import qualified Data.Map.Strict as Map import Data.Maybe import Data.Monoid -import Data.OSet.Strict (OSet, (|><)) +import Data.OSet.Strict (OSet) import qualified Data.OSet.Strict as OSet import Data.Scientific (toBoundedInteger) import qualified Data.Sequence.Strict as Seq @@ -1466,18 +1464,19 @@ indexTxVotingProcedures (TxVotingProcedures vProcedures (BuildTxWith sWitMap)) = -- ---------------------------------------------------------------------------- -- Proposals within transactions (era-dependent) -- - +-- A proposal procedure houses a governance action that is required to be voted into acceptance when submitted. data TxProposalProcedures build era where + -- | No proposals in transaction.. TxProposalProceduresNone :: TxProposalProcedures build era - -- | Create Tx proposal procedures. Prefer 'mkTxProposalProcedures' smart constructor to using this constructor - -- directly. + -- | Represents proposal procedures present in transaction. TxProposalProcedures :: Ledger.EraPParams (ShelleyLedgerEra era) - => OSet (L.ProposalProcedure (ShelleyLedgerEra era)) - -- ^ a set of proposals - -> BuildTxWith build (Map (L.ProposalProcedure (ShelleyLedgerEra era)) (ScriptWitness WitCtxStake era)) - -- ^ a map of witnesses for the proposals. If the proposals are not added to the first constructor - -- parameter too, the sky will fall on your head. + => OMap + (L.ProposalProcedure (ShelleyLedgerEra era)) + ( BuildTxWith + build + (Maybe (ScriptWitness WitCtxStake era)) + ) -> TxProposalProcedures build era deriving instance Eq (TxProposalProcedures build era) @@ -1492,27 +1491,21 @@ mkTxProposalProcedures => IsShelleyBasedEra era => [(L.ProposalProcedure (ShelleyLedgerEra era), Maybe (ScriptWitness WitCtxStake era))] -> TxProposalProcedures build era -mkTxProposalProcedures proposalsWithWitnessesList = do - let (proposals, proposalsWithWitnesses) = - bimap toList toList $ - Foldable.foldl' partitionProposals mempty proposalsWithWitnessesList +mkTxProposalProcedures proposals = do shelleyBasedEraConstraints (shelleyBasedEra @era) $ - TxProposalProcedures (fromList proposals) (pure $ fromList proposalsWithWitnesses) - where - partitionProposals (ps, pws) (p, Nothing) = - (DList.snoc ps p, pws) -- add a proposal to the list - partitionProposals (ps, pws) (p, Just w) = - (DList.snoc ps p, DList.snoc pws (p, w)) -- add a proposal both to the list and to the witnessed list + TxProposalProcedures $ + fromList $ + map (second pure) proposals -- | Index proposal procedures by their order ('Ord'). indexTxProposalProcedures :: TxProposalProcedures BuildTx era -> [(ScriptWitnessIndex, L.ProposalProcedure (ShelleyLedgerEra era), ScriptWitness WitCtxStake era)] indexTxProposalProcedures TxProposalProceduresNone = [] -indexTxProposalProcedures txpp@(TxProposalProcedures _ (BuildTxWith witnesses)) = do - let allProposalsList = toList $ convProposalProcedures txpp +indexTxProposalProcedures (TxProposalProcedures proposals) = do + let allProposalsList = fst <$> toList proposals [ (ScriptWitnessIndexProposing $ fromIntegral ix, proposal, scriptWitness) - | (proposal, scriptWitness) <- toList witnesses + | (proposal, BuildTxWith (Just scriptWitness)) <- toList proposals , ix <- maybeToList $ List.elemIndex proposal allProposalsList ] @@ -2228,9 +2221,8 @@ fromLedgerProposalProcedures sbe body = forShelleyBasedEraInEonMaybe sbe $ \w -> conwayEraOnwardsConstraints w $ Featured w $ - TxProposalProcedures - (body ^. L.proposalProceduresTxBodyL) - ViewTx + mkTxProposalProcedures + (fmap (,Nothing) . toList $ body ^. L.proposalProceduresTxBodyL) fromLedgerVotingProcedures :: () @@ -2821,15 +2813,10 @@ convReferenceInputs txInsReference = TxInsReference _ refTxins -> fromList $ map toShelleyTxIn refTxins -- | Returns an OSet of proposals from 'TxProposalProcedures'. --- --- If 'pws' in 'TxProposalProcedures pps (BuildTxWith pws)' contained proposals not present in 'pps', the'll --- be sorted ascendingly and snoc-ed to 'pps' if they're not present in 'pps'. convProposalProcedures :: TxProposalProcedures build era -> OSet (L.ProposalProcedure (ShelleyLedgerEra era)) convProposalProcedures TxProposalProceduresNone = OSet.empty -convProposalProcedures (TxProposalProcedures pp bWits) = do - let wits = fromMaybe mempty $ buildTxWithToMaybe bWits - pp |>< fromList (Map.keys wits) +convProposalProcedures (TxProposalProcedures proposals) = fromList $ fst <$> toList proposals convVotingProcedures :: TxVotingProcedures build era -> L.VotingProcedures (ShelleyLedgerEra era) convVotingProcedures txVotingProcedures = diff --git a/cardano-api/internal/Cardano/Api/Tx/Compatible.hs b/cardano-api/internal/Cardano/Api/Tx/Compatible.hs index 89d3d85789..d2390f3136 100644 --- a/cardano-api/internal/Cardano/Api/Tx/Compatible.hs +++ b/cardano-api/internal/Cardano/Api/Tx/Compatible.hs @@ -84,7 +84,7 @@ 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 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..9f61c8ffee 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 #-} @@ -105,7 +106,7 @@ prop_roundtrip_txbodycontent_conway_fields = H.property $ do :: TxProposalProcedures build era -> Maybe [L.ProposalProcedure (ShelleyLedgerEra era)] getProposalProcedures TxProposalProceduresNone = Nothing - getProposalProcedures txpp@(TxProposalProcedures _ _) = Just . toList $ convProposalProcedures txpp + getProposalProcedures (TxProposalProcedures pp) = Just $ fst <$> toList pp tests :: TestTree tests =