-- | 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 (
  Era,
  EraHistory,
  Key (..),
  LedgerEra,
  NetworkId,
  PParams,
  PaymentKey,
  PoolId,
  SigningKey,
  SocketPath,
  SystemStart,
  Tx,
  TxBodyErrorAutoBalance,
  TxId,
  TxIn (..),
  TxIx (..),
  UTxO,
  WitCtx (..),
  examplePlutusScriptAlwaysFails,
  mkScriptAddress,
  mkScriptRef,
  mkTxIn,
  mkTxOutAutoBalance,
  mkVkAddress,
  toCtxUTxOTxOut,
  txOuts',
  pattern TxOutDatumNone,
 )
import Hydra.Cardano.Api.Tx (signTx)
import Hydra.Chain.CardanoClient (
  QueryPoint (..),
  awaitTransaction,
  buildTransactionWithPParams',
  queryEraHistory,
  queryProtocolParameters,
  queryStakePools,
  querySystemStart,
  queryUTxOByTxIn,
  queryUTxOFor,
  submitTransaction,
 )
import Hydra.Contract.Head qualified as Head
import Hydra.Plutus (commitValidatorScript, initialValidatorScript)
import Hydra.Tx (txId)
import Hydra.Tx.ScriptRegistry (ScriptRegistry (..), newScriptRegistry)

-- | 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 ::
  (MonadIO m, MonadThrow m) =>
  -- | cardano-node's network identifier.
  -- A combination of network discriminant + magic number.
  NetworkId ->
  -- | Filepath to the cardano-node's domain socket
  SocketPath ->
  [TxId] ->
  m ScriptRegistry
queryScriptRegistry :: forall (m :: * -> *).
(MonadIO m, MonadThrow m) =>
NetworkId -> SocketPath -> [TxId] -> m ScriptRegistry
queryScriptRegistry NetworkId
networkId SocketPath
socketPath [TxId]
txIds = do
  UTxO
