diff --git a/cabal.project b/cabal.project index c21ef07881e..08557ee3bc8 100644 --- a/cabal.project +++ b/cabal.project @@ -263,8 +263,8 @@ source-repository-package source-repository-package type: git location: https://github.com/input-output-hk/ouroboros-network - tag: 23caffe4b434a121eea37af55b22b5888cef98af - --sha256: 0gvds64ybyhmn15p7b6makvlwmh3cjmq2zd0psd1i0vzh7pa4656 + tag: 01549ff9eaa895a9e728dbdd200ec95d5767b9e9 + --sha256: 19jwqvvdxdhcsshq29qlrq3y13d2yj8vc5pxngdl8izkhgcd8p2i subdir: monoidal-synchronisation network-mux diff --git a/cardano-api/src/Cardano/Api/KeysShelley.hs b/cardano-api/src/Cardano/Api/KeysShelley.hs index d4c5b0dd74c..c8c11f931c2 100644 --- a/cardano-api/src/Cardano/Api/KeysShelley.hs +++ b/cardano-api/src/Cardano/Api/KeysShelley.hs @@ -1184,7 +1184,9 @@ instance SerialiseAsBech32 (SigningKey StakePoolKey) where bech32PrefixesPermitted _ = ["pool_sk"] newtype instance Hash StakePoolKey = - StakePoolKeyHash (Shelley.KeyHash Shelley.StakePool StandardCrypto) + StakePoolKeyHash + { unStakePoolKeyHash :: Shelley.KeyHash Shelley.StakePool StandardCrypto + } deriving stock (Eq, Ord) deriving (Show, IsString) via UsingRawBytesHex (Hash StakePoolKey) deriving (ToCBOR, FromCBOR) via UsingRawBytes (Hash StakePoolKey) diff --git a/cardano-api/src/Cardano/Api/Orphans.hs b/cardano-api/src/Cardano/Api/Orphans.hs index e8f9f8b5e6a..d8270a94573 100644 --- a/cardano-api/src/Cardano/Api/Orphans.hs +++ b/cardano-api/src/Cardano/Api/Orphans.hs @@ -4,6 +4,7 @@ {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE GADTs #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE StandaloneDeriving #-} {-# LANGUAGE TypeApplications #-} @@ -16,7 +17,7 @@ module Cardano.Api.Orphans () where import Prelude -import Data.Aeson (FromJSON (..), ToJSON (..), object, (.=)) +import Data.Aeson (FromJSON (..), ToJSON (..), object, pairs, (.=)) import qualified Data.Aeson as Aeson import Data.Aeson.Types (ToJSONKey (..), toJSONKeyText) import Data.BiMap (BiMap (..), Bimap) @@ -56,12 +57,13 @@ import qualified Cardano.Ledger.Shelley.Constraints as Shelley import qualified Cardano.Ledger.Shelley.EpochBoundary as ShelleyEpoch import qualified Cardano.Ledger.Shelley.LedgerState as ShelleyLedger import Cardano.Ledger.Shelley.PParams (PParamsUpdate) -import qualified Cardano.Ledger.Shelley.RewardUpdate as Shelley import qualified Cardano.Ledger.Shelley.Rewards as Shelley +import qualified Cardano.Ledger.Shelley.RewardUpdate as Shelley import qualified Ouroboros.Consensus.Shelley.Eras as Consensus import Cardano.Api.Script import Cardano.Api.SerialiseRaw (serialiseToRawBytesHexText) +import qualified Ouroboros.Consensus.Shelley.Ledger.Query as Consensus -- Orphan instances involved in the JSON output of the API queries. -- We will remove/replace these as we provide more API wrapper types @@ -418,3 +420,40 @@ instance Crypto.Crypto crypto => ToJSON (VMap VB VB (Shelley.KeyHash 'Shelley instance Crypto.Crypto crypto => ToJSON (VMap VB VP (Shelley.Credential 'Shelley.Staking crypto) (Shelley.CompactForm Shelley.Coin)) where toJSON = toJSON . fmap fromCompact . VMap.toMap + +----- + +instance ToJSON (Consensus.StakeSnapshot crypto) where + toJSON + Consensus.StakeSnapshot + { Consensus.sMarkPool + , Consensus.sSetPool + , Consensus.sGoPool + , Consensus.sMarkTotal + , Consensus.sSetTotal + , Consensus.sGoTotal + } = object + [ "poolStakeMark" .= sMarkPool + , "poolStakeSet" .= sSetPool + , "poolStakeGo" .= sGoPool + , "activeStakeMark" .= sMarkTotal + , "activeStakeSet" .= sSetTotal + , "activeStakeGo" .= sGoTotal + ] + + toEncoding + Consensus.StakeSnapshot + { Consensus.sMarkPool + , Consensus.sSetPool + , Consensus.sGoPool + , Consensus.sMarkTotal + , Consensus.sSetTotal + , Consensus.sGoTotal + } = pairs $ mconcat + [ "poolStakeMark" .= sMarkPool + , "poolStakeSet" .= sSetPool + , "poolStakeGo" .= sGoPool + , "activeStakeMark" .= sMarkTotal + , "activeStakeSet" .= sSetTotal + , "activeStakeGo" .= sGoTotal + ] diff --git a/cardano-api/src/Cardano/Api/Query.hs b/cardano-api/src/Cardano/Api/Query.hs index 29f82bba8d7..57bb7c1cc14 100644 --- a/cardano-api/src/Cardano/Api/Query.hs +++ b/cardano-api/src/Cardano/Api/Query.hs @@ -47,6 +47,10 @@ module Cardano.Api.Query ( PoolState(..), decodePoolState, + SerialisedStakeSnapshot(..), + StakeSnapshot(..), + decodeStakeSnapshot, + EraHistory(..), SystemStart(..), @@ -242,6 +246,10 @@ data QueryInShelleyBasedEra era result where :: Maybe (Set PoolId) -> QueryInShelleyBasedEra era (SerialisedPoolState era) + QueryStakeSnapshot + :: PoolId + -> QueryInShelleyBasedEra era (SerialisedStakeSnapshot era) + deriving instance Show (QueryInShelleyBasedEra era result) @@ -377,6 +385,18 @@ decodePoolState -> Either DecoderError (PoolState era) decodePoolState (SerialisedPoolState (Serialised ls)) = PoolState <$> decodeFull ls +newtype SerialisedStakeSnapshot era + = SerialisedStakeSnapshot (Serialised (Consensus.StakeSnapshot (Ledger.Crypto (ShelleyLedgerEra era)))) + +newtype StakeSnapshot era = StakeSnapshot (Consensus.StakeSnapshot (Ledger.Crypto (ShelleyLedgerEra era))) + +decodeStakeSnapshot + :: forall era. () + => FromCBOR (Consensus.StakeSnapshot (Ledger.Crypto (ShelleyLedgerEra era))) + => SerialisedStakeSnapshot era + -> Either DecoderError (StakeSnapshot era) +decodeStakeSnapshot (SerialisedStakeSnapshot (Serialised ls)) = StakeSnapshot <$> decodeFull ls + toShelleyAddrSet :: CardanoEra era -> Set AddressAny -> Set (Shelley.Addr Consensus.StandardCrypto) @@ -545,7 +565,7 @@ toConsensusQueryShelleyBased erainmode (QueryStakePoolParameters poolids) = Some (consensusQueryInEraInMode erainmode (Consensus.GetStakePoolParams poolids')) where poolids' :: Set (Shelley.KeyHash Shelley.StakePool Consensus.StandardCrypto) - poolids' = Set.map (\(StakePoolKeyHash kh) -> kh) poolids + poolids' = Set.map unStakePoolKeyHash poolids toConsensusQueryShelleyBased erainmode QueryDebugLedgerState = Some (consensusQueryInEraInMode erainmode (Consensus.GetCBOR Consensus.DebugNewEpochState)) @@ -557,10 +577,10 @@ toConsensusQueryShelleyBased erainmode QueryCurrentEpochState = Some (consensusQueryInEraInMode erainmode (Consensus.GetCBOR Consensus.DebugEpochState)) toConsensusQueryShelleyBased erainmode (QueryPoolState poolIds) = - Some (consensusQueryInEraInMode erainmode (Consensus.GetCBOR (Consensus.GetPoolState (getPoolIds <$> poolIds)))) - where - getPoolIds :: Set PoolId -> Set (Shelley.KeyHash Shelley.StakePool Consensus.StandardCrypto) - getPoolIds = Set.map (\(StakePoolKeyHash kh) -> kh) + Some (consensusQueryInEraInMode erainmode (Consensus.GetCBOR (Consensus.GetPoolState (Set.map unStakePoolKeyHash <$> poolIds)))) + +toConsensusQueryShelleyBased erainmode (QueryStakeSnapshot poolId) = + Some (consensusQueryInEraInMode erainmode (Consensus.GetCBOR (Consensus.GetStakeSnapshot (unStakePoolKeyHash poolId)))) consensusQueryInEraInMode :: forall era mode erablock modeblock result result' xs. @@ -795,7 +815,12 @@ fromConsensusQueryResultShelleyBased _ QueryCurrentEpochState q' r' = fromConsensusQueryResultShelleyBased _ QueryPoolState{} q' r' = case q' of Consensus.GetCBOR Consensus.GetPoolState {} -> SerialisedPoolState r' - _ -> error "moomoo" + _ -> fromConsensusQueryResultMismatch + +fromConsensusQueryResultShelleyBased _ QueryStakeSnapshot{} q' r' = + case q' of + Consensus.GetCBOR Consensus.GetStakeSnapshot {} -> SerialisedStakeSnapshot r' + _ -> fromConsensusQueryResultMismatch -- | This should /only/ happen if we messed up the mapping in 'toConsensusQuery' -- and 'fromConsensusQueryResult' so they are inconsistent with each other. diff --git a/cardano-api/src/Cardano/Api/Shelley.hs b/cardano-api/src/Cardano/Api/Shelley.hs index 6198d753456..26932b01ea7 100644 --- a/cardano-api/src/Cardano/Api/Shelley.hs +++ b/cardano-api/src/Cardano/Api/Shelley.hs @@ -207,9 +207,15 @@ module Cardano.Api.Shelley CurrentEpochState(..), SerialisedCurrentEpochState(..), decodeCurrentEpochState, + PoolState(..), SerialisedPoolState(..), decodePoolState, + + StakeSnapshot(..), + SerialisedStakeSnapshot(..), + decodeStakeSnapshot, + UTxO(..), -- ** Various calculations diff --git a/cardano-cli/src/Cardano/CLI/Shelley/Run/Query.hs b/cardano-cli/src/Cardano/CLI/Shelley/Run/Query.hs index 5fff6770bd2..9aebdc1ba06 100644 --- a/cardano-cli/src/Cardano/CLI/Shelley/Run/Query.hs +++ b/cardano-cli/src/Cardano/CLI/Shelley/Run/Query.hs @@ -49,8 +49,6 @@ import qualified Cardano.Crypto.Hash.Blake2b as Blake2b import qualified Cardano.Crypto.VRF as Crypto import qualified Cardano.Ledger.Alonzo.PParams as Alonzo import Cardano.Ledger.BaseTypes (Seed, UnitInterval) -import Cardano.Ledger.Coin -import Cardano.Ledger.Compactible import qualified Cardano.Ledger.Core as Core import qualified Cardano.Ledger.Credential as Ledger import qualified Cardano.Ledger.Crypto as Crypto @@ -58,10 +56,8 @@ import qualified Cardano.Ledger.Era as Era import qualified Cardano.Ledger.Era as Ledger import Cardano.Ledger.Keys (KeyHash (..), KeyRole (..)) import Cardano.Ledger.Shelley.Constraints -import Cardano.Ledger.Shelley.EpochBoundary -import Cardano.Ledger.Shelley.LedgerState (DPState (..), - EpochState (esLState, esSnapshots), LedgerState (..), NewEpochState (nesEs), - PState (_fPParams, _pParams, _retiring)) +import Cardano.Ledger.Shelley.LedgerState (EpochState (esLState), LedgerState (..), + NewEpochState (nesEs), PState (_fPParams, _pParams, _retiring)) import qualified Cardano.Ledger.Shelley.LedgerState as SL import qualified Cardano.Ledger.Shelley.PParams as Shelley import Cardano.Ledger.Shelley.Scripts () @@ -93,7 +89,6 @@ import qualified Data.Text.Encoding as Text import qualified Data.Text.IO as T import qualified Data.Text.IO as Text import qualified Data.Vector as Vector -import qualified Data.VMap as VMap import Formatting.Buildable (build) import Numeric (showEFloat) import qualified Ouroboros.Consensus.HardFork.History as Consensus @@ -658,7 +653,7 @@ runQueryStakeSnapshot -> NetworkId -> Hash StakePoolKey -> ExceptT ShelleyQueryCmdError IO () -runQueryStakeSnapshot (AnyConsensusModeParams cModeParams) network poolid = do +runQueryStakeSnapshot (AnyConsensusModeParams cModeParams) network poolId = do SocketPath sockPath <- firstExceptT ShelleyQueryCmdEnvVarSocketErr readEnvSocketPath let localNodeConnInfo = LocalNodeConnectInfo cModeParams network sockPath @@ -669,9 +664,9 @@ runQueryStakeSnapshot (AnyConsensusModeParams cModeParams) network poolid = do eInMode <- toEraInMode era cMode & hoistMaybe (ShelleyQueryCmdEraConsensusModeMismatch (AnyConsensusMode cMode) anyE) - let qInMode = QueryInEra eInMode . QueryInShelleyBasedEra sbe $ QueryDebugLedgerState + let qInMode = QueryInEra eInMode . QueryInShelleyBasedEra sbe $ QueryStakeSnapshot poolId result <- executeQuery era cModeParams localNodeConnInfo qInMode - obtainLedgerEraClassConstraints sbe (writeStakeSnapshot poolid) result + obtainLedgerEraClassConstraints sbe writeStakeSnapshot result runQueryLedgerState @@ -822,44 +817,15 @@ writeLedgerState mOutFile qState@(SerialisedDebugLedgerState serLedgerState) = writeStakeSnapshot :: forall era ledgerera. () => ShelleyLedgerEra era ~ ledgerera => Era.Crypto ledgerera ~ StandardCrypto - => FromCBOR (DebugLedgerState era) - => PoolId - -> SerialisedDebugLedgerState era + => SerialisedStakeSnapshot era -> ExceptT ShelleyQueryCmdError IO () -writeStakeSnapshot (StakePoolKeyHash hk) qState = - case decodeDebugLedgerState qState of - -- In the event of decode failure print the CBOR instead - Left bs -> firstExceptT ShelleyQueryCmdHelpersError $ pPrintCBOR bs - - Right ledgerState -> do - -- Ledger State - let (DebugLedgerState snapshot) = ledgerState - - -- The three stake snapshots, obtained from the ledger state - let (SnapShots markS setS goS _) = esSnapshots $ nesEs snapshot +writeStakeSnapshot qState = + case decodeStakeSnapshot qState of + Left err -> left (ShelleyQueryCmdDecodeError "StakeSnapshot" err) + Right (StakeSnapshot snapshot) -> do -- Calculate the three pool and active stake values for the given pool - liftIO . LBS.putStrLn $ encodePretty $ Stakes - { markPool = getPoolStake hk markS - , setPool = getPoolStake hk setS - , goPool = getPoolStake hk goS - , markTotal = getAllStake markS - , setTotal = getAllStake setS - , goTotal = getAllStake goS - } - --- | Sum all the stake that is held by the pool -getPoolStake :: KeyHash Cardano.Ledger.Keys.StakePool crypto -> SnapShot crypto -> Integer -getPoolStake hash ss = pStake - where - Coin pStake = fold (Map.map fromCompact $ VMap.toMap s) - Stake s = poolStake hash (_delegations ss) (_stake ss) - --- | Sum the active stake from a snapshot -getAllStake :: SnapShot crypto -> Integer -getAllStake (SnapShot stake _ _) = activeStake - where - Coin activeStake = fold (fmap fromCompact (VMap.toMap (unStake stake))) + liftIO . LBS.putStrLn $ encodePretty snapshot -- | This function obtains the pool parameters, equivalent to the following jq query on the output of query ledger-state -- .nesEs.esLState._delegationState._pstate._pParams. @@ -880,7 +846,7 @@ writePoolParams (StakePoolKeyHash hk) qState = let DebugLedgerState snapshot = ledgerState let poolState :: PState StandardCrypto - poolState = dpsPState . lsDPState $ esLState $ nesEs snapshot + poolState = SL.dpsPState . lsDPState $ esLState $ nesEs snapshot -- Pool parameters let poolParams = Map.lookup hk $ _pParams poolState diff --git a/cardano-node/src/Cardano/Node/Tracing/Documentation.hs b/cardano-node/src/Cardano/Node/Tracing/Documentation.hs index 8b396ec7043..d9e612d7c30 100644 --- a/cardano-node/src/Cardano/Node/Tracing/Documentation.hs +++ b/cardano-node/src/Cardano/Node/Tracing/Documentation.hs @@ -680,7 +680,7 @@ docTracers configFileName outputFileName _ _ _ = do allPublic configureTracers trConfig docDebugPeerSelection [debugPeerSelectionTr] debugPeerSelectionTrDoc <- documentTracer trConfig debugPeerSelectionTr - (docDebugPeerSelection :: Documented (DebugPeerSelection Socket.SockAddr peer)) + (docDebugPeerSelection :: Documented (DebugPeerSelection Socket.SockAddr)) debugPeerSelectionResponderTr <- mkCardanoTracer trBase trForward mbTrEKG @@ -690,7 +690,7 @@ docTracers configFileName outputFileName _ _ _ = do allPublic configureTracers trConfig docDebugPeerSelection [debugPeerSelectionResponderTr] debugPeerSelectionResponderTrDoc <- documentTracer trConfig debugPeerSelectionResponderTr - (docDebugPeerSelection :: Documented (DebugPeerSelection Socket.SockAddr peer)) + (docDebugPeerSelection :: Documented (DebugPeerSelection Socket.SockAddr)) peerSelectionCountersTr <- mkCardanoTracer trBase trForward mbTrEKG diff --git a/cardano-node/src/Cardano/Node/Tracing/Tracers/P2P.hs b/cardano-node/src/Cardano/Node/Tracing/Tracers/P2P.hs index 4e04ff11237..fb684ae79f9 100644 --- a/cardano-node/src/Cardano/Node/Tracing/Tracers/P2P.hs +++ b/cardano-node/src/Cardano/Node/Tracing/Tracers/P2P.hs @@ -591,13 +591,13 @@ peerSelectionTargetsToObject -- DebugPeerSelection Tracer -------------------------------------------------------------------------------- -namesForDebugPeerSelection :: DebugPeerSelection SockAddr peerConn -> [Text] +namesForDebugPeerSelection :: DebugPeerSelection SockAddr -> [Text] namesForDebugPeerSelection _ = ["GovernorState"] -severityDebugPeerSelection :: DebugPeerSelection SockAddr peerConn -> SeverityS +severityDebugPeerSelection :: DebugPeerSelection SockAddr -> SeverityS severityDebugPeerSelection _ = Debug -instance Show peerConn => LogFormatting (DebugPeerSelection SockAddr peerConn) where +instance LogFormatting (DebugPeerSelection SockAddr) where forMachine DNormal (TraceGovernorState blockedAt wakeupAfter PeerSelectionState { targets, knownPeers, establishedPeers, activePeers }) = mconcat [ "kind" .= String "DebugPeerSelection" @@ -618,7 +618,7 @@ instance Show peerConn => LogFormatting (DebugPeerSelection SockAddr peerConn) w ] forHuman = pack . show -docDebugPeerSelection :: Documented (DebugPeerSelection SockAddr peerConn) +docDebugPeerSelection :: Documented (DebugPeerSelection SockAddr) docDebugPeerSelection = Documented [ DocMsg ["GovernorState"] @@ -1502,14 +1502,14 @@ docInboundGovernor isLocal = Documented "" , DocMsg ["InboundGovernorCounters"] - (if isLocal + (if isLocal then [("Net.LocalInboundGovernor.Idle","") ,("Net.LocalInboundGovernor.Cold","") ,("Net.LocalInboundGovernor.Warm","") ,("Net.LocalInboundGovernor.Hot","") - ] - else + ] + else [("Net.InboundGovernor.Idle","") ,("Net.InboundGovernor.Cold","") ,("Net.InboundGovernor.Warm","") diff --git a/cardano-node/src/Cardano/Tracing/OrphanInstances/Network.hs b/cardano-node/src/Cardano/Tracing/OrphanInstances/Network.hs index 579163af215..c98267c5d7d 100644 --- a/cardano-node/src/Cardano/Tracing/OrphanInstances/Network.hs +++ b/cardano-node/src/Cardano/Tracing/OrphanInstances/Network.hs @@ -409,8 +409,8 @@ instance HasSeverityAnnotation (TracePeerSelection addr) where TraceChurnWait {} -> Info TraceChurnMode {} -> Info -instance HasPrivacyAnnotation (DebugPeerSelection addr conn) -instance HasSeverityAnnotation (DebugPeerSelection addr conn) where +instance HasPrivacyAnnotation (DebugPeerSelection addr) +instance HasSeverityAnnotation (DebugPeerSelection addr) where getSeverityAnnotation _ = Debug instance HasPrivacyAnnotation (PeerSelectionActionsTrace SockAddr) @@ -664,10 +664,9 @@ instance Transformable Text IO (TracePeerSelection SockAddr) where instance HasTextFormatter (TracePeerSelection SockAddr) where formatText a _ = pack (show a) -instance Show conn - => Transformable Text IO (DebugPeerSelection SockAddr conn) where +instance Transformable Text IO (DebugPeerSelection SockAddr) where trTransformer = trStructuredText -instance HasTextFormatter (DebugPeerSelection SockAddr conn) where +instance HasTextFormatter (DebugPeerSelection SockAddr) where -- One can only change what is logged with respect to verbosity using json -- format. formatText _ obj = pack (show obj) @@ -1619,7 +1618,7 @@ peerSelectionTargetsToObject , "active" .= targetNumberOfActivePeers ] -instance Show peerConn => ToObject (DebugPeerSelection SockAddr peerConn) where +instance ToObject (DebugPeerSelection SockAddr) where toObject verb (TraceGovernorState blockedAt wakeupAfter PeerSelectionState { targets, knownPeers, establishedPeers, activePeers }) | verb <= NormalVerbosity =