module Hydra.Ledger.Cardano.Builder where
import Hydra.Cardano.Api
import Hydra.Prelude
import Data.Default (def)
import Data.Map qualified as Map
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
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
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
([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
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
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')
}
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)
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}
addExtraRequiredSigners :: [Hash PaymentKey] -> TxBodyContent BuildTx -> TxBodyContent BuildTx
[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)
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
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)
setValidityUpperBound :: SlotNo -> TxBodyContent BuildTx -> TxBodyContent BuildTx
setValidityUpperBound :: SlotNo -> TxBodyContent BuildTx -> TxBodyContent BuildTx
setValidityUpperBound SlotNo
slotNo TxBodyContent BuildTx
tx =
TxBodyContent BuildTx
tx{txValidityUpperBound = TxValidityUpperBound 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}