{-# LANGUAGE DuplicateRecordFields #-}

-- | A cardano-node client used in end-to-end tests and benchmarks.
--
-- This modules contains some more functions besides the re-exported basic
-- querying of hydra-node's 'Hydra.Chain.CardanoClient'.
module CardanoClient (
  module Hydra.Chain.CardanoClient,
  module CardanoClient,
) where

import Hydra.Prelude

import Hydra.Cardano.Api hiding (Block)
import Hydra.Chain.Backend qualified as Backend
import Hydra.Chain.CardanoClient

import Cardano.Api.UTxO qualified as UTxO
import Data.Map qualified as Map
import Hydra.Chain.Backend (ChainBackend)
import Hydra.Chain.CardanoClient qualified as CardanoClient

-- TODO(SN): DRY with Hydra.Cardano.Api

-- | Build an address give a key.
--
-- From <runAddressBuild https://github.com/input-output-hk/cardano-node/blob/master/cardano-cli/src/Cardano/CLI/Shelley/Run/Address.hs#L106>
-- Throws 'CardanoClientException' if the query fails.
buildAddress :: VerificationKey PaymentKey -> NetworkId -> Address ShelleyAddr
buildAddress :: VerificationKey PaymentKey -> NetworkId -> Address ShelleyAddr
buildAddress VerificationKey PaymentKey
vKey NetworkId
networkId =
  NetworkId
-> PaymentCredential
-> StakeAddressReference
-> Address ShelleyAddr
makeShelleyAddress NetworkId
networkId (Hash PaymentKey -> PaymentCredential
PaymentCredentialByKey (Hash PaymentKey -> PaymentCredential)
-> Hash PaymentKey -> PaymentCredential
forall a b. (a -> b) -> a -> b
$ VerificationKey PaymentKey -> Hash PaymentKey
forall keyrole.
Key keyrole =>
VerificationKey keyrole -> Hash keyrole
verificationKeyHash VerificationKey PaymentKey
vKey) StakeAddressReference
NoStakeAddress

-- | Sign a transaction body with given signing key.
sign :: SigningKey PaymentKey -> TxBody -> Tx
sign :: SigningKey PaymentKey -> TxBody -> Tx
sign SigningKey PaymentKey
signingKey TxBody
body =
  [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
signingKey)]
    TxBody
body

-- | Wait until the specified Address has received payments, visible on-chain,
-- for the specified Lovelace amount. Returns the UTxO set containing all payments
-- with the same Lovelace amount at the given Address.
--
-- Note that this function loops indefinitely; therefore, it's recommended to use
-- it with a surrounding timeout mechanism.
waitForPayments ::
  ChainBackend backend =>
  backend ->
  Coin ->
  Address ShelleyAddr ->
  IO UTxO
waitForPayments :: forall backend.
ChainBackend backend =>
backend -> Coin -> Address ShelleyAddr -> IO UTxO
waitForPayments backend
backend Coin
amount Address ShelleyAddr
addr =
  IO UTxO
go
 where
  go :: IO UTxO
go = do
    UTxO
utxo <- backend -> [Address ShelleyAddr] -> IO UTxO
forall a (m :: * -> *).
(ChainBackend a, MonadIO m, MonadThrow m) =>
a -> [Address ShelleyAddr] -> m UTxO
forall (m :: * -> *).
(MonadIO m, MonadThrow m) =>
backend -> [Address ShelleyAddr] -> m UTxO
Backend.queryUTxO backend
backend [Address ShelleyAddr
addr]
    let expectedPayments :: Map TxIn (TxOut CtxUTxO)
expectedPayments = UTxO -> Map TxIn (TxOut CtxUTxO)
selectPayments UTxO
utxo
    if Map TxIn (TxOut CtxUTxO)
expectedPayments Map TxIn (TxOut CtxUTxO) -> Map TxIn (TxOut CtxUTxO) -> Bool
forall a. Eq a => a -> a -> Bool
/= Map TxIn (TxOut CtxUTxO)
forall a. Monoid a => a
mempty
      then UTxO -> IO UTxO
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (UTxO -> IO UTxO) -> UTxO -> IO UTxO
forall a b. (a -> b) -> a -> b
$ Map TxIn (TxOut CtxUTxO) -> UTxO
forall out. Map TxIn out -> UTxO' out
UTxO Map TxIn (TxOut CtxUTxO)
expectedPayments
      else DiffTime -> IO ()
