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),
  RunningNode (..),
  SubmitTransactionException,
  awaitTransaction,
  buildAddress,
  buildTransaction,
  queryUTxO,
  queryUTxOFor,
  sign,
  submitTransaction,
 )
import Control.Exception (IOException)
import Control.Monad.Class.MonadThrow (Handler (Handler), catches)
import Control.Tracer (Tracer, traceWith)
import GHC.IO.Exception (IOErrorType (ResourceExhausted), IOException (ioe_type))
import Hydra.Chain.CardanoClient (queryProtocolParameters)
import Hydra.Chain.ScriptRegistry (
  publishHydraScripts,
 )
import Hydra.Cluster.Fixture (Actor (Faucet))
import Hydra.Cluster.Util (keysFor)
import Hydra.Ledger.Cardano ()
import Hydra.Tx (balance)

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

instance Exception FaucetException

data FaucetLog
  = TraceResourceExhaustedHandled Text
  | ReturnedFunds {FaucetLog -> Lovelace
returnAmount :: Coin}
  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, Maybe FaucetLog
Value -> Parser [FaucetLog]
Value -> Parser FaucetLog
(Value -> Parser FaucetLog)
-> (Value -> Parser [FaucetLog])
-> Maybe FaucetLog
-> FromJSON FaucetLog
forall a.
(Value -> Parser a)
-> (Value -> Parser [a]) -> Maybe a -> FromJSON a
$cparseJSON :: Value -> Parser FaucetLog
parseJSON :: Value -> Parser FaucetLog
$cparseJSONList :: Value -> Parser [FaucetLog]
parseJSONList :: Value -> Parser [FaucetLog]
$comittedField :: Maybe FaucetLog
omittedField :: Maybe FaucetLog
FromJSON)

-- | Create a specially marked "seed" UTXO containing requested 'Lovelace' by
-- redeeming funds available to the well-known faucet.
seedFromFaucet ::
  RunningNode ->
  -- | Recipient of the funds
  VerificationKey PaymentKey ->
  -- | Amount to get from faucet
  Coin ->
  Tracer IO FaucetLog ->
  IO UTxO
seedFromFaucet :: RunningNode
-> VerificationKey PaymentKey
-> Lovelace
-> Tracer IO FaucetLog
-> IO UTxO
seedFromFaucet node :: RunningNode
node@RunningNode{NetworkId
networkId :: NetworkId
$sel:networkId:RunningNode :: RunningNode -> NetworkId
networkId, SocketPath
nodeSocket :: SocketPath
$sel:nodeSocket:RunningNode :: RunningNode -> SocketPath
nodeSocket} VerificationKey PaymentKey
receivingVerificationKey Lovelace
lovelace Tracer IO FaucetLog
tracer = do
  (VerificationKey PaymentKey
faucetVk, SigningKey PaymentKey
faucetSk) <- Actor -> IO (VerificationKey PaymentKey, SigningKey PaymentKey)
keysFor Actor
Faucet
  Tx
seedTx <- Tracer IO FaucetLog -> IO Tx -> IO Tx
forall (m :: * -> *) a.
(MonadCatch m, MonadDelay m) =>
Tracer m FaucetLog -> m a -> m a
retryOnExceptions Tracer IO FaucetLog
tracer (IO Tx -> IO Tx) -> IO Tx -> IO Tx
forall a b. (a -> b) -> a -> b
$ VerificationKey PaymentKey -> SigningKey PaymentKey -> IO Tx
submitSeedTx VerificationKey PaymentKey
faucetVk SigningKey PaymentKey
faucetSk
  UTxO
producedUTxO <- NetworkId -> SocketPath -> Tx -> IO UTxO
awaitTransaction NetworkId
networkId SocketPath
nodeSocket Tx
seedTx
  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
forall {k} (f :: * -> k -> *) (era :: k).
ToUTxOContext f =>
f CtxTx era -> f CtxUTxO era
toUTxOContext TxOut CtxTx Era
theOutput) UTxO
producedUTxO
 where
  submitSeedTx :: VerificationKey PaymentKey -> SigningKey PaymentKey -> IO Tx
submitSeedTx VerificationKey PaymentKey
faucetVk SigningKey PaymentKey
faucetSk = do
    UTxO
