{-# 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, getVerificationKey)
import Hydra.Chain.Backend (ChainBackend)
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.Blockfrost (runBlockfrostBackend)
import Hydra.Chain.CardanoClient qualified as CardanoClient
import Hydra.Chain.Direct (runDirectBackend)
import Hydra.Options (ChainBackendOptions (..))
import Hydra.Tx.Crypto (getVerificationKey)
import Hydra.Tx.Secret (Secret, withSecret)
import System.IO.Error (userError)

-- | Run a 'ChainBackend' action given 'ChainBackendOptions'.
runBackend :: ChainBackendOptions -> (forall m. (ChainBackend m, MonadIO m, MonadThrow m, MonadCatch m) => m a) -> IO a
runBackend :: forall a.
ChainBackendOptions
-> (forall (m :: * -> *).
    (ChainBackend m, MonadIO m, MonadThrow m, MonadCatch m) =>
    m a)
-> IO a
runBackend ChainBackendOptions
opts forall (m :: * -> *).
(ChainBackend m, MonadIO m, MonadThrow m, MonadCatch m) =>
m a
action = case ChainBackendOptions
opts of
  Direct DirectOptions
directOpts -> DirectOptions -> DirectBackend a -> IO a
forall a. DirectOptions -> DirectBackend a -> IO a
runDirectBackend DirectOptions
directOpts DirectBackend a
forall (m :: * -> *).
(ChainBackend m, MonadIO m, MonadThrow m, MonadCatch m) =>
m a
action
  Blockfrost BlockfrostOptions
blockfrostOpts -> BlockfrostOptions -> BlockfrostBackend a -> IO a
forall a. BlockfrostOptions -> BlockfrostBackend a -> IO a
runBlockfrostBackend BlockfrostOptions
blockfrostOpts BlockfrostBackend a
forall (m :: * -> *).
(ChainBackend m, MonadIO m, MonadThrow m, MonadCatch m) =>
m a
action

-- 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 :: Secret (SigningKey PaymentKey) -> TxBody -> Tx
sign :: Secret (SigningKey PaymentKey) -> TxBody -> Tx
sign Secret (SigningKey PaymentKey)
signingKey TxBody
body =
  Secret (SigningKey PaymentKey)
-> (SigningKey PaymentKey -> Tx) -> Tx
forall a r. Secret a -> (a -> r) -> r
withSecret Secret (SigningKey PaymentKey)
signingKey ((SigningKey PaymentKey -> Tx) -> Tx)
-> (SigningKey PaymentKey -> Tx) -> Tx
forall a b. (a -> b) -> a -> b
$ \SigningKey PaymentKey
rawSk ->
    [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
rawSk)]
      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 ::
  ChainBackendOptions ->
  Coin ->
  Address ShelleyAddr ->
  IO UTxO
waitForPayments :: ChainBackendOptions -> Coin -> Address ShelleyAddr -> IO UTxO
waitForPayments ChainBackendOptions
opts Coin
amount Address ShelleyAddr
addr =
  IO UTxO
go
 where
  go :: IO UTxO
go = do
    UTxO
utxo <- ChainBackendOptions
-> (forall {m :: * -> *}.
    (ChainBackend m, MonadIO m, MonadThrow m, MonadCatch m) =>
    m UTxO)
-> IO UTxO
forall a.
ChainBackendOptions
-> (forall (m :: * -> *).
    (ChainBackend m, MonadIO m, MonadThrow m, MonadCatch m) =>
    m a)
-> IO a
runBackend ChainBackendOptions
opts ((forall {m :: * -> *}.
  (ChainBackend m, MonadIO m, MonadThrow m, MonadCatch m) =>
  m UTxO)
 -> IO UTxO)
-> (forall {m :: * -> *}.
    (ChainBackend m, MonadIO m, MonadThrow m, MonadCatch m) =>
    m UTxO)
-> IO UTxO
forall a b. (a -> b) -> a -> b
$ [Address ShelleyAddr] -> m UTxO
forall (m :: * -> *).
ChainBackend m =>
[Address ShelleyAddr] -> m UTxO
Backend.queryUTxO [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
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 ::
  ChainBackendOptions ->
  UTxO ->
  IO ()
waitForUTxO :: ChainBackendOptions -> UTxO -> IO ()
waitForUTxO ChainBackendOptions
opts 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 era. UTxO era -> [(TxIn, TxOut CtxUTxO era)]
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
$
        ChainBackendOptions -> Coin -> Address ShelleyAddr -> IO UTxO
waitForPayments
          ChainBackendOptions
opts
          (Value -> Coin
selectLovelace Value
value)
          Address ShelleyAddr
addr
    TxOut CtxUTxO
txOut ->
      IOError -> IO ()
forall e a. Exception e => e -> IO a
forall (m :: * -> *) e a. (MonadThrow m, Exception e) => e -> m a
throwIO (IOError -> IO ()) -> IOError -> IO ()
forall a b. (a -> b) -> a -> b
$ String -> IOError
userError (String -> IOError) -> String -> IOError
forall a b. (a -> b) -> a -> b
$ String
"Unexpected TxOut " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> TxOut CtxUTxO -> String
forall b a. (Show a, IsString b) => a -> b
show TxOut CtxUTxO
txOut

mkGenesisTx ::
  NetworkId ->
  -- | Owner of the 'initialFund'.
  Secret (SigningKey PaymentKey) ->
  -- | Amount of initialFunds
  Coin ->
  -- | Recipients and amounts to pay in this transaction.
  [(VerificationKey PaymentKey, Coin)] ->
  Tx
mkGenesisTx :: NetworkId
-> Secret (SigningKey PaymentKey)
-> Coin
-> [(VerificationKey PaymentKey, Coin)]
-> Tx
mkGenesisTx NetworkId
networkId Secret (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 -> Secret (SigningKey PaymentKey) -> TxBody -> Tx
sign Secret (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
$ Secret (SigningKey PaymentKey) -> VerificationKey PaymentKey
forall s k. HasVerificationKey s k => s -> VerificationKey k
getVerificationKey Secret (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 (Secret (SigningKey PaymentKey) -> VerificationKey PaymentKey
forall s k. HasVerificationKey s k => s -> VerificationKey k
getVerificationKey Secret (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 stock (Int -> RunningNode -> String -> String
[RunningNode] -> String -> String
RunningNode -> String
(Int -> RunningNode -> String -> String)
-> (RunningNode -> String)
-> ([RunningNode] -> String -> String)
-> Show RunningNode
forall a.
(Int -> a -> String -> String)
-> (a -> String) -> ([a] -> String -> String) -> Show a
$cshowsPrec :: Int -> RunningNode -> String -> String
showsPrec :: Int -> RunningNode -> String -> String
$cshow :: RunningNode -> String
show :: RunningNode -> String
$cshowList :: [RunningNode] -> String -> String
showList :: [RunningNode] -> String -> String
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)