module Cooked.MockChain.GenerateTx.Body
  ( txSkelToTxBody,
    txBodyContentToTxBody,
    txSkelToTxBodyContent,
  )
where

import Cardano.Api qualified as Cardano
import Cardano.Api.Shelley qualified as Cardano
import Cardano.Ledger.Alonzo.Tx qualified as Alonzo
import Cardano.Ledger.Alonzo.TxBody qualified as Alonzo
import Cardano.Ledger.Alonzo.TxWits qualified as Alonzo
import Cardano.Ledger.Conway.PParams qualified as Conway
import Cardano.Ledger.Plutus qualified as Cardano
import Cardano.Node.Emulator.Internal.Node qualified as Emulator
import Control.Lens qualified as Lens
import Control.Monad
import Control.Monad.Except
import Cooked.MockChain.BlockChain
import Cooked.MockChain.GenerateTx.Collateral qualified as Collateral
import Cooked.MockChain.GenerateTx.Common
import Cooked.MockChain.GenerateTx.Input qualified as Input
import Cooked.MockChain.GenerateTx.Mint qualified as Mint
import Cooked.MockChain.GenerateTx.Output qualified as Output
import Cooked.MockChain.GenerateTx.Proposal qualified as Proposal
import Cooked.MockChain.GenerateTx.Withdrawals qualified as Withdrawals
import Cooked.Skeleton
import Cooked.Wallet
import Data.Map qualified as Map
import Data.Set (Set)
import Data.Set qualified as Set
import Ledger.Address qualified as Ledger
import Ledger.Tx.CardanoAPI qualified as Ledger
import PlutusLedgerApi.V3 qualified as Api

-- | Generates a body content from a skeleton
txSkelToTxBodyContent ::
  (MonadBlockChainBalancing m) =>
  -- | The skeleton from which the body is created
  TxSkel ->
  -- | The fee to set in the body
  Integer ->
  -- | The collaterals to set in the body
  Maybe (Set Api.TxOutRef, Wallet) ->
  -- | Returns a Cardano body content
  m (Cardano.TxBodyContent Cardano.BuildTx Cardano.ConwayEra)
txSkelToTxBodyContent :: forall (m :: * -> *).
MonadBlockChainBalancing m =>
TxSkel
-> Integer
-> Maybe (Set TxOutRef, Wallet)
-> m (TxBodyContent BuildTx ConwayEra)
txSkelToTxBodyContent skel :: TxSkel
skel@TxSkel {[Wallet]
[TxSkelProposal]
[TxSkelOut]
Set TxOutRef
Set TxLabel
TxSkelWithdrawals
Map TxOutRef TxSkelRedeemer
TxSkelMints
SlotRange
TxOpts
txSkelLabel :: Set TxLabel
txSkelOpts :: TxOpts
txSkelMints :: TxSkelMints
txSkelSigners :: [Wallet]
txSkelValidityRange :: SlotRange
txSkelIns :: Map TxOutRef TxSkelRedeemer
txSkelInsReference :: Set TxOutRef
txSkelOuts :: [TxSkelOut]
txSkelProposals :: [TxSkelProposal]
txSkelWithdrawals :: TxSkelWithdrawals
txSkelLabel :: TxSkel -> Set TxLabel
txSkelOpts :: TxSkel -> TxOpts
txSkelMints :: TxSkel -> TxSkelMints
txSkelSigners :: TxSkel -> [Wallet]
txSkelValidityRange :: TxSkel -> SlotRange
txSkelIns :: TxSkel -> Map TxOutRef TxSkelRedeemer
txSkelInsReference :: TxSkel -> Set TxOutRef
txSkelOuts :: TxSkel -> [TxSkelOut]
txSkelProposals :: TxSkel -> [TxSkelProposal]
txSkelWithdrawals :: TxSkel -> TxSkelWithdrawals
..} Integer
fee Maybe (Set TxOutRef, Wallet)
mCollaterals | [TxOutRef]
txSkelReferenceInputs <- TxSkel -> [TxOutRef]
txSkelReferenceTxOutRefs TxSkel
skel = do
  [(TxIn, BuildTxWith BuildTx (Witness WitCtxTxIn ConwayEra))]
txIns <- ((TxOutRef, TxSkelRedeemer)
 -> m (TxIn, BuildTxWith BuildTx (Witness WitCtxTxIn ConwayEra)))
-> [(TxOutRef, TxSkelRedeemer)]
-> m [(TxIn, BuildTxWith BuildTx (Witness WitCtxTxIn ConwayEra))]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM (TxOutRef, TxSkelRedeemer)
-> m (TxIn, BuildTxWith BuildTx (Witness WitCtxTxIn ConwayEra))
forall (m :: * -> *).
MonadBlockChainBalancing m =>
(TxOutRef, TxSkelRedeemer)
-> m (TxIn, BuildTxWith BuildTx (Witness WitCtxTxIn ConwayEra))
Input.toTxInAndWitness ([(TxOutRef, TxSkelRedeemer)]
 -> m [(TxIn, BuildTxWith BuildTx (Witness WitCtxTxIn ConwayEra))])