forall (m :: * -> *). MonadDelay m => DiffTime -> m ()
threadDelay DiffTime
1 IO () -> IO UTxO -> IO UTxO
forall a b. IO a -> IO b -> IO b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> IO UTxO
go

  selectPayments :: UTxO -> Map TxIn (TxOut CtxUTxO)
selectPayments (UTxO Map TxIn (TxOut CtxUTxO)
utxo) =
    (TxOut CtxUTxO -> Bool)
-> Map TxIn (TxOut CtxUTxO) -> Map TxIn (TxOut CtxUTxO)
forall a k. (a -> Bool) -> Map k a -> Map k a
Map.filter ((Coin -> Coin -> Bool
forall a. Eq a => a -> a -> Bool
== Coin
amount) (Coin -> Bool) -> (TxOut CtxUTxO -> Coin) -> TxOut CtxUTxO -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Value -> Coin
selectLovelace (Value -> Coin)
-> (TxOut CtxUTxO -> Value) -> TxOut CtxUTxO -> Coin
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TxOut CtxUTxO -> Value
forall ctx. TxOut ctx -> Value
txOutValue) Map TxIn (TxOut CtxUTxO)
utxo

-- | Wait for transaction outputs with matching lovelace value and addresses of
-- the whole given UTxO
waitForUTxO ::
  ChainBackend backend =>
  backend ->
  UTxO ->
  IO ()
waitForUTxO :: forall backend. ChainBackend backend => backend -> UTxO -> IO ()
waitForUTxO backend
backend UTxO
utxo =
  [TxOut CtxUTxO] -> (TxOut CtxUTxO -> IO ()) -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ ((TxIn, TxOut CtxUTxO) -> TxOut CtxUTxO
forall a b. (a, b) -> b
snd ((TxIn, TxOut CtxUTxO) -> TxOut CtxUTxO)
-> [(TxIn, TxOut CtxUTxO)] -> [TxOut CtxUTxO]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> UTxO -> [(TxIn, TxOut CtxUTxO)]
forall out. UTxO' out -> [(TxIn, out)]
UTxO.toList UTxO
utxo) TxOut CtxUTxO -> IO ()
forEachUTxO
 where
  forEachUTxO :: TxOut CtxUTxO -> IO ()
  forEachUTxO :: TxOut CtxUTxO -> IO ()
forEachUTxO = \case
    TxOut (ShelleyAddressInEra addr :: Address ShelleyAddr
addr@ShelleyAddress{}) Value
value TxOutDatum CtxUTxO
_ ReferenceScript
_ -> do
      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
$
        backend -> Coin -> Address ShelleyAddr -> IO UTxO
forall backend.
ChainBackend backend =>
backend -> Coin -> Address ShelleyAddr -> IO UTxO
waitForPayments
          backend
backend
          (Value -> Coin
selectLovelace Value
value)
          Address ShelleyAddr
addr
    TxOut CtxUTxO
txOut ->
      Text -> IO ()
forall a t. (HasCallStack, IsText t) => t -> a
error (Text -> IO ()) -> Text -> IO ()
forall a b. (a -> b) -> a -> b
$ Text
"Unexpected TxOut " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> TxOut CtxUTxO -> Text
forall b a. (Show a, IsString b) => a -> b
show TxOut CtxUTxO
txOut

mkGenesisTx ::
  NetworkId ->
  -- | Owner of the 'initialFund'.
  SigningKey PaymentKey ->
  -- | Amount of initialFunds
  Coin ->
  -- | Recipients and amounts to pay in this transaction.
  [(VerificationKey PaymentKey, Coin)] ->
  Tx
mkGenesisTx :: NetworkId
-> SigningKey PaymentKey
-> Coin
-> [(VerificationKey PaymentKey, Coin)]
-> Tx
mkGenesisTx NetworkId
networkId SigningKey PaymentKey
signingKey Coin
initialAmount [(VerificationKey PaymentKey, Coin)]
recipients =
  case TxBodyContent BuildTx -> Either TxBodyError TxBody
createAndValidateTransactionBody TxBodyContent BuildTx
body of
    Left TxBodyError
