From b8c4b1bfca4fd1d916eee385f2544e22311f9823 Mon Sep 17 00:00:00 2001 From: John Ky Date: Sat, 28 Aug 2021 16:05:18 +1000 Subject: [PATCH] New query stake pools command --- .../src/Cardano/CLI/Shelley/Commands.hs | 2 + .../src/Cardano/CLI/Shelley/Parsers.hs | 9 ++++ .../src/Cardano/CLI/Shelley/Run/Query.hs | 52 ++++++++++++++++++- 3 files changed, 62 insertions(+), 1 deletion(-) diff --git a/cardano-cli/src/Cardano/CLI/Shelley/Commands.hs b/cardano-cli/src/Cardano/CLI/Shelley/Commands.hs index 8d3c75fa950..2b1b065d662 100644 --- a/cardano-cli/src/Cardano/CLI/Shelley/Commands.hs +++ b/cardano-cli/src/Cardano/CLI/Shelley/Commands.hs @@ -336,6 +336,7 @@ renderPoolCmd cmd = data QueryCmd = QueryProtocolParameters' AnyConsensusModeParams NetworkId (Maybe OutputFile) | QueryTip AnyConsensusModeParams NetworkId (Maybe OutputFile) + | QueryStakePools' AnyConsensusModeParams NetworkId (Maybe OutputFile) | QueryStakeDistribution' AnyConsensusModeParams NetworkId (Maybe OutputFile) | QueryStakeAddressInfo AnyConsensusModeParams StakeAddress NetworkId (Maybe OutputFile) | QueryUTxO' AnyConsensusModeParams QueryUTxOFilter NetworkId (Maybe OutputFile) @@ -350,6 +351,7 @@ renderQueryCmd cmd = case cmd of QueryProtocolParameters' {} -> "query protocol-parameters " QueryTip {} -> "query tip" + QueryStakePools' {} -> "query stake-pools" QueryStakeDistribution' {} -> "query stake-distribution" QueryStakeAddressInfo {} -> "query stake-address-info" QueryUTxO' {} -> "query utxo" diff --git a/cardano-cli/src/Cardano/CLI/Shelley/Parsers.hs b/cardano-cli/src/Cardano/CLI/Shelley/Parsers.hs index af5648154c2..c56d0f06c92 100644 --- a/cardano-cli/src/Cardano/CLI/Shelley/Parsers.hs +++ b/cardano-cli/src/Cardano/CLI/Shelley/Parsers.hs @@ -847,6 +847,8 @@ pQueryCmd = (Opt.info pQueryProtocolParameters $ Opt.progDesc "Get the node's current protocol parameters") , subParser "tip" (Opt.info pQueryTip $ Opt.progDesc "Get the node's current tip (slot no, hash, block no)") + , subParser "stake-pools" + (Opt.info pQueryStakePools $ Opt.progDesc "Get the node's current set of stake pool ids") , subParser "stake-distribution" (Opt.info pQueryStakeDistribution $ Opt.progDesc "Get the node's current aggregated stake distribution") , subParser "stake-address-info" @@ -887,6 +889,13 @@ pQueryCmd = <*> pNetworkId <*> pMaybeOutputFile + pQueryStakePools :: Parser QueryCmd + pQueryStakePools = + QueryStakePools' + <$> pConsensusModeParams + <*> pNetworkId + <*> pMaybeOutputFile + pQueryStakeDistribution :: Parser QueryCmd pQueryStakeDistribution = QueryStakeDistribution' diff --git a/cardano-cli/src/Cardano/CLI/Shelley/Run/Query.hs b/cardano-cli/src/Cardano/CLI/Shelley/Run/Query.hs index 1f51c2e9d51..f48c1299d38 100644 --- a/cardano-cli/src/Cardano/CLI/Shelley/Run/Query.hs +++ b/cardano-cli/src/Cardano/CLI/Shelley/Run/Query.hs @@ -116,6 +116,8 @@ runQueryCmd cmd = runQueryProtocolParameters consensusModeParams network mOutFile QueryTip consensusModeParams network mOutFile -> runQueryTip consensusModeParams network mOutFile + QueryStakePools' consensusModeParams network mOutFile -> + runQueryStakePools consensusModeParams network mOutFile QueryStakeDistribution' consensusModeParams network mOutFile -> runQueryStakeDistribution consensusModeParams network mOutFile QueryStakeAddressInfo consensusModeParams addr network mOutFile -> @@ -663,6 +665,54 @@ printUtxo shelleyBasedEra' txInOutTuple = printableValue (TxOutValue _ val) = renderValue val printableValue (TxOutAdaOnly _ (Lovelace i)) = Text.pack $ show i +joinEither :: (x -> z) -> (y -> z) -> Either x (Either y a) -> Either z a +joinEither f g = join . bimap f (first g) + +joinEitherM :: Functor m => (x -> z) -> (y -> z) -> m (Either x (Either y a)) -> m (Either z a) +joinEitherM f g = fmap (joinEither f g) + +runQueryStakePools + :: AnyConsensusModeParams + -> NetworkId + -> Maybe OutputFile + -> ExceptT ShelleyQueryCmdError IO () +runQueryStakePools (AnyConsensusModeParams cModeParams) + network mOutFile = do + SocketPath sockPath <- firstExceptT ShelleyQueryCmdEnvVarSocketErr readEnvSocketPath + + let localNodeConnInfo = LocalNodeConnectInfo cModeParams network sockPath + + result <- ExceptT . joinEitherM ShelleyQueryCmdAcquireFailure id $ + executeLocalStateQueryExpr localNodeConnInfo Nothing $ \_ntcVersion -> runExceptT @ShelleyQueryCmdError $ do + anyE@(AnyCardanoEra era) <- case consensusModeOnly cModeParams of + ByronMode -> return $ AnyCardanoEra ByronEra + ShelleyMode -> return $ AnyCardanoEra ShelleyEra + CardanoMode -> lift . queryExpr $ QueryCurrentEra CardanoModeIsMultiEra + + let cMode = consensusModeOnly cModeParams + + case toEraInMode era cMode of + Just eInMode -> do + sbe <- getSbe $ cardanoEraStyle era + + firstExceptT ShelleyQueryCmdEraMismatch . ExceptT $ + queryExpr . QueryInEra eInMode . QueryInShelleyBasedEra sbe $ QueryStakePools + + Nothing -> left $ ShelleyQueryCmdEraConsensusModeMismatch (AnyConsensusMode cMode) anyE + + writeStakePools mOutFile result + +writeStakePools + :: Maybe OutputFile + -> Set PoolId + -> ExceptT ShelleyQueryCmdError IO () +writeStakePools (Just (OutputFile outFile)) stakePools = + handleIOExceptT (ShelleyQueryCmdWriteFileError . FileIOError outFile) $ + LBS.writeFile outFile (encodePretty stakePools) + +writeStakePools Nothing stakePools = + forM_ (Set.toList stakePools) $ \poolId -> + liftIO . putStrLn $ Text.unpack (serialiseToBech32 poolId) runQueryStakeDistribution :: AnyConsensusModeParams @@ -793,7 +843,7 @@ executeQuery era cModeP localNodeConnInfo q = do execQuery :: IO (Either AcquireFailure (Either EraMismatch result)) execQuery = queryNodeLocalState localNodeConnInfo Nothing q -getSbe :: CardanoEraStyle era -> ExceptT ShelleyQueryCmdError IO (ShelleyBasedEra era) +getSbe :: Monad m => CardanoEraStyle era -> ExceptT ShelleyQueryCmdError m (ShelleyBasedEra era) getSbe LegacyByronEra = left ShelleyQueryCmdByronEra getSbe (ShelleyBasedEra sbe) = return sbe