{-# LANGUAGE DuplicateRecordFields #-}

module Hydra.Cluster.Faucet where

import Hydra.Cardano.Api hiding (getVerificationKey, signTx)
import Hydra.Prelude
import Test.Hydra.Prelude

import Cardano.Api.UTxO qualified as UTxO
import CardanoClient (
  QueryPoint (QueryTip),
  SubmitTransactionException,
  buildAddress,
  runBackend,
  sign,
 )
import Control.Exception (IOException)
import Control.Monad.Class.MonadThrow (Handler (Handler), catches)
import Control.Tracer (Tracer, traceWith)
import Data.Aeson qualified as Aeson
import Data.Set qualified as Set
import Data.Time.Clock.POSIX (posixSecondsToUTCTime)
import GHC.IO.Exception (IOErrorType (ResourceExhausted), IOException (ioe_type))
import Hydra.Chain.Backend (ChainBackend (..), buildTransaction, buildTransactionWithMintingScript, buildTransactionWithPParams')
import Hydra.Chain.Blockfrost.Client qualified as Blockfrost
import Hydra.Chain.ScriptRegistry (
  publishHydraScripts,
 )
import Hydra.Cluster.Fixture (Actor (Faucet))
import Hydra.Cluster.Util (keysFor)
import Hydra.Ledger.Cardano ()
import Hydra.Options (ChainBackendOptions (..))
import Hydra.Options qualified as Options
import Hydra.Tx (balance)
import Hydra.Tx.Crypto (getVerificationKey, signTx)
import Hydra.Tx.Secret (Secret, mkSecret, withSecret)
import System.Directory (doesFileExist)
import System.FilePath ((</>))

data FaucetException
  = FaucetHasNotEnoughFunds {FaucetException -> UTxO Era
faucetUTxO :: UTxO}
  | FaucetFailedToBuildTx {FaucetException -> TxBodyErrorAutoBalance Era
reason :: TxBodyErrorAutoBalance Era}
  | FaucetBlockfrostError {FaucetException -> Text
blockFrostError :: Text}
  deriving stock (Int -> FaucetException -> ShowS
[FaucetException] -> ShowS
FaucetException -> String
(Int -> FaucetException -> ShowS)
-> (FaucetException -> String)
-> ([FaucetException] -> ShowS)
-> Show FaucetException
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> FaucetException -> ShowS
showsPrec :: Int -> FaucetException -> ShowS
$cshow :: FaucetException -> String
show :: FaucetException -> String
$cshowList :: [FaucetException] -> ShowS
showList :: [FaucetException] -> ShowS
Show)

instance Exception FaucetException

data FaucetLog
  = TraceResourceExhaustedHandled Text
  | ReturnedFunds {FaucetLog -> Lovelace
returnAmount :: Coin}
  | SubmitTxError Text
  deriving stock (FaucetLog -> FaucetLog -> Bool
(FaucetLog -> FaucetLog -> Bool)
-> (FaucetLog -> FaucetLog -> Bool) -> Eq FaucetLog
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: FaucetLog -> FaucetLog -> Bool
== :: FaucetLog -> FaucetLog -> Bool
$c/= :: FaucetLog -> FaucetLog -> Bool
/= :: FaucetLog -> FaucetLog -> Bool
Eq, Int -> FaucetLog -> ShowS
[FaucetLog] -> ShowS
FaucetLog -> String
(Int -> FaucetLog -> ShowS)
-> (FaucetLog -> String)
-> ([FaucetLog] -> ShowS)
-> Show FaucetLog
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> FaucetLog -> ShowS
showsPrec :: Int -> FaucetLog -> ShowS
$cshow :: FaucetLog -> String
show :: FaucetLog -> String
$cshowList :: [FaucetLog] -> ShowS
showList :: [FaucetLog] -> ShowS
Show, (forall x. FaucetLog -> Rep FaucetLog x)
-> (forall x. Rep FaucetLog x -> FaucetLog) -> Generic FaucetLog
forall x. Rep FaucetLog x -> FaucetLog
forall x. FaucetLog -> Rep FaucetLog x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cfrom :: forall x. FaucetLog -> Rep FaucetLog x
from :: forall x. FaucetLog -> Rep FaucetLog x
$cto :: forall x. Rep FaucetLog x -> FaucetLog
to :: forall x. Rep FaucetLog x -> FaucetLog
Generic)
  deriving anyclass ([FaucetLog] -> Value
[FaucetLog] -> Encoding
FaucetLog -> Bool
FaucetLog -> Value
FaucetLog -> Encoding
(FaucetLog -> Value)
-> (FaucetLog -> Encoding)
-> ([FaucetLog] -> Value)
-> ([FaucetLog] -> Encoding)
-> (FaucetLog -> Bool)
-> ToJSON FaucetLog
forall a.
(a -> Value)
-> (a -> Encoding)
-> ([a] -> Value)
-> ([a] -> Encoding)
-> (a -> Bool)
-> ToJSON a
$ctoJSON :: FaucetLog -> Value
toJSON :: FaucetLog -> Value
$ctoEncoding :: FaucetLog -> Encoding
toEncoding :: FaucetLog -> Encoding
$ctoJSONList :: [FaucetLog] -> Value
toJSONList :: [FaucetLog] -> Value
$ctoEncodingList :: [FaucetLog] -> Encoding
toEncodingList :: [FaucetLog] -> Encoding
$comitField :: FaucetLog -> Bool
omitField :: FaucetLog -> Bool
ToJSON)

delayBF :: MonadDelay m => ChainBackendOptions -> m ()
delayBF :: forall (m :: * -> *). MonadDelay m => ChainBackendOptions -> m ()
delayBF ChainBackendOptions
opts = do
  let delay :: Int
delay = case ChainBackendOptions
opts of
        Options.Blockfrost{} -> Int
30 :: Int -- backoff before retrying a failed BF faucet operation
        ChainBackendOptions
_ -> Int
1
  DiffTime -> m ()
forall (m :: * -> *). MonadDelay m => DiffTime -> m ()
threadDelay (DiffTime -> m ()) -> DiffTime -> m ()
forall a b. (a -> b) -> a -> b
$ Int -> DiffTime
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
delay

seedFromFaucet ::
  ChainBackendOptions ->
  -- | Recipient of the funds
  VerificationKey PaymentKey ->
  -- | Value to get from faucet
  Value ->
  Tracer IO FaucetLog ->
  IO UTxO
seedFromFaucet :: ChainBackendOptions
-> VerificationKey PaymentKey
-> Value
-> Tracer IO FaucetLog
-> IO (UTxO Era)
seedFromFaucet ChainBackendOptions
opts VerificationKey PaymentKey
receivingVerificationKey Value
val Tracer IO FaucetLog
tracer = do
  ChainBackendOptions
-> VerificationKey PaymentKey
-> Value
-> Tracer IO FaucetLog
-> Maybe PlutusScript
-> IO (UTxO Era)
seedFromFaucetWithMinting ChainBackendOptions
opts VerificationKey PaymentKey
receivingVerificationKey Value
val Tracer IO FaucetLog
tracer Maybe PlutusScript
forall a. Maybe a
Nothing

-- | Create a specially marked "seed" UTXO containing requested 'Value' by
-- redeeming funds available to the well-known faucet.
seedFromFaucetWithMinting ::
  ChainBackendOptions ->
  -- | Recipient of the funds
  VerificationKey PaymentKey ->
  -- | Value to get from faucet
  Value ->
  Tracer IO FaucetLog ->
  Maybe PlutusScript ->
  IO UTxO
seedFromFaucetWithMinting :: ChainBackendOptions
-> VerificationKey PaymentKey
-> Value
-> Tracer IO FaucetLog
-> Maybe PlutusScript
-> IO (UTxO Era)
seedFromFaucetWithMinting ChainBackendOptions
opts VerificationKey PaymentKey
receivingVerificationKey Value
val Tracer IO FaucetLog
tracer Maybe PlutusScript
mintingScript = do
  (VerificationKey PaymentKey
faucetVk, Secret (SigningKey PaymentKey)
faucetSk) <- Actor
-> IO (VerificationKey PaymentKey, Secret (SigningKey PaymentKey))
keysFor Actor
Faucet
  NetworkId
networkId <- ChainBackendOptions
-> (forall (m :: * -> *).
    (ChainBackend m, MonadIO m, MonadThrow m, MonadCatch m) =>
    m NetworkId)
-> IO NetworkId
forall a.
ChainBackendOptions
-> (forall (m :: * -> *).
    (ChainBackend m, MonadIO m, MonadThrow m, MonadCatch m) =>
    m a)
-> IO a
runBackend ChainBackendOptions
opts m NetworkId
forall (m :: * -> *). ChainBackend m => m NetworkId
forall (m :: * -> *).
(ChainBackend m, MonadIO m, MonadThrow m, MonadCatch m) =>
m NetworkId
queryNetworkId
  Tx
seedTx <- Tracer IO FaucetLog -> ChainBackendOptions -> IO Tx -> IO Tx
forall (m :: * -> *) a.
(MonadCatch m, MonadDelay m) =>
Tracer m FaucetLog -> ChainBackendOptions -> m a -> m a
retryOnExceptions Tracer IO FaucetLog
tracer ChainBackendOptions
opts (IO Tx -> IO Tx) -> IO Tx -> IO Tx
forall a b. (a -> b) -> a -> b
$ VerificationKey PaymentKey
-> Secret (SigningKey PaymentKey) -> NetworkId -> IO Tx
submitSeedTx VerificationKey PaymentKey
faucetVk Secret (SigningKey PaymentKey)
faucetSk NetworkId
networkId
  UTxO Era
producedUTxO <- ChainBackendOptions
-> (forall {m :: * -> *}.
    (ChainBackend m, MonadIO m, MonadThrow m, MonadCatch m) =>
    m (UTxO Era))
-> IO (UTxO Era)
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 Era))
 -> IO (UTxO Era))
