p2p-governor: force the list of ledger peers to WHNF

IntersectMBO · Sep 27, 2021 · 84c4c02 · 84c4c02
1 parent 7a913f2
commit 84c4c02
Show file tree

Hide file tree

Showing 6 changed files with 33 additions and 5 deletions.
diff --git a/ouroboros-consensus-shelley/ouroboros-consensus-shelley.cabal b/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

diff --git a/ouroboros-consensus-shelley/src/Ouroboros/Consensus/Shelley/Ledger/PeerSelection.hs b/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)
@@ -65,11 +66,11 @@ instance c ~ EraCrypto era
 
       relayToRelayAddress :: SL.StakePoolRelay -> Maybe RelayAddress
       relayToRelayAddress (SL.SingleHostAddr (SJust (Port port)) (SJust ipv4) _) =
-          Just $ RelayAddressAddr (IPv4 ipv4) (fromIntegral port)
+          Just $ RelayAddress (IPv4 ipv4) (fromIntegral port)
       relayToRelayAddress (SL.SingleHostAddr (SJust (Port port)) SNothing (SJust ipv6)) =
-          Just $ RelayAddressAddr (IPv6 ipv6) (fromIntegral port)
+          Just $ RelayAddress (IPv6 ipv6) (fromIntegral port)
       relayToRelayAddress (SL.SingleHostName (SJust (Port port)) dnsName) =
-          Just $ RelayAddressDomain $ DomainAddress (encodeUtf8 $ dnsToText dnsName) (fromIntegral port)
+          Just $ RelayDomain $ DomainAddress (encodeUtf8 $ dnsToText dnsName) (fromIntegral port)
       relayToRelayAddress _ =
           -- 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.
@@ -82,6 +83,7 @@ instance c ~ EraCrypto era
         -> Maybe (NonEmpty StakePoolRelay)
       pparamsRelayAddresses injStakePoolRelay =
             NE.nonEmpty
+          . force
           . mapMaybe (fmap injStakePoolRelay . relayToRelayAddress)
           . toList
           . SL._poolRelays

diff --git a/ouroboros-consensus/src/Ouroboros/Consensus/Ledger/SupportsPeerSelection.hs b/ouroboros-consensus/src/Ouroboros/Consensus/Ledger/SupportsPeerSelection.hs
@@ -10,6 +10,7 @@ module Ouroboros.Consensus.Ledger.SupportsPeerSelection (
   , RelayAddress (..)
   ) where
 
+import           Control.DeepSeq (NFData (..))
 import           Data.List.NonEmpty (NonEmpty)
 
 import           Ouroboros.Network.PeerSelection.LedgerPeers
@@ -27,6 +28,10 @@ data StakePoolRelay =
   | FutureRelay  RelayAddress
   deriving (Show, Eq)
 
+instance NFData StakePoolRelay where
+    rnf (CurrentRelay ra) = rnf ra
+    rnf (FutureRelay  ra) = rnf ra
+
 stakePoolRelayAddress :: StakePoolRelay -> RelayAddress
 stakePoolRelayAddress (CurrentRelay ra) = ra
 stakePoolRelayAddress (FutureRelay  ra) = ra

diff --git a/ouroboros-consensus/src/Ouroboros/Consensus/NodeKernel.hs b/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)
@@ -743,6 +746,7 @@ getPeersFromCurrentLedger kernel p = do
       guard (p immutableLedger)
       return
         $ map (second (fmap stakePoolRelayAddress))
+        $ force
         $ getPeers immutableLedger
 
 -- | Like 'getPeersFromCurrentLedger' but with a \"after slot number X\"

diff --git a/ouroboros-network/ouroboros-network.cabal b/ouroboros-network/ouroboros-network.cabal
@@ -159,6 +159,7 @@ library
                        bytestring        >=0.10 && <0.11,
                        cborg             >=0.2.1 && <0.3,
                        containers,
+                       deepseq,
                        directory,
                        dns,
                        fingertree        >=0.1.4.2 && <0.2,

diff --git a/ouroboros-network/src/Ouroboros/Network/PeerSelection/LedgerPeers.hs b/ouroboros-network/src/Ouroboros/Network/PeerSelection/LedgerPeers.hs
@@ -1,4 +1,5 @@
 {-# LANGUAGE BangPatterns               #-}
+{-# LANGUAGE DerivingStrategies         #-}
 {-# LANGUAGE GADTs                      #-}
 {-# LANGUAGE GeneralizedNewtypeDeriving #-}
 {-# LANGUAGE OverloadedStrings          #-}
@@ -23,6 +24,7 @@ module Ouroboros.Network.PeerSelection.LedgerPeers (
     ) where
 
 
+import           Control.DeepSeq (NFData (..))
 import           Control.Monad (when)
 import           Control.Monad.Class.MonadAsync
 import           Control.Monad.Class.MonadSTM.Strict
@@ -103,15 +105,27 @@ instance Show TraceLedgerPeers where
 
 -- | A relay can have either an IP address and a port number or
 -- a domain with a port number
-data RelayAddress = RelayDomain DomainAddress
-                  | RelayAddress IP.IP Socket.PortNumber
+data RelayAddress = RelayDomain !DomainAddress
+                  | RelayAddress !IP.IP !Socket.PortNumber
                   deriving (Show, Eq, Ord)
 
+-- 'IP' nor 'IPv6' is strict, 'IPv4' is strict only because it's a newtype for
+-- a primitive type ('Word32').
+--
+instance NFData RelayAddress where
+  rnf (RelayDomain domain) = domain `seq` ()
+  rnf (RelayAddress ip !_port) =
+    case ip of
+      IP.IPv4 ipv4 -> rnf (IP.fromIPv4w ipv4)
+      IP.IPv6 ipv6 -> rnf (IP.fromIPv6w ipv6)
+
 -- | 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, Fractional, Num, Ord, Show)
+  deriving newtype NFData
+
 
 -- | 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].