-- | 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/input-output-hk/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 BuildTx
-> [TxOut CtxTx]
-> TxTotalCollateral BabbageEra
-> TxReturnCollateral CtxTx BabbageEra
-> TxFee
-> TxValidityLowerBound
-> TxValidityUpperBound
-> TxMetadataInEra
-> TxAuxScripts
-> TxExtraKeyWitnesses
-> BuildTxWith
     BuildTx (Maybe (LedgerProtocolParameters BabbageEra))
-> TxWithdrawals BuildTx BabbageEra
-> TxCertificates BuildTx BabbageEra
-> TxUpdateProposal BabbageEra
-> TxMintValue BuildTx
-> TxScriptValidity
-> Maybe
     (Featured
        ConwayEraOnwards
        BabbageEra
        (TxProposalProcedures BuildTx BabbageEra))
-> Maybe
     (Featured
        ConwayEraOnwards
        BabbageEra
        (TxVotingProcedures BuildTx BabbageEra))
-> TxBodyContent BuildTx
forall buidl.
TxIns buidl
-> TxInsCollateral
-> TxInsReference buidl
-> [TxOut CtxTx]
-> TxTotalCollateral BabbageEra
-> TxReturnCollateral CtxTx BabbageEra
-> TxFee
-> TxValidityLowerBound
-> TxValidityUpperBound
-> TxMetadataInEra
-> TxAuxScripts
-> TxExtraKeyWitnesses
-> BuildTxWith buidl (Maybe (LedgerProtocolParameters BabbageEra))
-> TxWithdrawals buidl BabbageEra
-> TxCertificates buidl BabbageEra
-> TxUpdateProposal BabbageEra
-> TxMintValue buidl
-> TxScriptValidity
-> Maybe
     (Featured
        ConwayEraOnwards
        BabbageEra
        (TxProposalProcedures buidl BabbageEra))
-> Maybe
     (Featured
        ConwayEraOnwards BabbageEra (TxVotingProcedures buidl BabbageEra))
-> TxBodyContent buidl
TxBodyContent
    TxIns BuildTx
forall a. Monoid a => a
mempty -- inputs
    ([TxIn] -> TxInsCollateral
TxInsCollateral [TxIn]
forall a. Monoid a => a
mempty)
    TxInsReference BuildTx
forall buidl. TxInsReference buidl
TxInsReferenceNone
    [TxOut CtxTx]
forall a. Monoid a => a
mempty -- outputs
    TxTotalCollateral BabbageEra
forall era. TxTotalCollateral era
TxTotalCollateralNone
    TxReturnCollateral CtxTx BabbageEra
forall ctx era. TxReturnCollateral ctx era
TxReturnCollateralNone
    (Coin -> TxFee
TxFeeExplicit Coin
0)
    TxValidityLowerBound
TxValidityNoLowerBound
    TxValidityUpperBound
TxValidityNoUpperBound
    TxMetadataInEra
TxMetadataNone
    TxAuxScripts
TxAuxScriptsNone
    TxExtraKeyWitnesses
TxExtraKeyWitnessesNone
    (Maybe (LedgerProtocolParameters BabbageEra)
-> BuildTxWith
     BuildTx (Maybe (LedgerProtocolParameters BabbageEra))
forall a. a -> BuildTxWith BuildTx a
BuildTxWith (Maybe (LedgerProtocolParameters BabbageEra)
 -> BuildTxWith
      BuildTx (Maybe (LedgerProtocolParameters BabbageEra)))
-> Maybe (LedgerProtocolParameters BabbageEra)
-> BuildTxWith
     BuildTx (Maybe (LedgerProtocolParameters BabbageEra))
forall a b. (a -> b) -> a -> b
$ LedgerProtocolParameters BabbageEra
-> Maybe (LedgerProtocolParameters BabbageEra)
forall a. a -> Maybe a
Just (LedgerProtocolParameters BabbageEra
 -> Maybe (LedgerProtocolParameters BabbageEra))
-> LedgerProtocolParameters BabbageEra
-> Maybe (LedgerProtocolParameters BabbageEra)
forall a b. (a -> b) -> a -> b
$ PParams (ShelleyLedgerEra BabbageEra)
-> LedgerProtocolParameters BabbageEra
forall era.
PParams (ShelleyLedgerEra era) -> LedgerProtocolParameters era
LedgerProtocolParameters PParams (ShelleyLedgerEra BabbageEra)
PParams StandardBabbage
forall a. Default a => a
def)
    TxWithdrawals BuildTx BabbageEra