-> (forall {m :: * -> *}.
    (ChainBackend m, MonadIO m, MonadThrow m, MonadCatch m) =>
    m (UTxO Era))
-> IO (UTxO Era)
forall a b. (a -> b) -> a -> b
$ Tx -> VerificationKey PaymentKey -> m (UTxO Era)
forall (m :: * -> *).
ChainBackend m =>
Tx -> VerificationKey PaymentKey -> m (UTxO Era)
awaitTransaction Tx
seedTx VerificationKey PaymentKey
receivingVerificationKey
  UTxO Era -> IO (UTxO Era)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (UTxO Era -> IO (UTxO Era)) -> UTxO Era -> IO (UTxO Era)
forall a b. (a -> b) -> a -> b
$ (TxOut CtxUTxO Era -> Bool) -> UTxO Era -> UTxO Era
forall era. (TxOut CtxUTxO era -> Bool) -> UTxO era -> UTxO era
UTxO.filter (TxOut CtxUTxO Era -> TxOut CtxUTxO Era -> Bool
forall a. Eq a => a -> a -> Bool
== TxOut CtxTx Era -> TxOut CtxUTxO Era
forall era. TxOut CtxTx era -> TxOut CtxUTxO era
toCtxUTxOTxOut (NetworkId -> TxOut CtxTx Era
theOutput NetworkId
networkId)) UTxO Era
producedUTxO
 where
  submitSeedTx :: VerificationKey PaymentKey
-> Secret (SigningKey PaymentKey) -> NetworkId -> IO Tx
submitSeedTx VerificationKey PaymentKey
faucetVk Secret (SigningKey PaymentKey)
faucetSk NetworkId
networkId = do
    UTxO Era
faucetUTxO <- NetworkId -> ChainBackendOptions -> Lovelace -> IO (UTxO Era)
findFaucetUTxO NetworkId
networkId ChainBackendOptions
opts (Value -> Lovelace
selectLovelace Value
val)
    let changeAddress :: AddressInEra
changeAddress = NetworkId -> VerificationKey PaymentKey -> AddressInEra
forall era.
IsShelleyBasedEra era =>
NetworkId -> VerificationKey PaymentKey -> AddressInEra era
mkVkAddress NetworkId
networkId VerificationKey PaymentKey
faucetVk

    ChainBackendOptions
-> (forall (m :: * -> *).
    (ChainBackend m, MonadIO m, MonadThrow m, MonadCatch m) =>
    m (Either (TxBodyErrorAutoBalance Era) Tx))
-> IO (Either (TxBodyErrorAutoBalance Era) Tx)
forall a.
ChainBackendOptions
-> (forall (m :: * -> *).
    (ChainBackend m, MonadIO m, MonadThrow m, MonadCatch m) =>
    m a)
-> IO a
runBackend ChainBackendOptions
opts (AddressInEra
-> UTxO Era
-> [TxIn]
-> [TxOut CtxTx Era]
-> Maybe PlutusScript
-> m (Either (TxBodyErrorAutoBalance Era) Tx)
forall (m :: * -> *).
(ChainBackend m, MonadIO m) =>
AddressInEra
-> UTxO Era
-> [TxIn]
-> [TxOut CtxTx Era]
-> Maybe PlutusScript
-> m (Either (TxBodyErrorAutoBalance Era) Tx)
buildTransactionWithMintingScript AddressInEra
changeAddress UTxO Era
faucetUTxO (Set TxIn -> [TxIn]
forall a. Set a -> [a]
forall (t :: * -> *) a. Foldable t => t a -> [a]
toList (Set TxIn -> [TxIn]) -> Set TxIn -> [TxIn]
forall a b. (a -> b) -> a -> b
$ UTxO Era -> Set TxIn
forall era. UTxO era -> Set TxIn
UTxO.inputSet UTxO Era
faucetUTxO) [NetworkId -> TxOut CtxTx Era
theOutput NetworkId
networkId] Maybe PlutusScript
mintingScript) IO (Either (TxBodyErrorAutoBalance Era) Tx)
-> (Either (TxBodyErrorAutoBalance Era) Tx -> IO Tx) -> IO Tx
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 -> FaucetException -> IO Tx
forall e a. Exception e => e -> IO a
forall (m :: * -> *) e a. (MonadThrow m, Exception e) => e -> m a
throwIO (FaucetException -> IO Tx) -> FaucetException -> IO Tx
forall a b. (a -> b) -> a -> b
$ FaucetFailedToBuildTx{$sel:reason:FaucetHasNotEnoughFunds :: TxBodyErrorAutoBalance Era
reason = TxBodyErrorAutoBalance Era
e}
      Right Tx
tx -> do
        let signedTx :: Tx
signedTx = Secret (SigningKey PaymentKey) -> TxBody -> Tx
sign Secret (SigningKey PaymentKey)
faucetSk (Tx -> TxBody
forall era. Tx era -> TxBody era
getTxBody Tx
tx)
        ChainBackendOptions
-> (forall {m :: * -> *}.
    (ChainBackend m, MonadIO m, MonadThrow m, MonadCatch m) =>
    m ())
-> IO ()
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 ())
 -> IO ())
