New query stake pools command

IntersectMBO · Aug 28, 2021 · b8c4b1b · b8c4b1b
1 parent 35aabd3
commit b8c4b1b
Show file tree

Hide file tree

Showing 3 changed files with 62 additions and 1 deletion.
diff --git 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
@@ -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
@@ -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