peer-metrics: use NoThunks in PeerMetrics

Use NoThunks library to verify that we don't have any unevaluated
expressions in PeerMetric.

This patch also makes PeerMetric more strict to satisfy the test.
Apparently there was a small memory leak which goes away at every churn
interval when we actually use peer metric in order to demote the 20% of
worse performing peers.

.github/workflows/build.yml

@@ -50,7 +50,7 @@ jobs:
 
     - name: "Configure cabal.project.local"
       run: |
-        cp .github/workflows/cabal.project.local.Windows cabal.project.local
+        cp .github/workflows/cabal.project.local cabal.project.local
 
     - name: Update PATH
       run: |

.github/workflows/cabal.project.local.Windows → .github/workflows/cabal.project.local

@@ -4,6 +4,9 @@ ignore-project: False
 tests: True
 benchmarks: True
 
+package strict-stm
+  flags: +checktvarinvariant
+
 program-options
   ghc-options: -Werror
 
@@ -32,12 +35,3 @@ package network-mux
 
 package ouroboros-network
   flags: +ipv6 +cddl +asserts
-
-package HsOpenSSL
-  extra-include-dirs: D:/a/_temp/msys64/mingw64/include
-  extra-lib-dirs: D:/a/_temp/msys64/mingw64/lib
-  flags: +use-pkg-config
-
-package basement
-  extra-include-dirs: D:/a/_temp/msys64/mingw64/include
-  extra-lib-dirs: D:/a/_temp/msys64/mingw64/lib

ouroboros-network-api/src/Ouroboros/Network/SizeInBytes.hs