-> (forall {m :: * -> *}.
    (ChainBackend m, MonadIO m, MonadThrow m, MonadCatch m) =>
    m ())
-> IO ()
forall a b. (a -> b) -> a -> b
$ Tx -> m ()
forall (m :: * -> *). ChainBackend m => Tx -> m ()
submitTransaction Tx
signedTx
        Tx -> IO Tx
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Tx
signedTx

  receivingAddress :: NetworkId -> Address ShelleyAddr
receivingAddress = VerificationKey PaymentKey -> NetworkId -> Address ShelleyAddr
buildAddress VerificationKey PaymentKey
receivingVerificationKey

  theOutput :: NetworkId -> TxOut CtxTx Era
theOutput NetworkId
networkId =
    AddressInEra
-> Value -> TxOutDatum CtxTx -> ReferenceScript -> TxOut CtxTx Era
forall ctx.
AddressInEra
-> Value -> TxOutDatum ctx -> ReferenceScript -> TxOut ctx
TxOut
      (ShelleyBasedEra Era -> Address ShelleyAddr -> AddressInEra
forall era.
ShelleyBasedEra era -> Address ShelleyAddr -> AddressInEra era
shelleyAddressInEra ShelleyBasedEra Era
forall era. IsShelleyBasedEra era => ShelleyBasedEra era
shelleyBasedEra (NetworkId -> Address ShelleyAddr
receivingAddress NetworkId
networkId))
      Value
val
      TxOutDatum CtxTx
forall ctx. TxOutDatum ctx
TxOutDatumNone
      ReferenceScript
ReferenceScriptNone

findFaucetUTxO :: NetworkId -> ChainBackendOptions -> Coin -> IO UTxO
findFaucetUTxO :: NetworkId -> ChainBackendOptions -> Lovelace -> IO (UTxO Era)
findFaucetUTxO NetworkId
networkId ChainBackendOptions
opts Lovelace
lovelace = do
  (VerificationKey PaymentKey
faucetVk, Secret (SigningKey PaymentKey)
_) <- Actor
-> IO (VerificationKey PaymentKey, Secret (SigningKey PaymentKey))
keysFor Actor
Faucet
  let address :: Address ShelleyAddr
address = VerificationKey PaymentKey -> NetworkId -> Address ShelleyAddr
buildAddress VerificationKey PaymentKey
faucetVk NetworkId
networkId
  UTxO Era
faucetUTxO <- ChainBackendOptions
-> (forall {m :: * -> *}.
    (ChainBackend m, MonadIO m, MonadThrow m, MonadCatch m) =>
    m (UTxO Era))
-> IO (UTxO Era)
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 Era))
 -> IO (UTxO Era))
-> (forall {m :: * -> *}.
    (ChainBackend m, MonadIO m, MonadThrow m, MonadCatch m) =>
    m (UTxO Era))
-> IO (UTxO Era)
forall a b. (a -> b) -> a -> b
$ [Address ShelleyAddr] -> m (UTxO Era)
forall (m :: * -> *).
ChainBackend m =>
[Address ShelleyAddr] -> m (UTxO Era)
queryUTxO [Address ShelleyAddr
address]
  UTxO Era -> Lovelace -> IO (UTxO Era)
forall (m :: * -> *).
MonadIO m =>
UTxO Era -> Lovelace -> m (UTxO Era)
findUTxO UTxO Era
faucetUTxO Lovelace
lovelace

seedFromFaucetBlockfrost ::
  -- | Recipient of the funds
  VerificationKey PaymentKey ->
  -- | Amount to get from faucet
  Coin ->
  Blockfrost.BlockfrostClientT IO UTxO
seedFromFaucetBlockfrost :: VerificationKey PaymentKey
-> Lovelace -> BlockfrostClientT IO (UTxO Era)
seedFromFaucetBlockfrost VerificationKey PaymentKey
receivingVerificationKey Lovelace
lovelace = do
  (VerificationKey PaymentKey
faucetVk, Secret (SigningKey PaymentKey)
faucetSk) <- IO (VerificationKey PaymentKey, Secret (SigningKey PaymentKey))
-> BlockfrostClientT
     IO (VerificationKey PaymentKey, Secret (SigningKey PaymentKey))
forall a. IO a -> BlockfrostClientT IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (VerificationKey PaymentKey, Secret (SigningKey PaymentKey))
 -> BlockfrostClientT
      IO (VerificationKey PaymentKey, Secret (SigningKey PaymentKey)))
-> IO (VerificationKey PaymentKey, Secret (SigningKey PaymentKey))
-> BlockfrostClientT
     IO (VerificationKey PaymentKey, Secret (SigningKey PaymentKey))
forall a b. (a -> b) -> a -> b
$ Actor
-> IO (VerificationKey PaymentKey, Secret (SigningKey PaymentKey))
keysFor Actor
Faucet

  Blockfrost.Genesis
    { $sel:_genesisNetworkMagic:Genesis :: Genesis -> Integer
Blockfrost._genesisNetworkMagic = Integer
networkMagic
    , $sel:_genesisSystemStart:Genesis :: Genesis -> POSIXTime
Blockfrost._genesisSystemStart = POSIXTime
systemStart'
    } <-
    BlockfrostClientT IO Genesis
Blockfrost.queryGenesisParameters
  PParams ConwayEra
pparams <- BlockfrostClientT IO (PParams LedgerEra)
BlockfrostClientT IO (PParams ConwayEra)
forall (m :: * -> *).
MonadIO m =>
BlockfrostClientT m (PParams LedgerEra)
Blockfrost.queryProtocolParameters
  let networkId :: NetworkId
networkId = Integer -> NetworkId
Blockfrost.toCardanoNetworkId Integer
networkMagic
  let changeAddress :: Address ShelleyAddr
changeAddress = VerificationKey PaymentKey -> NetworkId -> Address ShelleyAddr
buildAddress VerificationKey PaymentKey
faucetVk NetworkId
networkId
  let receivingAddress :: Address ShelleyAddr
receivingAddress = VerificationKey PaymentKey -> NetworkId -> Address ShelleyAddr
buildAddress VerificationKey PaymentKey
receivingVerificationKey NetworkId
networkId
  let theOutput :: TxOut CtxTx Era
theOutput =
        AddressInEra
-> Value -> TxOutDatum CtxTx -> ReferenceScript -> TxOut CtxTx Era
forall ctx.
AddressInEra
-> Value -> TxOutDatum ctx -> ReferenceScript -> TxOut ctx
TxOut
          (ShelleyBasedEra Era -> Address ShelleyAddr -> AddressInEra
forall era.
ShelleyBasedEra era -> Address ShelleyAddr -> AddressInEra era
shelleyAddressInEra ShelleyBasedEra Era
forall era. IsShelleyBasedEra era => ShelleyBasedEra era
shelleyBasedEra Address ShelleyAddr
receivingAddress)
          (Lovelace -> Value
lovelaceToValue Lovelace
lovelace)
          TxOutDatum CtxTx
forall ctx. TxOutDatum ctx
TxOutDatumNone
          ReferenceScript
ReferenceScriptNone
  [PoolId]
stakePools' <- BlockfrostClientT IO [PoolId]
forall (m :: * -> *). MonadBlockfrost m => m [PoolId]
Blockfrost.listPools
  let stakePools :: Set (Hash StakePoolKey)
