Merge #3377

3377: CAD-3444 p2p-governor changes from p2p-master r=coot a=coot

- p2p-governor: peer selection without gossip
- p2p-governor: localRootPersProvider
- p2p-governor: use ledger as a source for publicRootPeers
- p2p-governor: improved tracing when ledger peers is disabled
- p2p-governor: PoolStake: derive Real instance
- p2p-governor: force the list of ledger peers to WHNF
- p2p-governor: keep lookup results for different domains separate
- p2p-governor: basic churnGovernor based on random selection only
- p2p-governor: sleep between 3300s and 3900s between churns
- p2p-governor: Adjust number of active peers based on fetchmode
- p2p-governor: added PeerSelectionCounters and respective tracers.
- p2p-governor: change LocalRootPeers.toGroups to match fromGroups, and use in Show
- p2p-governor: fix a bug in the QC shrinker for the p2p governor mock environment
- p2p-governor: move QC utils to their own module
- p2p-governor: improve the Script shrinker
- p2p-governor: Restructure the p2p governor tests a bit: split, add and reorder
- p2p-governor: Slightly simplify the Arbitrary instance for PeerAddr
- p2p-governor: Make the arbitraryScriptOf generator more general and use it more
- p2p-governor: Generalise the LocalRootPeers instance for Arbitrary
- p2p-governor: Change the PickScript to pick elements not offsets.
- p2p-governor: Extend the shrinker tests: test that the shrinkers shrink!
- p2p-governor: Add a "no excessive busyness" test for the p2p governor
- p2p-governor: Adjust prop_governor_gossip_1hr to allow demotions
- p2p-governor: Adjust prop_governor_connstatus to allow demotions
- p2p-governor: Improve counterexamples for +prop_governor_connstatus
- p2p-governor: Improve the mock env pick script interpretation
- p2p-governor: Adjust playTimedScript to trace the initial value
- p2p-governor: Add new env tracers for public roots and gossips
- p2p-governor: Make gossip failure results take non-zero time
- p2p-governor: Add a new signal-based abstraction for expressing properties
- p2p-governor: New governor properties for making progress towards targets
- p2p-governor: Add a few misc comments and TODOs
- p2p-governor: Order p2p governor tests after the livelock test
- p2p-governor: Update the comment on the list of properties
- p2p-governor: Add review feedback
- p2p-governor: Fix prop_governor_target_known_1_valid_subset
- p2p-governor: Add more Signal primitives
- p2p-governor: Replace one use of Signal.primitiveTransformEvents
- p2p-governor: Adjust LocalRootPeers to require targets > 0
- p2p-governor: Minor correction in a comment
- p2p-governor: Fix the prop_governor_target_known_above property
- p2p-governor: Adjust established and active target properties for local roots
- p2p-governor: Add support for hitting the local root peer targets
- p2p-governor: Refactored localRootPeersProvider
- p2p-governor: Scale pool's stake by sqrt
- p2p-governor: new root peers configuration (#3079)
- p2p-governor: Refactored DNS resolution to use io-sim-classes
- p2p-governor: Added dns resolution tests
- p2p-governor: Process synchronous hot promotion errors
- p2p-governor: add some randomness to the reconnection delay


Co-authored-by: Marcin Szamotulski <profunctor@pm.me>
Co-authored-by: Karl Knutsson <karl.knutsson@iohk.io>
Co-authored-by: Armando Santos <armando@well-typed.com>
Co-authored-by: Duncan Coutts <duncan@well-typed.com>

ouroboros-consensus-shelley/ouroboros-consensus-shelley.cabal

@@ -54,10 +54,12 @@ library
                      , cardano-crypto-class
                      , cardano-ledger-core
                      , cardano-protocol-tpraos
+                     , cardano-prelude
                      , cardano-slotting
                      , cborg             >=0.2.2 && <0.3
                      , containers        >=0.5   && <0.7
                      , data-default-class
+                     , deepseq
                      , measures
                      , mtl               >=2.2   && <2.3
                      , nothunks

ouroboros-consensus-shelley/src/Ouroboros/Consensus/Shelley/Ledger/PeerSelection.hs

@@ -7,6 +7,7 @@
 {-# OPTIONS_GHC -Wno-orphans #-}
 module Ouroboros.Consensus.Shelley.Ledger.PeerSelection () where
 
+import           Control.DeepSeq (force)
 import           Data.Bifunctor (second)
 import           Data.Foldable (toList)
 import           Data.List (sortOn)
@@ -33,7 +34,7 @@ import           Ouroboros.Consensus.Shelley.Ledger.Ledger
 instance c ~ EraCrypto era
       => LedgerSupportsPeerSelection (ShelleyBlock era) where
   getPeers ShelleyLedgerState { shelleyLedgerState } = catMaybes
-      [ (poolStake,) <$> Map.lookup stakePool poolRelayAddresses
+      [ (poolStake,) <$> Map.lookup stakePool poolRelayAccessPoints
       | (stakePool, poolStake) <- orderByStake poolDistr
       ]
     where
@@ -63,35 +64,38 @@ instance c ~ EraCrypto era
               . SL.nesEs
               $ shelleyLedgerState
 
-      relayToRelayAddress :: SL.StakePoolRelay -> Maybe RelayAddress
-      relayToRelayAddress (SL.SingleHostAddr (SJust (Port port)) (SJust ipv4) _) =
-          Just $ RelayAddressAddr (IPv4 ipv4) (fromIntegral port)
-      relayToRelayAddress (SL.SingleHostAddr (SJust (Port port)) SNothing (SJust ipv6)) =
-          Just $ RelayAddressAddr (IPv6 ipv6) (fromIntegral port)
-      relayToRelayAddress (SL.SingleHostName (SJust (Port port)) dnsName) =
-          Just $ RelayAddressDomain $ DomainAddress (encodeUtf8 $ dnsToText dnsName) (fromIntegral port)
-      relayToRelayAddress _ =
+      relayToRelayAccessPoint :: SL.StakePoolRelay -> Maybe RelayAccessPoint
+      relayToRelayAccessPoint (SL.SingleHostAddr (SJust (Port port)) (SJust ipv4) _) =
+          Just $ RelayAccessAddress (IPv4 ipv4) (fromIntegral port)
+      relayToRelayAccessPoint (SL.SingleHostAddr (SJust (Port port))
+                                                  SNothing
+                                                 (SJust ipv6)) =
+          Just $ RelayAccessAddress (IPv6 ipv6) (fromIntegral port)
+      relayToRelayAccessPoint (SL.SingleHostName (SJust (Port port)) dnsName) =
+          Just $ RelayAccessDomain (encodeUtf8 $ dnsToText dnsName) (fromIntegral port)
+      relayToRelayAccessPoint _ =
           -- This could be an unsupported relay (SRV records) or an unusable
           -- relay such as a relay with an IP address but without a port number.
           Nothing
 
       -- | Note that a stake pool can have multiple registered relays
-      pparamsRelayAddresses ::
-           (RelayAddress -> StakePoolRelay)
+      pparamsRelayAccessPoints ::
+           (RelayAccessPoint -> StakePoolRelay)
         -> SL.PoolParams c
         -> Maybe (NonEmpty StakePoolRelay)
-      pparamsRelayAddresses injStakePoolRelay =
+      pparamsRelayAccessPoints injStakePoolRelay =
             NE.nonEmpty
-          . mapMaybe (fmap injStakePoolRelay . relayToRelayAddress)
+          . force
+          . mapMaybe (fmap injStakePoolRelay . relayToRelayAccessPoint)
           . toList
           . SL._poolRelays
 
       -- | Combine the stake pools registered in the future and the current pool
       -- parameters, and remove duplicates.
-      poolRelayAddresses ::
+      poolRelayAccessPoints ::
            Map (SL.KeyHash 'SL.StakePool c) (NonEmpty StakePoolRelay)
-      poolRelayAddresses =
+      poolRelayAccessPoints =
           Map.unionWith
             (\futureRelays currentRelays -> NE.nub (futureRelays <> currentRelays))
-            (Map.mapMaybe (pparamsRelayAddresses FutureRelay)  futurePoolParams)
-            (Map.mapMaybe (pparamsRelayAddresses CurrentRelay) poolParams)
+            (Map.mapMaybe (pparamsRelayAccessPoints FutureRelay)  futurePoolParams)
+            (Map.mapMaybe (pparamsRelayAccessPoints CurrentRelay) poolParams)

ouroboros-consensus/src/Ouroboros/Consensus/Ledger/SupportsPeerSelection.hs

@@ -2,34 +2,39 @@ module Ouroboros.Consensus.Ledger.SupportsPeerSelection (
     LedgerSupportsPeerSelection (..)
   , PoolStake (..)
   , StakePoolRelay (..)
-  , stakePoolRelayAddress
+  , stakePoolRelayAccessPoint
     -- * Re-exports for convenience
-  , DomainAddress (..)
+  , DomainAccessPoint (..)
   , IP (..)
   , PortNumber
-  , RelayAddress (..)
+  , RelayAccessPoint (..)
   ) where
 
+import           Control.DeepSeq (NFData (..))
 import           Data.List.NonEmpty (NonEmpty)
 
 import           Ouroboros.Network.PeerSelection.LedgerPeers
-                     (DomainAddress (..), IP (..), PoolStake (..), PortNumber,
-                     RelayAddress (..))
+                     (DomainAccessPoint (..), IP (..), PoolStake (..),
+                     PortNumber, RelayAccessPoint (..))
 
 import           Ouroboros.Consensus.Ledger.Abstract (LedgerState)
 
 -- | A relay registered for a stake pool
 data StakePoolRelay =
     -- | One of the current relays
-    CurrentRelay RelayAddress
+    CurrentRelay RelayAccessPoint
 
     -- | One of the future relays
-  | FutureRelay  RelayAddress
+  | FutureRelay  RelayAccessPoint
   deriving (Show, Eq)
 
-stakePoolRelayAddress :: StakePoolRelay -> RelayAddress
-stakePoolRelayAddress (CurrentRelay ra) = ra
-stakePoolRelayAddress (FutureRelay  ra) = ra
+instance NFData StakePoolRelay where
+    rnf (CurrentRelay ra) = rnf ra
+    rnf (FutureRelay  ra) = rnf ra
+
+stakePoolRelayAccessPoint :: StakePoolRelay -> RelayAccessPoint
+stakePoolRelayAccessPoint (CurrentRelay ra) = ra
+stakePoolRelayAccessPoint (FutureRelay  ra) = ra
 
 class LedgerSupportsPeerSelection blk where
   -- | Return peers registered in the ledger ordered by descending 'PoolStake'.

ouroboros-consensus/src/Ouroboros/Consensus/NodeKernel.hs

@@ -23,6 +23,9 @@ module Ouroboros.Consensus.NodeKernel (
   , initNodeKernel
   ) where
 
+
+
+import           Control.DeepSeq (force)
 import           Control.Monad
 import           Control.Monad.Except
 import           Data.Bifunctor (second)
@@ -735,14 +738,15 @@ getPeersFromCurrentLedger ::
      (IOLike m, LedgerSupportsPeerSelection blk)
   => NodeKernel m remotePeer localPeer blk
   -> (LedgerState blk -> Bool)
-  -> STM m (Maybe [(PoolStake, NonEmpty RelayAddress)])
+  -> STM m (Maybe [(PoolStake, NonEmpty RelayAccessPoint)])
 getPeersFromCurrentLedger kernel p = do
     immutableLedger <-
       ledgerState <$> ChainDB.getImmutableLedger (getChainDB kernel)
     return $ do
       guard (p immutableLedger)
       return
-        $ map (second (fmap stakePoolRelayAddress))
+        $ map (second (fmap stakePoolRelayAccessPoint))
+        $ force
         $ getPeers immutableLedger
 
 -- | Like 'getPeersFromCurrentLedger' but with a \"after slot number X\"
@@ -755,7 +759,7 @@ getPeersFromCurrentLedgerAfterSlot ::
      )
   => NodeKernel m remotePeer localPeer blk
   -> SlotNo
-  -> STM m (Maybe [(PoolStake, NonEmpty RelayAddress)])
+  -> STM m (Maybe [(PoolStake, NonEmpty RelayAccessPoint)])
 getPeersFromCurrentLedgerAfterSlot kernel slotNo =
     getPeersFromCurrentLedger kernel afterSlotNo
   where

ouroboros-network/ouroboros-network.cabal

@@ -77,8 +77,11 @@ library
                        Ouroboros.Network.PeerSelection.KnownPeers
                        Ouroboros.Network.PeerSelection.LedgerPeers
                        Ouroboros.Network.PeerSelection.LocalRootPeers
+                       Ouroboros.Network.PeerSelection.RelayAccessPoint
+                       Ouroboros.Network.PeerSelection.RootPeersDNS.DNSActions
                        Ouroboros.Network.PeerSelection.RootPeersDNS
                        Ouroboros.Network.PeerSelection.Governor
+                       Ouroboros.Network.PeerSelection.Simple
                        Ouroboros.Network.Protocol.ChainSync.Client
                        Ouroboros.Network.Protocol.ChainSync.ClientPipelined
                        Ouroboros.Network.Protocol.ChainSync.Codec
@@ -153,11 +156,13 @@ library
                        TypeFamilies,
                        TypeInType
   build-depends:       base              >=4.9 && <4.15,
+                       aeson,
                        async             >=2.2 && <2.3,
                        base16-bytestring,
                        bytestring        >=0.10 && <0.11,
                        cborg             >=0.2.1 && <0.3,
                        containers,
+                       deepseq,
                        directory,
                        dns,
                        fingertree        >=0.1.4.2 && <0.2,
@@ -263,6 +268,7 @@ test-suite test
   other-modules:       Ouroboros.Network.BlockFetch.Examples
                        Ouroboros.Network.MockNode
 
+                       Data.Signal
                        Test.AnchoredFragment
                        Test.Chain
                        Test.LedgerPeers
@@ -273,6 +279,8 @@ test-suite test
                        Test.Ouroboros.Network.PeerSelection
                        Test.Ouroboros.Network.PeerSelection.Instances
                        Test.Ouroboros.Network.PeerSelection.LocalRootPeers
+                       Test.Ouroboros.Network.PeerSelection.RootPeersDNS
+                       Test.Ouroboros.Network.PeerSelection.Json
                        Test.Ouroboros.Network.PeerSelection.MockEnvironment
                        Test.Ouroboros.Network.PeerSelection.PeerGraph
                        Test.Ouroboros.Network.PeerSelection.Script
@@ -283,24 +291,32 @@ test-suite test
                        Test.Socket
                        Test.PeerState
                        Test.Version
+                       Test.QuickCheck.Signal
+                       Test.QuickCheck.Utils
   default-language:    Haskell2010
   build-depends:       base,
                        QuickCheck,
+                       aeson,
                        array,
                        async,
                        bytestring,
                        cborg,
                        containers,
                        dns,
+                       deque,
                        hashable,
+                       iproute,
                        mtl,
                        network,
                        process,
+                       psqueues,
                        random,
                        serialise,
                        tasty,
                        tasty-hunit,
                        tasty-quickcheck,
+                       text,
+                       time,
 
                        cardano-prelude,
                        cardano-slotting,