{-# LANGUAGE BangPatterns        #-}
{-# LANGUAGE GADTs               #-}
{-# LANGUAGE NamedFieldPuns      #-}
{-# LANGUAGE RankNTypes          #-}
{-# LANGUAGE ScopedTypeVariables #-}


module Ouroboros.Network.PeerSelection.PeerMetric where

import           Control.Monad.Class.MonadSTM.Strict
import           Control.Monad.Class.MonadTime
import           Control.Tracer (Tracer (..), contramap, nullTracer)
import           Data.IntPSQ (IntPSQ)
import qualified Data.IntPSQ as Pq
import           Data.Map.Strict (Map)
import qualified Data.Map.Strict as Map

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


-- The maximum numbers of slots we will store data for.
-- On some chains sometimes this corresponds to 1h
-- worth of metrics *sighs*.
maxEntriesToTrack :: Int
maxEntriesToTrack :: Int
maxEntriesToTrack = Int
180


type SlotMetric p = IntPSQ SlotNo (p, Time)

data PeerMetrics m p = PeerMetrics {
    PeerMetrics m p -> StrictTVar m (SlotMetric p)
headerMetrics  :: StrictTVar m (SlotMetric p)
  , PeerMetrics m p -> StrictTVar m (SlotMetric (p, SizeInBytes))
fetchedMetrics :: StrictTVar m (SlotMetric (p, SizeInBytes))
  }

reportMetric
    :: forall m p.
       ( MonadSTM m )
     => PeerMetrics m p
     -> ReportPeerMetrics m (ConnectionId p)
reportMetric :: PeerMetrics m p -> ReportPeerMetrics m (ConnectionId p)
reportMetric 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 (PeerMetrics m p
-> Tracer (STM m) (TraceLabelPeer (ConnectionId p) (SlotNo, Time))
forall (m :: * -> *) p.
MonadSTM m =>
PeerMetrics m p
-> Tracer (STM m) (TraceLabelPeer (ConnectionId p) (SlotNo, Time))
headerMetricTracer PeerMetrics m p
peerMetrics)
                    (PeerMetrics m p
-> Tracer
     (STM m)
     (TraceLabelPeer (ConnectionId p) (SizeInBytes, SlotNo, Time))
forall (m :: * -> *) p.
MonadSTM m =>
PeerMetrics m p
-> Tracer
     (STM m)
     (TraceLabelPeer (ConnectionId p) (SizeInBytes, SlotNo, Time))
fetchedMetricTracer PeerMetrics m p
peerMetrics)

nullMetric
    :: MonadSTM m
    => ReportPeerMetrics m p
nullMetric :: 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

slotMetricKey :: SlotNo -> Int
slotMetricKey :: SlotNo -> Int
slotMetricKey (SlotNo Word64
s) = Word64 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word64
s

headerMetricTracer
    :: forall m p.
       ( MonadSTM m )
    => PeerMetrics m p
    -> Tracer (STM m) (TraceLabelPeer (ConnectionId p) (SlotNo, Time))
headerMetricTracer :: PeerMetrics m p
-> Tracer (STM m) (TraceLabelPeer (ConnectionId p) (SlotNo, Time))
headerMetricTracer PeerMetrics{StrictTVar m (SlotMetric p)
headerMetrics :: StrictTVar m (SlotMetric p)
headerMetrics :: forall (m :: * -> *) p.
PeerMetrics m p -> StrictTVar m (SlotMetric p)
headerMetrics} =
    (\(TraceLabelPeer ConnectionId p
con (SlotNo, Time)
d) -> p -> (SlotNo, Time) -> TraceLabelPeer p (SlotNo, Time)
forall peerid a. peerid -> a -> TraceLabelPeer peerid a
TraceLabelPeer (ConnectionId p -> p
forall addr. ConnectionId addr -> addr
remoteAddress ConnectionId p
con) (SlotNo, Time)
d)
    (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 (f :: * -> *) a b. Contravariant f => (a -> b) -> f b -> f a
`contramap`
    StrictTVar m (SlotMetric p)
-> Tracer (STM m) (TraceLabelPeer p (SlotNo, Time))
forall (m :: * -> *) p.
MonadSTM m =>
StrictTVar m (SlotMetric p)
-> Tracer (STM m) (TraceLabelPeer p (SlotNo, Time))
metricsTracer StrictTVar m (SlotMetric p)
headerMetrics

fetchedMetricTracer
    :: forall m p.
       ( MonadSTM m )
    => PeerMetrics m p
    -> Tracer (STM m) (TraceLabelPeer (ConnectionId p)
                                      ( SizeInBytes
                                      , SlotNo
                                      , Time
                                      ))
fetchedMetricTracer :: PeerMetrics m p
-> Tracer
     (STM m)
     (TraceLabelPeer (ConnectionId p) (SizeInBytes, SlotNo, Time))
fetchedMetricTracer PeerMetrics{StrictTVar m (SlotMetric (p, SizeInBytes))
fetchedMetrics :: StrictTVar m (SlotMetric (p, SizeInBytes))
fetchedMetrics :: forall (m :: * -> *) p.
PeerMetrics m p -> StrictTVar m (SlotMetric (p, SizeInBytes))
fetchedMetrics} =
    (\(TraceLabelPeer ConnectionId p
con (SizeInBytes
bytes, SlotNo
slot, Time
time)) ->
       (p, SizeInBytes)
-> (SlotNo, Time) -> TraceLabelPeer (p, SizeInBytes) (SlotNo, Time)
forall peerid a. peerid -> a -> TraceLabelPeer peerid a
TraceLabelPeer (ConnectionId p -> p
forall addr. ConnectionId addr -> addr
remoteAddress ConnectionId p
con, 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 (f :: * -> *) a b. Contravariant f => (a -> b) -> f b -> f a
`contramap`
     StrictTVar m (SlotMetric (p, SizeInBytes))
-> Tracer (STM m) (TraceLabelPeer (p, SizeInBytes) (SlotNo, Time))
forall (m :: * -> *) p.
MonadSTM m =>
StrictTVar m (SlotMetric p)
-> Tracer (STM m) (TraceLabelPeer p (SlotNo, Time))
metricsTracer StrictTVar m (SlotMetric (p, SizeInBytes))
fetchedMetrics


getHeaderMetrics
    :: MonadSTM m
    => PeerMetrics m p
    -> STM m (SlotMetric p)
getHeaderMetrics :: PeerMetrics m p -> STM m (SlotMetric p)
getHeaderMetrics PeerMetrics{StrictTVar m (SlotMetric p)
headerMetrics :: StrictTVar m (SlotMetric p)
headerMetrics :: forall (m :: * -> *) p.
PeerMetrics m p -> StrictTVar m (SlotMetric p)
headerMetrics} = StrictTVar m (SlotMetric p) -> STM m (SlotMetric p)
forall (m :: * -> *) a. MonadSTM m => StrictTVar m a -> STM m a
readTVar StrictTVar m (SlotMetric p)
headerMetrics

getFetchedMetrics
    :: MonadSTM m
    => PeerMetrics m p
    -> STM m (SlotMetric (p, SizeInBytes))
getFetchedMetrics :: PeerMetrics m p -> STM m (SlotMetric (p, SizeInBytes))
getFetchedMetrics PeerMetrics{StrictTVar m (SlotMetric (p, SizeInBytes))
fetchedMetrics :: StrictTVar m (SlotMetric (p, SizeInBytes))
fetchedMetrics :: forall (m :: * -> *) p.
PeerMetrics m p -> StrictTVar m (SlotMetric (p, SizeInBytes))
fetchedMetrics} = StrictTVar m (SlotMetric (p, SizeInBytes))
-> STM m (SlotMetric (p, SizeInBytes))
forall (m :: * -> *) a. MonadSTM m => StrictTVar m a -> STM m a
readTVar StrictTVar m (SlotMetric (p, SizeInBytes))
fetchedMetrics

metricsTracer
    :: forall m p.  ( MonadSTM m )
    => StrictTVar m (SlotMetric p)
    -> Tracer (STM m) (TraceLabelPeer p (SlotNo, Time))
metricsTracer :: StrictTVar m (SlotMetric p)
-> Tracer (STM m) (TraceLabelPeer p (SlotNo, Time))
metricsTracer StrictTVar m (SlotMetric p)
metricsVar = (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
    SlotMetric p
metrics <- StrictTVar m (SlotMetric p) -> STM m (SlotMetric p)
forall (m :: * -> *) a. MonadSTM m => StrictTVar m a -> STM m a
readTVar StrictTVar m (SlotMetric p)
metricsVar
    case Int -> SlotMetric p -> Maybe (SlotNo, (p, Time))
forall p v. Int -> IntPSQ p v -> Maybe (p, v)
Pq.lookup (SlotNo -> Int
slotMetricKey SlotNo
slot) SlotMetric p
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
Pq.insert (SlotNo -> Int
slotMetricKey SlotNo
slot) SlotNo
slot (p
peer, Time
time) SlotMetric p
metrics
             if SlotMetric p -> Int
forall p v. IntPSQ p v -> Int
Pq.size SlotMetric p
metrics' Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
maxEntriesToTrack
                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)
Pq.minView SlotMetric p
metrics' of
                       Maybe (Int, SlotNo, (p, Time), SlotMetric p)
Nothing -> [Char] -> STM m ()
forall a. HasCallStack => [Char] -> a
error [Char]
"impossible empty pq" -- We just inserted an element!
                       Just (Int
_, SlotNo
minSlotNo, (p, Time)
_, SlotMetric p
metrics'') ->
                            if SlotNo
minSlotNo SlotNo -> SlotNo -> Bool
forall a. Eq a => a -> a -> Bool
== SlotNo
slot
                               then () -> STM m ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
                               else StrictTVar m (SlotMetric p) -> SlotMetric p -> STM m ()
forall (m :: * -> *) a.
(MonadSTM m, HasCallStack) =>
StrictTVar m a -> a -> STM m ()
writeTVar StrictTVar m (SlotMetric p)
metricsVar SlotMetric p
metrics''
             else StrictTVar m (SlotMetric p) -> SlotMetric p -> STM m ()
forall (m :: * -> *) a.
(MonadSTM m, HasCallStack) =>
StrictTVar m a -> a -> STM m ()
writeTVar StrictTVar m (SlotMetric p)
metricsVar SlotMetric p
metrics'
         Just (SlotNo
_, (p
_, Time
oldTime)) ->
             if Time
oldTime Time -> Time -> Bool
forall a. Ord a => a -> a -> Bool
<= Time
time
                then () -> STM m ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
                else StrictTVar m (SlotMetric p) -> SlotMetric p -> STM m ()
forall (m :: * -> *) a.
(MonadSTM m, HasCallStack) =>
StrictTVar m a -> a -> STM m ()
writeTVar StrictTVar m (SlotMetric p)
metricsVar (Int -> SlotNo -> (p, Time) -> SlotMetric p -> SlotMetric p
forall p v. Ord p => Int -> p -> v -> IntPSQ p v -> IntPSQ p v
Pq.insert (SlotNo -> Int
slotMetricKey SlotNo
slot) SlotNo
slot (p
peer, Time
time) SlotMetric p
metrics)

newPeerMetric
    :: MonadSTM m
    => m (PeerMetrics m p)
newPeerMetric :: m (PeerMetrics m p)
newPeerMetric = do
  StrictTVar m (IntPSQ SlotNo (p, Time))
hs <- IntPSQ SlotNo (p, Time)
-> m (StrictTVar m (IntPSQ SlotNo (p, Time)))
forall (m :: * -> *) a. MonadSTM m => a -> m (StrictTVar m a)
newTVarIO IntPSQ SlotNo (p, Time)
forall p v. IntPSQ p v
Pq.empty
  StrictTVar m (IntPSQ SlotNo ((p, SizeInBytes), Time))
bs <- IntPSQ SlotNo ((p, SizeInBytes), Time)
-> m (StrictTVar m (IntPSQ SlotNo ((p, SizeInBytes), Time)))
forall (m :: * -> *) a. MonadSTM m => a -> m (StrictTVar m a)
newTVarIO IntPSQ SlotNo ((p, SizeInBytes), Time)
forall p v. IntPSQ p v
Pq.empty
  PeerMetrics m p -> m (PeerMetrics m p)
forall (m :: * -> *) a. Monad m => a -> m a
return (PeerMetrics m p -> m (PeerMetrics m p))
-> PeerMetrics m p -> m (PeerMetrics m p)
forall a b. (a -> b) -> a -> b
$ StrictTVar m (IntPSQ SlotNo (p, Time))
-> StrictTVar m (IntPSQ SlotNo ((p, SizeInBytes), Time))
-> PeerMetrics m p
forall (m :: * -> *) p.
StrictTVar m (SlotMetric p)
-> StrictTVar m (SlotMetric (p, SizeInBytes)) -> PeerMetrics m p
PeerMetrics StrictTVar m (IntPSQ SlotNo (p, Time))
hs StrictTVar m (IntPSQ SlotNo ((p, SizeInBytes), Time))
bs

-- 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.  ( Ord p )
    => SlotMetric p
    -> Map p Int
upstreamyness :: SlotMetric p -> Map p Int
upstreamyness = (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
Pq.fold' Int -> SlotNo -> (p, Time) -> Map p Int -> Map p Int
count Map p Int
forall k a. Map k a
Map.empty
  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


-- Returns a Map which counts the number of bytes downloaded
-- for a given peer.
fetchynessBytes
    :: forall p.  ( Ord p )
    => SlotMetric (p, SizeInBytes)
    -> Map p Int
fetchynessBytes :: SlotMetric (p, SizeInBytes) -> Map p Int
fetchynessBytes = (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
Pq.fold' Int -> SlotNo -> ((p, SizeInBytes), Time) -> Map p Int -> Map p Int
count Map p Int
forall k a. Map k a
Map.empty
  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

-- Returns a Map which counts the number of times a given peer
-- was the first we downloaded a block from.
fetchynessBlocks
    :: forall p.  ( Ord p )
    => SlotMetric (p, SizeInBytes)
    -> Map p Int
fetchynessBlocks :: SlotMetric (p, SizeInBytes) -> Map p Int
fetchynessBlocks = (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
Pq.fold' Int -> SlotNo -> ((p, SizeInBytes), Time) -> Map p Int -> Map p Int
count Map p Int
forall k a. Map k a
Map.empty
  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