Add UseRecentLedger constructor

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)]`

This allows to create a new interface function similar to the old one:

`getLedgerPeersFromSlotNo :: MonadSTM m => LedgerPeersConsensusInterface m -> (Maybe SlotNo -> STM m LedgerPeers)`

That abides buy 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';

Adds a test that checks this invariants

ouroboros-network/CHANGELOG.md

@@ -4,6 +4,14 @@
 
 ### Breaking changes
 
+* Added `UseRecentLedger` to `UseLedger` type .
+
+- 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)]`
+
 ### Non-breaking changes
 
 ## 0.8.2.0

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 (..)
@@ -51,7 +55,10 @@ import           Ouroboros.Network.PeerSelection.RootPeersDNS
 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,10 +70,21 @@ data IsLedgerPeer = IsLedgerPeer | IsNotLedgerPeer
 
 newtype NumberOfPeers = NumberOfPeers Word16 deriving Show
 
-newtype LedgerPeersConsensusInterface m = LedgerPeersConsensusInterface {
-      lpGetPeers :: SlotNo -> STM m (Maybe [(PoolStake, NonEmpty RelayAccessPoint)])
+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)]
     }
 
+data LedgerPeers = LedgerPeers LedgerStateJudgement [(PoolStake, NonEmpty RelayAccessPoint)]
+                 | BeforeSlot
+  deriving (Eq, Show)
+
 -- | Trace LedgerPeers events.
 data TraceLedgerPeers =
       PickedPeer RelayAccessPoint AccPoolStake PoolStake
@@ -111,6 +129,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 +260,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 +287,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)
 

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]

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