From f477420390eb36cea04f7faec37095eac837b8a0 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Cl=C3=A9ment=20Hurlin?= Date: Mon, 9 Dec 2024 15:03:54 +0100 Subject: [PATCH 1/5] Make query stake-address-info callable programmatically --- .../src/Cardano/CLI/EraBased/Run/Query.hs | 64 ++++++++++++++----- 1 file changed, 48 insertions(+), 16 deletions(-) diff --git a/cardano-cli/src/Cardano/CLI/EraBased/Run/Query.hs b/cardano-cli/src/Cardano/CLI/EraBased/Run/Query.hs index 818719c46..f7c87a72d 100644 --- a/cardano-cli/src/Cardano/CLI/EraBased/Run/Query.hs +++ b/cardano-cli/src/Cardano/CLI/EraBased/Run/Query.hs @@ -874,6 +874,40 @@ runQueryStakeAddressInfoCmd => Cmd.QueryStakeAddressInfoCmdArgs -> ExceptT QueryCmdError IO () runQueryStakeAddressInfoCmd + cmd@Cmd.QueryStakeAddressInfoCmdArgs + { Cmd.commons = + Cmd.QueryCommons + { Cmd.nodeSocketPath + , Cmd.consensusModeParams + , Cmd.networkId + , Cmd.target + } + , Cmd.mOutFile + } = do + let localNodeConnInfo = LocalNodeConnectInfo consensusModeParams networkId nodeSocketPath + AnyCardanoEra era <- + firstExceptT + QueryCmdAcquireFailure + (newExceptT $ executeLocalStateQueryExpr localNodeConnInfo target queryCurrentEra) + & onLeft (left . QueryCmdUnsupportedNtcVersion) + sbe <- requireShelleyBasedEra era & onNothing (left QueryCmdByronEra) + + said <- callQueryStakeAddressInfoCmd cmd + + writeStakeAddressInfo sbe said mOutFile + +-- | Container for data returned by 'callQueryStakeAddressInfoCmd' +data StakeAddressInfoData = StakeAddressInfoData + { rewards :: DelegationsAndRewards + , deposits :: Map StakeAddress Lovelace + , delegatees :: Map StakeAddress (L.DRep L.StandardCrypto) + } + +callQueryStakeAddressInfoCmd + :: () + => Cmd.QueryStakeAddressInfoCmdArgs + -> ExceptT QueryCmdError IO StakeAddressInfoData +callQueryStakeAddressInfoCmd Cmd.QueryStakeAddressInfoCmdArgs { Cmd.commons = Cmd.QueryCommons @@ -908,13 +942,12 @@ runQueryStakeAddressInfoCmd stakeVoteDelegatees <- monoidForEraInEonA era $ \ceo -> easyRunQuery (queryStakeVoteDelegatees ceo stakeAddr) - return $ do - writeStakeAddressInfo - sbe - mOutFile - (DelegationsAndRewards (stakeRewardAccountBalances, stakePools)) - (Map.mapKeys (makeStakeAddress networkId) stakeDelegDeposits) - (Map.mapKeys (makeStakeAddress networkId) stakeVoteDelegatees) + return $ + return $ + StakeAddressInfoData + (DelegationsAndRewards (stakeRewardAccountBalances, stakePools)) + (Map.mapKeys (makeStakeAddress networkId) stakeDelegDeposits) + (Map.mapKeys (makeStakeAddress networkId) stakeVoteDelegatees) ) & onLeft (left . QueryCmdAcquireFailure) & onLeft left @@ -923,19 +956,18 @@ runQueryStakeAddressInfoCmd writeStakeAddressInfo :: ShelleyBasedEra era + -> StakeAddressInfoData -> Maybe (File () Out) - -> DelegationsAndRewards - -> Map StakeAddress Lovelace - -- ^ deposits - -> Map StakeAddress (L.DRep L.StandardCrypto) - -- ^ vote delegatees -> ExceptT QueryCmdError IO () writeStakeAddressInfo sbe - mOutFile - (DelegationsAndRewards (stakeAccountBalances, stakePools)) - stakeDelegDeposits - voteDelegatees = + ( StakeAddressInfoData + { rewards = DelegationsAndRewards (stakeAccountBalances, stakePools) + , deposits = stakeDelegDeposits + , delegatees = voteDelegatees + } + ) + mOutFile = firstExceptT QueryCmdWriteFileError . newExceptT $ writeLazyByteStringOutput mOutFile (encodePretty $ jsonInfo sbe) where From ee57bc631824fa71e096af8e2eef7d8f4352d4f1 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Cl=C3=A9ment=20Hurlin?= Date: Mon, 9 Dec 2024 21:33:05 +0100 Subject: [PATCH 2/5] Augment spo-stake-distribution to include DRep delegation choice of pool's reward account --- .../src/Cardano/CLI/EraBased/Run/Query.hs | 63 +++++++++++++++++-- 1 file changed, 58 insertions(+), 5 deletions(-) diff --git a/cardano-cli/src/Cardano/CLI/EraBased/Run/Query.hs b/cardano-cli/src/Cardano/CLI/EraBased/Run/Query.hs index f7c87a72d..2f47ddb2e 100644 --- a/cardano-cli/src/Cardano/CLI/EraBased/Run/Query.hs +++ b/cardano-cli/src/Cardano/CLI/EraBased/Run/Query.hs @@ -10,6 +10,7 @@ {-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TupleSections #-} {-# LANGUAGE TypeApplications #-} {-# LANGUAGE TypeOperators #-} @@ -57,6 +58,7 @@ import Cardano.CLI.Types.Output (QueryDRepStateOutput (..)) import qualified Cardano.CLI.Types.Output as O import Cardano.Crypto.Hash (hashToBytesAsHex) import qualified Cardano.Crypto.Hash.Blake2b as Blake2b +import Cardano.Prelude (catMaybes) import Cardano.Slotting.EpochInfo (EpochInfo (..), epochInfoSlotToUTCTime, hoistEpochInfo) import Cardano.Slotting.Time (RelativeTime (..), toRelativeTime) @@ -917,7 +919,6 @@ callQueryStakeAddressInfoCmd , Cmd.target } , Cmd.addr = StakeAddress _ addr - , Cmd.mOutFile } = do let localNodeConnInfo = LocalNodeConnectInfo consensusModeParams networkId nodeSocketPath @@ -1344,6 +1345,7 @@ runQueryStakeDistributionCmd & onLeft (left . QueryCmdAcquireFailure) & onLeft left + writeStakeDistribution :: OutputFormatJsonOrText -> Maybe (File () Out) @@ -1670,7 +1672,7 @@ runQuerySPOStakeDistribution Cmd.QuerySPOStakeDistributionCmdArgs { Cmd.eon , Cmd.commons = - Cmd.QueryCommons + commons@Cmd.QueryCommons { Cmd.nodeSocketPath , Cmd.consensusModeParams , Cmd.networkId @@ -1687,9 +1689,60 @@ runQuerySPOStakeDistribution spos <- fromList <$> mapM spoFromSource spoHashSources - spoStakeDistribution <- runQuery localNodeConnInfo target $ querySPOStakeDistribution eon spos - writeOutput mOutFile $ - Map.assocs spoStakeDistribution + let beo = convert eon + + spoStakeDistribution :: Map (L.KeyHash L.StakePool StandardCrypto) L.Coin <- + runQuery localNodeConnInfo target $ querySPOStakeDistribution eon spos + let poolIds :: Maybe (Set (Hash StakePoolKey)) = Just $ Set.fromList $ map StakePoolKeyHash $ Map.keys spoStakeDistribution + + serialisedPoolState :: SerialisedPoolState era <- + runQuery localNodeConnInfo target $ queryPoolState beo poolIds + + PoolState (poolState :: (L.PState (ShelleyLedgerEra era))) <- + pure (decodePoolState serialisedPoolState) + & onLeft (left . QueryCmdPoolStateDecodeError) + + let spoToPoolParams + :: Map + (L.KeyHash L.StakePool StandardCrypto) + (L.PoolParams StandardCrypto) = L.psStakePoolParams poolState + rewardsAccounts + :: Map + (L.KeyHash L.StakePool StandardCrypto) + StakeCredential = Map.map (fromShelleyStakeCredential . L.raCredential . L.ppRewardAccount) spoToPoolParams + rewardsAddresses + :: Map + (L.KeyHash L.StakePool StandardCrypto) + StakeAddress = Map.map (makeStakeAddress networkId) rewardsAccounts + addressesAndRewards + :: Map + StakeAddress + (L.KeyHash L.StakePool StandardCrypto) = Map.fromList [(addr, keyHash) | (keyHash, addr) <- Map.toList rewardsAddresses] + mkQueryStakeAddressInfoCmdArgs addr = + Cmd.QueryStakeAddressInfoCmdArgs + { Cmd.commons = commons + , addr + , mOutFile -- unused anyway. TODO tighten this by removing the field. + } + infos <- + mapM (callQueryStakeAddressInfoCmd . mkQueryStakeAddressInfoCmdArgs) $ Map.elems rewardsAddresses + let spoToDelegatee :: Map (L.KeyHash L.StakePool StandardCrypto) (L.DRep StandardCrypto) = + Map.fromList $ + catMaybes $ + [ fmap (,delegatee) mSpo + | info <- infos + , (addr, delegatee) <- Map.toList $ delegatees info + , let mSpo = Map.lookup addr addressesAndRewards + ] + toWrite = + [ ( spo + , coin + , Map.lookup spo spoToDelegatee + ) + | (spo, coin) <- Map.assocs spoStakeDistribution + ] + + writeOutput mOutFile toWrite runQueryCommitteeMembersState :: Cmd.QueryCommitteeMembersStateCmdArgs era From 239b98b598e75e98268d24e16eb46997affd22df Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Cl=C3=A9ment=20Hurlin?= Date: Wed, 4 Dec 2024 13:13:55 +0100 Subject: [PATCH 3/5] Update to cardano-api 10.5 --- cabal.project | 2 +- cardano-cli/cardano-cli.cabal | 2 +- cardano-cli/src/Cardano/CLI/EraBased/Run/Query.hs | 6 +++--- flake.lock | 6 +++--- 4 files changed, 8 insertions(+), 8 deletions(-) diff --git a/cabal.project b/cabal.project index 153325bf2..2c22a1b67 100644 --- a/cabal.project +++ b/cabal.project @@ -14,7 +14,7 @@ repository cardano-haskell-packages -- you need to run if you change them index-state: , hackage.haskell.org 2024-10-11T15:49:11Z - , cardano-haskell-packages 2024-12-05T13:51:16Z + , cardano-haskell-packages 2024-12-19T20:16:27Z packages: cardano-cli diff --git a/cardano-cli/cardano-cli.cabal b/cardano-cli/cardano-cli.cabal index 79406db53..a1be050e7 100644 --- a/cardano-cli/cardano-cli.cabal +++ b/cardano-cli/cardano-cli.cabal @@ -207,7 +207,7 @@ library binary, bytestring, canonical-json, - cardano-api ^>=10.4, + cardano-api ^>=10.5, cardano-binary, cardano-crypto, cardano-crypto-class ^>=2.1.2, diff --git a/cardano-cli/src/Cardano/CLI/EraBased/Run/Query.hs b/cardano-cli/src/Cardano/CLI/EraBased/Run/Query.hs index 2f47ddb2e..8ff93110a 100644 --- a/cardano-cli/src/Cardano/CLI/EraBased/Run/Query.hs +++ b/cardano-cli/src/Cardano/CLI/EraBased/Run/Query.hs @@ -567,7 +567,7 @@ runQueryKesPeriodInfoCmd case Map.lookup (coerce blockIssuerHash) opCertCounterMap of -- Operational certificate exists in the protocol state -- so our ondisk op cert counter must be greater than or - -- equal to what is in the node state + -- equal to what is in the node state. Just ptclStateCounter -> return (OpCertOnDiskCounter onDiskOpCertCount, Just $ OpCertNodeStateCounter ptclStateCounter) Nothing -> return (OpCertOnDiskCounter onDiskOpCertCount, Nothing) @@ -1345,7 +1345,6 @@ runQueryStakeDistributionCmd & onLeft (left . QueryCmdAcquireFailure) & onLeft left - writeStakeDistribution :: OutputFormatJsonOrText -> Maybe (File () Out) @@ -1955,7 +1954,8 @@ easyRunQuerySystemStart = lift querySystemStart & onLeft (left . QueryCmdUnsuppo easyRunQuery :: () => Monad m - => m (Either UnsupportedNtcVersionError (Either Consensus.EraMismatch a)) -> ExceptT QueryCmdError m a + => m (Either UnsupportedNtcVersionError (Either Consensus.EraMismatch a)) + -> ExceptT QueryCmdError m a easyRunQuery q = lift q & onLeft (left . QueryCmdUnsupportedNtcVersion) diff --git a/flake.lock b/flake.lock index 387c4a3a8..073dfd525 100644 --- a/flake.lock +++ b/flake.lock @@ -3,11 +3,11 @@ "CHaP": { "flake": false, "locked": { - "lastModified": 1733408643, - "narHash": "sha256-IH5nYTjx+CYAK4zQAkOs475X+AOhP/GPgwXm5LQHsEE=", + "lastModified": 1734652334, + "narHash": "sha256-zDJVC0/vTaZq+qs2nYlSCKh19PB0K0eAtJZvn4hRHAI=", "owner": "intersectmbo", "repo": "cardano-haskell-packages", - "rev": "e062328804c933d296e5956c989b326ea3c69eeb", + "rev": "94b36615fa8f5aaae885627273bc8499eeebdca5", "type": "github" }, "original": { From 71af6f280213e193ab326de2dea6d462e2b9a9c4 Mon Sep 17 00:00:00 2001 From: Carlos LopezDeLara Date: Fri, 20 Dec 2024 15:01:25 -0600 Subject: [PATCH 4/5] Update Query.hs --- .../src/Cardano/CLI/EraBased/Run/Query.hs | 56 +++++++++---------- 1 file changed, 27 insertions(+), 29 deletions(-) diff --git a/cardano-cli/src/Cardano/CLI/EraBased/Run/Query.hs b/cardano-cli/src/Cardano/CLI/EraBased/Run/Query.hs index 8ff93110a..8b4232a66 100644 --- a/cardano-cli/src/Cardano/CLI/EraBased/Run/Query.hs +++ b/cardano-cli/src/Cardano/CLI/EraBased/Run/Query.hs @@ -58,7 +58,6 @@ import Cardano.CLI.Types.Output (QueryDRepStateOutput (..)) import qualified Cardano.CLI.Types.Output as O import Cardano.Crypto.Hash (hashToBytesAsHex) import qualified Cardano.Crypto.Hash.Blake2b as Blake2b -import Cardano.Prelude (catMaybes) import Cardano.Slotting.EpochInfo (EpochInfo (..), epochInfoSlotToUTCTime, hoistEpochInfo) import Cardano.Slotting.Time (RelativeTime (..), toRelativeTime) @@ -1692,48 +1691,47 @@ runQuerySPOStakeDistribution spoStakeDistribution :: Map (L.KeyHash L.StakePool StandardCrypto) L.Coin <- runQuery localNodeConnInfo target $ querySPOStakeDistribution eon spos - let poolIds :: Maybe (Set (Hash StakePoolKey)) = Just $ Set.fromList $ map StakePoolKeyHash $ Map.keys spoStakeDistribution + let poolIds :: Set (Hash StakePoolKey) = Set.fromList $ map StakePoolKeyHash $ Map.keys spoStakeDistribution serialisedPoolState :: SerialisedPoolState era <- - runQuery localNodeConnInfo target $ queryPoolState beo poolIds + runQuery localNodeConnInfo target $ queryPoolState beo (Just poolIds) - PoolState (poolState :: (L.PState (ShelleyLedgerEra era))) <- + PoolState (poolState :: L.PState (ShelleyLedgerEra era)) <- pure (decodePoolState serialisedPoolState) & onLeft (left . QueryCmdPoolStateDecodeError) - let spoToPoolParams - :: Map - (L.KeyHash L.StakePool StandardCrypto) - (L.PoolParams StandardCrypto) = L.psStakePoolParams poolState - rewardsAccounts - :: Map - (L.KeyHash L.StakePool StandardCrypto) - StakeCredential = Map.map (fromShelleyStakeCredential . L.raCredential . L.ppRewardAccount) spoToPoolParams - rewardsAddresses - :: Map - (L.KeyHash L.StakePool StandardCrypto) - StakeAddress = Map.map (makeStakeAddress networkId) rewardsAccounts - addressesAndRewards + let addressesAndRewards :: Map StakeAddress - (L.KeyHash L.StakePool StandardCrypto) = Map.fromList [(addr, keyHash) | (keyHash, addr) <- Map.toList rewardsAddresses] + (L.KeyHash L.StakePool StandardCrypto) = + Map.fromList + [ ( makeStakeAddress networkId . fromShelleyStakeCredential . L.raCredential . L.ppRewardAccount $ addr + , keyHash + ) + | (keyHash, addr) <- Map.toList $ L.psStakePoolParams poolState + ] + mkQueryStakeAddressInfoCmdArgs addr = Cmd.QueryStakeAddressInfoCmdArgs { Cmd.commons = commons , addr , mOutFile -- unused anyway. TODO tighten this by removing the field. } - infos <- - mapM (callQueryStakeAddressInfoCmd . mkQueryStakeAddressInfoCmdArgs) $ Map.elems rewardsAddresses - let spoToDelegatee :: Map (L.KeyHash L.StakePool StandardCrypto) (L.DRep StandardCrypto) = - Map.fromList $ - catMaybes $ - [ fmap (,delegatee) mSpo - | info <- infos - , (addr, delegatee) <- Map.toList $ delegatees info - , let mSpo = Map.lookup addr addressesAndRewards - ] - toWrite = + + spoToDelegatee <- + Map.fromList . concat + <$> traverse + ( \stakeAddr -> do + info <- callQueryStakeAddressInfoCmd $ mkQueryStakeAddressInfoCmdArgs stakeAddr + return $ + [ (spo, delegatee) + | (Just spo, delegatee) <- + map (first (`Map.lookup` addressesAndRewards)) $ Map.toList $ delegatees info + ] + ) + (Map.keys addressesAndRewards) + + let toWrite = [ ( spo , coin , Map.lookup spo spoToDelegatee From 38f5132175893824ff27c3aa25912d55d06d77e0 Mon Sep 17 00:00:00 2001 From: Carlos LopezDeLara Date: Fri, 20 Dec 2024 15:34:52 -0600 Subject: [PATCH 5/5] Update Query.hs --- .../src/Cardano/CLI/EraBased/Run/Query.hs | 47 +++++++++---------- 1 file changed, 22 insertions(+), 25 deletions(-) diff --git a/cardano-cli/src/Cardano/CLI/EraBased/Run/Query.hs b/cardano-cli/src/Cardano/CLI/EraBased/Run/Query.hs index 8b4232a66..3a03a2692 100644 --- a/cardano-cli/src/Cardano/CLI/EraBased/Run/Query.hs +++ b/cardano-cli/src/Cardano/CLI/EraBased/Run/Query.hs @@ -918,39 +918,36 @@ callQueryStakeAddressInfoCmd , Cmd.target } , Cmd.addr = StakeAddress _ addr - } = do - let localNodeConnInfo = LocalNodeConnectInfo consensusModeParams networkId nodeSocketPath + } = + do + let localNodeConnInfo = LocalNodeConnectInfo consensusModeParams networkId nodeSocketPath - join $ - lift - ( executeLocalStateQueryExpr localNodeConnInfo target $ runExceptT $ do - AnyCardanoEra era <- easyRunQueryCurrentEra + lift $ executeLocalStateQueryExpr localNodeConnInfo target $ runExceptT $ do + AnyCardanoEra era <- easyRunQueryCurrentEra - sbe <- - requireShelleyBasedEra era - & onNothing (left QueryCmdByronEra) + sbe <- + requireShelleyBasedEra era + & onNothing (left QueryCmdByronEra) - let stakeAddr = Set.singleton $ fromShelleyStakeCredential addr + let stakeAddr = Set.singleton $ fromShelleyStakeCredential addr - (stakeRewardAccountBalances, stakePools) <- - easyRunQuery (queryStakeAddresses sbe stakeAddr networkId) + (stakeRewardAccountBalances, stakePools) <- + easyRunQuery (queryStakeAddresses sbe stakeAddr networkId) - beo <- requireEon BabbageEra era + beo <- requireEon BabbageEra era - stakeDelegDeposits <- easyRunQuery (queryStakeDelegDeposits beo stakeAddr) + stakeDelegDeposits <- easyRunQuery (queryStakeDelegDeposits beo stakeAddr) - stakeVoteDelegatees <- monoidForEraInEonA era $ \ceo -> - easyRunQuery (queryStakeVoteDelegatees ceo stakeAddr) + stakeVoteDelegatees <- monoidForEraInEonA era $ \ceo -> + easyRunQuery (queryStakeVoteDelegatees ceo stakeAddr) - return $ - return $ - StakeAddressInfoData - (DelegationsAndRewards (stakeRewardAccountBalances, stakePools)) - (Map.mapKeys (makeStakeAddress networkId) stakeDelegDeposits) - (Map.mapKeys (makeStakeAddress networkId) stakeVoteDelegatees) - ) - & onLeft (left . QueryCmdAcquireFailure) - & onLeft left + pure $ + StakeAddressInfoData + (DelegationsAndRewards (stakeRewardAccountBalances, stakePools)) + (Map.mapKeys (makeStakeAddress networkId) stakeDelegDeposits) + (Map.mapKeys (makeStakeAddress networkId) stakeVoteDelegatees) + & onLeft (left . QueryCmdAcquireFailure) + & onLeft left -- -------------------------------------------------------------------------------------------------