faucetUTxO <- RunningNode -> Lovelace -> IO UTxO
findFaucetUTxO RunningNode
node Lovelace
lovelace
    let changeAddress :: AddressInEra
changeAddress = NetworkId -> VerificationKey PaymentKey -> AddressInEra
forall era.
IsShelleyBasedEra era =>
NetworkId -> VerificationKey PaymentKey -> AddressInEra era
mkVkAddress NetworkId
networkId VerificationKey PaymentKey
faucetVk
    NetworkId
-> SocketPath
-> AddressInEra
-> UTxO
-> [TxIn]
-> [TxOut CtxTx Era]
-> IO (Either (TxBodyErrorAutoBalance Era) Tx)
buildTransaction NetworkId
networkId SocketPath
nodeSocket AddressInEra
changeAddress UTxO
faucetUTxO [] [TxOut CtxTx Era
theOutput] 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{reason :: TxBodyErrorAutoBalance Era
reason = TxBodyErrorAutoBalance Era
e}
      Right Tx
tx -> do
        let signedTx :: Tx
signedTx = SigningKey PaymentKey -> TxBody -> Tx
sign SigningKey PaymentKey
faucetSk (TxBody -> Tx) -> TxBody -> Tx
forall a b. (a -> b) -> a -> b
$ Tx -> TxBody
forall era. Tx era -> TxBody era
getTxBody Tx
tx
        NetworkId -> SocketPath -> Tx -> IO ()
submitTransaction NetworkId
networkId SocketPath
nodeSocket Tx
signedTx
        Tx -> IO Tx
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Tx
signedTx

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

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

findFaucetUTxO :: RunningNode -> Coin -> IO UTxO
findFaucetUTxO :: RunningNode -> Lovelace -> IO UTxO
findFaucetUTxO RunningNode{NetworkId
$sel:networkId:RunningNode :: RunningNode -> NetworkId
networkId :: NetworkId
networkId, SocketPath
$sel:nodeSocket:RunningNode :: RunningNode -> SocketPath
nodeSocket :: SocketPath
nodeSocket} Lovelace
lovelace = do
  (VerificationKey PaymentKey
faucetVk, SigningKey PaymentKey
_) <- Actor -> IO (VerificationKey PaymentKey, SigningKey PaymentKey)
keysFor Actor
Faucet
  UTxO
faucetUTxO <- NetworkId
-> SocketPath -> QueryPoint -> [Address ShelleyAddr] -> IO UTxO
queryUTxO NetworkId
networkId SocketPath
nodeSocket QueryPoint
QueryTip [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 -> Lovelace
selectLovelace (Value -> Lovelace)
-> (TxOut CtxUTxO Era -> Value) -> TxOut CtxUTxO Era -> Lovelace
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TxOut CtxUTxO Era -> Value
forall ctx. TxOut ctx -> Value
txOutValue) TxOut CtxUTxO Era
o Lovelace -> Lovelace -> Bool
forall a. Ord a => a -> a -> Bool
>= Lovelace
lovelace) UTxO
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
faucetUTxO :: UTxO
faucetUTxO :: UTxO
faucetUTxO}
  UTxO -> IO UTxO
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure UTxO
foundUTxO

-- | Like 'seedFromFaucet', but without returning the seeded 'UTxO'.
seedFromFaucet_ ::
  RunningNode ->
  -- | Recipient of the funds
  VerificationKey PaymentKey ->
  -- | Amount to get from faucet
  Coin ->
  Tracer IO FaucetLog ->
  IO ()
seedFromFaucet_ :: RunningNode
-> VerificationKey PaymentKey
-> Lovelace
-> Tracer IO FaucetLog
-> IO ()
seedFromFaucet_ RunningNode
node VerificationKey PaymentKey
vk Lovelace
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
$ RunningNode
-> VerificationKey PaymentKey
-> Lovelace
-> Tracer IO FaucetLog
-> IO UTxO
seedFromFaucet RunningNode
node VerificationKey PaymentKey
vk Lovelace
ll Tracer IO FaucetLog
tracer

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

returnFundsToFaucet' ::
  Tracer IO FaucetLog ->
  RunningNode ->
  SigningKey PaymentKey ->
  IO Coin
