diff --git a/cardano-api/src/Cardano/Api.hs b/cardano-api/src/Cardano/Api.hs index 08fbc7a7178..a0e4a57ceb4 100644 --- a/cardano-api/src/Cardano/Api.hs +++ b/cardano-api/src/Cardano/Api.hs @@ -147,6 +147,7 @@ module Cardano.Api ( -- ** Transaction bodies TxBody, + getTransactionBodyContent, makeTransactionBody, TxBodyContent(..), TxBodyError(..), @@ -162,6 +163,7 @@ module Cardano.Api ( -- ** Transaction outputs TxOut(TxOut), TxOutValue(..), + serialiseAddressForTxOut, -- ** Other transaction body types TxFee(..), diff --git a/cardano-api/src/Cardano/Api/TxBody.hs b/cardano-api/src/Cardano/Api/TxBody.hs index baac3fbcb21..8da2e86a87d 100644 --- a/cardano-api/src/Cardano/Api/TxBody.hs +++ b/cardano-api/src/Cardano/Api/TxBody.hs @@ -1,10 +1,13 @@ +{-# LANGUAGE DataKinds #-} {-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE DerivingStrategies #-} +{-# LANGUAGE DisambiguateRecordFields #-} {-# LANGUAGE EmptyCase #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE GADTs #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE LambdaCase #-} {-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE PatternSynonyms #-} {-# LANGUAGE ScopedTypeVariables #-} @@ -19,6 +22,7 @@ module Cardano.Api.TxBody ( -- * Transaction bodies TxBody(..), + getTransactionBodyContent, makeTransactionBody, TxBodyContent(..), TxBodyError(..), @@ -100,12 +104,14 @@ module Cardano.Api.TxBody ( import Prelude +import Control.Monad (guard) import Data.Aeson (ToJSON (..), object, (.=)) import qualified Data.Aeson as Aeson import Data.Aeson.Types (ToJSONKey (..), toJSONKeyText) import Data.Bifunctor (first) import Data.ByteString (ByteString) import qualified Data.ByteString.Lazy as LBS +import Data.Foldable (toList) import Data.List (intercalate) import qualified Data.List.NonEmpty as NonEmpty import Data.Map.Strict (Map) @@ -119,8 +125,6 @@ import qualified Data.Text as Text import Data.Word (Word64) import GHC.Generics -import Control.Monad (guard) - import Cardano.Binary (Annotated (..), reAnnotate, recoverBytes) import qualified Cardano.Binary as CBOR import qualified Shelley.Spec.Ledger.Serialization as CBOR (decodeNullMaybe, encodeNullMaybe) @@ -138,8 +142,9 @@ import qualified Cardano.Ledger.Core as Ledger import qualified Cardano.Ledger.Era as Ledger import qualified Cardano.Ledger.SafeHash as SafeHash import qualified Cardano.Ledger.Shelley.Constraints as Ledger -import qualified Cardano.Ledger.ShelleyMA.AuxiliaryData as Allegra -import qualified Cardano.Ledger.ShelleyMA.TxBody as Allegra +import qualified Cardano.Ledger.ShelleyMA.AuxiliaryData as ShelleyMA +import qualified Cardano.Ledger.ShelleyMA.TxBody as ShelleyMA +import Cardano.Ledger.Val (isZero) import Ouroboros.Consensus.Shelley.Eras (StandardAllegra, StandardMary, StandardShelley) import Ouroboros.Consensus.Shelley.Protocol.Crypto (StandardCrypto) @@ -302,6 +307,13 @@ deriving instance Eq (TxOut era) deriving instance Show (TxOut era) +fromByronTxOut :: Byron.TxOut -> TxOut ByronEra +fromByronTxOut (Byron.TxOut addr value) = + TxOut + (AddressInEra ByronAddressInAnyEra (ByronAddress addr)) + (TxOutAdaOnly AdaOnlyInByronEra (fromByronLovelace value)) + + toByronTxOut :: TxOut ByronEra -> Maybe Byron.TxOut toByronTxOut (TxOut (AddressInEra ByronAddressInAnyEra (ByronAddress addr)) (TxOutAdaOnly AdaOnlyInByronEra value)) = @@ -1022,6 +1034,8 @@ data TxBodyError era = | TxBodyOutputOverflow Quantity (TxOut era) | TxBodyMetadataError [(Word64, TxMetadataRangeError)] | TxBodyMintAdaError + | TxBodyAuxDataHashInvalidError + | TxBodyMintBeforeMaryError deriving Show instance Error (TxBodyError era) where @@ -1042,6 +1056,10 @@ instance Error (TxBodyError era) where | (k, err) <- errs ] displayError TxBodyMintAdaError = "Transaction cannot mint ada, only non-ada assets" + displayError TxBodyMintBeforeMaryError = + "Transaction can mint in Mary era or later" + displayError TxBodyAuxDataHashInvalidError = + "Auxiliary data hash is invalid" makeTransactionBody :: forall era. @@ -1054,6 +1072,21 @@ makeTransactionBody = ShelleyBasedEra era -> makeShelleyTransactionBody era +getTransactionBodyContent :: TxBody era + -> Either + (TxBodyError era) + (TxBodyContent ViewTx era) +getTransactionBodyContent = \case + ByronTxBody body -> + Right $ getByronTxBodyContent body + ShelleyTxBody ShelleyBasedEraShelley body _scripts metadata -> + getShelleyTxBodyContent body metadata + ShelleyTxBody ShelleyBasedEraAllegra body _scripts aux -> + getAllegraTxBodyContent body aux + ShelleyTxBody ShelleyBasedEraMary body _scripts aux -> + getMaryTxBodyContent body aux + + makeByronTransactionBody :: TxBodyContent BuildTx ByronEra -> Either (TxBodyError ByronEra) (TxBody ByronEra) makeByronTransactionBody TxBodyContent { txIns, txOuts } = do @@ -1086,6 +1119,13 @@ makeByronTransactionBody TxBodyContent { txIns, txOuts } = do (TxOut (AddressInEra (ShelleyAddressInEra era) ShelleyAddress{}) _) = case era of {} +getByronTxBodyContent :: Annotated Byron.Tx ByteString + -> TxBodyContent ViewTx ByronEra +getByronTxBodyContent (Annotated Byron.UnsafeTx{txInputs, txOutputs} _) = + makeByronTransactionBodyContent + [(fromByronTxIn input, ViewTx) | input <- toList txInputs] + (fromByronTxOut <$> toList txOutputs) + makeShelleyTransactionBody :: ShelleyBasedEra era -> TxBodyContent BuildTx era -> Either (TxBodyError era) (TxBody era) @@ -1171,7 +1211,7 @@ makeShelleyTransactionBody era@ShelleyBasedEraAllegra return $ ShelleyTxBody era - (Allegra.TxBody + (ShelleyMA.TxBody (Set.fromList (map (toShelleyTxIn . fst) txIns)) (Seq.fromList (map toShelleyTxOut txOuts)) (case txCertificates of @@ -1183,11 +1223,11 @@ makeShelleyTransactionBody era@ShelleyBasedEraAllegra (case txFee of TxFeeImplicit era' -> case era' of {} TxFeeExplicit _ fee -> toShelleyLovelace fee) - (Allegra.ValidityInterval { - Allegra.invalidBefore = case lowerBound of + (ShelleyMA.ValidityInterval { + ShelleyMA.invalidBefore = case lowerBound of TxValidityNoLowerBound -> SNothing TxValidityLowerBound _ s -> SJust s, - Allegra.invalidHereafter = case upperBound of + ShelleyMA.invalidHereafter = case upperBound of TxValidityNoUpperBound _ -> SNothing TxValidityUpperBound _ s -> SJust s }) @@ -1249,7 +1289,7 @@ makeShelleyTransactionBody era@ShelleyBasedEraMary return $ ShelleyTxBody era - (Allegra.TxBody + (ShelleyMA.TxBody (Set.fromList (map (toShelleyTxIn . fst) txIns)) (Seq.fromList (map toShelleyTxOut txOuts)) (case txCertificates of @@ -1261,11 +1301,11 @@ makeShelleyTransactionBody era@ShelleyBasedEraMary (case txFee of TxFeeImplicit era' -> case era' of {} TxFeeExplicit _ fee -> toShelleyLovelace fee) - (Allegra.ValidityInterval { - Allegra.invalidBefore = case lowerBound of + (ShelleyMA.ValidityInterval { + ShelleyMA.invalidBefore = case lowerBound of TxValidityNoLowerBound -> SNothing TxValidityLowerBound _ s -> SJust s, - Allegra.invalidHereafter = case upperBound of + ShelleyMA.invalidHereafter = case upperBound of TxValidityNoUpperBound _ -> SNothing TxValidityUpperBound _ s -> SJust s }) @@ -1336,18 +1376,261 @@ collectTxBodySimpleScripts TxBodyContent { simpleScriptInEra _ = [] + toShelleySimpleScript :: SimpleScriptInEra era -> Ledger.Script (ShelleyLedgerEra era) toShelleySimpleScript (SimpleScriptInEra langInEra version script) = toShelleyScript (ScriptInEra langInEra (SimpleScript version script)) -toShelleyWithdrawal :: [(StakeAddress, Lovelace, a)] -> Shelley.Wdrl StandardCrypto + +getShelleyTxBodyContent :: Shelley.TxBody (ShelleyLedgerEra ShelleyEra) + -> Maybe + (Shelley.Metadata (ShelleyLedgerEra ShelleyEra)) + -> Either + (TxBodyError ShelleyEra) + (TxBodyContent ViewTx ShelleyEra) +getShelleyTxBodyContent body metadata = do + guard (Shelley._mdHash body == adHash') ?! TxBodyAuxDataHashInvalidError + pure + TxBodyContent + { txIns + , txOuts + , txFee + , txValidityRange + , txMetadata + , txAuxScripts = TxAuxScriptsNone + , txWithdrawals + , txCertificates + , txUpdateProposal + , txMintValue = TxMintNone + } + where + adHash' = + maybeToStrictMaybe $ + Ledger.hashAuxiliaryData @StandardShelley <$> metadata + txIns = + [(fromShelleyTxIn input, ViewTx) | input <- toList $ Shelley._inputs body] + txOuts = fromTxOut ShelleyBasedEraShelley <$> toList (Shelley._outputs body) + txFee = + TxFeeExplicit TxFeesExplicitInShelleyEra $ + fromShelleyLovelace $ Shelley._txfee body + txValidityRange = + ( TxValidityNoLowerBound + , TxValidityUpperBound ValidityUpperBoundInShelleyEra $ Shelley._ttl body + ) + txMetadata = + case metadata of + Nothing -> TxMetadataNone + Just s -> + let ms = fromShelleyAuxiliaryData s + in if null ms then + TxMetadataNone + else + TxMetadataInEra TxMetadataInShelleyEra (TxMetadata ms) + withdrawals = Shelley._wdrls body + txWithdrawals + | null (Shelley.unWdrl withdrawals) = TxWithdrawalsNone + | otherwise = + TxWithdrawals WithdrawalsInShelleyEra $ + fromShelleyWithdrawal withdrawals + certificates = Shelley._certs body + txCertificates + | null certificates = TxCertificatesNone + | otherwise = + TxCertificates + CertificatesInShelleyEra + (map fromShelleyCertificate $ toList certificates) + ViewTx + txUpdateProposal = + case Shelley._txUpdate body of + SNothing -> TxUpdateProposalNone + SJust p -> + TxUpdateProposal UpdateProposalInShelleyEra $ fromShelleyUpdate p + + +getAllegraTxBodyContent :: ShelleyMA.TxBody (ShelleyLedgerEra AllegraEra) + -> Maybe + (ShelleyMA.AuxiliaryData + (ShelleyLedgerEra AllegraEra)) + -> Either + (TxBodyError AllegraEra) + (TxBodyContent ViewTx AllegraEra) +getAllegraTxBodyContent + (ShelleyMA.TxBody + inputs + outputs + certificates + withdrawals + txfee + ShelleyMA.ValidityInterval{invalidBefore, invalidHereafter} + update + adHash + mint) + auxData = do + guard (adHash == adHash') ?! TxBodyAuxDataHashInvalidError + guard (isZero mint) ?! TxBodyMintBeforeMaryError + pure + TxBodyContent + { txIns + , txOuts + , txFee + , txValidityRange + , txMetadata + , txAuxScripts + , txWithdrawals + , txCertificates + , txUpdateProposal + , txMintValue = TxMintNone + } + where + adHash' = + maybeToStrictMaybe $ + Ledger.hashAuxiliaryData @StandardAllegra <$> auxData + txIns = [(fromShelleyTxIn input, ViewTx) | input <- toList inputs] + txOuts = fromTxOut ShelleyBasedEraAllegra <$> toList outputs + txFee = + TxFeeExplicit TxFeesExplicitInAllegraEra $ fromShelleyLovelace txfee + txValidityRange = + ( case invalidBefore of + SNothing -> TxValidityNoLowerBound + SJust s -> TxValidityLowerBound ValidityLowerBoundInAllegraEra s + , case invalidHereafter of + SNothing -> TxValidityNoUpperBound ValidityNoUpperBoundInAllegraEra + SJust s -> TxValidityUpperBound ValidityUpperBoundInAllegraEra s + ) + (txMetadata, txAuxScripts) = + case auxData of + Nothing -> (TxMetadataNone, TxAuxScriptsNone) + Just s -> + let (ms, ss) = fromAllegraAuxiliaryData s + in ( if null ms then + TxMetadataNone + else + TxMetadataInEra TxMetadataInAllegraEra (TxMetadata ms) + , case ss of + [] -> TxAuxScriptsNone + _ -> TxAuxScripts AuxScriptsInAllegraEra ss + ) + txWithdrawals + | null (Shelley.unWdrl withdrawals) = TxWithdrawalsNone + | otherwise = + TxWithdrawals WithdrawalsInAllegraEra $ + fromShelleyWithdrawal withdrawals + txCertificates + | null certificates = TxCertificatesNone + | otherwise = + TxCertificates + CertificatesInAllegraEra + (map fromShelleyCertificate $ toList certificates) + ViewTx + txUpdateProposal = + case update of + SNothing -> TxUpdateProposalNone + SJust p -> + TxUpdateProposal UpdateProposalInAllegraEra $ fromShelleyUpdate p + + +getMaryTxBodyContent :: ShelleyMA.TxBody (ShelleyLedgerEra MaryEra) + -> Maybe + (ShelleyMA.AuxiliaryData (ShelleyLedgerEra MaryEra)) + -> Either + (TxBodyError MaryEra) + (TxBodyContent ViewTx MaryEra) +getMaryTxBodyContent + (ShelleyMA.TxBody + inputs + outputs + certificates + withdrawals + txfee + ShelleyMA.ValidityInterval{invalidBefore, invalidHereafter} + update + adHash + mint) + auxData = do + guard (adHash == adHash') ?! TxBodyAuxDataHashInvalidError + pure + TxBodyContent + { txIns + , txOuts + , txFee + , txValidityRange + , txMetadata + , txAuxScripts + , txWithdrawals + , txCertificates + , txUpdateProposal + , txMintValue + } + where + adHash' = + maybeToStrictMaybe $ Ledger.hashAuxiliaryData @StandardMary <$> auxData + txIns = [(fromShelleyTxIn input, ViewTx) | input <- toList inputs] + txOuts = fromTxOut ShelleyBasedEraMary <$> toList outputs + txFee = TxFeeExplicit TxFeesExplicitInMaryEra $ fromShelleyLovelace txfee + txValidityRange = + ( case invalidBefore of + SNothing -> TxValidityNoLowerBound + SJust s -> TxValidityLowerBound ValidityLowerBoundInMaryEra s + , case invalidHereafter of + SNothing -> TxValidityNoUpperBound ValidityNoUpperBoundInMaryEra + SJust s -> TxValidityUpperBound ValidityUpperBoundInMaryEra s + ) + (txMetadata, txAuxScripts) = + case auxData of + Nothing -> (TxMetadataNone, TxAuxScriptsNone) + Just s -> + let (ms, ss) = fromMaryAuxiliaryData s + in ( if null ms then + TxMetadataNone + else + TxMetadataInEra TxMetadataInMaryEra (TxMetadata ms) + , case ss of + [] -> TxAuxScriptsNone + _ -> TxAuxScripts AuxScriptsInMaryEra ss + ) + txWithdrawals + | null (Shelley.unWdrl withdrawals) = TxWithdrawalsNone + | otherwise = + TxWithdrawals WithdrawalsInMaryEra $ fromShelleyWithdrawal withdrawals + txCertificates + | null certificates = TxCertificatesNone + | otherwise = + TxCertificates + CertificatesInMaryEra + (map fromShelleyCertificate $ toList certificates) + ViewTx + txUpdateProposal = + case update of + SNothing -> TxUpdateProposalNone + SJust p -> + TxUpdateProposal UpdateProposalInMaryEra $ fromShelleyUpdate p + txMintValue + | isZero mint = TxMintNone + | otherwise = TxMintValue MultiAssetInMaryEra (fromMaryValue mint) ViewTx + + +toShelleyWithdrawal :: [(StakeAddress, Lovelace, build)] + -> Shelley.Wdrl StandardCrypto toShelleyWithdrawal withdrawals = Shelley.Wdrl $ Map.fromList [ (toShelleyStakeAddr stakeAddr, toShelleyLovelace value) | (stakeAddr, value, _) <- withdrawals ] + +fromShelleyWithdrawal :: Shelley.Wdrl StandardCrypto + -> [ ( StakeAddress + , Lovelace + , BuildTxWith ViewTx (Witness WitCtxStake era) + ) + ] +fromShelleyWithdrawal (Shelley.Wdrl withdrawals) = + [ (fromShelleyStakeAddr stakeAddr, fromShelleyLovelace value, ViewTx) + | (stakeAddr, value) <- Map.assocs withdrawals + ] + + -- | In the Shelley era the auxiliary data consists only of the tx metadata toShelleyAuxiliaryData :: Map Word64 TxMetadataValue -> Ledger.AuxiliaryData StandardShelley @@ -1355,22 +1638,47 @@ toShelleyAuxiliaryData m = Shelley.Metadata (toShelleyMetadata m) + +fromShelleyAuxiliaryData :: Ledger.AuxiliaryData StandardShelley + -> Map Word64 TxMetadataValue +fromShelleyAuxiliaryData (Shelley.Metadata m) = fromShelleyMetadata m + + -- | In the Allegra and Mary eras the auxiliary data consists of the tx metadata -- and the axiliary scripts. -- -toAllegraAuxiliaryData :: forall era ledgeera. - ShelleyLedgerEra era ~ ledgeera - => Ledger.AuxiliaryData ledgeera ~ Allegra.AuxiliaryData ledgeera - => Ledger.AnnotatedData (Ledger.Script ledgeera) - => Ord (Ledger.Script ledgeera) +toAllegraAuxiliaryData :: forall era ledgerEra. + ShelleyLedgerEra era ~ ledgerEra + => Ledger.AuxiliaryData ledgerEra ~ ShelleyMA.AuxiliaryData ledgerEra + => Ledger.AnnotatedData (Ledger.Script ledgerEra) + => Ord (Ledger.Script ledgerEra) => Map Word64 TxMetadataValue -> [ScriptInEra era] - -> Ledger.AuxiliaryData ledgeera + -> Ledger.AuxiliaryData ledgerEra toAllegraAuxiliaryData m ss = - Allegra.AuxiliaryData + ShelleyMA.AuxiliaryData (toShelleyMetadata m) (Seq.fromList (map toShelleyScript ss)) + +fromAllegraAuxiliaryData :: Ledger.AuxiliaryData (ShelleyLedgerEra AllegraEra) + -> ( Map Word64 TxMetadataValue + , [ScriptInEra AllegraEra] + ) +fromAllegraAuxiliaryData (ShelleyMA.AuxiliaryData ms ss) = + ( fromShelleyMetadata ms + , fromShelleyBasedScript ShelleyBasedEraAllegra <$> toList ss + ) + + +fromMaryAuxiliaryData :: Ledger.AuxiliaryData (ShelleyLedgerEra MaryEra) + -> (Map Word64 TxMetadataValue, [ScriptInEra MaryEra]) +fromMaryAuxiliaryData (ShelleyMA.AuxiliaryData ms ss) = + ( fromShelleyMetadata ms + , fromShelleyBasedScript ShelleyBasedEraMary <$> toList ss + ) + + -- ---------------------------------------------------------------------------- -- Transitional utility functions for making transaction bodies -- @@ -1381,24 +1689,38 @@ makeByronTransaction :: [TxIn] -> [TxOut ByronEra] -> Either (TxBodyError ByronEra) (TxBody ByronEra) makeByronTransaction txIns txOuts = - makeTransactionBody $ - TxBodyContent { - txIns = [ (txin, BuildTxWith (KeyWitness KeyWitnessForSpending)) - | txin <- txIns ], - txOuts, - txFee = TxFeeImplicit TxFeesImplicitInByronEra, - txValidityRange = (TxValidityNoLowerBound, - TxValidityNoUpperBound - ValidityNoUpperBoundInByronEra), - txMetadata = TxMetadataNone, - txAuxScripts = TxAuxScriptsNone, - txWithdrawals = TxWithdrawalsNone, - txCertificates = TxCertificatesNone, - txUpdateProposal = TxUpdateProposalNone, - txMintValue = TxMintNone - } + makeTransactionBody $ + makeByronTransactionBodyContent + [(txin, BuildTxWith (KeyWitness KeyWitnessForSpending)) | txin <- txIns] + txOuts {-# DEPRECATED makeByronTransaction "Use makeTransactionBody" #-} + +makeByronTransactionBodyContent :: [ ( TxIn + , BuildTxWith + build + (Witness WitCtxTxIn ByronEra) + ) + ] + -> [TxOut ByronEra] + -> TxBodyContent build ByronEra +makeByronTransactionBodyContent txIns txOuts = + TxBodyContent { + txIns, + txOuts, + txFee = TxFeeImplicit TxFeesImplicitInByronEra, + txValidityRange = (TxValidityNoLowerBound, + TxValidityNoUpperBound + ValidityNoUpperBoundInByronEra), + txMetadata = TxMetadataNone, + txAuxScripts = TxAuxScriptsNone, + txWithdrawals = TxWithdrawalsNone, + txCertificates = TxCertificatesNone, + txUpdateProposal = TxUpdateProposalNone, + txMintValue = TxMintNone + } + + -- ---------------------------------------------------------------------------- -- Other utilities helpful with making transaction bodies --