Skip to content

Commit df183aa

Browse files
iohk-bors[bot]newhoggy
iohk-bors[bot]
and
newhoggy
authored
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]>
2 parents 6eb466a + 4590123 commit df183aa

File tree

2 files changed

+78
-36
lines changed

2 files changed

+78
-36
lines changed

‎cardano-cli/src/Cardano/CLI/Shelley/Orphans.hs

+48-25
Original file line numberDiff line numberDiff line change
@@ -4,6 +4,7 @@
44
{-# LANGUAGE FlexibleContexts #-}
55
{-# LANGUAGE FlexibleInstances #-}
66
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
7+
{-# LANGUAGE LambdaCase #-}
78
{-# LANGUAGE OverloadedStrings #-}
89
{-# LANGUAGE StandaloneDeriving #-}
910
{-# LANGUAGE TypeFamilies #-}
@@ -13,38 +14,37 @@
1314

1415
module Cardano.CLI.Shelley.Orphans () where
1516

16-
import Cardano.Prelude
17-
18-
import Control.SetAlgebra as SetAlgebra
19-
import Data.Aeson
20-
import qualified Data.ByteString.Base16 as Base16
21-
import qualified Data.ByteString.Short as SBS
22-
import qualified Data.Text.Encoding as Text
23-
2417
import Cardano.Api.Orphans ()
25-
26-
import Ouroboros.Consensus.Byron.Ledger.Block (ByronHash (..))
27-
import Ouroboros.Consensus.HardFork.Combinator (OneEraHash (..))
28-
import Ouroboros.Consensus.Shelley.Eras (StandardCrypto)
29-
import Ouroboros.Consensus.Shelley.Ledger.Block (ShelleyHash (..))
30-
import Ouroboros.Network.Block (BlockNo (..), HeaderHash, Tip (..))
31-
3218
import Cardano.Ledger.AuxiliaryData (AuxiliaryDataHash (..))
19+
import qualified Cardano.Ledger.Credential as Ledger
3320
import qualified Cardano.Ledger.Crypto as CC (Crypto)
21+
import qualified Cardano.Ledger.Mary.Value as Ledger.Mary
3422
import Cardano.Ledger.PoolDistr (PoolDistr (..))
35-
import Cardano.Protocol.TPraos.BHeader (HashHeader (..))
36-
37-
import qualified Cardano.Ledger.Credential as Ledger
38-
import qualified Cardano.Protocol.TPraos.API as Ledger
3923
import qualified Cardano.Ledger.Shelley.EpochBoundary as Ledger
24+
import qualified Cardano.Ledger.Shelley.PoolRank as Ledger
4025
import Cardano.Ledger.TxIn (TxId (..))
26+
import Cardano.Prelude (Bool(True), Category((.)))
27+
import qualified Cardano.Protocol.TPraos.API as Ledger
28+
import Cardano.Protocol.TPraos.BHeader (HashHeader (..))
4129
import qualified Cardano.Protocol.TPraos.Rules.Prtcl as Ledger
4230
import qualified Cardano.Protocol.TPraos.Rules.Tickn as Ledger
43-
44-
import qualified Cardano.Ledger.Mary.Value as Ledger.Mary
45-
31+
import qualified Cardano.Slotting.Slot as Cardano
32+
import qualified Control.SetAlgebra as SetAlgebra (BiMap, forwards)
33+
import Data.Aeson (FromJSON(..), KeyValue((.=)), ToJSON(..), ToJSONKey)
34+
import qualified Data.Aeson as Aeson
35+
import qualified Data.ByteString.Base16 as Base16
36+
import qualified Data.ByteString.Short as SBS
37+
import qualified Data.Text.Encoding as Text
4638
import qualified Data.VMap as VMap
47-
import qualified Cardano.Ledger.Shelley.PoolRank as Ledger
39+
import Ouroboros.Consensus.Byron.Ledger.Block (ByronHash (..))
40+
import Ouroboros.Consensus.HardFork.Combinator (OneEraHash (..))
41+
import Ouroboros.Consensus.Protocol.Praos (PraosState)
42+
import qualified Ouroboros.Consensus.Protocol.Praos as Consensus
43+
import Ouroboros.Consensus.Protocol.TPraos (TPraosState)
44+
import qualified Ouroboros.Consensus.Protocol.TPraos as Consensus
45+
import Ouroboros.Consensus.Shelley.Eras (StandardCrypto)
46+
import Ouroboros.Consensus.Shelley.Ledger.Block (ShelleyHash (..))
47+
import Ouroboros.Network.Block (BlockNo (..), HeaderHash, Tip (..))
4848

4949
instance ToJSON (OneEraHash xs) where
5050
toJSON = toJSON
@@ -58,9 +58,9 @@ deriving newtype instance ToJSON ByronHash
5858
-- This instance is temporarily duplicated in cardano-config
5959

6060
instance ToJSON (HeaderHash blk) => ToJSON (Tip blk) where
61-
toJSON TipGenesis = object [ "genesis" .= True ]
61+
toJSON TipGenesis = Aeson.object [ "genesis" .= True ]
6262
toJSON (Tip slotNo headerHash blockNo) =
63-
object
63+
Aeson.object
6464
[ "slotNo" .= slotNo
6565
, "headerHash" .= headerHash
6666
, "blockNo" .= blockNo
@@ -94,3 +94,26 @@ deriving newtype instance ToJSON (Ledger.Mary.PolicyID StandardCrypto)
9494

9595
instance (ToJSONKey k, ToJSON v) => ToJSON (SetAlgebra.BiMap v k v) where
9696
toJSON = toJSON . SetAlgebra.forwards -- to normal Map
97+
98+
instance ToJSON (TPraosState StandardCrypto) where
99+
toJSON s = Aeson.object
100+
[ "lastSlot" .= Consensus.tpraosStateLastSlot s
101+
, "chainDepState" .= Consensus.tpraosStateChainDepState s
102+
]
103+
104+
instance ToJSON (PraosState StandardCrypto) where
105+
toJSON s = Aeson.object
106+
[ "lastSlot" .= Consensus.praosStateLastSlot s
107+
, "oCertCounters" .= Consensus.praosStateOCertCounters s
108+
, "evolvingNonce" .= Consensus.praosStateEvolvingNonce s
109+
, "candidateNonce" .= Consensus.praosStateCandidateNonce s
110+
, "epochNonce" .= Consensus.praosStateEpochNonce s
111+
, "labNonce" .= Consensus.praosStateLabNonce s
112+
, "lastEpochBlockNonce" .= Consensus.praosStateLastEpochBlockNonce s
113+
]
114+
115+
116+
instance ToJSON (Cardano.WithOrigin Cardano.SlotNo) where
117+
toJSON = \case
118+
Cardano.Origin -> Aeson.String "origin"
119+
Cardano.At (Cardano.SlotNo n) -> toJSON n

‎cardano-cli/src/Cardano/CLI/Shelley/Run/Query.hs

+30-11
Original file line numberDiff line numberDiff line change
@@ -676,7 +676,7 @@ runQueryProtocolState
676676
-> Maybe OutputFile
677677
-> ExceptT ShelleyQueryCmdError IO ()
678678
runQueryProtocolState (AnyConsensusModeParams cModeParams)
679-
network _mOutFile = do
679+
network mOutFile = do
680680
SocketPath sockPath <- firstExceptT ShelleyQueryCmdEnvVarSocketErr readEnvSocketPath
681681
let localNodeConnInfo = LocalNodeConnectInfo cModeParams network sockPath
682682

@@ -689,12 +689,16 @@ runQueryProtocolState (AnyConsensusModeParams cModeParams)
689689
let qInMode = QueryInEra eInMode
690690
. QueryInShelleyBasedEra sbe
691691
$ QueryProtocolState
692-
_result <- executeQuery
692+
result <- executeQuery
693693
era
694694
cModeParams
695695
localNodeConnInfo
696696
qInMode
697-
panic "currentlyBroken: runQueryProtocolState writeProtocolState mOutFile result"
697+
698+
case cMode of
699+
CardanoMode -> eligibleWriteProtocolStateConstaints sbe $ writeProtocolState mOutFile result
700+
mode -> left . ShelleyQueryCmdUnsupportedMode $ AnyConsensusMode mode
701+
698702
Nothing -> left $ ShelleyQueryCmdEraConsensusModeMismatch (AnyConsensusMode cMode) anyE
699703

700704
-- | Query the current delegations and reward accounts, filtered by a given
@@ -853,16 +857,18 @@ writePoolParams (StakePoolKeyHash hk) qState =
853857

854858
liftIO . LBS.putStrLn $ encodePretty $ Params poolParams fPoolParams retiring
855859

856-
_writeProtocolState :: FromCBOR (Consensus.ChainDepState (ConsensusProtocol era))
857-
=> ToJSON (Consensus.ChainDepState (ConsensusProtocol era))
858-
=> Maybe OutputFile
859-
-> ProtocolState era
860-
-> ExceptT ShelleyQueryCmdError IO ()
861-
_writeProtocolState mOutFile ps@(ProtocolState pstate) =
860+
writeProtocolState ::
861+
( FromCBOR (Consensus.ChainDepState (ConsensusProtocol era))
862+
, ToJSON (Consensus.ChainDepState (ConsensusProtocol era))
863+
)
864+
=> Maybe OutputFile
865+
-> ProtocolState era
866+
-> ExceptT ShelleyQueryCmdError IO ()
867+
writeProtocolState mOutFile ps@(ProtocolState pstate) =
862868
case mOutFile of
863869
Nothing -> case decodeProtocolState ps of
864-
Left (bs, _) -> firstExceptT ShelleyQueryCmdHelpersError $ pPrintCBOR bs
865-
Right chainDepstate -> liftIO . LBS.putStrLn $ encodePretty chainDepstate
870+
Left (bs, _) -> firstExceptT ShelleyQueryCmdHelpersError $ pPrintCBOR bs
871+
Right chainDepstate -> liftIO . LBS.putStrLn $ encodePretty chainDepstate
866872
Just (OutputFile fpath) ->
867873
handleIOExceptT (ShelleyQueryCmdWriteFileError . FileIOError fpath)
868874
. LBS.writeFile fpath $ unSerialised pstate
@@ -1365,6 +1371,19 @@ eligibleLeaderSlotsConstaints ShelleyBasedEraMary f = f
13651371
eligibleLeaderSlotsConstaints ShelleyBasedEraAlonzo f = f
13661372
eligibleLeaderSlotsConstaints ShelleyBasedEraBabbage f = f
13671373

1374+
eligibleWriteProtocolStateConstaints
1375+
:: ShelleyBasedEra era
1376+
-> (( FromCBOR (Consensus.ChainDepState (ConsensusProtocol era))
1377+
, ToJSON (Consensus.ChainDepState (ConsensusProtocol era))
1378+
) => a
1379+
)
1380+
-> a
1381+
eligibleWriteProtocolStateConstaints ShelleyBasedEraShelley f = f
1382+
eligibleWriteProtocolStateConstaints ShelleyBasedEraAllegra f = f
1383+
eligibleWriteProtocolStateConstaints ShelleyBasedEraMary f = f
1384+
eligibleWriteProtocolStateConstaints ShelleyBasedEraAlonzo f = f
1385+
eligibleWriteProtocolStateConstaints ShelleyBasedEraBabbage f = f
1386+
13681387
-- Required instances
13691388
-- instance FromCBOR (TPraosState StandardCrypto) where
13701389
-- instance FromCBOR (Praos.PraosState StandardCrypto) where

0 commit comments

Comments
 (0)