-- | Utilities to building transactions on top of the cardano-api.
module Hydra.Ledger.Cardano.Builder where

import Hydra.Cardano.Api
import Hydra.Prelude

import Data.Default (def)
import Data.Map qualified as Map

-- * Executing

-- | Construct a transction from a builder. It is said 'unsafe' because the
-- underlying implementation will perform some sanity check on a transaction;
-- for example, check that it has at least one input, that no outputs are
-- negatives and whatnot.
--
-- We use the builder only internally for on-chain transaction crafted in the
-- context of Hydra.
unsafeBuildTransaction :: HasCallStack => TxBodyContent BuildTx -> Tx
unsafeBuildTransaction :: HasCallStack => TxBodyContent BuildTx -> Tx
unsafeBuildTransaction TxBodyContent BuildTx
builder =
  (TxBodyError -> Tx)
-> (TxBody -> Tx) -> Either TxBodyError TxBody -> Tx
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either
    (\TxBodyError
txBodyError -> InvalidTransactionException -> Tx
forall e a. (HasCallStack, Exception e) => e -> a
bug (InvalidTransactionException -> Tx)
-> InvalidTransactionException -> Tx
forall a b. (a -> b) -> a -> b
$ InvalidTransactionException{TxBodyError
txBodyError :: TxBodyError
$sel:txBodyError:InvalidTransactionException :: TxBodyError
txBodyError, TxBodyContent BuildTx
builder :: TxBodyContent BuildTx
$sel:builder:InvalidTransactionException :: TxBodyContent BuildTx
builder})
    (TxBody -> [KeyWitness] -> Tx
`Tx` [KeyWitness]
forall a. Monoid a => a
mempty)
    (Either TxBodyError TxBody -> Tx)
-> (TxBodyContent BuildTx -> Either TxBodyError TxBody)
-> TxBodyContent BuildTx
-> Tx
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TxBodyContent BuildTx -> Either TxBodyError TxBody
createAndValidateTransactionBody
    (TxBodyContent BuildTx -> Tx) -> TxBodyContent BuildTx -> Tx
forall a b. (a -> b) -> a -> b
$ TxBodyContent BuildTx
builder

-- | A runtime exception to capture (programmer) failures when building
-- transactions. This should never happened in practice (famous last words...)!
data InvalidTransactionException = InvalidTransactionException
  { InvalidTransactionException -> TxBodyError
txBodyError :: TxBodyError
  , InvalidTransactionException -> TxBodyContent BuildTx
builder :: TxBodyContent BuildTx
  }
  deriving stock (Int -> InvalidTransactionException -> ShowS
[InvalidTransactionException] -> ShowS
InvalidTransactionException -> String
(Int -> InvalidTransactionException -> ShowS)
-> (InvalidTransactionException -> String)
-> ([InvalidTransactionException] -> ShowS)
-> Show InvalidTransactionException
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> InvalidTransactionException -> ShowS
showsPrec :: Int -> InvalidTransactionException -> ShowS
$cshow :: InvalidTransactionException -> String
show :: InvalidTransactionException -> String
$cshowList :: [InvalidTransactionException] -> ShowS
showList :: [InvalidTransactionException] -> ShowS
Show)

instance Exception InvalidTransactionException

-- * Constructing