-> [(TxOutRef, TxSkelRedeemer)]
-> m [(TxIn, BuildTxWith BuildTx (Witness WitCtxTxIn ConwayEra))]
forall a b. (a -> b) -> a -> b
$ Map TxOutRef TxSkelRedeemer -> [(TxOutRef, TxSkelRedeemer)]
forall k a. Map k a -> [(k, a)]
Map.toList Map TxOutRef TxSkelRedeemer
txSkelIns
  TxInsReference BuildTx ConwayEra
txInsReference <-
    if [TxOutRef] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [TxOutRef]
txSkelReferenceInputs
      then TxInsReference BuildTx ConwayEra
-> m (TxInsReference BuildTx ConwayEra)
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return TxInsReference BuildTx ConwayEra
forall build era. TxInsReference build era
Cardano.TxInsReferenceNone
      else
        String
-> ([TxIn] -> TxInsReference BuildTx ConwayEra)
-> Either ToCardanoError [TxIn]
-> m (TxInsReference BuildTx ConwayEra)
forall (m :: * -> *) a b.
MonadError MockChainError m =>
String -> (a -> b) -> Either ToCardanoError a -> m b
throwOnToCardanoErrorOrApply
          String
"txSkelToBodyContent: Unable to translate reference inputs."
          (BabbageEraOnwards ConwayEra
-> [TxIn] -> TxInsReference BuildTx ConwayEra
forall era build.
BabbageEraOnwards era -> [TxIn] -> TxInsReference build era
Cardano.TxInsReference BabbageEraOnwards ConwayEra
Cardano.BabbageEraOnwardsConway)
          (Either ToCardanoError [TxIn]
 -> m (TxInsReference BuildTx ConwayEra))
-> Either ToCardanoError [TxIn]
-> m (TxInsReference BuildTx ConwayEra)
forall a b. (a -> b) -> a -> b
$ (TxOutRef -> Either ToCardanoError TxIn)
-> [TxOutRef] -> Either ToCardanoError [TxIn]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM TxOutRef -> Either ToCardanoError TxIn
Ledger.toCardanoTxIn [TxOutRef]
txSkelReferenceInputs
  (TxInsCollateral ConwayEra
txInsCollateral, TxTotalCollateral ConwayEra
txTotalCollateral, TxReturnCollateral CtxTx ConwayEra
txReturnCollateral) <- Integer
-> Maybe (Set TxOutRef, Wallet)
-> m (TxInsCollateral ConwayEra, TxTotalCollateral ConwayEra,
      TxReturnCollateral CtxTx ConwayEra)
forall (m :: * -> *).
MonadBlockChainBalancing m =>
Integer
-> Maybe (Set TxOutRef, Wallet)
-> m (TxInsCollateral ConwayEra, TxTotalCollateral ConwayEra,
      TxReturnCollateral CtxTx ConwayEra)
Collateral.toCollateralTriplet Integer
fee Maybe (Set TxOutRef, Wallet)
mCollaterals
  [TxOut CtxTx ConwayEra]
txOuts <- (TxSkelOut -> m (TxOut CtxTx ConwayEra))
-> [TxSkelOut] -> m [TxOut CtxTx ConwayEra]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM TxSkelOut -> m (TxOut CtxTx ConwayEra)
forall (m :: * -> *).
MonadBlockChainBalancing m =>
TxSkelOut -> m (TxOut CtxTx ConwayEra)
Output.toCardanoTxOut [TxSkelOut]
txSkelOuts
  (TxValidityLowerBound ConwayEra
txValidityLowerBound, TxValidityUpperBound ConwayEra
txValidityUpperBound) <-
    String
-> Either
     ToCardanoError
     (TxValidityLowerBound ConwayEra, TxValidityUpperBound ConwayEra)
-> m (TxValidityLowerBound ConwayEra,
      TxValidityUpperBound ConwayEra)
forall (m :: * -> *) a.
MonadError MockChainError m =>
String -> Either ToCardanoError a -> m a
throwOnToCardanoError
      String
"txSkelToBodyContent: Unable to translate transaction validity range."
      (Either
   ToCardanoError
   (TxValidityLowerBound ConwayEra, TxValidityUpperBound ConwayEra)
 -> m (TxValidityLowerBound ConwayEra,
       TxValidityUpperBound ConwayEra))
-> Either
     ToCardanoError
     (TxValidityLowerBound ConwayEra, TxValidityUpperBound ConwayEra)
-> m (TxValidityLowerBound ConwayEra,
      TxValidityUpperBound ConwayEra)
forall a b. (a -> b) -> a -> b
$ SlotRange
-> Either
     ToCardanoError
     (TxValidityLowerBound ConwayEra, TxValidityUpperBound ConwayEra)
Ledger.toCardanoValidityRange SlotRange
txSkelValidityRange
  TxMintValue BuildTx ConwayEra
txMintValue <- TxSkelMints -> m (TxMintValue BuildTx ConwayEra)
forall (m :: * -> *).
MonadBlockChainBalancing m =>
TxSkelMints -> m (TxMintValue BuildTx ConwayEra)
Mint.toMintValue TxSkelMints
txSkelMints
  TxExtraKeyWitnesses ConwayEra
txExtraKeyWits <-
    if [Wallet] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Wallet]
txSkelSigners
      then TxExtraKeyWitnesses ConwayEra -> m (TxExtraKeyWitnesses ConwayEra)
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return TxExtraKeyWitnesses ConwayEra
forall era. TxExtraKeyWitnesses era
Cardano.TxExtraKeyWitnessesNone
      else
        String