forall build era. TxWithdrawals build era
TxWithdrawalsNone
    TxCertificates BuildTx BabbageEra
forall build era. TxCertificates build era
TxCertificatesNone
    TxUpdateProposal BabbageEra
forall era. TxUpdateProposal era
TxUpdateProposalNone
    TxMintValue BuildTx
forall buidl. TxMintValue buidl
TxMintValueNone
    TxScriptValidity
TxScriptValidityNone
    Maybe
  (Featured
     ConwayEraOnwards
     BabbageEra
     (TxProposalProcedures BuildTx BabbageEra))
forall a. Maybe a
Nothing
    Maybe
  (Featured
     ConwayEraOnwards
     BabbageEra
     (TxVotingProcedures BuildTx BabbageEra))
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 BuildTx
TxInsReferenceNone ->
          [TxIn] -> TxInsReference BuildTx
forall buidl. [TxIn] -> TxInsReference buidl
TxInsReference [TxIn]
refs'
        TxInsReference [TxIn]
refs ->
          [TxIn] -> TxInsReference BuildTx
forall buidl. [TxIn] -> TxInsReference buidl
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 BabbageEra)
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 BabbageEra)
forall a. Monoid a => a
mempty)
      TxMintValue Value
t (BuildTxWith Map PolicyId (ScriptWitness WitCtxMint BabbageEra)
m) ->
        (Value
t, Map PolicyId (ScriptWitness WitCtxMint BabbageEra)
m)

  mintedTokens' :: Value
mintedTokens' =
    Value
mintedTokens Value -> Value -> Value
forall a. Semigroup a => a -> a -> a
<> [(AssetId, Quantity)] -> Value
valueFromList (((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 BabbageEra))
mintedWitnesses' =
    Map PolicyId (ScriptWitness WitCtxMint BabbageEra)
-> BuildTxWith
     BuildTx (Map PolicyId (ScriptWitness WitCtxMint BabbageEra))
forall a. a -> BuildTxWith BuildTx a
BuildTxWith (Map PolicyId (ScriptWitness WitCtxMint BabbageEra)
 -> BuildTxWith
      BuildTx (Map PolicyId (ScriptWitness WitCtxMint BabbageEra)))
-> Map PolicyId (ScriptWitness WitCtxMint BabbageEra)
-> BuildTxWith
     BuildTx (Map PolicyId (ScriptWitness WitCtxMint BabbageEra))
forall a b. (a -> b) -> a -> b
$ Map PolicyId (ScriptWitness WitCtxMint BabbageEra)
mintedWitnesses Map PolicyId (ScriptWitness WitCtxMint BabbageEra)
-> Map PolicyId (ScriptWitness WitCtxMint BabbageEra)
-> Map PolicyId (ScriptWitness WitCtxMint BabbageEra)
forall a. Semigroup a => a -> a -> a
<> PolicyId
-> ScriptWitness WitCtxMint BabbageEra
-> Map PolicyId (ScriptWitness WitCtxMint BabbageEra)
forall k a. k -> a -> Map k a
Map.singleton PolicyId
policyId ScriptWitness WitCtxMint BabbageEra
mintingWitness

  mintingWitness :: ScriptWitness WitCtxMint BabbageEra
mintingWitness =
    PlutusScript
-> ScriptDatum WitCtxMint
-> ScriptRedeemer
-> ScriptWitness WitCtxMint BabbageEra
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 PlutusScriptV2 -> ScriptHash
forall lang. Script lang -> ScriptHash
hashScript (Script PlutusScriptV2 -> ScriptHash)
-> Script PlutusScriptV2 -> ScriptHash
forall a b. (a -> b) -> a -> b
$ PlutusScript -> Script PlutusScriptV2
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}