-- | 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 Hydra.Cardano.Api (
  Key (..),
  NetworkId,
  PaymentKey,
  ShelleyWitnessSigningKey (WitnessPaymentKey),
  SigningKey,
  SocketPath,
  TxId,
  TxIn (..),
  TxIx (..),
  WitCtx (..),
  examplePlutusScriptAlwaysFails,
  getTxBody,
  getTxId,
  makeShelleyKeyWitness,
  makeSignedTransaction,
  mkScriptAddress,
  mkScriptRefV3,
  mkTxOutAutoBalance,
  mkVkAddress,
  selectLovelace,
  throwErrorAsException,
  txOutValue,
  pattern TxOutDatumNone,
 )
import Hydra.Chain.CardanoClient (
  QueryPoint (..),
  awaitTransaction,
  buildTransaction,
  queryProtocolParameters,
  queryUTxOByTxIn,
  queryUTxOFor,
  submitTransaction,
 )
import Hydra.Contract.Head qualified as Head
import Hydra.Plutus (commitValidatorScript, initialValidatorScript)
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.
--
-- NOTE: This is limited to an upper bound of 10 to not query too much before
-- providing an error.
--
-- NOTE: If this should change, make sure to update the command line help.
--
-- 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
txId = do
  UTxO' (TxOut CtxUTxO)
utxo <- IO (UTxO' (TxOut CtxUTxO)) -> m (UTxO' (TxOut CtxUTxO))
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (UTxO' (TxOut CtxUTxO)) -> m (UTxO' (TxOut CtxUTxO)))
-> IO (UTxO' (TxOut CtxUTxO)) -> m (UTxO' (TxOut CtxUTxO))
forall a b. (a -> b) -> a -> b
$ NetworkId
-> SocketPath -> QueryPoint -> [TxIn] -> IO (UTxO' (TxOut CtxUTxO))
queryUTxOByTxIn NetworkId
networkId SocketPath
socketPath QueryPoint
QueryTip [TxIn]
candidates
  case UTxO' (TxOut CtxUTxO)
-> Either NewScriptRegistryException ScriptRegistry
newScriptRegistry UTxO' (TxOut CtxUTxO)
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 -> TxIx -> TxIn
TxIn TxId
txId TxIx
ix | TxIx
ix <- [Word -> TxIx
TxIx Word
0 .. Word -> TxIx
TxIx Word
10]] -- Arbitrary but, high-enough.

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 StandardConway
pparams <- NetworkId -> SocketPath -> QueryPoint -> IO (PParams LedgerEra)
queryProtocolParameters NetworkId
networkId SocketPath
socketPath QueryPoint
QueryTip
  UTxO' (TxOut CtxUTxO)
