{-# LANGUAGE DuplicateRecordFields #-}
module Hydra.Cluster.Faucet where
import Hydra.Cardano.Api
import Hydra.Prelude
import Test.Hydra.Prelude
import Cardano.Api.UTxO qualified as UTxO
import CardanoClient (
QueryPoint (QueryTip),
SubmitTransactionException,
buildAddress,
sign,
)
import Control.Exception (IOException)
import Control.Monad.Class.MonadThrow (Handler (Handler), catches)
import Control.Tracer (Tracer, traceWith)
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, buildTransactionWithPParams')
import Hydra.Chain.Backend qualified as Backend
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.Tx (balance, txId)
data FaucetException
= FaucetHasNotEnoughFunds {FaucetException -> UTxO
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}
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)
seedFromFaucet ::
ChainBackend backend =>
backend ->
VerificationKey PaymentKey ->
Coin ->
Tracer IO FaucetLog ->
IO UTxO
seedFromFaucet :: forall backend.
ChainBackend backend =>
backend
-> VerificationKey PaymentKey
-> Coin
-> Tracer IO FaucetLog
-> IO UTxO
seedFromFaucet backend
backend VerificationKey PaymentKey
receivingVerificationKey Coin
lovelace Tracer IO FaucetLog
tracer = do
(VerificationKey PaymentKey
faucetVk, SigningKey PaymentKey
faucetSk) <- Actor -> IO (VerificationKey PaymentKey, SigningKey PaymentKey)
keysFor Actor
Faucet
NetworkId
networkId <- backend -> IO NetworkId
forall a (m :: * -> *).
(ChainBackend a, MonadIO m, MonadThrow m) =>
a -> m NetworkId
forall (m :: * -> *).
(MonadIO m, MonadThrow m) =>
backend -> m NetworkId
Backend.queryNetworkId backend
backend
Tx Era
seedTx <- Tracer IO FaucetLog -> IO (Tx Era) -> IO (Tx Era)
forall (m :: * -> *) a.
(MonadCatch m, MonadDelay m) =>
Tracer m FaucetLog -> m a -> m a
retryOnExceptions Tracer IO FaucetLog
tracer (IO (Tx Era) -> IO (Tx Era)) -> IO (Tx Era) -> IO (Tx Era)
forall a b. (a -> b) -> a -> b
$ VerificationKey PaymentKey
-> SigningKey PaymentKey -> NetworkId -> IO (Tx Era)
submitSeedTx VerificationKey PaymentKey
faucetVk SigningKey PaymentKey
faucetSk NetworkId
networkId
UTxO
producedUTxO <- backend -> Tx Era -> VerificationKey PaymentKey -> IO UTxO
forall a (m :: * -> *).
(ChainBackend a, MonadIO m, MonadThrow m) =>
a -> Tx Era -> VerificationKey PaymentKey -> m UTxO
forall (m :: * -> *).
(MonadIO m, MonadThrow m) =>
backend -> Tx Era -> VerificationKey PaymentKey -> m UTxO
Backend.awaitTransaction backend
backend Tx Era
seedTx VerificationKey PaymentKey
receivingVerificationKey
UTxO -> IO UTxO
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (UTxO -> IO UTxO) -> UTxO -> IO UTxO
forall a b. (a -> b) -> a -> b
$ (TxOut CtxUTxO Era -> Bool) -> UTxO -> UTxO
forall out. (out -> Bool) -> UTxO' out -> UTxO' out
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
producedUTxO
where
submitSeedTx :: VerificationKey PaymentKey
-> SigningKey PaymentKey -> NetworkId -> IO (Tx Era)
submitSeedTx VerificationKey PaymentKey
faucetVk SigningKey PaymentKey
faucetSk NetworkId
networkId = do
UTxO
faucetUTxO <- NetworkId -> backend -> Coin -> IO UTxO
forall backend.
ChainBackend backend =>
NetworkId -> backend -> Coin -> IO UTxO
findFaucetUTxO NetworkId
networkId backend
backend Coin
lovelace
let changeAddress :: AddressInEra Era
changeAddress = NetworkId -> VerificationKey PaymentKey -> AddressInEra Era
forall era.
IsShelleyBasedEra era =>
NetworkId -> VerificationKey PaymentKey -> AddressInEra era
mkVkAddress NetworkId
networkId VerificationKey PaymentKey
faucetVk
backend
-> AddressInEra Era
-> UTxO
-> [TxIn]
-> [TxOut CtxTx Era]
-> IO (Either (TxBodyErrorAutoBalance Era) (Tx Era))
forall backend.
ChainBackend backend =>
backend
-> AddressInEra Era
-> UTxO
-> [TxIn]
-> [TxOut CtxTx Era]
-> IO (Either (TxBodyErrorAutoBalance Era) (Tx Era))
buildTransaction backend
backend AddressInEra Era
changeAddress UTxO
faucetUTxO [] [NetworkId -> TxOut CtxTx Era
theOutput NetworkId
networkId] IO (Either (TxBodyErrorAutoBalance Era) (Tx Era))
-> (Either (TxBodyErrorAutoBalance Era) (Tx Era) -> IO (Tx Era))
-> IO (Tx 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 (Tx Era)
forall e a. Exception e => e -> IO a
forall (m :: * -> *) e a. (MonadThrow m, Exception e) => e -> m a
throwIO (FaucetException -> IO (Tx Era)) -> FaucetException -> IO (Tx Era)
forall a b. (a -> b) -> a -> b
$ FaucetFailedToBuildTx{$sel:reason:FaucetHasNotEnoughFunds :: TxBodyErrorAutoBalance Era
reason = TxBodyErrorAutoBalance Era
e}
Right Tx Era
tx -> do
let signedTx :: Tx Era
signedTx = SigningKey PaymentKey -> TxBody -> Tx Era
sign SigningKey PaymentKey
faucetSk (TxBody -> Tx Era) -> TxBody -> Tx Era
forall a b. (a -> b) -> a -> b
$ Tx Era -> TxBody
forall era. Tx era -> TxBody era
getTxBody Tx Era
tx
backend -> Tx Era -> IO ()
forall a (m :: * -> *).
(ChainBackend a, MonadIO m, MonadThrow m) =>
a -> Tx Era -> m ()
forall (m :: * -> *).
(MonadIO m, MonadThrow m) =>
backend -> Tx Era -> m ()
Backend.submitTransaction backend
backend Tx Era
signedTx
Tx Era -> IO (Tx Era)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Tx Era
signedTx
receivingAddress :: NetworkId -> Address ShelleyAddr
receivingAddress = VerificationKey PaymentKey -> NetworkId -> Address ShelleyAddr
buildAddress VerificationKey PaymentKey
receivingVerificationKey
theOutput :: NetworkId -> TxOut CtxTx Era
theOutput NetworkId
networkId =
AddressInEra Era
-> Value -> TxOutDatum CtxTx -> ReferenceScript -> TxOut CtxTx Era
forall ctx.
AddressInEra Era
-> Value -> TxOutDatum ctx -> ReferenceScript -> TxOut ctx
TxOut
(ShelleyBasedEra Era -> Address ShelleyAddr -> AddressInEra Era
forall era.
ShelleyBasedEra era -> Address ShelleyAddr -> AddressInEra era
shelleyAddressInEra ShelleyBasedEra Era
forall era. IsShelleyBasedEra era => ShelleyBasedEra era
shelleyBasedEra (NetworkId -> Address ShelleyAddr
receivingAddress NetworkId
networkId))
(Coin -> Value
lovelaceToValue Coin
lovelace)
TxOutDatum CtxTx
forall ctx. TxOutDatum ctx
TxOutDatumNone
ReferenceScript
ReferenceScriptNone
findFaucetUTxO :: ChainBackend backend => NetworkId -> backend -> Coin -> IO UTxO
findFaucetUTxO :: forall backend.
ChainBackend backend =>
NetworkId -> backend -> Coin -> IO UTxO
findFaucetUTxO NetworkId
networkId backend
backend Coin
lovelace = do
(VerificationKey PaymentKey
faucetVk, SigningKey PaymentKey
_) <- Actor -> IO (VerificationKey PaymentKey, SigningKey PaymentKey)
keysFor Actor
Faucet
UTxO
faucetUTxO <- backend -> [Address ShelleyAddr] -> IO UTxO
forall a (m :: * -> *).
(ChainBackend a, MonadIO m, MonadThrow m) =>
a -> [Address ShelleyAddr] -> m UTxO
forall (m :: * -> *).
(MonadIO m, MonadThrow m) =>
backend -> [Address ShelleyAddr] -> m UTxO
Backend.queryUTxO backend
backend [VerificationKey PaymentKey -> NetworkId -> Address ShelleyAddr
buildAddress VerificationKey PaymentKey
faucetVk NetworkId
networkId]
let foundUTxO :: UTxO
foundUTxO = (TxOut CtxUTxO Era -> Bool) -> UTxO -> UTxO
forall out. (out -> Bool) -> UTxO' out -> UTxO' out
UTxO.filter (\TxOut CtxUTxO Era
o -> (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) TxOut CtxUTxO Era
o Coin -> Coin -> Bool
forall a. Ord a => a -> a -> Bool
>= Coin
lovelace) UTxO
faucetUTxO
Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (UTxO -> Bool
forall a. UTxO' a -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null UTxO
foundUTxO) (IO () -> IO ()) -> IO () -> IO ()
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{UTxO
$sel:faucetUTxO:FaucetHasNotEnoughFunds :: UTxO
faucetUTxO :: UTxO
faucetUTxO}
UTxO -> IO UTxO
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure UTxO
foundUTxO
seedFromFaucetBlockfrost ::
VerificationKey PaymentKey ->
Coin ->
Blockfrost.BlockfrostClientT IO UTxO
seedFromFaucetBlockfrost :: VerificationKey PaymentKey -> Coin -> BlockfrostClientT IO UTxO
seedFromFaucetBlockfrost VerificationKey PaymentKey
receivingVerificationKey Coin
lovelace = do
(VerificationKey PaymentKey
faucetVk, SigningKey PaymentKey
faucetSk) <- IO (VerificationKey PaymentKey, SigningKey PaymentKey)
-> BlockfrostClientT
IO (VerificationKey PaymentKey, SigningKey PaymentKey)
forall a. IO a -> BlockfrostClientT IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (VerificationKey PaymentKey, SigningKey PaymentKey)
-> BlockfrostClientT
IO (VerificationKey PaymentKey, SigningKey PaymentKey))
-> IO (VerificationKey PaymentKey, SigningKey PaymentKey)
-> BlockfrostClientT
IO (VerificationKey PaymentKey, SigningKey PaymentKey)
forall a b. (a -> b) -> a -> b
$ Actor -> IO (VerificationKey PaymentKey, 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 Era
-> Value -> TxOutDatum CtxTx -> ReferenceScript -> TxOut CtxTx Era
forall ctx.
AddressInEra Era
-> Value -> TxOutDatum ctx -> ReferenceScript -> TxOut ctx
TxOut
(ShelleyBasedEra Era -> Address ShelleyAddr -> AddressInEra Era
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
foundUTxO <- NetworkId
-> Address ShelleyAddr -> Coin -> BlockfrostClientT IO UTxO
findUTxO NetworkId
networkId Address ShelleyAddr
changeAddress Coin
lovelace
case PParams LedgerEra
-> SystemStart
-> EraHistory
-> Set (Hash StakePoolKey)
-> AddressInEra Era
-> UTxO
-> [TxIn]
-> [TxOut CtxTx Era]
-> Either (TxBodyErrorAutoBalance Era) (Tx Era)
buildTransactionWithPParams' PParams LedgerEra
PParams ConwayEra
pparams SystemStart
systemStart EraHistory
eraHistory Set (Hash StakePoolKey)
stakePools (NetworkId -> VerificationKey PaymentKey -> AddressInEra Era
forall era.
IsShelleyBasedEra era =>
NetworkId -> VerificationKey PaymentKey -> AddressInEra era
mkVkAddress NetworkId
networkId VerificationKey PaymentKey
faucetVk) UTxO
foundUTxO [] [TxOut CtxTx Era
theOutput] of
Left TxBodyErrorAutoBalance Era
e -> IO UTxO -> BlockfrostClientT IO UTxO
forall a. IO a -> BlockfrostClientT IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO UTxO -> BlockfrostClientT IO UTxO)
-> IO UTxO -> BlockfrostClientT IO UTxO
forall a b. (a -> b) -> a -> b
$ FaucetException -> IO UTxO
forall e a. Exception e => e -> IO a
forall (m :: * -> *) e a. (MonadThrow m, Exception e) => e -> m a
throwIO (FaucetException -> IO UTxO) -> FaucetException -> IO UTxO
forall a b. (a -> b) -> a -> b
$ FaucetFailedToBuildTx{$sel:reason:FaucetHasNotEnoughFunds :: TxBodyErrorAutoBalance Era
reason = TxBodyErrorAutoBalance Era
e}
Right Tx Era
tx -> do
let signedTx :: Tx Era
signedTx = SigningKey PaymentKey -> Tx Era -> Tx Era
forall era.
IsShelleyBasedEra era =>
SigningKey PaymentKey -> Tx era -> Tx era
signTx SigningKey PaymentKey
faucetSk Tx Era
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 Era -> BlockfrostClientT IO TxHash
forall (m :: * -> *).
MonadIO m =>
Tx Era -> BlockfrostClientT m TxHash
Blockfrost.submitTransaction Tx Era
signedTx
case Either BlockfrostError TxHash
eResult of
Left BlockfrostError
err -> IO UTxO -> BlockfrostClientT IO UTxO
forall a. IO a -> BlockfrostClientT IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO UTxO -> BlockfrostClientT IO UTxO)
-> IO UTxO -> BlockfrostClientT IO UTxO
forall a b. (a -> b) -> a -> b
$ FaucetException -> IO UTxO
forall e a. Exception e => e -> IO a
forall (m :: * -> *) e a. (MonadThrow m, Exception e) => e -> m a
throwIO (FaucetException -> IO UTxO) -> FaucetException -> IO UTxO
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 -> BlockfrostClientT IO ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (BlockfrostClientT IO UTxO -> BlockfrostClientT IO ())
-> BlockfrostClientT IO UTxO -> BlockfrostClientT IO ()
forall a b. (a -> b) -> a -> b
$ NetworkId
-> [Address ShelleyAddr]
-> TxId
-> Int
-> BlockfrostClientT IO UTxO
Blockfrost.awaitUTxO NetworkId
networkId [Address ShelleyAddr
changeAddress] (Tx Era -> TxIdType (Tx Era)
forall tx. IsTx tx => tx -> TxIdType tx
txId Tx Era
signedTx) Int
200
NetworkId
-> [Address ShelleyAddr]
-> TxId
-> Int
-> BlockfrostClientT IO UTxO
Blockfrost.awaitUTxO NetworkId
networkId [Address ShelleyAddr
receivingAddress] (Tx Era -> TxIdType (Tx Era)
forall tx. IsTx tx => tx -> TxIdType tx
txId Tx Era
signedTx) Int
200
where
findUTxO :: NetworkId
-> Address ShelleyAddr -> Coin -> BlockfrostClientT IO UTxO
findUTxO NetworkId
networkId Address ShelleyAddr
address Coin
lovelace' = do
UTxO
faucetUTxO <- NetworkId -> [Address ShelleyAddr] -> BlockfrostClientT IO UTxO
Blockfrost.queryUTxO NetworkId
networkId [Address ShelleyAddr
address]
let foundUTxO :: Maybe (TxIn, TxOut CtxUTxO Era)
foundUTxO = (TxOut CtxUTxO Era -> Bool)
-> UTxO -> Maybe (TxIn, TxOut CtxUTxO Era)
forall out. (out -> Bool) -> UTxO' out -> Maybe (TxIn, out)
UTxO.find (\TxOut CtxUTxO Era
o -> (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) TxOut CtxUTxO Era
o Coin -> Coin -> Bool
forall a. Ord a => a -> a -> Bool
>= Coin
lovelace') UTxO
faucetUTxO
Bool -> BlockfrostClientT IO () -> BlockfrostClientT IO ()
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) (BlockfrostClientT IO () -> BlockfrostClientT IO ())
-> BlockfrostClientT IO () -> BlockfrostClientT IO ()
forall a b. (a -> b) -> a -> b
$
IO () -> BlockfrostClientT IO ()
forall a. IO a -> BlockfrostClientT IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> BlockfrostClientT IO ())
-> IO () -> BlockfrostClientT IO ()
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{UTxO
$sel:faucetUTxO:FaucetHasNotEnoughFunds :: UTxO
faucetUTxO :: UTxO
faucetUTxO}
UTxO -> BlockfrostClientT IO UTxO
forall a. a -> BlockfrostClientT IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (UTxO -> BlockfrostClientT IO UTxO)
-> UTxO -> BlockfrostClientT IO UTxO
forall a b. (a -> b) -> a -> b
$ UTxO
-> ((TxIn, TxOut CtxUTxO Era) -> UTxO)
-> Maybe (TxIn, TxOut CtxUTxO Era)
-> UTxO
forall b a. b -> (a -> b) -> Maybe a -> b
maybe UTxO
forall a. Monoid a => a
mempty ((TxIn -> TxOut CtxUTxO Era -> UTxO)
-> (TxIn, TxOut CtxUTxO Era) -> UTxO
forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry TxIn -> TxOut CtxUTxO Era -> UTxO
forall out. TxIn -> out -> UTxO' out
UTxO.singleton) Maybe (TxIn, TxOut CtxUTxO Era)
foundUTxO
seedFromFaucet_ ::
ChainBackend backend =>
backend ->
VerificationKey PaymentKey ->
Coin ->
Tracer IO FaucetLog ->
IO ()
seedFromFaucet_ :: forall backend.
ChainBackend backend =>
backend
-> VerificationKey PaymentKey
-> Coin
-> Tracer IO FaucetLog
-> IO ()
seedFromFaucet_ backend
backend VerificationKey PaymentKey
vk Coin
ll Tracer IO FaucetLog
tracer =
IO UTxO -> IO ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (IO UTxO -> IO ()) -> IO UTxO -> IO ()
forall a b. (a -> b) -> a -> b
$ backend
-> VerificationKey PaymentKey
-> Coin
-> Tracer IO FaucetLog
-> IO UTxO
forall backend.
ChainBackend backend =>
backend
-> VerificationKey PaymentKey
-> Coin
-> Tracer IO FaucetLog
-> IO UTxO
seedFromFaucet backend
backend VerificationKey PaymentKey
vk Coin
ll Tracer IO FaucetLog
tracer
returnFundsToFaucet ::
ChainBackend backend =>
Tracer IO FaucetLog ->
backend ->
Actor ->
IO ()
returnFundsToFaucet :: forall backend.
ChainBackend backend =>
Tracer IO FaucetLog -> backend -> Actor -> IO ()
returnFundsToFaucet Tracer IO FaucetLog
tracer backend
backend Actor
sender = do
(VerificationKey PaymentKey, SigningKey PaymentKey)
senderKeys <- Actor -> IO (VerificationKey PaymentKey, 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 -> backend -> SigningKey PaymentKey -> IO Coin
forall backend.
ChainBackend backend =>
Tracer IO FaucetLog -> backend -> SigningKey PaymentKey -> IO Coin
returnFundsToFaucet' Tracer IO FaucetLog
tracer backend
backend ((VerificationKey PaymentKey, SigningKey PaymentKey)
-> SigningKey PaymentKey
forall a b. (a, b) -> b
snd (VerificationKey PaymentKey, SigningKey PaymentKey)
senderKeys)
returnFundsToFaucet' ::
ChainBackend backend =>
Tracer IO FaucetLog ->
backend ->
SigningKey PaymentKey ->
IO Coin
returnFundsToFaucet' :: forall backend.
ChainBackend backend =>
Tracer IO FaucetLog -> backend -> SigningKey PaymentKey -> IO Coin
returnFundsToFaucet' Tracer IO FaucetLog
tracer backend
backend SigningKey PaymentKey
senderSk = do
(VerificationKey PaymentKey
faucetVk, SigningKey PaymentKey
_) <- Actor -> IO (VerificationKey PaymentKey, SigningKey PaymentKey)
keysFor Actor
Faucet
NetworkId
networkId <- backend -> IO NetworkId
forall a (m :: * -> *).
(ChainBackend a, MonadIO m, MonadThrow m) =>
a -> m NetworkId
forall (m :: * -> *).
(MonadIO m, MonadThrow m) =>
backend -> m NetworkId
Backend.queryNetworkId backend
backend
let faucetAddress :: AddressInEra Era
faucetAddress = NetworkId -> VerificationKey PaymentKey -> AddressInEra Era
forall era.
IsShelleyBasedEra era =>
NetworkId -> VerificationKey PaymentKey -> AddressInEra era
mkVkAddress NetworkId
networkId VerificationKey PaymentKey
faucetVk
let senderVk :: VerificationKey PaymentKey
senderVk = SigningKey PaymentKey -> VerificationKey PaymentKey
forall keyrole.
(Key keyrole, HasTypeProxy keyrole) =>
SigningKey keyrole -> VerificationKey keyrole
getVerificationKey SigningKey PaymentKey
senderSk
UTxO
utxo <- backend -> QueryPoint -> VerificationKey PaymentKey -> IO UTxO
forall a (m :: * -> *).
(ChainBackend a, MonadIO m, MonadThrow m) =>
a -> QueryPoint -> VerificationKey PaymentKey -> m UTxO
forall (m :: * -> *).
(MonadIO m, MonadThrow m) =>
backend -> QueryPoint -> VerificationKey PaymentKey -> m UTxO
Backend.queryUTxOFor backend
backend QueryPoint
QueryTip VerificationKey PaymentKey
senderVk
Coin
returnAmount <-
if UTxO -> Bool
forall a. UTxO' a -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null UTxO
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 -> IO Coin -> IO Coin
forall (m :: * -> *) a.
(MonadCatch m, MonadDelay m) =>
Tracer m FaucetLog -> m a -> m a
retryOnExceptions Tracer IO FaucetLog
tracer (IO Coin -> IO Coin) -> IO Coin -> IO Coin
forall a b. (a -> b) -> a -> b
$ do
let utxoValue :: ValueType (Tx Era)
utxoValue = forall tx. IsTx tx => UTxOType tx -> ValueType tx
balance @Tx UTxO
UTxOType (Tx Era)
utxo
let allLovelace :: Coin
allLovelace = Value -> Coin
selectLovelace Value
ValueType (Tx Era)
utxoValue
Tx Era
tx <- SigningKey PaymentKey -> TxBody -> Tx Era
sign SigningKey PaymentKey
senderSk (TxBody -> Tx Era) -> IO TxBody -> IO (Tx Era)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> UTxO -> AddressInEra Era -> IO TxBody
buildTxBody UTxO
utxo AddressInEra Era
faucetAddress
backend -> Tx Era -> IO ()
forall a (m :: * -> *).
(ChainBackend a, MonadIO m, MonadThrow m) =>
a -> Tx Era -> m ()
forall (m :: * -> *).
(MonadIO m, MonadThrow m) =>
backend -> Tx Era -> m ()
Backend.submitTransaction backend
backend Tx Era
tx
IO UTxO -> IO ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (IO UTxO -> IO ()) -> IO UTxO -> IO ()
forall a b. (a -> b) -> a -> b
$ backend -> Tx Era -> VerificationKey PaymentKey -> IO UTxO
forall a (m :: * -> *).
(ChainBackend a, MonadIO m, MonadThrow m) =>
a -> Tx Era -> VerificationKey PaymentKey -> m UTxO
forall (m :: * -> *).
(MonadIO m, MonadThrow m) =>
backend -> Tx Era -> VerificationKey PaymentKey -> m UTxO
Backend.awaitTransaction backend
backend Tx Era
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 -> AddressInEra Era -> IO TxBody
buildTxBody UTxO
utxo AddressInEra Era
faucetAddress =
backend
-> AddressInEra Era
-> UTxO
-> [TxIn]
-> [TxOut CtxTx Era]
-> IO (Either (TxBodyErrorAutoBalance Era) (Tx Era))
forall backend.
ChainBackend backend =>
backend
-> AddressInEra Era
-> UTxO
-> [TxIn]
-> [TxOut CtxTx Era]
-> IO (Either (TxBodyErrorAutoBalance Era) (Tx Era))
buildTransaction backend
backend AddressInEra Era
faucetAddress UTxO
utxo [] [] IO (Either (TxBodyErrorAutoBalance Era) (Tx Era))
-> (Either (TxBodyErrorAutoBalance Era) (Tx Era) -> 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 Era
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 Era -> TxBody
forall era. Tx era -> TxBody era
getTxBody Tx Era
tx
createOutputAtAddress ::
ChainBackend backend =>
NetworkId ->
backend ->
AddressInEra ->
TxOutDatum CtxTx ->
Value ->
IO (TxIn, TxOut CtxUTxO)
createOutputAtAddress :: forall backend.
ChainBackend backend =>
NetworkId
-> backend
-> AddressInEra Era
-> TxOutDatum CtxTx
-> Value
-> IO (TxIn, TxOut CtxUTxO Era)
createOutputAtAddress NetworkId
networkId backend
backend AddressInEra Era
atAddress TxOutDatum CtxTx
datum Value
val = do
(VerificationKey PaymentKey
faucetVk, SigningKey PaymentKey
faucetSk) <- Actor -> IO (VerificationKey PaymentKey, SigningKey PaymentKey)
keysFor Actor
Faucet
UTxO
utxo <- NetworkId -> backend -> Coin -> IO UTxO
forall backend.
ChainBackend backend =>
NetworkId -> backend -> Coin -> IO UTxO
findFaucetUTxO NetworkId
networkId backend
backend Coin
0
let collateralTxIns :: [TxIn]
collateralTxIns = [TxIn]
forall a. Monoid a => a
mempty
let output :: TxOut CtxTx Era
output = AddressInEra Era
-> Value -> TxOutDatum CtxTx -> ReferenceScript -> TxOut CtxTx Era
forall ctx.
AddressInEra Era
-> Value -> TxOutDatum ctx -> ReferenceScript -> TxOut ctx
TxOut AddressInEra Era
atAddress Value
val TxOutDatum CtxTx
datum ReferenceScript
ReferenceScriptNone
backend
-> AddressInEra Era
-> UTxO
-> [TxIn]
-> [TxOut CtxTx Era]
-> IO (Either (TxBodyErrorAutoBalance Era) (Tx Era))
forall backend.
ChainBackend backend =>
backend
-> AddressInEra Era
-> UTxO
-> [TxIn]
-> [TxOut CtxTx Era]
-> IO (Either (TxBodyErrorAutoBalance Era) (Tx Era))
buildTransaction backend
backend (NetworkId -> VerificationKey PaymentKey -> AddressInEra Era
forall era.
IsShelleyBasedEra era =>
NetworkId -> VerificationKey PaymentKey -> AddressInEra era
mkVkAddress NetworkId
networkId VerificationKey PaymentKey
faucetVk) UTxO
utxo [TxIn]
collateralTxIns [TxOut CtxTx Era
output] IO (Either (TxBodyErrorAutoBalance Era) (Tx Era))
-> (Either (TxBodyErrorAutoBalance Era) (Tx Era)
-> 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 ->
TxBodyErrorAutoBalance Era -> IO (TxIn, TxOut CtxUTxO Era)
forall e a. Error e => e -> IO a
throwErrorAsException TxBodyErrorAutoBalance Era
e
Right Tx Era
x -> do
let body :: TxBody
body = Tx Era -> TxBody
forall era. Tx era -> TxBody era
getTxBody Tx Era
x
let tx :: Tx Era
tx = [KeyWitness Era] -> TxBody -> Tx Era
forall era. [KeyWitness era] -> TxBody era -> Tx era
makeSignedTransaction [TxBody -> ShelleyWitnessSigningKey -> KeyWitness Era
makeShelleyKeyWitness TxBody
body (SigningKey PaymentKey -> ShelleyWitnessSigningKey
WitnessPaymentKey SigningKey PaymentKey
faucetSk)] TxBody
body
backend -> Tx Era -> IO ()
forall a (m :: * -> *).
(ChainBackend a, MonadIO m, MonadThrow m) =>
a -> Tx Era -> m ()
forall (m :: * -> *).
(MonadIO m, MonadThrow m) =>
backend -> Tx Era -> m ()
Backend.submitTransaction backend
backend Tx Era
tx
UTxO
newUtxo <- backend -> Tx Era -> VerificationKey PaymentKey -> IO UTxO
forall a (m :: * -> *).
(ChainBackend a, MonadIO m, MonadThrow m) =>
a -> Tx Era -> VerificationKey PaymentKey -> m UTxO
forall (m :: * -> *).
(MonadIO m, MonadThrow m) =>
backend -> Tx Era -> VerificationKey PaymentKey -> m UTxO
Backend.awaitTransaction backend
backend Tx Era
tx VerificationKey PaymentKey
faucetVk
case (TxOut CtxUTxO Era -> Bool)
-> UTxO -> Maybe (TxIn, TxOut CtxUTxO Era)
forall out. (out -> Bool) -> UTxO' out -> Maybe (TxIn, out)
UTxO.find (\TxOut CtxUTxO Era
out -> TxOut CtxUTxO Era -> AddressInEra Era
forall ctx. TxOut ctx -> AddressInEra Era
txOutAddress TxOut CtxUTxO Era
out AddressInEra Era -> AddressInEra Era -> Bool
forall a. Eq a => a -> a -> Bool
== AddressInEra Era
atAddress) UTxO
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 -> ByteString
forall a. ToJSON a => a -> ByteString
encodePretty UTxO
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
retryOnExceptions :: (MonadCatch m, MonadDelay m) => Tracer m FaucetLog -> m a -> m a
retryOnExceptions :: forall (m :: * -> *) a.
(MonadCatch m, MonadDelay m) =>
Tracer m FaucetLog -> m a -> m a
retryOnExceptions Tracer m FaucetLog
tracer 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 (m :: * -> *) a 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
_ :: SubmitTransactionException) -> do
DiffTime -> m ()
forall (m :: * -> *). MonadDelay m => DiffTime -> m ()
threadDelay DiffTime
1
Tracer m FaucetLog -> m a -> m a
forall (m :: * -> *) a.
(MonadCatch m, MonadDelay m) =>
Tracer m FaucetLog -> m a -> m a
retryOnExceptions Tracer m FaucetLog
tracer m a
action
, (IOException -> m a) -> Handler m a
forall (m :: * -> *) a 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
DiffTime -> m ()
forall (m :: * -> *). MonadDelay m => DiffTime -> m ()
threadDelay DiffTime
1
Tracer m FaucetLog -> m a -> m a
forall (m :: * -> *) a.
(MonadCatch m, MonadDelay m) =>
Tracer m FaucetLog -> m a -> m a
retryOnExceptions Tracer m FaucetLog
tracer 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
publishHydraScriptsAs :: ChainBackend backend => backend -> Actor -> IO [TxId]
publishHydraScriptsAs :: forall backend.
ChainBackend backend =>
backend -> Actor -> IO [TxId]
publishHydraScriptsAs backend
backend Actor
actor = do
(VerificationKey PaymentKey
_, SigningKey PaymentKey
sk) <- Actor -> IO (VerificationKey PaymentKey, SigningKey PaymentKey)
keysFor Actor
actor
backend -> SigningKey PaymentKey -> IO [TxId]
forall backend.
ChainBackend backend =>
backend -> SigningKey PaymentKey -> IO [TxId]
publishHydraScripts backend
backend SigningKey PaymentKey
sk