-- | An empty 'TxBodyContent' with all empty/zero values to be extended using
-- record updates.
--
-- NOTE: 'makeTransactionBody' throws when one tries to build a transaction
-- with scripts but no collaterals. This is unfortunate because collaterals are
-- currently added after by our integrated wallet.
--
-- Similarly, 'makeTransactionBody' throws when building a transaction with
-- scripts and no protocol parameters (needed to compute the script integrity
-- hash). This is also added by our wallet at the moment and this ugly
-- work-around will be removed eventually (related item
-- [215](https://github.com/cardano-scaling/hydra/issues/215).
--
-- So we currently bypass this by having default but seemingly innofensive
-- values for collaterals and protocol params in the 'empty' value
emptyTxBody :: TxBodyContent BuildTx
emptyTxBody :: TxBodyContent BuildTx
emptyTxBody =
  TxIns BuildTx
-> TxInsCollateral
-> TxInsReference
-> [TxOut CtxTx]
-> TxTotalCollateral ConwayEra
-> TxReturnCollateral CtxTx ConwayEra
-> TxFee
-> TxValidityLowerBound
-> TxValidityUpperBound
-> TxMetadataInEra
-> TxAuxScripts
-> BuildTxWith BuildTx (TxSupplementalDatums ConwayEra)
-> TxExtraKeyWitnesses
-> BuildTxWith BuildTx (Maybe (LedgerProtocolParameters ConwayEra))
-> TxWithdrawals BuildTx ConwayEra
-> TxCertificates BuildTx ConwayEra
-> TxUpdateProposal ConwayEra
-> TxMintValue BuildTx
-> TxScriptValidity
-> Maybe
     (Featured
        ConwayEraOnwards
        ConwayEra
        (TxProposalProcedures BuildTx ConwayEra))
-> Maybe
     (Featured
        ConwayEraOnwards ConwayEra (TxVotingProcedures BuildTx ConwayEra))
-> Maybe (Featured ConwayEraOnwards ConwayEra (Maybe Coin))
-> Maybe (Featured ConwayEraOnwards ConwayEra Coin)
-> TxBodyContent BuildTx
forall buidl.
TxIns buidl
-> TxInsCollateral
-> TxInsReference
-> [TxOut CtxTx]
-> TxTotalCollateral ConwayEra
-> TxReturnCollateral CtxTx ConwayEra
-> TxFee
-> TxValidityLowerBound
-> TxValidityUpperBound
-> TxMetadataInEra
-> TxAuxScripts
-> BuildTxWith buidl (TxSupplementalDatums ConwayEra)
-> TxExtraKeyWitnesses
-> BuildTxWith buidl (Maybe (LedgerProtocolParameters ConwayEra))
-> TxWithdrawals buidl ConwayEra
-> TxCertificates buidl ConwayEra
-> TxUpdateProposal ConwayEra
-> TxMintValue buidl
-> TxScriptValidity
-> Maybe
     (Featured
        ConwayEraOnwards ConwayEra (TxProposalProcedures buidl ConwayEra))
-> Maybe
     (Featured
        ConwayEraOnwards ConwayEra (TxVotingProcedures buidl ConwayEra))
-> Maybe (Featured ConwayEraOnwards ConwayEra (Maybe Coin))
-> Maybe (Featured ConwayEraOnwards ConwayEra Coin)
-> TxBodyContent buidl
TxBodyContent
    TxIns BuildTx
forall a. Monoid a => a
mempty -- inputs
    ([TxIn] -> TxInsCollateral
TxInsCollateral [TxIn]
forall a. Monoid a => a
mempty)
    TxInsReference
TxInsReferenceNone
    [TxOut CtxTx]
forall a. Monoid a => a
mempty -- outputs
    TxTotalCollateral ConwayEra
forall era. TxTotalCollateral era
TxTotalCollateralNone
    TxReturnCollateral CtxTx ConwayEra
forall ctx era. TxReturnCollateral ctx era
TxReturnCollateralNone
    (Coin -> TxFee
TxFeeExplicit Coin
0)
    TxValidityLowerBound
TxValidityNoLowerBound
    TxValidityUpperBound
TxValidityNoUpperBound
    TxMetadataInEra
TxMetadataNone
    TxAuxScripts
TxAuxScriptsNone
    (TxSupplementalDatums ConwayEra
-> BuildTxWith BuildTx (TxSupplementalDatums ConwayEra)
forall a. a -> BuildTxWith BuildTx a
BuildTxWith TxSupplementalDatums ConwayEra
forall era. TxSupplementalDatums era
TxSupplementalDataNone)
    TxExtraKeyWitnesses
TxExtraKeyWitnessesNone
    (Maybe (LedgerProtocolParameters ConwayEra)
-> BuildTxWith BuildTx (Maybe (LedgerProtocolParameters ConwayEra))
forall a. a -> BuildTxWith BuildTx a
BuildTxWith (Maybe (LedgerProtocolParameters ConwayEra)
 -> BuildTxWith
      BuildTx (Maybe (LedgerProtocolParameters ConwayEra)))
-> Maybe (LedgerProtocolParameters ConwayEra)
-> BuildTxWith BuildTx (Maybe (LedgerProtocolParameters ConwayEra))
forall a b. (a -> b) -> a -> b
$ LedgerProtocolParameters ConwayEra
-> Maybe (LedgerProtocolParameters ConwayEra)
forall a. a -> Maybe a
Just (LedgerProtocolParameters ConwayEra
 -> Maybe (LedgerProtocolParameters ConwayEra))
-> LedgerProtocolParameters ConwayEra
-> Maybe (LedgerProtocolParameters ConwayEra)
forall a b. (a -> b) -> a -> b
$ PParams (ShelleyLedgerEra ConwayEra)
-> LedgerProtocolParameters ConwayEra
forall era.
PParams (ShelleyLedgerEra era) -> LedgerProtocolParameters era
LedgerProtocolParameters PParams (ShelleyLedgerEra ConwayEra)
PParams StandardConway
forall a. Default a => a
def)
    TxWithdrawals BuildTx ConwayEra
forall build era. TxWithdrawals build era
TxWithdrawalsNone
    TxCertificates BuildTx ConwayEra
forall build era. TxCertificates build era
TxCertificatesNone
    TxUpdateProposal ConwayEra
forall era. TxUpdateProposal era
TxUpdateProposalNone
    TxMintValue BuildTx
forall buidl. TxMintValue buidl
TxMintValueNone
    TxScriptValidity
TxScriptValidityNone
    Maybe
  (Featured
     ConwayEraOnwards
     ConwayEra
     (TxProposalProcedures BuildTx ConwayEra))
forall a. Maybe a
Nothing
    Maybe
  (Featured
     ConwayEraOnwards ConwayEra (TxVotingProcedures BuildTx ConwayEra))
forall a. Maybe a
Nothing
    Maybe (Featured ConwayEraOnwards ConwayEra (Maybe Coin))
forall a. Maybe a
Nothing
    Maybe (Featured ConwayEraOnwards ConwayEra Coin)
forall a. Maybe a
Nothing

-- | Add new inputs to an ongoing builder.
addInputs :: TxIns BuildTx -> TxBodyContent BuildTx -> TxBodyContent BuildTx
addInputs :: TxIns BuildTx -> TxBodyContent BuildTx -> TxBodyContent BuildTx
addInputs TxIns BuildTx
ins TxBodyContent BuildTx
tx =
  TxBodyContent BuildTx
tx{txIns = txIns tx <> ins}

addReferenceInputs :: [TxIn] -> TxBodyContent BuildTx -> TxBodyContent BuildTx
addReferenceInputs :: [TxIn] -> TxBodyContent BuildTx -> TxBodyContent BuildTx
addReferenceInputs [TxIn]
refs' TxBodyContent BuildTx
tx =
  TxBodyContent BuildTx
tx
    { txInsReference = case txInsReference tx of
        TxInsReference
TxInsReferenceNone ->
          [TxIn] -> TxInsReference
TxInsReference [TxIn]
refs'
        TxInsReference [TxIn]
refs ->
          [TxIn] -> TxInsReference
TxInsReference ([TxIn]
refs [TxIn] -> [TxIn] -> [TxIn]
forall a. Semigroup a => a -> a -> a
<> [TxIn]
refs')
    }

-- | Like 'addInputs' but only for vk inputs which requires no additional data.
addVkInputs :: [TxIn] -> TxBodyContent BuildTx -> TxBodyContent BuildTx
addVkInputs :: [TxIn] -> TxBodyContent BuildTx -> TxBodyContent BuildTx
addVkInputs [TxIn]
ins =
  TxIns BuildTx -> TxBodyContent BuildTx -> TxBodyContent BuildTx
addInputs ((,Witness WitCtxTxIn -> BuildTxWith BuildTx (Witness WitCtxTxIn)
forall a. a -> BuildTxWith BuildTx a
BuildTxWith (Witness WitCtxTxIn -> BuildTxWith BuildTx (Witness WitCtxTxIn))
-> Witness WitCtxTxIn -> BuildTxWith BuildTx (Witness WitCtxTxIn)
forall a b. (a -> b) -> a -> b
$ KeyWitnessInCtx WitCtxTxIn -> Witness WitCtxTxIn
forall ctx. KeyWitnessInCtx ctx -> Witness ctx
KeyWitness KeyWitnessInCtx WitCtxTxIn
KeyWitnessForSpending) (TxIn -> (TxIn, BuildTxWith BuildTx (Witness WitCtxTxIn)))
-> [TxIn] -> TxIns BuildTx
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [TxIn]
ins)

-- | Append new outputs to an ongoing builder.
addOutputs :: [TxOut CtxTx] -> TxBodyContent BuildTx -> TxBodyContent BuildTx
addOutputs :: [TxOut CtxTx] -> TxBodyContent BuildTx -> TxBodyContent BuildTx
addOutputs [TxOut CtxTx]
outputs TxBodyContent BuildTx
tx =
  TxBodyContent BuildTx
tx{txOuts = txOuts tx <> outputs}

-- | Add extra required key witnesses to a transaction.
addExtraRequiredSigners :: [Hash PaymentKey] -> TxBodyContent BuildTx -> TxBodyContent BuildTx
addExtraRequiredSigners :: [Hash PaymentKey] -> TxBodyContent BuildTx -> TxBodyContent BuildTx
addExtraRequiredSigners [Hash PaymentKey]
vks TxBodyContent BuildTx
tx =
  TxBodyContent BuildTx
tx{txExtraKeyWits = txExtraKeyWits'}
 where
  txExtraKeyWits' :: TxExtraKeyWitnesses
txExtraKeyWits' =
    case TxBodyContent BuildTx -> TxExtraKeyWitnesses
forall buidl. TxBodyContent buidl -> TxExtraKeyWitnesses
txExtraKeyWits TxBodyContent BuildTx
tx of
      TxExtraKeyWitnesses
TxExtraKeyWitnessesNone ->
        [Hash PaymentKey] -> TxExtraKeyWitnesses
TxExtraKeyWitnesses [Hash PaymentKey]
vks
      TxExtraKeyWitnesses [Hash PaymentKey]
vks' ->
        [Hash PaymentKey] -> TxExtraKeyWitnesses
TxExtraKeyWitnesses ([Hash PaymentKey]
vks' [Hash PaymentKey] -> [Hash PaymentKey] -> [Hash PaymentKey]
forall a. Semigroup a => a -> a -> a
<> [Hash PaymentKey]
vks)

-- | Mint tokens with given plutus minting script and redeemer.
mintTokens :: ToScriptData redeemer => PlutusScript -> redeemer -> [(AssetName, Quantity)] -> TxBodyContent BuildTx -> TxBodyContent BuildTx
mintTokens :: forall redeemer.
ToScriptData redeemer =>
PlutusScript
-> redeemer
-> [(AssetName, Quantity)]
-> TxBodyContent BuildTx
-> TxBodyContent BuildTx
mintTokens PlutusScript
script redeemer
redeemer [(AssetName, Quantity)]
assets TxBodyContent BuildTx
tx =
  TxBodyContent BuildTx
tx{txMintValue = TxMintValue mintedTokens' mintedWitnesses'}
 where
  (Value
mintedTokens, Map PolicyId (ScriptWitness WitCtxMint ConwayEra)
mintedWitnesses) =
    case TxBodyContent BuildTx -> TxMintValue BuildTx
forall buidl. TxBodyContent buidl -> TxMintValue buidl
txMintValue TxBodyContent BuildTx
tx of
      TxMintValue BuildTx
TxMintValueNone ->
        (Value
forall a. Monoid a => a
mempty, Map PolicyId (ScriptWitness WitCtxMint ConwayEra)
forall a. Monoid a => a
mempty)
      TxMintValue Value
t (BuildTxWith Map PolicyId (ScriptWitness WitCtxMint ConwayEra)
m) ->
        (Value
t, Map PolicyId (ScriptWitness WitCtxMint ConwayEra)
m)

  mintedTokens' :: Value
mintedTokens' =
    Value
mintedTokens Value -> Value -> Value
forall a. Semigroup a => a -> a -> a
<> [Item Value] -> Value
forall l. IsList l => [Item l] -> l
fromList (((AssetName, Quantity) -> (AssetId, Quantity))
-> [(AssetName, Quantity)] -> [(AssetId, Quantity)]
forall a b. (a -> b) -> [a] -> [b]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((AssetName -> AssetId)
-> (AssetName, Quantity) -> (AssetId, Quantity)
forall a b c. (a -> b) -> (a, c) -> (b, c)
forall (p :: * -> * -> *) a b c.
Bifunctor p =>
(a -> b) -> p a c -> p b c
first (PolicyId -> AssetName -> AssetId
AssetId PolicyId
policyId)) [(AssetName, Quantity)]
assets)

  mintedWitnesses' :: BuildTxWith
  BuildTx (Map PolicyId (ScriptWitness WitCtxMint ConwayEra))
mintedWitnesses' =
    Map PolicyId (ScriptWitness WitCtxMint ConwayEra)
-> BuildTxWith
     BuildTx (Map PolicyId (ScriptWitness WitCtxMint ConwayEra))
forall a. a -> BuildTxWith BuildTx a
BuildTxWith (Map PolicyId (ScriptWitness WitCtxMint ConwayEra)
 -> BuildTxWith
      BuildTx (Map PolicyId (ScriptWitness WitCtxMint ConwayEra)))
-> Map PolicyId (ScriptWitness WitCtxMint ConwayEra)
-> BuildTxWith
     BuildTx (Map PolicyId (ScriptWitness WitCtxMint ConwayEra))
forall a b. (a -> b) -> a -> b
$ Map PolicyId (ScriptWitness WitCtxMint ConwayEra)
mintedWitnesses Map PolicyId (ScriptWitness WitCtxMint ConwayEra)
-> Map PolicyId (ScriptWitness WitCtxMint ConwayEra)
-> Map PolicyId (ScriptWitness WitCtxMint ConwayEra)
forall a. Semigroup a => a -> a -> a
<> PolicyId
-> ScriptWitness WitCtxMint ConwayEra
-> Map PolicyId (ScriptWitness WitCtxMint ConwayEra)
forall k a. k -> a -> Map k a
Map.singleton PolicyId
policyId ScriptWitness WitCtxMint ConwayEra
mintingWitness

  mintingWitness :: ScriptWitness WitCtxMint ConwayEra
mintingWitness =
    PlutusScript
-> ScriptDatum WitCtxMint
-> ScriptRedeemer
-> ScriptWitness WitCtxMint ConwayEra
forall ctx era lang.
(IsPlutusScriptLanguage lang, HasScriptLanguageInEra lang era) =>
PlutusScript lang
-> ScriptDatum ctx -> ScriptRedeemer -> ScriptWitness ctx era
mkScriptWitness PlutusScript
script ScriptDatum WitCtxMint
NoScriptDatumForMint (redeemer -> ScriptRedeemer
forall a. ToScriptData a => a -> ScriptRedeemer
toScriptData redeemer
redeemer)

  policyId :: PolicyId
policyId =
    ScriptHash -> PolicyId
PolicyId (ScriptHash -> PolicyId) -> ScriptHash -> PolicyId
forall a b. (a -> b) -> a -> b
$ Script PlutusScriptV3 -> ScriptHash
forall lang. Script lang -> ScriptHash
hashScript (Script PlutusScriptV3 -> ScriptHash)
-> Script PlutusScriptV3 -> ScriptHash
forall a b. (a -> b) -> a -> b
$ PlutusScript -> Script PlutusScriptV3
PlutusScript PlutusScript
script

-- | Burn tokens with given plutus minting script and redeemer.
-- This is really just `mintTokens` with negated 'Quantity'.
burnTokens :: ToScriptData redeemer => PlutusScript -> redeemer -> [(AssetName, Quantity)] -> TxBodyContent BuildTx -> TxBodyContent BuildTx
burnTokens :: forall redeemer.
ToScriptData redeemer =>
PlutusScript
-> redeemer
-> [(AssetName, Quantity)]
-> TxBodyContent BuildTx
-> TxBodyContent BuildTx
burnTokens PlutusScript
script redeemer
redeemer [(AssetName, Quantity)]
assets =
  PlutusScript
-> redeemer
-> [(AssetName, Quantity)]
-> TxBodyContent BuildTx
-> TxBodyContent BuildTx
forall redeemer.
ToScriptData redeemer =>
PlutusScript
-> redeemer
-> [(AssetName, Quantity)]
-> TxBodyContent BuildTx
-> TxBodyContent BuildTx
mintTokens PlutusScript
script redeemer
redeemer (((AssetName, Quantity) -> (AssetName, Quantity))
-> [(AssetName, Quantity)] -> [(AssetName, Quantity)]
forall a b. (a -> b) -> [a] -> [b]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((Quantity -> Quantity)
-> (AssetName, Quantity) -> (AssetName, Quantity)
forall b c a. (b -> c) -> (a, b) -> (a, c)
forall (p :: * -> * -> *) b c a.
Bifunctor p =>
(b -> c) -> p a b -> p a c
second Quantity -> Quantity
forall a. Num a => a -> a
negate) [(AssetName, Quantity)]
assets)

-- | Set the upper validity bound for this transaction to some 'SlotNo'.
setValidityUpperBound :: SlotNo -> TxBodyContent BuildTx -> TxBodyContent BuildTx
setValidityUpperBound :: SlotNo -> TxBodyContent BuildTx -> TxBodyContent BuildTx
setValidityUpperBound SlotNo
slotNo TxBodyContent BuildTx
tx =
  TxBodyContent BuildTx
tx{txValidityUpperBound = TxValidityUpperBound slotNo}

-- | Set the lower validity bound for this transaction to some 'SlotNo'.
setValidityLowerBound :: SlotNo -> TxBodyContent BuildTx -> TxBodyContent BuildTx
setValidityLowerBound :: SlotNo -> TxBodyContent BuildTx -> TxBodyContent BuildTx
setValidityLowerBound SlotNo
slotNo TxBodyContent BuildTx
tx =
  TxBodyContent BuildTx
tx{txValidityLowerBound = TxValidityLowerBound slotNo}