From 3f92c5718e117e8d1286f2065527419c4572dd72 Mon Sep 17 00:00:00 2001
From: Marcin Szamotulski <coot@coot.me>
Date: Fri, 20 Jan 2023 18:33:33 +0100
Subject: [PATCH] peer-metrics: makes it more strict

---
 ouroboros-network/CHANGELOG.md                |  1 +
 .../Network/PeerSelection/PeerMetric.hs       | 32 ++++++++-----------
 2 files changed, 15 insertions(+), 18 deletions(-)

diff --git a/ouroboros-network/CHANGELOG.md b/ouroboros-network/CHANGELOG.md
index 73461905a7c..5c2e38ec5ee 100644
--- a/ouroboros-network/CHANGELOG.md
+++ b/ouroboros-network/CHANGELOG.md
@@ -17,6 +17,7 @@
 * Limit concurrency used by dns resolution.  We only resolve up to 8 dns names
   concurrently for public / ledger peers and up to 2 for local root peers.
   This will affect how quickly node connects to ledger peers when it starts.
+* Improved memory footprint of peer metrics (#4620)
 
 ## 0.8.1.1
 
diff --git a/ouroboros-network/src/Ouroboros/Network/PeerSelection/PeerMetric.hs b/ouroboros-network/src/Ouroboros/Network/PeerSelection/PeerMetric.hs
index 43cf98f8387..f9fbb221c7f 100644
--- a/ouroboros-network/src/Ouroboros/Network/PeerSelection/PeerMetric.hs
+++ b/ouroboros-network/src/Ouroboros/Network/PeerSelection/PeerMetric.hs
@@ -85,31 +85,31 @@ data PeerMetricsState p = PeerMetricsState {
 
     -- | Header metrics.
     --
-    headerMetrics    :: SlotMetric p,
+    headerMetrics    :: !(SlotMetric p),
 
     -- | Fetch metrics.
     --
-    fetchedMetrics   :: SlotMetric (p, SizeInBytes),
+    fetchedMetrics   :: !(SlotMetric (p, SizeInBytes)),
 
     -- | Registry recording when a peer joined the board of 'PeerMetrics'.  The
     -- values are average header and fetched metrics.
     --
-    peerRegistry     :: PeerRegistry p,
+    peerRegistry     :: !(PeerRegistry p),
 
     -- | A registry which indicates when the last time a peer was seen.
     --
     -- If a peer hasn't been seen since the oldest recorded slot number, it will
     -- be removed.
     --
-    lastSeenRegistry :: LastSeenRegistry p,
+    lastSeenRegistry :: !(LastSeenRegistry p),
 
     -- | Latest slot registered in the leader board.
     --
-    lastSlotNo       :: SlotNo,
+    lastSlotNo       :: !SlotNo,
 
     -- | Metrics configuration.  Its kept here just for convenience.
     --
-    metricsConfig    :: PeerMetricsConfiguration
+    metricsConfig    :: !PeerMetricsConfiguration
   }
 
 
@@ -260,27 +260,23 @@ insertPeer :: forall p. Ord p
            -> SlotNo -- ^ current slot
            -> PeerMetricsState p
            -> PeerMetricsState p
-insertPeer p slotNo
+insertPeer p !slotNo
            peerMetricsState@PeerMetricsState { lastSeenRegistry, peerRegistry } =
     if p `OrdPSQ.member` lastSeenRegistry
     then peerMetricsState
     else case OrdPSQ.alter f p peerRegistry of
-           (False,  peerRegistry') -> peerMetricsState { peerRegistry = peerRegistry' }
+           (False, !peerRegistry') -> peerMetricsState { peerRegistry = peerRegistry' }
            (True,  _peerRegistry') -> peerMetricsState
   where
     f :: Maybe (SlotNo, AverageMetrics) -> (Bool, Maybe (SlotNo, AverageMetrics))
     f a@Just {} = (True,  a)
-    f Nothing   = (False, Just ( slotNo
-                               , AverageMetrics {
-                                     averageUpstreamyness    = avg upstreamenessResults,
-                                     averageFetchynessBytes  = avg fetchynessBytesResults,
-                                     averageFetchynessBlocks = avg fetchynessBlocksResults
-                                   }
-                               ))
+    f Nothing   = (False, Just $! (slotNo, metrics))
       where
-        upstreamenessResults    = upstreamynessImpl    peerMetricsState
-        fetchynessBytesResults  = fetchynessBytesImpl  peerMetricsState
-        fetchynessBlocksResults = fetchynessBlocksImpl peerMetricsState
+        !metrics = AverageMetrics {
+                     averageUpstreamyness    = avg (upstreamynessImpl    peerMetricsState),
+                     averageFetchynessBytes  = avg (fetchynessBytesImpl  peerMetricsState),
+                     averageFetchynessBlocks = avg (fetchynessBlocksImpl peerMetricsState)
+                   }
 
     avg :: Map p Int -> Int
     avg m | Map.null m = 0