module Hydra.Chain.Backend where

import Hydra.Prelude

import Cardano.Api.UTxO qualified as UTxO
import Hydra.Cardano.Api
import Hydra.Chain.CardanoClient qualified as CardanoClient
import Hydra.Options (ChainBackendOptions)
import Hydra.Tx (ScriptRegistry)

blockfrostProjectPath :: FilePath
blockfrostProjectPath :: FilePath
blockfrostProjectPath = FilePath
"./blockfrost-project.txt"

class ChainBackend a where
  queryGenesisParameters :: (MonadIO m, MonadThrow m) => a -> m (GenesisParameters ShelleyEra)
  queryScriptRegistry :: (MonadIO m, MonadThrow m) => a -> [TxId] -> m ScriptRegistry
  queryNetworkId :: (MonadIO m, MonadThrow m) => a -> m NetworkId
  queryTip :: (MonadIO m, MonadThrow m) => a -> m ChainPoint
  queryUTxO :: (MonadIO m, MonadThrow m) => a -> [Address ShelleyAddr] -> m UTxO
  queryUTxOByTxIn :: (MonadIO m, MonadThrow m) => a -> [TxIn] -> m UTxO
  queryEraHistory :: (MonadIO m, MonadThrow m) => a -> CardanoClient.QueryPoint -> m EraHistory
  querySystemStart :: (MonadIO m, MonadThrow m) => a -> CardanoClient.QueryPoint -> m SystemStart
  queryProtocolParameters :: (MonadIO m, MonadThrow m) => a -> CardanoClient.QueryPoint -> m (PParams LedgerEra)
  queryStakePools :: (MonadIO m, MonadThrow m) => a -> CardanoClient.QueryPoint -> m (Set PoolId)
  queryUTxOFor :: (MonadIO m, MonadThrow m) => a -> CardanoClient.QueryPoint -> VerificationKey PaymentKey -> m UTxO
  submitTransaction :: (MonadIO m, MonadThrow m) => a -> Tx -> m ()
  awaitTransaction :: (MonadIO m, MonadThrow m) => a -> Tx -> VerificationKey PaymentKey -> m UTxO
  getOptions :: a -> ChainBackendOptions
  getBlockTime :: a -> (MonadIO m, MonadThrow m) => m NominalDiffTime

buildTransaction ::
  ChainBackend backend =>
  backend ->
  -- | Change address to send
  AddressInEra ->
  -- | Unspent transaction outputs to spend.
  UTxO ->
  -- | Collateral inputs.
  [TxIn] ->
  -- | Outputs to create.
  [TxOut CtxTx] ->
  IO (Either (TxBodyErrorAutoBalance Era) Tx)
buildTransaction :: forall backend.
ChainBackend backend =>
backend
-> AddressInEra
-> UTxO
-> [TxIn]
-> [TxOut CtxTx]
-> IO (Either (TxBodyErrorAutoBalance Era) Tx)
buildTransaction backend
backend AddressInEra
changeAddress UTxO
body [TxIn]
utxoToSpend [TxOut CtxTx]
outs = do
  PParams ConwayEra
pparams <- backend -> QueryPoint -> IO (PParams LedgerEra)
forall a (m :: * -> *).
(ChainBackend a, MonadIO m, MonadThrow m) =>
a -> QueryPoint -> m (PParams LedgerEra)
forall (m :: * -> *).
(MonadIO m, MonadThrow m) =>
backend -> QueryPoint -> m (PParams LedgerEra)
queryProtocolParameters backend
backend QueryPoint
CardanoClient.QueryTip
  PParams LedgerEra
-> backend
-> AddressInEra
-> UTxO
-> [TxIn]
-> [TxOut CtxTx]
-> IO (Either (TxBodyErrorAutoBalance Era) Tx)
forall backend.
ChainBackend backend =>
PParams LedgerEra
-> backend
-> AddressInEra
-> UTxO
-> [TxIn]
-> [TxOut CtxTx]
-> IO (Either (TxBodyErrorAutoBalance Era) Tx)
buildTransactionWithPParams PParams ConwayEra
PParams LedgerEra
pparams backend
backend AddressInEra
changeAddress UTxO
body [TxIn]
utxoToSpend [TxOut CtxTx]
outs