-> ([Hash PaymentKey] -> TxExtraKeyWitnesses ConwayEra)
-> Either ToCardanoError [Hash PaymentKey]
-> m (TxExtraKeyWitnesses ConwayEra)
forall (m :: * -> *) a b.
MonadError MockChainError m =>
String -> (a -> b) -> Either ToCardanoError a -> m b
throwOnToCardanoErrorOrApply
          String
"txSkelToBodyContent: Unable to translate the required signers"
          (AlonzoEraOnwards ConwayEra
-> [Hash PaymentKey] -> TxExtraKeyWitnesses ConwayEra
forall era.
AlonzoEraOnwards era
-> [Hash PaymentKey] -> TxExtraKeyWitnesses era
Cardano.TxExtraKeyWitnesses AlonzoEraOnwards ConwayEra
Cardano.AlonzoEraOnwardsConway)
          (Either ToCardanoError [Hash PaymentKey]
 -> m (TxExtraKeyWitnesses ConwayEra))
-> Either ToCardanoError [Hash PaymentKey]
-> m (TxExtraKeyWitnesses ConwayEra)
forall a b. (a -> b) -> a -> b
$ (Wallet -> Either ToCardanoError (Hash PaymentKey))
-> [Wallet] -> Either ToCardanoError [Hash PaymentKey]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM (PaymentPubKeyHash -> Either ToCardanoError (Hash PaymentKey)
Ledger.toCardanoPaymentKeyHash (PaymentPubKeyHash -> Either ToCardanoError (Hash PaymentKey))
-> (Wallet -> PaymentPubKeyHash)
-> Wallet
-> Either ToCardanoError (Hash PaymentKey)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. PubKeyHash -> PaymentPubKeyHash
Ledger.PaymentPubKeyHash (PubKeyHash -> PaymentPubKeyHash)
-> (Wallet -> PubKeyHash) -> Wallet -> PaymentPubKeyHash
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Wallet -> PubKeyHash
walletPKHash) [Wallet]
txSkelSigners
  BuildTxWith BuildTx (Maybe (LedgerProtocolParameters ConwayEra))
txProtocolParams <- Maybe (LedgerProtocolParameters ConwayEra)
-> BuildTxWith BuildTx (Maybe (LedgerProtocolParameters ConwayEra))
forall a. a -> BuildTxWith BuildTx a
Cardano.BuildTxWith (Maybe (LedgerProtocolParameters ConwayEra)
 -> BuildTxWith
      BuildTx (Maybe (LedgerProtocolParameters ConwayEra)))
-> (Params -> Maybe (LedgerProtocolParameters ConwayEra))
-> Params
-> BuildTxWith BuildTx (Maybe (LedgerProtocolParameters ConwayEra))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. LedgerProtocolParameters ConwayEra
-> Maybe (LedgerProtocolParameters ConwayEra)
forall a. a -> Maybe a
Just (LedgerProtocolParameters ConwayEra
 -> Maybe (LedgerProtocolParameters ConwayEra))
-> (Params -> LedgerProtocolParameters ConwayEra)
-> Params
-> Maybe (LedgerProtocolParameters ConwayEra)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Params -> LedgerProtocolParameters ConwayEra
Emulator.ledgerProtocolParameters (Params
 -> BuildTxWith
      BuildTx (Maybe (LedgerProtocolParameters ConwayEra)))
-> m Params
-> m (BuildTxWith
        BuildTx (Maybe (LedgerProtocolParameters ConwayEra)))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> m Params
forall (m :: * -> *). MonadBlockChainBalancing m => m Params
getParams
  let txFee :: TxFee ConwayEra
txFee = ShelleyBasedEra ConwayEra -> Coin -> TxFee ConwayEra
forall era. ShelleyBasedEra era -> Coin -> TxFee era
Cardano.TxFeeExplicit ShelleyBasedEra ConwayEra
Cardano.ShelleyBasedEraConway (Coin -> TxFee ConwayEra) -> Coin -> TxFee ConwayEra
forall a b. (a -> b) -> a -> b
$ Integer -> Coin
Emulator.Coin Integer
fee
  Maybe
  (Featured
     ConwayEraOnwards
     ConwayEra
     (TxProposalProcedures BuildTx ConwayEra))
txProposalProcedures <-
    Featured
  ConwayEraOnwards ConwayEra (TxProposalProcedures BuildTx ConwayEra)
-> Maybe
     (Featured
        ConwayEraOnwards
        ConwayEra
        (TxProposalProcedures BuildTx ConwayEra))
forall a. a -> Maybe a
Just (Featured
   ConwayEraOnwards ConwayEra (TxProposalProcedures BuildTx ConwayEra)
 -> Maybe
      (Featured
         ConwayEraOnwards
         ConwayEra
         (TxProposalProcedures BuildTx ConwayEra)))
-> (TxProposalProcedures BuildTx ConwayEra
    -> Featured
         ConwayEraOnwards
         ConwayEra
         (TxProposalProcedures BuildTx ConwayEra))
-> TxProposalProcedures BuildTx ConwayEra
-> Maybe
     (Featured
        ConwayEraOnwards
        ConwayEra
        (TxProposalProcedures BuildTx ConwayEra))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ConwayEraOnwards ConwayEra
-> TxProposalProcedures BuildTx ConwayEra
-> Featured
     ConwayEraOnwards ConwayEra (TxProposalProcedures BuildTx ConwayEra)
