diff --git a/cardano-cli/src/Cardano/CLI/Shelley/Orphans.hs b/cardano-cli/src/Cardano/CLI/Shelley/Orphans.hs index 3a787ee750d..bedb93da107 100644 --- a/cardano-cli/src/Cardano/CLI/Shelley/Orphans.hs +++ b/cardano-cli/src/Cardano/CLI/Shelley/Orphans.hs @@ -10,41 +10,42 @@ {-# LANGUAGE UndecidableInstances #-} {-# OPTIONS_GHC -Wno-orphans #-} +{-# LANGUAGE LambdaCase #-} 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 Cardano.Ledger.AuxiliaryData (AuxiliaryDataHash (..)) +import Cardano.Ledger.PoolDistr (PoolDistr (..)) +import Cardano.Ledger.TxIn (TxId (..)) +import Cardano.Prelude (Bool(True), Category((.))) +import Cardano.Protocol.TPraos.BHeader (HashHeader (..)) +import Data.Aeson (FromJSON(..), KeyValue((.=)), ToJSON(..), ToJSONKey) import Ouroboros.Consensus.Byron.Ledger.Block (ByronHash (..)) import Ouroboros.Consensus.HardFork.Combinator (OneEraHash (..)) +import Ouroboros.Consensus.Protocol.Praos (PraosState) +import Ouroboros.Consensus.Protocol.TPraos (TPraosState) 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.Crypto as CC (Crypto) -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.Crypto as CC (Crypto) +import qualified Cardano.Ledger.Mary.Value as Ledger.Mary import qualified Cardano.Ledger.Shelley.EpochBoundary as Ledger -import Cardano.Ledger.TxIn (TxId (..)) +import qualified Cardano.Ledger.Shelley.PoolRank as Ledger +import qualified Cardano.Protocol.TPraos.API as Ledger 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 qualified Data.Aeson as J +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 qualified Ouroboros.Consensus.Protocol.Praos as Consensus +import qualified Ouroboros.Consensus.Protocol.TPraos as Consensus instance ToJSON (OneEraHash xs) where toJSON = toJSON @@ -58,9 +59,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 = J.object [ "genesis" .= True ] toJSON (Tip slotNo headerHash blockNo) = - object + J.object [ "slotNo" .= slotNo , "headerHash" .= headerHash , "blockNo" .= blockNo @@ -94,3 +95,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 = J.object + [ "lastSlot" .= Consensus.tpraosStateLastSlot s + , "chainDepState" .= Consensus.tpraosStateChainDepState s + ] + +instance ToJSON (PraosState StandardCrypto) where + toJSON s = J.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 -> J.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 index fcb402adb1a..27250208252 100644 --- 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,24 @@ eligibleLeaderSlotsConstaints ShelleyBasedEraMary f = f eligibleLeaderSlotsConstaints ShelleyBasedEraAlonzo f = f eligibleLeaderSlotsConstaints ShelleyBasedEraBabbage f = f +eligibleWriteProtocolStateConstaints + :: ShelleyLedgerEra era ~ ledgerera + => ShelleyBasedEra era + -> (( ShelleyLedgerEra era ~ ledgerera + , Ledger.Crypto ledgerera ~ StandardCrypto + , Consensus.PraosProtocolSupportsNode (ConsensusProtocol era) + , Era.Era ledgerera + , 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