module Hydra.Chain.Backend where
import Hydra.Prelude
import Cardano.Api.UTxO qualified as UTxO
import Data.Map.Strict qualified as Map
import Hydra.Cardano.Api
import Hydra.Chain.CardanoClient qualified as CardanoClient
import Hydra.Contract.Dummy (dummyMintingScript)
import Hydra.Tx (ScriptRegistry)
blockfrostProjectPath :: FilePath
blockfrostProjectPath :: FilePath
blockfrostProjectPath = FilePath
"blockfrost-project.txt"
class ChainBackend m where
queryGenesisParameters :: m (GenesisParameters ShelleyEra)
queryScriptRegistry :: [TxId] -> m ScriptRegistry
queryNetworkId :: m NetworkId
queryTip :: m ChainPoint
queryUTxO :: [Address ShelleyAddr] -> m UTxO
queryUTxOByTxIn :: [TxIn] -> m UTxO
queryEraHistory :: CardanoClient.QueryPoint -> m EraHistory
querySystemStart :: CardanoClient.QueryPoint -> m SystemStart
queryProtocolParameters :: CardanoClient.QueryPoint -> m (PParams LedgerEra)
queryStakePools :: CardanoClient.QueryPoint -> m (Set PoolId)
queryUTxOFor :: CardanoClient.QueryPoint -> VerificationKey PaymentKey -> m UTxO
submitTransaction :: Tx -> m ()
awaitTransaction :: Tx -> VerificationKey PaymentKey -> m UTxO
getBlockTime :: m NominalDiffTime
buildTransaction ::
ChainBackend m =>
MonadIO m =>
AddressInEra ->
UTxO ->
[TxIn] ->
[TxOut CtxTx] ->
m (Either (TxBodyErrorAutoBalance Era) Tx)
buildTransaction :: forall (m :: * -> *).
(ChainBackend m, MonadIO m) =>
AddressInEra
-> UTxO
-> [TxIn]
-> [TxOut CtxTx]
-> m (Either (TxBodyErrorAutoBalance Era) Tx)
buildTransaction AddressInEra
changeAddress UTxO
body [TxIn]
utxoToSpend [TxOut CtxTx]
outs = do
PParams ConwayEra
pparams <- QueryPoint -> m (PParams LedgerEra)
forall (m :: * -> *).
ChainBackend m =>
QueryPoint -> m (PParams LedgerEra)
queryProtocolParameters QueryPoint
CardanoClient.QueryTip
PParams LedgerEra
-> AddressInEra
-> UTxO
-> [TxIn]
-> [TxOut CtxTx]
-> Maybe PlutusScript
-> m (Either (TxBodyErrorAutoBalance Era) Tx)
forall (m :: * -> *).
(ChainBackend m, MonadIO m) =>
PParams LedgerEra
-> AddressInEra
-> UTxO
-> [TxIn]
-> [TxOut CtxTx]
-> Maybe PlutusScript
-> m (Either (TxBodyErrorAutoBalance Era) Tx)
buildTransactionWithPParams PParams ConwayEra
PParams LedgerEra
pparams AddressInEra
changeAddress UTxO
body [TxIn]
utxoToSpend [TxOut CtxTx]
outs Maybe PlutusScript
forall a. Maybe a
Nothing
buildTransactionWithMintingScript ::
ChainBackend m =>
MonadIO m =>
AddressInEra ->
UTxO ->
[TxIn] ->
[TxOut CtxTx] ->
Maybe PlutusScript ->
m (Either (TxBodyErrorAutoBalance Era) Tx)
buildTransactionWithMintingScript :: forall (m :: * -> *).
(ChainBackend m, MonadIO m) =>
AddressInEra
-> UTxO
-> [TxIn]
-> [TxOut CtxTx]
-> Maybe PlutusScript
-> m (Either (TxBodyErrorAutoBalance Era) Tx)
buildTransactionWithMintingScript AddressInEra
changeAddress UTxO
body [TxIn]
utxoToSpend [TxOut CtxTx]
outs Maybe PlutusScript
mintingScript = do
PParams ConwayEra
pparams <- QueryPoint -> m (PParams LedgerEra)
forall (m :: * -> *).
ChainBackend m =>
QueryPoint -> m (PParams LedgerEra)
queryProtocolParameters QueryPoint
CardanoClient.QueryTip
PParams LedgerEra
-> AddressInEra
-> UTxO
-> [TxIn]
-> [TxOut CtxTx]
-> Maybe PlutusScript
-> m (Either (TxBodyErrorAutoBalance Era) Tx)
forall (m :: * -> *).
(ChainBackend m, MonadIO m) =>
PParams LedgerEra
-> AddressInEra
-> UTxO
-> [TxIn]
-> [TxOut CtxTx]
-> Maybe PlutusScript
-> m (Either (TxBodyErrorAutoBalance Era) Tx)
buildTransactionWithPParams PParams ConwayEra
PParams LedgerEra
pparams AddressInEra
changeAddress UTxO
body [TxIn]
utxoToSpend [TxOut CtxTx]
outs Maybe PlutusScript
mintingScript
buildTransactionWithPParams ::
ChainBackend m =>
MonadIO m =>
PParams LedgerEra ->
AddressInEra ->
UTxO ->
[TxIn] ->
[TxOut CtxTx] ->
Maybe PlutusScript ->
m (Either (TxBodyErrorAutoBalance Era) Tx)
buildTransactionWithPParams :: forall (m :: * -> *).
(ChainBackend m, MonadIO m) =>
PParams LedgerEra
-> AddressInEra
-> UTxO
-> [TxIn]
-> [TxOut CtxTx]
-> Maybe PlutusScript
-> m (Either (TxBodyErrorAutoBalance Era) Tx)
buildTransactionWithPParams PParams LedgerEra
pparams AddressInEra
changeAddress UTxO
utxoToSpend [TxIn]
collateral [TxOut CtxTx]
outs Maybe PlutusScript
mintingScript = do
SystemStart
systemStart <- QueryPoint -> m SystemStart
forall (m :: * -> *). ChainBackend m => QueryPoint -> m SystemStart
querySystemStart QueryPoint
CardanoClient.QueryTip
EraHistory
eraHistory <- QueryPoint -> m EraHistory
forall (m :: * -> *). ChainBackend m => QueryPoint -> m EraHistory
queryEraHistory QueryPoint
CardanoClient.QueryTip
Set PoolId
stakePools <- QueryPoint -> m (Set PoolId)
forall (m :: * -> *).
ChainBackend m =>
QueryPoint -> m (Set PoolId)
queryStakePools QueryPoint
CardanoClient.QueryTip
Either (TxBodyErrorAutoBalance Era) Tx
-> m (Either (TxBodyErrorAutoBalance Era) Tx)
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Either (TxBodyErrorAutoBalance Era) Tx
-> m (Either (TxBodyErrorAutoBalance Era) Tx))
-> Either (TxBodyErrorAutoBalance Era) Tx
-> m (Either (TxBodyErrorAutoBalance Era) Tx)
forall a b. (a -> b) -> a -> b
$ PParams LedgerEra
-> SystemStart
-> EraHistory
-> Set PoolId
-> AddressInEra
-> UTxO
-> [TxIn]
-> [TxOut CtxTx]
-> Maybe PlutusScript
-> Either (TxBodyErrorAutoBalance Era) Tx
buildTransactionWithPParams' PParams LedgerEra
pparams SystemStart
systemStart EraHistory
eraHistory Set PoolId
stakePools AddressInEra
changeAddress UTxO
utxoToSpend [TxIn]
collateral [TxOut CtxTx]
outs Maybe PlutusScript
mintingScript
buildTransactionWithPParams' ::
PParams LedgerEra ->
SystemStart ->
EraHistory ->
Set PoolId ->
AddressInEra ->
UTxO ->
[TxIn] ->
[TxOut CtxTx] ->
Maybe PlutusScript ->
Either (TxBodyErrorAutoBalance Era) Tx
buildTransactionWithPParams' :: PParams LedgerEra
-> SystemStart
-> EraHistory
-> Set PoolId
-> AddressInEra
-> UTxO
-> [TxIn]
-> [TxOut CtxTx]
-> Maybe PlutusScript
-> Either (TxBodyErrorAutoBalance Era) Tx
buildTransactionWithPParams' PParams LedgerEra
pparams SystemStart
systemStart EraHistory
eraHistory Set PoolId
stakePools AddressInEra
changeAddress UTxO
utxoToSpend [TxIn]
collateral [TxOut CtxTx]
outs Maybe PlutusScript
mintingScript = do
PParams LedgerEra
-> SystemStart
-> EraHistory
-> Set PoolId
-> AddressInEra
-> TxBodyContent BuildTx
-> UTxO
-> Either (TxBodyErrorAutoBalance Era) Tx
buildTransactionWithBody PParams LedgerEra
pparams SystemStart
systemStart EraHistory
eraHistory Set PoolId
stakePools AddressInEra
changeAddress TxBodyContent BuildTx
bodyContent UTxO
utxoToSpend
where
mintValue :: TxMintValue BuildTx
mintValue =
case Maybe PlutusScript
mintingScript of
Maybe PlutusScript
Nothing -> TxMintValue BuildTx
forall build. TxMintValue build
TxMintValueNone
Just PlutusScript
_ ->
let mintingWitness :: ScriptWitness WitCtxMint Era
mintingWitness =
PlutusScript
-> ScriptDatum WitCtxMint
-> ScriptRedeemer
-> ScriptWitness WitCtxMint Era
forall ctx era lang.
(IsPlutusScriptLanguage lang, HasScriptLanguageInEra lang era) =>
PlutusScript lang
-> ScriptDatum ctx -> ScriptRedeemer -> ScriptWitness ctx era
mkScriptWitness PlutusScript
dummyMintingScript ScriptDatum WitCtxMint
NoScriptDatumForMint (() -> ScriptRedeemer
forall a. ToScriptData a => a -> ScriptRedeemer
toScriptData ())
toMint :: Map PolicyId PolicyAssets
toMint = Value -> Map PolicyId PolicyAssets
valueToPolicyAssets ((TxOut CtxTx -> Value) -> [TxOut CtxTx] -> Value
forall m a. Monoid m => (a -> m) -> [a] -> m
forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap TxOut CtxTx -> Value
forall ctx. TxOut ctx -> Value
txOutValue [TxOut CtxTx]
outs)
in if Map PolicyId PolicyAssets -> Bool
forall a. Map PolicyId a -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null Map PolicyId PolicyAssets
toMint
then TxMintValue BuildTx
forall build. TxMintValue build
TxMintValueNone
else
Map
PolicyId
(PolicyAssets, BuildTxWith BuildTx (ScriptWitness WitCtxMint Era))
-> TxMintValue BuildTx
forall build.
Map
PolicyId
(PolicyAssets, BuildTxWith build (ScriptWitness WitCtxMint Era))
-> TxMintValue build
TxMintValue (Map
PolicyId
(PolicyAssets, BuildTxWith BuildTx (ScriptWitness WitCtxMint Era))
-> TxMintValue BuildTx)
-> Map
PolicyId
(PolicyAssets, BuildTxWith BuildTx (ScriptWitness WitCtxMint Era))
-> TxMintValue BuildTx
forall a b. (a -> b) -> a -> b
$
[(PolicyId,
(PolicyAssets,
BuildTxWith BuildTx (ScriptWitness WitCtxMint Era)))]
-> Map
PolicyId
(PolicyAssets, BuildTxWith BuildTx (ScriptWitness WitCtxMint Era))
forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList ([(PolicyId,
(PolicyAssets,
BuildTxWith BuildTx (ScriptWitness WitCtxMint Era)))]
-> Map
PolicyId
(PolicyAssets, BuildTxWith BuildTx (ScriptWitness WitCtxMint Era)))
-> [(PolicyId,
(PolicyAssets,
BuildTxWith BuildTx (ScriptWitness WitCtxMint Era)))]
-> Map
PolicyId
(PolicyAssets, BuildTxWith BuildTx (ScriptWitness WitCtxMint Era))
forall a b. (a -> b) -> a -> b
$
( \(PolicyId
pid, PolicyAssets
assets) ->
( PolicyId
pid
,
( PolicyAssets
assets
, ScriptWitness WitCtxMint Era
-> BuildTxWith BuildTx (ScriptWitness WitCtxMint Era)
forall a. a -> BuildTxWith BuildTx a
BuildTxWith ScriptWitness WitCtxMint Era
mintingWitness
)
)
)
((PolicyId, PolicyAssets)
-> (PolicyId,
(PolicyAssets,
BuildTxWith BuildTx (ScriptWitness WitCtxMint Era))))
-> [(PolicyId, PolicyAssets)]
-> [(PolicyId,
(PolicyAssets,
BuildTxWith BuildTx (ScriptWitness WitCtxMint Era)))]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Map PolicyId PolicyAssets -> [(PolicyId, PolicyAssets)]
forall k a. Map k a -> [(k, a)]
Map.toList Map PolicyId PolicyAssets
toMint
auxScripts :: TxAuxScripts
auxScripts =
if TxMintValue BuildTx
mintValue TxMintValue BuildTx -> TxMintValue BuildTx -> Bool
forall a. Eq a => a -> a -> Bool
== TxMintValue BuildTx
forall build. TxMintValue build
TxMintValueNone
then TxAuxScripts
TxAuxScriptsNone
else
[ScriptInEra] -> TxAuxScripts
TxAuxScripts
( Maybe ScriptInEra -> [ScriptInEra]
forall a. Maybe a -> [a]
maybeToList (Maybe ScriptInEra -> [ScriptInEra])
-> Maybe ScriptInEra -> [ScriptInEra]
forall a b. (a -> b) -> a -> b
$
ShelleyBasedEra Era -> ScriptInAnyLang -> Maybe ScriptInEra
forall era.
ShelleyBasedEra era -> ScriptInAnyLang -> Maybe (ScriptInEra era)
toScriptInEra
ShelleyBasedEra Era
ShelleyBasedEraConway
( Script PlutusScriptV3 -> ScriptInAnyLang
forall lang. Script lang -> ScriptInAnyLang
toScriptInAnyLang (Script PlutusScriptV3 -> ScriptInAnyLang)
-> Script PlutusScriptV3 -> ScriptInAnyLang
forall a b. (a -> b) -> a -> b
$
PlutusScript -> Script PlutusScriptV3
PlutusScript (PlutusScript -> Script PlutusScriptV3)
-> PlutusScript -> Script PlutusScriptV3
forall a b. (a -> b) -> a -> b
$
PlutusScript -> Maybe PlutusScript -> PlutusScript
forall a. a -> Maybe a -> a
fromMaybe PlutusScript
dummyMintingScript Maybe PlutusScript
mintingScript
)
)
bodyContent :: TxBodyContent BuildTx
bodyContent =
TxBodyContent
{ txIns :: TxIns BuildTx
txIns = TxIn -> (TxIn, BuildTxWith BuildTx (Witness WitCtxTxIn Era))
withWitness (TxIn -> (TxIn, BuildTxWith BuildTx (Witness WitCtxTxIn Era)))
-> [TxIn] -> TxIns BuildTx
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Set TxIn -> [TxIn]
forall a. Set a -> [a]
forall (t :: * -> *) a. Foldable t => t a -> [a]
toList (UTxO -> Set TxIn
forall era. UTxO era -> Set TxIn
UTxO.inputSet UTxO
utxoToSpend)
, txInsCollateral :: TxInsCollateral
txInsCollateral = [TxIn] -> TxInsCollateral
TxInsCollateral [TxIn]
collateral
, txInsReference :: TxInsReference BuildTx
txInsReference = TxInsReference BuildTx
forall build. TxInsReference build
TxInsReferenceNone
, txOuts :: [TxOut CtxTx]
txOuts = [TxOut CtxTx]
outs
, txTotalCollateral :: TxTotalCollateral Era
txTotalCollateral = TxTotalCollateral Era
forall era. TxTotalCollateral era
TxTotalCollateralNone
, txReturnCollateral :: TxReturnCollateral CtxTx Era
txReturnCollateral = TxReturnCollateral CtxTx Era
forall ctx era. TxReturnCollateral ctx era
TxReturnCollateralNone
, txFee :: TxFee
txFee = Coin -> TxFee
TxFeeExplicit Coin
0
, txValidityLowerBound :: TxValidityLowerBound
txValidityLowerBound = TxValidityLowerBound
TxValidityNoLowerBound
, txValidityUpperBound :: TxValidityUpperBound
txValidityUpperBound = TxValidityUpperBound
TxValidityNoUpperBound
, txMetadata :: TxMetadataInEra
txMetadata = TxMetadataInEra
TxMetadataNone
, txAuxScripts :: TxAuxScripts
txAuxScripts = TxAuxScripts
auxScripts
, txExtraKeyWits :: TxExtraKeyWitnesses
txExtraKeyWits = TxExtraKeyWitnesses
TxExtraKeyWitnessesNone
, txProtocolParams :: BuildTxWith BuildTx (Maybe (LedgerProtocolParameters Era))
txProtocolParams = Maybe (LedgerProtocolParameters Era)
-> BuildTxWith BuildTx (Maybe (LedgerProtocolParameters Era))
forall a. a -> BuildTxWith BuildTx a
BuildTxWith (Maybe (LedgerProtocolParameters Era)
-> BuildTxWith BuildTx (Maybe (LedgerProtocolParameters Era)))
-> Maybe (LedgerProtocolParameters Era)
-> BuildTxWith BuildTx (Maybe (LedgerProtocolParameters Era))
forall a b. (a -> b) -> a -> b
$ LedgerProtocolParameters Era
-> Maybe (LedgerProtocolParameters Era)
forall a. a -> Maybe a
Just (LedgerProtocolParameters Era
-> Maybe (LedgerProtocolParameters Era))
-> LedgerProtocolParameters Era
-> Maybe (LedgerProtocolParameters Era)
forall a b. (a -> b) -> a -> b
$ PParams LedgerEra -> LedgerProtocolParameters Era
forall era.
PParams (ShelleyLedgerEra era) -> LedgerProtocolParameters era
LedgerProtocolParameters PParams LedgerEra
pparams
, txWithdrawals :: TxWithdrawals BuildTx Era
txWithdrawals = TxWithdrawals BuildTx Era
forall build era. TxWithdrawals build era
TxWithdrawalsNone
, txCertificates :: TxCertificates BuildTx Era
txCertificates = TxCertificates BuildTx Era
forall build era. TxCertificates build era
TxCertificatesNone
, txUpdateProposal :: TxUpdateProposal Era
txUpdateProposal = TxUpdateProposal Era
forall era. TxUpdateProposal era
TxUpdateProposalNone
, txMintValue :: TxMintValue BuildTx
txMintValue = TxMintValue BuildTx
mintValue
, txScriptValidity :: TxScriptValidity
txScriptValidity = TxScriptValidity
TxScriptValidityNone
, txProposalProcedures :: Maybe
(Featured ConwayEraOnwards Era (TxProposalProcedures BuildTx Era))
txProposalProcedures = Maybe
(Featured ConwayEraOnwards Era (TxProposalProcedures BuildTx Era))
forall a. Maybe a
Nothing
, txVotingProcedures :: Maybe
(Featured ConwayEraOnwards Era (TxVotingProcedures BuildTx Era))
txVotingProcedures = Maybe
(Featured ConwayEraOnwards Era (TxVotingProcedures BuildTx Era))
forall a. Maybe a
Nothing
, txCurrentTreasuryValue :: Maybe (Featured ConwayEraOnwards Era (Maybe Coin))
txCurrentTreasuryValue = Maybe (Featured ConwayEraOnwards Era (Maybe Coin))
forall a. Maybe a
Nothing
, txTreasuryDonation :: Maybe (Featured ConwayEraOnwards Era Coin)
txTreasuryDonation = Maybe (Featured ConwayEraOnwards Era Coin)
forall a. Maybe a
Nothing
}
buildTransactionWithBody ::
PParams LedgerEra ->
SystemStart ->
EraHistory ->
Set PoolId ->
AddressInEra ->
TxBodyContent BuildTx ->
UTxO ->
Either (TxBodyErrorAutoBalance Era) Tx
buildTransactionWithBody :: PParams LedgerEra
-> SystemStart
-> EraHistory
-> Set PoolId
-> AddressInEra
-> TxBodyContent BuildTx
-> UTxO
-> Either (TxBodyErrorAutoBalance Era) Tx
buildTransactionWithBody PParams LedgerEra
pparams SystemStart
systemStart EraHistory
eraHistory Set PoolId
stakePools AddressInEra
changeAddress TxBodyContent BuildTx
body UTxO
utxoToSpend = do
(BalancedTxBody -> Tx)
-> Either (TxBodyErrorAutoBalance Era) BalancedTxBody
-> Either (TxBodyErrorAutoBalance Era) Tx
forall b c a. (b -> c) -> Either a b -> Either a c
forall (p :: * -> * -> *) b c a.
Bifunctor p =>
(b -> c) -> p a b -> p a c
second ((TxBody -> [KeyWitness] -> Tx) -> [KeyWitness] -> TxBody -> Tx
forall a b c. (a -> b -> c) -> b -> a -> c
flip TxBody -> [KeyWitness] -> Tx
Tx [] (TxBody -> Tx)
-> (BalancedTxBody -> TxBody) -> BalancedTxBody -> Tx
forall b c a. (b -> c) -> (a -> b) -> a -> c
. BalancedTxBody -> TxBody
balancedTxBody) (Either (TxBodyErrorAutoBalance Era) BalancedTxBody
-> Either (TxBodyErrorAutoBalance Era) Tx)
-> Either (TxBodyErrorAutoBalance Era) BalancedTxBody
-> Either (TxBodyErrorAutoBalance Era) Tx
forall a b. (a -> b) -> a -> b
$
ShelleyBasedEra Era
-> SystemStart
-> LedgerEpochInfo
-> LedgerProtocolParameters Era
-> Set PoolId
-> Map StakeCredential Coin
-> Map (Credential DRepRole) Coin
-> UTxO
-> TxBodyContent BuildTx
-> AddressInEra
-> Maybe Word
-> Either (TxBodyErrorAutoBalance Era) BalancedTxBody
forall era.
HasCallStack =>
ShelleyBasedEra era
-> SystemStart
-> LedgerEpochInfo
-> LedgerProtocolParameters era
-> Set PoolId
-> Map StakeCredential Coin
-> Map (Credential DRepRole) Coin
-> UTxO era
-> TxBodyContent BuildTx era
-> AddressInEra era
-> Maybe Word
-> Either (TxBodyErrorAutoBalance era) (BalancedTxBody era)
makeTransactionBodyAutoBalance
ShelleyBasedEra Era
forall era. IsShelleyBasedEra era => ShelleyBasedEra era
shelleyBasedEra
SystemStart
systemStart
(EraHistory -> LedgerEpochInfo
toLedgerEpochInfo EraHistory
eraHistory)
(PParams LedgerEra -> LedgerProtocolParameters Era
forall era.
PParams (ShelleyLedgerEra era) -> LedgerProtocolParameters era
LedgerProtocolParameters PParams LedgerEra
pparams)
Set PoolId
stakePools
Map StakeCredential Coin
forall a. Monoid a => a
mempty
Map (Credential DRepRole) Coin
forall a. Monoid a => a
mempty
UTxO
utxoToSpend
TxBodyContent BuildTx
body
AddressInEra
changeAddress
Maybe Word
forall a. Maybe a
Nothing