-- | A data-type to keep track of reference Hydra scripts published on-chain,
-- and needed to construct transactions leveraging reference inputs.
module Hydra.Chain.ScriptRegistry where

import Hydra.Prelude

import Cardano.Api.UTxO qualified as UTxO
import Data.List ((!!))
import Hydra.Cardano.Api (
  CardanoSigningKey,
  Era,
  EraHistory,
  LedgerEra,
  NetworkId,
  PParams,
  PoolId,
  SystemStart,
  Tx,
  TxBodyErrorAutoBalance,
  TxId,
  TxIn (..),
  TxIx (..),
  TxOutDatum,
  UTxO,
  WitCtx (..),
  examplePlutusScriptAlwaysFails,
  getCardanoPaymentVerificationKey,
  mkScriptAddress,
  mkScriptRef,
  mkTxIn,
  mkTxOutAutoBalance,
  mkVkAddress,
  serialiseAddress,
  signTxWith,
  toCtxUTxOTxOut,
  txOuts',
  pattern TxOutDatumNone,
 )
import Hydra.Chain.Backend (ChainBackend (..), buildTransactionWithPParams')
import Hydra.Chain.Blockfrost.Client (APIBlockfrostError (..), BlockfrostException (..))
import Hydra.Chain.CardanoClient (
  QueryPoint (..),
 )
import Hydra.Contract.CRS qualified as CRS
import Hydra.Contract.Head qualified as Head
import Hydra.Tx (txId)
import Hydra.Tx.Accumulator qualified as Accumulator
import Hydra.Tx.ScriptRegistry (ScriptRegistry (..), newScriptRegistry)
import Hydra.Tx.Secret (Secret, withSecret)

-- | Query for 'TxIn's in the search for outputs containing all the reference
-- scripts of the 'ScriptRegistry'.
--
-- This is implemented by repeated querying until we have all necessary
-- reference scripts as we do only know the transaction id, not the indices.
--
-- Can throw at least 'NewScriptRegistryException' on failure.
queryScriptRegistry ::
  (ChainBackend m, MonadThrow m) =>
  [TxId] ->
  m ScriptRegistry
queryScriptRegistry :: forall (m :: * -> *).
(ChainBackend m, MonadThrow m) =>
[TxId] -> m ScriptRegistry
queryScriptRegistry [TxId]
txIds = do
  UTxO
utxo <- [TxIn] -> m UTxO
forall (m :: * -> *). ChainBackend m => [TxIn] -> m UTxO
queryUTxOByTxIn [TxIn]
candidates
  case UTxO -> Either NewScriptRegistryException ScriptRegistry
newScriptRegistry UTxO
utxo of
    Left NewScriptRegistryException
e -> NewScriptRegistryException -> m ScriptRegistry
forall e a. Exception e => e -> m a
forall (m :: * -> *) e a. (MonadThrow m, Exception e) => e -> m a
throwIO NewScriptRegistryException
e
    Right ScriptRegistry
sr -> ScriptRegistry -> m ScriptRegistry
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ScriptRegistry
sr
 where
  candidates :: [TxIn]
candidates = (TxId -> TxIn) -> [TxId] -> [TxIn]
forall a b. (a -> b) -> [a] -> [b]
map (\TxId
txid -> TxId -> TxIx -> TxIn
TxIn TxId
txid (Word -> TxIx
TxIx Word
0)) [TxId]
txIds

publishHydraScripts ::
  (ChainBackend m, MonadIO m, MonadCatch m) =>
  -- | Keys assumed to hold funds to pay for the publishing transaction.
  Secret CardanoSigningKey ->
  m [TxId]
publishHydraScripts :: forall (m :: * -> *).
(ChainBackend m, MonadIO m, MonadCatch m) =>
Secret CardanoSigningKey -> m [TxId]
publishHydraScripts Secret CardanoSigningKey
sk = do
  NetworkId
networkId <- m NetworkId
forall (m :: * -> *). ChainBackend m => m NetworkId
queryNetworkId
  PParams ConwayEra
pparams <- QueryPoint -> m (PParams LedgerEra)
forall (m :: * -> *).
ChainBackend m =>
QueryPoint -> m (PParams LedgerEra)
queryProtocolParameters QueryPoint
QueryTip
  SystemStart
systemStart <- QueryPoint -> m SystemStart
forall (m :: * -> *). ChainBackend m => QueryPoint -> m SystemStart
querySystemStart QueryPoint
QueryTip
  EraHistory
eraHistory <- QueryPoint -> m EraHistory
forall (m :: * -> *). ChainBackend m => QueryPoint -> m EraHistory
queryEraHistory QueryPoint
QueryTip
  Set PoolId
stakePools <- QueryPoint -> m (Set PoolId)
forall (m :: * -> *).
ChainBackend m =>
QueryPoint -> m (Set PoolId)
queryStakePools QueryPoint
QueryTip
  UTxO
utxo <-
    QueryPoint -> VerificationKey PaymentKey -> m UTxO
forall (m :: * -> *).
ChainBackend m =>
QueryPoint -> VerificationKey PaymentKey -> m UTxO
queryUTxOFor QueryPoint
QueryTip VerificationKey PaymentKey
vk
      m UTxO -> (SomeException -> m UTxO) -> m UTxO
forall e a. Exception e => m a -> (e -> m a) -> m a
forall (m :: * -> *) e a.
(MonadCatch m, Exception e) =>
m a -> (e -> m a) -> m a
`catch` SomeException -> m UTxO
forall (m :: * -> *) a. MonadThrow m => SomeException -> m a
handleError

  [Tx]
txs <- PParams LedgerEra
-> SystemStart
-> NetworkId
-> EraHistory
-> Set PoolId
-> UTxO
-> Secret CardanoSigningKey
-> m [Tx]
forall (m :: * -> *).
MonadThrow m =>
PParams LedgerEra
-> SystemStart
-> NetworkId
-> EraHistory
-> Set PoolId
-> UTxO
-> Secret CardanoSigningKey
-> m [Tx]
buildScriptPublishingTxs PParams ConwayEra
PParams LedgerEra
pparams SystemStart
systemStart NetworkId
networkId EraHistory
eraHistory Set PoolId
stakePools UTxO
utxo Secret CardanoSigningKey
sk
  [Tx] -> (Tx -> m TxId) -> m [TxId]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM [Tx]
txs ((Tx -> m TxId) -> m [TxId]) -> (Tx -> m TxId) -> m [TxId]
forall a b. (a -> b) -> a -> b
$ \Tx
tx -> do
    Tx -> m ()
forall (m :: * -> *). ChainBackend m => Tx -> m ()
submitTransaction Tx
tx
    m UTxO -> m ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (m UTxO -> m ()) -> m UTxO -> m ()
forall a b. (a -> b) -> a -> b
$ Tx -> VerificationKey PaymentKey -> m UTxO
forall (m :: * -> *).
ChainBackend m =>
Tx -> VerificationKey PaymentKey -> m UTxO
awaitTransaction Tx
tx VerificationKey PaymentKey
vk
    TxId -> m TxId
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (TxId -> m TxId) -> TxId -> m TxId
forall a b. (a -> b) -> a -> b
$ Tx -> TxIdType Tx
forall tx. IsTx tx => tx -> TxIdType tx
txId Tx
tx
 where
  vk :: VerificationKey PaymentKey
vk = Secret CardanoSigningKey
-> (CardanoSigningKey -> VerificationKey PaymentKey)
-> VerificationKey PaymentKey
forall a r. Secret a -> (a -> r) -> r
withSecret Secret CardanoSigningKey
sk CardanoSigningKey -> VerificationKey PaymentKey
getCardanoPaymentVerificationKey

handleError :: MonadThrow m => SomeException -> m a
handleError :: forall (m :: * -> *) a. MonadThrow m => SomeException -> m a
handleError SomeException
e =
  case SomeException -> Maybe APIBlockfrostError
forall e. Exception e => SomeException -> Maybe e
fromException SomeException
e of
    Just (BlockfrostClientError (NoUTxOFound Address ShelleyAddr
addr)) ->
      PublishScriptException -> m a
forall e a. Exception e => e -> m a
forall (m :: * -> *) e a. (MonadThrow m, Exception e) => e -> m a
throwIO (PublishScriptException -> m a) -> PublishScriptException -> m a
forall a b. (a -> b) -> a -> b
$ Text -> PublishScriptException
PublishingFundsMissing (Address ShelleyAddr -> Text
forall addr. SerialiseAddress addr => addr -> Text
serialiseAddress Address ShelleyAddr
addr)
    Maybe APIBlockfrostError
_ ->
      SomeException -> m a
forall e a. Exception e => e -> m a
forall (m :: * -> *) e a. (MonadThrow m, Exception e) => e -> m a
throwIO SomeException
e

-- | Exception raised when publishing Hydra scripts.
data PublishScriptException
  = PublishingFundsMissing Text
  | FailedToBuildPublishingTx (TxBodyErrorAutoBalance Era)
  deriving stock (Int -> PublishScriptException -> ShowS
[PublishScriptException] -> ShowS
PublishScriptException -> String
(Int -> PublishScriptException -> ShowS)
-> (PublishScriptException -> String)
-> ([PublishScriptException] -> ShowS)
-> Show PublishScriptException
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> PublishScriptException -> ShowS
showsPrec :: Int -> PublishScriptException -> ShowS
$cshow :: PublishScriptException -> String
show :: PublishScriptException -> String
$cshowList :: [PublishScriptException] -> ShowS
showList :: [PublishScriptException] -> ShowS
Show)

instance Exception PublishScriptException where
  displayException :: PublishScriptException -> String
displayException = \case
    FailedToBuildPublishingTx TxBodyErrorAutoBalance Era
e ->
      String
"Failed to build publishing transaction: " String -> ShowS
forall a. Semigroup a => a -> a -> a
<> TxBodyErrorAutoBalance Era -> String
forall b a. (Show a, IsString b) => a -> b
show TxBodyErrorAutoBalance Era
e
    PublishingFundsMissing Text
addr ->
      String
"Could not find any funds for address "
        String -> ShowS
forall a. Semigroup a => a -> a -> a
<> Text -> String
forall a. ToString a => a -> String
toString Text
addr
        String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
". Please ensure the address has funds and is on-chain."

-- | Builds a chain of script publishing transactions.
-- Throws: PublishScriptException
buildScriptPublishingTxs ::
  MonadThrow m =>
  PParams LedgerEra ->
  SystemStart ->
  NetworkId ->
  EraHistory ->
  Set PoolId ->
  -- | Outputs that can be spent by signing key.
  UTxO ->
  -- | Key owning funds to pay deposit and fees.
  Secret CardanoSigningKey ->
  m [Tx]
buildScriptPublishingTxs :: forall (m :: * -> *).
MonadThrow m =>
PParams LedgerEra
-> SystemStart
-> NetworkId
-> EraHistory
-> Set PoolId
-> UTxO
-> Secret CardanoSigningKey
-> m [Tx]
buildScriptPublishingTxs PParams LedgerEra
pparams SystemStart
systemStart NetworkId
networkId EraHistory
eraHistory Set PoolId
stakePools UTxO
availableUTxO Secret CardanoSigningKey
sk = do
  UTxO -> [TxOut CtxTx] -> m [Tx]
go UTxO
availableUTxO ([TxOut CtxTx]
scriptOutputs [TxOut CtxTx] -> [TxOut CtxTx] -> [TxOut CtxTx]
forall a. Semigroup a => a -> a -> a
<> [TxOut CtxTx]
scriptOutputsWithDatum)
 where
  scriptOutputs :: [TxOut CtxTx]
scriptOutputs =
    ReferenceScript Era -> TxOut CtxTx
mkScriptTxOut (ReferenceScript Era -> TxOut CtxTx)
-> (PlutusScript PlutusScriptV3 -> ReferenceScript Era)
-> PlutusScript PlutusScriptV3
-> TxOut CtxTx
forall b c a. (b -> c) -> (a -> b) -> a -> c
. PlutusScript PlutusScriptV3 -> ReferenceScript Era
forall lang.
IsPlutusScriptLanguage lang =>
PlutusScript lang -> ReferenceScript Era
mkScriptRef
      (PlutusScript PlutusScriptV3 -> TxOut CtxTx)
-> [PlutusScript PlutusScriptV3] -> [TxOut CtxTx]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [PlutusScript PlutusScriptV3
Head.validatorScript]

  scriptOutputsWithDatum :: [TxOut CtxTx]
scriptOutputsWithDatum =
    let crsDatum :: TxOutDatum ctx
        crsDatum :: forall ctx. TxOutDatum ctx
crsDatum = Int -> TxOutDatum ctx
forall ctx. Int -> TxOutDatum ctx
Accumulator.createCRSG2Datum Int
Accumulator.defaultItems
     in [PParams LedgerEra
-> AddressInEra Era
-> Value
-> TxOutDatum CtxTx Era
-> ReferenceScript Era
-> TxOut CtxTx
mkTxOutAutoBalance PParams LedgerEra
pparams AddressInEra Era
crsScriptAddress Value
forall a. Monoid a => a
mempty TxOutDatum CtxTx Era
forall ctx. TxOutDatum ctx
crsDatum (PlutusScript PlutusScriptV3 -> ReferenceScript Era
forall lang.
IsPlutusScriptLanguage lang =>
PlutusScript lang -> ReferenceScript Era
mkScriptRef PlutusScript PlutusScriptV3
CRS.validatorScript)]

  -- Loop over all script outputs to create while re-spending the change output.
  -- Note that we spend the entire UTxO set to cover the deposit scripts, resulting in a squashed UTxO at the end.
  go :: UTxO -> [TxOut CtxTx] -> m [Tx]
go UTxO
_ [] = [Tx] -> m [Tx]
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure []
  go UTxO
utxo (TxOut CtxTx
out : [TxOut CtxTx]
rest) = do
    Tx
tx <- case PParams LedgerEra
-> SystemStart
-> EraHistory
-> Set PoolId
-> AddressInEra Era
-> UTxO
-> [TxIn]
-> [TxOut CtxTx]
-> Maybe (PlutusScript PlutusScriptV3)
-> Either (TxBodyErrorAutoBalance Era) Tx
buildTransactionWithPParams' PParams LedgerEra
pparams SystemStart
systemStart EraHistory
eraHistory Set PoolId
stakePools AddressInEra Era
changeAddress UTxO
utxo [] [TxOut CtxTx
out] Maybe (PlutusScript PlutusScriptV3)
forall a. Maybe a
Nothing of
      Left TxBodyErrorAutoBalance Era
err -> PublishScriptException -> m Tx
forall e a. Exception e => e -> m a
forall (m :: * -> *) e a. (MonadThrow m, Exception e) => e -> m a
throwIO (PublishScriptException -> m Tx) -> PublishScriptException -> m Tx
forall a b. (a -> b) -> a -> b
$ TxBodyErrorAutoBalance Era -> PublishScriptException
FailedToBuildPublishingTx TxBodyErrorAutoBalance Era
err
      Right Tx
tx -> Tx -> m Tx
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Tx -> m Tx) -> Tx -> m Tx
forall a b. (a -> b) -> a -> b
$ Secret CardanoSigningKey -> (CardanoSigningKey -> Tx) -> Tx
forall a r. Secret a -> (a -> r) -> r
withSecret Secret CardanoSigningKey
sk (CardanoSigningKey -> Tx -> Tx
forall era.
IsShelleyBasedEra era =>
CardanoSigningKey -> Tx era -> Tx era
`signTxWith` Tx
tx)

    let changeOutput :: TxOut CtxTx