stakePools = [Hash StakePoolKey] -> Set (Hash StakePoolKey)
forall a. Ord a => [a] -> Set a
Set.fromList (PoolId -> Hash StakePoolKey
Blockfrost.toCardanoPoolId (PoolId -> Hash StakePoolKey) -> [PoolId] -> [Hash StakePoolKey]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [PoolId]
stakePools')
  let systemStart :: SystemStart
systemStart = UTCTime -> SystemStart
SystemStart (UTCTime -> SystemStart) -> UTCTime -> SystemStart
forall a b. (a -> b) -> a -> b
$ POSIXTime -> UTCTime
posixSecondsToUTCTime POSIXTime
systemStart'
  EraHistory
eraHistory <- BlockfrostClientT IO EraHistory
Blockfrost.queryEraHistory
  UTxO Era
faucetUTxO <- NetworkId
-> [Address ShelleyAddr] -> BlockfrostClientT IO (UTxO Era)
Blockfrost.queryUTxO NetworkId
networkId [Address ShelleyAddr
changeAddress]
  UTxO Era
foundUTxO <- UTxO Era -> Lovelace -> BlockfrostClientT IO (UTxO Era)
forall (m :: * -> *).
MonadIO m =>
UTxO Era -> Lovelace -> m (UTxO Era)
findUTxO UTxO Era
faucetUTxO Lovelace
lovelace
  case PParams LedgerEra
-> SystemStart
-> EraHistory
-> Set (Hash StakePoolKey)
-> AddressInEra
-> UTxO Era
-> [TxIn]
-> [TxOut CtxTx Era]
-> Maybe PlutusScript
-> Either (TxBodyErrorAutoBalance Era) Tx
buildTransactionWithPParams' PParams LedgerEra
PParams ConwayEra
pparams SystemStart
systemStart EraHistory
eraHistory Set (Hash StakePoolKey)
stakePools (NetworkId -> VerificationKey PaymentKey -> AddressInEra
forall era.
IsShelleyBasedEra era =>
NetworkId -> VerificationKey PaymentKey -> AddressInEra era
mkVkAddress NetworkId
networkId VerificationKey PaymentKey
faucetVk) UTxO Era
foundUTxO [] [TxOut CtxTx Era
theOutput] Maybe PlutusScript
forall a. Maybe a
Nothing of
    Left TxBodyErrorAutoBalance Era
e -> IO (UTxO Era) -> BlockfrostClientT IO (UTxO Era)
forall a. IO a -> BlockfrostClientT IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (UTxO Era) -> BlockfrostClientT IO (UTxO Era))
-> IO (UTxO Era) -> BlockfrostClientT IO (UTxO Era)
forall a b. (a -> b) -> a -> b
$ FaucetException -> IO (UTxO Era)
forall e a. Exception e => e -> IO a
forall (m :: * -> *) e a. (MonadThrow m, Exception e) => e -> m a
throwIO (FaucetException -> IO (UTxO Era))
-> FaucetException -> IO (UTxO Era)
forall a b. (a -> b) -> a -> b
$ FaucetFailedToBuildTx{$sel:reason:FaucetHasNotEnoughFunds :: TxBodyErrorAutoBalance Era
reason = TxBodyErrorAutoBalance Era
e}
    Right Tx
tx -> do
      let signedTx :: Tx
signedTx = Secret (SigningKey PaymentKey) -> Tx -> Tx
forall s. CanSignTx s => s -> Tx -> Tx
signTx Secret (SigningKey PaymentKey)
faucetSk Tx
tx
      Either BlockfrostError TxHash
eResult <- BlockfrostClientT IO TxHash
-> BlockfrostClientT IO (Either BlockfrostError TxHash)
forall e (m :: * -> *) a. MonadError e m => m a -> m (Either e a)
Blockfrost.tryError (BlockfrostClientT IO TxHash
 -> BlockfrostClientT IO (Either BlockfrostError TxHash))
-> BlockfrostClientT IO TxHash
-> BlockfrostClientT IO (Either BlockfrostError TxHash)
forall a b. (a -> b) -> a -> b
$ Tx -> BlockfrostClientT IO TxHash
forall (m :: * -> *). MonadIO m => Tx -> BlockfrostClientT m TxHash
Blockfrost.submitTransaction Tx
signedTx
      case Either BlockfrostError TxHash
eResult of
        Left BlockfrostError
err -> IO (UTxO Era) -> BlockfrostClientT IO (UTxO Era)
forall a. IO a -> BlockfrostClientT IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (UTxO Era) -> BlockfrostClientT IO (UTxO Era))
-> IO (UTxO Era) -> BlockfrostClientT IO (UTxO Era)
forall a b. (a -> b) -> a -> b
$ FaucetException -> IO (UTxO Era)
forall e a. Exception e => e -> IO a
forall (m :: * -> *) e a. (MonadThrow m, Exception e) => e -> m a
throwIO (FaucetException -> IO (UTxO Era))
-> FaucetException -> IO (UTxO Era)
forall a b. (a -> b) -> a -> b
$ FaucetBlockfrostError{$sel:blockFrostError:FaucetHasNotEnoughFunds :: Text
blockFrostError = BlockfrostError -> Text
forall b a. (Show a, IsString b) => a -> b
show BlockfrostError
err}
        Right TxHash
_ -> do
          BlockfrostClientT IO (UTxO Era) -> BlockfrostClientT IO ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (BlockfrostClientT IO (UTxO Era) -> BlockfrostClientT IO ())
-> BlockfrostClientT IO (UTxO Era) -> BlockfrostClientT IO ()
forall a b. (a -> b) -> a -> b
$ NetworkId
-> [Address ShelleyAddr] -> Tx -> BlockfrostClientT IO (UTxO Era)
Blockfrost.awaitUTxO NetworkId
networkId [Address ShelleyAddr
changeAddress] Tx
signedTx
          NetworkId
-> [Address ShelleyAddr] -> Tx -> BlockfrostClientT IO (UTxO Era)
Blockfrost.awaitUTxO NetworkId
networkId [Address ShelleyAddr
receivingAddress] Tx
signedTx

findUTxO :: MonadIO m => UTxO.UTxO Era -> Lovelace -> m (UTxO.UTxO Era)
findUTxO :: forall (m :: * -> *).
MonadIO m =>
UTxO Era -> Lovelace -> m (UTxO Era)
findUTxO UTxO Era
utxo Lovelace
lovelace' = do
  let foundUTxO :: Maybe (TxIn, TxOut CtxUTxO Era)
foundUTxO = (TxOut CtxUTxO Era -> Bool)
-> UTxO Era -> Maybe (TxIn, TxOut CtxUTxO Era)
forall era.
(TxOut CtxUTxO era -> Bool)
-> UTxO era -> Maybe (TxIn, TxOut CtxUTxO era)
UTxO.find (\TxOut CtxUTxO Era
o -> (Value -> Lovelace
selectLovelace (Value -> Lovelace)
-> (TxOut CtxUTxO Era -> Value) -> TxOut CtxUTxO Era -> Lovelace
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TxOut CtxUTxO Era -> Value
forall ctx. TxOut ctx -> Value
txOutValue) TxOut CtxUTxO Era
o Lovelace -> Lovelace -> Bool
forall a. Ord a => a -> a -> Bool
>= Lovelace
lovelace') UTxO Era
utxo
  Bool -> m () -> m ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Maybe (TxIn, TxOut CtxUTxO Era) -> Bool
forall a. Maybe a -> Bool
isNothing Maybe (TxIn, TxOut CtxUTxO Era)
foundUTxO) (m () -> m ()) -> m () -> m ()
forall a b. (a -> b) -> a -> b
$
    IO () -> m ()
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> m ()) -> IO () -> m ()
forall a b. (a -> b) -> a -> b
$
      FaucetException -> IO ()
