{-# 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.CardanoClient

import Cardano.Api.UTxO qualified as UTxO
import Data.Map qualified as Map
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

-- | Submit a transaction to a 'RunningNode'
submitTx :: RunningNode -> Tx -> IO ()
submitTx :: RunningNode -> Tx -> IO ()
submitTx RunningNode{NetworkId
networkId :: NetworkId
$sel:networkId:RunningNode :: RunningNode -> NetworkId
networkId, SocketPath
nodeSocket :: SocketPath
$sel:nodeSocket:RunningNode :: RunningNode -> SocketPath
nodeSocket} =
  NetworkId -> SocketPath -> Tx -> IO ()
submitTransaction NetworkId
networkId SocketPath
nodeSocket

-- | 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 ::
  NetworkId ->
  SocketPath ->
  Coin ->
  Address ShelleyAddr ->
  IO UTxO
waitForPayments :: NetworkId -> SocketPath -> Coin -> Address ShelleyAddr -> IO UTxO
waitForPayments NetworkId
networkId SocketPath
socket Coin
amount Address ShelleyAddr
addr =
  IO UTxO
go
 where
  go :: IO UTxO
go = do
    UTxO
utxo <- NetworkId
-> SocketPath -> QueryPoint -> [Address ShelleyAddr] -> IO UTxO
queryUTxO NetworkId
networkId SocketPath
socket QueryPoint
QueryTip [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 ::
  RunningNode ->
  UTxO ->
  IO ()
waitForUTxO :: RunningNode -> UTxO -> IO ()
waitForUTxO RunningNode
node 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.pairs UTxO
utxo) TxOut CtxUTxO -> IO ()
forEachUTxO
 where
  RunningNode{NetworkId
$sel:networkId:RunningNode :: RunningNode -> NetworkId
networkId :: NetworkId
networkId, SocketPath
$sel:nodeSocket:RunningNode :: RunningNode -> SocketPath
nodeSocket :: SocketPath
nodeSocket} = RunningNode
node

  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
$
        NetworkId -> SocketPath -> Coin -> Address ShelleyAddr -> IO UTxO
waitForPayments
          NetworkId
networkId
          SocketPath
nodeSocket
          (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 transations: " 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)