forall (eon :: * -> *) era a. eon era -> a -> Featured eon era a
Cardano.Featured ConwayEraOnwards ConwayEra
Cardano.ConwayEraOnwardsConway
      (TxProposalProcedures BuildTx ConwayEra
 -> Maybe
      (Featured
         ConwayEraOnwards
         ConwayEra
         (TxProposalProcedures BuildTx ConwayEra)))
-> m (TxProposalProcedures BuildTx ConwayEra)
-> m (Maybe
        (Featured
           ConwayEraOnwards
           ConwayEra
           (TxProposalProcedures BuildTx ConwayEra)))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [TxSkelProposal]
-> AnchorResolution -> m (TxProposalProcedures BuildTx ConwayEra)
forall (m :: * -> *).
MonadBlockChainBalancing m =>
[TxSkelProposal]
-> AnchorResolution -> m (TxProposalProcedures BuildTx ConwayEra)
Proposal.toProposalProcedures [TxSkelProposal]
txSkelProposals (TxOpts -> AnchorResolution
txOptAnchorResolution TxOpts
txSkelOpts)
  TxWithdrawals BuildTx ConwayEra
txWithdrawals <- TxSkelWithdrawals -> m (TxWithdrawals BuildTx ConwayEra)
forall (m :: * -> *).
MonadBlockChainBalancing m =>
TxSkelWithdrawals -> m (TxWithdrawals BuildTx ConwayEra)
Withdrawals.toWithdrawals TxSkelWithdrawals
txSkelWithdrawals
  let txMetadata :: TxMetadataInEra era
txMetadata = TxMetadataInEra era
forall era. TxMetadataInEra era
Cardano.TxMetadataNone -- That's what plutus-apps does as well
      txAuxScripts :: TxAuxScripts era
txAuxScripts = TxAuxScripts era
forall era. TxAuxScripts era
Cardano.TxAuxScriptsNone -- That's what plutus-apps does as well
      txUpdateProposal :: TxUpdateProposal era
txUpdateProposal = TxUpdateProposal era
forall era. TxUpdateProposal era
Cardano.TxUpdateProposalNone -- That's what plutus-apps does as well
      txCertificates :: TxCertificates build era
txCertificates = TxCertificates build era
forall build era. TxCertificates build era
Cardano.TxCertificatesNone -- That's what plutus-apps does as well
      txScriptValidity :: TxScriptValidity era
txScriptValidity = TxScriptValidity era
forall era. TxScriptValidity era
Cardano.TxScriptValidityNone -- That's what plutus-apps does as well
      txVotingProcedures :: Maybe a
txVotingProcedures = Maybe a
forall a. Maybe a
Nothing
  TxBodyContent BuildTx ConwayEra
-> m (TxBodyContent BuildTx ConwayEra)
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return Cardano.TxBodyContent {[(TxIn, BuildTxWith BuildTx (Witness WitCtxTxIn ConwayEra))]
[TxOut CtxTx ConwayEra]
Maybe
  (Featured
     ConwayEraOnwards
     ConwayEra
     (TxProposalProcedures BuildTx ConwayEra))
Maybe
  (Featured
     ConwayEraOnwards ConwayEra (TxVotingProcedures BuildTx ConwayEra))
BuildTxWith BuildTx (Maybe (LedgerProtocolParameters ConwayEra))
TxAuxScripts ConwayEra
TxCertificates BuildTx ConwayEra
TxExtraKeyWitnesses ConwayEra
TxFee ConwayEra
TxInsCollateral ConwayEra
TxInsReference BuildTx ConwayEra
TxMetadataInEra ConwayEra
TxMintValue BuildTx ConwayEra
TxReturnCollateral CtxTx ConwayEra
TxTotalCollateral ConwayEra
TxUpdateProposal ConwayEra
TxValidityLowerBound ConwayEra
TxValidityUpperBound ConwayEra
TxWithdrawals BuildTx ConwayEra
TxScriptValidity ConwayEra
forall a. Maybe a
forall era. TxAuxScripts era
forall era. TxMetadataInEra era
forall era. TxUpdateProposal era
forall era. TxScriptValidity era
forall build era. TxCertificates build era
txIns :: [(TxIn, BuildTxWith BuildTx (Witness WitCtxTxIn ConwayEra))]
txInsReference :: TxInsReference BuildTx ConwayEra
txInsCollateral :: TxInsCollateral ConwayEra
txTotalCollateral :: TxTotalCollateral ConwayEra
txReturnCollateral :: TxReturnCollateral CtxTx ConwayEra
txOuts :: [TxOut CtxTx ConwayEra]
txValidityLowerBound :: TxValidityLowerBound ConwayEra
txValidityUpperBound :: TxValidityUpperBound ConwayEra
txMintValue :: TxMintValue BuildTx ConwayEra
txExtraKeyWits :: TxExtraKeyWitnesses ConwayEra
txProtocolParams :: BuildTxWith BuildTx (Maybe (LedgerProtocolParameters ConwayEra))
txFee :: TxFee ConwayEra
txProposalProcedures :: Maybe
  (Featured
     ConwayEraOnwards
     ConwayEra
     (TxProposalProcedures BuildTx ConwayEra))
txWithdrawals :: TxWithdrawals BuildTx ConwayEra
txMetadata :: forall era. TxMetadataInEra era
txAuxScripts :: forall era. TxAuxScripts era
txUpdateProposal :: forall era. TxUpdateProposal era
txCertificates :: forall build era. TxCertificates build era
txScriptValidity :: forall era. TxScriptValidity era
txVotingProcedures :: forall a. Maybe a
txAuxScripts :: TxAuxScripts ConwayEra
txCertificates :: TxCertificates BuildTx ConwayEra
txExtraKeyWits :: TxExtraKeyWitnesses ConwayEra
txFee :: TxFee ConwayEra
txIns :: [(TxIn, BuildTxWith BuildTx (Witness WitCtxTxIn ConwayEra))]
txInsCollateral :: TxInsCollateral ConwayEra
txInsReference :: TxInsReference BuildTx ConwayEra
txMetadata :: TxMetadataInEra ConwayEra
txMintValue :: TxMintValue BuildTx ConwayEra
txOuts :: [TxOut CtxTx ConwayEra]
txProposalProcedures :: Maybe
  (Featured
     ConwayEraOnwards
     ConwayEra
     (TxProposalProcedures BuildTx ConwayEra))
txProtocolParams :: BuildTxWith BuildTx (Maybe (LedgerProtocolParameters ConwayEra))
txReturnCollateral :: TxReturnCollateral CtxTx ConwayEra
txScriptValidity :: TxScriptValidity ConwayEra
txTotalCollateral :: TxTotalCollateral ConwayEra
txUpdateProposal :: TxUpdateProposal ConwayEra
txValidityLowerBound :: TxValidityLowerBound ConwayEra
txValidityUpperBound :: TxValidityUpperBound ConwayEra
txVotingProcedures :: Maybe
  (Featured
     ConwayEraOnwards ConwayEra (TxVotingProcedures BuildTx ConwayEra))
txWithdrawals :: TxWithdrawals BuildTx ConwayEra
..}