changeOutput = Tx -> [TxOut CtxTx]
forall era. Tx era -> [TxOut CtxTx era]
txOuts' Tx
tx [TxOut CtxTx] -> Int -> TxOut CtxTx
forall a. HasCallStack => [a] -> Int -> a
!! Int
1
        utxo' :: UTxO
utxo' = TxIn -> TxOut CtxUTxO Era -> UTxO
forall era. TxIn -> TxOut CtxUTxO era -> UTxO era
UTxO.singleton (Tx -> Word -> TxIn
forall era. Tx era -> Word -> TxIn
mkTxIn Tx
tx Word
1) (TxOut CtxTx -> TxOut CtxUTxO Era
forall era. TxOut CtxTx era -> TxOut CtxUTxO era
toCtxUTxOTxOut TxOut CtxTx
changeOutput)
    (Tx
tx :) ([Tx] -> [Tx]) -> m [Tx] -> m [Tx]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> UTxO -> [TxOut CtxTx] -> m [Tx]
go UTxO
utxo' [TxOut CtxTx]
rest

  changeAddress :: AddressInEra Era
changeAddress = NetworkId -> VerificationKey PaymentKey -> AddressInEra Era
forall era.
IsShelleyBasedEra era =>
NetworkId -> VerificationKey PaymentKey -> AddressInEra era
mkVkAddress NetworkId
networkId (Secret CardanoSigningKey
-> (CardanoSigningKey -> VerificationKey PaymentKey)
-> VerificationKey PaymentKey
forall a r. Secret a -> (a -> r) -> r
withSecret Secret CardanoSigningKey
sk CardanoSigningKey -> VerificationKey PaymentKey
getCardanoPaymentVerificationKey)

  mkScriptTxOut :: ReferenceScript Era -> TxOut CtxTx