returnFundsToFaucet' :: Tracer IO FaucetLog
-> RunningNode -> SigningKey PaymentKey -> IO Lovelace
returnFundsToFaucet' Tracer IO FaucetLog
tracer RunningNode{NetworkId
$sel:networkId:RunningNode :: RunningNode -> NetworkId
networkId :: NetworkId
networkId, SocketPath
$sel:nodeSocket:RunningNode :: RunningNode -> SocketPath
nodeSocket :: SocketPath
nodeSocket} SigningKey PaymentKey
senderSk = do
  (VerificationKey PaymentKey
faucetVk, SigningKey PaymentKey
_) <- Actor -> IO (VerificationKey PaymentKey, SigningKey PaymentKey)
keysFor Actor
Faucet
  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 = SigningKey PaymentKey -> VerificationKey PaymentKey
forall keyrole.
(Key keyrole, HasTypeProxy keyrole) =>
SigningKey keyrole -> VerificationKey keyrole
getVerificationKey SigningKey PaymentKey
senderSk
  UTxO
utxo <- NetworkId
-> SocketPath
-> QueryPoint
-> VerificationKey PaymentKey
-> IO UTxO
queryUTxOFor NetworkId
networkId SocketPath
nodeSocket QueryPoint
QueryTip VerificationKey PaymentKey
senderVk
  Lovelace
returnAmount <-
    if UTxO -> Bool
forall a. UTxO' a -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null UTxO
utxo
      then Lovelace -> IO Lovelace
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Lovelace
0
      else Tracer IO FaucetLog -> IO Lovelace -> IO Lovelace
forall (m :: * -> *) a.
(MonadCatch m, MonadDelay m) =>
Tracer m FaucetLog -> m a -> m a
retryOnExceptions Tracer IO FaucetLog
tracer (IO Lovelace -> IO Lovelace) -> IO Lovelace -> IO Lovelace
forall a b. (a -> b) -> a -> b
$ do
        let utxoValue :: ValueType Tx
utxoValue = forall tx. IsTx tx => UTxOType tx -> ValueType tx
balance @Tx UTxO
UTxOType Tx
utxo
        let allLovelace :: Lovelace
allLovelace = Value -> Lovelace
selectLovelace Value
ValueType Tx
utxoValue
        Tx
tx <- SigningKey PaymentKey -> TxBody -> Tx
sign SigningKey PaymentKey
senderSk (TxBody -> Tx) -> IO TxBody -> IO Tx
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> UTxO -> AddressInEra -> IO TxBody
buildTxBody UTxO
utxo AddressInEra
faucetAddress
        NetworkId -> SocketPath -> Tx -> IO ()
submitTransaction NetworkId
networkId SocketPath
nodeSocket Tx
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
$ NetworkId -> SocketPath -> Tx -> IO UTxO
awaitTransaction NetworkId
networkId SocketPath
nodeSocket Tx
tx
        Lovelace -> IO Lovelace
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Lovelace
allLovelace
  Tracer IO FaucetLog -> FaucetLog -> IO ()
forall (m :: * -> *) a. Tracer m a -> a -> m ()
traceWith Tracer IO FaucetLog
tracer (FaucetLog -> IO ()) -> FaucetLog -> IO ()
forall a b. (a -> b) -> a -> b
$ ReturnedFunds{Lovelace
returnAmount :: Lovelace
returnAmount :: Lovelace
returnAmount}
  Lovelace -> IO Lovelace
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Lovelace
returnAmount
 where
  buildTxBody :: UTxO -> AddressInEra -> IO TxBody
buildTxBody UTxO
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.
    NetworkId
-> SocketPath
-> AddressInEra
-> UTxO
-> [TxIn]
-> [TxOut CtxTx Era]
-> IO (Either (TxBodyErrorAutoBalance Era) Tx)
buildTransaction NetworkId
networkId SocketPath
nodeSocket AddressInEra
faucetAddress UTxO
utxo [] [] IO (Either (TxBodyErrorAutoBalance Era) Tx)
-> (Either (TxBodyErrorAutoBalance Era) Tx -> IO TxBody)
-> IO TxBody
forall a b. IO a -> (a -> IO b) -> IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
      Left TxBodyErrorAutoBalance Era
e -> FaucetException -> IO TxBody
forall e a. Exception e => e -> IO a
forall (m :: * -> *) e a. (MonadThrow m, Exception e) => e -> m a
throwIO (FaucetException -> IO TxBody) -> FaucetException -> IO TxBody
forall a b. (a -> b) -> a -> b
$ FaucetFailedToBuildTx{reason :: TxBodyErrorAutoBalance Era
reason = TxBodyErrorAutoBalance Era
e}
      Right Tx