utxo <- IO UTxO -> m UTxO
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO UTxO -> m UTxO) -> IO UTxO -> m UTxO
forall a b. (a -> b) -> a -> b
$ NetworkId -> SocketPath -> QueryPoint -> [TxIn] -> IO UTxO
queryUTxOByTxIn NetworkId
networkId SocketPath
socketPath QueryPoint
QueryTip [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 ::
  -- | Expected network discriminant.
  NetworkId ->
  -- | Path to the cardano-node's domain socket
  SocketPath ->
  -- | Keys assumed to hold funds to pay for the publishing transaction.
  SigningKey PaymentKey ->
  IO [TxId]
publishHydraScripts :: NetworkId -> SocketPath -> SigningKey PaymentKey -> IO [TxId]
publishHydraScripts NetworkId
networkId SocketPath
socketPath SigningKey PaymentKey
sk = do
  PParams ConwayEra
pparams <- NetworkId -> SocketPath -> QueryPoint -> IO (PParams LedgerEra)
queryProtocolParameters NetworkId
networkId SocketPath
socketPath QueryPoint
QueryTip
  SystemStart
systemStart <- NetworkId -> SocketPath -> QueryPoint -> IO SystemStart
querySystemStart NetworkId
networkId SocketPath
socketPath QueryPoint
QueryTip
  EraHistory
eraHistory <- NetworkId -> SocketPath -> QueryPoint -> IO EraHistory
queryEraHistory NetworkId
networkId SocketPath
socketPath QueryPoint
QueryTip
  Set PoolId
stakePools <- NetworkId -> SocketPath -> QueryPoint -> IO (Set PoolId)
queryStakePools NetworkId
networkId SocketPath
socketPath QueryPoint
QueryTip
  UTxO
utxo <- NetworkId
-> SocketPath
-> QueryPoint
-> VerificationKey PaymentKey
-> IO UTxO
queryUTxOFor NetworkId
networkId SocketPath
socketPath QueryPoint
QueryTip VerificationKey PaymentKey
vk
  [Tx]
txs <- PParams LedgerEra
-> SystemStart
-> NetworkId
-> EraHistory
-> Set PoolId
-> UTxO
-> SigningKey PaymentKey
-> IO [Tx]
forall (m :: * -> *).
MonadThrow m =>
PParams LedgerEra
-> SystemStart
-> NetworkId
-> EraHistory
-> Set PoolId
-> UTxO
-> SigningKey PaymentKey
-> m [Tx]
buildScriptPublishingTxs PParams ConwayEra
PParams LedgerEra
pparams SystemStart
systemStart NetworkId
networkId EraHistory
eraHistory Set PoolId
stakePools UTxO
utxo SigningKey PaymentKey
sk
  [Tx] -> (Tx -> IO TxId) -> IO [TxId]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM [Tx]
txs ((Tx -> IO TxId) -> IO [TxId]) -> (Tx -> IO TxId) -> IO [TxId]
forall a b. (a -> b) -> a -> b
$ \Tx
tx -> do
    NetworkId -> SocketPath -> Tx -> IO ()
submitTransaction NetworkId
networkId SocketPath
socketPath Tx
tx
    IO UTxO -> IO ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (IO UTxO -> IO ()) -> IO UTxO -> IO ()
forall a b. (a -> b) -> a -> b
$ NetworkId -> SocketPath -> Tx -> IO UTxO
awaitTransaction NetworkId
networkId SocketPath
socketPath Tx
tx
    TxId -> IO TxId
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (TxId -> IO TxId) -> TxId -> IO 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 = SigningKey PaymentKey -> VerificationKey PaymentKey
forall keyrole.
(Key keyrole, HasTypeProxy keyrole) =>
SigningKey keyrole -> VerificationKey keyrole
getVerificationKey SigningKey PaymentKey
sk

-- | Exception raised when building the script publishing transactions.
newtype PublishScriptException
  = FailedToBuildPublishingTx (TxBodyErrorAutoBalance Era)
  deriving newtype (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)
  deriving anyclass (Show PublishScriptException
Typeable PublishScriptException
(Typeable PublishScriptException, Show PublishScriptException) =>
(PublishScriptException -> SomeException)
-> (SomeException -> Maybe PublishScriptException)
-> (PublishScriptException -> String)
-> Exception PublishScriptException
SomeException -> Maybe PublishScriptException
PublishScriptException -> String
PublishScriptException -> SomeException
forall e.
(Typeable e, Show e) =>
(e -> SomeException)
-> (SomeException -> Maybe e) -> (e -> String) -> Exception e
$ctoException :: PublishScriptException -> SomeException
toException :: PublishScriptException -> SomeException
$cfromException :: SomeException -> Maybe PublishScriptException
fromException :: SomeException -> Maybe PublishScriptException
$cdisplayException :: PublishScriptException -> String
displayException :: PublishScriptException -> String
Exception)

-- | 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.
  SigningKey PaymentKey ->
  m [Tx]
buildScriptPublishingTxs :: forall (m :: * -> *).
MonadThrow m =>
PParams LedgerEra
-> SystemStart
-> NetworkId
-> EraHistory
-> Set PoolId
-> UTxO
-> SigningKey PaymentKey
-> m [Tx]
buildScriptPublishingTxs PParams LedgerEra
pparams SystemStart
systemStart NetworkId
networkId EraHistory
eraHistory Set PoolId
stakePools UTxO
availableUTxO SigningKey PaymentKey
sk = do
  UTxO -> [TxOut CtxTx] -> m [Tx]
go UTxO
availableUTxO [TxOut CtxTx]
scriptOutputs
 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
initialValidatorScript, PlutusScript PlutusScriptV3
commitValidatorScript, PlutusScript PlutusScriptV3
Head.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
-> UTxO
-> [TxIn]
-> [TxOut CtxTx]
-> Either (TxBodyErrorAutoBalance Era) Tx
buildTransactionWithPParams' PParams LedgerEra
pparams SystemStart
systemStart EraHistory
eraHistory Set PoolId
stakePools AddressInEra
changeAddress UTxO
utxo [] [TxOut CtxTx
out] 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
$ SigningKey PaymentKey -> Tx -> Tx
forall era.
IsShelleyBasedEra era =>
SigningKey PaymentKey -> Tx era -> Tx era
signTx SigningKey PaymentKey
sk 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 out. TxIn -> out -> UTxO' out
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
changeAddress = NetworkId -> VerificationKey PaymentKey -> AddressInEra
forall era.
IsShelleyBasedEra era =>
NetworkId -> VerificationKey PaymentKey -> AddressInEra era
mkVkAddress NetworkId
networkId (SigningKey PaymentKey -> VerificationKey PaymentKey
forall keyrole.
(Key keyrole, HasTypeProxy keyrole) =>
SigningKey keyrole -> VerificationKey keyrole
getVerificationKey SigningKey PaymentKey
sk)

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

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