diff --git a/ouroboros-network-api/CHANGELOG.md b/ouroboros-network-api/CHANGELOG.md index f6194e90b11..e9841e3bc65 100644 --- a/ouroboros-network-api/CHANGELOG.md +++ b/ouroboros-network-api/CHANGELOG.md @@ -1,5 +1,13 @@ # Revision history for ouroboros-network-api +## 0.6.0.0 -- YYYY-MM-DD + +- Changed `LedgerConsensusInterface` type: + `LedgerConsensusInterface` now has to fill 3 STM actions: + - `lpGetLatestSlot :: STM m SlotNo` + - `lpGetLedgerStateJudgment :: STM m LedgerStateJudgement` + - `lpGetLedgerPeers :: STM m [(PoolStake, NonEmpty RelayAccessPoint)]` + ## 0.5.0.0 -- 2023-05-15 * Swapped `NodeToClientV_15` with `NodeToClientV_16`, e.g. handshake query 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 e9b7c8e6c32..972861d9f54 100644 --- a/ouroboros-network-api/src/Ouroboros/Network/PeerSelection/LedgerPeers/Type.hs +++ b/ouroboros-network-api/src/Ouroboros/Network/PeerSelection/LedgerPeers/Type.hs @@ -4,9 +4,16 @@ module Ouroboros.Network.PeerSelection.LedgerPeers.Type ( PoolStake (..) , AccPoolStake (..) + , LedgerStateJudgement (..) + , LedgerPeersConsensusInterface (..) ) where +import Cardano.Slotting.Slot (SlotNo) +import Control.Concurrent.Class.MonadSTM import Control.DeepSeq (NFData (..)) +import Data.List.NonEmpty (NonEmpty) +import Ouroboros.Network.PeerSelection.RelayAccessPoint + (RelayAccessPoint) -- | The relative stake of a stakepool in relation to the total amount staked. -- A value in the [0, 1] range. @@ -21,3 +28,15 @@ newtype PoolStake = PoolStake { unPoolStake :: Rational } -- newtype AccPoolStake = AccPoolStake { unAccPoolStake :: Rational } deriving (Eq, Num, Ord) + +data LedgerStateJudgement = YoungEnough | TooOld + deriving (Eq, Show) + +-- | Return ledger state information and ledger peers. +-- +data LedgerPeersConsensusInterface m = LedgerPeersConsensusInterface { + lpGetLatestSlot :: STM m SlotNo, + lpGetLedgerStateJudgement :: STM m LedgerStateJudgement, + lpGetLedgerPeers :: STM m [(PoolStake, NonEmpty RelayAccessPoint)] + } + diff --git a/ouroboros-network/CHANGELOG.md b/ouroboros-network/CHANGELOG.md index e00d0124d41..c70aaceb068 100644 --- a/ouroboros-network/CHANGELOG.md +++ b/ouroboros-network/CHANGELOG.md @@ -4,6 +4,10 @@ ### Breaking changes +* Added `UseRecentLedger` to `UseLedger` type . + +- Moved `LedgerConsensusInterface` type to `ouroboros-network-api`. + ### Non-breaking changes ## 0.8.2.0 diff --git a/ouroboros-network/src/Ouroboros/Network/PeerSelection/LedgerPeers.hs b/ouroboros-network/src/Ouroboros/Network/PeerSelection/LedgerPeers.hs index 1b3151f4d29..745ba9f8a3f 100644 --- a/ouroboros-network/src/Ouroboros/Network/PeerSelection/LedgerPeers.hs +++ b/ouroboros-network/src/Ouroboros/Network/PeerSelection/LedgerPeers.hs @@ -2,6 +2,7 @@ {-# LANGUAGE DerivingStrategies #-} {-# LANGUAGE GADTs #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE LambdaCase #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE ScopedTypeVariables #-} @@ -10,6 +11,9 @@ module Ouroboros.Network.PeerSelection.LedgerPeers ( DomainAccessPoint (..) , IP.IP (..) , LedgerPeersConsensusInterface (..) + , LedgerStateJudgement (..) + , LedgerPeers (..) + , getLedgerPeersFromSlotNo , RelayAccessPoint (..) , PoolStake (..) , AccPoolStake (..) @@ -45,13 +49,17 @@ import System.Random import Cardano.Slotting.Slot (SlotNo) import Ouroboros.Network.PeerSelection.LedgerPeers.Type - (AccPoolStake (..), PoolStake (..)) + (AccPoolStake (..), LedgerPeersConsensusInterface (..), + LedgerStateJudgement (..), PoolStake (..)) import Ouroboros.Network.PeerSelection.RootPeersDNS (DomainAccessPoint (..), RelayAccessPoint (..)) import Text.Printf -- | Only use the ledger after the given slot number. -data UseLedgerAfter = DontUseLedger | UseLedgerAfter SlotNo deriving (Eq, Show) +data UseLedgerAfter = DontUseLedger + | UseLedgerAfter SlotNo + | UseRecentLedger + deriving (Eq, Show) isLedgerPeersEnabled :: UseLedgerAfter -> Bool isLedgerPeersEnabled DontUseLedger = False @@ -63,9 +71,10 @@ data IsLedgerPeer = IsLedgerPeer | IsNotLedgerPeer newtype NumberOfPeers = NumberOfPeers Word16 deriving Show -newtype LedgerPeersConsensusInterface m = LedgerPeersConsensusInterface { - lpGetPeers :: SlotNo -> STM m (Maybe [(PoolStake, NonEmpty RelayAccessPoint)]) - } +data LedgerPeers = LedgerPeers LedgerStateJudgement + [(PoolStake, NonEmpty RelayAccessPoint)] + | BeforeSlot + deriving (Eq, Show) -- | Trace LedgerPeers events. data TraceLedgerPeers = @@ -111,6 +120,30 @@ instance Show TraceLedgerPeers where show FallingBackToBootstrapPeers = "Falling back to bootstrap peers" show DisabledLedgerPeers = "LedgerPeers is disabled" +-- | Internal API to deal with 'UseRecentLedger' and 'UseLedgerAfter' configuration +-- options +-- +-- Receiving the 'LedgerPeersConsensusInterface' we are able to compute a function that +-- given a maybe 'SlotNo' will give us 'LedgerPeers' according to the following +-- invariants: +-- +-- * If 'Nothing' is given then 'BeforeSlot' is not returned +-- * If 'Just slotNo' is given then 'BeforeSlot' is returned iff the latest slot is +-- before the 'slotNo' +-- * If 'Just slotNo' is given then 'LedgerPeers lsj peers' is returned iff the latest +-- slot is after the 'slotNo'; +-- +getLedgerPeersFromSlotNo + :: MonadSTM m + => LedgerPeersConsensusInterface m -> (Maybe SlotNo -> STM m LedgerPeers) +getLedgerPeersFromSlotNo LedgerPeersConsensusInterface{..} Nothing = + LedgerPeers <$> lpGetLedgerStateJudgement <*> lpGetLedgerPeers +getLedgerPeersFromSlotNo LedgerPeersConsensusInterface{..} (Just s) = do + curSlot <- lpGetLatestSlot + if curSlot < s + then pure BeforeSlot + else LedgerPeers <$> lpGetLedgerStateJudgement + <*> lpGetLedgerPeers -- | Convert a list of pools with stake to a Map keyed on the accumulated stake. -- Consensus provides a list of pairs of relative stake and corresponding relays for all usable @@ -218,7 +251,7 @@ ledgerPeersThread :: forall m peerAddr. -- ledger peers -> (Maybe (Set peerAddr, DiffTime) -> STM m ()) -> m Void -ledgerPeersThread inRng toPeerAddr tracer readUseLedgerAfter LedgerPeersConsensusInterface{..} doResolve +ledgerPeersThread inRng toPeerAddr tracer readUseLedgerAfter lpci doResolve getReq putRsp = go inRng (Time 0) Map.empty where @@ -245,8 +278,19 @@ ledgerPeersThread inRng toPeerAddr tracer readUseLedgerAfter LedgerPeersConsensu traceWith tracer DisabledLedgerPeers return (Map.empty, now) UseLedgerAfter slot -> do - peers_m <- atomically $ lpGetPeers slot - let peers = maybe Map.empty accPoolStake peers_m + peers <- (\case + BeforeSlot -> Map.empty + LedgerPeers _ peers -> accPoolStake peers + ) + <$> atomically (getLedgerPeersFromSlotNo lpci (Just slot)) + traceWith tracer $ FetchingNewLedgerState $ Map.size peers + return (peers, now) + UseRecentLedger -> do + peers <- (\case + BeforeSlot -> Map.empty + LedgerPeers _ peers -> accPoolStake peers + ) + <$> atomically (getLedgerPeersFromSlotNo lpci Nothing) traceWith tracer $ FetchingNewLedgerState $ Map.size peers return (peers, now) diff --git a/ouroboros-network/test/Test/LedgerPeers.hs b/ouroboros-network/test/Test/LedgerPeers.hs index fee0f56e553..4b83ad2dfbd 100644 --- a/ouroboros-network/test/Test/LedgerPeers.hs +++ b/ouroboros-network/test/Test/LedgerPeers.hs @@ -31,6 +31,8 @@ import Network.DNS (Domain) import Network.Socket (SockAddr) import Ouroboros.Network.PeerSelection.LedgerPeers +import Cardano.Slotting.Slot (SlotNo) +import Control.Concurrent.Class.MonadSTM import Test.QuickCheck import Test.Tasty (TestTree, testGroup) import Test.Tasty.QuickCheck (testProperty) @@ -40,6 +42,7 @@ tests :: TestTree tests = testGroup "LedgerPeers" [ testProperty "Pick 100%" prop_pick100 , testProperty "Pick" prop_pick + , testProperty "getLedgerPeersFromSlotNo invariants" prop_getLedgerPeersFromSlot ] newtype ArbitraryPortNumber = ArbitraryPortNumber { getArbitraryPortNumber :: PortNumber } @@ -58,6 +61,27 @@ instance Arbitrary ArbitraryRelayAccessPoint where , RelayAccessDomain "relay.iohk.example" . getArbitraryPortNumber <$> arbitrary ] +newtype ArbitraryLedgerStateJudgement = + ArbitraryLedgerStateJudgement { + getArbitraryLedgerStateJudgement :: LedgerStateJudgement + } deriving Show + +instance Arbitrary ArbitraryLedgerStateJudgement where + arbitrary = + ArbitraryLedgerStateJudgement <$> + oneof [ pure YoungEnough + , pure TooOld + ] + +newtype ArbitrarySlotNo = + ArbitrarySlotNo { + getArbitrarySlotNo :: SlotNo + } deriving Show + +instance Arbitrary ArbitrarySlotNo where + arbitrary = + ArbitrarySlotNo . fromInteger <$> arbitrary + data StakePool = StakePool { spStake :: !Word64 , spRelay :: NonEmpty RelayAccessPoint @@ -124,7 +148,11 @@ prop_pick100 seed = ] ) where - interface = LedgerPeersConsensusInterface $ \_ -> pure (Just (Map.elems (accPoolStake sps))) + interface = + LedgerPeersConsensusInterface + (pure minBound) + (pure YoungEnough) + (pure (Map.elems (accPoolStake sps))) in ioProperty $ do tr' <- evaluateTrace (runSimTrace sim) @@ -162,7 +190,10 @@ prop_pick (LedgerPools lps) count seed = ) where interface :: LedgerPeersConsensusInterface (IOSim s) - interface = LedgerPeersConsensusInterface $ \_ -> pure (Just (Map.elems (accPoolStake lps))) + interface = LedgerPeersConsensusInterface + (pure minBound) + (pure YoungEnough) + (pure (Map.elems (accPoolStake lps))) domainMap :: Map Domain (Set IP) domainMap = Map.fromList [("relay.iohk.example", Set.singleton (read "2.2.2.2"))] @@ -212,6 +243,38 @@ prop_pick (LedgerPools lps) count seed = prop :: Property prop = prop_pick (LedgerPools [(PoolStake {unPoolStake = 1 % 1},RelayAccessAddress (read "1.1.1.1") 1016 :| [])]) 0 2 +prop_getLedgerPeersFromSlot :: ArbitrarySlotNo + -> ArbitraryLedgerStateJudgement + -> LedgerPools + -> Maybe ArbitrarySlotNo + -> Property +prop_getLedgerPeersFromSlot (ArbitrarySlotNo curSlot) + (ArbitraryLedgerStateJudgement lsj) + (LedgerPools lps) + mbSlot = + let sim :: IOSim m LedgerPeers + sim = atomically $ getLedgerPeersFromSlotNo interface (getArbitrarySlotNo <$> mbSlot) + + result :: LedgerPeers + result = runSimOrThrow sim + + in counterexample (show result) $ + case result of + LedgerPeers _ _ -> + case mbSlot of + Nothing -> property True + Just (ArbitrarySlotNo s) -> property (curSlot >= s) + BeforeSlot -> + case mbSlot of + Nothing -> property False + Just (ArbitrarySlotNo s) -> property (curSlot < s) + where + interface :: LedgerPeersConsensusInterface (IOSim s) + interface = LedgerPeersConsensusInterface + (pure curSlot) + (pure lsj) + (pure (Map.elems (accPoolStake lps))) + -- TODO: Belongs in iosim. data SimResult a = SimReturn a [String] | SimException SomeException [String] diff --git a/ouroboros-network/test/Test/Ouroboros/Network/Testnet/Simulation/Node.hs b/ouroboros-network/test/Test/Ouroboros/Network/Testnet/Simulation/Node.hs index 93d0391c2f9..4521e9cca44 100644 --- a/ouroboros-network/test/Test/Ouroboros/Network/Testnet/Simulation/Node.hs +++ b/ouroboros-network/test/Test/Ouroboros/Network/Testnet/Simulation/Node.hs @@ -80,7 +80,8 @@ import Ouroboros.Network.PeerSelection.Governor TracePeerSelection) import qualified Ouroboros.Network.PeerSelection.Governor as PeerSelection import Ouroboros.Network.PeerSelection.LedgerPeers - (LedgerPeersConsensusInterface (..), UseLedgerAfter (..)) + (LedgerPeersConsensusInterface (..), + LedgerStateJudgement (..), UseLedgerAfter (..)) import Ouroboros.Network.PeerSelection.PeerStateActions (PeerSelectionActionsTrace) import Ouroboros.Network.PeerSelection.RootPeersDNS @@ -912,7 +913,9 @@ diffusionSimulation , NodeKernel.iDomainMap = dMapVar , NodeKernel.iLedgerPeersConsensusInterface = LedgerPeersConsensusInterface - $ \_ -> return Nothing + (pure maxBound) + (pure TooOld) + (pure []) } shouldChainSyncExit :: StrictTVar m (Maybe BlockNo) -> BlockHeader -> m Bool