{-# LANGUAGE BangPatterns        #-}
{-# LANGUAGE DataKinds           #-}
{-# LANGUAGE DeriveAnyClass      #-}
{-# LANGUAGE DeriveGeneric       #-}
{-# LANGUAGE GADTs               #-}
{-# LANGUAGE NamedFieldPuns      #-}
{-# LANGUAGE RankNTypes          #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE StandaloneDeriving  #-}


module Ouroboros.Network.PeerSelection.PeerMetric
  ( -- * Peer metrics
    PeerMetrics
  , PeerMetricsConfiguration (..)
  , newPeerMetric
    -- * Metric calculations
  , joinedPeerMetricAt
  , upstreamyness
  , fetchynessBytes
  , fetchynessBlocks
    -- * Tracers
  , headerMetricTracer
  , fetchedMetricTracer
    -- * Metrics reporters
  , ReportPeerMetrics (..)
  , nullMetric
  , reportMetric
    -- * Internals
    -- only exported for testing purposes
  , SlotMetric
  , newPeerMetric'
  ) where

import Control.Concurrent.Class.MonadSTM.Strict.TVar.Checked
import Control.DeepSeq (NFData (..))
import Control.Monad (when)
import Control.Monad.Class.MonadSTM
import Control.Monad.Class.MonadTime.SI
import Control.Tracer (Tracer (..), contramap, nullTracer)
import Data.Bifunctor (Bifunctor (..))
import Data.IntPSQ (IntPSQ)
import Data.IntPSQ qualified as IntPSQ
import Data.Map.Strict (Map)
import Data.Map.Strict qualified as Map
import Data.Maybe (fromMaybe)
import Data.Monoid (Sum (..))
import Data.OrdPSQ (OrdPSQ)
import Data.OrdPSQ qualified as OrdPSQ
import GHC.Generics

import NoThunks.Class
import NoThunks.Class.Orphans ()

import Cardano.Slotting.Slot (SlotNo (..))
import Ouroboros.Network.DeltaQ (SizeInBytes)
import Ouroboros.Network.NodeToNode (ConnectionId (..))
import Ouroboros.Network.PeerSelection.PeerMetric.Type


newtype PeerMetricsConfiguration = PeerMetricsConfiguration {
      -- | The maximum numbers of slots we will store data for.  On some chains
      -- sometimes this corresponds to 1h worth of metrics *sighs*.
      --
      -- this number MUST correspond to number of headers / blocks which are
      -- produced in one hour.
      PeerMetricsConfiguration -> Int
maxEntriesToTrack :: Int
    }
  deriving (Int -> PeerMetricsConfiguration -> ShowS
[PeerMetricsConfiguration] -> ShowS
PeerMetricsConfiguration -> String
(Int -> PeerMetricsConfiguration -> ShowS)
-> (PeerMetricsConfiguration -> String)
-> ([PeerMetricsConfiguration] -> ShowS)
-> Show PeerMetricsConfiguration
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> PeerMetricsConfiguration -> ShowS
showsPrec :: Int -> PeerMetricsConfiguration -> ShowS
$cshow :: PeerMetricsConfiguration -> String
show :: PeerMetricsConfiguration -> String
$cshowList :: [PeerMetricsConfiguration] -> ShowS
showList :: [PeerMetricsConfiguration] -> ShowS
Show, (forall x.
 PeerMetricsConfiguration -> Rep PeerMetricsConfiguration x)
-> (forall x.
    Rep PeerMetricsConfiguration x -> PeerMetricsConfiguration)
-> Generic PeerMetricsConfiguration
forall x.
Rep PeerMetricsConfiguration x -> PeerMetricsConfiguration
forall x.
PeerMetricsConfiguration -> Rep PeerMetricsConfiguration x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cfrom :: forall x.
PeerMetricsConfiguration -> Rep PeerMetricsConfiguration x
from :: forall x.
PeerMetricsConfiguration -> Rep PeerMetricsConfiguration x
$cto :: forall x.
Rep PeerMetricsConfiguration x -> PeerMetricsConfiguration
to :: forall x.
Rep PeerMetricsConfiguration x -> PeerMetricsConfiguration
Generic, Context -> PeerMetricsConfiguration -> IO (Maybe ThunkInfo)
Proxy PeerMetricsConfiguration -> String
(Context -> PeerMetricsConfiguration -> IO (Maybe ThunkInfo))
-> (Context -> PeerMetricsConfiguration -> IO (Maybe ThunkInfo))
-> (Proxy PeerMetricsConfiguration -> String)
-> NoThunks PeerMetricsConfiguration
forall a.
(Context -> a -> IO (Maybe ThunkInfo))
-> (Context -> a -> IO (Maybe ThunkInfo))
-> (Proxy a -> String)
-> NoThunks a
$cnoThunks :: Context -> PeerMetricsConfiguration -> IO (Maybe ThunkInfo)
noThunks :: Context -> PeerMetricsConfiguration -> IO (Maybe ThunkInfo)
$cwNoThunks :: Context -> PeerMetricsConfiguration -> IO (Maybe ThunkInfo)
wNoThunks :: Context -> PeerMetricsConfiguration -> IO (Maybe ThunkInfo)
$cshowTypeOf :: Proxy PeerMetricsConfiguration -> String
showTypeOf :: Proxy PeerMetricsConfiguration -> String
NoThunks, PeerMetricsConfiguration -> ()
(PeerMetricsConfiguration -> ()) -> NFData PeerMetricsConfiguration
forall a. (a -> ()) -> NFData a
$crnf :: PeerMetricsConfiguration -> ()
rnf :: PeerMetricsConfiguration -> ()
NFData)


-- | Integer based metric ordered by 'SlotNo' which holds the peer and time.
--
-- The `p` parameter is truly polymorphic.  For `upstreamyness` and we use peer
-- address, and for `fetchyness` it is a pair of peer id and bytes downloaded.
--
type SlotMetric p = IntPSQ SlotNo (p, Time)

-- | Peer registry ordered by slot when a peer joined the peer metric.
--
type PeerRegistry p = OrdPSQ p SlotNo AverageMetrics

-- | Peer registry ordered by slot when a peer was last seen.
--
type LastSeenRegistry p = OrdPSQ p SlotNo ()

-- | Mutable peer metrics state accessible via 'STM'.
--
newtype PeerMetrics m p = PeerMetrics {
    forall (m :: * -> *) p.
PeerMetrics m p -> StrictTVar m (PeerMetricsState p)
peerMetricsVar :: StrictTVar m (PeerMetricsState p)
  }

-- | Internal state
--
data PeerMetricsState p = PeerMetricsState {

    -- | Header metrics.
    --
    forall p. PeerMetricsState p -> SlotMetric p
headerMetrics    :: !(SlotMetric p),

    -- | Fetch metrics.
    --
    forall p. PeerMetricsState p -> 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.
    --
    forall p. PeerMetricsState p -> 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.
    --
    forall p. PeerMetricsState p -> LastSeenRegistry p
lastSeenRegistry :: !(LastSeenRegistry p),

    -- | Latest slot registered in the leader board.
    --
    forall p. PeerMetricsState p -> SlotNo
lastSlotNo       :: !SlotNo,

    -- | Metrics configuration.  Its kept here just for convenience.
    --
    forall p. PeerMetricsState p -> PeerMetricsConfiguration
metricsConfig    :: !PeerMetricsConfiguration
  }
  deriving (Int -> PeerMetricsState p -> ShowS
[PeerMetricsState p] -> ShowS
PeerMetricsState p -> String
(Int -> PeerMetricsState p -> ShowS)
-> (PeerMetricsState p -> String)
-> ([PeerMetricsState p] -> ShowS)
-> Show (PeerMetricsState p)
forall p. Show p => Int -> PeerMetricsState p -> ShowS
forall p. Show p => [PeerMetricsState p] -> ShowS
forall p. Show p => PeerMetricsState p -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: forall p. Show p => Int -> PeerMetricsState p -> ShowS
showsPrec :: Int -> PeerMetricsState p -> ShowS
$cshow :: forall p. Show p => PeerMetricsState p -> String
show :: PeerMetricsState p -> String
$cshowList :: forall p. Show p => [PeerMetricsState p] -> ShowS
showList :: [PeerMetricsState p] -> ShowS
Show, (forall x. PeerMetricsState p -> Rep (PeerMetricsState p) x)
-> (forall x. Rep (PeerMetricsState p) x -> PeerMetricsState p)
-> Generic (PeerMetricsState p)
forall x. Rep (PeerMetricsState p) x -> PeerMetricsState p
forall x. PeerMetricsState p -> Rep (PeerMetricsState p) x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
forall p x. Rep (PeerMetricsState p) x -> PeerMetricsState p
forall p x. PeerMetricsState p -> Rep (PeerMetricsState p) x
$cfrom :: forall p x. PeerMetricsState p -> Rep (PeerMetricsState p) x
from :: forall x. PeerMetricsState p -> Rep (PeerMetricsState p) x
$cto :: forall p x. Rep (PeerMetricsState p) x -> PeerMetricsState p
to :: forall x. Rep (PeerMetricsState p) x -> PeerMetricsState p
Generic, Context -> PeerMetricsState p -> IO (Maybe ThunkInfo)
Proxy (PeerMetricsState p) -> String
(Context -> PeerMetricsState p -> IO (Maybe ThunkInfo))
-> (Context -> PeerMetricsState p -> IO (Maybe ThunkInfo))
-> (Proxy (PeerMetricsState p) -> String)
-> NoThunks (PeerMetricsState p)
forall p.
NoThunks p =>
Context -> PeerMetricsState p -> IO (Maybe ThunkInfo)
forall p. NoThunks p => Proxy (PeerMetricsState p) -> String
forall a.
(Context -> a -> IO (Maybe ThunkInfo))
-> (Context -> a -> IO (Maybe ThunkInfo))
-> (Proxy a -> String)
-> NoThunks a
$cnoThunks :: forall p.
NoThunks p =>
Context -> PeerMetricsState p -> IO (Maybe ThunkInfo)
noThunks :: Context -> PeerMetricsState p -> IO (Maybe ThunkInfo)
$cwNoThunks :: forall p.
NoThunks p =>
Context -> PeerMetricsState p -> IO (Maybe ThunkInfo)
wNoThunks :: Context -> PeerMetricsState p -> IO (Maybe ThunkInfo)
$cshowTypeOf :: forall p. NoThunks p => Proxy (PeerMetricsState p) -> String
showTypeOf :: Proxy (PeerMetricsState p) -> String
NoThunks, PeerMetricsState p -> ()
(PeerMetricsState p -> ()) -> NFData (PeerMetricsState p)
forall p. NFData p => PeerMetricsState p -> ()
forall a. (a -> ()) -> NFData a
$crnf :: forall p. NFData p => PeerMetricsState p -> ()
rnf :: PeerMetricsState p -> ()
NFData)


-- | Average results at a given slot.
--
data AverageMetrics = AverageMetrics {
    AverageMetrics -> Int
averageUpstreamyness    :: !Int,
    AverageMetrics -> Int
averageFetchynessBlocks :: !Int,
    AverageMetrics -> Int
averageFetchynessBytes  :: !Int
  }
  deriving (Int -> AverageMetrics -> ShowS
[AverageMetrics] -> ShowS
AverageMetrics -> String
(Int -> AverageMetrics -> ShowS)
-> (AverageMetrics -> String)
-> ([AverageMetrics] -> ShowS)
-> Show AverageMetrics
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> AverageMetrics -> ShowS
showsPrec :: Int -> AverageMetrics -> ShowS
$cshow :: AverageMetrics -> String
show :: AverageMetrics -> String
$cshowList :: [AverageMetrics] -> ShowS
showList :: [AverageMetrics] -> ShowS
Show, (forall x. AverageMetrics -> Rep AverageMetrics x)
-> (forall x. Rep AverageMetrics x -> AverageMetrics)
-> Generic AverageMetrics
forall x. Rep AverageMetrics x -> AverageMetrics
forall x. AverageMetrics -> Rep AverageMetrics x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cfrom :: forall x. AverageMetrics -> Rep AverageMetrics x
from :: forall x. AverageMetrics -> Rep AverageMetrics x
$cto :: forall x. Rep AverageMetrics x -> AverageMetrics
to :: forall x. Rep AverageMetrics x -> AverageMetrics
Generic, Context -> AverageMetrics -> IO (Maybe ThunkInfo)
Proxy AverageMetrics -> String
(Context -> AverageMetrics -> IO (Maybe ThunkInfo))
-> (Context -> AverageMetrics -> IO (Maybe ThunkInfo))
-> (Proxy AverageMetrics -> String)
-> NoThunks AverageMetrics
forall a.
(Context -> a -> IO (Maybe ThunkInfo))
-> (Context -> a -> IO (Maybe ThunkInfo))
-> (Proxy a -> String)
-> NoThunks a
$cnoThunks :: Context -> AverageMetrics -> IO (Maybe ThunkInfo)
noThunks :: Context -> AverageMetrics -> IO (Maybe ThunkInfo)
$cwNoThunks :: Context -> AverageMetrics -> IO (Maybe ThunkInfo)
wNoThunks :: Context -> AverageMetrics -> IO (Maybe ThunkInfo)
$cshowTypeOf :: Proxy AverageMetrics -> String
showTypeOf :: Proxy AverageMetrics -> String
NoThunks, AverageMetrics -> ()
(AverageMetrics -> ()) -> NFData AverageMetrics
forall a. (a -> ()) -> NFData a
$crnf :: AverageMetrics -> ()
rnf :: AverageMetrics -> ()
NFData)


newPeerMetric
    :: (MonadLabelledSTM m, NoThunks p, NFData p)
    => PeerMetricsConfiguration
    -> m (PeerMetrics m p)
newPeerMetric :: forall (m :: * -> *) p.
(MonadLabelledSTM m, NoThunks p, NFData p) =>
PeerMetricsConfiguration -> m (PeerMetrics m p)
newPeerMetric = SlotMetric p
-> SlotMetric (p, SizeInBytes)
-> PeerMetricsConfiguration
-> m (PeerMetrics m p)
forall (m :: * -> *) p.
(MonadLabelledSTM m, NoThunks p, NFData p) =>
SlotMetric p
-> SlotMetric (p, SizeInBytes)
-> PeerMetricsConfiguration
-> m (PeerMetrics m p)
newPeerMetric' SlotMetric p
forall p v. IntPSQ p v
IntPSQ.empty SlotMetric (p, SizeInBytes)
forall p v. IntPSQ p v
IntPSQ.empty


newPeerMetric'
    :: (MonadLabelledSTM m, NoThunks p, NFData p)
    => SlotMetric p
    -> SlotMetric (p, SizeInBytes)
    -> PeerMetricsConfiguration
    -> m (PeerMetrics m p)
newPeerMetric' :: forall (m :: * -> *) p.
(MonadLabelledSTM m, NoThunks p, NFData p) =>
SlotMetric p
-> SlotMetric (p, SizeInBytes)
-> PeerMetricsConfiguration
-> m (PeerMetrics m p)
newPeerMetric' SlotMetric p
headerMetrics SlotMetric (p, SizeInBytes)
fetchedMetrics PeerMetricsConfiguration
metricsConfig =
    case PeerMetricsState p -> ()
forall a. NFData a => a -> ()
rnf PeerMetricsState p
state of
      () -> STM m (PeerMetrics m p) -> m (PeerMetrics m p)
forall a. HasCallStack => STM m a -> m a
forall (m :: * -> *) a.
(MonadSTM m, HasCallStack) =>
STM m a -> m a
atomically (STM m (PeerMetrics m p) -> m (PeerMetrics m p))
-> STM m (PeerMetrics m p) -> m (PeerMetrics m p)
forall a b. (a -> b) -> a -> b
$ do
        a <- (PeerMetricsState p -> Maybe String)
-> PeerMetricsState p -> STM m (StrictTVar m (PeerMetricsState p))
forall (m :: * -> *) a.
(MonadSTM m, HasCallStack) =>
(a -> Maybe String) -> a -> STM m (StrictTVar m a)
newTVarWithInvariant (\PeerMetricsState p
a -> ThunkInfo -> String
forall a. Show a => a -> String
show (ThunkInfo -> String) -> Maybe ThunkInfo -> Maybe String
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> PeerMetricsState p -> Maybe ThunkInfo
forall a. NoThunks a => a -> Maybe ThunkInfo
unsafeNoThunks PeerMetricsState p
a)
                                  PeerMetricsState p
state
        labelTVar a "peermetrics"
        return (PeerMetrics a)
  where
    state :: PeerMetricsState p
state = PeerMetricsState {
                SlotMetric p
headerMetrics :: SlotMetric p
headerMetrics :: SlotMetric p
headerMetrics,
                SlotMetric (p, SizeInBytes)
fetchedMetrics :: SlotMetric (p, SizeInBytes)
fetchedMetrics :: SlotMetric (p, SizeInBytes)
fetchedMetrics,
                peerRegistry :: PeerRegistry p
peerRegistry     = PeerRegistry p
forall k p v. OrdPSQ k p v
OrdPSQ.empty,
                lastSeenRegistry :: LastSeenRegistry p
lastSeenRegistry = LastSeenRegistry p
forall k p v. OrdPSQ k p v
OrdPSQ.empty,
                lastSlotNo :: SlotNo
lastSlotNo       = Word64 -> SlotNo
SlotNo Word64
0,
                PeerMetricsConfiguration
metricsConfig :: PeerMetricsConfiguration
metricsConfig :: PeerMetricsConfiguration
metricsConfig
              }

updateLastSlot :: SlotNo -> PeerMetricsState p -> PeerMetricsState p
updateLastSlot :: forall p. SlotNo -> PeerMetricsState p -> PeerMetricsState p
updateLastSlot SlotNo
slotNo state :: PeerMetricsState p
state@PeerMetricsState { SlotNo
lastSlotNo :: forall p. PeerMetricsState p -> SlotNo
lastSlotNo :: SlotNo
lastSlotNo }
  | SlotNo
slotNo SlotNo -> SlotNo -> Bool
forall a. Ord a => a -> a -> Bool
> SlotNo
lastSlotNo = PeerMetricsState p
state { lastSlotNo = slotNo }
  | Bool
otherwise           = PeerMetricsState p
state


firstSlotNo :: PeerMetricsState p -> Maybe SlotNo
firstSlotNo :: forall p. PeerMetricsState p -> Maybe SlotNo
firstSlotNo PeerMetricsState {SlotMetric p
headerMetrics :: forall p. PeerMetricsState p -> SlotMetric p
headerMetrics :: SlotMetric p
headerMetrics, SlotMetric (p, SizeInBytes)
fetchedMetrics :: forall p. PeerMetricsState p -> SlotMetric (p, SizeInBytes)
fetchedMetrics :: SlotMetric (p, SizeInBytes)
fetchedMetrics} =
    (\(Int, SlotNo, (p, Time), SlotMetric p)
a (Int, SlotNo, ((p, SizeInBytes), Time),
 SlotMetric (p, SizeInBytes))
b -> SlotNo -> SlotNo -> SlotNo
forall a. Ord a => a -> a -> a
min ((Int, SlotNo, (p, Time), SlotMetric p) -> SlotNo
forall a b c. (a, SlotNo, b, c) -> SlotNo
f (Int, SlotNo, (p, Time), SlotMetric p)
a) ((Int, SlotNo, ((p, SizeInBytes), Time),
 SlotMetric (p, SizeInBytes))
-> SlotNo
forall a b c. (a, SlotNo, b, c) -> SlotNo
f (Int, SlotNo, ((p, SizeInBytes), Time),
 SlotMetric (p, SizeInBytes))
b))
      ((Int, SlotNo, (p, Time), SlotMetric p)
 -> (Int, SlotNo, ((p, SizeInBytes), Time),
     SlotMetric (p, SizeInBytes))
 -> SlotNo)
-> Maybe (Int, SlotNo, (p, Time), SlotMetric p)
-> Maybe
     ((Int, SlotNo, ((p, SizeInBytes), Time),
       SlotMetric (p, SizeInBytes))
      -> SlotNo)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> SlotMetric p -> Maybe (Int, SlotNo, (p, Time), SlotMetric p)
forall p v. Ord p => IntPSQ p v -> Maybe (Int, p, v, IntPSQ p v)
IntPSQ.minView SlotMetric p
headerMetrics
      Maybe
  ((Int, SlotNo, ((p, SizeInBytes), Time),
    SlotMetric (p, SizeInBytes))
   -> SlotNo)
-> Maybe
     (Int, SlotNo, ((p, SizeInBytes), Time),
      SlotMetric (p, SizeInBytes))
-> Maybe SlotNo
forall a b. Maybe (a -> b) -> Maybe a -> Maybe b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> SlotMetric (p, SizeInBytes)
-> Maybe
     (Int, SlotNo, ((p, SizeInBytes), Time),
      SlotMetric (p, SizeInBytes))
forall p v. Ord p => IntPSQ p v -> Maybe (Int, p, v, IntPSQ p v)
IntPSQ.minView SlotMetric (p, SizeInBytes)
fetchedMetrics
  where
    f :: (a, SlotNo, b, c) -> SlotNo
    f :: forall a b c. (a, SlotNo, b, c) -> SlotNo
f (a
_, SlotNo
slotNo, b
_, c
_) = SlotNo
slotNo


reportMetric
    :: forall m p.
       ( MonadSTM m
       , Ord p
       )
     => PeerMetricsConfiguration
     -> PeerMetrics m p
     -> ReportPeerMetrics m (ConnectionId p)
reportMetric :: forall (m :: * -> *) p.
(MonadSTM m, Ord p) =>
PeerMetricsConfiguration
-> PeerMetrics m p -> ReportPeerMetrics m (ConnectionId p)
reportMetric PeerMetricsConfiguration
config PeerMetrics m p
peerMetrics =
  Tracer (STM m) (TraceLabelPeer (ConnectionId p) (SlotNo, Time))
-> Tracer
     (STM m)
     (TraceLabelPeer (ConnectionId p) (SizeInBytes, SlotNo, Time))
-> ReportPeerMetrics m (ConnectionId p)
forall (m :: * -> *) peerAddr.
Tracer (STM m) (TraceLabelPeer peerAddr (SlotNo, Time))
-> Tracer
     (STM m) (TraceLabelPeer peerAddr (SizeInBytes, SlotNo, Time))
-> ReportPeerMetrics m peerAddr
ReportPeerMetrics (PeerMetricsConfiguration
-> PeerMetrics m p
-> Tracer (STM m) (TraceLabelPeer (ConnectionId p) (SlotNo, Time))
forall (m :: * -> *) p.
(MonadSTM m, Ord p) =>
PeerMetricsConfiguration
-> PeerMetrics m p
-> Tracer (STM m) (TraceLabelPeer (ConnectionId p) (SlotNo, Time))
headerMetricTracer  PeerMetricsConfiguration
config PeerMetrics m p
peerMetrics)
                    (PeerMetricsConfiguration
-> PeerMetrics m p
-> Tracer
     (STM m)
     (TraceLabelPeer (ConnectionId p) (SizeInBytes, SlotNo, Time))
forall (m :: * -> *) p.
(MonadSTM m, Ord p) =>
PeerMetricsConfiguration
-> PeerMetrics m p
-> Tracer
     (STM m)
     (TraceLabelPeer (ConnectionId p) (SizeInBytes, SlotNo, Time))
fetchedMetricTracer PeerMetricsConfiguration
config PeerMetrics m p
peerMetrics)

nullMetric
    :: MonadSTM m
    => ReportPeerMetrics m p
nullMetric :: forall (m :: * -> *) p. MonadSTM m => ReportPeerMetrics m p
nullMetric =
  Tracer (STM m) (TraceLabelPeer p (SlotNo, Time))
-> Tracer (STM m) (TraceLabelPeer p (SizeInBytes, SlotNo, Time))
-> ReportPeerMetrics m p
forall (m :: * -> *) peerAddr.
Tracer (STM m) (TraceLabelPeer peerAddr (SlotNo, Time))
-> Tracer
     (STM m) (TraceLabelPeer peerAddr (SizeInBytes, SlotNo, Time))
-> ReportPeerMetrics m peerAddr
ReportPeerMetrics Tracer (STM m) (TraceLabelPeer p (SlotNo, Time))
forall (m :: * -> *) a. Applicative m => Tracer m a
nullTracer Tracer (STM m) (TraceLabelPeer p (SizeInBytes, SlotNo, Time))
forall (m :: * -> *) a. Applicative m => Tracer m a
nullTracer


slotToInt :: SlotNo -> Int
slotToInt :: SlotNo -> Int
slotToInt = Word64 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Word64 -> Int) -> (SlotNo -> Word64) -> SlotNo -> Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. SlotNo -> Word64
unSlotNo


-- | Tracer which updates header metrics (upstreameness) and inserts new peers
-- into 'peerRegistry'.
--
headerMetricTracer
    :: forall m p.
       ( MonadSTM m
       , Ord p
       )
    => PeerMetricsConfiguration
    -> PeerMetrics m p
    -> Tracer (STM m) (TraceLabelPeer (ConnectionId p) (SlotNo, Time))
headerMetricTracer :: forall (m :: * -> *) p.
(MonadSTM m, Ord p) =>
PeerMetricsConfiguration
-> PeerMetrics m p
-> Tracer (STM m) (TraceLabelPeer (ConnectionId p) (SlotNo, Time))
headerMetricTracer PeerMetricsConfiguration
config peerMetrics :: PeerMetrics m p
peerMetrics@PeerMetrics{StrictTVar m (PeerMetricsState p)
peerMetricsVar :: forall (m :: * -> *) p.
PeerMetrics m p -> StrictTVar m (PeerMetricsState p)
peerMetricsVar :: StrictTVar m (PeerMetricsState p)
peerMetricsVar} =
    (ConnectionId p -> p)
-> ((SlotNo, Time) -> SlotNo)
-> TraceLabelPeer (ConnectionId p) (SlotNo, Time)
-> TraceLabelPeer p SlotNo
forall a b c d.
(a -> b) -> (c -> d) -> TraceLabelPeer a c -> TraceLabelPeer b d
forall (p :: * -> * -> *) a b c d.
Bifunctor p =>
(a -> b) -> (c -> d) -> p a c -> p b d
bimap ConnectionId p -> p
forall addr. ConnectionId addr -> addr
remoteAddress (SlotNo, Time) -> SlotNo
forall a b. (a, b) -> a
fst
    (TraceLabelPeer (ConnectionId p) (SlotNo, Time)
 -> TraceLabelPeer p SlotNo)
-> Tracer (STM m) (TraceLabelPeer p SlotNo)
-> Tracer (STM m) (TraceLabelPeer (ConnectionId p) (SlotNo, Time))
forall a' a. (a' -> a) -> Tracer (STM m) a -> Tracer (STM m) a'
forall (f :: * -> *) a' a.
Contravariant f =>
(a' -> a) -> f a -> f a'
`contramap`
    PeerMetrics m p -> Tracer (STM m) (TraceLabelPeer p SlotNo)
forall p (m :: * -> *).
(MonadSTM m, Ord p) =>
PeerMetrics m p -> Tracer (STM m) (TraceLabelPeer p SlotNo)
peerRegistryTracer PeerMetrics m p
peerMetrics
 Tracer (STM m) (TraceLabelPeer (ConnectionId p) (SlotNo, Time))
-> Tracer (STM m) (TraceLabelPeer (ConnectionId p) (SlotNo, Time))
-> Tracer (STM m) (TraceLabelPeer (ConnectionId p) (SlotNo, Time))
forall a. Semigroup a => a -> a -> a
<> (ConnectionId p -> p)
-> TraceLabelPeer (ConnectionId p) (SlotNo, Time)
-> TraceLabelPeer p (SlotNo, Time)
forall a b c. (a -> b) -> TraceLabelPeer a c -> TraceLabelPeer b c
forall (p :: * -> * -> *) a b c.
Bifunctor p =>
(a -> b) -> p a c -> p b c
first ConnectionId p -> p
forall addr. ConnectionId addr -> addr
remoteAddress
    (TraceLabelPeer (ConnectionId p) (SlotNo, Time)
 -> TraceLabelPeer p (SlotNo, Time))
-> Tracer (STM m) (TraceLabelPeer p (SlotNo, Time))
-> Tracer (STM m) (TraceLabelPeer (ConnectionId p) (SlotNo, Time))
forall a' a. (a' -> a) -> Tracer (STM m) a -> Tracer (STM m) a'
forall (f :: * -> *) a' a.
Contravariant f =>
(a' -> a) -> f a -> f a'
`contramap`
    STM m (SlotMetric p)
-> (SlotMetric p -> STM m ())
-> PeerMetricsConfiguration
-> Tracer (STM m) (TraceLabelPeer p (SlotNo, Time))
forall (m :: * -> *) p.
MonadSTM m =>
STM m (SlotMetric p)
-> (SlotMetric p -> STM m ())
-> PeerMetricsConfiguration
-> Tracer (STM m) (TraceLabelPeer p (SlotNo, Time))
metricsTracer
      (PeerMetricsState p -> SlotMetric p
forall p. PeerMetricsState p -> SlotMetric p
headerMetrics (PeerMetricsState p -> SlotMetric p)
-> STM m (PeerMetricsState p) -> STM m (SlotMetric p)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> StrictTVar m (PeerMetricsState p) -> STM m (PeerMetricsState p)
forall (m :: * -> *) a. MonadSTM m => StrictTVar m a -> STM m a
readTVar StrictTVar m (PeerMetricsState p)
peerMetricsVar)
      (\SlotMetric p
headerMetrics -> StrictTVar m (PeerMetricsState p)
-> (PeerMetricsState p -> PeerMetricsState p) -> STM m ()
forall (m :: * -> *) a.
MonadSTM m =>
StrictTVar m a -> (a -> a) -> STM m ()
modifyTVar StrictTVar m (PeerMetricsState p)
peerMetricsVar
                                    (\PeerMetricsState p
metrics -> PeerMetricsState p
metrics { headerMetrics }))
      PeerMetricsConfiguration
config


-- | Tracer which updates fetched metrics (fetchyness) and inserts new peers
-- into 'peerRegistry'.
--
fetchedMetricTracer
    :: forall m p.
       ( MonadSTM m
       , Ord p
       )
    => PeerMetricsConfiguration
    -> PeerMetrics m p
    -> Tracer (STM m) (TraceLabelPeer (ConnectionId p)
                                      ( SizeInBytes
                                      , SlotNo
                                      , Time
                                      ))
fetchedMetricTracer :: forall (m :: * -> *) p.
(MonadSTM m, Ord p) =>
PeerMetricsConfiguration
-> PeerMetrics m p
-> Tracer
     (STM m)
     (TraceLabelPeer (ConnectionId p) (SizeInBytes, SlotNo, Time))
fetchedMetricTracer PeerMetricsConfiguration
config peerMetrics :: PeerMetrics m p
peerMetrics@PeerMetrics{StrictTVar m (PeerMetricsState p)
peerMetricsVar :: forall (m :: * -> *) p.
PeerMetrics m p -> StrictTVar m (PeerMetricsState p)
peerMetricsVar :: StrictTVar m (PeerMetricsState p)
peerMetricsVar} =
    (ConnectionId p -> p)
-> ((SizeInBytes, SlotNo, Time) -> SlotNo)
-> TraceLabelPeer (ConnectionId p) (SizeInBytes, SlotNo, Time)
-> TraceLabelPeer p SlotNo
forall a b c d.
(a -> b) -> (c -> d) -> TraceLabelPeer a c -> TraceLabelPeer b d
forall (p :: * -> * -> *) a b c d.
Bifunctor p =>
(a -> b) -> (c -> d) -> p a c -> p b d
bimap ConnectionId p -> p
forall addr. ConnectionId addr -> addr
remoteAddress (\(SizeInBytes
_, SlotNo
slotNo, Time
_) -> SlotNo
slotNo)
    (TraceLabelPeer (ConnectionId p) (SizeInBytes, SlotNo, Time)
 -> TraceLabelPeer p SlotNo)
-> Tracer (STM m) (TraceLabelPeer p SlotNo)
-> Tracer
     (STM m)
     (TraceLabelPeer (ConnectionId p) (SizeInBytes, SlotNo, Time))
forall a' a. (a' -> a) -> Tracer (STM m) a -> Tracer (STM m) a'
forall (f :: * -> *) a' a.
Contravariant f =>
(a' -> a) -> f a -> f a'
`contramap`
    PeerMetrics m p -> Tracer (STM m) (TraceLabelPeer p SlotNo)
forall p (m :: * -> *).
(MonadSTM m, Ord p) =>
PeerMetrics m p -> Tracer (STM m) (TraceLabelPeer p SlotNo)
peerRegistryTracer PeerMetrics m p
peerMetrics
 Tracer
  (STM m)
  (TraceLabelPeer (ConnectionId p) (SizeInBytes, SlotNo, Time))
-> Tracer
     (STM m)
     (TraceLabelPeer (ConnectionId p) (SizeInBytes, SlotNo, Time))
-> Tracer
     (STM m)
     (TraceLabelPeer (ConnectionId p) (SizeInBytes, SlotNo, Time))
forall a. Semigroup a => a -> a -> a
<> (\(TraceLabelPeer ConnectionId { p
remoteAddress :: forall addr. ConnectionId addr -> addr
remoteAddress :: p
remoteAddress } (!SizeInBytes
bytes, SlotNo
slot, Time
time)) ->
       (p, SizeInBytes)
-> (SlotNo, Time) -> TraceLabelPeer (p, SizeInBytes) (SlotNo, Time)
forall peerid a. peerid -> a -> TraceLabelPeer peerid a
TraceLabelPeer (p
remoteAddress, SizeInBytes
bytes) (SlotNo
slot, Time
time))
    (TraceLabelPeer (ConnectionId p) (SizeInBytes, SlotNo, Time)
 -> TraceLabelPeer (p, SizeInBytes) (SlotNo, Time))
-> Tracer (STM m) (TraceLabelPeer (p, SizeInBytes) (SlotNo, Time))
-> Tracer
     (STM m)
     (TraceLabelPeer (ConnectionId p) (SizeInBytes, SlotNo, Time))
forall a' a. (a' -> a) -> Tracer (STM m) a -> Tracer (STM m) a'
forall (f :: * -> *) a' a.
Contravariant f =>
(a' -> a) -> f a -> f a'
`contramap`
     STM m (SlotMetric (p, SizeInBytes))
-> (SlotMetric (p, SizeInBytes) -> STM m ())
-> PeerMetricsConfiguration
-> Tracer (STM m) (TraceLabelPeer (p, SizeInBytes) (SlotNo, Time))
forall (m :: * -> *) p.
MonadSTM m =>
STM m (SlotMetric p)
-> (SlotMetric p -> STM m ())
-> PeerMetricsConfiguration
-> Tracer (STM m) (TraceLabelPeer p (SlotNo, Time))
metricsTracer
       (PeerMetricsState p -> SlotMetric (p, SizeInBytes)
forall p. PeerMetricsState p -> SlotMetric (p, SizeInBytes)
fetchedMetrics (PeerMetricsState p -> SlotMetric (p, SizeInBytes))
-> STM m (PeerMetricsState p)
-> STM m (SlotMetric (p, SizeInBytes))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> StrictTVar m (PeerMetricsState p) -> STM m (PeerMetricsState p)
forall (m :: * -> *) a. MonadSTM m => StrictTVar m a -> STM m a
readTVar StrictTVar m (PeerMetricsState p)
peerMetricsVar)
       (\SlotMetric (p, SizeInBytes)
fetchedMetrics -> StrictTVar m (PeerMetricsState p)
-> (PeerMetricsState p -> PeerMetricsState p) -> STM m ()
forall (m :: * -> *) a.
MonadSTM m =>
StrictTVar m a -> (a -> a) -> STM m ()
modifyTVar StrictTVar m (PeerMetricsState p)
peerMetricsVar
                                      (\PeerMetricsState p
metrics -> PeerMetricsState p
metrics { fetchedMetrics }))
       PeerMetricsConfiguration
config


--
--  peer registry tracer which maintains 'peerRegistry' and 'lastSeenRegistry'
--

-- | Insert new peer into 'PeerMetricsState'.  If this peer hasn't been
-- recorded before, we compute the current average score and record it in
-- 'peerRegistry'.  Entries in `peerRegistry' are only kept if they are newer
-- than the oldest slot in the 'headerMetrics' and 'fetchedMetrics'.
--
-- Implementation detail:
-- We need first check 'lastSeenRegistry' which checks if a peer is part of the
-- leader board.  If a peer has not contributed to 'PeerMetrics' in
-- `maxEntriesToTrack` slots, we will consider it as a new peer.  Without using
-- `lastSeenRegistry` we could consider a peer new while it exists in peer
-- metrics for a very long time.  Just using `peerRegistry` does not guarantee
-- that.
--
insertPeer :: forall p. Ord p
           => p
           -> SlotNo -- ^ current slot
           -> PeerMetricsState p
           -> PeerMetricsState p
insertPeer :: forall p.
Ord p =>
p -> SlotNo -> PeerMetricsState p -> PeerMetricsState p
insertPeer p
p !SlotNo
slotNo
           peerMetricsState :: PeerMetricsState p
peerMetricsState@PeerMetricsState { LastSeenRegistry p
lastSeenRegistry :: forall p. PeerMetricsState p -> LastSeenRegistry p
lastSeenRegistry :: LastSeenRegistry p
lastSeenRegistry, PeerRegistry p
peerRegistry :: forall p. PeerMetricsState p -> PeerRegistry p
peerRegistry :: PeerRegistry p
peerRegistry } =
    if p
p p -> LastSeenRegistry p -> Bool
forall k p v. Ord k => k -> OrdPSQ k p v -> Bool
`OrdPSQ.member` LastSeenRegistry p
lastSeenRegistry
    then PeerMetricsState p
peerMetricsState
    else case (Maybe (SlotNo, AverageMetrics)
 -> (Bool, Maybe (SlotNo, AverageMetrics)))
-> p -> PeerRegistry p -> (Bool, PeerRegistry p)
forall k p v b.
(Ord k, Ord p) =>
(Maybe (p, v) -> (b, Maybe (p, v)))
-> k -> OrdPSQ k p v -> (b, OrdPSQ k p v)
OrdPSQ.alter Maybe (SlotNo, AverageMetrics)
-> (Bool, Maybe (SlotNo, AverageMetrics))
f p
p PeerRegistry p
peerRegistry of
           (Bool
False, !PeerRegistry p
peerRegistry') -> PeerMetricsState p
peerMetricsState { peerRegistry = peerRegistry' }
           (Bool
True,  PeerRegistry p
_peerRegistry') -> PeerMetricsState p
peerMetricsState
  where
    f :: Maybe (SlotNo, AverageMetrics) -> (Bool, Maybe (SlotNo, AverageMetrics))
    f :: Maybe (SlotNo, AverageMetrics)
-> (Bool, Maybe (SlotNo, AverageMetrics))
f a :: Maybe (SlotNo, AverageMetrics)
a@Just {} = (Bool
True,  Maybe (SlotNo, AverageMetrics)
a)
    f Maybe (SlotNo, AverageMetrics)
Nothing   = (Bool
False, (SlotNo, AverageMetrics) -> Maybe (SlotNo, AverageMetrics)
forall a. a -> Maybe a
Just ((SlotNo, AverageMetrics) -> Maybe (SlotNo, AverageMetrics))
-> (SlotNo, AverageMetrics) -> Maybe (SlotNo, AverageMetrics)
forall a b. (a -> b) -> a -> b
$! (SlotNo
slotNo, AverageMetrics
metrics))
      where
        !metrics :: AverageMetrics
metrics = AverageMetrics {
                     averageUpstreamyness :: Int
averageUpstreamyness    = Map p Int -> Int
avg (PeerMetricsState p -> Map p Int
forall p. Ord p => PeerMetricsState p -> Map p Int
upstreamynessImpl    PeerMetricsState p
peerMetricsState),
                     averageFetchynessBytes :: Int
averageFetchynessBytes  = Map p Int -> Int
avg (PeerMetricsState p -> Map p Int
forall p. Ord p => PeerMetricsState p -> Map p Int
fetchynessBytesImpl  PeerMetricsState p
peerMetricsState),
                     averageFetchynessBlocks :: Int
averageFetchynessBlocks = Map p Int -> Int
avg (PeerMetricsState p -> Map p Int
forall p. Ord p => PeerMetricsState p -> Map p Int
fetchynessBlocksImpl PeerMetricsState p
peerMetricsState)
                   }

    avg :: Map p Int -> Int
    avg :: Map p Int -> Int
avg Map p Int
m | Map p Int -> Bool
forall k a. Map k a -> Bool
Map.null Map p Int
m = Int
0
    avg Map p Int
m =
      -- division truncated towards the plus infinity, rather then the minus
      -- infinity
      case Sum Int -> Int
forall a. Sum a -> a
getSum ((Int -> Sum Int) -> Map p Int -> Sum Int
forall m a. Monoid m => (a -> m) -> Map p a -> m
forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap Int -> Sum Int
forall a. a -> Sum a
Sum Map p Int
m) Int -> Int -> (Int, Int)
forall a. Integral a => a -> a -> (a, a)
`divMod` Map p Int -> Int
forall k a. Map k a -> Int
Map.size Map p Int
m of
        (Int
x, Int
0) -> Int
x
        (Int
x, Int
_) -> Int
x Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1


-- | A tracer which takes care about:
--
-- * inserting new peers to 'peerRegistry'
-- * removing old entries of 'peerRegistry'
--
-- * inserting new peers to 'lastSeenRegistry'
-- * removing old entries of 'lastSeenRegistry'
--
peerRegistryTracer :: forall p m.
                      ( MonadSTM m
                      , Ord p
                      )
                   => PeerMetrics m p
                   -> Tracer (STM m) (TraceLabelPeer p SlotNo)
peerRegistryTracer :: forall p (m :: * -> *).
(MonadSTM m, Ord p) =>
PeerMetrics m p -> Tracer (STM m) (TraceLabelPeer p SlotNo)
peerRegistryTracer PeerMetrics { StrictTVar m (PeerMetricsState p)
peerMetricsVar :: forall (m :: * -> *) p.
PeerMetrics m p -> StrictTVar m (PeerMetricsState p)
peerMetricsVar :: StrictTVar m (PeerMetricsState p)
peerMetricsVar } =
    (TraceLabelPeer p SlotNo -> STM m ())
-> Tracer (STM m) (TraceLabelPeer p SlotNo)
forall (m :: * -> *) a. (a -> m ()) -> Tracer m a
Tracer ((TraceLabelPeer p SlotNo -> STM m ())
 -> Tracer (STM m) (TraceLabelPeer p SlotNo))
-> (TraceLabelPeer p SlotNo -> STM m ())
-> Tracer (STM m) (TraceLabelPeer p SlotNo)
forall a b. (a -> b) -> a -> b
$ \(TraceLabelPeer p
peer SlotNo
slotNo) -> do
      -- order matters: 'insertPeer' must access the previous value of
      -- lastSeenRegistry
      StrictTVar m (PeerMetricsState p)
-> (PeerMetricsState p -> PeerMetricsState p) -> STM m ()
forall (m :: * -> *) a.
MonadSTM m =>
StrictTVar m a -> (a -> a) -> STM m ()
modifyTVar StrictTVar m (PeerMetricsState p)
peerMetricsVar ((PeerMetricsState p -> PeerMetricsState p) -> STM m ())
-> (PeerMetricsState p -> PeerMetricsState p) -> STM m ()
forall a b. (a -> b) -> a -> b
$ SlotNo -> PeerMetricsState p -> PeerMetricsState p
forall p. SlotNo -> PeerMetricsState p -> PeerMetricsState p
updateLastSlot SlotNo
slotNo
                                (PeerMetricsState p -> PeerMetricsState p)
-> (PeerMetricsState p -> PeerMetricsState p)
-> PeerMetricsState p
-> PeerMetricsState p
forall b c a. (b -> c) -> (a -> b) -> a -> c
. p -> SlotNo -> PeerMetricsState p -> PeerMetricsState p
witnessedPeer p
peer SlotNo
slotNo
                                (PeerMetricsState p -> PeerMetricsState p)
-> (PeerMetricsState p -> PeerMetricsState p)
-> PeerMetricsState p
-> PeerMetricsState p
forall b c a. (b -> c) -> (a -> b) -> a -> c
. p -> SlotNo -> PeerMetricsState p -> PeerMetricsState p
forall p.
Ord p =>
p -> SlotNo -> PeerMetricsState p -> PeerMetricsState p
insertPeer p
peer SlotNo
slotNo
                                (PeerMetricsState p -> PeerMetricsState p)
-> (PeerMetricsState p -> PeerMetricsState p)
-> PeerMetricsState p
-> PeerMetricsState p
forall b c a. (b -> c) -> (a -> b) -> a -> c
. PeerMetricsState p -> PeerMetricsState p
afterSlot
  where
    snd_ :: (a, b, c, d) -> b
snd_ (a
_, b
slotNo, c
_, d
_) = b
slotNo

    -- remove all entries which are older than the oldest slot in the
    -- 'PeerMetrics'
    afterSlot :: PeerMetricsState p -> PeerMetricsState p
    afterSlot :: PeerMetricsState p -> PeerMetricsState p
afterSlot peerMetrics :: PeerMetricsState p
peerMetrics@PeerMetricsState { SlotMetric p
headerMetrics :: forall p. PeerMetricsState p -> SlotMetric p
headerMetrics :: SlotMetric p
headerMetrics,
                                             SlotMetric (p, SizeInBytes)
fetchedMetrics :: forall p. PeerMetricsState p -> SlotMetric (p, SizeInBytes)
fetchedMetrics :: SlotMetric (p, SizeInBytes)
fetchedMetrics,
                                             PeerRegistry p
peerRegistry :: forall p. PeerMetricsState p -> PeerRegistry p
peerRegistry :: PeerRegistry p
peerRegistry,
                                             LastSeenRegistry p
lastSeenRegistry :: forall p. PeerMetricsState p -> LastSeenRegistry p
lastSeenRegistry :: LastSeenRegistry p
lastSeenRegistry } =
      let -- the oldest slot in the metrics leader board
          slotNo :: SlotNo
          slotNo :: SlotNo
slotNo = SlotNo -> Maybe SlotNo -> SlotNo
forall a. a -> Maybe a -> a
fromMaybe SlotNo
0 (Maybe SlotNo -> SlotNo) -> Maybe SlotNo -> SlotNo
forall a b. (a -> b) -> a -> b
$
            ((Int, SlotNo, (p, Time), SlotMetric p) -> SlotNo
forall {a} {b} {c} {d}. (a, b, c, d) -> b
snd_ ((Int, SlotNo, (p, Time), SlotMetric p) -> SlotNo)
-> Maybe (Int, SlotNo, (p, Time), SlotMetric p) -> Maybe SlotNo
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> SlotMetric p -> Maybe (Int, SlotNo, (p, Time), SlotMetric p)
forall p v. Ord p => IntPSQ p v -> Maybe (Int, p, v, IntPSQ p v)
IntPSQ.minView SlotMetric p
headerMetrics)
            Maybe SlotNo -> Maybe SlotNo -> Maybe SlotNo
forall a. Ord a => a -> a -> a
`min`
            ((Int, SlotNo, ((p, SizeInBytes), Time),
 SlotMetric (p, SizeInBytes))
-> SlotNo
forall {a} {b} {c} {d}. (a, b, c, d) -> b
snd_ ((Int, SlotNo, ((p, SizeInBytes), Time),
  SlotMetric (p, SizeInBytes))
 -> SlotNo)
-> Maybe
     (Int, SlotNo, ((p, SizeInBytes), Time),
      SlotMetric (p, SizeInBytes))
-> Maybe SlotNo
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> SlotMetric (p, SizeInBytes)
-> Maybe
     (Int, SlotNo, ((p, SizeInBytes), Time),
      SlotMetric (p, SizeInBytes))
forall p v. Ord p => IntPSQ p v -> Maybe (Int, p, v, IntPSQ p v)
IntPSQ.minView SlotMetric (p, SizeInBytes)
fetchedMetrics)

      in PeerMetricsState p
peerMetrics
           { peerRegistry     = snd (OrdPSQ.atMostView slotNo peerRegistry),
             lastSeenRegistry = snd (OrdPSQ.atMostView slotNo lastSeenRegistry)
           }

    witnessedPeer :: p -> SlotNo
                  -> PeerMetricsState p -> PeerMetricsState p
    witnessedPeer :: p -> SlotNo -> PeerMetricsState p -> PeerMetricsState p
witnessedPeer p
peer SlotNo
slotNo
                  peerMetrics :: PeerMetricsState p
peerMetrics@PeerMetricsState { LastSeenRegistry p
lastSeenRegistry :: forall p. PeerMetricsState p -> LastSeenRegistry p
lastSeenRegistry :: LastSeenRegistry p
lastSeenRegistry } =
                  PeerMetricsState p
peerMetrics { lastSeenRegistry =
                                  OrdPSQ.insert peer slotNo () lastSeenRegistry
                              }


--
-- Metrics tracer
--

-- | A metrics tracer which updates the metric.
--
metricsTracer
    :: forall m p.
       MonadSTM m
    => STM m (SlotMetric p)       -- ^ read metrics
    -> (SlotMetric p -> STM m ()) -- ^ update metrics
    -> PeerMetricsConfiguration
    -> Tracer (STM m) (TraceLabelPeer p (SlotNo, Time))
metricsTracer :: forall (m :: * -> *) p.
MonadSTM m =>
STM m (SlotMetric p)
-> (SlotMetric p -> STM m ())
-> PeerMetricsConfiguration
-> Tracer (STM m) (TraceLabelPeer p (SlotNo, Time))
metricsTracer STM m (SlotMetric p)
getMetrics SlotMetric p -> STM m ()
writeMetrics PeerMetricsConfiguration { Int
maxEntriesToTrack :: PeerMetricsConfiguration -> Int
maxEntriesToTrack :: Int
maxEntriesToTrack } =
    (TraceLabelPeer p (SlotNo, Time) -> STM m ())
-> Tracer (STM m) (TraceLabelPeer p (SlotNo, Time))
forall (m :: * -> *) a. (a -> m ()) -> Tracer m a
Tracer ((TraceLabelPeer p (SlotNo, Time) -> STM m ())
 -> Tracer (STM m) (TraceLabelPeer p (SlotNo, Time)))
-> (TraceLabelPeer p (SlotNo, Time) -> STM m ())
-> Tracer (STM m) (TraceLabelPeer p (SlotNo, Time))
forall a b. (a -> b) -> a -> b
$ \(TraceLabelPeer !p
peer (!SlotNo
slot, !Time
time)) -> do
      metrics <- STM m (SlotMetric p)
getMetrics
      let !k = SlotNo -> Int
slotToInt SlotNo
slot
          !v = (p
peer, Time
time)
      case IntPSQ.lookup k metrics of
           Maybe (SlotNo, (p, Time))
Nothing -> do
             let metrics' :: SlotMetric p
metrics' = Int -> SlotNo -> (p, Time) -> SlotMetric p -> SlotMetric p
forall p v. Ord p => Int -> p -> v -> IntPSQ p v -> IntPSQ p v
IntPSQ.insert Int
k SlotNo
slot (p, Time)
v SlotMetric p
metrics
             if SlotMetric p -> Int
forall p v. IntPSQ p v -> Int
IntPSQ.size SlotMetric p
metrics' Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
maxEntriesToTrack
             -- drop last element if the metric board is too large
             then case SlotMetric p -> Maybe (Int, SlotNo, (p, Time), SlotMetric p)
forall p v. Ord p => IntPSQ p v -> Maybe (Int, p, v, IntPSQ p v)
IntPSQ.minView SlotMetric p
metrics' of
                    Maybe (Int, SlotNo, (p, Time), SlotMetric p)
Nothing -> String -> STM m ()
forall a. HasCallStack => String -> a
error String
"impossible empty pq"
                            -- We just inserted an element!
                    Just (Int
_, SlotNo
minSlotNo, (p, Time)
_, SlotMetric p
metrics'') ->
                         Bool -> STM m () -> STM m ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (SlotNo
minSlotNo SlotNo -> SlotNo -> Bool
forall a. Eq a => a -> a -> Bool
/= SlotNo
slot) (STM m () -> STM m ()) -> STM m () -> STM m ()
forall a b. (a -> b) -> a -> b
$
                              SlotMetric p -> STM m ()
writeMetrics SlotMetric p
metrics''
             else SlotMetric p -> STM m ()
writeMetrics SlotMetric p
metrics'
           Just (SlotNo
_, (p
_, Time
oldTime)) ->
               Bool -> STM m () -> STM m ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Time
oldTime Time -> Time -> Bool
forall a. Ord a => a -> a -> Bool
> Time
time) (STM m () -> STM m ()) -> STM m () -> STM m ()
forall a b. (a -> b) -> a -> b
$
                    SlotMetric p -> STM m ()
writeMetrics (Int -> SlotNo -> (p, Time) -> SlotMetric p -> SlotMetric p
forall p v. Ord p => Int -> p -> v -> IntPSQ p v -> IntPSQ p v
IntPSQ.insert Int
k SlotNo
slot (p, Time)
v SlotMetric p
metrics)


joinedPeerMetricAt
    :: forall p m.
       MonadSTM m
    => Ord p
    => PeerMetrics m p
    -> STM m (Map p SlotNo)
joinedPeerMetricAt :: forall p (m :: * -> *).
(MonadSTM m, Ord p) =>
PeerMetrics m p -> STM m (Map p SlotNo)
joinedPeerMetricAt PeerMetrics {StrictTVar m (PeerMetricsState p)
peerMetricsVar :: forall (m :: * -> *) p.
PeerMetrics m p -> StrictTVar m (PeerMetricsState p)
peerMetricsVar :: StrictTVar m (PeerMetricsState p)
peerMetricsVar} =
    PeerMetricsState p -> Map p SlotNo
forall p. Ord p => PeerMetricsState p -> Map p SlotNo
joinedPeerMetricAtImpl (PeerMetricsState p -> Map p SlotNo)
-> STM m (PeerMetricsState p) -> STM m (Map p SlotNo)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> StrictTVar m (PeerMetricsState p) -> STM m (PeerMetricsState p)
forall (m :: * -> *) a. MonadSTM m => StrictTVar m a -> STM m a
readTVar StrictTVar m (PeerMetricsState p)
peerMetricsVar


joinedPeerMetricAtImpl
    :: forall p.
       Ord p
    => PeerMetricsState p
    -> Map p SlotNo
joinedPeerMetricAtImpl :: forall p. Ord p => PeerMetricsState p -> Map p SlotNo
joinedPeerMetricAtImpl PeerMetricsState { PeerRegistry p
peerRegistry :: forall p. PeerMetricsState p -> PeerRegistry p
peerRegistry :: PeerRegistry p
peerRegistry } =
    (p -> SlotNo -> AverageMetrics -> Map p SlotNo -> Map p SlotNo)
-> Map p SlotNo -> PeerRegistry p -> Map p SlotNo
forall k p v a. (k -> p -> v -> a -> a) -> a -> OrdPSQ k p v -> a
OrdPSQ.fold' (\p
p SlotNo
slotNo AverageMetrics
_ Map p SlotNo
m -> p -> SlotNo -> Map p SlotNo -> Map p SlotNo
forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert p
p SlotNo
slotNo Map p SlotNo
m) Map p SlotNo
forall k a. Map k a
Map.empty PeerRegistry p
peerRegistry

--
-- Metrics
--
-- * upstreameness
-- * fetchyness by blocks
-- * fetchyness by bytes
--

-- | Returns a Map which counts the number of times a given peer was the first
-- to present us with a block/header.
--
upstreamyness
    :: forall p m.
       MonadSTM m
    => Ord p
    => PeerMetrics m p
    -> STM m (Map p Int)
upstreamyness :: forall p (m :: * -> *).
(MonadSTM m, Ord p) =>
PeerMetrics m p -> STM m (Map p Int)
upstreamyness PeerMetrics {StrictTVar m (PeerMetricsState p)
peerMetricsVar :: forall (m :: * -> *) p.
PeerMetrics m p -> StrictTVar m (PeerMetricsState p)
peerMetricsVar :: StrictTVar m (PeerMetricsState p)
peerMetricsVar} =
    PeerMetricsState p -> Map p Int
forall p. Ord p => PeerMetricsState p -> Map p Int
upstreamynessImpl (PeerMetricsState p -> Map p Int)
-> STM m (PeerMetricsState p) -> STM m (Map p Int)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> StrictTVar m (PeerMetricsState p) -> STM m (PeerMetricsState p)
forall (m :: * -> *) a. MonadSTM m => StrictTVar m a -> STM m a
readTVar StrictTVar m (PeerMetricsState p)
peerMetricsVar


upstreamynessImpl
    :: forall p.
       Ord p
    => PeerMetricsState p
    -> Map p Int
upstreamynessImpl :: forall p. Ord p => PeerMetricsState p -> Map p Int
upstreamynessImpl state :: PeerMetricsState p
state@PeerMetricsState { SlotMetric p
headerMetrics :: forall p. PeerMetricsState p -> SlotMetric p
headerMetrics :: SlotMetric p
headerMetrics,
                                           PeerRegistry p
peerRegistry :: forall p. PeerMetricsState p -> PeerRegistry p
peerRegistry :: PeerRegistry p
peerRegistry,
                                           SlotNo
lastSlotNo :: forall p. PeerMetricsState p -> SlotNo
lastSlotNo :: SlotNo
lastSlotNo,
                                           PeerMetricsConfiguration
metricsConfig :: forall p. PeerMetricsState p -> PeerMetricsConfiguration
metricsConfig :: PeerMetricsConfiguration
metricsConfig
                                         } =
    (Int -> Int -> Int) -> Map p Int -> Map p Int -> Map p Int
forall k a. Ord k => (a -> a -> a) -> Map k a -> Map k a -> Map k a
Map.unionWith Int -> Int -> Int
forall a. Num a => a -> a -> a
(+) ((Int -> SlotNo -> (p, Time) -> Map p Int -> Map p Int)
-> Map p Int -> SlotMetric p -> Map p Int
forall p v a. (Int -> p -> v -> a -> a) -> a -> IntPSQ p v -> a
IntPSQ.fold' Int -> SlotNo -> (p, Time) -> Map p Int -> Map p Int
count Map p Int
forall k a. Map k a
Map.empty SlotMetric p
headerMetrics)
                      ((p -> SlotNo -> AverageMetrics -> Map p Int -> Map p Int)
-> Map p Int -> PeerRegistry p -> Map p Int
forall k p v a. (k -> p -> v -> a -> a) -> a -> OrdPSQ k p v -> a
OrdPSQ.fold' (Maybe SlotNo
-> p -> SlotNo -> AverageMetrics -> Map p Int -> Map p Int
countCorrection (PeerMetricsState p -> Maybe SlotNo
forall p. PeerMetricsState p -> Maybe SlotNo
firstSlotNo PeerMetricsState p
state))
                                    Map p Int
forall k a. Map k a
Map.empty PeerRegistry p
peerRegistry)
  where
    count :: Int
          -> SlotNo
          -> (p,Time)
          -> Map p Int
          -> Map p Int
    count :: Int -> SlotNo -> (p, Time) -> Map p Int -> Map p Int
count Int
_ SlotNo
_ (p
peer,Time
_) Map p Int
m =
        (Maybe Int -> Maybe Int) -> p -> Map p Int -> Map p Int
forall k a.
Ord k =>
(Maybe a -> Maybe a) -> k -> Map k a -> Map k a
Map.alter Maybe Int -> Maybe Int
fn p
peer Map p Int
m
      where
        fn :: Maybe Int -> Maybe Int
        fn :: Maybe Int -> Maybe Int
fn Maybe Int
Nothing  = Int -> Maybe Int
forall a. a -> Maybe a
Just Int
1
        fn (Just Int
c) = Int -> Maybe Int
forall a. a -> Maybe a
Just (Int -> Maybe Int) -> Int -> Maybe Int
forall a b. (a -> b) -> a -> b
$! Int
c Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1

    countCorrection :: Maybe SlotNo
                    -> p
                    -> SlotNo
                    -> AverageMetrics
                    -> Map p Int
                    -> Map p Int
    countCorrection :: Maybe SlotNo
-> p -> SlotNo -> AverageMetrics -> Map p Int -> Map p Int
countCorrection Maybe SlotNo
minSlotNo p
peer SlotNo
joinedAt AverageMetrics { Int
averageUpstreamyness :: AverageMetrics -> Int
averageUpstreamyness :: Int
averageUpstreamyness } Map p Int
m =
        p -> Int -> Map p Int -> Map p Int
forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert p
peer
                   (PeerMetricsConfiguration
-> Maybe SlotNo -> SlotNo -> SlotNo -> Int -> Int
adjustAvg PeerMetricsConfiguration
metricsConfig
                              Maybe SlotNo
minSlotNo
                              SlotNo
joinedAt
                              SlotNo
lastSlotNo
                              Int
averageUpstreamyness)
                   Map p Int
m


-- | Returns a Map which counts the number of bytes downloaded for a given
-- peer.
--
fetchynessBytes
    :: forall p m.
       MonadSTM m
    => Ord p
    => PeerMetrics m p
    -> STM m (Map p Int)
fetchynessBytes :: forall p (m :: * -> *).
(MonadSTM m, Ord p) =>
PeerMetrics m p -> STM m (Map p Int)
fetchynessBytes PeerMetrics {StrictTVar m (PeerMetricsState p)
peerMetricsVar :: forall (m :: * -> *) p.
PeerMetrics m p -> StrictTVar m (PeerMetricsState p)
peerMetricsVar :: StrictTVar m (PeerMetricsState p)
peerMetricsVar} =
    PeerMetricsState p -> Map p Int
forall p. Ord p => PeerMetricsState p -> Map p Int
fetchynessBytesImpl (PeerMetricsState p -> Map p Int)
-> STM m (PeerMetricsState p) -> STM m (Map p Int)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> StrictTVar m (PeerMetricsState p) -> STM m (PeerMetricsState p)
forall (m :: * -> *) a. MonadSTM m => StrictTVar m a -> STM m a
readTVar StrictTVar m (PeerMetricsState p)
peerMetricsVar

fetchynessBytesImpl
    :: forall p.
       Ord p
    => PeerMetricsState p
    -> Map p Int
fetchynessBytesImpl :: forall p. Ord p => PeerMetricsState p -> Map p Int
fetchynessBytesImpl state :: PeerMetricsState p
state@PeerMetricsState { SlotMetric (p, SizeInBytes)
fetchedMetrics :: forall p. PeerMetricsState p -> SlotMetric (p, SizeInBytes)
fetchedMetrics :: SlotMetric (p, SizeInBytes)
fetchedMetrics,
                                             PeerRegistry p
peerRegistry :: forall p. PeerMetricsState p -> PeerRegistry p
peerRegistry :: PeerRegistry p
peerRegistry,
                                             SlotNo
lastSlotNo :: forall p. PeerMetricsState p -> SlotNo
lastSlotNo :: SlotNo
lastSlotNo,
                                             PeerMetricsConfiguration
metricsConfig :: forall p. PeerMetricsState p -> PeerMetricsConfiguration
metricsConfig :: PeerMetricsConfiguration
metricsConfig
                                           } =
    (Int -> Int -> Int) -> Map p Int -> Map p Int -> Map p Int
forall k a. Ord k => (a -> a -> a) -> Map k a -> Map k a -> Map k a
Map.unionWith Int -> Int -> Int
forall a. Num a => a -> a -> a
(+) ((Int
 -> SlotNo -> ((p, SizeInBytes), Time) -> Map p Int -> Map p Int)
-> Map p Int -> SlotMetric (p, SizeInBytes) -> Map p Int
forall p v a. (Int -> p -> v -> a -> a) -> a -> IntPSQ p v -> a
IntPSQ.fold' Int -> SlotNo -> ((p, SizeInBytes), Time) -> Map p Int -> Map p Int
count Map p Int
forall k a. Map k a
Map.empty SlotMetric (p, SizeInBytes)
fetchedMetrics)
                      ((p -> SlotNo -> AverageMetrics -> Map p Int -> Map p Int)
-> Map p Int -> PeerRegistry p -> Map p Int
forall k p v a. (k -> p -> v -> a -> a) -> a -> OrdPSQ k p v -> a
OrdPSQ.fold' (Maybe SlotNo
-> p -> SlotNo -> AverageMetrics -> Map p Int -> Map p Int
countCorrection (PeerMetricsState p -> Maybe SlotNo
forall p. PeerMetricsState p -> Maybe SlotNo
firstSlotNo PeerMetricsState p
state))
                                     Map p Int
forall k a. Map k a
Map.empty PeerRegistry p
peerRegistry)
  where
    count :: Int
          -> SlotNo
          -> ((p, SizeInBytes), Time)
          -> Map p Int
          -> Map p Int
    count :: Int -> SlotNo -> ((p, SizeInBytes), Time) -> Map p Int -> Map p Int
count Int
_ SlotNo
_ ((p
peer, SizeInBytes
bytes),Time
_) Map p Int
m =
        (Maybe Int -> Maybe Int) -> p -> Map p Int -> Map p Int
forall k a.
Ord k =>
(Maybe a -> Maybe a) -> k -> Map k a -> Map k a
Map.alter Maybe Int -> Maybe Int
fn p
peer Map p Int
m
      where
        fn :: Maybe Int -> Maybe Int
        fn :: Maybe Int -> Maybe Int
fn Maybe Int
Nothing         = Int -> Maybe Int
forall a. a -> Maybe a
Just (Int -> Maybe Int) -> Int -> Maybe Int
forall a b. (a -> b) -> a -> b
$ SizeInBytes -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral SizeInBytes
bytes
        fn (Just Int
oldBytes) = Int -> Maybe Int
forall a. a -> Maybe a
Just (Int -> Maybe Int) -> Int -> Maybe Int
forall a b. (a -> b) -> a -> b
$! Int
oldBytes Int -> Int -> Int
forall a. Num a => a -> a -> a
+ SizeInBytes -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral SizeInBytes
bytes

    countCorrection :: Maybe SlotNo
                    -> p
                    -> SlotNo
                    -> AverageMetrics
                    -> Map p Int
                    -> Map p Int
    countCorrection :: Maybe SlotNo
-> p -> SlotNo -> AverageMetrics -> Map p Int -> Map p Int
countCorrection Maybe SlotNo
minSlotNo p
peer SlotNo
joinedAt AverageMetrics { Int
averageFetchynessBytes :: AverageMetrics -> Int
averageFetchynessBytes :: Int
averageFetchynessBytes } Map p Int
m =
        p -> Int -> Map p Int -> Map p Int
forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert p
peer
                   (PeerMetricsConfiguration
-> Maybe SlotNo -> SlotNo -> SlotNo -> Int -> Int
adjustAvg PeerMetricsConfiguration
metricsConfig
                              Maybe SlotNo
minSlotNo
                              SlotNo
joinedAt
                              SlotNo
lastSlotNo
                              Int
averageFetchynessBytes)
                   Map p Int
m


-- | Returns a Map which counts the number of times a given peer was the first
-- we downloaded a block from.
--
fetchynessBlocks
    :: forall p m.
       MonadSTM m
    => Ord p
    => PeerMetrics m p
    -> STM m (Map p Int)
fetchynessBlocks :: forall p (m :: * -> *).
(MonadSTM m, Ord p) =>
PeerMetrics m p -> STM m (Map p Int)
fetchynessBlocks PeerMetrics {StrictTVar m (PeerMetricsState p)
peerMetricsVar :: forall (m :: * -> *) p.
PeerMetrics m p -> StrictTVar m (PeerMetricsState p)
peerMetricsVar :: StrictTVar m (PeerMetricsState p)
peerMetricsVar} =
    PeerMetricsState p -> Map p Int
forall p. Ord p => PeerMetricsState p -> Map p Int
fetchynessBlocksImpl (PeerMetricsState p -> Map p Int)
-> STM m (PeerMetricsState p) -> STM m (Map p Int)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> StrictTVar m (PeerMetricsState p) -> STM m (PeerMetricsState p)
forall (m :: * -> *) a. MonadSTM m => StrictTVar m a -> STM m a
readTVar StrictTVar m (PeerMetricsState p)
peerMetricsVar

fetchynessBlocksImpl
    :: forall p.
       Ord p
    => PeerMetricsState p
    -> Map p Int
fetchynessBlocksImpl :: forall p. Ord p => PeerMetricsState p -> Map p Int
fetchynessBlocksImpl state :: PeerMetricsState p
state@PeerMetricsState { SlotMetric (p, SizeInBytes)
fetchedMetrics :: forall p. PeerMetricsState p -> SlotMetric (p, SizeInBytes)
fetchedMetrics :: SlotMetric (p, SizeInBytes)
fetchedMetrics,
                                              PeerRegistry p
peerRegistry :: forall p. PeerMetricsState p -> PeerRegistry p
peerRegistry :: PeerRegistry p
peerRegistry,
                                              SlotNo
lastSlotNo :: forall p. PeerMetricsState p -> SlotNo
lastSlotNo :: SlotNo
lastSlotNo,
                                              PeerMetricsConfiguration
metricsConfig :: forall p. PeerMetricsState p -> PeerMetricsConfiguration
metricsConfig :: PeerMetricsConfiguration
metricsConfig
                                            } =
    (Int -> Int -> Int) -> Map p Int -> Map p Int -> Map p Int
forall k a. Ord k => (a -> a -> a) -> Map k a -> Map k a -> Map k a
Map.unionWith Int -> Int -> Int
forall a. Num a => a -> a -> a
(+) ((Int
 -> SlotNo -> ((p, SizeInBytes), Time) -> Map p Int -> Map p Int)
-> Map p Int -> SlotMetric (p, SizeInBytes) -> Map p Int
forall p v a. (Int -> p -> v -> a -> a) -> a -> IntPSQ p v -> a
IntPSQ.fold' Int -> SlotNo -> ((p, SizeInBytes), Time) -> Map p Int -> Map p Int
count Map p Int
forall k a. Map k a
Map.empty SlotMetric (p, SizeInBytes)
fetchedMetrics)
                      ((p -> SlotNo -> AverageMetrics -> Map p Int -> Map p Int)
-> Map p Int -> PeerRegistry p -> Map p Int
forall k p v a. (k -> p -> v -> a -> a) -> a -> OrdPSQ k p v -> a
OrdPSQ.fold' (Maybe SlotNo
-> p -> SlotNo -> AverageMetrics -> Map p Int -> Map p Int
countCorrection (PeerMetricsState p -> Maybe SlotNo
forall p. PeerMetricsState p -> Maybe SlotNo
firstSlotNo PeerMetricsState p
state))
                                    Map p Int
forall k a. Map k a
Map.empty PeerRegistry p
peerRegistry)
  where
    count :: Int
          -> SlotNo
          -> ((p, SizeInBytes), Time)
          -> Map p Int
          -> Map p Int
    count :: Int -> SlotNo -> ((p, SizeInBytes), Time) -> Map p Int -> Map p Int
count Int
_ SlotNo
_ ((p
peer, SizeInBytes
_),Time
_) Map p Int
m =
        (Maybe Int -> Maybe Int) -> p -> Map p Int -> Map p Int
forall k a.
Ord k =>
(Maybe a -> Maybe a) -> k -> Map k a -> Map k a
Map.alter Maybe Int -> Maybe Int
fn p
peer Map p Int
m
      where
        fn :: Maybe Int -> Maybe Int
        fn :: Maybe Int -> Maybe Int
fn Maybe Int
Nothing  = Int -> Maybe Int
forall a. a -> Maybe a
Just Int
1
        fn (Just Int
c) = Int -> Maybe Int
forall a. a -> Maybe a
Just (Int -> Maybe Int) -> Int -> Maybe Int
forall a b. (a -> b) -> a -> b
$! Int
c Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1

    countCorrection :: Maybe SlotNo
                    -> p
                    -> SlotNo
                    -> AverageMetrics
                    -> Map p Int
                    -> Map p Int
    countCorrection :: Maybe SlotNo
-> p -> SlotNo -> AverageMetrics -> Map p Int -> Map p Int
countCorrection Maybe SlotNo
minSlotNo p
peer SlotNo
joinedAt AverageMetrics { Int
averageFetchynessBlocks :: AverageMetrics -> Int
averageFetchynessBlocks :: Int
averageFetchynessBlocks } Map p Int
m =
        p -> Int -> Map p Int -> Map p Int
forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert p
peer
                   (PeerMetricsConfiguration
-> Maybe SlotNo -> SlotNo -> SlotNo -> Int -> Int
adjustAvg PeerMetricsConfiguration
metricsConfig
                              Maybe SlotNo
minSlotNo
                              SlotNo
joinedAt
                              SlotNo
lastSlotNo
                              Int
averageFetchynessBlocks)
                   Map p Int
m


--
-- Utils
--


adjustAvg :: PeerMetricsConfiguration
          -> Maybe SlotNo -- ^ smallest slot number
          -> SlotNo       -- ^ slot when joined the leader board
          -> SlotNo       -- ^ current slot
          -> Int
          -> Int
adjustAvg :: PeerMetricsConfiguration
-> Maybe SlotNo -> SlotNo -> SlotNo -> Int -> Int
adjustAvg PeerMetricsConfiguration
_ Maybe SlotNo
_ SlotNo
_ SlotNo
_ Int
_ = Int
0
{-adjustAvg PeerMetricsConfiguration { maxEntriesToTrack } minSlotNo joinedSlotNo lastSlotNo avg
    -- when there are only a few results in the 'PeerMetricsState' we don't
    -- take into account the average.  This allows the system to start, without
    -- penalising the peers which we connected to early.
    | lastSlot - minSlot + 1 < maxEntriesToTrack `div` 2
    = 0

    -- the peer is too old to take the correction into account.
    | lastSlot - joinedSlot + 1 >= maxEntriesToTrack
    = 0

    | otherwise
    = (maxEntriesToTrack + joinedSlot - lastSlot) * avg
      `div` maxEntriesToTrack
  where
    minSlot, lastSlot, joinedSlot :: Int
    minSlot    = maybe 1 slotToInt minSlotNo
    lastSlot   = slotToInt lastSlotNo
    joinedSlot = slotToInt joinedSlotNo -}