tx -> TxBody -> IO TxBody
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (TxBody -> IO TxBody) -> TxBody -> IO TxBody
forall a b. (a -> b) -> a -> b
$ Tx -> TxBody
forall era. Tx era -> TxBody era
getTxBody Tx
tx

-- Use the Faucet utxo to create the output at specified address
createOutputAtAddress ::
  RunningNode ->
  AddressInEra ->
  TxOutDatum CtxTx ->
  Value ->
  IO (TxIn, TxOut CtxUTxO)
createOutputAtAddress :: RunningNode
-> AddressInEra
-> TxOutDatum CtxTx
-> Value
-> IO (TxIn, TxOut CtxUTxO Era)
createOutputAtAddress node :: RunningNode
node@RunningNode{NetworkId
$sel:networkId:RunningNode :: RunningNode -> NetworkId
networkId :: NetworkId
networkId, SocketPath
$sel:nodeSocket:RunningNode :: RunningNode -> SocketPath
nodeSocket :: SocketPath
nodeSocket} AddressInEra
atAddress TxOutDatum CtxTx
datum Value
val = do
  (VerificationKey PaymentKey
faucetVk, SigningKey PaymentKey
faucetSk) <- Actor -> IO (VerificationKey PaymentKey, SigningKey PaymentKey)
keysFor Actor
Faucet
  UTxO
utxo <- RunningNode -> Lovelace -> IO UTxO
findFaucetUTxO RunningNode
node Lovelace
0
  PParams StandardConway
pparams <- NetworkId -> SocketPath -> QueryPoint -> IO (PParams LedgerEra)
queryProtocolParameters NetworkId
networkId SocketPath
nodeSocket QueryPoint
QueryTip
  let collateralTxIns :: [TxIn]
collateralTxIns = [TxIn]
forall a. Monoid a => a
mempty
  let output :: TxOut CtxTx Era
output =
        PParams LedgerEra
-> AddressInEra
-> Value
-> TxOutDatum CtxTx
-> ReferenceScript
-> TxOut CtxTx Era
mkTxOutAutoBalance
          PParams LedgerEra
PParams StandardConway
pparams
          AddressInEra
atAddress
          Value
val
          TxOutDatum CtxTx
datum
          ReferenceScript
ReferenceScriptNone
  NetworkId
-> SocketPath
-> AddressInEra
-> UTxO
-> [TxIn]
-> [TxOut CtxTx Era]
-> IO (Either (TxBodyErrorAutoBalance Era) Tx)
buildTransaction
    NetworkId
networkId
    SocketPath
nodeSocket
    (VerificationKey PaymentKey -> AddressInEra
changeAddress VerificationKey PaymentKey
faucetVk)
    UTxO
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 ->
        TxBodyErrorAutoBalance Era -> IO (TxIn, TxOut CtxUTxO Era)
forall e a. Error e => e -> IO a
throwErrorAsException TxBodyErrorAutoBalance Era
e
      Right Tx
x -> do
        let body :: TxBody
body = Tx -> TxBody
forall era. Tx era -> TxBody era
getTxBody Tx
x
        let tx :: Tx
tx = [KeyWitness Era] -> TxBody -> Tx
forall era. [KeyWitness era] -> TxBody era -> Tx era
makeSignedTransaction [TxBody -> ShelleyWitnessSigningKey -> KeyWitness Era
makeShelleyKeyWitness TxBody
body (SigningKey PaymentKey -> ShelleyWitnessSigningKey
WitnessPaymentKey SigningKey PaymentKey
faucetSk)] TxBody
body
        NetworkId -> SocketPath -> Tx -> IO ()
submitTransaction NetworkId
networkId SocketPath
nodeSocket Tx
tx
        UTxO
newUtxo <- NetworkId -> SocketPath -> Tx -> IO UTxO
awaitTransaction NetworkId
networkId SocketPath
nodeSocket Tx
tx
        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
forall ctx. TxOut ctx -> AddressInEra
txOutAddress TxOut CtxUTxO Era
out AddressInEra -> AddressInEra -> Bool
forall a. Eq a => a -> a -> Bool
== AddressInEra
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
 where
  changeAddress :: VerificationKey PaymentKey -> AddressInEra
