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 800263f9301..2ac1e348791 100644 --- a/ouroboros-network-api/src/Ouroboros/Network/PeerSelection/LedgerPeers/Type.hs +++ b/ouroboros-network-api/src/Ouroboros/Network/PeerSelection/LedgerPeers/Type.hs @@ -35,7 +35,8 @@ import Ouroboros.Network.PeerSelection.RelayAccessPoint (RelayAccessPoint) -- from the current ledger. Consensus uses CBOR. newtype LedgerPeerSnapshot = LedgerPeerSnapshot { unLedgerPeerSnapshot :: (WithOrigin SlotNo, [(AccPoolStake, (PoolStake, NonEmpty RelayAccessPoint))]) } - deriving newtype (Show, ToCBOR, FromCBOR) + deriving (Eq) + deriving newtype (Show, NFData, ToCBOR, FromCBOR) -- | Which ledger peers to pick. -- @@ -69,7 +70,7 @@ newtype PoolStake = PoolStake { unPoolStake :: Rational } -- newtype AccPoolStake = AccPoolStake { unAccPoolStake :: Rational } deriving (Eq, Ord, Show) - deriving newtype (Fractional, Num, FromCBOR, ToCBOR) -- CBOR to support LedgerPeerSnapshot + deriving newtype (Fractional, Num, NFData, FromCBOR, ToCBOR) -- CBOR to support LedgerPeerSnapshot -- | A boolean like type. Big ledger peers are the largest SPOs which control -- 90% of staked stake. diff --git a/ouroboros-network/ouroboros-network.cabal b/ouroboros-network/ouroboros-network.cabal index e4fbc5266f4..1ccd74e975e 100644 --- a/ouroboros-network/ouroboros-network.cabal +++ b/ouroboros-network/ouroboros-network.cabal @@ -166,6 +166,7 @@ library sim-tests-lib QuickCheck, aeson, array, + cardano-binary, cborg, containers, deepseq, diff --git a/ouroboros-network/sim-tests-lib/Test/Ouroboros/Network/LedgerPeers.hs b/ouroboros-network/sim-tests-lib/Test/Ouroboros/Network/LedgerPeers.hs index ee7c8a48f3e..923c86d7226 100644 --- a/ouroboros-network/sim-tests-lib/Test/Ouroboros/Network/LedgerPeers.hs +++ b/ouroboros-network/sim-tests-lib/Test/Ouroboros/Network/LedgerPeers.hs @@ -8,6 +8,8 @@ module Test.Ouroboros.Network.LedgerPeers where +import Codec.CBOR.FlatTerm +import Control.Concurrent.Class.MonadSTM.Strict import Control.Exception (SomeException (..)) import Control.Monad.Class.MonadAsync import Control.Monad.Class.MonadFork @@ -32,8 +34,8 @@ import System.Random import Network.DNS (Domain) -import Cardano.Slotting.Slot (SlotNo, WithOrigin (..)) -import Control.Concurrent.Class.MonadSTM.Strict +import Cardano.Binary +import Cardano.Slotting.Slot (SlotNo (..), WithOrigin (..)) import Ouroboros.Network.PeerSelection.LedgerPeers import Ouroboros.Network.PeerSelection.RelayAccessPoint import Ouroboros.Network.PeerSelection.RootPeersDNS @@ -50,6 +52,7 @@ tests = testGroup "Ouroboros.Network.LedgerPeers" , testProperty "Pick" prop_pick , testProperty "accBigPoolStake" prop_accBigPoolStake , testProperty "getLedgerPeers invariants" prop_getLedgerPeers + , testProperty "LedgerPeerSnapshot encode/decode" prop_ledgerPeerSnapshot ] newtype ArbitraryPortNumber = ArbitraryPortNumber { getArbitraryPortNumber :: PortNumber } @@ -95,7 +98,7 @@ newtype ArbitrarySlotNo = -- of the tests we run. instance Arbitrary ArbitrarySlotNo where arbitrary = - ArbitrarySlotNo . fromInteger <$> arbitrary + ArbitrarySlotNo . SlotNo <$> arbitrarySizedBoundedIntegral data StakePool = StakePool { spStake :: !Word64 @@ -367,6 +370,24 @@ prop_getLedgerPeers (ArbitrarySlotNo curSlot) (pure lsj) (pure (Map.elems (accPoolStake lps))) +-- | Tests if the CBOR encoding is valid, and whether a round +-- trip results in the original peer snapshot value. +-- +prop_ledgerPeerSnapshot :: ArbitrarySlotNo + -> LedgerPools + -> Property +prop_ledgerPeerSnapshot (ArbitrarySlotNo slot) + (LedgerPools pools) = + validFlatTerm encoded .&&. either (const False) (snapshot ==) decoded + where + poolStakeWithAccumulation = Map.assocs . accPoolStake $ pools + originOrSlot = if slot == 0 + then Origin + else At slot + snapshot = LedgerPeerSnapshot (originOrSlot, poolStakeWithAccumulation) + encoded = toFlatTerm . toCBOR $ snapshot + decoded = fromFlatTerm fromCBOR encoded + -- TODO: Belongs in iosim. data SimResult a = SimReturn a [String] | SimException SomeException [String] diff --git a/ouroboros-network/src/Ouroboros/Network/PeerSelection/LedgerPeers.hs b/ouroboros-network/src/Ouroboros/Network/PeerSelection/LedgerPeers.hs index d92e756fd91..65b92bb6bc2 100644 --- a/ouroboros-network/src/Ouroboros/Network/PeerSelection/LedgerPeers.hs +++ b/ouroboros-network/src/Ouroboros/Network/PeerSelection/LedgerPeers.hs @@ -224,9 +224,7 @@ ledgerPeersThread PeerActionsDNS { paDnsSemaphore } WithLedgerPeersArgs { wlpRng, - wlpConsensusInterface = wlpConsensusInterface@LedgerPeersConsensusInterface { - lpGetLatestSlot, - lpGetLedgerStateJudgement }, + wlpConsensusInterface, wlpTracer, wlpGetUseLedgerPeers, wlpGetLedgerPeerSnapshot } @@ -260,25 +258,25 @@ ledgerPeersThread PeerActionsDNS { traceWith wlpTracer DisabledLedgerPeers return (Map.empty, Map.empty, now) UseLedgerPeers ula -> do - (ledgerStateJudgement, consensusSlotNo, consensusPeers, peerSnapshot) <- - atomically ((,,,) <$> lpGetLedgerStateJudgement - <*> lpGetLatestSlot - <*> getLedgerPeers wlpConsensusInterface ula - <*> wlpGetLedgerPeerSnapshot) + (consensusSlotNo, consensusPeers, peerSnapshot) <- + atomically ((,,) <$> lpGetLatestSlot wlpConsensusInterface + <*> getLedgerPeers wlpConsensusInterface ula + <*> wlpGetLedgerPeerSnapshot) -- we have to assess which of, if any, peers we get from consensus vs. -- peers we may have from the snapshot file is more recent, and use that - let (accPoolStake -> peersStake, bigPeersStakeMap) = + (accPoolStake -> peersStake, bigPeersStakeMap) <- case (consensusSlotNo, consensusPeers, peerSnapshot) of (At t, LedgerPeers _ lp, Just (LedgerPeerSnapshot (At t', sp {- snapshot peer-}))) - | t' > t -> (lp, Map.fromAscList sp) - | otherwise -> (lp, accBigPoolStakeMap lp) + | t' > t -> traceWith wlpTracer UsingBigLedgerPeerSnapshot >> return (lp, Map.fromAscList sp) + | otherwise -> return (lp, accBigPoolStakeMap lp) - (_, LedgerPeers _ lp, Nothing) -> (lp, accBigPoolStakeMap lp) + (_, LedgerPeers _ lp, Nothing) -> return (lp, accBigPoolStakeMap lp) (_, _, Just (LedgerPeerSnapshot (At t', sp))) - | After slot <- ula, t' >= slot -> ([], Map.fromAscList sp) - otherwise -> ([], Map.empty) + | After slot <- ula, t' >= slot -> + traceWith wlpTracer UsingBigLedgerPeerSnapshot >> return ([], Map.fromAscList sp) + otherwise -> return ([], Map.empty) traceWith wlpTracer $ FetchingNewLedgerState (Map.size peersStake) (Map.size bigPeersStakeMap) return (peersStake, bigPeersStakeMap, now) diff --git a/ouroboros-network/src/Ouroboros/Network/PeerSelection/LedgerPeers/Common.hs b/ouroboros-network/src/Ouroboros/Network/PeerSelection/LedgerPeers/Common.hs index 36b9db269b2..e599515888f 100644 --- a/ouroboros-network/src/Ouroboros/Network/PeerSelection/LedgerPeers/Common.hs +++ b/ouroboros-network/src/Ouroboros/Network/PeerSelection/LedgerPeers/Common.hs @@ -57,6 +57,7 @@ data TraceLedgerPeers = | FallingBackToPublicRootPeers | NotEnoughBigLedgerPeers NumberOfPeers Int | NotEnoughLedgerPeers NumberOfPeers Int + | UsingBigLedgerPeerSnapshot instance Show TraceLedgerPeers where @@ -102,3 +103,4 @@ instance Show TraceLedgerPeers where "Resolution success " ++ show domain ++ " " ++ show l show (TraceLedgerPeersFailure domain err) = "Resolution failed " ++ show domain ++ " " ++ show err + show UsingBigLedgerPeerSnapshot = "Using peer snapshot for big ledger peers"