err -> Text -> Tx
forall a t. (HasCallStack, IsText t) => t -> a
error (Text -> Tx) -> Text -> Tx
forall a b. (a -> b) -> a -> b
$ Text
"Fail to build genesis transactions: " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> TxBodyError -> Text
forall b a. (Show a, IsString b) => a -> b
show TxBodyError
err
    Right TxBody
tx -> SigningKey PaymentKey -> TxBody -> Tx
sign SigningKey PaymentKey
signingKey TxBody
tx
 where
  body :: TxBodyContent BuildTx
body =
    TxBodyContent BuildTx
defaultTxBodyContent
      TxBodyContent BuildTx
-> (TxBodyContent BuildTx -> TxBodyContent BuildTx)
-> TxBodyContent BuildTx
forall a b. a -> (a -> b) -> b
& TxIns BuildTx Era -> TxBodyContent BuildTx -> TxBodyContent BuildTx
forall build era.
TxIns build era
-> TxBodyContent build era -> TxBodyContent build era
setTxIns [(TxIn
initialInput, Witness WitCtxTxIn Era
-> BuildTxWith BuildTx (Witness WitCtxTxIn Era)
forall a. a -> BuildTxWith BuildTx a
BuildTxWith (Witness WitCtxTxIn Era
 -> BuildTxWith BuildTx (Witness WitCtxTxIn Era))
-> Witness WitCtxTxIn Era
-> BuildTxWith BuildTx (Witness WitCtxTxIn Era)
forall a b. (a -> b) -> a -> b
$ KeyWitnessInCtx WitCtxTxIn -> Witness WitCtxTxIn Era
forall ctx. KeyWitnessInCtx ctx -> Witness ctx
KeyWitness KeyWitnessInCtx WitCtxTxIn
KeyWitnessForSpending)]
      TxBodyContent BuildTx
-> (TxBodyContent BuildTx -> TxBodyContent BuildTx)
-> TxBodyContent BuildTx
forall a b. a -> (a -> b) -> b
& [TxOut CtxTx Era] -> TxBodyContent BuildTx -> TxBodyContent BuildTx
forall era build.
[TxOut CtxTx era]
-> TxBodyContent build era -> TxBodyContent build era
setTxOuts ([TxOut CtxTx Era]
recipientOutputs [TxOut CtxTx Era] -> [TxOut CtxTx Era] -> [TxOut CtxTx Era]
forall a. Semigroup a => a -> a -> a
<> [TxOut CtxTx Era
changeOutput])
      TxBodyContent BuildTx
-> (TxBodyContent BuildTx -> TxBodyContent BuildTx)
-> TxBodyContent BuildTx
forall a b. a -> (a -> b) -> b
& TxFee Era -> TxBodyContent BuildTx -> TxBodyContent BuildTx
forall era build.
TxFee era -> TxBodyContent build era -> TxBodyContent build era
setTxFee (Coin -> TxFee Era
TxFeeExplicit Coin
2_000_000)

  initialInput :: TxIn
initialInput =
    NetworkId -> Hash GenesisUTxOKey -> TxIn
genesisUTxOPseudoTxIn
      NetworkId
networkId
      (Hash PaymentKey -> Hash GenesisUTxOKey
forall a b.
(SerialiseAsCBOR (Hash a), SerialiseAsCBOR (Hash b),
 HasCallStack) =>
Hash a -> Hash b
unsafeCastHash (Hash PaymentKey -> Hash GenesisUTxOKey)
-> Hash PaymentKey -> Hash GenesisUTxOKey
forall a b. (a -> b) -> a -> b
$ VerificationKey PaymentKey -> Hash PaymentKey
forall keyrole.
Key keyrole =>
VerificationKey keyrole -> Hash keyrole
verificationKeyHash (VerificationKey PaymentKey -> Hash PaymentKey)
-> VerificationKey PaymentKey -> Hash PaymentKey
forall a b. (a -> b) -> a -> b
$ SigningKey PaymentKey -> VerificationKey PaymentKey
forall keyrole.
(Key keyrole, HasTypeProxy keyrole) =>
SigningKey keyrole -> VerificationKey keyrole
getVerificationKey SigningKey PaymentKey
signingKey)

  fee :: Coin
fee = Coin
2_000_000

  totalSent :: Coin
totalSent = ((VerificationKey PaymentKey, Coin) -> Coin)
-> [(VerificationKey PaymentKey, Coin)] -> Coin
forall m a. Monoid m => (a -> m) -> [a] -> m
forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap (VerificationKey PaymentKey, Coin) -> Coin
forall a b. (a, b) -> b
snd [(VerificationKey PaymentKey, Coin)]
recipients

  changeAddr :: AddressInEra
