{-# 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 -> Coin
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 =
  ChainBackendOptions
-> [(VerificationKey PaymentKey, Value)]
-> Tracer IO FaucetLog
-> Maybe PlutusScript
-> IO [UTxO Era]
seedManyFromFaucetWithMinting ChainBackendOptions
opts [(VerificationKey PaymentKey
receivingVerificationKey, Value
val)] Tracer IO FaucetLog
tracer Maybe PlutusScript
mintingScript IO [UTxO Era] -> ([UTxO Era] -> IO (UTxO Era)) -> IO (UTxO 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
    [UTxO Era
utxo] -> UTxO Era -> IO (UTxO Era)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure UTxO Era
utxo
    [UTxO Era]
utxos -> String -> IO (UTxO Era)
forall (m :: * -> *) a.
(HasCallStack, MonadThrow m) =>
String -> m a
failure (String -> IO (UTxO Era)) -> String -> IO (UTxO Era)
forall a b. (a -> b) -> a -> b
$ String
"seedFromFaucetWithMinting: expected one seeded UTxO, got " String -> ShowS
forall a. Semigroup a => a -> a -> a
<> Int -> String
forall b a. (Show a, IsString b) => a -> b
show ([UTxO Era] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [UTxO Era]
utxos)

-- | Like 'seedFromFaucet' but pays every recipient from a single faucet
-- transaction. A scenario needing more than one funded key then waits for one
-- confirmation instead of one per key, which is a block time each on a public
-- network.
seedManyFromFaucet ::
  ChainBackendOptions ->
  -- | Recipients of the funds and the value each is to receive.
  [(VerificationKey PaymentKey, Value)] ->
  Tracer IO FaucetLog ->
  -- | The seeded UTxO of each recipient, in the order given.
  IO [UTxO]
seedManyFromFaucet :: ChainBackendOptions
-> [(VerificationKey PaymentKey, Value)]
-> Tracer IO FaucetLog
-> IO [UTxO Era]
seedManyFromFaucet ChainBackendOptions
opts [(VerificationKey PaymentKey, Value)]
recipients Tracer IO FaucetLog
tracer =
  ChainBackendOptions
-> [(VerificationKey PaymentKey, Value)]
-> Tracer IO FaucetLog
-> Maybe PlutusScript
-> IO [UTxO Era]
seedManyFromFaucetWithMinting ChainBackendOptions
opts [(VerificationKey PaymentKey, Value)]
recipients Tracer IO FaucetLog
tracer Maybe PlutusScript
forall a. Maybe a
Nothing

seedManyFromFaucetWithMinting ::
  ChainBackendOptions ->
  -- | Recipients of the funds and the value each is to receive.
  [(VerificationKey PaymentKey, Value)] ->
  Tracer IO FaucetLog ->
  Maybe PlutusScript ->
  -- | The seeded UTxO of each recipient, in the order given.
  IO [UTxO]
seedManyFromFaucetWithMinting :: ChainBackendOptions
-> [(VerificationKey PaymentKey, Value)]
-> Tracer IO FaucetLog
-> Maybe PlutusScript
-> IO [UTxO Era]
seedManyFromFaucetWithMinting ChainBackendOptions
_ [] Tracer IO FaucetLog
_ Maybe PlutusScript
_ = [UTxO Era] -> IO [UTxO Era]
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure []
seedManyFromFaucetWithMinting ChainBackendOptions
opts [(VerificationKey PaymentKey, Value)]
recipients 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
  -- NOTE: The direct backend's 'awaitTransaction' yields all of the tx's
  -- outputs while the Blockfrost one yields only those paying to the given key,
  -- so ask per recipient and filter. Only the first call waits for the
  -- transaction, the rest are already satisfied by it.
  [(VerificationKey PaymentKey, Value)]
-> ((VerificationKey PaymentKey, Value) -> IO (UTxO Era))
-> IO [UTxO Era]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM [(VerificationKey PaymentKey, Value)]
recipients (((VerificationKey PaymentKey, Value) -> IO (UTxO Era))
 -> IO [UTxO Era])
-> ((VerificationKey PaymentKey, Value) -> IO (UTxO Era))
-> IO [UTxO Era]
forall a b. (a -> b) -> a -> b
$ \(VerificationKey PaymentKey
vk, Value
val) -> do
    UTxO Era
seeded <-
      (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 -> VerificationKey PaymentKey -> Value -> TxOut CtxTx Era
theOutput NetworkId
networkId VerificationKey PaymentKey
vk Value
val))
        (UTxO Era -> UTxO Era) -> IO (UTxO Era) -> IO (UTxO Era)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f 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 (Tx -> VerificationKey PaymentKey -> m (UTxO Era)
forall (m :: * -> *).
ChainBackend m =>
Tx -> VerificationKey PaymentKey -> m (UTxO Era)
awaitTransaction Tx
seedTx VerificationKey PaymentKey
vk)
    -- An empty result means the output we asked for is not the one that landed
    -- (a value normalised on the way out, say). Say so here rather than let the
    -- caller trip over an empty UTxO much later.
    Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (UTxO Era -> Bool
forall era. UTxO era -> Bool
UTxO.null UTxO Era
seeded) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$
      String -> IO ()
forall (m :: * -> *) a.
(HasCallStack, MonadThrow m) =>
String -> m a
failure (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$
        String
"seedManyFromFaucet: no output of " String -> ShowS
forall a. Semigroup a => a -> a -> a
<> Value -> String
forall b a. (Show a, IsString b) => a -> b
show Value
val String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
" for " String -> ShowS
forall a. Semigroup a => a -> a -> a
<> VerificationKey PaymentKey -> String
forall b a. (Show a, IsString b) => a -> b
show VerificationKey PaymentKey
vk String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
" in " String -> ShowS
forall a. Semigroup a => a -> a -> a
<> TxId -> String
forall b a. (Show a, IsString b) => a -> b
show (TxBody Era -> TxId
forall era. TxBody era -> TxId
getTxId (TxBody Era -> TxId) -> TxBody Era -> TxId
forall a b. (a -> b) -> a -> b
$ Tx -> TxBody Era
forall era. Tx era -> TxBody era
getTxBody Tx
seedTx)
    UTxO Era -> IO (UTxO Era)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure UTxO Era
seeded
 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 -> Coin -> IO (UTxO Era)
findFaucetUTxO NetworkId
networkId ChainBackendOptions
opts ([Coin] -> Coin
forall a (f :: * -> *). (Foldable f, Num a) => f a -> a
sum ([Coin] -> Coin) -> [Coin] -> Coin
forall a b. (a -> b) -> a -> b
$ Value -> Coin
selectLovelace (Value -> Coin)
-> ((VerificationKey PaymentKey, Value) -> Value)
-> (VerificationKey PaymentKey, Value)
-> Coin
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (VerificationKey PaymentKey, Value) -> Value
forall a b. (a, b) -> b
snd ((VerificationKey PaymentKey, Value) -> Coin)
-> [(VerificationKey PaymentKey, Value)] -> [Coin]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [(VerificationKey PaymentKey, Value)]
recipients)
    let changeAddress :: AddressInEra
changeAddress = NetworkId -> VerificationKey PaymentKey -> AddressInEra
forall era.
IsShelleyBasedEra era =>
NetworkId -> VerificationKey PaymentKey -> AddressInEra era
mkVkAddress NetworkId
networkId VerificationKey PaymentKey
faucetVk
    let outputs :: [TxOut CtxTx Era]
outputs = (VerificationKey PaymentKey -> Value -> TxOut CtxTx Era)
-> (VerificationKey PaymentKey, Value) -> TxOut CtxTx Era
forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry (NetworkId -> VerificationKey PaymentKey -> Value -> TxOut CtxTx Era
theOutput NetworkId
networkId) ((VerificationKey PaymentKey, Value) -> TxOut CtxTx Era)
-> [(VerificationKey PaymentKey, Value)] -> [TxOut CtxTx Era]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [(VerificationKey PaymentKey, Value)]
recipients

    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) [TxOut CtxTx Era]
outputs 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 Era -> Tx
sign Secret (SigningKey PaymentKey)
faucetSk (Tx -> TxBody Era
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

  theOutput :: NetworkId -> VerificationKey PaymentKey -> Value -> TxOut CtxTx
  theOutput :: NetworkId -> VerificationKey PaymentKey -> Value -> TxOut CtxTx Era
theOutput NetworkId
networkId VerificationKey PaymentKey
vk Value
val =
    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 (VerificationKey PaymentKey -> NetworkId -> Address ShelleyAddr
buildAddress VerificationKey PaymentKey
vk NetworkId
networkId))
      Value
val
      TxOutDatum CtxTx
forall ctx. TxOutDatum ctx
TxOutDatumNone
      ReferenceScript
ReferenceScriptNone

findFaucetUTxO :: NetworkId -> ChainBackendOptions -> Coin -> IO UTxO
findFaucetUTxO :: NetworkId -> ChainBackendOptions -> Coin -> IO (UTxO Era)
findFaucetUTxO NetworkId
networkId ChainBackendOptions
opts Coin
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 -> Coin -> IO (UTxO Era)
forall (m :: * -> *). MonadIO m => UTxO Era -> Coin -> m (UTxO Era)
findUTxO UTxO Era
faucetUTxO Coin
lovelace

seedFromFaucetBlockfrost ::
  -- | Recipient of the funds
  VerificationKey PaymentKey ->
  -- | Amount to get from faucet
  Coin ->
  Blockfrost.BlockfrostClientT IO UTxO
seedFromFaucetBlockfrost :: VerificationKey PaymentKey
-> Coin -> BlockfrostClientT IO (UTxO Era)
seedFromFaucetBlockfrost VerificationKey PaymentKey
receivingVerificationKey Coin
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)
          (Coin -> Value
lovelaceToValue Coin
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 -> Coin -> BlockfrostClientT IO (UTxO Era)
forall (m :: * -> *). MonadIO m => UTxO Era -> Coin -> m (UTxO Era)
findUTxO UTxO Era
faucetUTxO Coin
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

-- | Select entries covering the given amount, largest first, and sweep up to
-- 'sweepLimit' of the smallest remaining entries into the selection. Both parts
-- keep the faucet usable across runs: outputs smaller than a requested amount
-- (e.g. what 'returnFundsToFaucet' pays back) would otherwise never be spent
-- again, while the change output alone shrinks with every seeding.
findUTxO :: MonadIO m => UTxO.UTxO Era -> Lovelace -> m (UTxO.UTxO Era)
findUTxO :: forall (m :: * -> *). MonadIO m => UTxO Era -> Coin -> m (UTxO Era)
findUTxO UTxO Era
utxo Coin
lovelace' =
  Coin
-> [(TxIn, TxOut CtxUTxO Era)]
-> [(TxIn, TxOut CtxUTxO Era)]
-> m (UTxO Era)
go Coin
0 [] (((TxIn, TxOut CtxUTxO Era) -> Down Coin)
-> [(TxIn, TxOut CtxUTxO Era)] -> [(TxIn, TxOut CtxUTxO Era)]
forall b a. Ord b => (a -> b) -> [a] -> [a]
sortOn (Coin -> Down Coin
forall a. a -> Down a
Down (Coin -> Down Coin)
-> ((TxIn, TxOut CtxUTxO Era) -> Coin)
-> (TxIn, TxOut CtxUTxO Era)
-> Down Coin
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TxOut CtxUTxO Era -> Coin
lovelaceOf (TxOut CtxUTxO Era -> Coin)
-> ((TxIn, TxOut CtxUTxO Era) -> TxOut CtxUTxO Era)
-> (TxIn, TxOut CtxUTxO Era)
-> Coin
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (TxIn, TxOut CtxUTxO Era) -> TxOut CtxUTxO Era
forall a b. (a, b) -> b
snd) (UTxO Era -> [(TxIn, TxOut CtxUTxO Era)]
forall era. UTxO era -> [(TxIn, TxOut CtxUTxO era)]
UTxO.toList UTxO Era
utxo))
 where
  go :: Coin
-> [(TxIn, TxOut CtxUTxO Era)]
-> [(TxIn, TxOut CtxUTxO Era)]
-> m (UTxO Era)
go Coin
total [(TxIn, TxOut CtxUTxO Era)]
selected [(TxIn, TxOut CtxUTxO Era)]
rest
    | Coin
total Coin -> Coin -> Bool
forall a. Ord a => a -> a -> Bool
>= Coin
lovelace' =
        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
$ [(TxIn, TxOut CtxUTxO Era)] -> UTxO Era
forall era. [(TxIn, TxOut CtxUTxO era)] -> UTxO era
UTxO.fromList ([(TxIn, TxOut CtxUTxO Era)]
selected [(TxIn, TxOut CtxUTxO Era)]
-> [(TxIn, TxOut CtxUTxO Era)] -> [(TxIn, TxOut CtxUTxO Era)]
forall a. Semigroup a => a -> a -> a
<> Int -> [(TxIn, TxOut CtxUTxO Era)] -> [(TxIn, TxOut CtxUTxO Era)]
forall a. Int -> [a] -> [a]
take Int
sweepLimit ([(TxIn, TxOut CtxUTxO Era)] -> [(TxIn, TxOut CtxUTxO Era)]
forall a. [a] -> [a]
reverse [(TxIn, TxOut CtxUTxO Era)]
rest))
    | Bool
otherwise = case [(TxIn, TxOut CtxUTxO Era)]
rest of
        [] -> IO (UTxO Era) -> m (UTxO Era)
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (UTxO Era) -> m (UTxO Era)) -> IO (UTxO Era) -> m (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 FaucetHasNotEnoughFunds{$sel:faucetUTxO:FaucetHasNotEnoughFunds :: UTxO Era
faucetUTxO = UTxO Era
utxo}
        (TxIn, TxOut CtxUTxO Era)
entry : [(TxIn, TxOut CtxUTxO Era)]
more -> Coin
-> [(TxIn, TxOut CtxUTxO Era)]
-> [(TxIn, TxOut CtxUTxO Era)]
-> m (UTxO Era)
go (Coin
total Coin -> Coin -> Coin
forall a. Num a => a -> a -> a
+ TxOut CtxUTxO Era -> Coin
lovelaceOf ((TxIn, TxOut CtxUTxO Era) -> TxOut CtxUTxO Era
forall a b. (a, b) -> b
snd (TxIn, TxOut CtxUTxO Era)
entry)) ((TxIn, TxOut CtxUTxO Era)
entry (TxIn, TxOut CtxUTxO Era)
-> [(TxIn, TxOut CtxUTxO Era)] -> [(TxIn, TxOut CtxUTxO Era)]
forall a. a -> [a] -> [a]
: [(TxIn, TxOut CtxUTxO Era)]
selected) [(TxIn, TxOut CtxUTxO Era)]
more

  lovelaceOf :: TxOut CtxUTxO -> Lovelace
  lovelaceOf :: TxOut CtxUTxO Era -> Coin
lovelaceOf = Value -> Coin
selectLovelace (Value -> Coin)
-> (TxOut CtxUTxO Era -> Value) -> TxOut CtxUTxO Era -> Coin
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TxOut CtxUTxO Era -> Value
forall ctx. TxOut ctx -> Value
txOutValue

-- | Cap on the extra entries 'findUTxO' sweeps into a transaction, bounding its
-- size. Consolidation only has to outpace the one or two outputs a scenario
-- returns to the faucet per run.
sweepLimit :: Int
sweepLimit :: Int
sweepLimit = Int
20

-- | 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
-> Coin
-> Tracer IO FaucetLog
-> IO ()
seedFromFaucet_ ChainBackendOptions
opts VerificationKey PaymentKey
vk Coin
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 (Coin -> Value
lovelaceToValue Coin
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 Coin -> IO ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (IO Coin -> IO ()) -> IO Coin -> IO ()
forall a b. (a -> b) -> a -> b
$ Tracer IO FaucetLog
-> ChainBackendOptions -> Secret (SigningKey PaymentKey) -> IO Coin
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 Coin
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
  Coin
returnAmount <-
    if UTxO Era -> Bool
forall era. UTxO era -> Bool
UTxO.null UTxO Era
utxo
      then Coin -> IO Coin
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Coin
0
      else Tracer IO FaucetLog -> ChainBackendOptions -> IO Coin -> IO Coin
forall (m :: * -> *) a.
(MonadCatch m, MonadDelay m) =>
Tracer m FaucetLog -> ChainBackendOptions -> m a -> m a
retryOnExceptions Tracer IO FaucetLog
tracer ChainBackendOptions
opts (IO Coin -> IO Coin) -> IO Coin -> IO Coin
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 :: Coin
allLovelace = Value -> Coin
selectLovelace Value
ValueType Tx
utxoValue
        Tx
tx <- Secret (SigningKey PaymentKey) -> TxBody Era -> Tx
sign Secret (SigningKey PaymentKey)
senderSk (TxBody Era -> Tx) -> IO (TxBody Era) -> IO Tx
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> UTxO Era -> AddressInEra -> IO (TxBody Era)
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
        Coin -> IO Coin
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Coin
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{Coin
$sel:returnAmount:TraceResourceExhaustedHandled :: Coin
returnAmount :: Coin
returnAmount}
  Coin -> IO Coin
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Coin
returnAmount
 where
  buildTxBody :: UTxO Era -> AddressInEra -> IO (TxBody Era)
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 Era))
-> IO (TxBody 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 -> FaucetException -> IO (TxBody Era)
forall e a. Exception e => e -> IO a
forall (m :: * -> *) e a. (MonadThrow m, Exception e) => e -> m a
throwIO (FaucetException -> IO (TxBody Era))
-> FaucetException -> IO (TxBody Era)
forall a b. (a -> b) -> a -> b
$ FaucetFailedToBuildTx{$sel:reason:FaucetHasNotEnoughFunds :: TxBodyErrorAutoBalance Era
reason = TxBodyErrorAutoBalance Era
e}
      Right Tx
tx -> TxBody Era -> IO (TxBody Era)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (TxBody Era -> IO (TxBody Era)) -> TxBody Era -> IO (TxBody Era)
forall a b. (a -> b) -> a -> b
$ Tx -> TxBody Era
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 -> Coin -> IO (UTxO Era)
findFaucetUTxO NetworkId
networkId ChainBackendOptions
opts (Value -> Coin
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 Era
body = Tx -> TxBody Era
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 Era -> Tx
forall era. [KeyWitness era] -> TxBody era -> Tx era
makeSignedTransaction [TxBody Era -> ShelleyWitnessSigningKey -> KeyWitness Era
makeShelleyKeyWitness TxBody Era
body (SigningKey PaymentKey -> ShelleyWitnessSigningKey
WitnessPaymentKey SigningKey PaymentKey
rawSk)] TxBody Era
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