txBodyContentToTxBody :: (MonadBlockChainBalancing m) => Cardano.TxBodyContent Cardano.BuildTx Cardano.ConwayEra -> TxSkel -> m (Cardano.TxBody Cardano.ConwayEra)
txBodyContentToTxBody :: forall (m :: * -> *).
MonadBlockChainBalancing m =>
TxBodyContent BuildTx ConwayEra -> TxSkel -> m (TxBody ConwayEra)
txBodyContentToTxBody TxBodyContent BuildTx ConwayEra
txBodyContent TxSkel
skel = do
  -- We create the associated Shelley TxBody
  txBody :: TxBody ConwayEra
txBody@(Cardano.ShelleyTxBody ShelleyBasedEra ConwayEra
a TxBody (ShelleyLedgerEra ConwayEra)
body [Script (ShelleyLedgerEra ConwayEra)]
c TxBodyScriptData ConwayEra
dats Maybe (TxAuxData (ShelleyLedgerEra ConwayEra))
e TxScriptValidity ConwayEra
f) <-
    (TxBodyError -> m (TxBody ConwayEra))
-> (TxBody ConwayEra -> m (TxBody ConwayEra))
-> Either TxBodyError (TxBody ConwayEra)
-> m (TxBody ConwayEra)
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either
      (MockChainError -> m (TxBody ConwayEra)
forall a. MockChainError -> m a
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (MockChainError -> m (TxBody ConwayEra))
-> (TxBodyError -> MockChainError)
-> TxBodyError
-> m (TxBody ConwayEra)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. GenerateTxError -> MockChainError
MCEGenerationError (GenerateTxError -> MockChainError)
-> (TxBodyError -> GenerateTxError)
-> TxBodyError
-> MockChainError
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> TxBodyError -> GenerateTxError
TxBodyError String
"generateTx :")
      TxBody ConwayEra -> m (TxBody ConwayEra)
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return
      (ShelleyBasedEra ConwayEra
-> TxBodyContent BuildTx ConwayEra
-> Either TxBodyError (TxBody ConwayEra)
forall era.
ShelleyBasedEra era
-> TxBodyContent BuildTx era -> Either TxBodyError (TxBody era)
Cardano.createAndValidateTransactionBody ShelleyBasedEra ConwayEra
Cardano.ShelleyBasedEraConway TxBodyContent BuildTx ConwayEra
txBodyContent)

  -- There is a chance that the body is in need of additional data. This happens
  -- when the set of reference inputs contains hashed datums that will need to
  -- be resolved during phase 2 validation. All that follows until the
  -- definition of "txBody'" aims at doing just that. In the process, we have to
  -- reconstruct the body with the new data and the associated hash. Hopefully,
  -- in the future, cardano-api provides a way to add those data in the body
  -- directly without requiring this method, which somewhat feels like a hack.

  -- We attempt to resolve the reference inputs used by the skeleton
  [TxOut]
refIns <- [TxOutRef] -> (TxOutRef -> m TxOut) -> m [TxOut]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM (TxSkel -> [TxOutRef]
txSkelReferenceTxOutRefs TxSkel
skel) ((TxOutRef -> m TxOut) -> m [TxOut])
-> (TxOutRef -> m TxOut) -> m [TxOut]
forall a b. (a -> b) -> a -> b
$ \TxOutRef
oRef ->
    String -> Maybe TxOut -> m TxOut
