From 0675afb485fc19a60afae9ad55b69392e04f87af Mon Sep 17 00:00:00 2001 From: John Ky Date: Wed, 20 Dec 2023 00:55:12 +1100 Subject: [PATCH] Make it impossible to get or set the invalid here after value in eras up to Alonzo --- cardano-api/gen/Test/Gen/Cardano/Api/Typed.hs | 8 ++-- .../internal/Cardano/Api/Ledger/Lens.hs | 42 +----------------- cardano-api/internal/Cardano/Api/TxBody.hs | 43 ++++++++----------- cardano-api/src/Cardano/Api.hs | 1 - 4 files changed, 25 insertions(+), 69 deletions(-) diff --git a/cardano-api/gen/Test/Gen/Cardano/Api/Typed.hs b/cardano-api/gen/Test/Gen/Cardano/Api/Typed.hs index 571665b8b2..8aa512467b 100644 --- a/cardano-api/gen/Test/Gen/Cardano/Api/Typed.hs +++ b/cardano-api/gen/Test/Gen/Cardano/Api/Typed.hs @@ -544,9 +544,9 @@ genTxValidityLowerBound = (\w -> TxValidityLowerBound w <$> genTtl) -- TODO: Accept a range for generating ttl. -genTxValidityUpperBound :: ShelleyBasedEra era -> Gen (TxValidityUpperBound era) -genTxValidityUpperBound sbe = - TxValidityUpperBound sbe <$> Gen.maybe genTtl +genTxValidityUpperBound :: BabbageEraOnwards era -> Gen (TxValidityUpperBound era) +genTxValidityUpperBound w = + TxValidityUpperBound w <$> genTtl genTxMetadataInEra :: CardanoEra era -> Gen (TxMetadataInEra era) genTxMetadataInEra = @@ -640,7 +640,7 @@ genTxBodyContent sbe = do txReturnCollateral <- genTxReturnCollateral sbe txFee <- genTxFee sbe txValidityLowerBound <- genTxValidityLowerBound era - txValidityUpperBound <- genTxValidityUpperBound sbe + txValidityUpperBound <- forShelleyBasedEraInEon sbe (pure TxValidityNoUpperBound) genTxValidityUpperBound txMetadata <- genTxMetadataInEra era txAuxScripts <- genTxAuxScripts sbe let txExtraKeyWits = TxExtraKeyWitnessesNone --TODO: Alonzo era: Generate witness key hashes diff --git a/cardano-api/internal/Cardano/Api/Ledger/Lens.hs b/cardano-api/internal/Cardano/Api/Ledger/Lens.hs index 9ec99e1538..b64bb688b4 100644 --- a/cardano-api/internal/Cardano/Api/Ledger/Lens.hs +++ b/cardano-api/internal/Cardano/Api/Ledger/Lens.hs @@ -15,11 +15,8 @@ module Cardano.Api.Ledger.Lens , strictMaybeL , L.invalidBeforeL , L.invalidHereAfterL - , invalidBeforeStrictL - , invalidHereAfterStrictL , invalidBeforeTxBodyL , invalidHereAfterTxBodyL - , ttlAsInvalidHereAfterTxBodyL , updateTxBodyL , txBodyL @@ -98,43 +95,8 @@ invalidBeforeTxBodyL w = babbageEraOnwardsConstraints w $ txBodyL . L.vldtTxBody -- -- 'invalidHereAfterTxBodyL' lens over both with a 'Maybe SlotNo' type representation. Withing the -- Shelley era, setting Nothing will set the ttl to 'maxBound' in the underlying ledger type. -invalidHereAfterTxBodyL :: ShelleyBasedEra era -> Lens' (TxBody era) (Maybe SlotNo) -invalidHereAfterTxBodyL sbe = - forShelleyBasedEraInEon sbe - ttlAsInvalidHereAfterTxBodyL - (\w -> babbageEraOnwardsConstraints w $ txBodyL . L.vldtTxBodyL . L.invalidHereAfterL) - --- | Compatibility lens over 'ttlTxBodyL' which represents 'maxBound' as Nothing and all other values as 'Just'. -ttlAsInvalidHereAfterTxBodyL :: Lens' (TxBody era) (Maybe SlotNo) -ttlAsInvalidHereAfterTxBodyL = lens g s - where - g :: TxBody era -> Maybe SlotNo - g _ = Nothing - - s :: TxBody era -> Maybe SlotNo -> TxBody era - s txBody _ = txBody -- Refuse to set the ttl as we don't support it anymore - --- | Lens to access the 'invalidBefore' field of a 'ValidityInterval' as a 'StrictMaybe SlotNo'. --- Ideally this should be defined in cardano-ledger -invalidBeforeStrictL :: Lens' L.ValidityInterval (StrictMaybe SlotNo) -invalidBeforeStrictL = lens g s - where - g :: L.ValidityInterval -> StrictMaybe SlotNo - g (L.ValidityInterval a _) = a - - s :: L.ValidityInterval -> StrictMaybe SlotNo -> L.ValidityInterval - s (L.ValidityInterval _ b) a = L.ValidityInterval a b - --- | Lens to access the 'invalidHereAfter' field of a 'ValidityInterval' as a 'StrictMaybe SlotNo'. --- Ideally this should be defined in cardano-ledger -invalidHereAfterStrictL :: Lens' L.ValidityInterval (StrictMaybe SlotNo) -invalidHereAfterStrictL = lens g s - where - g :: L.ValidityInterval -> StrictMaybe SlotNo - g (L.ValidityInterval _ b) = b - - s :: L.ValidityInterval -> StrictMaybe SlotNo -> L.ValidityInterval - s (L.ValidityInterval a _) b = L.ValidityInterval a b +invalidHereAfterTxBodyL :: BabbageEraOnwards era -> Lens' (TxBody era) (Maybe SlotNo) +invalidHereAfterTxBodyL w = babbageEraOnwardsConstraints w $ txBodyL . L.vldtTxBodyL . L.invalidHereAfterL updateTxBodyL :: ShelleyToBabbageEra era -> Lens' (TxBody era) (StrictMaybe (L.Update (ShelleyLedgerEra era))) updateTxBodyL w = shelleyToBabbageEraConstraints w $ txBodyL . L.updateTxBodyL diff --git a/cardano-api/internal/Cardano/Api/TxBody.hs b/cardano-api/internal/Cardano/Api/TxBody.hs index f2c185a7dd..097b7d4e16 100644 --- a/cardano-api/internal/Cardano/Api/TxBody.hs +++ b/cardano-api/internal/Cardano/Api/TxBody.hs @@ -38,7 +38,6 @@ module Cardano.Api.TxBody ( -- ** Transaction body builders defaultTxBodyContent, defaultTxFee, - defaultTxValidityUpperBound, setTxIns, modTxIns, addTxIn, @@ -1067,19 +1066,17 @@ defaultTxFee w = TxFeeExplicit w mempty -- | This was formerly known as the TTL. -- data TxValidityUpperBound era where + TxValidityNoUpperBound + :: TxValidityUpperBound era + TxValidityUpperBound - :: ShelleyBasedEra era - -> Maybe SlotNo + :: BabbageEraOnwards era + -> SlotNo -> TxValidityUpperBound era deriving instance Eq (TxValidityUpperBound era) deriving instance Show (TxValidityUpperBound era) -defaultTxValidityUpperBound :: () - => ShelleyBasedEra era - -> TxValidityUpperBound era -defaultTxValidityUpperBound sbe = TxValidityUpperBound sbe Nothing - data TxValidityLowerBound era where TxValidityNoLowerBound @@ -1248,7 +1245,7 @@ defaultTxBodyContent era = TxBodyContent , txReturnCollateral = TxReturnCollateralNone , txFee = defaultTxFee era , txValidityLowerBound = TxValidityNoLowerBound - , txValidityUpperBound = defaultTxValidityUpperBound era + , txValidityUpperBound = TxValidityNoUpperBound , txMetadata = TxMetadataNone , txAuxScripts = TxAuxScriptsNone , txExtraKeyWits = TxExtraKeyWitnessesNone @@ -1821,10 +1818,12 @@ createTransactionBody sbe bc = setTotalCollateral <- monoidForEraInEonA era $ \w -> pure $ Endo $ A.totalCollateralTxBodyL w .~ totalCollateral + setInvalidHereAfter <- monoidForEraInEonA era $ \w -> + pure $ Endo $ A.invalidHereAfterTxBodyL w .~ convValidityUpperBound sbe (txValidityUpperBound bc) + let ledgerTxBody = mkCommonTxBody sbe (txIns bc) (txOuts bc) (txFee bc) (txWithdrawals bc) txAuxData & A.certsTxBodyL sbe .~ certs - & A.invalidHereAfterTxBodyL sbe .~ convValidityUpperBound sbe (txValidityUpperBound bc) & appEndo ( mconcat [ setUpdateProposal @@ -1836,6 +1835,7 @@ createTransactionBody sbe bc = , setReferenceInputs , setCollateralReturn , setTotalCollateral + , setInvalidHereAfter ] ) @@ -2240,8 +2240,7 @@ fromLedgerTxValidityLowerBound -> TxValidityLowerBound era fromLedgerTxValidityLowerBound sbe body = forShelleyBasedEraInEon sbe TxValidityNoLowerBound $ \w -> - let mInvalidBefore = body ^. A.invalidBeforeTxBodyL w in - case mInvalidBefore of + case body ^. A.invalidBeforeTxBodyL w of Nothing -> TxValidityNoLowerBound Just s -> TxValidityLowerBound w s @@ -2250,7 +2249,10 @@ fromLedgerTxValidityUpperBound -> A.TxBody era -> TxValidityUpperBound era fromLedgerTxValidityUpperBound sbe body = - TxValidityUpperBound sbe $ body ^. A.invalidHereAfterTxBodyL sbe + forShelleyBasedEraInEon sbe TxValidityNoUpperBound $ \w -> + case body ^. A.invalidHereAfterTxBodyL w of + Nothing -> TxValidityNoUpperBound + Just s -> TxValidityUpperBound w s fromLedgerAuxiliaryData :: ShelleyBasedEra era @@ -2470,7 +2472,8 @@ convValidityUpperBound :: () -> TxValidityUpperBound era -> Maybe SlotNo convValidityUpperBound _ = \case - TxValidityUpperBound _ ms -> ms + TxValidityNoUpperBound -> Nothing + TxValidityUpperBound _ s -> Just s -- | Convert transaction update proposal into ledger update proposal convTxUpdateProposal :: () @@ -2606,7 +2609,6 @@ makeShelleyTransactionBody sbe@ShelleyBasedEraShelley txIns, txOuts, txFee, - txValidityUpperBound, txMetadata, txWithdrawals, txCertificates, @@ -2619,7 +2621,6 @@ makeShelleyTransactionBody sbe@ShelleyBasedEraShelley ( mkCommonTxBody sbe txIns txOuts txFee txWithdrawals txAuxData & A.certsTxBodyL sbe .~ convCertificates sbe txCertificates & A.updateTxBodyL s2b .~ update - & A.invalidHereAfterTxBodyL sbe .~ convValidityUpperBound sbe txValidityUpperBound ) ^. A.txBodyL return $ ShelleyTxBody sbe @@ -2644,7 +2645,6 @@ makeShelleyTransactionBody sbe@ShelleyBasedEraAllegra txIns, txOuts, txFee, - txValidityUpperBound, txMetadata, txAuxScripts, txWithdrawals, @@ -2657,7 +2657,6 @@ makeShelleyTransactionBody sbe@ShelleyBasedEraAllegra let txbody = (mkCommonTxBody sbe txIns txOuts txFee txWithdrawals txAuxData & A.certsTxBodyL sbe .~ convCertificates sbe txCertificates - & A.invalidHereAfterTxBodyL sbe .~ convValidityUpperBound sbe txValidityUpperBound & A.updateTxBodyL s2b .~ update ) ^. A.txBodyL return $ @@ -2683,7 +2682,6 @@ makeShelleyTransactionBody sbe@ShelleyBasedEraMary txIns, txOuts, txFee, - txValidityUpperBound, txMetadata, txAuxScripts, txWithdrawals, @@ -2698,7 +2696,6 @@ makeShelleyTransactionBody sbe@ShelleyBasedEraMary let txbody = (mkCommonTxBody sbe txIns txOuts txFee txWithdrawals txAuxData & A.certsTxBodyL sbe .~ convCertificates sbe txCertificates - & A.invalidHereAfterTxBodyL sbe .~ convValidityUpperBound sbe txValidityUpperBound & A.updateTxBodyL s2b .~ update & A.mintTxBodyL mOn .~ convMintValue txMintValue ) ^. A.txBodyL @@ -2726,7 +2723,6 @@ makeShelleyTransactionBody sbe@ShelleyBasedEraAlonzo txInsCollateral, txOuts, txFee, - txValidityUpperBound, txMetadata, txAuxScripts, txExtraKeyWits, @@ -2748,7 +2744,6 @@ makeShelleyTransactionBody sbe@ShelleyBasedEraAlonzo (mkCommonTxBody sbe txIns txOuts txFee txWithdrawals txAuxData & A.collateralInputsTxBodyL azOn .~ convCollateralTxIns txInsCollateral & A.certsTxBodyL sbe .~ convCertificates sbe txCertificates - & A.invalidHereAfterTxBodyL sbe .~ convValidityUpperBound sbe txValidityUpperBound & A.updateTxBodyL s2b .~ update & A.reqSignerHashesTxBodyL azOn .~ convExtraKeyWitnesses txExtraKeyWits & A.mintTxBodyL mOn .~ convMintValue txMintValue @@ -2848,7 +2843,7 @@ makeShelleyTransactionBody sbe@ShelleyBasedEraBabbage & A.totalCollateralTxBodyL bOn .~ convTotalCollateral txTotalCollateral & A.certsTxBodyL sbe .~ convCertificates sbe txCertificates & A.invalidBeforeTxBodyL bOn .~ convValidityLowerBound txValidityLowerBound - & A.invalidHereAfterTxBodyL sbe .~ convValidityUpperBound sbe txValidityUpperBound + & A.invalidHereAfterTxBodyL bOn .~ convValidityUpperBound sbe txValidityUpperBound & A.updateTxBodyL s2b .~ update & A.reqSignerHashesTxBodyL azOn .~ convExtraKeyWitnesses txExtraKeyWits & A.mintTxBodyL mOn .~ convMintValue txMintValue @@ -2957,7 +2952,7 @@ makeShelleyTransactionBody sbe@ShelleyBasedEraConway & A.totalCollateralTxBodyL bOn .~ convTotalCollateral txTotalCollateral & A.certsTxBodyL sbe .~ convCertificates sbe txCertificates & A.invalidBeforeTxBodyL bOn .~ convValidityLowerBound txValidityLowerBound - & A.invalidHereAfterTxBodyL sbe .~ convValidityUpperBound sbe txValidityUpperBound + & A.invalidHereAfterTxBodyL bOn .~ convValidityUpperBound sbe txValidityUpperBound & A.reqSignerHashesTxBodyL azOn .~ convExtraKeyWitnesses txExtraKeyWits & A.mintTxBodyL mOn .~ convMintValue txMintValue & A.scriptIntegrityHashTxBodyL azOn .~ scriptIntegrityHash diff --git a/cardano-api/src/Cardano/Api.hs b/cardano-api/src/Cardano/Api.hs index 6ef8c034d3..db47d7bdee 100644 --- a/cardano-api/src/Cardano/Api.hs +++ b/cardano-api/src/Cardano/Api.hs @@ -297,7 +297,6 @@ module Cardano.Api ( -- ** Transaction body builders defaultTxBodyContent, defaultTxFee, - defaultTxValidityUpperBound, setTxIns, modTxIns, addTxIn,