Merge #3152

3152: Query for stakepools in run tx build r=newhoggy a=newhoggy Co-authored-by: John Ky <[email protected]>
IntersectMBO · Sep 6, 2021 · d407d2c · d407d2c
2 parents bc729af + e04bb8c
commit d407d2c
Show file tree

Hide file tree

Showing 4 changed files with 71 additions and 124 deletions.
diff --git a/cardano-cli/src/Cardano/CLI/Shelley/Commands.hs b/cardano-cli/src/Cardano/CLI/Shelley/Commands.hs
@@ -340,6 +340,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)
@@ -354,6 +355,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
@@ -849,6 +849,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"
@@ -889,6 +891,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
@@ -117,6 +117,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 ->
@@ -664,6 +666,48 @@ printUtxo shelleyBasedEra' txInOutTuple =
   printableValue (TxOutValue _ val) = renderValue val
   printableValue (TxOutAdaOnly _ (Lovelace i)) = Text.pack $ show i
 
+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 . fmap (join . first ShelleyQueryCmdAcquireFailure) $
+    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

diff --git a/cardano-cli/src/Cardano/CLI/Shelley/Run/Transaction.hs b/cardano-cli/src/Cardano/CLI/Shelley/Run/Transaction.hs
@@ -19,13 +19,11 @@ import           Prelude (String, error)
 import qualified Data.Aeson as Aeson
 import qualified Data.ByteString.Char8 as BS
 import qualified Data.ByteString.Lazy.Char8 as LBS
-import           Data.List (intersect, (\\))
 import qualified Data.Map.Strict as Map
 import qualified Data.Set as Set
 import qualified Data.Text as Text
 import           Data.Type.Equality (TestEquality (..))
 
-import           Control.Concurrent.STM
 import           Control.Monad.Trans.Except.Extra (firstExceptT, handleIOExceptT, hoistEither,
                    hoistMaybe, left, newExceptT)
 
@@ -51,14 +49,11 @@ import           Cardano.CLI.Shelley.Run.Query (ShelleyQueryCmdLocalStateQueryEr
                    renderLocalStateQueryError)
 import           Cardano.CLI.Shelley.Script
 import           Cardano.CLI.Types
-import           Ouroboros.Consensus.BlockchainTime.WallClock.Types (SystemStart (..))
 import           Ouroboros.Consensus.Byron.Ledger (ByronBlock)
 import           Ouroboros.Consensus.Cardano.Block (EraMismatch (..))
 import           Ouroboros.Consensus.Ledger.SupportsMempool (ApplyTxErr)
 import           Ouroboros.Consensus.Shelley.Ledger (ShelleyBlock)
-import qualified Ouroboros.Network.Protocol.LocalStateQuery.Client as Net.Query
 import           Ouroboros.Network.Protocol.LocalStateQuery.Type (AcquireFailure (..))
-import qualified Ouroboros.Network.Protocol.LocalStateQuery.Type as Net.Query
 import qualified Ouroboros.Network.Protocol.LocalTxSubmission.Client as Net.Tx
 
 import qualified System.IO as IO
@@ -374,7 +369,6 @@ runTxBuildRaw (AnyCardanoEra era)
     firstExceptT ShelleyTxCmdWriteFileError . newExceptT $
       writeFileTextEnvelope fpath Nothing txBody
 
-
 runTxBuild
   :: AnyCardanoEra
   -> AnyConsensusModeParams
@@ -440,38 +434,30 @@ runTxBuild (AnyCardanoEra era) (AnyConsensusModeParams cModeParams) networkId mS
           <*> validateTxMintValue         era mValue
           <*> validateTxScriptValidity    era mScriptValidity
 
-      -- TODO: Combine queries
-      let localConnInfo = LocalNodeConnectInfo
-                            { localConsensusModeParams = CardanoModeParams (EpochSlots 21600)
-                            , localNodeNetworkId       = networkId
-                            , localNodeSocketPath      = sockPath
-                            }
-
       eInMode <- case toEraInMode era CardanoMode of
                    Just result -> return result
                    Nothing ->
                      left (ShelleyTxCmdEraConsensusModeMismatchTxBalance outBody
                             (AnyConsensusMode CardanoMode) (AnyCardanoEra era))
 