forall e a. Exception e => e -> IO a
forall (m :: * -> *) e a. (MonadThrow m, Exception e) => e -> m a
throwIO (FaucetException -> IO ()) -> FaucetException -> IO ()
forall a b. (a -> b) -> a -> b
$
        FaucetHasNotEnoughFunds{$sel:faucetUTxO:FaucetHasNotEnoughFunds :: UTxO Era
faucetUTxO = UTxO Era
utxo}
  UTxO Era -> m (UTxO Era)
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (UTxO Era -> m (UTxO Era)) -> UTxO Era -> m (UTxO Era)
forall a b. (a -> b) -> a -> b
$ UTxO Era
-> ((TxIn, TxOut CtxUTxO Era) -> UTxO Era)
-> Maybe (TxIn, TxOut CtxUTxO Era)
-> UTxO Era
forall b a. b -> (a -> b) -> Maybe a -> b
maybe UTxO Era
forall a. Monoid a => a
mempty ((TxIn -> TxOut CtxUTxO Era -> UTxO Era)
-> (TxIn, TxOut CtxUTxO Era) -> UTxO Era
forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry TxIn -> TxOut CtxUTxO Era -> UTxO Era
forall era. TxIn -> TxOut CtxUTxO era -> UTxO era
UTxO.singleton) Maybe (TxIn, TxOut CtxUTxO Era)
foundUTxO

-- | Like 'seedFromFaucet', but without returning the seeded 'UTxO'.
seedFromFaucet_ ::
  ChainBackendOptions ->
  -- | Recipient of the funds
  VerificationKey PaymentKey ->
  -- | Amount to get from faucet
  Coin ->
  Tracer IO FaucetLog ->
  IO ()
seedFromFaucet_ :: ChainBackendOptions
-> VerificationKey PaymentKey
-> Lovelace
-> Tracer IO FaucetLog
-> IO ()
seedFromFaucet_ ChainBackendOptions
opts VerificationKey PaymentKey
vk Lovelace
ll Tracer IO FaucetLog
tracer =
  IO (UTxO Era) -> IO ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (IO (UTxO Era) -> IO ()) -> IO (UTxO Era) -> IO ()
forall a b. (a -> b) -> a -> b
$ ChainBackendOptions
-> VerificationKey PaymentKey
-> Value
-> Tracer IO FaucetLog
-> IO (UTxO Era)
seedFromFaucet ChainBackendOptions
opts VerificationKey PaymentKey
vk (Lovelace -> Value
lovelaceToValue Lovelace
ll) Tracer IO FaucetLog
tracer

-- | Return the remaining funds to the faucet
returnFundsToFaucet ::
  Tracer IO FaucetLog ->
  ChainBackendOptions ->
  Actor ->
  IO ()
returnFundsToFaucet :: Tracer IO FaucetLog -> ChainBackendOptions -> Actor -> IO ()
returnFundsToFaucet Tracer IO FaucetLog
tracer ChainBackendOptions
opts Actor
sender = do
  (VerificationKey PaymentKey, Secret (SigningKey PaymentKey))
senderKeys <- Actor
-> IO (VerificationKey PaymentKey, Secret (SigningKey PaymentKey))
keysFor Actor
sender
  IO Lovelace -> IO ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (IO Lovelace -> IO ()) -> IO Lovelace -> IO ()
forall a b. (a -> b) -> a -> b
$ Tracer IO FaucetLog
-> ChainBackendOptions
-> Secret (SigningKey PaymentKey)
-> IO Lovelace
returnFundsToFaucet' Tracer IO FaucetLog
tracer ChainBackendOptions
opts ((VerificationKey PaymentKey, Secret (SigningKey PaymentKey))
-> Secret (SigningKey PaymentKey)
forall a b. (a, b) -> b
snd (VerificationKey PaymentKey, Secret (SigningKey PaymentKey))
senderKeys)

returnFundsToFaucet' ::
  Tracer IO FaucetLog ->
  ChainBackendOptions ->
  Secret (SigningKey PaymentKey) ->
  IO Coin
returnFundsToFaucet' :: Tracer IO FaucetLog
-> ChainBackendOptions
-> Secret (SigningKey PaymentKey)
-> IO Lovelace
returnFundsToFaucet' Tracer IO FaucetLog
tracer ChainBackendOptions
opts Secret (SigningKey PaymentKey)
senderSk = do
  (VerificationKey PaymentKey
faucetVk, Secret (SigningKey PaymentKey)
_) <- Actor
-> IO (VerificationKey PaymentKey, Secret (SigningKey PaymentKey))
keysFor Actor
Faucet
  NetworkId
networkId <- ChainBackendOptions
-> (forall (m :: * -> *).
    (ChainBackend m, MonadIO m, MonadThrow m, MonadCatch m) =>
    m NetworkId)
-> IO NetworkId
forall a.
ChainBackendOptions
-> (forall (m :: * -> *).
    (ChainBackend m, MonadIO m, MonadThrow m, MonadCatch m) =>
    m a)
-> IO a
runBackend ChainBackendOptions
opts m NetworkId
forall (m :: * -> *). ChainBackend m => m NetworkId
forall (m :: * -> *).
(ChainBackend m, MonadIO m, MonadThrow m, MonadCatch m) =>
m NetworkId
queryNetworkId
  let faucetAddress :: AddressInEra
faucetAddress = NetworkId -> VerificationKey PaymentKey -> AddressInEra
forall era.
IsShelleyBasedEra era =>
NetworkId -> VerificationKey PaymentKey -> AddressInEra era
mkVkAddress NetworkId
networkId VerificationKey PaymentKey
faucetVk
  let senderVk :: VerificationKey PaymentKey
senderVk = Secret (SigningKey PaymentKey) -> VerificationKey PaymentKey
forall s k. HasVerificationKey s k => s -> VerificationKey k
getVerificationKey Secret (SigningKey PaymentKey)
senderSk
  UTxO Era
utxo <- ChainBackendOptions
-> (forall {m :: * -> *}.
    (ChainBackend m, MonadIO m, MonadThrow m, MonadCatch m) =>
    m (UTxO Era))
-> IO (UTxO Era)
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 Era))
 -> IO (UTxO Era))
-> (forall {m :: * -> *}.
    (ChainBackend m, MonadIO m, MonadThrow m, MonadCatch m) =>
    m (UTxO Era))
-> IO (UTxO Era)
forall a b. (a -> b) -> a -> b
$ QueryPoint -> VerificationKey PaymentKey -> m (UTxO Era)
forall (m :: * -> *).
ChainBackend m =>
QueryPoint -> VerificationKey PaymentKey -> m (UTxO Era)
queryUTxOFor QueryPoint
QueryTip VerificationKey PaymentKey
senderVk
  Lovelace
returnAmount <-
    if UTxO Era -> Bool
forall era. UTxO era -> Bool
UTxO.null UTxO Era
utxo
      then Lovelace -> IO Lovelace
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Lovelace
0
      else Tracer IO FaucetLog
-> ChainBackendOptions -> IO Lovelace -> IO Lovelace
forall (m :: * -> *) a.
(MonadCatch m, MonadDelay m) =>
Tracer m FaucetLog -> ChainBackendOptions -> m a -> m a
retryOnExceptions Tracer IO FaucetLog
tracer ChainBackendOptions
opts (IO Lovelace -> IO Lovelace) -> IO Lovelace -> IO Lovelace
forall a b. (a -> b) -> a -> b
$ do
        let utxoValue :: ValueType Tx
utxoValue = forall tx. IsTx tx => UTxOType tx -> ValueType tx
balance @Tx UTxO Era
UTxOType Tx
utxo
        let allLovelace :: Lovelace