changeAddr = 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
signingKey)

  changeOutput :: TxOut CtxTx Era
changeOutput =
    AddressInEra
-> Value -> TxOutDatum CtxTx -> ReferenceScript -> TxOut CtxTx Era
forall ctx.
AddressInEra
-> Value -> TxOutDatum ctx -> ReferenceScript -> TxOut ctx
TxOut
      AddressInEra
changeAddr
      (Coin -> Value
lovelaceToValue (Coin -> Value) -> Coin -> Value
forall a b. (a -> b) -> a -> b
$ Coin
initialAmount Coin -> Coin -> Coin
forall a. Num a => a -> a -> a
- Coin
totalSent Coin -> Coin -> Coin
forall a. Num a => a -> a -> a
- Coin
fee)
      TxOutDatum CtxTx
forall ctx. TxOutDatum ctx
TxOutDatumNone
      ReferenceScript
ReferenceScriptNone

  recipientOutputs :: [TxOut CtxTx Era]
recipientOutputs =
    (((VerificationKey PaymentKey, Coin) -> TxOut CtxTx Era)
 -> [(VerificationKey PaymentKey, Coin)] -> [TxOut CtxTx Era])
-> [(VerificationKey PaymentKey, Coin)]
-> ((VerificationKey PaymentKey, Coin) -> TxOut CtxTx Era)
-> [TxOut CtxTx Era]
forall a b c. (a -> b -> c) -> b -> a -> c
flip ((VerificationKey PaymentKey, Coin) -> TxOut CtxTx Era)
-> [(VerificationKey PaymentKey, Coin)] -> [TxOut CtxTx Era]
forall a b. (a -> b) -> [a] -> [b]
map [(VerificationKey PaymentKey, Coin)]
recipients (((VerificationKey PaymentKey, Coin) -> TxOut CtxTx Era)
 -> [TxOut CtxTx Era])
-> ((VerificationKey PaymentKey, Coin) -> TxOut CtxTx Era)
-> [TxOut CtxTx Era]
forall a b. (a -> b) -> a -> b
$ \(VerificationKey PaymentKey
vk, Coin
ll) ->
      AddressInEra
-> Value -> TxOutDatum CtxTx -> ReferenceScript -> TxOut CtxTx Era
forall ctx.
AddressInEra
-> Value -> TxOutDatum ctx -> ReferenceScript -> TxOut ctx
TxOut
        (NetworkId -> VerificationKey PaymentKey -> AddressInEra
forall era.
IsShelleyBasedEra era =>
NetworkId -> VerificationKey PaymentKey -> AddressInEra era
mkVkAddress NetworkId
networkId VerificationKey PaymentKey
vk)
        (Coin -> Value
lovelaceToValue Coin
ll)
        TxOutDatum CtxTx
forall ctx. TxOutDatum ctx
TxOutDatumNone
        ReferenceScript
ReferenceScriptNone

data RunningNode = RunningNode
  { RunningNode -> SocketPath
nodeSocket :: SocketPath
  , RunningNode -> NetworkId
networkId :: NetworkId
  , RunningNode -> NominalDiffTime
blockTime :: NominalDiffTime
  -- ^ Expected time between blocks (varies a lot on testnets)
  }
  deriving (Int -> RunningNode -> ShowS
[RunningNode] -> ShowS
RunningNode -> String
(Int -> RunningNode -> ShowS)
-> (RunningNode -> String)
-> ([RunningNode] -> ShowS)
-> Show RunningNode
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> RunningNode -> ShowS
showsPrec :: Int -> RunningNode -> ShowS
$cshow :: RunningNode -> String
show :: RunningNode -> String
$cshowList :: [RunningNode] -> ShowS
showList :: [RunningNode] -> ShowS
Show, RunningNode -> RunningNode -> Bool
(RunningNode -> RunningNode -> Bool)
-> (RunningNode -> RunningNode -> Bool) -> Eq RunningNode
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: RunningNode -> RunningNode -> Bool
== :: RunningNode -> RunningNode -> Bool
$c/= :: RunningNode -> RunningNode -> Bool
/= :: RunningNode -> RunningNode -> Bool
Eq)