diff --git a/cardano-api/internal/Cardano/Api/Eon/AlonzoEraOnwards.hs b/cardano-api/internal/Cardano/Api/Eon/AlonzoEraOnwards.hs index 43e3ca61ab..faee076dca 100644 --- a/cardano-api/internal/Cardano/Api/Eon/AlonzoEraOnwards.hs +++ b/cardano-api/internal/Cardano/Api/Eon/AlonzoEraOnwards.hs @@ -79,6 +79,7 @@ type AlonzoEraOnwardsConstraints era = , L.AlonzoEraTx (ShelleyLedgerEra era) , L.AlonzoEraTxBody (ShelleyLedgerEra era) , L.AlonzoEraTxOut (ShelleyLedgerEra era) + , L.AlonzoEraTxOut (ShelleyLedgerEra era) , L.AlonzoEraTxWits (ShelleyLedgerEra era) , L.Crypto (L.EraCrypto (ShelleyLedgerEra era)) , L.Era (ShelleyLedgerEra era) @@ -90,6 +91,7 @@ type AlonzoEraOnwardsConstraints era = , L.EraUTxO (ShelleyLedgerEra era) , L.ExtendedUTxO (ShelleyLedgerEra era) , L.HashAnnotated (L.TxBody (ShelleyLedgerEra era)) L.EraIndependentTxBody L.StandardCrypto + , L.MaryEraTxBody (ShelleyLedgerEra era) , L.Script (ShelleyLedgerEra era) ~ L.AlonzoScript (ShelleyLedgerEra era) , L.ScriptsNeeded (ShelleyLedgerEra era) ~ L.AlonzoScriptsNeeded (ShelleyLedgerEra era) , L.ShelleyEraTxBody (ShelleyLedgerEra era) diff --git a/cardano-api/internal/Cardano/Api/Eon/BabbageEraOnly.hs b/cardano-api/internal/Cardano/Api/Eon/BabbageEraOnly.hs index e9acf19c6c..cc73715877 100644 --- a/cardano-api/internal/Cardano/Api/Eon/BabbageEraOnly.hs +++ b/cardano-api/internal/Cardano/Api/Eon/BabbageEraOnly.hs @@ -1,10 +1,12 @@ {-# LANGUAGE ConstraintKinds #-} +{-# LANGUAGE DataKinds #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE GADTs #-} {-# LANGUAGE LambdaCase #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE StandaloneDeriving #-} {-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeOperators #-} module Cardano.Api.Eon.BabbageEraOnly ( BabbageEraOnly(..) @@ -14,8 +16,30 @@ module Cardano.Api.Eon.BabbageEraOnly , BabbageEraOnlyConstraints ) where +import Cardano.Api.Eon.ShelleyBasedEra import Cardano.Api.Eras.Core +import Cardano.Api.Modes +import Cardano.Api.Query.Types +import Cardano.Binary +import qualified Cardano.Crypto.Hash.Blake2b as Blake2b +import qualified Cardano.Crypto.Hash.Class as C +import qualified Cardano.Crypto.VRF as C +import qualified Cardano.Ledger.Alonzo.Language as L +import qualified Cardano.Ledger.Alonzo.Scripts as L +import qualified Cardano.Ledger.Alonzo.TxInfo as L +import qualified Cardano.Ledger.Alonzo.UTxO as L +import qualified Cardano.Ledger.Api as L +import qualified Cardano.Ledger.BaseTypes as L +import qualified Cardano.Ledger.Core as L +import qualified Cardano.Ledger.Mary.Value as L +import qualified Cardano.Ledger.SafeHash as L +import qualified Cardano.Ledger.UTxO as L +import qualified Ouroboros.Consensus.Protocol.Abstract as Consensus +import qualified Ouroboros.Consensus.Protocol.Praos.Common as Consensus +import qualified Ouroboros.Consensus.Shelley.Ledger as Consensus + +import Data.Aeson import Data.Typeable (Typeable) data BabbageEraOnly era where @@ -39,7 +63,38 @@ instance ToCardanoEra BabbageEraOnly where BabbageEraOnlyBabbage -> BabbageEra type BabbageEraOnlyConstraints era = - ( IsCardanoEra era + ( L.AlonzoEraTxOut (ShelleyLedgerEra era) + , C.HashAlgorithm (L.HASH (L.EraCrypto (ShelleyLedgerEra era))) + , C.Signable (L.VRF (L.EraCrypto (ShelleyLedgerEra era))) L.Seed + , Consensus.PraosProtocolSupportsNode (ConsensusProtocol era) + , Consensus.ShelleyCompatible (ConsensusProtocol era) (ShelleyLedgerEra era) + , L.ADDRHASH (Consensus.PraosProtocolSupportsNodeCrypto (ConsensusProtocol era)) ~ Blake2b.Blake2b_224 + , L.AlonzoEraTxOut (ShelleyLedgerEra era) + , L.BabbageEraPParams (ShelleyLedgerEra era) + , L.BabbageEraTxBody (ShelleyLedgerEra era) + , L.BabbageEraTxOut (ShelleyLedgerEra era) + , L.Crypto (L.EraCrypto (ShelleyLedgerEra era)) + , L.Era (ShelleyLedgerEra era) + , L.EraCrypto (ShelleyLedgerEra era) ~ L.StandardCrypto + , L.EraPlutusContext 'L.PlutusV1 (ShelleyLedgerEra era) + , L.EraPParams (ShelleyLedgerEra era) + , L.EraTx (ShelleyLedgerEra era) + , L.EraTxBody (ShelleyLedgerEra era) + , L.EraUTxO (ShelleyLedgerEra era) + , L.ExtendedUTxO (ShelleyLedgerEra era) + , L.HashAnnotated (L.TxBody (ShelleyLedgerEra era)) L.EraIndependentTxBody L.StandardCrypto + , L.MaryEraTxBody (ShelleyLedgerEra era) + , L.Script (ShelleyLedgerEra era) ~ L.AlonzoScript (ShelleyLedgerEra era) + , L.ScriptsNeeded (ShelleyLedgerEra era) ~ L.AlonzoScriptsNeeded (ShelleyLedgerEra era) + , L.ShelleyEraTxBody (ShelleyLedgerEra era) + , L.ShelleyEraTxCert (ShelleyLedgerEra era) + , L.Value (ShelleyLedgerEra era) ~ L.MaryValue L.StandardCrypto + + , FromCBOR (Consensus.ChainDepState (ConsensusProtocol era)) + , FromCBOR (DebugLedgerState era) + , IsCardanoEra era + , IsShelleyBasedEra era + , ToJSON (DebugLedgerState era) , Typeable era ) diff --git a/cardano-api/internal/Cardano/Api/Eon/BabbageEraOnwards.hs b/cardano-api/internal/Cardano/Api/Eon/BabbageEraOnwards.hs index 6bc8aa9062..06695f3778 100644 --- a/cardano-api/internal/Cardano/Api/Eon/BabbageEraOnwards.hs +++ b/cardano-api/internal/Cardano/Api/Eon/BabbageEraOnwards.hs @@ -71,6 +71,7 @@ type BabbageEraOnwardsConstraints era = , Consensus.PraosProtocolSupportsNode (ConsensusProtocol era) , Consensus.ShelleyCompatible (ConsensusProtocol era) (ShelleyLedgerEra era) , L.ADDRHASH (Consensus.PraosProtocolSupportsNodeCrypto (ConsensusProtocol era)) ~ Blake2b.Blake2b_224 + , L.AlonzoEraTxOut (ShelleyLedgerEra era) , L.BabbageEraPParams (ShelleyLedgerEra era) , L.BabbageEraTxBody (ShelleyLedgerEra era) , L.BabbageEraTxOut (ShelleyLedgerEra era) @@ -84,6 +85,7 @@ type BabbageEraOnwardsConstraints era = , L.EraUTxO (ShelleyLedgerEra era) , L.ExtendedUTxO (ShelleyLedgerEra era) , L.HashAnnotated (L.TxBody (ShelleyLedgerEra era)) L.EraIndependentTxBody L.StandardCrypto + , L.MaryEraTxBody (ShelleyLedgerEra era) , L.Script (ShelleyLedgerEra era) ~ L.AlonzoScript (ShelleyLedgerEra era) , L.ScriptsNeeded (ShelleyLedgerEra era) ~ L.AlonzoScriptsNeeded (ShelleyLedgerEra era) , L.ShelleyEraTxBody (ShelleyLedgerEra era) diff --git a/cardano-api/internal/Cardano/Api/Eon/ConwayEraOnwards.hs b/cardano-api/internal/Cardano/Api/Eon/ConwayEraOnwards.hs index 5d97ea0247..d10a88420b 100644 --- a/cardano-api/internal/Cardano/Api/Eon/ConwayEraOnwards.hs +++ b/cardano-api/internal/Cardano/Api/Eon/ConwayEraOnwards.hs @@ -72,6 +72,7 @@ type ConwayEraOnwardsConstraints era = , Consensus.PraosProtocolSupportsNode (ConsensusProtocol era) , Consensus.ShelleyCompatible (ConsensusProtocol era) (ShelleyLedgerEra era) , L.ADDRHASH (Consensus.PraosProtocolSupportsNodeCrypto (ConsensusProtocol era)) ~ Blake2b.Blake2b_224 + , L.AlonzoEraTxOut (ShelleyLedgerEra era) , L.BabbageEraTxBody (ShelleyLedgerEra era) , L.ConwayEraGov (ShelleyLedgerEra era) , L.ConwayEraPParams (ShelleyLedgerEra era) @@ -88,6 +89,7 @@ type ConwayEraOnwardsConstraints era = , L.EraUTxO (ShelleyLedgerEra era) , L.ExtendedUTxO (ShelleyLedgerEra era) , L.HashAnnotated (L.TxBody (ShelleyLedgerEra era)) L.EraIndependentTxBody L.StandardCrypto + , L.MaryEraTxBody (ShelleyLedgerEra era) , L.Script (ShelleyLedgerEra era) ~ L.AlonzoScript (ShelleyLedgerEra era) , L.ScriptsNeeded (ShelleyLedgerEra era) ~ L.AlonzoScriptsNeeded (ShelleyLedgerEra era) , L.ShelleyEraTxBody (ShelleyLedgerEra era) diff --git a/cardano-api/internal/Cardano/Api/Ledger/Lens.hs b/cardano-api/internal/Cardano/Api/Ledger/Lens.hs index 7aa58f28cb..707cc4a17c 100644 --- a/cardano-api/internal/Cardano/Api/Ledger/Lens.hs +++ b/cardano-api/internal/Cardano/Api/Ledger/Lens.hs @@ -11,16 +11,19 @@ module Cardano.Api.Ledger.Lens , invalidBeforeTxBodyL , invalidHereAfterTxBodyL , ttlAsInvalidHereAfterTxBodyL + , apiUpdateTxBodyL ) where import Cardano.Api.Eon.AllegraEraOnwards import Cardano.Api.Eon.ShelleyBasedEra import Cardano.Api.Eon.ShelleyEraOnly +import Cardano.Api.Eon.ShelleyToBabbageEra import Cardano.Api.Eras.Case import qualified Cardano.Ledger.Allegra.Core as L import qualified Cardano.Ledger.Api as L import Cardano.Ledger.BaseTypes (SlotNo, StrictMaybe (..)) +import qualified Cardano.Ledger.Shelley.PParams as L import Lens.Micro @@ -95,3 +98,6 @@ invalidHereAfterStrictL = lens g s s :: L.ValidityInterval -> StrictMaybe SlotNo -> L.ValidityInterval s (L.ValidityInterval a _) b = L.ValidityInterval a b + +apiUpdateTxBodyL :: ShelleyToBabbageEra era -> Lens' (L.TxBody (ShelleyLedgerEra era)) (StrictMaybe (L.Update (ShelleyLedgerEra era))) +apiUpdateTxBodyL w = shelleyToBabbageEraConstraints w L.updateTxBodyL diff --git a/cardano-api/internal/Cardano/Api/TxBody.hs b/cardano-api/internal/Cardano/Api/TxBody.hs index 5a47ab872f..5763e4a197 100644 --- a/cardano-api/internal/Cardano/Api/TxBody.hs +++ b/cardano-api/internal/Cardano/Api/TxBody.hs @@ -19,6 +19,7 @@ {- HLINT ignore "Avoid lambda using `infix`" -} {- HLINT ignore "Redundant flip" -} +{- HLINT ignore "Use let" -} {- HLINT ignore "Use section" -} -- | Transaction bodies @@ -169,7 +170,7 @@ import Cardano.Api.Hash import Cardano.Api.HasTypeProxy import Cardano.Api.Keys.Byron import Cardano.Api.Keys.Shelley -import qualified Cardano.Api.Ledger.Lens as L +import qualified Cardano.Api.Ledger.Lens as A import Cardano.Api.NetworkId import Cardano.Api.ProtocolParameters import qualified Cardano.Api.ReexposeLedger as Ledger @@ -1799,184 +1800,116 @@ instance Error TxBodyError where displayError (TxBodyProtocolParamsConversionError ppces) = "Errors in protocol parameters conversion: " ++ displayError ppces -createTransactionBody - :: ShelleyBasedEra era +createTransactionBody :: () + => ShelleyBasedEra era -> TxBodyContent BuildTx era -> Either TxBodyError (TxBody era) -createTransactionBody sbe txBodyContent = - let apiTxOuts = txOuts txBodyContent - apiScriptWitnesses = collectTxBodyScriptWitnesses sbe txBodyContent - apiScriptValidity = txScriptValidity txBodyContent - apiMintValue = txMintValue txBodyContent - apiProtocolParameters = txProtocolParams txBodyContent - apiCollateralTxIns = txInsCollateral txBodyContent - apiReferenceInputs = txInsReference txBodyContent - apiExtraKeyWitnesses = txExtraKeyWits txBodyContent - apiReturnCollateral = txReturnCollateral txBodyContent - apiTotalCollateral = txTotalCollateral txBodyContent - - -- Ledger types - collTxIns = convCollateralTxIns apiCollateralTxIns - refTxIns = convReferenceInputs apiReferenceInputs - returnCollateral = convReturnCollateral sbe apiReturnCollateral - totalCollateral = convTotalCollateral apiTotalCollateral - certs = convCertificates sbe $ txCertificates txBodyContent - txAuxData = toAuxiliaryData sbe (txMetadata txBodyContent) (txAuxScripts txBodyContent) - scripts = convScripts apiScriptWitnesses - languages = convLanguages apiScriptWitnesses - - mkTxBody :: () - => ShelleyBasedEra era - -> TxBodyContent BuildTx era - -> Maybe (L.TxAuxData (ShelleyLedgerEra era)) - -> L.TxBody (ShelleyLedgerEra era) - mkTxBody sbe' bc = - mkCommonTxBody - sbe' - (txIns bc) - (txOuts bc) - (txFee bc) - (txWithdrawals bc) +createTransactionBody sbe bc = + shelleyBasedEraConstraints sbe $ do + let apiTxOuts = txOuts bc + apiScriptWitnesses = collectTxBodyScriptWitnesses sbe bc + apiScriptValidity = txScriptValidity bc + apiMintValue = txMintValue bc + apiProtocolParameters = txProtocolParams bc + apiCollateralTxIns = txInsCollateral bc + apiReferenceInputs = txInsReference bc + apiExtraKeyWitnesses = txExtraKeyWits bc + apiReturnCollateral = txReturnCollateral bc + apiTotalCollateral = txTotalCollateral bc + + -- Ledger types + collTxIns = convCollateralTxIns apiCollateralTxIns + refTxIns = convReferenceInputs apiReferenceInputs + returnCollateral = convReturnCollateral sbe apiReturnCollateral + totalCollateral = convTotalCollateral apiTotalCollateral + certs = convCertificates sbe $ txCertificates bc + txAuxData = toAuxiliaryData sbe (txMetadata bc) (txAuxScripts bc) + scripts = convScripts apiScriptWitnesses + languages = convLanguages apiScriptWitnesses + sData = convScriptData sbe apiTxOuts apiScriptWitnesses + + setUpdateProposal <- + caseShelleyToBabbageOrConwayEraOnwards + (\w -> (A.apiUpdateTxBodyL w .~) <$> convTxUpdateProposal sbe (txUpdateProposal bc)) + (const $ pure id) + sbe - in case sbe of - ShelleyBasedEraShelley -> do - update <- convTxUpdateProposal sbe (txUpdateProposal txBodyContent) - let ledgerTxBody = - mkTxBody ShelleyBasedEraShelley txBodyContent txAuxData - & L.certsTxBodyL .~ certs - & L.invalidHereAfterTxBodyL sbe .~ convValidityUpperBound sbe (txValidityUpperBound txBodyContent) - & L.updateTxBodyL .~ update - - sData = convScriptData sbe apiTxOuts apiScriptWitnesses - - pure $ ShelleyTxBody sbe - ledgerTxBody - scripts - sData - txAuxData - apiScriptValidity + setInvalidBefore <- + caseShelleyEraOnlyOrAllegraEraOnwards + (const $ pure id) + (\aOn -> pure $ A.invalidBeforeTxBodyL aOn .~ convValidityLowerBound (txValidityLowerBound bc)) + sbe - ShelleyBasedEraAllegra -> do - let aOn = AllegraEraOnwardsAllegra - update <- convTxUpdateProposal sbe (txUpdateProposal txBodyContent) - let ledgerTxBody = - mkTxBody ShelleyBasedEraAllegra txBodyContent txAuxData - & L.certsTxBodyL .~ certs - & L.updateTxBodyL .~ update - & L.invalidBeforeTxBodyL aOn .~ convValidityLowerBound (txValidityLowerBound txBodyContent) - & L.invalidHereAfterTxBodyL sbe .~ convValidityUpperBound sbe (txValidityUpperBound txBodyContent) - - pure $ ShelleyTxBody sbe - ledgerTxBody - scripts - (convScriptData sbe apiTxOuts apiScriptWitnesses) - txAuxData - apiScriptValidity + setMint <- + caseShelleyToAllegraOrMaryEraOnwards + (const $ pure id) + (const $ pure $ L.mintTxBodyL .~ convMintValue apiMintValue) + sbe - ShelleyBasedEraMary -> do - let aOn = AllegraEraOnwardsMary - update <- convTxUpdateProposal sbe (txUpdateProposal txBodyContent) - let ledgerTxBody = - mkTxBody ShelleyBasedEraMary txBodyContent txAuxData - & L.certsTxBodyL .~ certs - & L.updateTxBodyL .~ update - & L.invalidBeforeTxBodyL aOn .~ convValidityLowerBound (txValidityLowerBound txBodyContent) - & L.invalidHereAfterTxBodyL sbe .~ convValidityUpperBound sbe (txValidityUpperBound txBodyContent) - & L.mintTxBodyL .~ convMintValue apiMintValue - pure $ ShelleyTxBody sbe - ledgerTxBody - scripts - (convScriptData sbe apiTxOuts apiScriptWitnesses) - txAuxData - apiScriptValidity + setScriptIntegrityHash <- + caseShelleyToMaryOrAlonzoEraOnwards + (const $ pure id) + (const $ pure $ L.scriptIntegrityHashTxBodyL .~ getScriptIntegrityHash apiProtocolParameters languages sData) + sbe - ShelleyBasedEraAlonzo -> do - let aOn = AllegraEraOnwardsAlonzo - update <- convTxUpdateProposal sbe (txUpdateProposal txBodyContent) - let sData = convScriptData sbe apiTxOuts apiScriptWitnesses - let scriptIntegrityHash = - case sData of - TxBodyNoScriptData -> SNothing - TxBodyScriptData w datums redeemers -> - convPParamsToScriptIntegrityHash w apiProtocolParameters redeemers datums languages - let ledgerTxBody = - mkTxBody ShelleyBasedEraAlonzo txBodyContent txAuxData - & L.certsTxBodyL .~ certs - & L.updateTxBodyL .~ update - & L.invalidBeforeTxBodyL aOn .~ convValidityLowerBound (txValidityLowerBound txBodyContent) - & L.invalidHereAfterTxBodyL sbe .~ convValidityUpperBound sbe (txValidityUpperBound txBodyContent) - & L.collateralInputsTxBodyL .~ collTxIns - & L.reqSignerHashesTxBodyL .~ convExtraKeyWitnesses apiExtraKeyWitnesses - & L.mintTxBodyL .~ convMintValue apiMintValue - & L.scriptIntegrityHashTxBodyL .~ scriptIntegrityHash - -- TODO: NetworkId for hardware wallets. We don't always want this - -- & L.networkIdTxBodyL .~ ... - pure $ ShelleyTxBody sbe - ledgerTxBody - scripts - (convScriptData sbe apiTxOuts apiScriptWitnesses) - txAuxData - apiScriptValidity + setCollateralInputs <- + caseShelleyToMaryOrAlonzoEraOnwards + (const $ pure id) + (const $ pure $ L.collateralInputsTxBodyL .~ collTxIns) + sbe - ShelleyBasedEraBabbage -> do - let aOn = AllegraEraOnwardsBabbage - update <- convTxUpdateProposal sbe (txUpdateProposal txBodyContent) - let sData = convScriptData sbe apiTxOuts apiScriptWitnesses - let scriptIntegrityHash = - case sData of - TxBodyNoScriptData -> SNothing - TxBodyScriptData w datums redeemers -> - convPParamsToScriptIntegrityHash w apiProtocolParameters redeemers datums languages - let ledgerTxBody = - mkTxBody ShelleyBasedEraBabbage txBodyContent txAuxData - & L.certsTxBodyL .~ certs - & L.updateTxBodyL .~ update - & L.invalidBeforeTxBodyL aOn .~ convValidityLowerBound (txValidityLowerBound txBodyContent) - & L.invalidHereAfterTxBodyL sbe .~ convValidityUpperBound sbe (txValidityUpperBound txBodyContent) - & L.collateralInputsTxBodyL .~ collTxIns - & L.reqSignerHashesTxBodyL .~ convExtraKeyWitnesses apiExtraKeyWitnesses - & L.mintTxBodyL .~ convMintValue apiMintValue - & L.scriptIntegrityHashTxBodyL .~ scriptIntegrityHash - & L.referenceInputsTxBodyL .~ refTxIns - & L.collateralReturnTxBodyL .~ returnCollateral - & L.totalCollateralTxBodyL .~ totalCollateral - -- TODO: NetworkId for hardware wallets. We don't always want this - -- & L.networkIdTxBodyL .~ ... - pure $ ShelleyTxBody sbe - ledgerTxBody - scripts - sData - txAuxData - apiScriptValidity + setReqSignerHashes <- + caseShelleyToMaryOrAlonzoEraOnwards + (const $ pure id) + (const $ pure $ L.reqSignerHashesTxBodyL .~ convExtraKeyWitnesses apiExtraKeyWitnesses) + sbe - ShelleyBasedEraConway -> do - let aOn = AllegraEraOnwardsConway - let sData = convScriptData sbe apiTxOuts apiScriptWitnesses - let scriptIntegrityHash = - case sData of - TxBodyNoScriptData -> SNothing - TxBodyScriptData w datums redeemers -> - convPParamsToScriptIntegrityHash w apiProtocolParameters redeemers datums languages - let ledgerTxBody = - mkTxBody ShelleyBasedEraConway txBodyContent txAuxData - & L.certsTxBodyL .~ certs - & L.invalidBeforeTxBodyL aOn .~ convValidityLowerBound (txValidityLowerBound txBodyContent) - & L.invalidHereAfterTxBodyL sbe .~ convValidityUpperBound sbe (txValidityUpperBound txBodyContent) - & L.collateralInputsTxBodyL .~ collTxIns - & L.reqSignerHashesTxBodyL .~ convExtraKeyWitnesses apiExtraKeyWitnesses - & L.mintTxBodyL .~ convMintValue apiMintValue - & L.scriptIntegrityHashTxBodyL .~ scriptIntegrityHash - & L.referenceInputsTxBodyL .~ refTxIns - & L.collateralReturnTxBodyL .~ returnCollateral - & L.totalCollateralTxBodyL .~ totalCollateral - -- TODO: NetworkId for hardware wallets. We don't always want this - -- & L.networkIdTxBodyL .~ ... - pure $ ShelleyTxBody sbe - ledgerTxBody - scripts - sData - txAuxData - apiScriptValidity + setReferenceInputs <- + caseShelleyToAlonzoOrBabbageEraOnwards + (const $ pure id) + (const $ pure $ L.referenceInputsTxBodyL .~ refTxIns) + sbe + + setCollateralReturn <- + caseShelleyToAlonzoOrBabbageEraOnwards + (const $ pure id) + (const $ pure $ L.collateralReturnTxBodyL .~ returnCollateral) + sbe + + setTotalCollateral <- + caseShelleyToAlonzoOrBabbageEraOnwards + (const $ pure id) + (const $ pure $ L.totalCollateralTxBodyL .~ totalCollateral) + sbe + + let ledgerTxBody = + mkCommonTxBody sbe (txIns bc) (txOuts bc) (txFee bc) (txWithdrawals bc) txAuxData + & L.certsTxBodyL .~ certs + & A.invalidHereAfterTxBodyL sbe .~ convValidityUpperBound sbe (txValidityUpperBound bc) + & modifyWith setUpdateProposal + & modifyWith setInvalidBefore + & modifyWith setMint + & modifyWith setScriptIntegrityHash + & modifyWith setCollateralInputs + & modifyWith setReqSignerHashes + & modifyWith setReferenceInputs + & modifyWith setCollateralReturn + & modifyWith setTotalCollateral + + -- TODO: NetworkId for hardware wallets. We don't always want this + -- & L.networkIdTxBodyL .~ ... + + pure $ ShelleyTxBody sbe ledgerTxBody scripts sData txAuxData apiScriptValidity + +getScriptIntegrityHash :: () + => BuildTxWith BuildTx (Maybe (LedgerProtocolParameters era)) + -> Set Alonzo.Language + -> TxBodyScriptData era + -> StrictMaybe (L.ScriptIntegrityHash (Ledger.EraCrypto (ShelleyLedgerEra era))) +getScriptIntegrityHash apiProtocolParameters languages = \case + TxBodyNoScriptData -> SNothing + TxBodyScriptData w datums redeemers -> + convPParamsToScriptIntegrityHash w apiProtocolParameters redeemers datums languages validateTxBodyContent :: ShelleyBasedEra era @@ -2379,7 +2312,7 @@ fromLedgerTxValidityLowerBound sbe body = caseShelleyEraOnlyOrAllegraEraOnwards (const TxValidityNoLowerBound) (\w -> - let mInvalidBefore = body ^. L.vldtTxBodyL . L.invalidBeforeL in + let mInvalidBefore = body ^. L.vldtTxBodyL . A.invalidBeforeL in case mInvalidBefore of Nothing -> TxValidityNoLowerBound Just s -> TxValidityLowerBound w s @@ -2391,7 +2324,7 @@ fromLedgerTxValidityUpperBound -> Ledger.TxBody (ShelleyLedgerEra era) -> TxValidityUpperBound era fromLedgerTxValidityUpperBound sbe body = - TxValidityUpperBound sbe $ body ^. L.invalidHereAfterTxBodyL sbe + TxValidityUpperBound sbe $ body ^. A.invalidHereAfterTxBodyL sbe fromLedgerAuxiliaryData :: ShelleyBasedEra era @@ -2797,7 +2730,7 @@ makeShelleyTransactionBody sbe@ShelleyBasedEraShelley (mkCommonTxBody sbe txIns txOuts txFee txWithdrawals txAuxData & L.certsTxBodyL .~ convCertificates sbe txCertificates & L.updateTxBodyL .~ update - & L.invalidHereAfterTxBodyL sbe .~ convValidityUpperBound sbe txValidityUpperBound + & A.invalidHereAfterTxBodyL sbe .~ convValidityUpperBound sbe txValidityUpperBound ) scripts_ TxBodyNoScriptData @@ -2834,8 +2767,8 @@ makeShelleyTransactionBody sbe@ShelleyBasedEraAllegra ShelleyTxBody sbe (mkCommonTxBody sbe txIns txOuts txFee txWithdrawals txAuxData & L.certsTxBodyL .~ convCertificates sbe txCertificates - & L.invalidBeforeTxBodyL aOn .~ convValidityLowerBound txValidityLowerBound - & L.invalidHereAfterTxBodyL sbe .~ convValidityUpperBound sbe txValidityUpperBound + & A.invalidBeforeTxBodyL aOn .~ convValidityLowerBound txValidityLowerBound + & A.invalidHereAfterTxBodyL sbe .~ convValidityUpperBound sbe txValidityUpperBound & L.updateTxBodyL .~ update ) scripts_ @@ -2874,8 +2807,8 @@ makeShelleyTransactionBody sbe@ShelleyBasedEraMary ShelleyTxBody sbe (mkCommonTxBody sbe txIns txOuts txFee txWithdrawals txAuxData & L.certsTxBodyL .~ convCertificates sbe txCertificates - & L.invalidBeforeTxBodyL aOn .~ convValidityLowerBound txValidityLowerBound - & L.invalidHereAfterTxBodyL sbe .~ convValidityUpperBound sbe txValidityUpperBound + & A.invalidBeforeTxBodyL aOn .~ convValidityLowerBound txValidityLowerBound + & A.invalidHereAfterTxBodyL sbe .~ convValidityUpperBound sbe txValidityUpperBound & L.updateTxBodyL .~ update & L.mintTxBodyL .~ convMintValue txMintValue ) @@ -2922,8 +2855,8 @@ makeShelleyTransactionBody sbe@ShelleyBasedEraAlonzo (mkCommonTxBody sbe txIns txOuts txFee txWithdrawals txAuxData & L.collateralInputsTxBodyL .~ convCollateralTxIns txInsCollateral & L.certsTxBodyL .~ convCertificates sbe txCertificates - & L.invalidBeforeTxBodyL aOn .~ convValidityLowerBound txValidityLowerBound - & L.invalidHereAfterTxBodyL sbe .~ convValidityUpperBound sbe txValidityUpperBound + & A.invalidBeforeTxBodyL aOn .~ convValidityLowerBound txValidityLowerBound + & A.invalidHereAfterTxBodyL sbe .~ convValidityUpperBound sbe txValidityUpperBound & L.updateTxBodyL .~ update & L.reqSignerHashesTxBodyL .~ convExtraKeyWitnesses txExtraKeyWits & L.mintTxBodyL .~ convMintValue txMintValue @@ -3017,8 +2950,8 @@ makeShelleyTransactionBody sbe@ShelleyBasedEraBabbage & L.collateralReturnTxBodyL .~ convReturnCollateral sbe txReturnCollateral & L.totalCollateralTxBodyL .~ convTotalCollateral txTotalCollateral & L.certsTxBodyL .~ convCertificates sbe txCertificates - & L.invalidBeforeTxBodyL aOn .~ convValidityLowerBound txValidityLowerBound - & L.invalidHereAfterTxBodyL sbe .~ convValidityUpperBound sbe txValidityUpperBound + & A.invalidBeforeTxBodyL aOn .~ convValidityLowerBound txValidityLowerBound + & A.invalidHereAfterTxBodyL sbe .~ convValidityUpperBound sbe txValidityUpperBound & L.updateTxBodyL .~ update & L.reqSignerHashesTxBodyL .~ convExtraKeyWitnesses txExtraKeyWits & L.mintTxBodyL .~ convMintValue txMintValue @@ -3121,8 +3054,8 @@ makeShelleyTransactionBody sbe@ShelleyBasedEraConway & L.collateralReturnTxBodyL .~ convReturnCollateral sbe txReturnCollateral & L.totalCollateralTxBodyL .~ convTotalCollateral txTotalCollateral & L.certsTxBodyL .~ convCertificates sbe txCertificates - & L.invalidBeforeTxBodyL aOn .~ convValidityLowerBound txValidityLowerBound - & L.invalidHereAfterTxBodyL sbe .~ convValidityUpperBound sbe txValidityUpperBound + & A.invalidBeforeTxBodyL aOn .~ convValidityLowerBound txValidityLowerBound + & A.invalidHereAfterTxBodyL sbe .~ convValidityUpperBound sbe txValidityUpperBound & L.reqSignerHashesTxBodyL .~ convExtraKeyWitnesses txExtraKeyWits & L.mintTxBodyL .~ convMintValue txMintValue & L.scriptIntegrityHashTxBodyL .~ scriptIntegrityHash diff --git a/cardano-api/internal/Cardano/Api/Utils.hs b/cardano-api/internal/Cardano/Api/Utils.hs index 84af05f123..67147d1d4f 100644 --- a/cardano-api/internal/Cardano/Api/Utils.hs +++ b/cardano-api/internal/Cardano/Api/Utils.hs @@ -5,7 +5,6 @@ {-# LANGUAGE RankNTypes #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeApplications #-} -{-# LANGUAGE TypeOperators #-} #if !defined(mingw32_HOST_OS) #define UNIX @@ -26,6 +25,7 @@ module Cardano.Api.Utils , renderEra , runParsecParser , textShow + , modifyWith -- ** CLI option parsing , bounded @@ -133,3 +133,10 @@ bounded t = eitherReader $ \s -> do when (i < fromIntegral (minBound @a)) $ Left $ t <> " must not be less than " <> show (minBound @a) when (i > fromIntegral (maxBound @a)) $ Left $ t <> " must not greater than " <> show (maxBound @a) pure (fromIntegral i) + +-- | Aids type inference. Use this function to ensure the value is a function +-- that modifies a value. +modifyWith :: () + => (a -> a) + -> (a -> a) +modifyWith = id