allLovelace = Value -> Lovelace
selectLovelace Value
ValueType Tx
utxoValue
        Tx
tx <- Secret (SigningKey PaymentKey) -> TxBody -> Tx
sign Secret (SigningKey PaymentKey)
senderSk (TxBody -> Tx) -> IO TxBody -> IO Tx
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> UTxO Era -> AddressInEra -> IO TxBody
buildTxBody UTxO Era
utxo AddressInEra
faucetAddress
        ChainBackendOptions
-> (forall {m :: * -> *}.
    (ChainBackend m, MonadIO m, MonadThrow m, MonadCatch m) =>
    m ())
-> IO ()
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 ())
 -> IO ())
-> (forall {m :: * -> *}.
    (ChainBackend m, MonadIO m, MonadThrow m, MonadCatch m) =>
    m ())
-> IO ()
forall a b. (a -> b) -> a -> b
$ Tx -> m ()
forall (m :: * -> *). ChainBackend m => Tx -> m ()
submitTransaction Tx
tx
        IO (UTxO Era) -> IO ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (IO (UTxO Era) -> IO ()) -> IO (UTxO Era) -> IO ()
forall a b. (a -> b) -> a -> b
$ ChainBackendOptions
-> (forall {m :: * -> *}.
    (ChainBackend m, MonadIO m, MonadThrow m, MonadCatch m) =>
    m (UTxO Era))
-> IO (UTxO Era)
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 Era))
 -> IO (UTxO Era))
-> (forall {m :: * -> *}.
    (ChainBackend m, MonadIO m, MonadThrow m, MonadCatch m) =>
    m (UTxO Era))
-> IO (UTxO Era)
forall a b. (a -> b) -> a -> b
$ Tx -> VerificationKey PaymentKey -> m (UTxO Era)
forall (m :: * -> *).
ChainBackend m =>
Tx -> VerificationKey PaymentKey -> m (UTxO Era)
awaitTransaction Tx
tx VerificationKey PaymentKey
faucetVk
        Lovelace -> IO Lovelace
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Lovelace
allLovelace
  Tracer IO FaucetLog -> FaucetLog -> IO ()
forall (m :: * -> *) a. Tracer m a -> a -> m ()
traceWith Tracer IO FaucetLog
tracer (FaucetLog -> IO ()) -> FaucetLog -> IO ()
forall a b. (a -> b) -> a -> b
$ ReturnedFunds{Lovelace
$sel:returnAmount:TraceResourceExhaustedHandled :: Lovelace
returnAmount :: Lovelace
returnAmount}
  Lovelace -> IO Lovelace
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Lovelace
returnAmount
 where
  buildTxBody :: UTxO Era -> AddressInEra -> IO TxBody
buildTxBody UTxO Era
utxo AddressInEra
faucetAddress =
    -- Here we specify no outputs in the transaction so that a change output with the
    -- entire value is created and paid to the faucet address.
    ChainBackendOptions
-> (forall (m :: * -> *).
    (ChainBackend m, MonadIO m, MonadThrow m, MonadCatch m) =>
    m (Either (TxBodyErrorAutoBalance Era) Tx))
-> IO (Either (TxBodyErrorAutoBalance Era) Tx)
forall a.
ChainBackendOptions
-> (forall (m :: * -> *).
    (ChainBackend m, MonadIO m, MonadThrow m, MonadCatch m) =>
    m a)
-> IO a
runBackend ChainBackendOptions
opts (AddressInEra
-> UTxO Era
-> [TxIn]
-> [TxOut CtxTx Era]
-> m (Either (TxBodyErrorAutoBalance Era) Tx)
forall (m :: * -> *).
(ChainBackend m, MonadIO m) =>
AddressInEra
-> UTxO Era
-> [TxIn]
-> [TxOut CtxTx Era]
-> m (Either (TxBodyErrorAutoBalance Era) Tx)
buildTransaction AddressInEra
faucetAddress UTxO Era
utxo [] []) IO (Either (TxBodyErrorAutoBalance Era) Tx)
-> (Either (TxBodyErrorAutoBalance Era) Tx -> IO TxBody)
-> IO TxBody
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 -> FaucetException -> IO TxBody
forall e a. Exception e => e -> IO a
forall (m :: * -> *) e a. (MonadThrow m, Exception e) => e -> m a
throwIO (FaucetException -> IO TxBody) -> FaucetException -> IO TxBody
forall a b. (a -> b) -> a -> b
$ FaucetFailedToBuildTx{$sel:reason:FaucetHasNotEnoughFunds :: TxBodyErrorAutoBalance Era
reason = TxBodyErrorAutoBalance Era
e}
      Right Tx
tx -> TxBody -> IO TxBody
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (TxBody -> IO TxBody) -> TxBody -> IO TxBody
forall a b. (a -> b) -> a -> b
$ Tx -> TxBody
forall era. Tx era -> TxBody era
getTxBody Tx
tx

-- Use the Faucet utxo to create the output at specified address
createOutputAtAddress ::
  NetworkId ->
  ChainBackendOptions ->
  AddressInEra ->
  TxOutDatum CtxTx ->
  Value ->
  IO (TxIn, TxOut CtxUTxO)
createOutputAtAddress :: NetworkId
-> ChainBackendOptions
-> AddressInEra
-> TxOutDatum CtxTx
-> Value
-> IO (TxIn, TxOut CtxUTxO Era)
createOutputAtAddress NetworkId
networkId ChainBackendOptions
opts AddressInEra
atAddress TxOutDatum CtxTx
datum Value
val = do
  (VerificationKey PaymentKey
faucetVk, Secret (SigningKey PaymentKey)
faucetSk) <- Actor
-> IO (VerificationKey PaymentKey, Secret (SigningKey PaymentKey))
keysFor Actor
Faucet
  UTxO Era
utxo <- NetworkId -> ChainBackendOptions -> Lovelace -> IO (UTxO Era)
findFaucetUTxO NetworkId
networkId ChainBackendOptions
opts (Value -> Lovelace
selectLovelace Value
val)
  let collateralTxIns :: [TxIn]
collateralTxIns = [TxIn]
forall a. Monoid a => a
mempty
  let output :: TxOut CtxTx Era
output = AddressInEra
-> Value -> TxOutDatum CtxTx -> ReferenceScript -> TxOut CtxTx Era
forall ctx.
AddressInEra
-> Value -> TxOutDatum ctx -> ReferenceScript -> TxOut ctx
TxOut AddressInEra
atAddress Value
val TxOutDatum CtxTx
datum ReferenceScript
ReferenceScriptNone
  ChainBackendOptions
-> (forall (m :: * -> *).
    (ChainBackend m, MonadIO m, MonadThrow m, MonadCatch m) =>
    m (Either (TxBodyErrorAutoBalance Era) Tx))
-> IO (Either (TxBodyErrorAutoBalance Era) Tx)
forall a.
ChainBackendOptions
-> (forall (m :: * -> *).
    (ChainBackend m, MonadIO m, MonadThrow m, MonadCatch m) =>
    m a)
