-- | 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.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

-- | Like 'addInputs' but only for vk inputs which requires no additional data.
addTxInsSpending :: [TxIn] -> TxBodyContent BuildTx -> TxBodyContent BuildTx
addTxInsSpending :: [TxIn] -> TxBodyContent BuildTx -> TxBodyContent BuildTx
addTxInsSpending [TxIn]
ins =
  TxIns BuildTx ConwayEra
-> TxBodyContent BuildTx -> TxBodyContent BuildTx
forall build era.
TxIns build era
-> TxBodyContent build era -> TxBodyContent build era
addTxIns ((,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 ConwayEra
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [TxIn]
ins)

-- | 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 = Map
  PolicyId
  [(AssetName, Quantity,
    BuildTxWith BuildTx (ScriptWitness WitCtxMint ConwayEra))]
-> TxBodyContent BuildTx -> TxBodyContent BuildTx
forall era build.
IsMaryBasedEra era =>
Map
  PolicyId
  [(AssetName, Quantity,
    BuildTxWith build (ScriptWitness WitCtxMint era))]
-> TxBodyContent build era -> TxBodyContent build era
addTxMintValue Map
  PolicyId
  [(AssetName, Quantity,
    BuildTxWith BuildTx (ScriptWitness WitCtxMint ConwayEra))]
newTokens
 where
  newTokens :: Map
  PolicyId
  [(AssetName, Quantity,
    BuildTxWith BuildTx (ScriptWitness WitCtxMint ConwayEra))]
newTokens =
    [(PolicyId,
  [(AssetName, Quantity,
    BuildTxWith BuildTx (ScriptWitness WitCtxMint ConwayEra))])]
-> Map
     PolicyId
     [(AssetName, Quantity,
       BuildTxWith BuildTx (ScriptWitness WitCtxMint ConwayEra))]
forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList [(PolicyId
policyId, ((AssetName, Quantity)
 -> (AssetName, Quantity,
     BuildTxWith BuildTx (ScriptWitness WitCtxMint ConwayEra)))
-> [(AssetName, Quantity)]
-> [(AssetName, Quantity,
     BuildTxWith BuildTx (ScriptWitness WitCtxMint ConwayEra))]
forall a b. (a -> b) -> [a] -> [b]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (\(AssetName
x, Quantity
y) -> (AssetName
x, Quantity
y, ScriptWitness WitCtxMint ConwayEra
-> BuildTxWith BuildTx (ScriptWitness WitCtxMint ConwayEra)
forall a. a -> BuildTxWith BuildTx a
BuildTxWith ScriptWitness WitCtxMint ConwayEra
mintingWitness)) [(AssetName, Quantity)]
assets)]

  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)