{-# LANGUAGE DuplicateRecordFields #-}
module CardanoClient (
module Hydra.Chain.CardanoClient,
module CardanoClient,
) where
import Hydra.Prelude
import Hydra.Cardano.Api hiding (Block)
import Hydra.Chain.Backend qualified as Backend
import Hydra.Chain.CardanoClient
import Cardano.Api.UTxO qualified as UTxO
import Data.Map qualified as Map
import Hydra.Chain.Backend (ChainBackend)
import Hydra.Chain.CardanoClient qualified as CardanoClient
buildAddress :: VerificationKey PaymentKey -> NetworkId -> Address ShelleyAddr
buildAddress :: VerificationKey PaymentKey -> NetworkId -> Address ShelleyAddr
buildAddress VerificationKey PaymentKey
vKey NetworkId
networkId =
NetworkId
-> PaymentCredential
-> StakeAddressReference
-> Address ShelleyAddr
makeShelleyAddress NetworkId
networkId (Hash PaymentKey -> PaymentCredential
PaymentCredentialByKey (Hash PaymentKey -> PaymentCredential)
-> Hash PaymentKey -> PaymentCredential
forall a b. (a -> b) -> a -> b
$ VerificationKey PaymentKey -> Hash PaymentKey
forall keyrole.
Key keyrole =>
VerificationKey keyrole -> Hash keyrole
verificationKeyHash VerificationKey PaymentKey
vKey) StakeAddressReference
NoStakeAddress
sign :: SigningKey PaymentKey -> TxBody -> Tx
sign :: SigningKey PaymentKey -> TxBody -> Tx
sign SigningKey PaymentKey
signingKey TxBody
body =
[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
signingKey)]
TxBody
body
waitForPayments ::
ChainBackend backend =>
backend ->
Coin ->
Address ShelleyAddr ->
IO UTxO
waitForPayments :: forall backend.
ChainBackend backend =>
backend -> Coin -> Address ShelleyAddr -> IO UTxO
waitForPayments backend
backend Coin
amount Address ShelleyAddr
addr =
IO UTxO
go
where
go :: IO UTxO
go = do
UTxO
utxo <- 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 [Address ShelleyAddr
addr]
let expectedPayments :: Map TxIn (TxOut CtxUTxO)
expectedPayments = UTxO -> Map TxIn (TxOut CtxUTxO)
selectPayments UTxO
utxo
if Map TxIn (TxOut CtxUTxO)
expectedPayments Map TxIn (TxOut CtxUTxO) -> Map TxIn (TxOut CtxUTxO) -> Bool
forall a. Eq a => a -> a -> Bool
/= Map TxIn (TxOut CtxUTxO)
forall a. Monoid a => a
mempty
then UTxO -> IO UTxO
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (UTxO -> IO UTxO) -> UTxO -> IO UTxO
forall a b. (a -> b) -> a -> b
$ Map TxIn (TxOut CtxUTxO) -> UTxO
forall out. Map TxIn out -> UTxO' out
UTxO Map TxIn (TxOut CtxUTxO)
expectedPayments
else DiffTime -> IO ()
forall (m :: * -> *). MonadDelay m => DiffTime -> m ()
threadDelay DiffTime
1 IO () -> IO UTxO -> IO UTxO
forall a b. IO a -> IO b -> IO b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> IO UTxO
go
selectPayments :: UTxO -> Map TxIn (TxOut CtxUTxO)
selectPayments (UTxO Map TxIn (TxOut CtxUTxO)
utxo) =
(TxOut CtxUTxO -> Bool)
-> Map TxIn (TxOut CtxUTxO) -> Map TxIn (TxOut CtxUTxO)
forall a k. (a -> Bool) -> Map k a -> Map k a
Map.filter ((Coin -> Coin -> Bool
forall a. Eq a => a -> a -> Bool
== Coin
amount) (Coin -> Bool) -> (TxOut CtxUTxO -> Coin) -> TxOut CtxUTxO -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Value -> Coin
selectLovelace (Value -> Coin)
-> (TxOut CtxUTxO -> Value) -> TxOut CtxUTxO -> Coin
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TxOut CtxUTxO -> Value
forall ctx. TxOut ctx -> Value
txOutValue) Map TxIn (TxOut CtxUTxO)
utxo
waitForUTxO ::
ChainBackend backend =>
backend ->
UTxO ->
IO ()
waitForUTxO :: forall backend. ChainBackend backend => backend -> UTxO -> IO ()
waitForUTxO backend
backend UTxO
utxo =
[TxOut CtxUTxO] -> (TxOut CtxUTxO -> IO ()) -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ ((TxIn, TxOut CtxUTxO) -> TxOut CtxUTxO
forall a b. (a, b) -> b
snd ((TxIn, TxOut CtxUTxO) -> TxOut CtxUTxO)
-> [(TxIn, TxOut CtxUTxO)] -> [TxOut CtxUTxO]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> UTxO -> [(TxIn, TxOut CtxUTxO)]
forall out. UTxO' out -> [(TxIn, out)]
UTxO.toList UTxO
utxo) TxOut CtxUTxO -> IO ()
forEachUTxO
where
forEachUTxO :: TxOut CtxUTxO -> IO ()
forEachUTxO :: TxOut CtxUTxO -> IO ()
forEachUTxO = \case
TxOut (ShelleyAddressInEra addr :: Address ShelleyAddr
addr@ShelleyAddress{}) Value
value TxOutDatum CtxUTxO
_ ReferenceScript
_ -> do
IO UTxO -> IO ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (IO UTxO -> IO ()) -> IO UTxO -> IO ()
forall a b. (a -> b) -> a -> b
$
backend -> Coin -> Address ShelleyAddr -> IO UTxO
forall backend.
ChainBackend backend =>
backend -> Coin -> Address ShelleyAddr -> IO UTxO
waitForPayments
backend
backend
(Value -> Coin
selectLovelace Value
value)
Address ShelleyAddr
addr
TxOut CtxUTxO
txOut ->
Text -> IO ()
forall a t. (HasCallStack, IsText t) => t -> a
error (Text -> IO ()) -> Text -> IO ()
forall a b. (a -> b) -> a -> b
$ Text
"Unexpected TxOut " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> TxOut CtxUTxO -> Text
forall b a. (Show a, IsString b) => a -> b
show TxOut CtxUTxO
txOut
mkGenesisTx ::
NetworkId ->
SigningKey PaymentKey ->
Coin ->
[(VerificationKey PaymentKey, Coin)] ->
Tx
mkGenesisTx :: NetworkId
-> SigningKey PaymentKey
-> Coin
-> [(VerificationKey PaymentKey, Coin)]
-> Tx
mkGenesisTx NetworkId
networkId SigningKey PaymentKey
signingKey Coin
initialAmount [(VerificationKey PaymentKey, Coin)]
recipients =
case TxBodyContent BuildTx -> Either TxBodyError TxBody
createAndValidateTransactionBody TxBodyContent BuildTx
body of
Left TxBodyError
err -> Text -> Tx
forall a t. (HasCallStack, IsText t) => t -> a
error (Text -> Tx) -> Text -> Tx
forall a b. (a -> b) -> a -> b
$ Text
"Fail to build genesis transactions: " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> TxBodyError -> Text
forall b a. (Show a, IsString b) => a -> b
show TxBodyError
err
Right TxBody
tx -> SigningKey PaymentKey -> TxBody -> Tx
sign SigningKey PaymentKey
signingKey TxBody
tx
where
body :: TxBodyContent BuildTx
body =
TxBodyContent BuildTx
defaultTxBodyContent
TxBodyContent BuildTx
-> (TxBodyContent BuildTx -> TxBodyContent BuildTx)
-> TxBodyContent BuildTx
forall a b. a -> (a -> b) -> b
& TxIns BuildTx Era -> TxBodyContent BuildTx -> TxBodyContent BuildTx
forall build era.
TxIns build era
-> TxBodyContent build era -> TxBodyContent build era
setTxIns [(TxIn
initialInput, Witness WitCtxTxIn Era
-> BuildTxWith BuildTx (Witness WitCtxTxIn Era)
forall a. a -> BuildTxWith BuildTx a
BuildTxWith (Witness WitCtxTxIn Era
-> BuildTxWith BuildTx (Witness WitCtxTxIn Era))
-> Witness WitCtxTxIn Era
-> BuildTxWith BuildTx (Witness WitCtxTxIn Era)
forall a b. (a -> b) -> a -> b
$ KeyWitnessInCtx WitCtxTxIn -> Witness WitCtxTxIn Era
forall ctx. KeyWitnessInCtx ctx -> Witness ctx
KeyWitness KeyWitnessInCtx WitCtxTxIn
KeyWitnessForSpending)]
TxBodyContent BuildTx
-> (TxBodyContent BuildTx -> TxBodyContent BuildTx)
-> TxBodyContent BuildTx
forall a b. a -> (a -> b) -> b
& [TxOut CtxTx Era] -> TxBodyContent BuildTx -> TxBodyContent BuildTx
forall era build.
[TxOut CtxTx era]
-> TxBodyContent build era -> TxBodyContent build era
setTxOuts ([TxOut CtxTx Era]
recipientOutputs [TxOut CtxTx Era] -> [TxOut CtxTx Era] -> [TxOut CtxTx Era]
forall a. Semigroup a => a -> a -> a
<> [TxOut CtxTx Era
changeOutput])
TxBodyContent BuildTx
-> (TxBodyContent BuildTx -> TxBodyContent BuildTx)
-> TxBodyContent BuildTx
forall a b. a -> (a -> b) -> b
& TxFee Era -> TxBodyContent BuildTx -> TxBodyContent BuildTx
forall era build.
TxFee era -> TxBodyContent build era -> TxBodyContent build era
setTxFee (Coin -> TxFee Era
TxFeeExplicit Coin
2_000_000)
initialInput :: TxIn
initialInput =
NetworkId -> Hash GenesisUTxOKey -> TxIn
genesisUTxOPseudoTxIn
NetworkId
networkId
(Hash PaymentKey -> Hash GenesisUTxOKey
forall a b.
(SerialiseAsCBOR (Hash a), SerialiseAsCBOR (Hash b),
HasCallStack) =>
Hash a -> Hash b
unsafeCastHash (Hash PaymentKey -> Hash GenesisUTxOKey)
-> Hash PaymentKey -> Hash GenesisUTxOKey
forall a b. (a -> b) -> a -> b
$ VerificationKey PaymentKey -> Hash PaymentKey
forall keyrole.
Key keyrole =>
VerificationKey keyrole -> Hash keyrole
verificationKeyHash (VerificationKey PaymentKey -> Hash PaymentKey)
-> VerificationKey PaymentKey -> Hash PaymentKey
forall a b. (a -> b) -> a -> b
$ SigningKey PaymentKey -> VerificationKey PaymentKey
forall keyrole.
(Key keyrole, HasTypeProxy keyrole) =>
SigningKey keyrole -> VerificationKey keyrole
getVerificationKey SigningKey PaymentKey
signingKey)
fee :: Coin
fee = Coin
2_000_000
totalSent :: Coin
totalSent = ((VerificationKey PaymentKey, Coin) -> Coin)
-> [(VerificationKey PaymentKey, Coin)] -> Coin
forall m a. Monoid m => (a -> m) -> [a] -> m
forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap (VerificationKey PaymentKey, Coin) -> Coin
forall a b. (a, b) -> b
snd [(VerificationKey PaymentKey, Coin)]
recipients
changeAddr :: AddressInEra
changeAddr = NetworkId -> VerificationKey PaymentKey -> AddressInEra
forall era.
IsShelleyBasedEra era =>
NetworkId -> VerificationKey PaymentKey -> AddressInEra era
mkVkAddress NetworkId
networkId (SigningKey PaymentKey -> VerificationKey PaymentKey
forall keyrole.
(Key keyrole, HasTypeProxy keyrole) =>
SigningKey keyrole -> VerificationKey keyrole
getVerificationKey SigningKey PaymentKey
signingKey)
changeOutput :: TxOut CtxTx Era
changeOutput =
AddressInEra
-> Value -> TxOutDatum CtxTx -> ReferenceScript -> TxOut CtxTx Era
forall ctx.
AddressInEra
-> Value -> TxOutDatum ctx -> ReferenceScript -> TxOut ctx
TxOut
AddressInEra
changeAddr
(Coin -> Value
lovelaceToValue (Coin -> Value) -> Coin -> Value
forall a b. (a -> b) -> a -> b
$ Coin
initialAmount Coin -> Coin -> Coin
forall a. Num a => a -> a -> a
- Coin
totalSent Coin -> Coin -> Coin
forall a. Num a => a -> a -> a
- Coin
fee)
TxOutDatum CtxTx
forall ctx. TxOutDatum ctx
TxOutDatumNone
ReferenceScript
ReferenceScriptNone
recipientOutputs :: [TxOut CtxTx Era]
recipientOutputs =
(((VerificationKey PaymentKey, Coin) -> TxOut CtxTx Era)
-> [(VerificationKey PaymentKey, Coin)] -> [TxOut CtxTx Era])
-> [(VerificationKey PaymentKey, Coin)]
-> ((VerificationKey PaymentKey, Coin) -> TxOut CtxTx Era)
-> [TxOut CtxTx Era]
forall a b c. (a -> b -> c) -> b -> a -> c
flip ((VerificationKey PaymentKey, Coin) -> TxOut CtxTx Era)
-> [(VerificationKey PaymentKey, Coin)] -> [TxOut CtxTx Era]
forall a b. (a -> b) -> [a] -> [b]
map [(VerificationKey PaymentKey, Coin)]
recipients (((VerificationKey PaymentKey, Coin) -> TxOut CtxTx Era)
-> [TxOut CtxTx Era])
-> ((VerificationKey PaymentKey, Coin) -> TxOut CtxTx Era)
-> [TxOut CtxTx Era]
forall a b. (a -> b) -> a -> b
$ \(VerificationKey PaymentKey
vk, Coin
ll) ->
AddressInEra
-> Value -> TxOutDatum CtxTx -> ReferenceScript -> TxOut CtxTx Era
forall ctx.
AddressInEra
-> Value -> TxOutDatum ctx -> ReferenceScript -> TxOut ctx
TxOut
(NetworkId -> VerificationKey PaymentKey -> AddressInEra
forall era.
IsShelleyBasedEra era =>
NetworkId -> VerificationKey PaymentKey -> AddressInEra era
mkVkAddress NetworkId
networkId VerificationKey PaymentKey
vk)
(Coin -> Value
lovelaceToValue Coin
ll)
TxOutDatum CtxTx
forall ctx. TxOutDatum ctx
TxOutDatumNone
ReferenceScript
ReferenceScriptNone
data RunningNode = RunningNode
{ RunningNode -> SocketPath
nodeSocket :: SocketPath
, RunningNode -> NetworkId
networkId :: NetworkId
, RunningNode -> NominalDiffTime
blockTime :: NominalDiffTime
}
deriving (Int -> RunningNode -> ShowS
[RunningNode] -> ShowS
RunningNode -> String
(Int -> RunningNode -> ShowS)
-> (RunningNode -> String)
-> ([RunningNode] -> ShowS)
-> Show RunningNode
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> RunningNode -> ShowS
showsPrec :: Int -> RunningNode -> ShowS
$cshow :: RunningNode -> String
show :: RunningNode -> String
$cshowList :: [RunningNode] -> ShowS
showList :: [RunningNode] -> ShowS
Show, RunningNode -> RunningNode -> Bool
(RunningNode -> RunningNode -> Bool)
-> (RunningNode -> RunningNode -> Bool) -> Eq RunningNode
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: RunningNode -> RunningNode -> Bool
== :: RunningNode -> RunningNode -> Bool
$c/= :: RunningNode -> RunningNode -> Bool
/= :: RunningNode -> RunningNode -> Bool
Eq)