-> IO a
runBackend ChainBackendOptions
opts (AddressInEra
-> UTxO Era
-> [TxIn]
-> [TxOut CtxTx Era]
-> m (Either (TxBodyErrorAutoBalance Era) Tx)
forall (m :: * -> *).
(ChainBackend m, MonadIO m) =>
AddressInEra
-> UTxO Era
-> [TxIn]
-> [TxOut CtxTx Era]
-> m (Either (TxBodyErrorAutoBalance Era) Tx)
buildTransaction (NetworkId -> VerificationKey PaymentKey -> AddressInEra
forall era.
IsShelleyBasedEra era =>
NetworkId -> VerificationKey PaymentKey -> AddressInEra era
mkVkAddress NetworkId
networkId VerificationKey PaymentKey
faucetVk) UTxO Era
utxo [TxIn]
collateralTxIns [TxOut CtxTx Era
output]) IO (Either (TxBodyErrorAutoBalance Era) Tx)
-> (Either (TxBodyErrorAutoBalance Era) Tx
    -> IO (TxIn, TxOut CtxUTxO Era))
-> IO (TxIn, TxOut CtxUTxO Era)
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 ->
      ErrorAsException -> IO (TxIn, TxOut CtxUTxO Era)
forall e a. Exception e => e -> IO a
forall (m :: * -> *) e a. (MonadThrow m, Exception e) => e -> m a
throwIO (TxBodyErrorAutoBalance Era -> ErrorAsException
forall e.
(HasCallStack, Typeable e, Error e) =>
e -> ErrorAsException
ErrorAsException TxBodyErrorAutoBalance Era
e)
    Right Tx
x -> do
      let body :: TxBody
body = Tx -> TxBody
forall era. Tx era -> TxBody era
getTxBody Tx
x
      let tx :: Tx
tx = Secret (SigningKey PaymentKey)
-> (SigningKey PaymentKey -> Tx) -> Tx
forall a r. Secret a -> (a -> r) -> r
withSecret Secret (SigningKey PaymentKey)
faucetSk ((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
      ChainBackendOptions
-> (forall {m :: * -> *}.
    (ChainBackend m, MonadIO m, MonadThrow m, MonadCatch m) =>
    m ())
-> IO ()
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 ())
 -> IO ())
-> (forall {m :: * -> *}.
    (ChainBackend m, MonadIO m, MonadThrow m, MonadCatch m) =>
    m ())
-> IO ()
forall a b. (a -> b) -> a -> b
$ Tx -> m ()
forall (m :: * -> *). ChainBackend m => Tx -> m ()
submitTransaction Tx
tx
      UTxO Era
newUtxo <- ChainBackendOptions
-> (forall {m :: * -> *}.
    (ChainBackend m, MonadIO m, MonadThrow m, MonadCatch m) =>
    m (UTxO Era))
-> IO (UTxO Era)
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 Era))
 -> IO (UTxO Era))
-> (forall {m :: * -> *}.
    (ChainBackend m, MonadIO m, MonadThrow m, MonadCatch m) =>
    m (UTxO Era))
-> IO (UTxO Era)
forall a b. (a -> b) -> a -> b
$ Tx -> VerificationKey PaymentKey -> m (UTxO Era)
forall (m :: * -> *).
ChainBackend m =>
Tx -> VerificationKey PaymentKey -> m (UTxO Era)
awaitTransaction Tx
tx VerificationKey PaymentKey
faucetVk
      case (TxOut CtxUTxO Era -> Bool)
-> UTxO Era -> Maybe (TxIn, TxOut CtxUTxO Era)
forall era.
(TxOut CtxUTxO era -> Bool)
-> UTxO era -> Maybe (TxIn, TxOut CtxUTxO era)
UTxO.find (\TxOut CtxUTxO Era
out -> TxOut CtxUTxO Era -> AddressInEra
forall ctx. TxOut ctx -> AddressInEra
txOutAddress TxOut CtxUTxO Era
out AddressInEra -> AddressInEra -> Bool
forall a. Eq a => a -> a -> Bool
== AddressInEra
atAddress) UTxO Era
newUtxo of
        Maybe (TxIn, TxOut CtxUTxO Era)
Nothing -> String -> IO (TxIn, TxOut CtxUTxO Era)
forall (m :: * -> *) a.
(HasCallStack, MonadThrow m) =>
String -> m a
failure (String -> IO (TxIn, TxOut CtxUTxO Era))
-> String -> IO (TxIn, TxOut CtxUTxO Era)
forall a b. (a -> b) -> a -> b
$ String
"Could not find script output: " String -> ShowS
forall a. Semigroup a => a -> a -> a
<> ByteString -> String
forall a b. ConvertUtf8 a b => b -> a
decodeUtf8 (UTxO Era -> ByteString
forall a. ToJSON a => a -> ByteString
encodePretty UTxO Era
newUtxo)
        Just (TxIn, TxOut CtxUTxO Era)
u -> (TxIn, TxOut CtxUTxO Era) -> IO (TxIn, TxOut CtxUTxO Era)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (TxIn, TxOut CtxUTxO Era)
u

-- | Try to submit tx and retry when some caught exception/s take place.
retryOnExceptions :: (MonadCatch m, MonadDelay m) => Tracer m FaucetLog -> ChainBackendOptions -> m a -> m a
retryOnExceptions :: forall (m :: * -> *) a.
(MonadCatch m, MonadDelay m) =>
Tracer m FaucetLog -> ChainBackendOptions -> m a -> m a
retryOnExceptions Tracer m FaucetLog
tracer ChainBackendOptions
opts m a
action =
  m a
action
    m a -> [Handler m a] -> m a
forall (m :: * -> *) a. MonadCatch m => m a -> [Handler m a] -> m a
`catches` [ (SubmitTransactionException -> m a) -> Handler m a
forall {k} (m :: k -> *) (a :: k) e.
Exception e =>
(e -> m a) -> Handler m a
Handler ((SubmitTransactionException -> m a) -> Handler m a)
-> (SubmitTransactionException -> m a) -> Handler m a
forall a b. (a -> b) -> a -> b
$ \(SubmitTransactionException
ex :: SubmitTransactionException) -> do
                  Tracer m FaucetLog -> FaucetLog -> m ()
forall (m :: * -> *) a. Tracer m a -> a -> m ()
traceWith Tracer m FaucetLog
tracer (FaucetLog -> m ()) -> FaucetLog -> m ()
forall a b. (a -> b) -> a -> b
$
                    Text -> FaucetLog
SubmitTxError (Text -> FaucetLog) -> Text -> FaucetLog
forall a b. (a -> b) -> a -> b
$
                      SubmitTransactionException -> Text
forall b a. (Show a, IsString b) => a -> b
show SubmitTransactionException
ex
                  ChainBackendOptions -> m ()
forall (m :: * -> *). MonadDelay m => ChainBackendOptions -> m ()
delayBF ChainBackendOptions
opts
                  Tracer m FaucetLog -> ChainBackendOptions -> m a -> m a
forall (m :: * -> *) a.
(MonadCatch m, MonadDelay m) =>
Tracer m FaucetLog -> ChainBackendOptions -> m a -> m a
retryOnExceptions Tracer m FaucetLog
tracer ChainBackendOptions
opts m a
action
              , (IOException -> m a) -> Handler m a
forall {k} (m :: k -> *) (a :: k) e.
Exception e =>
(e -> m a) -> Handler m a
Handler ((IOException -> m a) -> Handler m a)
-> (IOException -> m a) -> Handler m a
forall a b. (a -> b) -> a -> b
$ \(IOException
ex :: IOException) -> do
                  Bool -> m () -> m ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (IOException -> Bool
isResourceExhausted IOException
ex) (m () -> m ()) -> m () -> m ()
forall a b. (a -> b) -> a -> b
$
                    IOException -> m ()
forall e a. Exception e => e -> m a
forall (m :: * -> *) e a. (MonadThrow m, Exception e) => e -> m a
throwIO IOException
ex
                  Tracer m FaucetLog -> FaucetLog -> m ()
forall (m :: * -> *) a. Tracer m a -> a -> m ()
traceWith Tracer m FaucetLog
tracer (FaucetLog -> m ()) -> FaucetLog -> m ()
forall a b. (a -> b) -> a -> b
$
                    Text -> FaucetLog
TraceResourceExhaustedHandled (Text -> FaucetLog) -> Text -> FaucetLog
forall a b. (a -> b) -> a -> b
$
                      Text
"Expected exception raised from seedFromFaucet: " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> IOException -> Text
forall b a. (Show a, IsString b) => a -> b
show IOException
ex
                  ChainBackendOptions -> m ()
forall (m :: * -> *). MonadDelay m => ChainBackendOptions -> m ()
delayBF ChainBackendOptions
opts
                  Tracer m FaucetLog -> ChainBackendOptions -> m a -> m a
forall (m :: * -> *) a.
(MonadCatch m, MonadDelay m) =>
Tracer m FaucetLog -> ChainBackendOptions -> m a -> m a
retryOnExceptions Tracer m FaucetLog
tracer ChainBackendOptions
opts m a
action
              ]
 where
  isResourceExhausted :: IOException -> Bool