-      let collateralUTxOQuery = QueryInEra eInMode $ QueryInShelleyBasedEra sbe
-                                  (QueryUTxO . QueryUTxOByTxIn $ Set.fromList txinsc)
-          utxoQuery = QueryInEra eInMode $ QueryInShelleyBasedEra sbe
-                        (QueryUTxO . QueryUTxOByTxIn $ Set.fromList onlyInputs)
-          pParamsQuery = QueryInEra eInMode $ QueryInShelleyBasedEra sbe QueryProtocolParameters
+      (utxo, pparams, eraHistory, systemStart, stakePools) <-
+        newExceptT . fmap (join . first ShelleyTxCmdAcquireFailure) $
+          executeLocalStateQueryExpr localNodeConnInfo Nothing $ \_ntcVersion -> runExceptT $ do
+            utxo <- firstExceptT ShelleyTxCmdTxSubmitErrorEraMismatch . newExceptT . queryExpr
+              $ QueryInEra eInMode $ QueryInShelleyBasedEra sbe
+              $ QueryUTxO (QueryUTxOByTxIn (Set.fromList onlyInputs))
+
+            pparams <- firstExceptT ShelleyTxCmdTxSubmitErrorEraMismatch . newExceptT . queryExpr
+              $ QueryInEra eInMode $ QueryInShelleyBasedEra sbe QueryProtocolParameters
 
-      if null txinsc
-      then return ()
-      else do
-        collateralUtxo <- executeQuery era cModeParams localConnInfo collateralUTxOQuery
-        txinsExist txinsc collateralUtxo
-        notScriptLockedTxIns collateralUtxo
+            eraHistory <- lift . queryExpr $ QueryEraHistory CardanoModeIsMultiEra
 
-      utxo <- executeQuery era cModeParams localConnInfo utxoQuery
-      txinsExist onlyInputs utxo
+            systemStart <- lift $ queryExpr QuerySystemStart
 
-      pparams <- executeQuery era cModeParams localConnInfo pParamsQuery
-      (eraHistory, systemStart) <- firstExceptT ShelleyTxCmdAcquireFailure
-                                     $ newExceptT $ queryEraHistoryAndSystemStart localNodeConnInfo Nothing
+            stakePools <- firstExceptT ShelleyTxCmdTxSubmitErrorEraMismatch . ExceptT $
+              queryExpr . QueryInEra eInMode . QueryInShelleyBasedEra sbe $ QueryStakePools
+
+            return (utxo, pparams, eraHistory, systemStart, stakePools)
 
       let cAddr = case anyAddressInEra era changeAddr of
                     Just addr -> addr
@@ -481,7 +467,7 @@ runTxBuild (AnyCardanoEra era) (AnyConsensusModeParams cModeParams) networkId mS
         firstExceptT ShelleyTxCmdBalanceTxBody
           . hoistEither
           $ makeTransactionBodyAutoBalance eInMode systemStart eraHistory
-                                           pparams Set.empty utxo txBodyContent
+                                           pparams stakePools utxo txBodyContent
                                            cAddr mOverrideWits
 
       putStrLn $ "Estimated transaction fee: " <> (show fee :: String)
@@ -492,65 +478,6 @@ runTxBuild (AnyCardanoEra era) (AnyConsensusModeParams cModeParams) networkId mS
     (CardanoMode, LegacyByronEra) -> left ShelleyTxCmdByronEra
 
     (wrongMode, _) -> left (ShelleyTxCmdUnsupportedMode (AnyConsensusMode wrongMode))