changeAddress = NetworkId -> VerificationKey PaymentKey -> AddressInEra
forall era.
IsShelleyBasedEra era =>
NetworkId -> VerificationKey PaymentKey -> AddressInEra era
mkVkAddress NetworkId
networkId

-- | Build and sign tx and return the calculated fee.
-- - Signing key should be the key of a sender
-- - Address is used as a change address.
-- - Lovelace amount should be one we are trying to send.
calculateTxFee ::
  RunningNode ->
  SigningKey PaymentKey ->
  UTxO ->
  AddressInEra ->
  Coin ->
  IO Coin
calculateTxFee :: RunningNode
-> SigningKey PaymentKey
-> UTxO
-> AddressInEra
-> Lovelace
-> IO Lovelace
calculateTxFee RunningNode{NetworkId
$sel:networkId:RunningNode :: RunningNode -> NetworkId
networkId :: NetworkId
networkId, SocketPath
$sel:nodeSocket:RunningNode :: RunningNode -> SocketPath
nodeSocket :: SocketPath
nodeSocket} SigningKey PaymentKey
secretKey UTxO
utxo AddressInEra
addr Lovelace
lovelace =
  let theOutput :: TxOut CtxTx Era
theOutput = AddressInEra
-> Value -> TxOutDatum CtxTx -> ReferenceScript -> TxOut CtxTx Era
forall ctx.
AddressInEra
-> Value -> TxOutDatum ctx -> ReferenceScript -> TxOut ctx
TxOut AddressInEra
addr (Lovelace -> Value
lovelaceToValue Lovelace
lovelace) TxOutDatum CtxTx
forall ctx. TxOutDatum ctx
TxOutDatumNone ReferenceScript
ReferenceScriptNone
   in NetworkId
-> SocketPath
-> AddressInEra
-> UTxO
-> [TxIn]
-> [TxOut CtxTx Era]
-> IO (Either (TxBodyErrorAutoBalance Era) Tx)
buildTransaction NetworkId
networkId SocketPath
nodeSocket AddressInEra
addr UTxO
utxo [] [TxOut CtxTx Era
theOutput] IO (Either (TxBodyErrorAutoBalance Era) Tx)
-> (Either (TxBodyErrorAutoBalance Era) Tx -> IO Lovelace)
-> IO Lovelace
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 Lovelace
forall e a. Exception e => e -> IO a
forall (m :: * -> *) e a. (MonadThrow m, Exception e) => e -> m a
throwIO (FaucetException -> IO Lovelace) -> FaucetException -> IO Lovelace
forall a b. (a -> b) -> a -> b
$ FaucetFailedToBuildTx{reason :: TxBodyErrorAutoBalance Era
reason = TxBodyErrorAutoBalance Era
e}
        Right Tx
tx -> Lovelace -> IO Lovelace
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Lovelace -> IO Lovelace) -> Lovelace -> IO Lovelace
forall a b. (a -> b) -> a -> b
$ Tx -> Lovelace
forall era. Tx era -> Lovelace
txFee' (SigningKey PaymentKey -> TxBody -> Tx
sign SigningKey PaymentKey
secretKey (TxBody -> Tx) -> TxBody -> Tx
forall a b. (a -> b) -> a -> b
$ Tx -> TxBody
forall era. Tx era -> TxBody era
getTxBody Tx
tx)

-- | Try to submit tx and retry when some caught exception/s take place.
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

-- | 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 :: RunningNode -> Actor -> IO TxId
publishHydraScriptsAs :: RunningNode -> Actor -> IO TxId
publishHydraScriptsAs RunningNode{NetworkId
$sel:networkId:RunningNode :: RunningNode -> NetworkId
networkId :: NetworkId
networkId, SocketPath
$sel:nodeSocket:RunningNode :: RunningNode -> SocketPath
nodeSocket :: SocketPath
nodeSocket} Actor
actor = do
  (VerificationKey PaymentKey
_, SigningKey PaymentKey
sk) <- Actor -> IO (VerificationKey PaymentKey, SigningKey PaymentKey)
keysFor Actor
actor
  NetworkId -> SocketPath -> SigningKey PaymentKey -> IO TxId
publishHydraScripts NetworkId
networkId SocketPath
nodeSocket SigningKey PaymentKey
sk