@@ -1,7 +1,10 @@
-{-# LANGUAGE DerivingVia #-}
+{-# LANGUAGE DerivingStrategies         #-}
+{-# LANGUAGE DerivingVia                #-}
+{-# LANGUAGE GeneralisedNewtypeDeriving #-}
 
 module Ouroboros.Network.SizeInBytes (SizeInBytes (..)) where
 
+import           Control.DeepSeq (NFData (..))
 import           Data.Word (Word32)
 
 import           NoThunks.Class (NoThunks (..))
@@ -13,3 +16,4 @@ newtype SizeInBytes = SizeInBytes { getSizeInBytes :: Word32 }
   deriving Real     via Word32
   deriving Integral via Word32
   deriving NoThunks via Word32
+  deriving newtype NFData

ouroboros-network-framework/ouroboros-network-framework.cabal

@@ -72,6 +72,7 @@ library
                      , bytestring      >=0.10  && <0.12
                      , cborg           >=0.2.1 && <0.3
                      , containers      >=0.5   && <0.7
+                     , deepseq
                      , dns                        < 4.0
                      , iproute         >=1.7   && < 1.8
                      , hashable

ouroboros-network-framework/src/Ouroboros/Network/Snocket.hs

@@ -42,6 +42,7 @@ module Ouroboros.Network.Snocket
   ) where
 
 import           Control.Exception
+import           Control.DeepSeq (NFData (..))
 import           Data.Bifoldable (Bifoldable (..))
 import           Data.Bifunctor (Bifunctor (..))
 import           Data.Hashable
@@ -197,7 +198,7 @@ instance Hashable LocalAddress where
     hashWithSalt s (LocalAddress path) = hashWithSalt s path
 
 newtype TestAddress addr = TestAddress { getTestAddress :: addr }
-  deriving (Eq, Ord, Typeable, Generic)
+  deriving (Eq, Ord, Typeable, Generic, NFData)
   deriving NoThunks via InspectHeap (TestAddress addr)
 
 instance Show addr => Show (TestAddress addr) where

ouroboros-network/CHANGELOG.md

@@ -6,6 +6,8 @@
 
 ### Non-breaking changes
 
+- Fixed a small memory leak in `PeerMetrics` (#4633).
+
 ## 0.8.2.0
 
 ### Breaking changes

ouroboros-network/ouroboros-network.cabal

@@ -102,6 +102,7 @@ library
                        bytestring        >=0.10 && <0.12,
                        cborg             >=0.2.1 && <0.3,
                        containers,
+                       deepseq,
                        dns,
                        hashable,
                        iproute,
@@ -124,7 +125,7 @@ library
                        ouroboros-network-api       ^>=0.5,
                        ouroboros-network-framework ^>=0.7,
                        ouroboros-network-protocols ^>=0.5.1.0,
-                       strict-stm,
+                       strict-stm                  ^>=1.1.0.1,
                        typed-protocols   >=0.1.0.4 && <1.0,
   if !os(windows)
     build-depends:     directory,
@@ -186,6 +187,7 @@ test-suite test
                        array,
                        cborg,
                        containers,
+                       deepseq,
                        dns,
                        hashable,
                        iproute,

ouroboros-network/src/Ouroboros/Network/PeerSelection/PeerMetric.hs

@@ -1,8 +1,13 @@
 {-# LANGUAGE BangPatterns        #-}
+{-# LANGUAGE DataKinds           #-}
+{-# LANGUAGE DeriveAnyClass      #-}
+{-# LANGUAGE DerivingVia         #-}
+{-# LANGUAGE DeriveGeneric       #-}
 {-# LANGUAGE GADTs               #-}
 {-# LANGUAGE NamedFieldPuns      #-}
 {-# LANGUAGE RankNTypes          #-}
 {-# LANGUAGE ScopedTypeVariables #-}
+{-# LANGUAGE StandaloneDeriving  #-}
 
 
 module Ouroboros.Network.PeerSelection.PeerMetric
@@ -29,6 +34,7 @@ module Ouroboros.Network.PeerSelection.PeerMetric
   ) where
 
 import           Control.Concurrent.Class.MonadSTM.Strict
+import           Control.DeepSeq (NFData (..))
 import           Control.Monad (when)
 import           Control.Monad.Class.MonadTime.SI
 import           Control.Tracer (Tracer (..), contramap, nullTracer)
@@ -41,6 +47,10 @@ import           Data.Maybe (fromMaybe)
 import           Data.Monoid (Sum (..))
 import           Data.OrdPSQ (OrdPSQ)
 import qualified Data.OrdPSQ as OrdPSQ
+import           GHC.Generics
+
+import           NoThunks.Class
+import           NoThunks.Class.Orphans () -- orphan instances
 
 import           Cardano.Slotting.Slot (SlotNo (..))
 import           Ouroboros.Network.DeltaQ (SizeInBytes)
@@ -56,6 +66,7 @@ newtype PeerMetricsConfiguration = PeerMetricsConfiguration {
       -- produced in one hour.
       maxEntriesToTrack :: Int
     }
+  deriving (Show, Generic, NoThunks)
 
 
 -- | Integer based metric ordered by 'SlotNo' which holds the peer and time.
@@ -111,6 +122,10 @@ data PeerMetricsState p = PeerMetricsState {
     --
     metricsConfig    :: !PeerMetricsConfiguration
   }
+  deriving Show
+  deriving Generic
+
+deriving instance NoThunks p => NoThunks (PeerMetricsState p)
 
 
 -- | Average results at a given slot.
@@ -120,31 +135,37 @@ data AverageMetrics = AverageMetrics {
     averageFetchynessBlocks :: !Int,
     averageFetchynessBytes  :: !Int
   }
-  deriving Show
+  deriving (Show, Generic, NoThunks)
 
 
 newPeerMetric
-    :: MonadSTM m
+    :: (MonadLabelledSTM m, NoThunks p, NFData p)
     => PeerMetricsConfiguration
     -> m (PeerMetrics m p)
 newPeerMetric = newPeerMetric' IntPSQ.empty IntPSQ.empty
 
 
 newPeerMetric'
-    :: MonadSTM m
+    :: (MonadLabelledSTM m, NoThunks p, NFData p)
     => SlotMetric p
     -> SlotMetric (p, SizeInBytes)
     -> PeerMetricsConfiguration
     -> m (PeerMetrics m p)
-newPeerMetric' headerMetrics fetchedMetrics metricsConfig =
-  PeerMetrics <$> newTVarIO PeerMetricsState {
-                                headerMetrics,
-                                fetchedMetrics,
-                                peerRegistry = OrdPSQ.empty,
-                                lastSeenRegistry = OrdPSQ.empty,
-                                lastSlotNo = SlotNo 0,
-                                metricsConfig
-                              }
+newPeerMetric' headerMetrics fetchedMetrics metricsConfig = atomically $ do
+  -- install nothunk invariant and evaluate `headerMetrics` and `fetchedMetrics
+  -- to normal form
+  a <- newTVarWithInvariant
+    (\a -> show <$> unsafeNoThunks a)
+    PeerMetricsState {
+      headerMetrics    = rnf headerMetrics `seq` headerMetrics,
+      fetchedMetrics   = rnf fetchedMetrics `seq` fetchedMetrics,
+      peerRegistry     = OrdPSQ.empty,
+      lastSeenRegistry = OrdPSQ.empty,
+      lastSlotNo       = SlotNo 0,
+      metricsConfig
+    }
+  labelTVar a "peermetrics"
+  return (PeerMetrics a)
 
 updateLastSlot :: SlotNo -> PeerMetricsState p -> PeerMetricsState p
 updateLastSlot slotNo state@PeerMetricsState { lastSlotNo }
@@ -228,8 +249,8 @@ fetchedMetricTracer config peerMetrics@PeerMetrics{peerMetricsVar} =
     bimap remoteAddress (\(_, slotNo, _) -> slotNo)
     `contramap`
     peerRegistryTracer peerMetrics
- <> (\(TraceLabelPeer con (bytes, slot, time)) ->
-       TraceLabelPeer (remoteAddress con, bytes) (slot, time))
+ <> (\(TraceLabelPeer ConnectionId { remoteAddress } (!bytes, slot, time)) ->
+       TraceLabelPeer (remoteAddress, bytes) (slot, time))
     `contramap`
      metricsTracer
        (fetchedMetrics <$> readTVar peerMetricsVar)
@@ -357,9 +378,11 @@ metricsTracer
 metricsTracer getMetrics writeMetrics PeerMetricsConfiguration { maxEntriesToTrack } =
     Tracer $ \(TraceLabelPeer !peer (!slot, !time)) -> do
       metrics <- getMetrics
-      case IntPSQ.lookup (slotToInt slot) metrics of
+      let !k = slotToInt slot
+          !v = (peer, time)
+      case IntPSQ.lookup k metrics of
            Nothing -> do
-             let metrics' = IntPSQ.insert (slotToInt slot) slot (peer, time) metrics
+             let metrics' = IntPSQ.insert k slot v metrics
              if IntPSQ.size metrics' > maxEntriesToTrack
              -- drop last element if the metric board is too large
              then case IntPSQ.minView metrics' of
@@ -371,8 +394,7 @@ metricsTracer getMetrics writeMetrics PeerMetricsConfiguration { maxEntriesToTra
              else writeMetrics metrics'
            Just (_, (_, oldTime)) ->
                when (oldTime > time) $
-                    writeMetrics (IntPSQ.insert (slotToInt slot) slot
-                                                (peer, time) metrics)
+                    writeMetrics (IntPSQ.insert k slot v metrics)
 
 
 joinedPeerMetricAt

ouroboros-network/test/Test/Ouroboros/Network/Diffusion/Node/NodeKernel.hs

@@ -1,3 +1,4 @@
+{-# LANGUAGE DeriveAnyClass      #-}
 {-# LANGUAGE DeriveGeneric       #-}
 {-# LANGUAGE FlexibleContexts    #-}
 {-# LANGUAGE NamedFieldPuns      #-}
@@ -33,6 +34,7 @@ import           GHC.Generics (Generic)
 import           Control.Applicative (Alternative)
 import qualified Control.Concurrent.Class.MonadSTM as LazySTM
 import           Control.Concurrent.Class.MonadSTM.Strict
+import           Control.DeepSeq (NFData (..))
 import           Control.Monad (replicateM, when)
 import           Control.Monad.Class.MonadAsync
 import           Control.Monad.Class.MonadThrow
@@ -94,6 +96,13 @@ data NtNAddr_
   | IPAddr IP.IP PortNumber
   deriving (Eq, Ord, Generic)
 
+-- we need to work around the lack of the `NFData IP` instance
+instance NFData NtNAddr_ where
+    rnf (EphemeralIPv4Addr p) = p `seq` ()
+    rnf (EphemeralIPv6Addr p) = p `seq` ()
+    rnf (IPAddr (IP.IPv4 ip) port) = ip `seq` port `seq` ()
+    rnf (IPAddr (IP.IPv6 ip) port) = rnf (IP.fromIPv6w ip) `seq` port `seq` ()
+
 instance Arbitrary NtNAddr_ where
   arbitrary = do
     -- TODO: Move this IP generator to ouroboros-network-testing

ouroboros-network/test/Test/Ouroboros/Network/Diffusion/Policies.hs

@@ -6,12 +6,12 @@
 {-# LANGUAGE ScopedTypeVariables #-}
 
 
-
 module Test.Ouroboros.Network.Diffusion.Policies where
 
 import           Control.Concurrent.Class.MonadSTM.Strict
 import           Control.Monad.Class.MonadTime.SI
 import           Control.Monad.IOSim (runSimOrThrow)
+import           Control.DeepSeq (rnf)
 import qualified Data.IntPSQ as Pq
 import           Data.List (foldl')
 import           Data.Map.Strict (Map)
@@ -22,6 +22,8 @@ import           Data.Word
 import           Network.Socket (SockAddr (..))
 import           System.Random
 
+import           NoThunks.Class.Orphans ()
+
 import           Cardano.Slotting.Slot (SlotNo (..))
 import           Ouroboros.Network.Diffusion.Policies
 import           Ouroboros.Network.ExitPolicy (ReconnectDelay (..))
@@ -40,7 +42,6 @@ tests = testGroup "Policies"
   , testProperty "WarmToCold" prop_randomDemotion
   ]
 
-
 newtype ArbitrarySockAddr = ArbitrarySockAddr SockAddr deriving (Eq, Ord, Show)
 
 instance Arbitrary ArbitrarySockAddr where
@@ -137,13 +138,13 @@ instance Arbitrary ArbitraryPolicyArguments where
 
 
 prop_hotToWarm :: ArbitraryPolicyArguments
-                 -> Int
-                 -> Property
+               -> Int
+               -> Property
 prop_hotToWarm args seed = runSimOrThrow $ prop_hotToWarmM args seed
 
 -- Verify that there are no peers worse than the peers picked for demotion.
 prop_hotToWarmM :: forall m.
-                   ( MonadSTM m
+                   ( MonadLabelledSTM m
                    , Monad (STM m)
                    )
                  => ArbitraryPolicyArguments
@@ -210,7 +211,7 @@ prop_randomDemotion args seed = runSimOrThrow $ prop_randomDemotionM args seed
 -- Verifies that Tepid (formerly hot) or failing peers are more likely to get
 -- demoted/forgotten.
 prop_randomDemotionM :: forall m.
-                        ( MonadSTM m
+                        ( MonadLabelledSTM m
                         , Monad (STM m)
                         )
                      => ArbitraryPolicyArguments

ouroboros-network/test/Test/Ouroboros/Network/PeerSelection/PeerMetric.hs

@@ -1,13 +1,16 @@
-{-# LANGUAGE LambdaCase          #-}
-{-# LANGUAGE NamedFieldPuns      #-}
-{-# LANGUAGE NumericUnderscores  #-}
-{-# LANGUAGE ScopedTypeVariables #-}
+{-# LANGUAGE DerivingStrategies         #-}
+{-# LANGUAGE GeneralisedNewtypeDeriving #-}
+{-# LANGUAGE LambdaCase                 #-}
+{-# LANGUAGE NamedFieldPuns             #-}
+{-# LANGUAGE NumericUnderscores         #-}
+{-# LANGUAGE ScopedTypeVariables        #-}
 
 module Test.Ouroboros.Network.PeerSelection.PeerMetric where
 
 
 import qualified Control.Concurrent.Class.MonadSTM as LazySTM
 import           Control.Concurrent.Class.MonadSTM.Strict
+import           Control.DeepSeq (NFData (..))
 import           Control.Monad (when)
 import           Control.Monad.Class.MonadAsync
 import           Control.Monad.Class.MonadTime.SI
@@ -32,6 +35,8 @@ import           Cardano.Slotting.Slot (SlotNo (..))
 
 import           Control.Monad.IOSim
 
+import           NoThunks.Class
+
 import           Ouroboros.Network.Testing.Data.Script
 import           TestLib.Utils (AllProperty (..))
 
@@ -50,7 +55,8 @@ tests = testGroup "Ouroboros.Network.PeerSelection.PeerMetric"
 
 
 newtype TestAddress = TestAddress Int
-  deriving (Show, Eq, Ord)
+  deriving stock   (Show, Eq, Ord)
+  deriving newtype (NoThunks, NFData)
 
 instance Arbitrary TestAddress where
     arbitrary = do
@@ -147,13 +153,14 @@ data PeerMetricsTrace = PeerMetricsTrace {
     }
   deriving Show
 
-
 simulatePeerMetricScript
   :: forall m.
      ( MonadAsync m
      , MonadDelay m
      , MonadTimer m
      , MonadMonotonicTime m
+     , MonadLabelledSTM m
+     , MonadTraceSTM m
      )
   => Tracer m PeerMetricsTrace
   -> PeerMetricsConfiguration