- where
-  txinsExist :: [TxIn] -> UTxO era -> ExceptT ShelleyTxCmdError IO ()
-  txinsExist ins (UTxO utxo)
-    | null utxo = left $ ShelleyTxCmdTxInsDoNotExist ins
-    | otherwise = do
-        let utxoIns = Map.keys utxo
-            occursInUtxo = [ txin | txin <- ins, txin `elem` utxoIns ]
-        if length occursInUtxo == length ins
-        then return ()
-        else left . ShelleyTxCmdTxInsDoNotExist $ ins \\ ins `intersect` occursInUtxo
-
-  notScriptLockedTxIns :: UTxO era -> ExceptT ShelleyTxCmdError IO ()
-  notScriptLockedTxIns (UTxO utxo) = do
-    let scriptLockedTxIns =
-          filter (\(_, TxOut aInEra _ _) -> not $ isKeyAddress aInEra ) $ Map.assocs utxo
-    if null scriptLockedTxIns
-    then return ()
-    else left . ShelleyTxCmdExpectedKeyLockedTxIn $ map fst scriptLockedTxIns
-
-queryEraHistoryAndSystemStart
-  :: LocalNodeConnectInfo CardanoMode
-  -> Maybe ChainPoint
-  -> IO (Either Net.Query.AcquireFailure (EraHistory CardanoMode, SystemStart))
-queryEraHistoryAndSystemStart connctInfo mpoint = do
-    resultVar <- newEmptyTMVarIO
-    connectToLocalNode
-      connctInfo
-      LocalNodeClientProtocols
-      { localChainSyncClient    = NoLocalChainSyncClient
-      , localStateQueryClient   = Just (singleQuery mpoint resultVar)
-      , localTxSubmissionClient = Nothing
-      }
-    atomically (takeTMVar resultVar)
-  where
-    singleQuery
-      :: Maybe ChainPoint
-      -> TMVar (Either Net.Query.AcquireFailure (EraHistory CardanoMode, SystemStart))
-      -> Net.Query.LocalStateQueryClient (BlockInMode CardanoMode) ChainPoint
-                                         (QueryInMode CardanoMode) IO ()
-    singleQuery mPointVar' resultVar' =
-      LocalStateQueryClient $ do
-      pure . Net.Query.SendMsgAcquire mPointVar' $
-        Net.Query.ClientStAcquiring
-        { Net.Query.recvMsgAcquired =
-          pure $ Net.Query.SendMsgQuery (QueryEraHistory CardanoModeIsMultiEra) $
-            Net.Query.ClientStQuerying
-            { Net.Query.recvMsgResult = \result1 -> do
-              pure $ Net.Query.SendMsgQuery QuerySystemStart $
-                Net.Query.ClientStQuerying
-                { Net.Query.recvMsgResult = \result2 -> do
-                  atomically $ putTMVar resultVar' (Right (result1, result2))
-
-                  pure $ Net.Query.SendMsgRelease $ pure $ Net.Query.SendMsgDone ()
-                }
-            }
-        , Net.Query.recvMsgFailure = \failure -> do
-            atomically $ putTMVar resultVar' (Left failure)
-            pure $ Net.Query.SendMsgDone ()
-        }
 
 
 -- ----------------------------------------------------------------------------
@@ -1502,38 +1429,3 @@ readFileTxMetadata _ (MetadataFileCBOR fp) = do
     firstExceptT (ShelleyTxCmdMetaValidationError fp) $ hoistEither $ do
         validateTxMetadata txMetadata
         return txMetadata
-
-executeQuery
-  :: forall result era mode. CardanoEra era
-  -> ConsensusModeParams mode
-  -> LocalNodeConnectInfo mode
-  -> QueryInMode mode (Either EraMismatch result)
-  -> ExceptT ShelleyTxCmdError IO result
-executeQuery era cModeP localNodeConnInfo q = do
-  eraInMode <- calcEraInMode era $ consensusModeOnly cModeP
-  case eraInMode of
-    ByronEraInByronMode -> left ShelleyTxCmdByronEraQuery
-    _ -> liftIO execQuery >>= queryResult
- where
-   execQuery :: IO (Either AcquireFailure (Either EraMismatch result))
-   execQuery = queryNodeLocalState localNodeConnInfo Nothing q
-
-
-queryResult
-  :: Either AcquireFailure (Either EraMismatch a)
-  -> ExceptT ShelleyTxCmdError IO a
-queryResult eAcq =
-  case eAcq of
-    Left acqFailure -> left $ ShelleyTxCmdAcquireFailure acqFailure
-    Right eResult ->
-      case eResult of
-        Left err -> left . ShelleyTxCmdLocalStateQueryError $ EraMismatchError err
-        Right result -> return result
-
-calcEraInMode
-  :: CardanoEra era
-  -> ConsensusMode mode
-  -> ExceptT ShelleyTxCmdError IO (EraInMode era mode)
-calcEraInMode era mode=
-  hoistMaybe (ShelleyTxCmdEraConsensusModeMismatchQuery (AnyConsensusMode mode) (anyCardanoEra era))
-                   $ toEraInMode era mode