mkScriptTxOut = PParams LedgerEra
-> AddressInEra Era
-> Value
-> TxOutDatum CtxTx Era
-> ReferenceScript Era
-> TxOut CtxTx
mkTxOutAutoBalance PParams LedgerEra
pparams AddressInEra Era
unspendableScriptAddress Value
forall a. Monoid a => a
mempty TxOutDatum CtxTx Era
forall ctx. TxOutDatum ctx
TxOutDatumNone

  unspendableScriptAddress :: AddressInEra Era
unspendableScriptAddress =
    NetworkId -> PlutusScript PlutusScriptV1 -> AddressInEra Era
forall lang era.
(IsShelleyBasedEra era, IsPlutusScriptLanguage lang) =>
NetworkId -> PlutusScript lang -> AddressInEra era
mkScriptAddress NetworkId
networkId (PlutusScript PlutusScriptV1 -> AddressInEra Era)
-> PlutusScript PlutusScriptV1 -> AddressInEra Era
forall a b. (a -> b) -> a -> b
$ WitCtx WitCtxTxIn -> PlutusScript PlutusScriptV1
forall witctx. WitCtx witctx -> PlutusScript PlutusScriptV1
examplePlutusScriptAlwaysFails WitCtx WitCtxTxIn
WitCtxTxIn

  crsScriptAddress :: AddressInEra Era
crsScriptAddress =
    NetworkId -> PlutusScript PlutusScriptV3 -> AddressInEra Era
forall lang era.
(IsShelleyBasedEra era, IsPlutusScriptLanguage lang) =>
NetworkId -> PlutusScript lang -> AddressInEra era
mkScriptAddress NetworkId
networkId PlutusScript PlutusScriptV3
CRS.validatorScript