forall (m :: * -> *) a.
MonadError MockChainError m =>
String -> Maybe a -> m a
throwOnMaybe (String
"txSkelToCardanoTx: Unable to resolve TxOutRef " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> TxOutRef -> String
forall a. Show a => a -> String
show TxOutRef
oRef) (Maybe TxOut -> m TxOut) -> m (Maybe TxOut) -> m TxOut
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< TxOutRef -> m (Maybe TxOut)
forall (m :: * -> *).
MonadBlockChainBalancing m =>
TxOutRef -> m (Maybe TxOut)
txOutByRef TxOutRef
oRef
  -- We collect the datum hashes present at these outputs
  let datumHashes :: [DatumHash]
datumHashes = [DatumHash
hash | (Api.TxOut Address
_ Value
_ (Api.OutputDatumHash DatumHash
hash) Maybe ScriptHash
_) <- [TxOut]
refIns]
  -- We resolve those datum hashes from the context
  [Datum]
additionalData <- [DatumHash] -> (DatumHash -> m Datum) -> m [Datum]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM [DatumHash]
datumHashes ((DatumHash -> m Datum) -> m [Datum])
-> (DatumHash -> m Datum) -> m [Datum]
forall a b. (a -> b) -> a -> b
$ \DatumHash
dHash ->
    String -> Maybe Datum -> m Datum
forall (m :: * -> *) a.
MonadError MockChainError m =>
String -> Maybe a -> m a
throwOnMaybe (String
"txSkelToCardanoTx: Unable to resolve datum hash " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> DatumHash -> String
forall a. Show a => a -> String
show DatumHash
dHash) (Maybe Datum -> m Datum) -> m (Maybe Datum) -> m Datum
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< DatumHash -> m (Maybe Datum)
forall (m :: * -> *).
MonadBlockChainBalancing m =>
DatumHash -> m (Maybe Datum)
datumFromHash DatumHash
dHash
  -- We compute the map from datum hash to datum of these additional required data
  let additionalDataMap :: Map (DataHash (EraCrypto StandardConway)) (Data StandardConway)
additionalDataMap = [(DataHash (EraCrypto StandardConway), Data StandardConway)]
-> Map (DataHash (EraCrypto StandardConway)) (Data StandardConway)
forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList [(Data StandardConway -> DataHash (EraCrypto StandardConway)
forall era. Era era => Data era -> DataHash (EraCrypto era)
Cardano.hashData Data StandardConway
dat, Data StandardConway
dat) | Api.Datum (Data -> Data StandardConway
forall era. Era era => Data -> Data era
Cardano.Data (Data -> Data StandardConway)
-> (BuiltinData -> Data) -> BuiltinData -> Data StandardConway
forall b c a. (b -> c) -> (a -> b) -> a -> c
. BuiltinData -> Data
forall a. ToData a => a -> Data
Api.toData -> Data StandardConway
dat) <- [Datum]
additionalData]
  -- We retrieve a needed parameter to process difference plutus languages
  Language -> LangDepView
toLangDepViewParam <- PParams StandardConway -> Language -> LangDepView
forall era.
AlonzoEraPParams era =>
PParams era -> Language -> LangDepView
Conway.getLanguageView (PParams StandardConway -> Language -> LangDepView)
-> (Params -> PParams StandardConway)
-> Params
-> Language
-> LangDepView
forall b c a. (b -> c) -> (a -> b) -> a -> c
. LedgerProtocolParameters ConwayEra
-> PParams (ShelleyLedgerEra ConwayEra)
LedgerProtocolParameters ConwayEra -> PParams StandardConway
forall era.
LedgerProtocolParameters era -> PParams (ShelleyLedgerEra era)
Cardano.unLedgerProtocolParameters (LedgerProtocolParameters ConwayEra -> PParams StandardConway)
-> (Params -> LedgerProtocolParameters ConwayEra)
-> Params
-> PParams StandardConway
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Params -> LedgerProtocolParameters ConwayEra
Emulator.ledgerProtocolParameters (Params -> Language -> LangDepView)
-> m Params -> m (Language -> LangDepView)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> m Params
forall (m :: * -> *). MonadBlockChainBalancing m => m Params
getParams
  -- We convert our data map into a 'TxDats'
  let txDats' :: TxDats StandardConway
txDats' = Map (DataHash (EraCrypto StandardConway)) (Data StandardConway)
-> TxDats StandardConway
forall era.
Era era =>
Map (DataHash (EraCrypto era)) (Data era) -> TxDats era
Alonzo.TxDats Map (DataHash (EraCrypto StandardConway)) (Data StandardConway)
additionalDataMap
      -- We compute the new era, datums and redeemers based on the current dats
      -- in the body and the additional data to include in the body.
      (AlonzoEraOnwards ConwayEra
era, TxDats StandardConway
datums, Redeemers StandardConway
redeemers) = case TxBodyScriptData ConwayEra
dats of
        TxBodyScriptData ConwayEra
Cardano.TxBodyNoScriptData -> (AlonzoEraOnwards ConwayEra
Cardano.AlonzoEraOnwardsConway, TxDats StandardConway
txDats', Map
  (PlutusPurpose AsIx StandardConway) (Data StandardConway, ExUnits)
-> Redeemers StandardConway
forall era.
AlonzoEraScript era =>
Map (PlutusPurpose AsIx era) (Data era, ExUnits) -> Redeemers era
Alonzo.Redeemers Map
  (PlutusPurpose AsIx StandardConway) (Data StandardConway, ExUnits)
forall k a. Map k a
Map.empty)
        Cardano.TxBodyScriptData AlonzoEraOnwards ConwayEra