isResourceExhausted IOException
ex = case IOException -> IOErrorType
ioe_type IOException
ex of
    IOErrorType
ResourceExhausted -> Bool
True
    IOErrorType
_other -> Bool
False

-- | Publish current Hydra scripts as scripts outputs for later referencing them.
--
-- The key of the given Actor is used to pay for fees in required transactions,
-- it is expected to have sufficient funds.
publishHydraScriptsAs :: ChainBackendOptions -> Actor -> IO [TxId]
publishHydraScriptsAs :: ChainBackendOptions -> Actor -> IO [TxId]
publishHydraScriptsAs ChainBackendOptions
opts Actor
actor = do
  (VerificationKey PaymentKey
_, Secret (SigningKey PaymentKey)
sk) <- Actor
-> IO (VerificationKey PaymentKey, Secret (SigningKey PaymentKey))
keysFor Actor
actor
  ChainBackendOptions
-> (forall {m :: * -> *}.
    (ChainBackend m, MonadIO m, MonadThrow m, MonadCatch m) =>
    m [TxId])
-> IO [TxId]
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 [TxId])
 -> IO [TxId])
-> (forall {m :: * -> *}.
    (ChainBackend m, MonadIO m, MonadThrow m, MonadCatch m) =>
    m [TxId])
-> IO [TxId]
forall a b. (a -> b) -> a -> b
$ Secret CardanoSigningKey -> m [TxId]
forall (m :: * -> *).
(ChainBackend m, MonadIO m, MonadCatch m) =>
Secret CardanoSigningKey -> m [TxId]
publishHydraScripts (Secret (SigningKey PaymentKey)
-> (SigningKey PaymentKey -> Secret CardanoSigningKey)
-> Secret CardanoSigningKey
forall a r. Secret a -> (a -> r) -> r
withSecret Secret (SigningKey PaymentKey)
sk (CardanoSigningKey -> Secret CardanoSigningKey
forall a. a -> Secret a
mkSecret (CardanoSigningKey -> Secret CardanoSigningKey)
-> (SigningKey PaymentKey -> CardanoSigningKey)
-> SigningKey PaymentKey
-> Secret CardanoSigningKey
forall b c a. (b -> c) -> (a -> b) -> a -> c
. SigningKey PaymentKey -> CardanoSigningKey
CardanoSigningKey))

-- | Like 'publishHydraScriptsAs', but caches the resulting 'TxId's to a file
-- in the given directory. On subsequent calls, the cached 'TxId's are validated
-- against the chain (using 'queryScriptRegistry') and reused if still valid.
-- This avoids re-publishing identical scripts on every test run, saving funds
-- and time especially on public testnets.
publishOrReuseHydraScripts :: ChainBackendOptions -> Actor -> FilePath -> IO [TxId]
publishOrReuseHydraScripts :: ChainBackendOptions -> Actor -> String -> IO [TxId]
publishOrReuseHydraScripts ChainBackendOptions
opts Actor
actor String
cacheDir = do
  let cacheFile :: String
cacheFile = String
cacheDir String -> ShowS
</> String
".hydra-scripts-tx-ids"
  String -> IO (Maybe [TxId])
readCachedTxIds String
cacheFile IO (Maybe [TxId]) -> (Maybe [TxId] -> 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
    Just [TxId]
txIds -> do
      Either SomeException ScriptRegistry
result <- IO ScriptRegistry -> IO (Either SomeException ScriptRegistry)
forall e a. Exception e => IO a -> IO (Either e a)
forall (m :: * -> *) e a.
(MonadCatch m, Exception e) =>
m a -> m (Either e a)
try (IO ScriptRegistry -> IO (Either SomeException ScriptRegistry))
-> IO ScriptRegistry -> IO (Either SomeException ScriptRegistry)
forall a b. (a -> b) -> a -> b
$ ChainBackendOptions
-> (forall {m :: * -> *}.
    (ChainBackend m, MonadIO m, MonadThrow m, MonadCatch m) =>
    m ScriptRegistry)
-> IO ScriptRegistry
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 ScriptRegistry)
 -> IO ScriptRegistry)
-> (forall {m :: * -> *}.
    (ChainBackend m, MonadIO m, MonadThrow m, MonadCatch m) =>
    m ScriptRegistry)
-> IO ScriptRegistry
forall a b. (a -> b) -> a -> b
$ [TxId] -> m ScriptRegistry
forall (m :: * -> *). ChainBackend m => [TxId] -> m ScriptRegistry
queryScriptRegistry [TxId]
txIds
      case Either SomeException ScriptRegistry
result of
        Right ScriptRegistry
_registry -> [TxId] -> IO [TxId]
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure [TxId]
txIds
        Left (SomeException
_ :: SomeException) -> String -> IO [TxId]
publishAndCache String
cacheFile
    Maybe [TxId]
Nothing -> String -> IO [TxId]
publishAndCache String
cacheFile
 where
  readCachedTxIds :: FilePath -> IO (Maybe [TxId])
  readCachedTxIds :: String -> IO (Maybe [TxId])
readCachedTxIds String
path = do
    Bool
exists <- String -> IO Bool
doesFileExist String
path
    if Bool
exists
      then (String -> Maybe [TxId])
-> ([TxId] -> Maybe [TxId]) -> Either String [TxId] -> Maybe [TxId]
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (Maybe [TxId] -> String -> Maybe [TxId]
forall a b. a -> b -> a
const Maybe [TxId]
forall a. Maybe a
Nothing) [TxId] -> Maybe [TxId]
forall a. a -> Maybe a
Just (Either String [TxId] -> Maybe [TxId])
-> IO (Either String [TxId]) -> IO (Maybe [TxId])
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> String -> IO (Either String [TxId])
forall a. FromJSON a => String -> IO (Either String a)
Aeson.eitherDecodeFileStrict String
path
      else Maybe [TxId] -> IO (Maybe [TxId])
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe [TxId]
forall a. Maybe a
Nothing

  publishAndCache :: FilePath -> IO [TxId]
  publishAndCache :: String -> IO [TxId]
publishAndCache String
path = do
    [TxId]
txIds <- ChainBackendOptions -> Actor -> IO [TxId]
publishHydraScriptsAs ChainBackendOptions
opts Actor
actor
    String -> [TxId] -> IO ()
forall a. ToJSON a => String -> a -> IO ()
Aeson.encodeFile String
path [TxId]
txIds
    [TxId] -> IO [TxId]
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure [TxId]
txIds