Skip to content
New issue

Have a question about this project? Sign up for a free GitHub account to open an issue and contact its maintainers and the community.

Sign up for GitHub

By clicking “Sign up for GitHub”, you agree to our terms of service and privacy statement. We’ll occasionally send you account related emails.

Already on GitHub? Sign in to your account

Query stake addresses #138 #144

Merged
merged 3 commits into from
Apr 19, 2024
Merged

Query stake addresses #138 #144

Show file tree
Hide file tree
Changes from all commits
Commits
Show all changes
3 commits
Select commit Hold shift + click to select a range
745f0cf
Query stake addresses #138
the-headless-ghost Apr 18, 2024
5b6d6c5
Undo accidental removal
the-headless-ghost Apr 18, 2024
94e7d78
Merge remote-tracking branch 'origin' into edgr/query-stake-addresses…
the-headless-ghost Apr 18, 2024
File filter

Filter by extension

Filter by extension
Conversations
Failed to load comments.
Loading
Jump to
Jump to file
Failed to load files.
Loading
Diff view
Diff view
1 change: 1 addition & 0 deletions src/base/lib/Convex/BuildTx.hs
View file
Open in desktop
Original file line number Diff line number Diff line change
Expand Up @@ -237,6 +237,7 @@ instance MonadBlockchain m => MonadBlockchain (BuildTxT m) where
sendTx = lift . sendTx
utxoByTxIn = lift . utxoByTxIn
queryProtocolParameters = lift queryProtocolParameters
queryStakeAddresses creds = lift . queryStakeAddresses creds
queryStakePools = lift queryStakePools
querySystemStart = lift querySystemStart
queryEraHistory = lift queryEraHistory
Expand Down
10 changes: 10 additions & 0 deletions src/base/lib/Convex/Class.hs
View file
Open in desktop
Original file line number Diff line number Diff line change
Expand Up @@ -62,6 +62,7 @@ import Convex.Utils (posixTimeToS
slotToUtcTime)
import Data.Aeson (FromJSON,
ToJSON)
import Data.Map (Map)
import qualified Data.Map as Map
import Data.Set (Set)
import qualified Data.Set as Set
Expand All @@ -79,6 +80,7 @@ class Monad m => MonadBlockchain m where
sendTx :: Tx BabbageEra -> m TxId -- ^ Submit a transaction to the network
utxoByTxIn :: Set C.TxIn -> m (C.UTxO C.BabbageEra) -- ^ Resolve tx inputs
queryProtocolParameters :: m (LedgerProtocolParameters C.BabbageEra) -- ^ Get the protocol parameters
queryStakeAddresses :: Set C.StakeCredential -> NetworkId -> m (Map C.StakeAddress C.Lovelace, Map C.StakeAddress PoolId) -- ^ Get stake rewards
queryStakePools :: m (Set PoolId) -- ^ Get the stake pools
querySystemStart :: m SystemStart
queryEraHistory :: m EraHistory
Expand All @@ -93,6 +95,7 @@ instance MonadBlockchain m => MonadBlockchain (ResultT m) where
sendTx = lift . sendTx
utxoByTxIn = lift . utxoByTxIn
queryProtocolParameters = lift queryProtocolParameters
queryStakeAddresses creds = lift . queryStakeAddresses creds
queryStakePools = lift queryStakePools
querySystemStart = lift querySystemStart
queryEraHistory = lift queryEraHistory
Expand All @@ -103,6 +106,7 @@ instance MonadBlockchain m => MonadBlockchain (ExceptT e m) where
sendTx = lift . sendTx
utxoByTxIn = lift . utxoByTxIn
queryProtocolParameters = lift queryProtocolParameters
queryStakeAddresses creds = lift . queryStakeAddresses creds
queryStakePools = lift queryStakePools
querySystemStart = lift querySystemStart
queryEraHistory = lift queryEraHistory
Expand All @@ -113,6 +117,7 @@ instance MonadBlockchain m => MonadBlockchain (ReaderT e m) where
sendTx = lift . sendTx
utxoByTxIn = lift . utxoByTxIn
queryProtocolParameters = lift queryProtocolParameters
queryStakeAddresses creds = lift . queryStakeAddresses creds
queryStakePools = lift queryStakePools
querySystemStart = lift querySystemStart
queryEraHistory = lift queryEraHistory
Expand All @@ -123,6 +128,7 @@ instance MonadBlockchain m => MonadBlockchain (StrictState.StateT e m) where
sendTx = lift . sendTx
utxoByTxIn = lift . utxoByTxIn
queryProtocolParameters = lift queryProtocolParameters
queryStakeAddresses creds = lift . queryStakeAddresses creds
queryStakePools = lift queryStakePools
querySystemStart = lift querySystemStart
queryEraHistory = lift queryEraHistory
Expand All @@ -133,6 +139,7 @@ instance MonadBlockchain m => MonadBlockchain (LazyState.StateT e m) where
sendTx = lift . sendTx
utxoByTxIn = lift . utxoByTxIn
queryProtocolParameters = lift queryProtocolParameters
queryStakeAddresses creds = lift . queryStakeAddresses creds
queryStakePools = lift queryStakePools
querySystemStart = lift querySystemStart
queryEraHistory = lift queryEraHistory
Expand Down Expand Up @@ -284,6 +291,9 @@ instance (MonadLog m, MonadIO m) => MonadBlockchain (MonadBlockchainCardanoNodeT
queryProtocolParameters = do
LedgerProtocolParameters <$> runQuery' (C.QueryInEra (C.QueryInShelleyBasedEra C.ShelleyBasedEraBabbage C.QueryProtocolParameters))

queryStakeAddresses creds nid =
runQuery' (C.QueryInEra (C.QueryInShelleyBasedEra C.ShelleyBasedEraBabbage (C.QueryStakeAddresses creds nid)))

queryStakePools =
runQuery' (C.QueryInEra (C.QueryInShelleyBasedEra C.ShelleyBasedEraBabbage C.QueryStakePools))

Expand Down
29 changes: 28 additions & 1 deletion src/base/lib/Convex/NodeQueries.hs
View file
Open in desktop
Original file line number Diff line number Diff line change
Expand Up @@ -8,7 +8,9 @@ module Convex.NodeQueries(
querySystemStart,
queryLocalState,
queryTip,
queryProtocolParameters
queryProtocolParameters,
queryStakePools,
queryStakeAddresses
) where

import Cardano.Api (ChainPoint,
Expand All @@ -21,8 +23,11 @@ import Cardano.Api (ChainPoint,
NetworkId (Mainnet, Testnet),
NetworkMagic (..),
SystemStart,
Lovelace,
envSecurityParam)
import qualified Cardano.Api as CAPI
import Cardano.Api.Shelley (PoolId, StakeAddress,
StakeCredential)
import qualified Cardano.Chain.Genesis
import Cardano.Crypto (RequiresNetworkMagic (..),
getProtocolMagic)
Expand All @@ -32,6 +37,8 @@ import Control.Monad.Except (MonadError,
import Control.Monad.IO.Class (MonadIO (..))
import Control.Monad.Trans.Except (runExceptT)
import Data.SOP.Strict (NP ((:*)))
import Data.Set (Set)
import Data.Map (Map)
import qualified Ouroboros.Consensus.Cardano.CanHardFork as Consensus
import qualified Ouroboros.Consensus.HardFork.Combinator as Consensus
import qualified Ouroboros.Consensus.HardFork.Combinator.AcrossEras as HFC
Expand Down Expand Up @@ -91,6 +98,26 @@ queryEraHistory = queryLocalState CAPI.QueryEraHistory
queryTip :: LocalNodeConnectInfo -> IO ChainPoint
queryTip = queryLocalState CAPI.QueryChainPoint

queryStakePools :: LocalNodeConnectInfo -> IO (Set PoolId)
queryStakePools connectInfo = do
result <- queryLocalState
(CAPI.QueryInEra (CAPI.QueryInShelleyBasedEra CAPI.ShelleyBasedEraBabbage CAPI.QueryStakePools))
connectInfo
case result of
Left err -> do
fail ("queryStakePools: failed with: " <> show err)
Right k -> pure k

queryStakeAddresses :: LocalNodeConnectInfo -> Set StakeCredential -> NetworkId -> IO (Map StakeAddress Lovelace, Map StakeAddress PoolId)
queryStakeAddresses info creds nid = do
result <- queryLocalState
(CAPI.QueryInEra (CAPI.QueryInShelleyBasedEra CAPI.ShelleyBasedEraBabbage (CAPI.QueryStakeAddresses creds nid)))
info
case result of
Left err -> do
fail ("queryStakeAddresses: failed with: " <> show err)
Right k -> pure k

-- | Run a local state query on the local cardano node, using the volatile tip
queryLocalState :: CAPI.QueryInMode b -> LocalNodeConnectInfo -> IO b
queryLocalState query connectInfo = do
Expand Down
26 changes: 25 additions & 1 deletion src/mockchain/lib/Convex/MockChain.hs
View file
Open in desktop
Original file line number Diff line number Diff line change
Expand Up @@ -64,7 +64,8 @@ module Convex.MockChain(
) where

import Cardano.Api.Shelley (AddressInEra,
BabbageEra, Hash,
BabbageEra,
Hash (StakePoolKeyHash),
ScriptData,
ShelleyLedgerEra,
SlotNo, Tx,
Expand Down Expand Up @@ -93,13 +94,16 @@ import Cardano.Ledger.Shelley.API (AccountState (..),
ApplyTxError, Coin (..),
LedgerEnv (..),
MempoolEnv,
CertState (..),
MempoolState, UTxO (..),
UtxoEnv (..), Validated,
initialFundsPseudoTxIn)
import qualified Cardano.Ledger.Shelley.API
import Cardano.Ledger.Shelley.LedgerState (LedgerState (..),
UTxOState (..),
rewards,
smartUTxOState)
import Cardano.Ledger.UMap ((⋪), rewardMap, sPoolMap)
import qualified Cardano.Ledger.Val as Val
import Control.Lens (_1, _3, over, set, to,
view, (%=), (&), (.~),
Expand Down Expand Up @@ -136,6 +140,7 @@ import Data.Foldable (for_, traverse_)
import Data.Functor.Identity (Identity (..))
import Data.Map (Map)
import qualified Data.Map as Map
import qualified Data.Set as Set
import Ouroboros.Consensus.Shelley.Eras (EraCrypto)
import qualified PlutusCore as PLC
import PlutusLedgerApi.Common (mkTermToEvaluate)
Expand Down Expand Up @@ -350,6 +355,25 @@ instance Monad m => MonadBlockchain (MockchainT m) where
let mp' = Map.restrictKeys mp txIns
pure (Cardano.Api.UTxO mp')
queryProtocolParameters = MockchainT (asks npProtocolParameters)
queryStakeAddresses creds nid = MockchainT $ do
dState <- gets (certDState . lsCertState . view poolState)
let
-- (Map (Credential 'Staking StandardCrypto) (UMElem StandardCrypto))
rewards' = toLedgerStakeCredentials creds ⋪ rewards dState
rewardsMap =
Map.fromList
$ bimap
fromLedgerStakeAddress
Cardano.Api.fromShelleyLovelace <$> Map.toList (rewardMap rewards')
poolMap =
Map.fromList
$ bimap
fromLedgerStakeAddress
StakePoolKeyHash <$> Map.toList (sPoolMap rewards')
pure (rewardsMap, poolMap)
where
toLedgerStakeCredentials creds' = Set.fromList $ Cardano.Api.toShelleyStakeCredential <$> Set.toList creds'
fromLedgerStakeAddress = Cardano.Api.makeStakeAddress nid . Cardano.Api.fromShelleyStakeCredential
queryStakePools = MockchainT (asks npStakePools)
networkId = MockchainT (asks npNetworkId)
querySystemStart = MockchainT (asks npSystemStart)
Expand Down
2 changes: 2 additions & 0 deletions src/node-client/lib/Convex/NodeClient/WaitForTxnClient.hs
View file
Open in desktop
Original file line number Diff line number Diff line change
Expand Up @@ -95,6 +95,8 @@ instance (MonadIO m, MonadBlockchain m, MonadLog m) => MonadBlockchain (MonadBlo

queryProtocolParameters = MonadBlockchainWaitingT queryProtocolParameters

queryStakeAddresses creds = MonadBlockchainWaitingT . queryStakeAddresses creds

queryStakePools = MonadBlockchainWaitingT queryStakePools

querySystemStart = MonadBlockchainWaitingT querySystemStart
Expand Down
Loading