era' TxDats (ShelleyLedgerEra ConwayEra)
txDats Redeemers (ShelleyLedgerEra ConwayEra)
reds -> (AlonzoEraOnwards ConwayEra
era', TxDats (ShelleyLedgerEra ConwayEra)
TxDats StandardConway
txDats TxDats StandardConway
-> TxDats StandardConway -> TxDats StandardConway
forall a. Semigroup a => a -> a -> a
<> TxDats StandardConway
txDats', Redeemers (ShelleyLedgerEra ConwayEra)
Redeemers StandardConway
reds)
      -- We collect the various witnesses in the body
      witnesses :: [(ScriptWitnessIndex, AnyScriptWitness ConwayEra)]
witnesses = ShelleyBasedEra ConwayEra
-> TxBodyContent BuildTx ConwayEra
-> [(ScriptWitnessIndex, AnyScriptWitness ConwayEra)]
forall era.
ShelleyBasedEra era
-> TxBodyContent BuildTx era
-> [(ScriptWitnessIndex, AnyScriptWitness era)]
Cardano.collectTxBodyScriptWitnesses ShelleyBasedEra ConwayEra
Cardano.ShelleyBasedEraConway TxBodyContent BuildTx ConwayEra
txBodyContent
      -- We collect their associated languages
      languages :: [Language]
languages = [PlutusScriptVersion lang -> Language
forall lang. PlutusScriptVersion lang -> Language
toCardanoLanguage PlutusScriptVersion lang
v | (ScriptWitnessIndex
_, Cardano.AnyScriptWitness (Cardano.PlutusScriptWitness ScriptLanguageInEra lang ConwayEra
_ PlutusScriptVersion lang
v PlutusScriptOrReferenceInput lang
_ ScriptDatum witctx
_ ScriptRedeemer
_ ExecutionUnits
_)) <- [(ScriptWitnessIndex, AnyScriptWitness ConwayEra)]
witnesses]
      -- We compute the new script integrity hash with the added data
      scriptIntegrityHash :: StrictMaybe (ScriptIntegrityHash (EraCrypto StandardConway))
scriptIntegrityHash =
        AlonzoEraOnwards ConwayEra
-> (AlonzoEraOnwardsConstraints ConwayEra =>
    StrictMaybe (ScriptIntegrityHash (EraCrypto StandardConway)))
-> StrictMaybe (ScriptIntegrityHash (EraCrypto StandardConway))
forall era a.
AlonzoEraOnwards era -> (AlonzoEraOnwardsConstraints era => a) -> a
Cardano.alonzoEraOnwardsConstraints AlonzoEraOnwards ConwayEra
era ((AlonzoEraOnwardsConstraints ConwayEra =>
  StrictMaybe (ScriptIntegrityHash (EraCrypto StandardConway)))
 -> StrictMaybe (ScriptIntegrityHash (EraCrypto StandardConway)))
-> (AlonzoEraOnwardsConstraints ConwayEra =>
    StrictMaybe (ScriptIntegrityHash (EraCrypto StandardConway)))
-> StrictMaybe (ScriptIntegrityHash (EraCrypto StandardConway))
forall a b. (a -> b) -> a -> b
$
          Set LangDepView
-> Redeemers StandardConway
-> TxDats StandardConway
-> StrictMaybe (ScriptIntegrityHash (EraCrypto StandardConway))
forall era.
AlonzoEraScript era =>
Set LangDepView
-> Redeemers era
-> TxDats era
-> StrictMaybe (ScriptIntegrityHash (EraCrypto era))
Alonzo.hashScriptIntegrity ([LangDepView] -> Set LangDepView
forall a. Ord a => [a] -> Set a
Set.fromList ([LangDepView] -> Set LangDepView)
-> [LangDepView] -> Set LangDepView
forall a b. (a -> b) -> a -> b
$ Language -> LangDepView
toLangDepViewParam (Language -> LangDepView) -> [Language] -> [LangDepView]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Language]
languages) Redeemers StandardConway
redeemers TxDats StandardConway
datums
      -- We wrap all of this in the new body
      body' :: ConwayTxBody StandardConway
body' = TxBody (ShelleyLedgerEra ConwayEra)
ConwayTxBody StandardConway
body ConwayTxBody StandardConway
-> (ConwayTxBody StandardConway -> ConwayTxBody StandardConway)
-> ConwayTxBody StandardConway
forall a b. a -> (a -> b) -> b
Lens.& (StrictMaybe (ScriptIntegrityHash (EraCrypto StandardConway))
 -> Identity
      (StrictMaybe (ScriptIntegrityHash (EraCrypto StandardConway))))
-> TxBody StandardConway -> Identity (TxBody StandardConway)
(StrictMaybe (ScriptIntegrityHash (EraCrypto StandardConway))
 -> Identity
      (StrictMaybe (ScriptIntegrityHash (EraCrypto StandardConway))))
-> ConwayTxBody StandardConway
-> Identity (ConwayTxBody StandardConway)
forall era.
AlonzoEraTxBody era =>
Lens'
  (TxBody era) (StrictMaybe (ScriptIntegrityHash (EraCrypto era)))
