Merge #4102

4102: Fix query protocol-state r=newhoggy a=newhoggy Fixes one of the commands in #3883 Co-authored-by: John Ky <[email protected]>
IntersectMBO · Jun 27, 2022 · df183aa · df183aa
2 parents 6eb466a + 4590123
commit df183aa
Show file tree

Hide file tree

Showing 2 changed files with 78 additions and 36 deletions.
diff --git a/cardano-cli/src/Cardano/CLI/Shelley/Orphans.hs b/cardano-cli/src/Cardano/CLI/Shelley/Orphans.hs
@@ -4,6 +4,7 @@
 {-# LANGUAGE FlexibleContexts #-}
 {-# LANGUAGE FlexibleInstances #-}
 {-# LANGUAGE GeneralizedNewtypeDeriving #-}
+{-# LANGUAGE LambdaCase #-}
 {-# LANGUAGE OverloadedStrings #-}
 {-# LANGUAGE StandaloneDeriving #-}
 {-# LANGUAGE TypeFamilies #-}
@@ -13,38 +14,37 @@
 
 module Cardano.CLI.Shelley.Orphans () where
 
-import           Cardano.Prelude
-
-import           Control.SetAlgebra as SetAlgebra
-import           Data.Aeson
-import qualified Data.ByteString.Base16 as Base16
-import qualified Data.ByteString.Short as SBS
-import qualified Data.Text.Encoding as Text
-
 import           Cardano.Api.Orphans ()
-
-import           Ouroboros.Consensus.Byron.Ledger.Block (ByronHash (..))
-import           Ouroboros.Consensus.HardFork.Combinator (OneEraHash (..))
-import           Ouroboros.Consensus.Shelley.Eras (StandardCrypto)
-import           Ouroboros.Consensus.Shelley.Ledger.Block (ShelleyHash (..))
-import           Ouroboros.Network.Block (BlockNo (..), HeaderHash, Tip (..))
-
 import           Cardano.Ledger.AuxiliaryData (AuxiliaryDataHash (..))
+import qualified Cardano.Ledger.Credential as Ledger
 import qualified Cardano.Ledger.Crypto as CC (Crypto)
+import qualified Cardano.Ledger.Mary.Value as Ledger.Mary
 import           Cardano.Ledger.PoolDistr (PoolDistr (..))
-import           Cardano.Protocol.TPraos.BHeader (HashHeader (..))
-
-import qualified Cardano.Ledger.Credential as Ledger
-import qualified Cardano.Protocol.TPraos.API as Ledger
 import qualified Cardano.Ledger.Shelley.EpochBoundary as Ledger
+import qualified Cardano.Ledger.Shelley.PoolRank as Ledger
 import           Cardano.Ledger.TxIn (TxId (..))
+import           Cardano.Prelude (Bool(True), Category((.)))
+import qualified Cardano.Protocol.TPraos.API as Ledger
+import           Cardano.Protocol.TPraos.BHeader (HashHeader (..))
 import qualified Cardano.Protocol.TPraos.Rules.Prtcl as Ledger
 import qualified Cardano.Protocol.TPraos.Rules.Tickn as Ledger
-
-import qualified Cardano.Ledger.Mary.Value as Ledger.Mary
-
+import qualified Cardano.Slotting.Slot as Cardano
+import qualified Control.SetAlgebra as SetAlgebra (BiMap, forwards)
+import           Data.Aeson (FromJSON(..), KeyValue((.=)), ToJSON(..), ToJSONKey)
+import qualified Data.Aeson as Aeson
+import qualified Data.ByteString.Base16 as Base16
+import qualified Data.ByteString.Short as SBS
+import qualified Data.Text.Encoding as Text
 import qualified Data.VMap as VMap
-import qualified Cardano.Ledger.Shelley.PoolRank as Ledger
+import           Ouroboros.Consensus.Byron.Ledger.Block (ByronHash (..))
+import           Ouroboros.Consensus.HardFork.Combinator (OneEraHash (..))
+import           Ouroboros.Consensus.Protocol.Praos (PraosState)
+import qualified Ouroboros.Consensus.Protocol.Praos as Consensus
+import           Ouroboros.Consensus.Protocol.TPraos (TPraosState)
+import qualified Ouroboros.Consensus.Protocol.TPraos as Consensus
+import           Ouroboros.Consensus.Shelley.Eras (StandardCrypto)
+import           Ouroboros.Consensus.Shelley.Ledger.Block (ShelleyHash (..))
+import           Ouroboros.Network.Block (BlockNo (..), HeaderHash, Tip (..))
 
 instance ToJSON (OneEraHash xs) where
   toJSON = toJSON
@@ -58,9 +58,9 @@ deriving newtype instance ToJSON ByronHash
 -- This instance is temporarily duplicated in cardano-config
 
 instance ToJSON (HeaderHash blk) => ToJSON (Tip blk) where
-  toJSON TipGenesis = object [ "genesis" .= True ]
+  toJSON TipGenesis = Aeson.object [ "genesis" .= True ]
   toJSON (Tip slotNo headerHash blockNo) =
-    object
+    Aeson.object
       [ "slotNo"     .= slotNo
       , "headerHash" .= headerHash
       , "blockNo"    .= blockNo
@@ -94,3 +94,26 @@ deriving newtype  instance ToJSON    (Ledger.Mary.PolicyID StandardCrypto)
 
 instance (ToJSONKey k, ToJSON v) => ToJSON (SetAlgebra.BiMap v k v) where
   toJSON = toJSON . SetAlgebra.forwards -- to normal Map
+
+instance ToJSON (TPraosState StandardCrypto) where
+  toJSON s = Aeson.object
+    [ "lastSlot" .= Consensus.tpraosStateLastSlot s
+    , "chainDepState" .= Consensus.tpraosStateChainDepState s
+    ]
+
+instance ToJSON (PraosState StandardCrypto) where
+  toJSON s = Aeson.object
+    [ "lastSlot" .= Consensus.praosStateLastSlot s
+    , "oCertCounters" .= Consensus.praosStateOCertCounters s
+    , "evolvingNonce" .= Consensus.praosStateEvolvingNonce s
+    , "candidateNonce" .= Consensus.praosStateCandidateNonce s
+    , "epochNonce" .= Consensus.praosStateEpochNonce s
+    , "labNonce" .= Consensus.praosStateLabNonce s
+    , "lastEpochBlockNonce" .= Consensus.praosStateLastEpochBlockNonce s
+    ]
+
+
+instance ToJSON (Cardano.WithOrigin Cardano.SlotNo) where
+  toJSON = \case
+    Cardano.Origin -> Aeson.String "origin"
+    Cardano.At (Cardano.SlotNo n) -> toJSON n
diff --git a/cardano-cli/src/Cardano/CLI/Shelley/Run/Query.hs b/cardano-cli/src/Cardano/CLI/Shelley/Run/Query.hs
@@ -676,7 +676,7 @@ runQueryProtocolState
   -> Maybe OutputFile
   -> ExceptT ShelleyQueryCmdError IO ()
 runQueryProtocolState (AnyConsensusModeParams cModeParams)
-                      network _mOutFile = do
+                      network mOutFile = do
   SocketPath sockPath <- firstExceptT ShelleyQueryCmdEnvVarSocketErr readEnvSocketPath
   let localNodeConnInfo = LocalNodeConnectInfo cModeParams network sockPath
 
@@ -689,12 +689,16 @@ runQueryProtocolState (AnyConsensusModeParams cModeParams)
       let qInMode = QueryInEra eInMode
                       . QueryInShelleyBasedEra sbe
                       $ QueryProtocolState
-      _result <- executeQuery
+      result <- executeQuery
                   era
                   cModeParams
                   localNodeConnInfo
                   qInMode
-      panic "currentlyBroken: runQueryProtocolState writeProtocolState mOutFile result"
+
+      case cMode of
+        CardanoMode -> eligibleWriteProtocolStateConstaints sbe $ writeProtocolState mOutFile result
+        mode -> left . ShelleyQueryCmdUnsupportedMode $ AnyConsensusMode mode
+
     Nothing -> left $ ShelleyQueryCmdEraConsensusModeMismatch (AnyConsensusMode cMode) anyE
 
 -- | Query the current delegations and reward accounts, filtered by a given
@@ -853,16 +857,18 @@ writePoolParams (StakePoolKeyHash hk) qState =
 
       liftIO . LBS.putStrLn $ encodePretty $ Params poolParams fPoolParams retiring
 
-_writeProtocolState :: FromCBOR (Consensus.ChainDepState (ConsensusProtocol era))
-                   => ToJSON (Consensus.ChainDepState (ConsensusProtocol era))
-                   => Maybe OutputFile
-                   -> ProtocolState era
-                   -> ExceptT ShelleyQueryCmdError IO ()
-_writeProtocolState mOutFile ps@(ProtocolState pstate) =
+writeProtocolState ::
+  ( FromCBOR (Consensus.ChainDepState (ConsensusProtocol era))
+  , ToJSON (Consensus.ChainDepState (ConsensusProtocol era))
+  )
+  => Maybe OutputFile
+  -> ProtocolState era
+  -> ExceptT ShelleyQueryCmdError IO ()
+writeProtocolState mOutFile ps@(ProtocolState pstate) =
   case mOutFile of
     Nothing -> case decodeProtocolState ps of
-                 Left (bs, _) -> firstExceptT ShelleyQueryCmdHelpersError $ pPrintCBOR bs
-                 Right chainDepstate -> liftIO . LBS.putStrLn $ encodePretty chainDepstate
+      Left (bs, _) -> firstExceptT ShelleyQueryCmdHelpersError $ pPrintCBOR bs
+      Right chainDepstate -> liftIO . LBS.putStrLn $ encodePretty chainDepstate
     Just (OutputFile fpath) ->
       handleIOExceptT (ShelleyQueryCmdWriteFileError . FileIOError fpath)
         . LBS.writeFile fpath $ unSerialised pstate
@@ -1365,6 +1371,19 @@ eligibleLeaderSlotsConstaints ShelleyBasedEraMary    f = f
 eligibleLeaderSlotsConstaints ShelleyBasedEraAlonzo  f = f
 eligibleLeaderSlotsConstaints ShelleyBasedEraBabbage f = f
 
+eligibleWriteProtocolStateConstaints
+  :: ShelleyBasedEra era
+  -> (( FromCBOR (Consensus.ChainDepState (ConsensusProtocol era))
+      , ToJSON (Consensus.ChainDepState (ConsensusProtocol era))
+      ) => a
+     )
+  -> a
+eligibleWriteProtocolStateConstaints ShelleyBasedEraShelley f = f
+eligibleWriteProtocolStateConstaints ShelleyBasedEraAllegra f = f
+eligibleWriteProtocolStateConstaints ShelleyBasedEraMary    f = f
+eligibleWriteProtocolStateConstaints ShelleyBasedEraAlonzo  f = f
+eligibleWriteProtocolStateConstaints ShelleyBasedEraBabbage f = f
+
 -- Required instances
 -- instance FromCBOR (TPraosState StandardCrypto) where
 -- instance FromCBOR (Praos.PraosState StandardCrypto) where