Merge pull request #324 from Concordium/consensus-detailed-status

Support for GetConsensusDetailedStatus.

ChangeLog.md

@@ -3,6 +3,9 @@
 ## Unreleased
 
 - Support node version 8 and protocol version 8.
+- Add command `consensus detailed-status` for getting detailed consensus status (from protocol
+  version 6).
+- Add `raw GetConsensusDetailedStatus` that presents the detailed consensus status as JSON.
 
 ## 7.0.1
 

concordium-client.cabal

@@ -47,6 +47,7 @@ library
       Concordium.Client.Runner.Helper
       Concordium.Client.RWLock
       Concordium.Client.Types.Account
+      Concordium.Client.Types.ConsensusStatus
       Concordium.Client.Types.Contract.BuildInfo
       Concordium.Client.Types.Contract.Info
       Concordium.Client.Types.Contract.Parameter

src/Concordium/Client/Commands.hs

@@ -439,6 +439,9 @@ data ConsensusCmd
           ccuKeys :: ![FilePath],
           ccuInteractionOpts :: !InteractionOpts
         }
+    | ConsensusDetailedStatus
+        { cdsGenesisIndex :: !(Maybe GenesisIndex)
+        }
     deriving (Show)
 
 data BlockCmd = BlockShow
@@ -1560,6 +1563,7 @@ consensusCmds =
             ( ConsensusCmd
                 <$> ( hsubparser
                         ( consensusStatusCmd
+                            <> consensusDetailedStatusCmd
                             <> consensusShowChainParametersCmd
                             <> consensusShowParametersCmd
                         )
@@ -1579,6 +1583,17 @@ consensusStatusCmd =
             (progDesc "List various parameters related to the current state of the consensus protocol.")
         )
 
+consensusDetailedStatusCmd :: Mod CommandFields ConsensusCmd
+consensusDetailedStatusCmd =
+    command
+        "detailed-status"
+        ( info
+            ( ConsensusDetailedStatus
+                <$> optional (option auto (long "genesis-index" <> metavar "GENINDEX" <> help "Genesis index (defaults to latest)"))
+            )
+            (progDesc "Show detailed consensus status information.")
+        )
+
 consensusShowParametersCmd :: Mod CommandFields ConsensusCmd
 consensusShowParametersCmd =
     command

src/Concordium/Client/GRPC2.hs

@@ -78,6 +78,8 @@ import qualified Concordium.Types.Transactions as Transactions
 import qualified Concordium.Types.Updates as Updates
 import qualified Concordium.Wasm as Wasm
 
+import Concordium.Client.Types.ConsensusStatus
+import qualified Concordium.Crypto.BlockSignature as BlockSignature
 import qualified Proto.V2.Concordium.Service as CS
 import qualified Proto.V2.Concordium.Types as Proto
 import qualified Proto.V2.Concordium.Types as ProtoFields
@@ -2882,6 +2884,186 @@ instance FromProto Proto.WinningBaker where
         let wbPresent = winningBaker ^. ProtoFields.present
         return WinningBaker{..}
 
+instance FromProto Proto.FinalizerIndex where
+    type Output Proto.FinalizerIndex = FinalizerIndex
+    fromProto fi = return . FinalizerIndex $ fi ^. ProtoFields.value
+
+instance FromProto Proto.QuorumMessage where
+    type Output Proto.QuorumMessage = QuorumMessage
+    fromProto qm = do
+        qmSignature <- fromProto (qm ^. ProtoFields.signature)
+        qmBlock <- fromProto (qm ^. ProtoFields.block)
+        qmFinalizer <- fromProto (qm ^. ProtoFields.finalizer)
+        qmRound <- fromProto (qm ^. ProtoFields.round)
+        qmEpoch <- fromProto (qm ^. ProtoFields.epoch)
+        return QuorumMessage{..}
+
+instance FromProto Proto.RawQuorumCertificate where
+    type Output Proto.RawQuorumCertificate = QuorumCertificate
+    fromProto qc = do
+        qcBlockHash <- fromProto (qc ^. ProtoFields.blockHash)
+        qcRound <- fromProto (qc ^. ProtoFields.round)
+        qcEpoch <- fromProto (qc ^. ProtoFields.epoch)
+        qcAggregateSignature <- fromProto (qc ^. ProtoFields.aggregateSignature)
+        qcSignatories <- mapM fromProto (qc ^. ProtoFields.signatories)
+        return QuorumCertificate{..}
+
+instance FromProto Proto.BlockSignature where
+    type Output Proto.BlockSignature = BlockSignature.Signature
+    fromProto = deMkSerialize
+
+instance FromProto Proto.TimeoutMessage where
+    type Output Proto.TimeoutMessage = TimeoutMessage
+    fromProto tm = do
+        tmFinalizer <- fromProto (tm ^. ProtoFields.finalizer)
+        tmRound <- fromProto (tm ^. ProtoFields.round)
+        tmEpoch <- fromProto (tm ^. ProtoFields.epoch)
+        tmQuorumCertificate <- fromProto (tm ^. ProtoFields.quorumCertificate)
+        tmSignature <- fromProto (tm ^. ProtoFields.signature)
+        tmMessageSignature <- fromProto (tm ^. ProtoFields.messageSignature)
+        return TimeoutMessage{..}
+
+instance FromProto Proto.RawFinalizerRound where
+    type Output Proto.RawFinalizerRound = FinalizerRound
+    fromProto fr = do
+        frRound <- fromProto (fr ^. ProtoFields.round)
+        frFinalizers <- mapM fromProto (fr ^. ProtoFields.finalizers)
+        return FinalizerRound{..}
+
+instance FromProto Proto.RawTimeoutCertificate where
+    type Output Proto.RawTimeoutCertificate = TimeoutCertificate
+    fromProto tc = do
+        tcRound <- fromProto (tc ^. ProtoFields.round)
+        tcMinEpoch <- fromProto (tc ^. ProtoFields.minEpoch)
+        tcQcRoundsFirstEpoch <- mapM fromProto (tc ^. ProtoFields.qcRoundsFirstEpoch)
+        tcQcRoundsSecondEpoch <- mapM fromProto (tc ^. ProtoFields.qcRoundsSecondEpoch)
+        tcAggregateSignature <- fromProto (tc ^. ProtoFields.aggregateSignature)
+        return TimeoutCertificate{..}
+
+instance FromProto Proto.PersistentRoundStatus where
+    type Output Proto.PersistentRoundStatus = PersistentRoundStatus
+    fromProto prs = do
+        prsLastSignedQuorumMessage <- mapM fromProto (prs ^. ProtoFields.maybe'lastSignedQuorumMessage)
+        prsLastSignedTimeoutMessage <- mapM fromProto (prs ^. ProtoFields.maybe'lastSignedTimeoutMessage)
+        prsLastBakedRound <- fromProto (prs ^. ProtoFields.lastBakedRound)
+        prsLatestTimeout <- mapM fromProto (prs ^. ProtoFields.maybe'latestTimeout)
+        return PersistentRoundStatus{..}
+
+instance FromProto Proto.RoundTimeout where
+    type Output Proto.RoundTimeout = RoundTimeout
+    fromProto rt = do
+        rtTimeoutCertificate <- fromProto (rt ^. ProtoFields.timeoutCertificate)
+        rtQuorumCertificate <- fromProto (rt ^. ProtoFields.quorumCertificate)
+        return RoundTimeout{..}
+
+instance FromProto Proto.RawFinalizationEntry where
+    type Output Proto.RawFinalizationEntry = FinalizationEntry
+    fromProto fe = do
+        feFinalizedQC <- fromProto (fe ^. ProtoFields.finalizedQc)
+        feSuccessorQC <- fromProto (fe ^. ProtoFields.successorQc)
+        feSuccessorProof <- fromProto (fe ^. ProtoFields.successorProof)
+        return FinalizationEntry{..}
+
+instance FromProto Proto.RoundStatus where
+    type Output Proto.RoundStatus = RoundStatus
+    fromProto rs = do
+        rsCurrentRound <- fromProto (rs ^. ProtoFields.currentRound)
+        rsHighestCertifiedBlock <- fromProto (rs ^. ProtoFields.highestCertifiedBlock)
+        rsPreviousRoundTimeout <- mapM fromProto (rs ^. ProtoFields.maybe'previousRoundTimeout)
+        let rsRoundEligibleToBake = rs ^. ProtoFields.roundEligibleToBake
+        rsCurrentEpoch <- fromProto (rs ^. ProtoFields.currentEpoch)
+        rsLastEpochFinalizationEntry <- mapM fromProto (rs ^. ProtoFields.maybe'lastEpochFinalizationEntry)
+        rsCurrentTimeout <- fromProto (rs ^. ProtoFields.currentTimeout)
+        return RoundStatus{..}
+
+instance FromProto Proto.BlockTableSummary where
+    type Output Proto.BlockTableSummary = BlockTableSummary
+    fromProto bts = do
+        let btsDeadBlockCacheSize = bts ^. ProtoFields.deadBlockCacheSize
+        btsLiveBlocks <- mapM fromProto (bts ^. ProtoFields.liveBlocks)
+        return BlockTableSummary{..}
+
+instance FromProto Proto.RoundExistingBlock where
+    type Output Proto.RoundExistingBlock = RoundExistingBlock
+    fromProto reb = do
+        rebRound <- fromProto (reb ^. ProtoFields.round)
+        rebBaker <- fromProto (reb ^. ProtoFields.baker)
+        rebBlock <- fromProto (reb ^. ProtoFields.block)
+        return RoundExistingBlock{..}
+
+instance FromProto Proto.RoundExistingQC where
+    type Output Proto.RoundExistingQC = RoundExistingQC
+    fromProto req = do
+        reqRound <- fromProto (req ^. ProtoFields.round)
+        reqEpoch <- fromProto (req ^. ProtoFields.epoch)
+        return RoundExistingQC{..}
+
+instance FromProto Proto.FullBakerInfo where
+    type Output Proto.FullBakerInfo = FullBakerInfo
+    fromProto fbi = do
+        fbiBakerIdentity <- fromProto (fbi ^. ProtoFields.bakerIdentity)
+        fbiElectionVerifyKey <- fromProto (fbi ^. ProtoFields.electionVerifyKey)
+        fbiSignatureVerifyKey <- fromProto (fbi ^. ProtoFields.signatureVerifyKey)
+        fbiAggregationVerifyKey <- fromProto (fbi ^. ProtoFields.aggregationVerifyKey)
+        fbiStake <- fromProto (fbi ^. ProtoFields.stake)
+        return FullBakerInfo{..}
+
+instance FromProto Proto.FinalizationCommitteeHash where
+    type Output Proto.FinalizationCommitteeHash = Hash
+    fromProto = deMkSerialize
+
+instance FromProto Proto.BakersAndFinalizers where
+    type Output Proto.BakersAndFinalizers = BakersAndFinalizers
+    fromProto baf = do
+        bafBakers <- mapM fromProto (baf ^. ProtoFields.bakers)
+        bafFinalizers <- mapM fromProto (baf ^. ProtoFields.finalizers)
+        bafBakerTotalStake <- fromProto (baf ^. ProtoFields.bakerTotalStake)
+        bafFinalizerTotalStake <- fromProto (baf ^. ProtoFields.finalizerTotalStake)
+        bafFinalizationCommitteeHash <- fromProto (baf ^. ProtoFields.finalizationCommitteeHash)
+        return BakersAndFinalizers{..}
+
+instance FromProto Proto.EpochBakers where
+    type Output Proto.EpochBakers = EpochBakers
+    fromProto epochBakers = do
+        ebPreviousEpochBakers <- fromProto (epochBakers ^. ProtoFields.previousEpochBakers)
+        ebCurrentEpochBakers <- mapM fromProto (epochBakers ^. ProtoFields.maybe'currentEpochBakers)
+        ebNextEpochBakers <- mapM fromProto (epochBakers ^. ProtoFields.maybe'nextEpochBakers)
+        ebNextPayday <- fromProto (epochBakers ^. ProtoFields.nextPayday)
+        return EpochBakers{..}
+
+instance FromProto Proto.TimeoutMessages where
+    type Output Proto.TimeoutMessages = TimeoutMessages
+    fromProto timeoutMessages = do
+        tmFirstEpoch <- fromProto (timeoutMessages ^. ProtoFields.firstEpoch)
+        tmFirstEpochTimeouts <- mapM fromProto (timeoutMessages ^. ProtoFields.firstEpochTimeouts)
+        tmSecondEpochTimeouts <- mapM fromProto (timeoutMessages ^. ProtoFields.secondEpochTimeouts)
+        return TimeoutMessages{..}
+
+instance FromProto Proto.BranchBlocks where
+    type Output Proto.BranchBlocks = [BlockHash]
+    fromProto branchBlocks = mapM fromProto (branchBlocks ^. ProtoFields.blocksAtBranchHeight)
+
+instance FromProto Proto.ConsensusDetailedStatus where
+    type Output Proto.ConsensusDetailedStatus = ConsensusDetailedStatus
+    fromProto consensusDetailedStatus = do
+        cdsGenesisBlock <- fromProto (consensusDetailedStatus ^. ProtoFields.genesisBlock)
+        cdsPersistentRoundStatus <- fromProto (consensusDetailedStatus ^. ProtoFields.persistentRoundStatus)
+        cdsRoundStatus <- fromProto (consensusDetailedStatus ^. ProtoFields.roundStatus)
+        let cdsNonFinalizedTransactionCount = consensusDetailedStatus ^. ProtoFields.nonFinalizedTransactionCount
+        let cdsTransactionTablePurgeCounter = consensusDetailedStatus ^. ProtoFields.transactionTablePurgeCounter
+        cdsBlockTable <- fromProto (consensusDetailedStatus ^. ProtoFields.blockTable)
+        cdsBranches <- mapM fromProto (consensusDetailedStatus ^. ProtoFields.branches)
+        cdsRoundExistingBlocks <- mapM fromProto (consensusDetailedStatus ^. ProtoFields.roundExistingBlocks)
+        cdsRoundExistingQCs <- mapM fromProto (consensusDetailedStatus ^. ProtoFields.roundExistingQcs)
+        cdsGenesisBlockHeight <- fromProto (consensusDetailedStatus ^. ProtoFields.genesisBlockHeight)
+        cdsLastFinalizedBlock <- fromProto (consensusDetailedStatus ^. ProtoFields.lastFinalizedBlock)
+        cdsLastFinalizedBlockHeight <- fromProto (consensusDetailedStatus ^. ProtoFields.lastFinalizedBlockHeight)
+        cdsLatestFinalizationEntry <- mapM fromProto (consensusDetailedStatus ^. ProtoFields.maybe'latestFinalizationEntry)
+        cdsEpochBakers <- fromProto (consensusDetailedStatus ^. ProtoFields.epochBakers)
+        cdsTimeoutMessages <- mapM fromProto (consensusDetailedStatus ^. ProtoFields.maybe'timeoutMessages)
+        cdsTerminalBlock <- mapM fromProto (consensusDetailedStatus ^. ProtoFields.maybe'terminalBlock)
+        return ConsensusDetailedStatus{..}
+
 type LoggerMethod = Text -> IO ()
 
 data GrpcConfig = GrpcConfig
@@ -3327,6 +3509,12 @@ getBlockInfo bhInput = withUnary (call @"getBlockInfo") msg (fmap fromProto)
 getConsensusInfo :: (MonadIO m) => ClientMonad m (GRPCResult (FromProtoResult ConsensusStatus))
 getConsensusInfo = withUnary (call @"getConsensusInfo") defMessage (fmap fromProto)
 
+-- | Get detailed consensus state information (for consensus version 1).
+getConsensusDetailedStatus :: (MonadIO m) => Maybe GenesisIndex -> ClientMonad m (GRPCResult (FromProtoResult ConsensusDetailedStatus))
+getConsensusDetailedStatus mGenesisIndex = withUnary (call @"getConsensusDetailedStatus") msg (fmap fromProto)
+  where
+    msg = defMessage & ProtoFields.maybe'genesisIndex .~ fmap toProto mGenesisIndex
+
 -- | Get the source of a smart contract module.
 getModuleSource :: (MonadIO m) => ModuleRef -> BlockHashInput -> ClientMonad m (GRPCResult (FromProtoResult Wasm.WasmModule))
 getModuleSource modRef bhInput = withUnary (call @"getModuleSource") msg (fmap fromProto)

src/Concordium/Client/LegacyCommands.hs

@@ -42,6 +42,8 @@ data LegacyCmd
         }
     | -- | Queries the gRPC server for the consensus information
       GetConsensusInfo
+    | -- | Queries the gRPC server for detailed consensus status
+      GetConsensusDetailedStatus {legacyFromGenesisIndex :: !(Maybe GenesisIndex)}
     | -- | Queries the gRPC server for the information of a specific block
       GetBlockInfo
         { legacyEvery :: !Bool,
@@ -174,6 +176,7 @@ legacyProgramOptions =
     hsubparser
         ( getTransactionStatusCommand
             <> getConsensusInfoCommand
+            <> getConsensusDetailedStatusCommand
             <> getBlockInfoCommand
             <> getBlockPendingUpdatesCommand
             <> getBlockTransactionEventsCommand
@@ -265,6 +268,17 @@ getConsensusInfoCommand =
             (progDesc "Query the gRPC server for the consensus information.")
         )
 
+getConsensusDetailedStatusCommand :: Mod CommandFields LegacyCmd
+getConsensusDetailedStatusCommand =
+    command
+        "GetConsensusDetailedStatus"
+        ( info
+            ( GetConsensusDetailedStatus
+                <$> optional (option auto (long "genesis-index" <> metavar "GENINDEX" <> help "Consensus genesis index"))
+            )
+            (progDesc "Query the gRPC server for the detailed consensus status. If the genesis index is not specified, the current one is used.")
+        )
+
 getBlockInfoCommand :: Mod CommandFields LegacyCmd
 getBlockInfoCommand =
     command