-- | Construct a simple payment consuming some inputs and producing some
-- outputs (no certificates or withdrawals involved).
--
-- On success, the returned transaction is fully balanced. On error, return
-- `TxBodyErrorAutoBalance`.
buildTransactionWithPParams ::
  ChainBackend backend =>
  -- | Protocol parameters
  PParams LedgerEra ->
  backend ->
  -- | Change address to send
  AddressInEra ->
  -- | Unspent transaction outputs to spend.
  UTxO ->
  -- | Collateral inputs.
  [TxIn] ->
  -- | Outputs to create.
  [TxOut CtxTx] ->
  IO (Either (TxBodyErrorAutoBalance Era) Tx)
buildTransactionWithPParams :: forall backend.
ChainBackend backend =>
PParams LedgerEra
-> backend
-> AddressInEra
-> UTxO
-> [TxIn]
-> [TxOut CtxTx]
-> IO (Either (TxBodyErrorAutoBalance Era) Tx)
buildTransactionWithPParams PParams LedgerEra
pparams backend
backend AddressInEra
changeAddress UTxO
utxoToSpend [TxIn]
collateral [TxOut CtxTx]
outs = do
  SystemStart
systemStart <- backend -> QueryPoint -> IO SystemStart
forall a (m :: * -> *).
(ChainBackend a, MonadIO m, MonadThrow m) =>
a -> QueryPoint -> m SystemStart
forall (m :: * -> *).
(MonadIO m, MonadThrow m) =>
backend -> QueryPoint -> m SystemStart
querySystemStart backend
backend QueryPoint
CardanoClient.QueryTip
  EraHistory
eraHistory <- backend -> QueryPoint -> IO EraHistory
forall a (m :: * -> *).
(ChainBackend a, MonadIO m, MonadThrow m) =>
a -> QueryPoint -> m EraHistory
forall (m :: * -> *).
(MonadIO m, MonadThrow m) =>
backend -> QueryPoint -> m EraHistory
queryEraHistory backend
backend QueryPoint
CardanoClient.QueryTip
  Set PoolId
stakePools <- backend -> QueryPoint -> IO (Set PoolId)
forall a (m :: * -> *).
(ChainBackend a, MonadIO m, MonadThrow m) =>
a -> QueryPoint -> m (Set PoolId)
forall (m :: * -> *).
(MonadIO m, MonadThrow m) =>
backend -> QueryPoint -> m (Set PoolId)
queryStakePools backend
backend QueryPoint
CardanoClient.QueryTip
  Either (TxBodyErrorAutoBalance Era) Tx
-> IO (Either (TxBodyErrorAutoBalance Era) Tx)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Either (TxBodyErrorAutoBalance Era) Tx
 -> IO (Either (TxBodyErrorAutoBalance Era) Tx))
-> Either (TxBodyErrorAutoBalance Era) Tx
-> IO (Either (TxBodyErrorAutoBalance Era) Tx)
forall a b. (a -> b) -> a -> b
$ PParams LedgerEra
-> SystemStart
-> EraHistory
-> Set PoolId
-> AddressInEra
-> UTxO
-> [TxIn]
-> [TxOut CtxTx]
-> Either (TxBodyErrorAutoBalance Era) Tx
buildTransactionWithPParams' PParams LedgerEra
pparams SystemStart
systemStart EraHistory
eraHistory Set PoolId
stakePools AddressInEra
changeAddress UTxO
utxoToSpend [TxIn]
collateral [TxOut CtxTx]
outs

buildTransactionWithPParams' ::
  -- | Protocol parameters
  PParams LedgerEra ->
  SystemStart ->
  EraHistory ->
  Set PoolId ->
  -- | Change address to send
  AddressInEra ->
  -- | Unspent transaction outputs to spend.
  UTxO ->
  -- | Collateral inputs.
  [TxIn] ->
  -- | Outputs to create.
  [TxOut CtxTx] ->
  Either (TxBodyErrorAutoBalance Era) Tx
buildTransactionWithPParams' :: PParams LedgerEra
-> SystemStart
-> EraHistory
-> Set PoolId
-> AddressInEra
-> UTxO
-> [TxIn]
-> [TxOut CtxTx]
-> Either (TxBodyErrorAutoBalance Era) Tx
buildTransactionWithPParams' PParams LedgerEra
pparams SystemStart
systemStart EraHistory
eraHistory Set PoolId
stakePools AddressInEra
changeAddress UTxO
utxoToSpend [TxIn]
collateral [TxOut CtxTx]
outs = 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
  -- NOTE: 'makeTransactionBodyAutoBalance' overwrites this.
  bodyContent :: TxBodyContent BuildTx
bodyContent =
    TxIns BuildTx
