diff --git a/cardano-api/cardano-api.cabal b/cardano-api/cardano-api.cabal index 053ab98546..ec7f6293ca 100644 --- a/cardano-api/cardano-api.cabal +++ b/cardano-api/cardano-api.cabal @@ -134,7 +134,7 @@ library internal Cardano.Api.Script Cardano.Api.Experimental.Eras Cardano.Api.Experimental.Script - Cardano.Api.Experimental.UnsignedTx + Cardano.Api.Experimental.Tx Cardano.Api.ScriptData Cardano.Api.SerialiseBech32 Cardano.Api.SerialiseCBOR diff --git a/cardano-api/internal/Cardano/Api/Experimental/UnsignedTx.hs b/cardano-api/internal/Cardano/Api/Experimental/UnsignedTx.hs index d1b9e326b0..2652934373 100644 --- a/cardano-api/internal/Cardano/Api/Experimental/UnsignedTx.hs +++ b/cardano-api/internal/Cardano/Api/Experimental/UnsignedTx.hs @@ -1,76 +1,142 @@ {-# LANGUAGE DataKinds #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE GADTs #-} {-# LANGUAGE KindSignatures #-} +{-# LANGUAGE TypeOperators #-} -module Cardano.Api.Experimental.UnsignedTx where +module Cardano.Api.Experimental.Tx where -import Cardano.Api.Eras +import Cardano.Api.Eon.ShelleyBasedEra import Cardano.Api.Experimental.Eras -import Cardano.Api.ReexposeLedger (strictMaybeToMaybe) +import Cardano.Api.Feature +import Cardano.Api.Protocol.AvailableEras +import Cardano.Api.ReexposeLedger (StrictMaybe (..), maybeToStrictMaybe) +import qualified Cardano.Api.ReexposeLedger as L import Cardano.Api.Tx.Body +import Cardano.Api.Tx.Sign +import qualified Cardano.Ledger.Alonzo.TxBody as L +import qualified Cardano.Ledger.Api as L +import qualified Cardano.Ledger.Conway.TxBody as L import qualified Cardano.Ledger.Core as Ledger import Data.Bifunctor +import qualified Data.Map.Strict as Map +import qualified Data.Set as Set +import Lens.Micro - - --- A transaction that contains everything --- except signing key witnesses +-- | A transaction that can contain everything +-- except key witnesses newtype UnsignedTx era = UnsignedTx (Ledger.Tx (ToConstrainedEra era)) - -data UnsignedTxError +newtype UnsignedTxError = UnsignedTxError TxBodyError makeUnsignedTx - :: Era era + :: Ledger.EraCrypto (ToConstrainedEra era) ~ L.StandardCrypto + => L.AlonzoEraTx (ToConstrainedEra era) + => L.BabbageEraTxBody (ToConstrainedEra era) + => L.ShelleyEraTxBody (ToConstrainedEra era) + => ShelleyLedgerEra (AvailableErasToSbe era) ~ ToConstrainedEra era + => Era era -> TxBodyContent BuildTx (AvailableErasToSbe era) -> Either UnsignedTxError (UnsignedTx era) makeUnsignedTx era bc = do - sbe <- maybe (Left $ error "") Right $ protocolVersionToSbe era - - -- Construct tx body - 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 + sbe <- maybe (Left $ error "TODO") Right $ protocolVersionToSbe era + + -- cardano-api types + 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 + txins = convTxIns $ txIns bc + collTxIns = convCollateralTxIns apiCollateralTxIns + refTxIns = convReferenceInputs apiReferenceInputs + outs = convTxOuts sbe apiTxOuts + fee = convTransactionFee sbe $ txFee bc + withdrawals = convWithdrawals $ txWithdrawals bc + 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 <- first UnsignedTxError $ convTxUpdateProposal sbe (txUpdateProposal bc) - setInvalidBefore <- maybe (Left $ error "TODO") Right $ convValidityLowerBound (txValidityLowerBound bc) - let setMint = convMintValue apiMintValue - - setScriptIntegrityHash <- maybe (Left $ error "TODO") Right $ strictMaybeToMaybe $ getScriptIntegrityHash apiProtocolParameters languages sData - - let setReqSignerHashes = convExtraKeyWitnesses apiExtraKeyWitnesses - - let ledgerTxBody = - mkCommonTxBody sbe (txIns bc) (txOuts bc) (txFee bc) (txWithdrawals bc) txAuxData - & A.certsTxBodyL sbe .~ certs - & A.invalidHereAfterTxBodyL sbe .~ convValidityUpperBound sbe (txValidityUpperBound bc) - - -- TODO: Left off here - undefined - -- Construct script witnesses - --- TODO: Left off here. Fill out this function and also --- create a function for signing. + setReqSignerHashes = convExtraKeyWitnesses apiExtraKeyWitnesses + ledgerTxBody = L.mkBasicTxBody + & L.inputsTxBodyL .~ txins + & L.collateralInputsTxBodyL .~ collTxIns + & L.referenceInputsTxBodyL .~ refTxIns + & L.outputsTxBodyL .~ outs + & L.totalCollateralTxBodyL .~ totalCollateral + & L.collateralReturnTxBodyL .~ returnCollateral + & L.feeTxBodyL .~ fee + & L.vldtTxBodyL . L.invalidBeforeL .~ convValidityLowerBound (txValidityLowerBound bc) + & L.vldtTxBodyL . L.invalidHereAfterL .~ convValidityUpperBound sbe (txValidityUpperBound bc) + & L.reqSignerHashesTxBodyL .~ setReqSignerHashes + & L.scriptIntegrityHashTxBodyL .~ getScriptIntegrityHash apiProtocolParameters languages sData + & L.withdrawalsTxBodyL .~ withdrawals + & L.certsTxBodyL .~ certs + & L.updateTxBodyL .~ setUpdateProposal + & L.mintTxBodyL .~ setMint + & L.auxDataHashTxBodyL .~ maybe SNothing (SJust . Ledger.hashTxAuxData) txAuxData + + eraSpecificTxBody = eraSpecificLedgerTxBody era ledgerTxBody bc + + scriptWitnesses = L.mkBasicTxWits + & L.scriptTxWitsL .~ Map.fromList + [ (L.hashScript sw, sw) + | sw <- scripts + ] + + return . UnsignedTx + $ L.mkBasicTx eraSpecificTxBody + & L.witsTxL .~ scriptWitnesses + & L.auxDataTxL .~ maybeToStrictMaybe (toAuxiliaryData sbe (txMetadata bc) (txAuxScripts bc)) + & L.isValidTxL .~ txScriptValidityToIsValid apiScriptValidity + +eraSpecificLedgerTxBody + :: Era era + -> Ledger.TxBody (ToConstrainedEra era) + -> TxBodyContent BuildTx (AvailableErasToSbe era) + -> Ledger.TxBody (ToConstrainedEra era) +eraSpecificLedgerTxBody CurrentEraInternal ledgerbody _ = ledgerbody +eraSpecificLedgerTxBody UpcomingEraInternal ledgerbody bc = + let propProcedures = txProposalProcedures bc + voteProcedures = txVotingProcedures bc + treasuryDonation = txTreasuryDonation bc + currentTresuryValue = txCurrentTreasuryValue bc + in ledgerbody + & L.proposalProceduresTxBodyL .~ convProposalProcedures (maybe TxProposalProceduresNone unFeatured propProcedures) + & L.votingProceduresTxBodyL .~ convVotingProcedures (maybe TxVotingProceduresNone unFeatured voteProcedures) + & L.treasuryDonationTxBodyL .~ maybe (L.Coin 0) unFeatured treasuryDonation + & L.currentTreasuryValueTxBodyL .~ L.maybeToStrictMaybe (unFeatured <$> currentTresuryValue) + +signTx + :: L.EraTx (ToConstrainedEra era) + => Ledger.EraCrypto (ToConstrainedEra era) ~ L.StandardCrypto + => [KeyWitness (AvailableErasToSbe era)] + -> UnsignedTx era + -> Ledger.Tx (ToConstrainedEra era) +signTx apiKeyWits (UnsignedTx unsigned) = + let currentScriptWitnesses = unsigned ^. L.witsTxL + keyWits = L.mkBasicTxWits + & L.addrTxWitsL + .~ Set.fromList [w | ShelleyKeyWitness _ w <- apiKeyWits] + & L.bootAddrTxWitsL + .~ Set.fromList [w | ShelleyBootstrapWitness _ w <- apiKeyWits] + signedTx = unsigned & L.witsTxL .~ (keyWits <> currentScriptWitnesses) + in signedTx diff --git a/cardano-api/internal/Cardano/Api/Tx/Body.hs b/cardano-api/internal/Cardano/Api/Tx/Body.hs index 3e6940df9a..dc2863d974 100644 --- a/cardano-api/internal/Cardano/Api/Tx/Body.hs +++ b/cardano-api/internal/Cardano/Api/Tx/Body.hs @@ -135,14 +135,20 @@ module Cardano.Api.Tx.Body , convExtraKeyWitnesses , convLanguages , convMintValue + , convProposalProcedures , convReferenceInputs , convReturnCollateral , convScripts , convScriptData , convTotalCollateral + , convTransactionFee + , convTxIns + , convTxOuts , convTxUpdateProposal , convValidityLowerBound , convValidityUpperBound + , convVotingProcedures + , convWithdrawals , getScriptIntegrityHash , mkCommonTxBody , toAuxiliaryData