Lens'
  (TxBody StandardConway)
  (StrictMaybe (ScriptIntegrityHash (EraCrypto StandardConway)))
Alonzo.scriptIntegrityHashTxBodyL ((StrictMaybe (ScriptIntegrityHash (EraCrypto StandardConway))
  -> Identity
       (StrictMaybe (ScriptIntegrityHash (EraCrypto StandardConway))))
 -> ConwayTxBody StandardConway
 -> Identity (ConwayTxBody StandardConway))
-> StrictMaybe (ScriptIntegrityHash (EraCrypto StandardConway))
-> ConwayTxBody StandardConway
-> ConwayTxBody StandardConway
forall s t a b. ASetter s t a b -> b -> s -> t
Lens..~ StrictMaybe (ScriptIntegrityHash (EraCrypto StandardConway))
scriptIntegrityHash
      txBody' :: TxBody ConwayEra
txBody' = ShelleyBasedEra ConwayEra
-> TxBody (ShelleyLedgerEra ConwayEra)
-> [Script (ShelleyLedgerEra ConwayEra)]
-> TxBodyScriptData ConwayEra
-> Maybe (TxAuxData (ShelleyLedgerEra ConwayEra))
-> TxScriptValidity ConwayEra
-> TxBody ConwayEra
forall era.
ShelleyBasedEra era
-> TxBody (ShelleyLedgerEra era)
-> [Script (ShelleyLedgerEra era)]
-> TxBodyScriptData era
-> Maybe (TxAuxData (ShelleyLedgerEra era))
-> TxScriptValidity era
-> TxBody era
Cardano.ShelleyTxBody ShelleyBasedEra ConwayEra
a TxBody (ShelleyLedgerEra ConwayEra)
ConwayTxBody StandardConway
body' [Script (ShelleyLedgerEra ConwayEra)]
c (AlonzoEraOnwards ConwayEra
-> TxDats (ShelleyLedgerEra ConwayEra)
-> Redeemers (ShelleyLedgerEra ConwayEra)
-> TxBodyScriptData ConwayEra
forall era.
AlonzoEraOnwardsConstraints era =>
AlonzoEraOnwards era
-> TxDats (ShelleyLedgerEra era)
-> Redeemers (ShelleyLedgerEra era)
-> TxBodyScriptData era
Cardano.TxBodyScriptData AlonzoEraOnwards ConwayEra
era TxDats (ShelleyLedgerEra ConwayEra)
TxDats StandardConway
datums Redeemers (ShelleyLedgerEra ConwayEra)
Redeemers StandardConway
redeemers) Maybe (TxAuxData (ShelleyLedgerEra ConwayEra))
e TxScriptValidity ConwayEra
f

  TxBody ConwayEra -> m (TxBody ConwayEra)
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return (TxBody ConwayEra -> m (TxBody ConwayEra))
-> TxBody ConwayEra -> m (TxBody ConwayEra)
forall a b. (a -> b) -> a -> b
$ if Map (DataHash (EraCrypto StandardConway)) (Data StandardConway)
-> Bool
forall a. Map (DataHash (EraCrypto StandardConway)) a -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null Map (DataHash (EraCrypto StandardConway)) (Data StandardConway)
additionalDataMap then TxBody ConwayEra
txBody else TxBody ConwayEra
txBody'
  where
    toCardanoLanguage :: Cardano.PlutusScriptVersion lang -> Cardano.Language
    toCardanoLanguage :: forall lang. PlutusScriptVersion lang -> Language
toCardanoLanguage = \case
      PlutusScriptVersion lang
Cardano.PlutusScriptV1 -> Language
Cardano.PlutusV1
      PlutusScriptVersion lang
Cardano.PlutusScriptV2 -> Language
Cardano.PlutusV2
      PlutusScriptVersion lang
Cardano.PlutusScriptV3 -> Language
Cardano.PlutusV3

txSkelToTxBody :: (MonadBlockChainBalancing m) => TxSkel -> Integer -> Maybe (Set Api.TxOutRef, Wallet) -> m (Cardano.TxBody Cardano.ConwayEra)
txSkelToTxBody :: forall (m :: * -> *).
MonadBlockChainBalancing m =>
TxSkel
-> Integer -> Maybe (Set TxOutRef, Wallet) -> m (TxBody ConwayEra)
txSkelToTxBody TxSkel
skel Integer
fee Maybe (Set TxOutRef, Wallet)
mCollaterals = do
  TxBodyContent BuildTx ConwayEra
txBodyContent <- TxSkel
-> Integer
-> Maybe (Set TxOutRef, Wallet)
-> m (TxBodyContent BuildTx ConwayEra)
forall (m :: * -> *).
MonadBlockChainBalancing m =>
TxSkel
-> Integer
-> Maybe (Set TxOutRef, Wallet)
-> m (TxBodyContent BuildTx ConwayEra)
txSkelToTxBodyContent TxSkel
skel Integer
fee Maybe (Set TxOutRef, Wallet)
mCollaterals
  TxBodyContent BuildTx ConwayEra -> TxSkel -> m (TxBody ConwayEra)
forall (m :: * -> *).
MonadBlockChainBalancing m =>
TxBodyContent BuildTx ConwayEra -> TxSkel -> m (TxBody ConwayEra)
txBodyContentToTxBody TxBodyContent BuildTx ConwayEra
txBodyContent TxSkel
skel