From 77d1249a7724c92693f8d15355a6e019eab67504 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Markus=20L=C3=A4ll?= Date: Tue, 29 Nov 2022 13:13:01 +0200 Subject: [PATCH] reset me: Add blocksCallback blocksCallbackPipelined --- .../src/Cardano/Streaming/LedgerState.hs | 175 ++++++++++++++---- marconi/test/EpochStakepoolSize.hs | 99 ++++------ marconi/test/Helpers.hs | 22 ++- 3 files changed, 192 insertions(+), 104 deletions(-) diff --git a/cardano-streaming/src/Cardano/Streaming/LedgerState.hs b/cardano-streaming/src/Cardano/Streaming/LedgerState.hs index 62c23cf537..d9c5772978 100644 --- a/cardano-streaming/src/Cardano/Streaming/LedgerState.hs +++ b/cardano-streaming/src/Cardano/Streaming/LedgerState.hs @@ -19,6 +19,10 @@ module Cardano.Streaming.LedgerState , foldBlocks , ledgerStatesPipelined , ledgerStates + + -- * Raw chain-sync clients using callback + , blocksCallbackPipelined + , blocksCallback ) where @@ -26,6 +30,7 @@ import Prelude import Control.Concurrent.Async qualified as IO import Control.Concurrent.Chan qualified as IO +import Control.Exception (Exception, SomeException (SomeException), catch, throw) import Control.Exception qualified as E import Control.Monad.IO.Class (liftIO) import Control.Monad.Trans.Class (lift) @@ -45,7 +50,8 @@ import Cardano.Api qualified as C import Cardano.Chain.Genesis qualified import Cardano.Crypto (ProtocolMagicId (unProtocolMagicId), RequiresNetworkMagic (RequiresMagic, RequiresNoMagic)) import Cardano.Slotting.Slot (WithOrigin (At, Origin)) -import Cardano.Streaming (ChainSyncEvent (RollForward), blocks) +import Cardano.Streaming (ChainSyncEvent (RollBackward, RollForward), ChainSyncEventException (NoIntersectionFound), + blocks) import Ouroboros.Consensus.Cardano.CanHardFork qualified as Consensus import Ouroboros.Consensus.HardFork.Combinator qualified as Consensus import Ouroboros.Consensus.HardFork.Combinator.AcrossEras qualified as HFC @@ -120,7 +126,7 @@ foldBlocksPipelinedIO env initialLedgerState' nodeConfigFilePath socketPath vali clientNextN :: Nat n -> LedgerStateHistory -> CSP.ClientStNext n (C.BlockInMode C.CardanoMode) C.ChainPoint C.ChainTip IO () clientNextN rqsInFlight knownLedgerStates = - CSP.ClientStNext { + CSP.ClientStNext { -- xxx CSP.recvMsgRollForward = \blockInMode@(C.BlockInMode block@(C.Block (C.BlockHeader slotNo _ currBlockNo) _) _era) serverChainTip -> do newLedgerState <- applyBlock_ (getLastLedgerState knownLedgerStates) block let (knownLedgerStates', committedStates) = pushLedgerState env knownLedgerStates slotNo newLedgerState blockInMode @@ -173,45 +179,59 @@ foldBlocksIO -> FilePath -> FilePath -> C.ValidationMode -> IO.IORef a -> (C.LedgerState -> [C.LedgerEvent] -> C.BlockInMode C.CardanoMode -> a -> IO a) -> IO () -foldBlocksIO env initialLedgerState' nodeConfigFilePath socketPath validationMode stateIORef accumulate = - C.connectToLocalNode (mkConnectInfo env socketPath) $ C.LocalNodeClientProtocols - { C.localChainSyncClient = C.LocalChainSyncClient (chainSyncClient $ singletonLedgerStateHistory initialLedgerState') - , C.localTxSubmissionClient = Nothing - , C.localStateQueryClient = Nothing - , C.localTxMonitoringClient = Nothing - } +foldBlocksIO env initialLedgerState' nodeConfigFilePath socketPath validationMode stateIORef accumulate = do + + lhsIORef <- IO.newIORef $ singletonLedgerStateHistory initialLedgerState' + blocksCallback (mkConnectInfo env socketPath) C.ChainPointAtGenesis $ \case + RollForward blockInMode@(C.BlockInMode block _) _ -> do + knownLedgerStates <- IO.readIORef lhsIORef + newLedgerState <- applyBlock_ (getLastLedgerState knownLedgerStates) block + let + slotNo = bimSlotNo blockInMode + (knownLedgerStates', committedStates) = pushLedgerState env knownLedgerStates slotNo newLedgerState blockInMode + forM_ committedStates $ \(_, (ledgerState, ledgerEvents), currBlockMay) -> case currBlockMay of + Origin -> return () + At currBlock -> do + newState <- accumulate ledgerState ledgerEvents currBlock =<< IO.readIORef stateIORef + IO.writeIORef stateIORef newState + IO.writeIORef lhsIORef knownLedgerStates' + + RollBackward cp ct -> TODO where -- | Pre-applied applyBlock to env and validation mode as these don't change over the fold. applyBlock_ :: C.LedgerState -> C.Block era -> IO (C.LedgerState, [C.LedgerEvent]) applyBlock_ ledgerState block = applyBlockThrow env ledgerState validationMode block - -- | Defines the client side of the chain sync protocol. - chainSyncClient :: LedgerStateHistory -> CS.ChainSyncClient (C.BlockInMode C.CardanoMode) C.ChainPoint C.ChainTip IO () - chainSyncClient lsh = CS.ChainSyncClient $ do - pure $ clientIdle_RequestMoreN lsh - where - clientIdle_RequestMoreN :: LedgerStateHistory -> CS.ClientStIdle (C.BlockInMode C.CardanoMode) C.ChainPoint C.ChainTip IO () - clientIdle_RequestMoreN knownLedgerStates - = let action = clientNextN knownLedgerStates - in CS.SendMsgRequestNext action (pure action) - - clientNextN :: LedgerStateHistory -> CS.ClientStNext (C.BlockInMode C.CardanoMode) C.ChainPoint C.ChainTip IO () - clientNextN knownLedgerStates = CS.ClientStNext - { CS.recvMsgRollForward = \blockInMode@(C.BlockInMode block@(C.Block (C.BlockHeader slotNo _ _currBlockNo) _) _era) _serverChainTip -> - CS.ChainSyncClient $ do - newLedgerState <- applyBlock_ (getLastLedgerState knownLedgerStates) block - let (knownLedgerStates', committedStates) = pushLedgerState env knownLedgerStates slotNo newLedgerState blockInMode - forM_ committedStates $ \(_, (ledgerState, ledgerEvents), currBlockMay) -> case currBlockMay of - Origin -> return () - At currBlock -> do - newState <- accumulate ledgerState ledgerEvents currBlock =<< IO.readIORef stateIORef - IO.writeIORef stateIORef newState - return (clientIdle_RequestMoreN knownLedgerStates') - , CS.recvMsgRollBackward = \chainPoint _ -> chainSyncClient $ case chainPoint of - C.ChainPointAtGenesis -> lsh - C.ChainPoint slotNo _ -> rollBackLedgerStateHist knownLedgerStates slotNo - } + -- C.connectToLocalNode (mkConnectInfo env socketPath) $ C.LocalNodeClientProtocols + -- { C.localChainSyncClient = C.LocalChainSyncClient (chainSyncClient $ singletonLedgerStateHistory initialLedgerState') + + -- -- | Defines the client side of the chain sync protocol. + -- chainSyncClient :: LedgerStateHistory -> CS.ChainSyncClient (C.BlockInMode C.CardanoMode) C.ChainPoint C.ChainTip IO () + -- chainSyncClient lsh = CS.ChainSyncClient $ do + -- pure $ clientIdle_RequestMoreN lsh + -- where + -- clientIdle_RequestMoreN :: LedgerStateHistory -> CS.ClientStIdle (C.BlockInMode C.CardanoMode) C.ChainPoint C.ChainTip IO () + -- clientIdle_RequestMoreN knownLedgerStates + -- = let action = clientNextN knownLedgerStates + -- in CS.SendMsgRequestNext action (pure action) + + -- clientNextN :: LedgerStateHistory -> CS.ClientStNext (C.BlockInMode C.CardanoMode) C.ChainPoint C.ChainTip IO () + -- clientNextN knownLedgerStates = CS.ClientStNext + -- { CS.recvMsgRollForward = \blockInMode@(C.BlockInMode block@(C.Block (C.BlockHeader slotNo _ _currBlockNo) _) _era) _serverChainTip -> + -- CS.ChainSyncClient $ do + -- newLedgerState <- applyBlock_ (getLastLedgerState knownLedgerStates) block + -- let (knownLedgerStates', committedStates) = pushLedgerState env knownLedgerStates slotNo newLedgerState blockInMode + -- forM_ committedStates $ \(_, (ledgerState, ledgerEvents), currBlockMay) -> case currBlockMay of + -- Origin -> return () + -- At currBlock -> do + -- newState <- accumulate ledgerState ledgerEvents currBlock =<< IO.readIORef stateIORef + -- IO.writeIORef stateIORef newState + -- return (clientIdle_RequestMoreN knownLedgerStates') + -- , CS.recvMsgRollBackward = \chainPoint _ -> chainSyncClient $ case chainPoint of + -- C.ChainPointAtGenesis -> lsh + -- C.ChainPoint slotNo _ -> rollBackLedgerStateHist knownLedgerStates slotNo + -- } applyBlockThrow :: C.Env -> C.LedgerState -> C.ValidationMode -> C.Block era -> IO (C.LedgerState, [C.LedgerEvent]) applyBlockThrow env ledgerState validationMode block = case C.applyBlock env ledgerState validationMode block of @@ -323,3 +343,88 @@ ledgerStates_ config validationMode socketPath networkId point = do blocks socketPath networkId point & S.mapMaybe (\case (RollForward e _) -> Just e; _ -> Nothing) & loop (singletonLedgerStateHistory initialLedgerState) + +-- * Raw chain-sync clients using callback + +blocksCallbackPipelined + :: forall a. Word32 -> C.LocalNodeConnectInfo C.CardanoMode + -> (ChainSyncEvent (C.BlockInMode C.CardanoMode) -> IO ()) + -> IO () +blocksCallbackPipelined n con callback = + C.connectToLocalNode con $ C.LocalNodeClientProtocols + { C.localChainSyncClient = C.LocalChainSyncClientPipelined (work n) + , C.localTxSubmissionClient = Nothing + , C.localStateQueryClient = Nothing + , C.localTxMonitoringClient = Nothing + } + where + work :: Word32 -> CSP.ChainSyncClientPipelined (C.BlockInMode C.CardanoMode) C.ChainPoint C.ChainTip IO () + work pipelineSize = CSP.ChainSyncClientPipelined $ pure $ requestMore Origin Origin Zero [] + where + requestMore -- was clientIdle_RequestMoreN + :: WithOrigin C.BlockNo -> WithOrigin C.BlockNo -> Nat n + -> [ChainSyncEvent (C.BlockInMode C.CardanoMode)] + -> CSP.ClientPipelinedStIdle n (C.BlockInMode C.CardanoMode) C.ChainPoint C.ChainTip IO () + requestMore clientTip serverTip rqsInFlight bims = let + in case pipelineDecisionMax pipelineSize rqsInFlight clientTip serverTip of + -- handle a response + Collect -> case rqsInFlight of + Succ predN -> CSP.CollectResponse Nothing (clientNextN predN bims) + -- request more: client and server tip unchanged, one more request in flight, accumulator (bims) unchanged + _ -> CSP.SendMsgRequestNextPipelined (requestMore clientTip serverTip (Succ rqsInFlight) bims) + + clientNextN + :: Nat n + -> [ChainSyncEvent (C.BlockInMode C.CardanoMode)] + -> CSP.ClientStNext n (C.BlockInMode C.CardanoMode) C.ChainPoint C.ChainTip IO () + clientNextN rqsInFlight bims = CSP.ClientStNext + { CSP.recvMsgRollForward = \bim ct -> do + mapM_ callback bims -- emit collected batch + return $ requestMore (At $ bimBlockNo bim) (fromChainTip ct) rqsInFlight [] + , CSP.recvMsgRollBackward = \cp ct -> do + return $ requestMore Origin (fromChainTip ct) rqsInFlight (RollBackward cp ct : bims) + } + + fromChainTip :: C.ChainTip -> WithOrigin C.BlockNo + fromChainTip ct = case ct of + C.ChainTipAtGenesis -> Origin + C.ChainTip _ _ bno -> At bno + +blocksCallback + :: C.LocalNodeConnectInfo C.CardanoMode -> C.ChainPoint + -> (ChainSyncEvent (C.BlockInMode C.CardanoMode) -> IO ()) + -> IO () +blocksCallback con point callback = + C.connectToLocalNode con $ C.LocalNodeClientProtocols + { C.localChainSyncClient = C.LocalChainSyncClient $ CS.ChainSyncClient $ pure $ CS.SendMsgFindIntersect [point] onIntersect + , C.localTxSubmissionClient = Nothing + , C.localStateQueryClient = Nothing + , C.localTxMonitoringClient = Nothing + } + where + onIntersect = + CS.ClientStIntersect + { CS.recvMsgIntersectFound = \_ _ -> CS.ChainSyncClient sendRequestNext + , CS.recvMsgIntersectNotFound = throw NoIntersectionFound + } + sendRequestNext = pure $ CS.SendMsgRequestNext onNext (pure onNext) + where + onNext = CS.ClientStNext + { CS.recvMsgRollForward = \bim ct -> CS.ChainSyncClient $ do + callback $ RollForward bim ct + sendRequestNext + , CS.recvMsgRollBackward = \cp ct -> CS.ChainSyncClient $ do + callback $ RollBackward cp ct + sendRequestNext + } + +-- * Helpers + +bimBlockNo :: C.BlockInMode C.CardanoMode -> C.BlockNo +bimBlockNo (C.BlockInMode (C.Block (C.BlockHeader _ _ blockNo) _) _) = blockNo + +bimSlotNo :: C.BlockInMode C.CardanoMode -> C.SlotNo +bimSlotNo (C.BlockInMode (C.Block (C.BlockHeader slotNo _ _) _) _) = slotNo + +u :: a +u = undefined diff --git a/marconi/test/EpochStakepoolSize.hs b/marconi/test/EpochStakepoolSize.hs index 0938251288..413e4e22fe 100644 --- a/marconi/test/EpochStakepoolSize.hs +++ b/marconi/test/EpochStakepoolSize.hs @@ -8,7 +8,7 @@ module EpochStakepoolSize where import Control.Concurrent qualified as IO import Control.Concurrent.Async qualified as IO -import Control.Monad (forever, void, when) +import Control.Monad (forM_, forever, void, when) import Control.Monad.IO.Class (liftIO) import Data.Aeson ((.=)) import Data.Aeson qualified as J @@ -44,6 +44,9 @@ tests = testGroup "EpochStakepoolSize" [ testPropertyNamed "prop_epoch_stakepool_size" "test" test ] +-- TODO +-- - add comment for https://developers.cardano.org/docs/stake-pool-course/handbook/create-stake-pool-keys + test :: Property test = H.integration . HE.runFinallies . TN.workspace "chairman" $ \tempAbsPath -> do @@ -56,9 +59,7 @@ test = H.integration . HE.runFinallies . TN.workspace "chairman" $ \tempAbsPath let networkId = TN.getNetworkId runtime -- socketPath <- TN.getSocketPathAbs conf runtime socketPath <- TN.getPoolSocketPathAbs conf runtime - - TN.p2 "socketPath" socketPath - -- HE.threadDelay 1000_000000 + pparams <- TN.getAlonzoProtocolParams con -- start indexer printStakeMaps <- liftIO $ do @@ -99,8 +100,7 @@ test = H.integration . HE.runFinallies . TN.workspace "chairman" $ \tempAbsPath putStrLn $ "awaitTxId: Awaiting for tx id " <> show txId loop - - -- genesis keys: these already exist from the testnet + -- Get the genesis keys, these already exist and are created by the testnet function genesisVKey :: C.VerificationKey C.GenesisUTxOKey <- TN.readAs (C.AsVerificationKey C.AsGenesisUTxOKey) $ tempAbsPath "shelley/utxo-keys/utxo1.vkey" genesisSKey :: C.SigningKey C.GenesisUTxOKey <- TN.readAs (C.AsSigningKey C.AsGenesisUTxOKey) $ tempAbsPath "shelley/utxo-keys/utxo1.skey" let @@ -109,57 +109,39 @@ test = H.integration . HE.runFinallies . TN.workspace "chairman" $ \tempAbsPath genesisAddress :: C.Address C.ShelleyAddr genesisAddress = C.makeShelleyAddress networkId genesisVKeyHash C.NoStakeAddress :: C.Address C.ShelleyAddr - -- | Build an address based on paymentVKey and stakeVKey - -- cardano-cli stake-address build - -- => done above - -- * Payment key pair - -- cardano-cli address key-gen + -- * Create Stake Pool Keys + -- https://developers.cardano.org/docs/stake-pool-course/handbook/create-stake-pool-keys + + -- Payment key pair: cardano-cli address key-gen paymentSKey :: C.SigningKey C.PaymentKey <- liftIO $ C.generateSigningKey C.AsPaymentKey let paymentVKey = C.getVerificationKey paymentSKey :: C.VerificationKey C.PaymentKey paymentVKeyHash = C.PaymentCredentialByKey $ C.verificationKeyHash paymentVKey - -- paymentAddress0 = C.makeShelleyAddress networkId paymentVKeyHash C.NoStakeAddress :: C.Address C.ShelleyAddr -- without stake - -- * Stake key pair - -- cardano-cli stake-address key-gen - -- file:/home/iog/src/cardano-node/cardano-cli/src/Cardano/CLI/Shelley/Run/StakeAddress.hs::59 + -- Stake key pair: cardano-cli stake-address key-gen stakeSKey :: C.SigningKey C.StakeKey <- liftIO $ C.generateSigningKey C.AsStakeKey let stakeVKey = C.getVerificationKey stakeSKey :: C.VerificationKey C.StakeKey stakeCredential = C.StakeCredentialByKey $ C.verificationKeyHash stakeVKey :: C.StakeCredential stakeAddressReference = C.StakeAddressByValue stakeCredential :: C.StakeAddressReference - -- * Payment address - -- cardano-cli address build - -- file:/home/iog/src/cardano-node/cardano-cli/src/Cardano/CLI/Shelley/Run/Address.hs::106 - paymentAddress = C.makeShelleyAddress networkId paymentVKeyHash stakeAddressReference :: C.Address C.ShelleyAddr -- with stake - - -- * Stake address - -- cardano-cli stake-address build - -- file:/home/iog/src/cardano-node/cardano-cli/src/Cardano/CLI/Shelley/Run/StakeAddress.hs::86 - -- stakeAddress = C.makeStakeAddress networkId stakeCredential :: C.StakeAddress -- todo this never used? - - liftIO $ putStrLn " -- Balances start --" - TN.printAddressBalance "genesisAddress" con genesisAddress - TN.printAddressBalance "paymentAddress" con paymentAddress --- TN.printAddressBalance "paymentAddress0" con paymentAddress0 --- TN.printAddressBalance con "stakeAddress" stakeAddress - - pparams <- TN.getAlonzoProtocolParams con + -- Payment address: cardano-cli address build + let paymentAddress = C.makeShelleyAddress networkId paymentVKeyHash stakeAddressReference :: C.Address C.ShelleyAddr + liftIO (putStrLn " -- Balances start --") >> forM_ [("genesisAddress", genesisAddress), ("paymentAddress", paymentAddress)] (\(lbl, a) -> TN.printAddressBalance con lbl a) + -- Transfer 50 ADA to paymentAddress transfer awaitTxId networkId con genesisAddress paymentAddress [C.WitnessGenesisUTxOKey genesisSKey] 50_000_000 - liftIO $ putStrLn " -- Balances after genesis => paymentAddress --" - TN.printAddressBalance "genesisAddress" con genesisAddress - TN.printAddressBalance "paymentAddress" con paymentAddress - -- * Register Stake Address on the Blockchain - -- | Create cert - -- cardano-cli stake-address registration-certificate - let stakeAddressRegistrationCertificate = C.makeStakeAddressRegistrationCertificate stakeCredential :: C.Certificate + liftIO (putStrLn " -- Balances after genesis => paymentAddress --") >> forM_ [("genesisAddress", genesisAddress), ("paymentAddress", paymentAddress)] (\(lbl, a) -> TN.printAddressBalance con lbl a) - -- | Make tx and submit stake address registration certificate + -- * Register Stake Address on the Blockchain + -- -- https://developers.cardano.org/docs/stake-pool-course/handbook/register-stake-keys - -- (cardano-cli query utxo) + + -- Create a registration certificate: cardano-cli stake-address registration-certificate + let stakeAddressRegCert = C.makeStakeAddressRegistrationCertificate stakeCredential :: C.Certificate + + -- Draft transaction & Calculate fees; Submit the certificate with a transaction -- cardano-cli transaction build -- cardano-cli transaction sign -- cardano-cli transaction submit @@ -169,15 +151,17 @@ test = H.integration . HE.runFinallies . TN.workspace "chairman" $ \tempAbsPath tx = (TN.emptyTxBodyContent fee pparams) { C.txIns = map (, C.BuildTxWith $ C.KeyWitness C.KeyWitnessForSpending) txIns , C.txOuts = [outAddress genesisAddress $ totalLovelace - fee] - , C.txCertificates = C.TxCertificates C.CertificatesInAlonzoEra [stakeAddressRegistrationCertificate] (C.BuildTxWith mempty) + , C.txCertificates = C.TxCertificates C.CertificatesInAlonzoEra [stakeAddressRegCert] (C.BuildTxWith mempty) } txBody :: C.TxBody C.AlonzoEra <- HE.leftFail $ C.makeTransactionBody tx TN.submitTx con $ C.signShelleyTransaction txBody [C.WitnessGenesisUTxOKey genesisSKey] liftIO $ awaitTxId $ C.getTxId txBody -- TODO: have a submitAwaitTx - -- Register a Stake Pool with Metadata + -- * Register a Stake Pool with Metadata + -- -- https://developers.cardano.org/docs/stake-pool-course/handbook/register-stake-pool-metadata - -- cardano-cli stake-pool metadata-hash --pool-metadata-file + + -- Create the metadata file HE.lbsWriteFile (tempAbsPath "poolMetadata.json") . J.encode $ J.object -- [ "heavyDelThd" .= J.toJSON @String "300000000000" [ "name" .= id @String "TestPool" @@ -186,21 +170,19 @@ test = H.integration . HE.runFinallies . TN.workspace "chairman" $ \tempAbsPath , "homepage" .= id @String "https://teststakepool.com" ] lbs <- HE.lbsReadFile (tempAbsPath "poolMetadata.json") + -- cardano-cli stake-pool metadata-hash --pool-metadata-file (_poolMetadata, poolMetadataHash) <- HE.leftFail $ C.validateAndHashStakePoolMetadata $ BL.toStrict lbs - p2 "poolMetadataHash" poolMetadataHash - p2 "poolMetadataHash" _poolMetadata - - -- cardano-cli stake-pool registration-certificate + -- TODO: these are missing from the tutorial? https://developers.cardano.org/docs/stake-pool-course/handbook/register-stake-pool-metadata coldSKey :: C.SigningKey C.StakePoolKey <- liftIO $ C.generateSigningKey C.AsStakePoolKey let coldVKey = C.getVerificationKey coldSKey :: C.VerificationKey C.StakePoolKey coldVKeyHash = (C.verificationKeyHash coldVKey :: C.Hash C.StakePoolKey) :: C.PoolId - skeyVrf :: C.SigningKey C.VrfKey <- liftIO $ C.generateSigningKey C.AsVrfKey let vkeyVrf = C.getVerificationKey skeyVrf :: C.VerificationKey C.VrfKey - let stakePoolRegistrationCertificate :: C.Certificate - stakePoolRegistrationCertificate = makeStakePoolRegistrationCert_ + -- Generate Stake pool registration certificate: cardano-cli stake-pool registration-certificate + let poolRegistration :: C.Certificate + poolRegistration = makeStakePoolRegistrationCert_ coldVKey -- stakePoolVerKey; :: C.VerificationKey C.StakePoolKey; node key-gen vkeyVrf -- vrfVerKey -> C.VerificationKey C.VrfKey 0 -- pldg -> C.Lovelace @@ -212,8 +194,7 @@ test = H.integration . HE.runFinallies . TN.workspace "chairman" $ \tempAbsPath (Just $ C.StakePoolMetadataReference "" poolMetadataHash) -- -> Maybe C.StakePoolMetadataReference networkId -- -> C.NetworkId - -- cardano-cli stake-address delegation-certificate - -- file:/home/iog/src/cardano-node/cardano-cli/src/Cardano/CLI/Shelley/Run/StakeAddress.hs::150 + -- Generate delegation certificate pledge: cardano-cli stake-address delegation-certificate let delegationCertificate = C.makeStakeAddressDelegationCertificate stakeCredential coldVKeyHash do (txIns, totalLovelace) <- TN.getAddressTxInsValue con genesisAddress @@ -223,7 +204,7 @@ test = H.integration . HE.runFinallies . TN.workspace "chairman" $ \tempAbsPath { C.txIns = (map (, C.BuildTxWith $ C.KeyWitness C.KeyWitnessForSpending) txIns) , C.txOuts = [outAddress genesisAddress $ totalLovelace - dummyFee] , C.txCertificates = C.TxCertificates C.CertificatesInAlonzoEra - [stakePoolRegistrationCertificate, delegationCertificate] + [poolRegistration, delegationCertificate] (C.BuildTxWith mempty) -- BuildTxWith build (Map StakeCredential (Witness WitCtxStake era)) } txBody0 :: C.TxBody C.AlonzoEra <- HE.leftFail $ C.makeTransactionBody tx0 @@ -237,20 +218,15 @@ test = H.integration . HE.runFinallies . TN.workspace "chairman" $ \tempAbsPath feeLovelace = calculateFee pparams (length $ C.txIns tx0) (length $ C.txOuts tx0) 0 (length keyWitnesses) networkId txBody0 :: C.Lovelace fee = C.TxFeeExplicit C.TxFeesExplicitInAlonzoEra feeLovelace tx = tx0 { C.txFee = fee, C.txOuts = [outAddress genesisAddress $ totalLovelace - feeLovelace] } - p2 "tx fee is" fee txBody :: C.TxBody C.AlonzoEra <- HE.leftFail $ C.makeTransactionBody tx TN.submitTx con $ C.signShelleyTransaction txBody keyWitnesses liftIO $ awaitTxId $ C.getTxId txBody liftIO $ putStrLn "Stakepool created" - - liftIO $ putStrLn " -- Balances end --" - TN.printAddressBalance "genesisAddress" con genesisAddress - TN.printAddressBalance "paymentAddress" con paymentAddress --- TN.printAddressBalance "paymentAddress0" con paymentAddress0 + liftIO (putStrLn " -- Balances end --") >> forM_ [("genesisAddress", genesisAddress), ("paymentAddress", paymentAddress)] (\(lbl, a) -> TN.printAddressBalance con lbl a) liftIO printStakeMaps - -- cardano-cli stake-pool id + True === True @@ -317,7 +293,6 @@ hot = defaultMain tests printEpochNo :: S.Stream (S.Of C.LedgerState) IO r -> S.Stream (S.Of C.LedgerState) IO r printEpochNo = S.chain $ \e -> do TN.p2 "" $ EpochStakepoolSize.getEpochNo e - -- IO.writeChan chan e u :: a u = undefined diff --git a/marconi/test/Helpers.hs b/marconi/test/Helpers.hs index 15d42c0713..4d097ebd5e 100644 --- a/marconi/test/Helpers.hs +++ b/marconi/test/Helpers.hs @@ -3,7 +3,9 @@ module Helpers where -import Control.Monad (when) +import Control.Concurrent.Async qualified as IO +import Control.Concurrent.MVar qualified as IO +import Control.Monad (void, when) import Control.Monad.IO.Class (MonadIO, liftIO) import Data.Map qualified as Map import Data.Set qualified as Set @@ -163,10 +165,16 @@ submitTx localNodeConnectInfo tx = do SubmitFail reason -> H.failMessage GHC.callStack $ "Transaction failed: " <> show reason SubmitSuccess -> pure () - --- submitAwaitTx :: LocalNodeConnectInfo -> TxBody era -> Chan () -> m () --- submitAwaitTx con txBody chan = do --- TN.submitTx con $ C.signShelleyTransaction tx1body [C.WitnessGenesisUTxOKey genesisSKey] +submitAwaitTx :: MonadIO m => C.LocalNodeConnectInfo C.CardanoMode -> C.Tx C.AlonzoEra -> m () +submitAwaitTx con tx = liftIO $ do + m <- IO.newEmptyMVar + -- 1. start listener + -- 2. submit tx + -- 3. block on reception + IO.withAsync (C.submitTxToNodeLocal con $ C.TxInMode tx C.AlonzoEraInCardanoMode) $ \a -> do + C.submitTxToNodeLocal con $ C.TxInMode tx C.AlonzoEraInCardanoMode + -- submitTx con tx -- $ C.signShelleyTransaction undefined [C.WitnessGenesisUTxOKey undefined] + void $ IO.readMVar m -- p2 "Tx1 id" $ (C.getTxId tx1body :: C.TxId) @@ -207,8 +215,8 @@ bimBlockNo (C.BlockInMode (C.Block (C.BlockHeader _slotNo _ blockNo) _txs) _era) -- * Temporary -printAddressBalance :: (MonadTest m, MonadIO m) => String -> C.LocalNodeConnectInfo C.CardanoMode -> C.Address addr -> m () -printAddressBalance label con address = do +printAddressBalance :: (MonadTest m, MonadIO m) => C.LocalNodeConnectInfo C.CardanoMode -> String -> C.Address addr -> m () +printAddressBalance con label address = do (txIns, totalLovelace) <- getAddressTxInsValue con address p2 label (totalLovelace, txIns)