-> TxInsCollateral
-> TxInsReference BuildTx
-> [TxOut CtxTx]
-> TxTotalCollateral Era
-> TxReturnCollateral CtxTx Era
-> TxFee
-> TxValidityLowerBound
-> TxValidityUpperBound
-> TxMetadataInEra
-> TxAuxScripts
-> TxExtraKeyWitnesses
-> BuildTxWith BuildTx (Maybe (LedgerProtocolParameters Era))
-> TxWithdrawals BuildTx Era
-> TxCertificates BuildTx Era
-> TxUpdateProposal Era
-> TxMintValue BuildTx
-> TxScriptValidity
-> Maybe
     (Featured ConwayEraOnwards Era (TxProposalProcedures BuildTx Era))
-> Maybe
     (Featured ConwayEraOnwards Era (TxVotingProcedures BuildTx Era))
-> Maybe (Featured ConwayEraOnwards Era (Maybe Coin))
-> Maybe (Featured ConwayEraOnwards Era Coin)
-> TxBodyContent BuildTx
forall build.
TxIns build
-> TxInsCollateral
-> TxInsReference build
-> [TxOut CtxTx]
-> TxTotalCollateral Era
-> TxReturnCollateral CtxTx Era
-> TxFee
-> TxValidityLowerBound
-> TxValidityUpperBound
-> TxMetadataInEra
-> TxAuxScripts
-> TxExtraKeyWitnesses
-> BuildTxWith build (Maybe (LedgerProtocolParameters Era))
-> TxWithdrawals build Era
-> TxCertificates build Era
-> TxUpdateProposal Era
-> TxMintValue build
-> TxScriptValidity
-> Maybe
     (Featured ConwayEraOnwards Era (TxProposalProcedures build Era))
-> Maybe
     (Featured ConwayEraOnwards Era (TxVotingProcedures build Era))
-> Maybe (Featured ConwayEraOnwards Era (Maybe Coin))
-> Maybe (Featured ConwayEraOnwards Era Coin)
-> TxBodyContent build
TxBodyContent
      (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 out. UTxO' out -> Set TxIn
UTxO.inputSet UTxO
utxoToSpend))
      ([TxIn] -> TxInsCollateral
TxInsCollateral [TxIn]
collateral)
      TxInsReference BuildTx
forall build. TxInsReference build
TxInsReferenceNone
      [TxOut CtxTx]
outs
      TxTotalCollateral Era
forall era. TxTotalCollateral era
TxTotalCollateralNone
      TxReturnCollateral CtxTx Era
forall ctx era. TxReturnCollateral ctx era
TxReturnCollateralNone
      (Coin -> TxFee
TxFeeExplicit Coin
0)
      TxValidityLowerBound
TxValidityNoLowerBound
      TxValidityUpperBound
TxValidityNoUpperBound
      TxMetadataInEra
TxMetadataNone
      TxAuxScripts
TxAuxScriptsNone
      TxExtraKeyWitnesses
TxExtraKeyWitnessesNone
      (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 BuildTx Era
forall build era. TxWithdrawals build era
TxWithdrawalsNone
      TxCertificates BuildTx Era
forall build era. TxCertificates build era
TxCertificatesNone
      TxUpdateProposal Era
forall era. TxUpdateProposal era
TxUpdateProposalNone
      TxMintValue BuildTx
forall build. TxMintValue build
TxMintValueNone
      TxScriptValidity
TxScriptValidityNone
      Maybe
  (Featured ConwayEraOnwards Era (TxProposalProcedures BuildTx Era))
forall a. Maybe a
Nothing
      Maybe
  (Featured ConwayEraOnwards Era (TxVotingProcedures BuildTx Era))
forall a. Maybe a
Nothing
      Maybe (Featured ConwayEraOnwards Era (Maybe Coin))
forall a. Maybe a
Nothing
      Maybe (Featured ConwayEraOnwards Era Coin)
forall a. Maybe a
Nothing

buildTransactionWithBody ::
  -- | Protocol parameters
  PParams LedgerEra ->
  -- | System start
  SystemStart ->
  -- | Change address to send
  EraHistory ->
  Set PoolId ->
  AddressInEra ->
  -- | Body
  TxBodyContent BuildTx ->
  -- | Unspent transaction outputs to spend.
  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 Era
-> 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 -> UTxO Era
UTxO.toApi UTxO
utxoToSpend)
      TxBodyContent BuildTx
body
      AddressInEra
changeAddress
      Maybe Word
forall a. Maybe a
Nothing