utxo <- NetworkId
-> SocketPath
-> QueryPoint
-> VerificationKey PaymentKey
-> IO (UTxO' (TxOut CtxUTxO))
queryUTxOFor NetworkId
networkId SocketPath
socketPath QueryPoint
QueryTip VerificationKey PaymentKey
vk
  let outputs :: [TxOut CtxTx Era]
outputs =
        PParams StandardConway -> ReferenceScript Era -> TxOut CtxTx Era
mkScriptTxOut PParams StandardConway
pparams
          (ReferenceScript Era -> TxOut CtxTx Era)
-> [ReferenceScript Era] -> [TxOut CtxTx Era]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [ SerialisedScript -> ReferenceScript Era
mkScriptRefV3 SerialisedScript
initialValidatorScript
              , SerialisedScript -> ReferenceScript Era
mkScriptRefV3 SerialisedScript
commitValidatorScript
              , SerialisedScript -> ReferenceScript Era
mkScriptRefV3 SerialisedScript
Head.validatorScript
              ]
      totalDeposit :: Lovelace
totalDeposit = [Lovelace] -> Lovelace
forall a (f :: * -> *). (Foldable f, Num a) => f a -> a
sum (Value -> Lovelace
selectLovelace (Value -> Lovelace)
-> (TxOut CtxTx Era -> Value) -> TxOut CtxTx Era -> Lovelace
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TxOut CtxTx Era -> Value
forall ctx. TxOut ctx -> Value
txOutValue (TxOut CtxTx Era -> Lovelace) -> [TxOut CtxTx Era] -> [Lovelace]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [TxOut CtxTx Era]
outputs)
      someUTxO :: UTxO' (TxOut CtxUTxO)
someUTxO =
        UTxO' (TxOut CtxUTxO)
-> ((TxIn, TxOut CtxUTxO) -> UTxO' (TxOut CtxUTxO))
-> Maybe (TxIn, TxOut CtxUTxO)
-> UTxO' (TxOut CtxUTxO)
forall b a. b -> (a -> b) -> Maybe a -> b
maybe UTxO' (TxOut CtxUTxO)
forall a. Monoid a => a
mempty (TxIn, TxOut CtxUTxO) -> UTxO' (TxOut CtxUTxO)
forall out. (TxIn, out) -> UTxO' out
UTxO.singleton (Maybe (TxIn, TxOut CtxUTxO) -> UTxO' (TxOut CtxUTxO))
-> Maybe (TxIn, TxOut CtxUTxO) -> UTxO' (TxOut CtxUTxO)
forall a b. (a -> b) -> a -> b
$
          (TxOut CtxUTxO -> Bool)
-> UTxO' (TxOut CtxUTxO) -> Maybe (TxIn, TxOut CtxUTxO)
forall out. (out -> Bool) -> UTxO' out -> Maybe (TxIn, out)
UTxO.find (\TxOut CtxUTxO
o -> Value -> Lovelace
selectLovelace (TxOut CtxUTxO -> Value
forall ctx. TxOut ctx -> Value
txOutValue TxOut CtxUTxO
o) Lovelace -> Lovelace -> Bool
forall a. Ord a => a -> a -> Bool
> Lovelace
totalDeposit) UTxO' (TxOut CtxUTxO)
utxo
  NetworkId
-> SocketPath
-> AddressInEra
-> UTxO' (TxOut CtxUTxO)
-> [TxIn]
-> [TxOut CtxTx Era]
-> IO (Either (TxBodyErrorAutoBalance Era) Tx)
buildTransaction
    NetworkId
networkId
    SocketPath
socketPath
    AddressInEra
changeAddress
    UTxO' (TxOut CtxUTxO)
someUTxO
    []
    [TxOut CtxTx Era]
outputs
    IO (Either (TxBodyErrorAutoBalance Era) Tx)
-> (Either (TxBodyErrorAutoBalance Era) Tx -> IO TxId) -> IO TxId
forall a b. IO a -> (a -> IO b) -> IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
      Left TxBodyErrorAutoBalance Era
e ->
        TxBodyErrorAutoBalance Era -> IO TxId
forall e a. Error e => e -> IO a
throwErrorAsException TxBodyErrorAutoBalance Era
e
      Right Tx
x -> do
        let body :: TxBody Era
body = Tx -> TxBody Era
forall era. Tx era -> TxBody era
getTxBody Tx
x
        let tx :: Tx
tx = [KeyWitness Era] -> TxBody Era -> Tx
forall era. [KeyWitness era] -> TxBody era -> Tx era
makeSignedTransaction [TxBody Era -> ShelleyWitnessSigningKey -> KeyWitness Era
makeShelleyKeyWitness TxBody Era
body (SigningKey PaymentKey -> ShelleyWitnessSigningKey
WitnessPaymentKey SigningKey PaymentKey
sk)] TxBody Era
body
        NetworkId -> SocketPath -> Tx -> IO ()
submitTransaction NetworkId
networkId SocketPath
socketPath Tx
tx
        IO (UTxO' (TxOut CtxUTxO)) -> IO ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (IO (UTxO' (TxOut CtxUTxO)) -> IO ())
-> IO (UTxO' (TxOut CtxUTxO)) -> IO ()
forall a b. (a -> b) -> a -> b
$ NetworkId -> SocketPath -> Tx -> IO (UTxO' (TxOut CtxUTxO))
awaitTransaction NetworkId
networkId SocketPath
socketPath Tx
tx
        TxId -> IO TxId
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (TxId -> IO TxId) -> TxId -> IO TxId
forall a b. (a -> b) -> a -> b
$ TxBody Era -> TxId
forall era. TxBody era -> TxId
getTxId TxBody Era
body
 where
  vk :: VerificationKey PaymentKey
vk = SigningKey PaymentKey -> VerificationKey PaymentKey
forall keyrole.
(Key keyrole, HasTypeProxy keyrole) =>
SigningKey keyrole -> VerificationKey keyrole
getVerificationKey SigningKey PaymentKey
sk

  changeAddress :: AddressInEra
changeAddress = NetworkId -> VerificationKey PaymentKey -> AddressInEra
forall era.
IsShelleyBasedEra era =>
NetworkId -> VerificationKey PaymentKey -> AddressInEra era
mkVkAddress NetworkId
networkId VerificationKey PaymentKey
vk

  mkScriptTxOut :: PParams StandardConway -> ReferenceScript Era -> TxOut CtxTx Era
mkScriptTxOut PParams StandardConway
pparams =
    PParams LedgerEra
-> AddressInEra
-> Value
-> TxOutDatum CtxTx Era
-> ReferenceScript Era
-> TxOut CtxTx Era
mkTxOutAutoBalance
      PParams StandardConway
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