-- | 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 (
  AddressInEra,
  EraHistory,
  Key (..),
  LedgerEra,
  NetworkId,
  PParams,
  PaymentKey,
  PlutusScript,
  PoolId,
  ShelleyWitnessSigningKey (WitnessPaymentKey),
  SigningKey,
  SocketPath,
  SystemStart,
  Tx,
  TxBody,
  TxId,
  TxIn (..),
  TxIx (..),
  UTxO,
  WitCtx (..),
  examplePlutusScriptAlwaysFails,
  getTxBody,
  isKeyAddress,
  makeShelleyKeyWitness,
  makeSignedTransaction,
  mkScriptAddress,
  mkScriptRef,
  mkTxOutAutoBalance,
  mkVkAddress,
  selectLovelace,
  throwErrorAsException,
  txOutAddress,
  txOutValue,
  pattern TxOutDatumNone,
 )
import Hydra.Chain.CardanoClient (
  QueryPoint (..),
  awaitTransaction,
  buildTransactionWithPParams',
  queryEraHistory,
  queryProtocolParameters,
  queryStakePools,
  querySystemStart,
  queryUTxOByTxIn,
  queryUTxOFor,
  submitTransaction,
 )
import Hydra.Contract.Head qualified as Head
import Hydra.Ledger.Cardano (adjustUTxO)
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' (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 -> 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 StandardConway
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' (TxOut CtxUTxO)
utxo <- NetworkId
-> SocketPath
-> QueryPoint
-> VerificationKey PaymentKey
-> IO (UTxO' (TxOut CtxUTxO))
queryUTxOFor NetworkId
networkId SocketPath
socketPath QueryPoint
QueryTip VerificationKey PaymentKey
vk
  [Tx]
txs <- PParams LedgerEra
-> SystemStart
-> NetworkId
-> EraHistory
-> Set PoolId
-> UTxO' (TxOut CtxUTxO)
-> SigningKey PaymentKey
-> IO [Tx]
buildScriptPublishingTxs PParams StandardConway
PParams LedgerEra
pparams SystemStart
systemStart NetworkId
networkId EraHistory
eraHistory Set PoolId
stakePools UTxO' (TxOut CtxUTxO)
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' (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 (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

buildScriptPublishingTxs ::
  PParams LedgerEra ->
  SystemStart ->
  NetworkId ->
  EraHistory ->
  Set PoolId ->
  UTxO ->
  SigningKey PaymentKey ->
  IO [Tx]
buildScriptPublishingTxs :: PParams LedgerEra
-> SystemStart
-> NetworkId
-> EraHistory
-> Set PoolId
-> UTxO' (TxOut CtxUTxO)
-> SigningKey PaymentKey
-> IO [Tx]
buildScriptPublishingTxs PParams LedgerEra
pparams SystemStart
systemStart NetworkId
networkId EraHistory
eraHistory Set PoolId
stakePools UTxO' (TxOut CtxUTxO)
startUTxO SigningKey PaymentKey
sk =
  (StateT (UTxO' (TxOut CtxUTxO), [Tx]) IO [Tx]
 -> (UTxO' (TxOut CtxUTxO), [Tx]) -> IO [Tx])
-> (UTxO' (TxOut CtxUTxO), [Tx])
-> StateT (UTxO' (TxOut CtxUTxO), [Tx]) IO [Tx]
-> IO [Tx]
forall a b c. (a -> b -> c) -> b -> a -> c
flip StateT (UTxO' (TxOut CtxUTxO), [Tx]) IO [Tx]
-> (UTxO' (TxOut CtxUTxO), [Tx]) -> IO [Tx]
forall (m :: * -> *) s a. Monad m => StateT s m a -> s -> m a
evalStateT (UTxO' (TxOut CtxUTxO)
startUTxO, []) (StateT (UTxO' (TxOut CtxUTxO), [Tx]) IO [Tx] -> IO [Tx])
-> StateT (UTxO' (TxOut CtxUTxO), [Tx]) IO [Tx] -> IO [Tx]
forall a b. (a -> b) -> a -> b
$
    [PlutusScript]
-> (PlutusScript -> StateT (UTxO' (TxOut CtxUTxO), [Tx]) IO Tx)
-> StateT (UTxO' (TxOut CtxUTxO), [Tx]) IO [Tx]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM [PlutusScript]
scripts ((PlutusScript -> StateT (UTxO' (TxOut CtxUTxO), [Tx]) IO Tx)
 -> StateT (UTxO' (TxOut CtxUTxO), [Tx]) IO [Tx])
-> (PlutusScript -> StateT (UTxO' (TxOut CtxUTxO), [Tx]) IO Tx)
-> StateT (UTxO' (TxOut CtxUTxO), [Tx]) IO [Tx]
forall a b. (a -> b) -> a -> b
$ \PlutusScript
script -> do
      (UTxO' (TxOut CtxUTxO)
nextUTxO, [Tx]
_) <- StateT
  (UTxO' (TxOut CtxUTxO), [Tx]) IO (UTxO' (TxOut CtxUTxO), [Tx])
forall s (m :: * -> *). MonadState s m => m s
get
      (Tx
tx, TxBody
_, UTxO' (TxOut CtxUTxO)
spentUTxO) <- IO (Tx, TxBody, UTxO' (TxOut CtxUTxO))
-> StateT
     (UTxO' (TxOut CtxUTxO), [Tx])
     IO
     (Tx, TxBody, UTxO' (TxOut CtxUTxO))
forall a. IO a -> StateT (UTxO' (TxOut CtxUTxO), [Tx]) IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (Tx, TxBody, UTxO' (TxOut CtxUTxO))
 -> StateT
      (UTxO' (TxOut CtxUTxO), [Tx])
      IO
      (Tx, TxBody, UTxO' (TxOut CtxUTxO)))
-> IO (Tx, TxBody, UTxO' (TxOut CtxUTxO))
-> StateT
     (UTxO' (TxOut CtxUTxO), [Tx])
     IO
     (Tx, TxBody, UTxO' (TxOut CtxUTxO))
forall a b. (a -> b) -> a -> b
$ PParams LedgerEra
-> SystemStart
-> NetworkId
-> EraHistory
-> Set PoolId
-> AddressInEra
-> SigningKey PaymentKey
-> PlutusScript
-> UTxO' (TxOut CtxUTxO)
-> IO (Tx, TxBody, UTxO' (TxOut CtxUTxO))
buildScriptPublishingTx PParams LedgerEra
pparams SystemStart
systemStart NetworkId
networkId EraHistory
eraHistory Set PoolId
stakePools AddressInEra
changeAddress SigningKey PaymentKey
sk PlutusScript
script UTxO' (TxOut CtxUTxO)
nextUTxO
      ((UTxO' (TxOut CtxUTxO), [Tx]) -> (UTxO' (TxOut CtxUTxO), [Tx]))
-> StateT (UTxO' (TxOut CtxUTxO), [Tx]) IO ()
forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify' (\(UTxO' (TxOut CtxUTxO)
_, [Tx]
existingTxs) -> (UTxO' (TxOut CtxUTxO) -> UTxO' (TxOut CtxUTxO)
forall {ctx}. UTxO' (TxOut ctx) -> UTxO' (TxOut ctx)
pickKeyAddressUTxO (UTxO' (TxOut CtxUTxO) -> UTxO' (TxOut CtxUTxO))
-> UTxO' (TxOut CtxUTxO) -> UTxO' (TxOut CtxUTxO)
forall a b. (a -> b) -> a -> b
$ Tx -> UTxO' (TxOut CtxUTxO) -> UTxO' (TxOut CtxUTxO)
adjustUTxO Tx
tx UTxO' (TxOut CtxUTxO)
spentUTxO, Tx
tx Tx -> [Tx] -> [Tx]
forall a. a -> [a] -> [a]
: [Tx]
existingTxs))
      Tx -> StateT (UTxO' (TxOut CtxUTxO), [Tx]) IO Tx
forall a. a -> StateT (UTxO' (TxOut CtxUTxO), [Tx]) IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Tx
tx
 where
  pickKeyAddressUTxO :: UTxO' (TxOut ctx) -> UTxO' (TxOut ctx)
pickKeyAddressUTxO UTxO' (TxOut ctx)
utxo = UTxO' (TxOut ctx)
-> ((TxIn, TxOut ctx) -> UTxO' (TxOut ctx))
-> Maybe (TxIn, TxOut ctx)
-> UTxO' (TxOut ctx)
forall b a. b -> (a -> b) -> Maybe a -> b
maybe UTxO' (TxOut ctx)
forall a. Monoid a => a
mempty (TxIn, TxOut ctx) -> UTxO' (TxOut ctx)
forall out. (TxIn, out) -> UTxO' out
UTxO.singleton (Maybe (TxIn, TxOut ctx) -> UTxO' (TxOut ctx))
-> Maybe (TxIn, TxOut ctx) -> UTxO' (TxOut ctx)
forall a b. (a -> b) -> a -> b
$ ((TxIn, TxOut ctx) -> Bool)
-> UTxO' (TxOut ctx) -> Maybe (TxIn, TxOut ctx)
forall out. ((TxIn, out) -> Bool) -> UTxO' out -> Maybe (TxIn, out)
UTxO.findBy (\(TxIn
_, TxOut ctx
txOut) -> AddressInEra -> Bool
forall era. AddressInEra era -> Bool
isKeyAddress (TxOut ctx -> AddressInEra
forall ctx. TxOut ctx -> AddressInEra
txOutAddress TxOut ctx
txOut)) UTxO' (TxOut ctx)
utxo

  scripts :: [PlutusScript]
scripts = [PlutusScript
initialValidatorScript, PlutusScript
commitValidatorScript, PlutusScript
Head.validatorScript]

  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

buildScriptPublishingTx ::
  PParams LedgerEra ->
  SystemStart ->
  NetworkId ->
  EraHistory ->
  Set PoolId ->
  AddressInEra ->
  SigningKey PaymentKey ->
  PlutusScript ->
  UTxO.UTxO ->
  IO (Tx, TxBody, UTxO.UTxO)
buildScriptPublishingTx :: PParams LedgerEra
-> SystemStart
-> NetworkId
-> EraHistory
-> Set PoolId
-> AddressInEra
-> SigningKey PaymentKey
-> PlutusScript
-> UTxO' (TxOut CtxUTxO)
-> IO (Tx, TxBody, UTxO' (TxOut CtxUTxO))
buildScriptPublishingTx PParams LedgerEra
pparams SystemStart
systemStart NetworkId
networkId EraHistory
eraHistory Set PoolId
stakePools AddressInEra
changeAddress SigningKey PaymentKey
sk PlutusScript
script UTxO' (TxOut CtxUTxO)
utxo =
  let output :: [TxOut CtxTx Era]
output = ReferenceScript Era -> TxOut CtxTx Era
mkScriptTxOut (ReferenceScript Era -> TxOut CtxTx Era)
-> [ReferenceScript Era] -> [TxOut CtxTx Era]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [PlutusScript -> ReferenceScript Era
forall lang.
IsPlutusScriptLanguage lang =>
PlutusScript lang -> ReferenceScript Era
mkScriptRef PlutusScript
script]
      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]
output)
      utxoToSpend :: UTxO' (TxOut CtxUTxO)
utxoToSpend =
        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
   in case PParams LedgerEra
-> SystemStart
-> EraHistory
-> Set PoolId
-> AddressInEra
-> UTxO' (TxOut CtxUTxO)
-> [TxIn]
-> [TxOut CtxTx Era]
-> Either (TxBodyErrorAutoBalance Era) Tx
buildTransactionWithPParams' PParams LedgerEra
pparams SystemStart
systemStart EraHistory
eraHistory Set PoolId
stakePools AddressInEra
changeAddress UTxO' (TxOut CtxUTxO)
utxoToSpend [] [TxOut CtxTx Era]
output of
        Left TxBodyErrorAutoBalance Era
e -> TxBodyErrorAutoBalance Era
-> IO (Tx, TxBody, UTxO' (TxOut CtxUTxO))
forall e a. Error e => e -> IO a
throwErrorAsException TxBodyErrorAutoBalance Era
e
        Right Tx
rawTx -> do
          let body :: TxBody
body = Tx -> TxBody
forall era. Tx era -> TxBody era
getTxBody Tx
rawTx
          (Tx, TxBody, UTxO' (TxOut CtxUTxO))
-> IO (Tx, TxBody, UTxO' (TxOut CtxUTxO))
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ([KeyWitness Era] -> TxBody -> Tx
forall era. [KeyWitness era] -> TxBody era -> Tx era
makeSignedTransaction [TxBody -> ShelleyWitnessSigningKey -> KeyWitness Era
makeShelleyKeyWitness TxBody
body (SigningKey PaymentKey -> ShelleyWitnessSigningKey
WitnessPaymentKey SigningKey PaymentKey
sk)] TxBody
body, TxBody
body, UTxO' (TxOut CtxUTxO)
utxoToSpend)
 where
  mkScriptTxOut :: ReferenceScript Era -> TxOut CtxTx Era
mkScriptTxOut =
    PParams LedgerEra
-> AddressInEra
-> Value
-> TxOutDatum CtxTx Era
-> ReferenceScript Era
-> TxOut CtxTx Era
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