diff --git a/cardano-ping/src/Cardano/Network/Ping.hs b/cardano-ping/src/Cardano/Network/Ping.hs index ae723af712b..81ed82fd413 100644 --- a/cardano-ping/src/Cardano/Network/Ping.hs +++ b/cardano-ping/src/Cardano/Network/Ping.hs @@ -154,6 +154,7 @@ supportedNodeToClientVersions magic = , NodeToClientVersionV20 magic , NodeToClientVersionV21 magic , NodeToClientVersionV22 magic + , NodeToClientVersionV33 magic ] data InitiatorOnly = InitiatorOnly | InitiatorAndResponder @@ -193,6 +194,7 @@ data NodeVersion | NodeToClientVersionV20 Word32 | NodeToClientVersionV21 Word32 | NodeToClientVersionV22 Word32 + | NodeToClientVersionV23 Word32 | NodeToNodeVersionV1 Word32 | NodeToNodeVersionV2 Word32 | NodeToNodeVersionV3 Word32 @@ -226,6 +228,7 @@ instance ToJSON NodeVersion where NodeToClientVersionV20 m -> go2 "NodeToClientVersionV20" m NodeToClientVersionV21 m -> go2 "NodeToClientVersionV21" m NodeToClientVersionV22 m -> go2 "NodeToClientVersionV22" m + NodeToClientVersionV23 m -> go2 "NodeToClientVersionV23" m NodeToNodeVersionV1 m -> go2 "NodeToNodeVersionV1" m NodeToNodeVersionV2 m -> go2 "NodeToNodeVersionV2" m NodeToNodeVersionV3 m -> go2 "NodeToNodeVersionV3" m @@ -377,6 +380,9 @@ handshakeReqEnc versions query = encodeVersion (NodeToClientVersionV22 magic) = CBOR.encodeWord (22 `setBit` nodeToClientVersionBit) <> nodeToClientDataWithQuery magic + encodeVersion (NodeToClientVersionV23 magic) = + CBOR.encodeWord (23 `setBit` nodeToClientVersionBit) + <> nodeToClientDataWithQuery magic -- node-to-node encodeVersion (NodeToNodeVersionV1 magic) = @@ -528,6 +534,7 @@ handshakeDec = do (20, True) -> Right . NodeToClientVersionV20 <$> (CBOR.decodeListLen *> CBOR.decodeWord32 <* (modeFromBool <$> CBOR.decodeBool)) (21, True) -> Right . NodeToClientVersionV21 <$> (CBOR.decodeListLen *> CBOR.decodeWord32 <* (modeFromBool <$> CBOR.decodeBool)) (22, True) -> Right . NodeToClientVersionV22 <$> (CBOR.decodeListLen *> CBOR.decodeWord32 <* (modeFromBool <$> CBOR.decodeBool)) + (23, True) -> Right . NodeToClientVersionV23 <$> (CBOR.decodeListLen *> CBOR.decodeWord32 <* (modeFromBool <$> CBOR.decodeBool)) _ -> return $ Left $ UnknownVersionInRsp version decodeWithMode :: (Word32 -> InitiatorOnly -> NodeVersion) -> CBOR.Decoder s (Either HandshakeFailure NodeVersion) @@ -853,6 +860,7 @@ isSameVersionAndMagic v1 v2 = extract v1 == extract v2 extract (NodeToClientVersionV20 m) = (-20, m) extract (NodeToClientVersionV21 m) = (-21, m) extract (NodeToClientVersionV22 m) = (-22, m) + extract (NodeToClientVersionV23 m) = (-23, m) extract (NodeToNodeVersionV1 m) = (1, m) extract (NodeToNodeVersionV2 m) = (2, m) extract (NodeToNodeVersionV3 m) = (3, m) diff --git a/ouroboros-network-api/ouroboros-network-api.cabal b/ouroboros-network-api/ouroboros-network-api.cabal index 6ec413aad56..c4e526cb97d 100644 --- a/ouroboros-network-api/ouroboros-network-api.cabal +++ b/ouroboros-network-api/ouroboros-network-api.cabal @@ -60,6 +60,7 @@ library base16-bytestring, bytestring >=0.10 && <0.13, cardano-binary, + cardano-crypto-class, cardano-slotting, cardano-strict-containers, cborg >=0.2.1 && <0.3, diff --git a/ouroboros-network-api/src/Ouroboros/Network/Block.hs b/ouroboros-network-api/src/Ouroboros/Network/Block.hs index e39f8608ff5..7bcdd080bf3 100644 --- a/ouroboros-network-api/src/Ouroboros/Network/Block.hs +++ b/ouroboros-network-api/src/Ouroboros/Network/Block.hs @@ -79,6 +79,7 @@ import Codec.CBOR.Read qualified as Read import Codec.CBOR.Write qualified as Write import Codec.Serialise (Serialise (..)) import Control.Monad (when) +import Data.Aeson (FromJSON, ToJSON) import Data.ByteString.Base16.Lazy qualified as B16 import Data.ByteString.Lazy qualified as Lazy import Data.ByteString.Lazy.Char8 qualified as BSC @@ -216,6 +217,8 @@ deriving newtype instance StandardHash block => Ord (Point block) deriving via (Quiet (Point block)) instance StandardHash block => Show (Point block) deriving newtype instance StandardHash block => NoThunks (Point block) +deriving newtype instance ToJSON (Point.Block SlotNo (HeaderHash block)) => ToJSON (Point block) +deriving newtype instance FromJSON (Point.Block SlotNo (HeaderHash block)) => FromJSON (Point block) instance ShowProxy block => ShowProxy (Point block) where showProxy _ = "Point " ++ showProxy (Proxy :: Proxy block) diff --git a/ouroboros-network-api/src/Ouroboros/Network/NodeToClient/Version.hs b/ouroboros-network-api/src/Ouroboros/Network/NodeToClient/Version.hs index a3aaeb8de9f..e797253df58 100644 --- a/ouroboros-network-api/src/Ouroboros/Network/NodeToClient/Version.hs +++ b/ouroboros-network-api/src/Ouroboros/Network/NodeToClient/Version.hs @@ -56,6 +56,10 @@ data NodeToClientVersion -- ^ new codecs for @PParams@ and @CompactGenesis@ | NodeToClientV_22 -- ^ support SRV records in @GetBigLedgerPeerSnapshot@ query + -- TODO: remove CBOR instances from LedgerPeers.Type when V22 support + -- is removed! + | NodeToClientV_23 + -- ^ LedgerPeerSnapshot CBOR encoding contains block hash deriving (Eq, Ord, Enum, Bounded, Show, Generic, NFData) -- | We set 16ths bit to distinguish `NodeToNodeVersion` and @@ -76,6 +80,7 @@ nodeToClientVersionCodec = CodecCBORTerm { encodeTerm, decodeTerm } NodeToClientV_20 -> enc 20 NodeToClientV_21 -> enc 21 NodeToClientV_22 -> enc 22 + NodeToClientV_23 -> enc 23 where enc :: Int -> CBOR.Term enc = CBOR.TInt . (`setBit` nodeToClientVersionBit) @@ -89,6 +94,7 @@ nodeToClientVersionCodec = CodecCBORTerm { encodeTerm, decodeTerm } 20 -> Right NodeToClientV_20 21 -> Right NodeToClientV_21 22 -> Right NodeToClientV_22 + 23 -> Right NodeToClientV_23 n -> Left (unknownTag n) where dec :: CBOR.Term -> Either (Text, Maybe Int) Int diff --git a/ouroboros-network-api/src/Ouroboros/Network/PeerSelection/LedgerPeers/Type.hs b/ouroboros-network-api/src/Ouroboros/Network/PeerSelection/LedgerPeers/Type.hs index ca92eecdff4..1401f8306ba 100644 --- a/ouroboros-network-api/src/Ouroboros/Network/PeerSelection/LedgerPeers/Type.hs +++ b/ouroboros-network-api/src/Ouroboros/Network/PeerSelection/LedgerPeers/Type.hs @@ -2,6 +2,7 @@ {-# LANGUAGE DeriveAnyClass #-} {-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE DerivingVia #-} +{-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE LambdaCase #-} @@ -9,9 +10,11 @@ {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE PatternSynonyms #-} {-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE StandaloneDeriving #-} {-# LANGUAGE TypeApplications #-} - -{-# OPTIONS_GHC -fno-warn-orphans #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE UndecidableInstances #-} +{-# LANGUAGE ViewPatterns #-} -- | Various types related to ledger peers. This module is re-exported from -- "Ouroboros.Network.PeerSelection.LedgerPeers". @@ -31,9 +34,10 @@ module Ouroboros.Network.PeerSelection.LedgerPeers.Type , LedgerPeerSnapshotSRVSupport (..) , encodeLedgerPeerSnapshot , decodeLedgerPeerSnapshot + , encodeLedgerPeerSnapshotPoint + , decodeLedgerPeerSnapshotPoint , getRelayAccessPointsFromLedgerPeerSnapshot , isLedgerPeersEnabled - , compareLedgerPeerSnapshotApproximate -- * Re-exports , SRVPrefix , RelayAccessPoint (..) @@ -41,78 +45,69 @@ module Ouroboros.Network.PeerSelection.LedgerPeers.Type , prefixLedgerRelayAccessPoint ) where -import GHC.Generics (Generic) --- TODO: remove `FromCBOR` and `ToCBOR` type classes -import Cardano.Binary (FromCBOR (..), ToCBOR (..)) -import Cardano.Binary qualified as Codec -import Cardano.Slotting.Slot (SlotNo (..), WithOrigin (..)) +import Control.Applicative ((<|>)) import Control.Concurrent.Class.MonadSTM -import Control.DeepSeq (NFData (..)) +import Control.DeepSeq (NFData (..), force) import Control.Monad (forM) import Data.Aeson -import Data.Bifunctor (first, second) +import Data.Bifunctor (second) +import Data.ByteString (ByteString) import Data.List.NonEmpty (NonEmpty) import Data.List.NonEmpty qualified as NonEmpty +import GHC.Generics (Generic) import NoThunks.Class +-- TODO: remove `FromCBOR` and `ToCBOR` instances when ntc V22 is no longer supported +import Cardano.Binary (FromCBOR (..), ToCBOR (..)) +import Cardano.Binary qualified as Codec +import Cardano.Crypto.Hash (Hash, Blake2b_256) +import Ouroboros.Network.Block import Ouroboros.Network.PeerSelection.RelayAccessPoint +import Ouroboros.Network.Point --- |The type of big ledger peers that is serialised or later +-- | The type of big ledger peers that is serialised or later -- provided by node configuration for the networking layer --- to connect to when syncing. +-- to connect to when syncing. Provided pattern synonym +-- abstracts over the internal representation. -- data LedgerPeerSnapshot = - LedgerPeerSnapshotV2 (WithOrigin SlotNo, [(AccPoolStake, (PoolStake, NonEmpty LedgerRelayAccessPoint))]) - -- ^ Internal use for version 2, use pattern synonym for public API - deriving (Eq, Show) + LedgerPeerSnapshotV2 + (WithOrigin SlotNo, [(AccPoolStake, (PoolStake, NonEmpty LedgerRelayAccessPoint))]) + | LedgerPeerSnapshotV3 + !(Point LedgerPeerSnapshot) + ![(AccPoolStake, (PoolStake, NonEmpty LedgerRelayAccessPoint))] + +instance StandardHash LedgerPeerSnapshot +deriving instance Show (Point LedgerPeerSnapshot) => Show LedgerPeerSnapshot +type instance HeaderHash LedgerPeerSnapshot = Hash Blake2b_256 ByteString getRelayAccessPointsFromLedgerPeerSnapshot :: SRVPrefix -> LedgerPeerSnapshot -> (WithOrigin SlotNo, [(AccPoolStake, (PoolStake, NonEmpty RelayAccessPoint))]) -getRelayAccessPointsFromLedgerPeerSnapshot srvPrefix (LedgerPeerSnapshotV2 as) = +getRelayAccessPointsFromLedgerPeerSnapshot srvPrefix = \case + LedgerPeerSnapshotV2 as -> fmap (fmap (fmap (fmap (fmap (prefixLedgerRelayAccessPoint srvPrefix))))) as + LedgerPeerSnapshotV3 pt as -> + let as' = fmap (fmap (fmap (fmap (prefixLedgerRelayAccessPoint srvPrefix)))) as + in (pointSlot pt, as') -- |Public API to access snapshot data. Currently access to only most recent version is available. -- Nonetheless, serialisation from the node into JSON is supported for older versions via internal -- api so that newer CLI can still support older node formats. -- -pattern LedgerPeerSnapshot :: (WithOrigin SlotNo, [(AccPoolStake, (PoolStake, NonEmpty LedgerRelayAccessPoint))]) +pattern LedgerPeerSnapshot :: Point LedgerPeerSnapshot + -> [(AccPoolStake, (PoolStake, NonEmpty LedgerRelayAccessPoint))] -> LedgerPeerSnapshot -pattern LedgerPeerSnapshot payload <- LedgerPeerSnapshotV2 payload where - LedgerPeerSnapshot payload = LedgerPeerSnapshotV2 payload +pattern LedgerPeerSnapshot pt as <- LedgerPeerSnapshotV3 pt as + where + LedgerPeerSnapshot pt (force -> pools) = LedgerPeerSnapshotV3 pt pools {-# COMPLETE LedgerPeerSnapshot #-} --- | Since ledger peer snapshot is serialised with all domain names --- fully qualified, and all stake values are approximate in floating --- point, comparison is necessarily approximate as well. --- The candidate argument is processed here to simulate a round trip --- by the serialisation mechanism and then compared to the baseline --- argument, which is assumed that it was actually processed this way --- when a snapshot was created earlier, and hence it is approximate as well. --- The two approximate values should be equal if they were created --- from the same 'faithful' data. --- -compareLedgerPeerSnapshotApproximate :: [(AccPoolStake, (PoolStake, NonEmpty RelayAccessPoint))] - -> [(AccPoolStake, (PoolStake, NonEmpty RelayAccessPoint))] - -> Bool -compareLedgerPeerSnapshotApproximate baseline candidate = - case tripIt of - Success candidate' -> candidate' == baseline - Error _ -> False - where - tripIt = fmap (fmap (fmap (first unPoolStakeCoded))) - . fmap (fmap (first unAccPoolStakeCoded)) - . fromJSON - . toJSON - . fmap (fmap (first PoolStakeCoded)) - . fmap (first AccPoolStakeCoded) - $ candidate - -- | In case the format changes in the future, this function provides a migration functionality -- when possible. -- @@ -120,6 +115,7 @@ migrateLedgerPeerSnapshot :: LedgerPeerSnapshot -> Maybe LedgerPeerSnapshot migrateLedgerPeerSnapshot snapshot@LedgerPeerSnapshotV2{} = Just snapshot +migrateLedgerPeerSnapshot snapshot@LedgerPeerSnapshotV3{} = Just snapshot instance ToJSON LedgerPeerSnapshot where toJSON (LedgerPeerSnapshotV2 (slot, pools)) = @@ -127,45 +123,70 @@ instance ToJSON LedgerPeerSnapshot where , "slotNo" .= slot , "bigLedgerPools" .= [ object [ "accumulatedStake" .= fromRational @Double accStake - , "relativeStake" .= fromRational @Double relStake - , "relays" .= relays] + , "relativeStake" .= fromRational @Double relStake + , "relays" .= relays] + | (AccPoolStake accStake, (PoolStake relStake, relays)) <- pools + ]] + toJSON (LedgerPeerSnapshotV3 pt pools) = + object [ "NodeToClientVersion" .= (23 :: Int) + , "Point" .= toJSON pt + , "bigLedgerPools" .= [ object + [ "accumulatedStake" .= fromRational @Double accStake + , "relativeStake" .= fromRational @Double relStake + , "relays" .= relays] | (AccPoolStake accStake, (PoolStake relStake, relays)) <- pools ]] instance FromJSON LedgerPeerSnapshot where parseJSON = withObject "LedgerPeerSnapshot" $ \v -> do - vNum :: Int <- v .: "version" + vNum :: Maybe Int <- v .:? "version" <|> v.:? "NodeToClientVersion" + bigPools <- v .: "bigLedgerPools" ledgerPeerSnapshot <- case vNum of - 1 -> do + Just 1 -> do slot <- v .: "slotNo" - bigPools <- v .: "bigLedgerPools" bigPools' <- forM (zip [0 :: Int ..] bigPools) \(idx, poolO) -> do let f poolV = do - AccPoolStakeCoded accStake <- poolV .: "accumulatedStake" - PoolStakeCoded reStake <- poolV .: "relativeStake" + accStake <- poolV .: "accumulatedStake" + reStake <- poolV .: "relativeStake" -- decode using `LedgerRelayAccessPointV1` instance relays <- fmap getLedgerReelayAccessPointV1 <$> poolV .: "relays" return (accStake, (reStake, relays)) withObject ("bigLedgerPools[" <> show idx <> "]") f (Object poolO) return $ LedgerPeerSnapshotV2 (slot, bigPools') - 2 -> do + Just 2 -> do slot <- v .: "slotNo" - bigPools <- v .: "bigLedgerPools" bigPools' <- forM (zip [0 :: Int ..] bigPools) \(idx, poolO) -> do let f poolV = do - AccPoolStakeCoded accStake <- poolV .: "accumulatedStake" - PoolStakeCoded reStake <- poolV .: "relativeStake" - relays <- poolV .: "relays" + accStake <- poolV .: "accumulatedStake" + reStake <- poolV .: "relativeStake" + relays <- poolV .: "relays" return (accStake, (reStake, relays)) withObject ("bigLedgerPools[" <> show idx <> "]") f (Object poolO) return $ LedgerPeerSnapshotV2 (slot, bigPools') - _ -> fail $ "Network.LedgerPeers.Type: parseJSON: failed to parse unsupported version " <> show vNum + Just 23 -> do + point <- v .: "Point" + bigPools' <- forM (zip [0 :: Int ..] bigPools) \(idx, poolO) -> do + let f poolV = do + accStake <- poolV .: "accumulatedStake" + reStake <- poolV .: "relativeStake" + relays <- poolV .: "relays" + return (accStake, (reStake, relays)) + withObject ("bigLedgerPools[" <> show idx <> "]") f (Object poolO) + + return $ LedgerPeerSnapshotV3 point bigPools' + Just _ -> + fail $ "Network.LedgerPeers.Type: parseJSON: failed to parse unsupported version " + <> show vNum + Nothing -> + fail $ "Network.LedgerPeers.Type: parseJSON: failed to parse unsupported version " + <> show vNum case migrateLedgerPeerSnapshot ledgerPeerSnapshot of Just ledgerPeerSnapshot' -> return ledgerPeerSnapshot' - Nothing -> fail "Network.LedgerPeers.Type: parseJSON: failed to migrate big ledger peer snapshot" + Nothing -> + fail "Network.LedgerPeers.Type: parseJSON: failed to migrate big ledger peer snapshot" encodeWithOrigin :: WithOrigin SlotNo -> Codec.Encoding @@ -192,63 +213,115 @@ data LedgerPeerSnapshotSRVSupport encodeLedgerPeerSnapshot :: LedgerPeerSnapshotSRVSupport -> LedgerPeerSnapshot -> Codec.Encoding encodeLedgerPeerSnapshot LedgerPeerSnapshotDoesntSupportSRV (LedgerPeerSnapshotV2 (wOrigin, pools)) = - Codec.encodeListLen 2 - <> Codec.encodeWord8 1 -- internal version - <> Codec.encodeListLen 2 - <> encodeWithOrigin wOrigin - <> toCBOR pools' - where - pools' = - [(AccPoolStakeCoded accPoolStake, (PoolStakeCoded relStake, relays)) - | (accPoolStake, (relStake, relays)) <- - -- filter out SRV domains, not supported by `< NodeToClientV_22` - map - (second $ second $ NonEmpty.filter - (\case - LedgerRelayAccessSRVDomain {} -> False - _ -> True) - ) - pools - , not (null relays) - ] + Codec.encodeListLen 2 + <> Codec.encodeWord8 1 -- internal version + <> Codec.encodeListLen 2 + <> encodeWithOrigin wOrigin + <> toCBOR pools' + where + pools' = + [(accPoolStake, (relStake, NonEmpty.fromList relays)) + | (accPoolStake, (relStake, relays)) <- + -- filter out SRV domains, not supported by `< NodeToClientV_22` + map + (second $ second $ NonEmpty.filter + (\case + LedgerRelayAccessSRVDomain {} -> False + _ -> True) + ) + pools + , not (null relays) + ] + encodeLedgerPeerSnapshot LedgerPeerSnapshotSupportsSRV (LedgerPeerSnapshotV2 (wOrigin, pools)) = - Codec.encodeListLen 2 - <> Codec.encodeWord8 1 -- internal version - <> Codec.encodeListLen 2 - <> encodeWithOrigin wOrigin - <> toCBOR pools' - where - pools' = - [(AccPoolStakeCoded accPoolStake, (PoolStakeCoded relStake, relays)) - | (accPoolStake, (relStake, relays)) <- pools - ] + Codec.encodeListLen 2 + <> Codec.encodeWord8 1 -- internal version + <> Codec.encodeListLen 2 + <> encodeWithOrigin wOrigin + <> toCBOR pools + +encodeLedgerPeerSnapshot _LedgerPeerSnapshotSupportsSRV (LedgerPeerSnapshotV3 pt pools) = + Codec.encodeListLen 2 + <> Codec.encodeWord8 3 -- internal version + <> Codec.encodeListLen 2 + <> encodeLedgerPeerSnapshotPoint pt + <> encodeStakePools pools + + +encodeLedgerPeerSnapshotPoint :: Point LedgerPeerSnapshot -> Codec.Encoding +encodeLedgerPeerSnapshotPoint = \case + Point Origin -> Codec.encodeListLen 1 <> Codec.encodeWord8 0 + Point (At Block { blockPointSlot, blockPointHash }) -> + Codec.encodeListLen 3 <> Codec.encodeWord8 1 + <> Codec.toCBOR blockPointSlot <> Codec.toCBOR blockPointHash + decodeLedgerPeerSnapshot :: LedgerPeerSnapshotSRVSupport -> Codec.Decoder s LedgerPeerSnapshot decodeLedgerPeerSnapshot _ = do Codec.decodeListLenOf 2 version <- Codec.decodeWord8 case version of - 1 -> LedgerPeerSnapshotV2 <$> do - Codec.decodeListLenOf 2 - wOrigin <- decodeWithOrigin - pools <- fromCBOR - let pools' = [(accStake, (relStake, relays)) - | (AccPoolStakeCoded accStake, (PoolStakeCoded relStake, relays)) <- pools - ] - return (wOrigin, pools') + 1 -> Codec.decodeListLenOf 2 >> + LedgerPeerSnapshotV2 <$> + ((,) <$> decodeWithOrigin <*> fromCBOR) + 3 -> Codec.decodeListLenOf 2 >> + LedgerPeerSnapshotV3 <$> decodeLedgerPeerSnapshotPoint + <*> decodeStakePools _ -> fail $ "LedgerPeers.Type: no decoder could be found for version " <> show version --- | Which ledger peers to pick. + +decodeLedgerPeerSnapshotPoint :: Codec.Decoder s (Point LedgerPeerSnapshot) +decodeLedgerPeerSnapshotPoint = do + listLen <- Codec.decodeListLen + tag <- Codec.decodeWord8 + case (tag, listLen) of + (0, 1) -> pure $ Point Origin + (0, n) -> fail $ "LedgerPeers.Type: invalid listLen for Origin tag, expected 1 got " <> show n + (1, 3) -> Point . At <$> (Block <$> fromCBOR <*> fromCBOR) + (1, n) -> fail $ "LedgerPeers.Type: invalid listLen for At tag, expected 3 got " <> show n + _ -> fail "LedgerPeers.Type: Unrecognized CBOR encoding of Point for LedgerPeerSnapshot" + + +encodeStakePools :: [(AccPoolStake, (PoolStake, NonEmpty LedgerRelayAccessPoint))] + -> Codec.Encoding +encodeStakePools pools = + Codec.encodeListLenIndef + <> foldr (\(AccPoolStake accPoolStake, (PoolStake poolStake, relays)) r -> + Codec.encodeListLen 3 + <> toCBOR accPoolStake + <> toCBOR poolStake + <> toCBOR relays + <> r) + Codec.encodeBreak + pools + + +decodeStakePools :: Codec.Decoder s [(AccPoolStake, (PoolStake, NonEmpty LedgerRelayAccessPoint))] +decodeStakePools = do + Codec.decodeListLenIndef + Codec.decodeSequenceLenIndef + (flip (:)) [] reverse + do + Codec.decodeListLenOf 3 + accPoolStake <- AccPoolStake <$> fromCBOR + poolStake <- PoolStake <$> fromCBOR + relays <- fromCBOR + return (accPoolStake, (poolStake, relays)) + + +-- | Used by functions to indicate what kind of ledger peer to process -- data LedgerPeersKind = AllLedgerPeers | BigLedgerPeers deriving Show -- | Only use the ledger after the given slot number. +-- data UseLedgerPeers = DontUseLedgerPeers | UseLedgerPeers AfterSlot deriving (Eq, Show, Generic, NoThunks) -- | Only use the ledger after the given slot number. +-- data AfterSlot = Always | After SlotNo deriving (Eq, Show, Generic) @@ -258,25 +331,24 @@ isLedgerPeersEnabled :: UseLedgerPeers -> Bool isLedgerPeersEnabled DontUseLedgerPeers = False isLedgerPeersEnabled UseLedgerPeers {} = True + -- | The relative stake of a stakepool in relation to the total amount staked. -- A value in the [0, 1] range. -- newtype PoolStake = PoolStake { unPoolStake :: Rational } deriving (Eq, Ord, Show) - deriving newtype (Fractional, Num, NFData) + deriving newtype (Fractional, Num, NFData, FromJSON, ToJSON, ToCBOR, FromCBOR) + -- the ToCBOR and FromCBOR instances can be removed once V22 is no longer supported -newtype PoolStakeCoded = PoolStakeCoded { unPoolStakeCoded :: PoolStake } - deriving (ToCBOR, FromCBOR, FromJSON, ToJSON) via Rational -- | The accumulated relative stake of a stake pool, like PoolStake but it also includes the -- relative stake of all preceding pools. A value in the range [0, 1]. -- newtype AccPoolStake = AccPoolStake { unAccPoolStake :: Rational } - deriving (Eq, Ord, Show) - deriving newtype (Fractional, Num) + deriving (Eq, Ord, Show) + deriving newtype (Fractional, Num, NFData, FromJSON, ToJSON, FromCBOR, ToCBOR) + -- the ToCBOR and FromCBOR instances can be removed once V22 is no longer supported -newtype AccPoolStakeCoded = AccPoolStakeCoded { unAccPoolStakeCoded :: AccPoolStake } - deriving (ToCBOR, FromCBOR, FromJSON, ToJSON) via Rational -- | Identifies a peer as coming from ledger or not. data IsLedgerPeer = IsLedgerPeer diff --git a/ouroboros-network-api/src/Ouroboros/Network/PeerSelection/LedgerPeers/Utils.hs b/ouroboros-network-api/src/Ouroboros/Network/PeerSelection/LedgerPeers/Utils.hs index 3cf28aa7f10..5d3f7894872 100644 --- a/ouroboros-network-api/src/Ouroboros/Network/PeerSelection/LedgerPeers/Utils.hs +++ b/ouroboros-network-api/src/Ouroboros/Network/PeerSelection/LedgerPeers/Utils.hs @@ -20,7 +20,8 @@ import Data.Ratio ((%)) import Ouroboros.Network.PeerSelection.LedgerPeers.Type --- | The total accumulated stake of big ledger peers. +-- | Big ledger peers are those ledger peers, which when sorted down by their +-- relative stake, in the aggregate hold 90% of the total stake in the network. -- bigLedgerPeerQuota :: AccPoolStake bigLedgerPeerQuota = 0.9 diff --git a/ouroboros-network-api/src/Ouroboros/Network/Point.hs b/ouroboros-network-api/src/Ouroboros/Network/Point.hs index 8f09b55cec1..cd49f242a8a 100644 --- a/ouroboros-network-api/src/Ouroboros/Network/Point.hs +++ b/ouroboros-network-api/src/Ouroboros/Network/Point.hs @@ -16,6 +16,7 @@ module Ouroboros.Network.Point , withOriginFromMaybe ) where +import Data.Aeson import GHC.Generics (Generic) import NoThunks.Class (NoThunks) @@ -25,7 +26,7 @@ data Block slot hash = Block { blockPointSlot :: !slot , blockPointHash :: !hash } - deriving (Eq, Ord, Show, Generic, NoThunks) + deriving (Eq, Ord, Show, ToJSON, FromJSON, Generic, NoThunks) block :: slot -> hash -> WithOrigin (Block slot hash) block slot hash = at (Block slot hash) diff --git a/ouroboros-network-protocols/cddl/specs/handshake-node-to-client.cddl b/ouroboros-network-protocols/cddl/specs/handshake-node-to-client.cddl index afee197d68b..8715996714a 100644 --- a/ouroboros-network-protocols/cddl/specs/handshake-node-to-client.cddl +++ b/ouroboros-network-protocols/cddl/specs/handshake-node-to-client.cddl @@ -19,13 +19,13 @@ versionTable = { * versionNumber => nodeToClientVersionData } ; as of version 2 (which is no longer supported) we set 16th bit to 1 -; 16 / 17 / 18 / 19 / 20 / 21 / 22 -versionNumber = 32784 / 32785 / 32786 / 32787 / 32788 / 32789 / 32790 +; 16 / 17 / 18 / 19 / 20 / 21 / 22 / 23 +versionNumber = 32784 / 32785 / 32786 / 32787 / 32788 / 32789 / 32790 / 32791 ; As of version 15 and higher nodeToClientVersionData = [networkMagic, query] -networkMagic = uint +networkMagic = uint query = bool refuseReason diff --git a/ouroboros-network/cardano-diffusion/Cardano/Network/PeerSelection/Governor/Monitor.hs b/ouroboros-network/cardano-diffusion/Cardano/Network/PeerSelection/Governor/Monitor.hs index a8ac6068911..a1f617a19a4 100644 --- a/ouroboros-network/cardano-diffusion/Cardano/Network/PeerSelection/Governor/Monitor.hs +++ b/ouroboros-network/cardano-diffusion/Cardano/Network/PeerSelection/Governor/Monitor.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE LambdaCase #-} {-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE ScopedTypeVariables #-} @@ -17,14 +18,16 @@ module Cardano.Network.PeerSelection.Governor.Monitor , waitForSystemToQuiesce ) where -import Data.Set qualified as Set - +import Control.Exception (assert) import Control.Monad.Class.MonadSTM import Control.Monad.Class.MonadTime.SI import Control.Monad.Class.MonadTimer.SI +import Data.Map.Strict (Map) +import Data.Map.Strict qualified as Map +import Data.Set (Set) +import Data.Set qualified as Set import Cardano.Network.ConsensusMode -import Cardano.Network.Diffusion.Configuration qualified as Cardano (srvPrefix) import Cardano.Network.LedgerPeerConsensusInterface qualified as Cardano import Cardano.Network.PeerSelection.Bootstrap (isBootstrapPeersEnabled, isNodeAbleToMakeProgress, requiresBootstrapPeers) @@ -34,17 +37,13 @@ import Cardano.Network.PeerSelection.Governor.PeerSelectionState qualified as Ca import Cardano.Network.PeerSelection.PeerTrustable (PeerTrustable (..)) import Cardano.Network.PeerSelection.PublicRootPeers qualified as Cardano.PublicRootPeers import Cardano.Network.Types (LedgerStateJudgement (..)) -import Control.Exception (assert) -import Data.Map.Strict (Map) -import Data.Map.Strict qualified as Map -import Data.Set (Set) import Ouroboros.Network.PeerSelection.Governor.ActivePeers (jobDemoteActivePeer) import Ouroboros.Network.PeerSelection.Governor.Monitor (jobVerifyPeerSnapshot) import Ouroboros.Network.PeerSelection.Governor.Types hiding (PeerSelectionCounters) import Ouroboros.Network.PeerSelection.LedgerPeers.Type - (LedgerPeersConsensusInterface (..)) + (LedgerPeersConsensusInterface (..), LedgerPeerSnapshot (..)) import Ouroboros.Network.PeerSelection.PublicRootPeers qualified as PublicRootPeers import Ouroboros.Network.PeerSelection.State.EstablishedPeers qualified as EstablishedPeers import Ouroboros.Network.PeerSelection.State.KnownPeers qualified as KnownPeers @@ -520,8 +519,8 @@ monitorLedgerStateJudgement PeerSelectionActions{ Decision { decisionTrace = [TraceLedgerStateJudgementChanged lsj], decisionJobs = case (lsj, ledgerPeerSnapshot) of - (TooOld, Just ledgerPeerSnapshot') -> - [jobVerifyPeerSnapshot Cardano.srvPrefix ledgerPeerSnapshot' ledgerCtx] + (TooOld, Just (LedgerPeerSnapshotV3 point _pools)) -> + [jobVerifyPeerSnapshot point ledgerCtx undefined] _otherwise -> [], decisionState = st { extraState = cpst { diff --git a/ouroboros-network/orphan-instances/Cardano/Network/OrphanInstances.hs b/ouroboros-network/orphan-instances/Cardano/Network/OrphanInstances.hs index 8f1fd702d55..6e2603190d0 100644 --- a/ouroboros-network/orphan-instances/Cardano/Network/OrphanInstances.hs +++ b/ouroboros-network/orphan-instances/Cardano/Network/OrphanInstances.hs @@ -84,6 +84,7 @@ instance FromJSON NodeToClientVersion where Number 20 -> pure NodeToClientV_20 Number 21 -> pure NodeToClientV_21 Number 22 -> pure NodeToClientV_22 + Number 23 -> pure NodeToClientV_23 Number x -> fail $ "FromJSON.NodeToClientVersion: unsupported node-to-client protocol version " ++ show x x -> fail $ "FromJSON.NodeToClientVersion: error parsing NodeToClientVersion: " ++ show x @@ -96,6 +97,7 @@ instance ToJSON NodeToClientVersion where NodeToClientV_20 -> Number 20 NodeToClientV_21 -> Number 21 NodeToClientV_22 -> Number 22 + NodeToClientV_23 -> Number 23 instance ToJSON NodeToNodeVersionData where toJSON (NodeToNodeVersionData (NetworkMagic m) dm ps q) = object diff --git a/ouroboros-network/src/Ouroboros/Network/PeerSelection/Governor/Monitor.hs b/ouroboros-network/src/Ouroboros/Network/PeerSelection/Governor/Monitor.hs index ae5c0268679..3238f5da749 100644 --- a/ouroboros-network/src/Ouroboros/Network/PeerSelection/Governor/Monitor.hs +++ b/ouroboros-network/src/Ouroboros/Network/PeerSelection/Governor/Monitor.hs @@ -1,4 +1,4 @@ -{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE ScopedTypeVariables #-} @@ -23,6 +23,7 @@ import Data.Map.Strict qualified as Map import Data.Maybe (fromMaybe, isJust) import Data.Set (Set) import Data.Set qualified as Set +import Data.Wedge import Control.Concurrent.JobPool (Job (..), JobPool) import Control.Concurrent.JobPool qualified as JobPool @@ -32,6 +33,7 @@ import Control.Monad.Class.MonadTime.SI import Control.Monad.Class.MonadTimer.SI import System.Random (randomR) +import Ouroboros.Network.Block (Point) import Ouroboros.Network.ExitPolicy (RepromoteDelay) import Ouroboros.Network.ExitPolicy qualified as ExitPolicy import Ouroboros.Network.PeerSelection.Governor.ActivePeers @@ -39,11 +41,7 @@ import Ouroboros.Network.PeerSelection.Governor.ActivePeers import Ouroboros.Network.PeerSelection.Governor.Types hiding (PeerSelectionCounters) import Ouroboros.Network.PeerSelection.LedgerPeers.Type - (LedgerPeerSnapshot (..), LedgerPeersConsensusInterface (..), - SRVPrefix, compareLedgerPeerSnapshotApproximate, - getRelayAccessPointsFromLedger, - getRelayAccessPointsFromLedgerPeerSnapshot) -import Ouroboros.Network.PeerSelection.LedgerPeers.Utils + (LedgerPeerSnapshot (..), LedgerPeersConsensusInterface (..)) import Ouroboros.Network.PeerSelection.PublicRootPeers qualified as PublicRootPeers import Ouroboros.Network.PeerSelection.State.EstablishedPeers qualified as EstablishedPeers import Ouroboros.Network.PeerSelection.State.KnownPeers qualified as KnownPeers @@ -412,19 +410,16 @@ localRoots actions@PeerSelectionActions{ readLocalRootPeers -- ledger state once the node catches up to the slot at which the -- snapshot was ostensibly taken -- -jobVerifyPeerSnapshot :: MonadSTM m - => SRVPrefix - -> LedgerPeerSnapshot +jobVerifyPeerSnapshot :: (MonadSTM m) + => Point LedgerPeerSnapshot -> LedgerPeersConsensusInterface extraAPI m + -> (Point LedgerPeerSnapshot -> STM m (Wedge (Point LedgerPeerSnapshot) ())) -> Job () m (Completion m extraState extraDebugState extraFlags extraPeers peeraddr peerconn) -jobVerifyPeerSnapshot srvPrefix - ledgerPeerSnapshot - ledgerCtx@LedgerPeersConsensusInterface { lpGetLatestSlot } +jobVerifyPeerSnapshot point + _ledgerCtx + demoConsensusAPI = Job job (const (completion False)) () "jobVerifyPeerSnapshot" where - (slot, snapshotPeers) = - getRelayAccessPointsFromLedgerPeerSnapshot srvPrefix ledgerPeerSnapshot - completion result = return . Completion $ \st _now -> Decision { decisionTrace = [TraceVerifyPeerSnapshot result], @@ -432,13 +427,19 @@ jobVerifyPeerSnapshot srvPrefix decisionJobs = [] } job = do - ledgerPeers <- + result <- atomically $ do - check . (>= slot) =<< lpGetLatestSlot - accumulateBigLedgerStake <$> getRelayAccessPointsFromLedger srvPrefix ledgerCtx - completion $ snapshotPeers - `compareLedgerPeerSnapshotApproximate` - ledgerPeers + checkPoint <- demoConsensusAPI point + case checkPoint of + Nowhere -> return False + There () -> retry + Here pt -> return $ pt == point + return . Completion $ \st _now -> + Decision { + decisionTrace = [TraceVerifyPeerSnapshot result], + decisionState = st, + decisionJobs = [] } + -- |This job monitors for any changes in the big ledger peer snapshot -- and flips ledger state judgement private state so that monitoring action @@ -461,8 +462,8 @@ ledgerPeerSnapshotChange extraStateChange ledgerPeerSnapshot' <- readLedgerPeerSnapshot case (ledgerPeerSnapshot', ledgerPeerSnapshot) of (Nothing, _) -> retry - (Just (LedgerPeerSnapshot (slot, _)), Just (LedgerPeerSnapshot (slot', _))) - | slot == slot' -> retry + (Just (LedgerPeerSnapshot point _), Just (LedgerPeerSnapshot point' _)) + | point == point' -> retry _otherwise -> return $ \_now -> Decision { decisionTrace = [], diff --git a/ouroboros-network/src/Ouroboros/Network/PeerSelection/Governor/Types.hs b/ouroboros-network/src/Ouroboros/Network/PeerSelection/Governor/Types.hs index 7e0cb3f75df..f71d7824c75 100644 --- a/ouroboros-network/src/Ouroboros/Network/PeerSelection/Governor/Types.hs +++ b/ouroboros-network/src/Ouroboros/Network/PeerSelection/Governor/Types.hs @@ -127,6 +127,11 @@ module Ouroboros.Network.PeerSelection.Governor.Types , DemotionTimeoutException (..) ) where +import Control.Applicative (Alternative) +import Control.Concurrent.JobPool (Job) +import Control.Concurrent.Class.MonadSTM.Strict +import Control.Exception (Exception (..), SomeException, assert) +import Control.Monad.Class.MonadTime.SI import Data.Map.Strict (Map) import Data.Map.Strict qualified as Map import Data.Maybe (fromMaybe) @@ -136,18 +141,12 @@ import Data.Semigroup (Min (..)) import Data.Set (Set) import Data.Set qualified as Set import GHC.Stack (HasCallStack) - -import Control.Applicative (Alternative) -import Control.Concurrent.JobPool (Job) -import Control.Exception (Exception (..), SomeException, assert) -import Control.Monad.Class.MonadSTM -import Control.Monad.Class.MonadTime.SI import System.Random (StdGen) -import Control.Concurrent.Class.MonadSTM.Strict +import Cardano.Network.PeerSelection.Bootstrap (UseBootstrapPeers (..)) +import Ouroboros.Network.Block import Ouroboros.Network.ExitPolicy import Ouroboros.Network.NodeToNode.Version (DiffusionMode) -import Cardano.Network.PeerSelection.Bootstrap (UseBootstrapPeers (..)) import Ouroboros.Network.PeerSelection.LedgerPeers.Type import Ouroboros.Network.PeerSelection.PeerSharing (PeerSharing) import Ouroboros.Network.PeerSelection.PublicRootPeers (PublicRootPeers) @@ -718,7 +717,10 @@ data PeerSelectionState extraState extraFlags extraPeers peeraddr peerconn = -- considering them all to have bad connectivity. -- Should also take account of DNS failures for root peer set. -- lastSuccessfulNetworkEvent :: Time - } deriving Show + } + +deriving instance (Show LedgerPeerSnapshot, Show extraFlags, Show peeraddr, Show extraPeers, Show peerconn, Show extraState, StandardHash LedgerPeerSnapshot, Ord peeraddr) + => Show (PeerSelectionState extraState extraFlags extraPeers peeraddr peerconn) -- | A node is classified as `LocalRootsOnly` if it is a hidden relay or -- a BP, e.g. if it is configured such that it can only have a chance to be @@ -1897,4 +1899,5 @@ deriving instance ( Show extraState , Show extraPeers , Ord peeraddr , Show peeraddr + , StandardHash LedgerPeerSnapshot ) => Show (DebugPeerSelection extraState extraFlags extraPeers peeraddr) diff --git a/ouroboros-network/src/Ouroboros/Network/PeerSelection/LedgerPeers.hs b/ouroboros-network/src/Ouroboros/Network/PeerSelection/LedgerPeers.hs index 87594f5d948..484b981c19c 100644 --- a/ouroboros-network/src/Ouroboros/Network/PeerSelection/LedgerPeers.hs +++ b/ouroboros-network/src/Ouroboros/Network/PeerSelection/LedgerPeers.hs @@ -2,11 +2,14 @@ {-# LANGUAGE CPP #-} {-# LANGUAGE DerivingStrategies #-} {-# LANGUAGE DuplicateRecordFields #-} +{-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE GADTs #-} {-# LANGUAGE LambdaCase #-} {-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE UndecidableInstances #-} #if __GLASGOW_HASKELL__ >= 908 {-# OPTIONS_GHC -Wno-x-partial #-} #endif @@ -388,7 +391,8 @@ data StakeMapOverSource = StakeMapOverSource { useLedgerAfter :: AfterSlot, srvPrefix :: SRVPrefix } - deriving Show + +deriving instance Show LedgerPeerSnapshot => Show StakeMapOverSource -- | Build up a stake map to sample ledger peers from. The SlotNo, if different from 0, -- indicates that the maps are the stake pools from the snapshot taken from the particular