{-# LANGUAGE DerivingVia #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE PackageImports #-}

module Cardano.Node.Tracing.Tracers.Peer
  ( PeerT (..)
  , startPeerTracer
  , namesForPeers
  , severityPeers
  , docPeers
  , ppPeer
  ) where

import           Cardano.Prelude hiding (atomically)
import           Prelude (String)

import qualified Control.Monad.Class.MonadSTM.Strict as STM
import           "contra-tracer" Control.Tracer

import           Data.Aeson (ToJSON (..), Value (..), toJSON, (.=))
import qualified Data.Map.Strict as Map
import qualified Data.Set as Set
import qualified Data.Text as Text
import           Text.Printf (printf)

import           Ouroboros.Consensus.Block (Header)
import           Ouroboros.Consensus.Util.Orphans ()
import           Ouroboros.Network.ConnectionId (remoteAddress)

import qualified Ouroboros.Network.AnchoredFragment as Net
import           Ouroboros.Network.Block (unSlotNo)
import qualified Ouroboros.Network.Block as Net
import qualified Ouroboros.Network.BlockFetch.ClientRegistry as Net
import           Ouroboros.Network.BlockFetch.ClientState (PeerFetchInFlight (..),
                   PeerFetchStatus (..), readFetchClientState)

import           Cardano.Logging hiding (traceWith)
import           Cardano.Node.Queries

startPeerTracer
  :: Tracer IO [PeerT blk]
  -> NodeKernelData blk
  -> Int
  -> IO ()
startPeerTracer :: Tracer IO [PeerT blk] -> NodeKernelData blk -> Int -> IO ()
startPeerTracer Tracer IO [PeerT blk]
tr NodeKernelData blk
nodeKern Int
delayMilliseconds = do
    Async ()
as <- IO () -> IO (Async ())
forall a. IO a -> IO (Async a)
async IO ()
peersThread
    Async () -> IO ()
forall a. Async a -> IO ()
link Async ()
as
  where
    peersThread :: IO ()
    peersThread :: IO ()
peersThread = IO () -> IO ()
forall (f :: * -> *) a b. Applicative f => f a -> f b
forever (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
          [PeerT blk]
peers <- NodeKernelData blk -> IO [PeerT blk]
forall blk. NodeKernelData blk -> IO [PeerT blk]
getCurrentPeers NodeKernelData blk
nodeKern
          Tracer IO [PeerT blk] -> [PeerT blk] -> IO ()
forall (m :: * -> *) a. Tracer m a -> a -> m ()
traceWith Tracer IO [PeerT blk]
tr [PeerT blk]
peers
          Int -> IO ()
threadDelay (Int
delayMilliseconds Int -> Int -> Int
forall a. Num a => a -> a -> a
* Int
1000)

data PeerT blk = PeerT
    RemoteConnectionId
    (Net.AnchoredFragment (Header blk))
    (PeerFetchStatus (Header blk))
    (PeerFetchInFlight (Header blk))


ppPeer :: PeerT blk -> Text
ppPeer :: PeerT blk -> Text
ppPeer (PeerT RemoteConnectionId
cid AnchoredFragment (Header blk)
_af PeerFetchStatus (Header blk)
status PeerFetchInFlight (Header blk)
inflight) =
  String -> Text
Text.pack (String -> Text) -> String -> Text
forall a b. (a -> b) -> a -> b
$ String -> String -> String -> String -> String
forall r. PrintfType r => String -> r
printf String
"%-15s %-8s %s" (RemoteConnectionId -> String
ppCid RemoteConnectionId
cid) (PeerFetchStatus (Header blk) -> String
forall header. PeerFetchStatus header -> String
ppStatus PeerFetchStatus (Header blk)
status) (PeerFetchInFlight (Header blk) -> String
forall header. PeerFetchInFlight header -> String
ppInFlight PeerFetchInFlight (Header blk)
inflight)

ppCid :: RemoteConnectionId -> String
ppCid :: RemoteConnectionId -> String
ppCid = (Char -> Bool) -> String -> String
forall a. (a -> Bool) -> [a] -> [a]
takeWhile (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
/= Char
':') (String -> String)
-> (RemoteConnectionId -> String) -> RemoteConnectionId -> String
forall k (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. RemoteAddress -> String
forall a b. (Show a, ConvertText String b) => a -> b
show (RemoteAddress -> String)
-> (RemoteConnectionId -> RemoteAddress)
-> RemoteConnectionId
-> String
forall k (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. RemoteConnectionId -> RemoteAddress
forall addr. ConnectionId addr -> addr
remoteAddress

ppInFlight :: PeerFetchInFlight header -> String
ppInFlight :: PeerFetchInFlight header -> String
ppInFlight PeerFetchInFlight header
f = String -> String -> Word -> Int -> SizeInBytes -> String
forall r. PrintfType r => String -> r
printf
 String
"%5s  %3d  %5d  %6d"
 (MaxSlotNo -> String
ppMaxSlotNo (MaxSlotNo -> String) -> MaxSlotNo -> String
forall a b. (a -> b) -> a -> b
$ PeerFetchInFlight header -> MaxSlotNo
forall header. PeerFetchInFlight header -> MaxSlotNo
peerFetchMaxSlotNo PeerFetchInFlight header
f)
 (PeerFetchInFlight header -> Word
forall header. PeerFetchInFlight header -> Word
peerFetchReqsInFlight PeerFetchInFlight header
f)
 (Set (Point header) -> Int
forall a. Set a -> Int
Set.size (Set (Point header) -> Int) -> Set (Point header) -> Int
forall a b. (a -> b) -> a -> b
$ PeerFetchInFlight header -> Set (Point header)
forall header. PeerFetchInFlight header -> Set (Point header)
peerFetchBlocksInFlight PeerFetchInFlight header
f)
 (PeerFetchInFlight header -> SizeInBytes
forall header. PeerFetchInFlight header -> SizeInBytes
peerFetchBytesInFlight PeerFetchInFlight header
f)

ppMaxSlotNo :: Net.MaxSlotNo -> String
ppMaxSlotNo :: MaxSlotNo -> String
ppMaxSlotNo MaxSlotNo
Net.NoMaxSlotNo   = String
"???"
ppMaxSlotNo (Net.MaxSlotNo SlotNo
x) = Word64 -> String
forall a b. (Show a, ConvertText String b) => a -> b
show (SlotNo -> Word64
unSlotNo SlotNo
x)

ppStatus :: PeerFetchStatus header -> String
ppStatus :: PeerFetchStatus header -> String
ppStatus PeerFetchStatus header
PeerFetchStatusShutdown = String
"shutdown"
ppStatus PeerFetchStatus header
PeerFetchStatusAberrant = String
"aberrant"
ppStatus PeerFetchStatus header
PeerFetchStatusBusy     = String
"fetching"
ppStatus PeerFetchStatusReady {} = String
"ready"

getCurrentPeers
  :: NodeKernelData blk
  -> IO [PeerT blk]
getCurrentPeers :: NodeKernelData blk -> IO [PeerT blk]
getCurrentPeers NodeKernelData blk
nkd = (NodeKernel IO RemoteConnectionId LocalConnectionId blk
 -> IO [PeerT blk])
-> NodeKernelData blk -> IO (StrictMaybe [PeerT blk])
forall blk a.
(NodeKernel IO RemoteConnectionId LocalConnectionId blk -> IO a)
-> NodeKernelData blk -> IO (StrictMaybe a)
mapNodeKernelDataIO NodeKernel IO RemoteConnectionId LocalConnectionId blk
-> IO [PeerT blk]
forall blk.
NodeKernel IO RemoteConnectionId LocalConnectionId blk
-> IO [PeerT blk]
extractPeers NodeKernelData blk
nkd
                      IO (StrictMaybe [PeerT blk])
-> (StrictMaybe [PeerT blk] -> [PeerT blk]) -> IO [PeerT blk]
forall (f :: * -> *) a b. Functor f => f a -> (a -> b) -> f b
<&> [PeerT blk] -> StrictMaybe [PeerT blk] -> [PeerT blk]
forall a. a -> StrictMaybe a -> a
fromSMaybe [PeerT blk]
forall a. Monoid a => a
mempty
 where
  tuple3pop :: (a, b, c) -> (a, b)
  tuple3pop :: (a, b, c) -> (a, b)
tuple3pop (a
a, b
b, c
_) = (a
a, b
b)

  getCandidates
    :: STM.StrictTVar IO (Map peer (STM.StrictTVar IO (Net.AnchoredFragment (Header blk))))
    -> STM.STM IO (Map peer (Net.AnchoredFragment (Header blk)))
  getCandidates :: StrictTVar
  IO (Map peer (StrictTVar IO (AnchoredFragment (Header blk))))
-> STM IO (Map peer (AnchoredFragment (Header blk)))
getCandidates StrictTVar
  IO (Map peer (StrictTVar IO (AnchoredFragment (Header blk))))
var = StrictTVar
  IO (Map peer (StrictTVar IO (AnchoredFragment (Header blk))))
-> STM
     IO (Map peer (StrictTVar IO (AnchoredFragment (Header blk))))
forall (m :: * -> *) a. MonadSTM m => StrictTVar m a -> STM m a
STM.readTVar StrictTVar
  IO (Map peer (StrictTVar IO (AnchoredFragment (Header blk))))
var STM (Map peer (StrictTVar IO (AnchoredFragment (Header blk))))
-> (Map peer (StrictTVar IO (AnchoredFragment (Header blk)))
    -> STM (Map peer (AnchoredFragment (Header blk))))
-> STM (Map peer (AnchoredFragment (Header blk)))
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= (StrictTVar IO (AnchoredFragment (Header blk))
 -> STM (AnchoredFragment (Header blk)))
-> Map peer (StrictTVar IO (AnchoredFragment (Header blk)))
-> STM (Map peer (AnchoredFragment (Header blk)))
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse StrictTVar IO (AnchoredFragment (Header blk))
-> STM (AnchoredFragment (Header blk))
forall (m :: * -> *) a. MonadSTM m => StrictTVar m a -> STM m a
STM.readTVar

  extractPeers :: NodeKernel IO RemoteConnectionId LocalConnectionId blk
                -> IO [PeerT blk]
  extractPeers :: NodeKernel IO RemoteConnectionId LocalConnectionId blk
-> IO [PeerT blk]
extractPeers NodeKernel IO RemoteConnectionId LocalConnectionId blk
kernel = do
    Map
  RemoteConnectionId
  (PeerFetchStatus (Header blk), PeerFetchInFlight (Header blk))
peerStates <- ((PeerFetchStatus (Header blk), PeerFetchInFlight (Header blk),
  FetchClientStateVars IO (Header blk))
 -> (PeerFetchStatus (Header blk), PeerFetchInFlight (Header blk)))
-> Map
     RemoteConnectionId
     (PeerFetchStatus (Header blk), PeerFetchInFlight (Header blk),
      FetchClientStateVars IO (Header blk))
-> Map
     RemoteConnectionId
     (PeerFetchStatus (Header blk), PeerFetchInFlight (Header blk))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (PeerFetchStatus (Header blk), PeerFetchInFlight (Header blk),
 FetchClientStateVars IO (Header blk))
-> (PeerFetchStatus (Header blk), PeerFetchInFlight (Header blk))
forall a b c. (a, b, c) -> (a, b)
tuple3pop (Map
   RemoteConnectionId
   (PeerFetchStatus (Header blk), PeerFetchInFlight (Header blk),
    FetchClientStateVars IO (Header blk))
 -> Map
      RemoteConnectionId
      (PeerFetchStatus (Header blk), PeerFetchInFlight (Header blk)))
-> IO
     (Map
        RemoteConnectionId
        (PeerFetchStatus (Header blk), PeerFetchInFlight (Header blk),
         FetchClientStateVars IO (Header blk)))
-> IO
     (Map
        RemoteConnectionId
        (PeerFetchStatus (Header blk), PeerFetchInFlight (Header blk)))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (   STM
  (Map
     RemoteConnectionId
     (PeerFetchStatus (Header blk), PeerFetchInFlight (Header blk),
      FetchClientStateVars IO (Header blk)))
-> IO
     (Map
        RemoteConnectionId
        (PeerFetchStatus (Header blk), PeerFetchInFlight (Header blk),
         FetchClientStateVars IO (Header blk)))
forall (m :: * -> *) a.
(MonadSTM m, HasCallStack) =>
STM m a -> m a
STM.atomically
                                       (STM
   (Map
      RemoteConnectionId
      (PeerFetchStatus (Header blk), PeerFetchInFlight (Header blk),
       FetchClientStateVars IO (Header blk)))
 -> IO
      (Map
         RemoteConnectionId
         (PeerFetchStatus (Header blk), PeerFetchInFlight (Header blk),
          FetchClientStateVars IO (Header blk))))
-> (NodeKernel IO RemoteConnectionId LocalConnectionId blk
    -> STM
         (Map
            RemoteConnectionId
            (PeerFetchStatus (Header blk), PeerFetchInFlight (Header blk),
             FetchClientStateVars IO (Header blk))))
-> NodeKernel IO RemoteConnectionId LocalConnectionId blk
-> IO
     (Map
        RemoteConnectionId
        (PeerFetchStatus (Header blk), PeerFetchInFlight (Header blk),
         FetchClientStateVars IO (Header blk)))
forall k (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. (STM (Map RemoteConnectionId (FetchClientStateVars IO (Header blk)))
-> (Map RemoteConnectionId (FetchClientStateVars IO (Header blk))
    -> STM
         (Map
            RemoteConnectionId
            (PeerFetchStatus (Header blk), PeerFetchInFlight (Header blk),
             FetchClientStateVars IO (Header blk))))
-> STM
     (Map
        RemoteConnectionId
        (PeerFetchStatus (Header blk), PeerFetchInFlight (Header blk),
         FetchClientStateVars IO (Header blk)))
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= (FetchClientStateVars IO (Header blk)
 -> STM
      (PeerFetchStatus (Header blk), PeerFetchInFlight (Header blk),
       FetchClientStateVars IO (Header blk)))
-> Map RemoteConnectionId (FetchClientStateVars IO (Header blk))
-> STM
     (Map
        RemoteConnectionId
        (PeerFetchStatus (Header blk), PeerFetchInFlight (Header blk),
         FetchClientStateVars IO (Header blk)))
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse FetchClientStateVars IO (Header blk)
-> STM
     (PeerFetchStatus (Header blk), PeerFetchInFlight (Header blk),
      FetchClientStateVars IO (Header blk))
forall (m :: * -> *) header.
MonadSTM m =>
FetchClientStateVars m header
-> STM
     m
     (PeerFetchStatus header, PeerFetchInFlight header,
      FetchClientStateVars m header)
readFetchClientState)
                                       (STM
   (Map RemoteConnectionId (FetchClientStateVars IO (Header blk)))
 -> STM
      (Map
         RemoteConnectionId
         (PeerFetchStatus (Header blk), PeerFetchInFlight (Header blk),
          FetchClientStateVars IO (Header blk))))
-> (NodeKernel IO RemoteConnectionId LocalConnectionId blk
    -> STM
         (Map RemoteConnectionId (FetchClientStateVars IO (Header blk))))
-> NodeKernel IO RemoteConnectionId LocalConnectionId blk
-> STM
     (Map
        RemoteConnectionId
        (PeerFetchStatus (Header blk), PeerFetchInFlight (Header blk),
         FetchClientStateVars IO (Header blk)))
forall k (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. FetchClientRegistry RemoteConnectionId (Header blk) blk IO
-> STM
     (Map RemoteConnectionId (FetchClientStateVars IO (Header blk)))
forall (m :: * -> *) peer header block.
MonadSTM m =>
FetchClientRegistry peer header block m
-> STM m (Map peer (FetchClientStateVars m header))
Net.readFetchClientsStateVars
                                       (FetchClientRegistry RemoteConnectionId (Header blk) blk IO
 -> STM
      (Map RemoteConnectionId (FetchClientStateVars IO (Header blk))))
-> (NodeKernel IO RemoteConnectionId LocalConnectionId blk
    -> FetchClientRegistry RemoteConnectionId (Header blk) blk IO)
-> NodeKernel IO RemoteConnectionId LocalConnectionId blk
-> STM
     (Map RemoteConnectionId (FetchClientStateVars IO (Header blk)))
forall k (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. NodeKernel IO RemoteConnectionId LocalConnectionId blk
-> FetchClientRegistry RemoteConnectionId (Header blk) blk IO
forall (m :: * -> *) remotePeer localPeer blk.
NodeKernel m remotePeer localPeer blk
-> FetchClientRegistry remotePeer (Header blk) blk m
getFetchClientRegistry (NodeKernel IO RemoteConnectionId LocalConnectionId blk
 -> IO
      (Map
         RemoteConnectionId
         (PeerFetchStatus (Header blk), PeerFetchInFlight (Header blk),
          FetchClientStateVars IO (Header blk))))
-> NodeKernel IO RemoteConnectionId LocalConnectionId blk
-> IO
     (Map
        RemoteConnectionId
        (PeerFetchStatus (Header blk), PeerFetchInFlight (Header blk),
         FetchClientStateVars IO (Header blk)))
forall a b. (a -> b) -> a -> b
$ NodeKernel IO RemoteConnectionId LocalConnectionId blk
kernel
                                     )
    Map RemoteConnectionId (AnchoredFragment (Header blk))
candidates <- STM (Map RemoteConnectionId (AnchoredFragment (Header blk)))
-> IO (Map RemoteConnectionId (AnchoredFragment (Header blk)))
forall (m :: * -> *) a.
(MonadSTM m, HasCallStack) =>
STM m a -> m a
STM.atomically (STM (Map RemoteConnectionId (AnchoredFragment (Header blk)))
 -> IO (Map RemoteConnectionId (AnchoredFragment (Header blk))))
-> (NodeKernel IO RemoteConnectionId LocalConnectionId blk
    -> STM (Map RemoteConnectionId (AnchoredFragment (Header blk))))
-> NodeKernel IO RemoteConnectionId LocalConnectionId blk
-> IO (Map RemoteConnectionId (AnchoredFragment (Header blk)))
forall k (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. StrictTVar
  IO
  (Map
     RemoteConnectionId (StrictTVar IO (AnchoredFragment (Header blk))))
-> STM (Map RemoteConnectionId (AnchoredFragment (Header blk)))
forall peer blk.
StrictTVar
  IO (Map peer (StrictTVar IO (AnchoredFragment (Header blk))))
-> STM IO (Map peer (AnchoredFragment (Header blk)))
getCandidates (StrictTVar
   IO
   (Map
      RemoteConnectionId (StrictTVar IO (AnchoredFragment (Header blk))))
 -> STM (Map RemoteConnectionId (AnchoredFragment (Header blk))))
-> (NodeKernel IO RemoteConnectionId LocalConnectionId blk
    -> StrictTVar
         IO
         (Map
            RemoteConnectionId
            (StrictTVar IO (AnchoredFragment (Header blk)))))
-> NodeKernel IO RemoteConnectionId LocalConnectionId blk
-> STM (Map RemoteConnectionId (AnchoredFragment (Header blk)))
forall k (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. NodeKernel IO RemoteConnectionId LocalConnectionId blk
-> StrictTVar
     IO
     (Map
        RemoteConnectionId (StrictTVar IO (AnchoredFragment (Header blk))))
forall (m :: * -> *) remotePeer localPeer blk.
NodeKernel m remotePeer localPeer blk
-> StrictTVar
     m (Map remotePeer (StrictTVar m (AnchoredFragment (Header blk))))
getNodeCandidates (NodeKernel IO RemoteConnectionId LocalConnectionId blk
 -> IO (Map RemoteConnectionId (AnchoredFragment (Header blk))))
-> NodeKernel IO RemoteConnectionId LocalConnectionId blk
-> IO (Map RemoteConnectionId (AnchoredFragment (Header blk)))
forall a b. (a -> b) -> a -> b
$ NodeKernel IO RemoteConnectionId LocalConnectionId blk
kernel

    let peers :: Map RemoteConnectionId (PeerT blk)
peers = ((RemoteConnectionId
  -> AnchoredFragment (Header blk) -> Maybe (PeerT blk))
 -> Map RemoteConnectionId (AnchoredFragment (Header blk))
 -> Map RemoteConnectionId (PeerT blk))
-> Map RemoteConnectionId (AnchoredFragment (Header blk))
-> (RemoteConnectionId
    -> AnchoredFragment (Header blk) -> Maybe (PeerT blk))
-> Map RemoteConnectionId (PeerT blk)
forall a b c. (a -> b -> c) -> b -> a -> c
flip (RemoteConnectionId
 -> AnchoredFragment (Header blk) -> Maybe (PeerT blk))
-> Map RemoteConnectionId (AnchoredFragment (Header blk))
-> Map RemoteConnectionId (PeerT blk)
forall k a b. (k -> a -> Maybe b) -> Map k a -> Map k b
Map.mapMaybeWithKey Map RemoteConnectionId (AnchoredFragment (Header blk))
candidates ((RemoteConnectionId
  -> AnchoredFragment (Header blk) -> Maybe (PeerT blk))
 -> Map RemoteConnectionId (PeerT blk))
-> (RemoteConnectionId
    -> AnchoredFragment (Header blk) -> Maybe (PeerT blk))
-> Map RemoteConnectionId (PeerT blk)
forall a b. (a -> b) -> a -> b
$ \RemoteConnectionId
cid AnchoredFragment (Header blk)
af ->
                  Maybe (PeerT blk)
-> ((PeerFetchStatus (Header blk), PeerFetchInFlight (Header blk))
    -> Maybe (PeerT blk))
-> Maybe
     (PeerFetchStatus (Header blk), PeerFetchInFlight (Header blk))
-> Maybe (PeerT blk)
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Maybe (PeerT blk)
forall a. Maybe a
Nothing
                        (\(PeerFetchStatus (Header blk)
status, PeerFetchInFlight (Header blk)
inflight) -> PeerT blk -> Maybe (PeerT blk)
forall a. a -> Maybe a
Just (PeerT blk -> Maybe (PeerT blk)) -> PeerT blk -> Maybe (PeerT blk)
forall a b. (a -> b) -> a -> b
$ RemoteConnectionId
-> AnchoredFragment (Header blk)
-> PeerFetchStatus (Header blk)
-> PeerFetchInFlight (Header blk)
-> PeerT blk
forall blk.
RemoteConnectionId
-> AnchoredFragment (Header blk)
-> PeerFetchStatus (Header blk)
-> PeerFetchInFlight (Header blk)
-> PeerT blk
PeerT RemoteConnectionId
cid AnchoredFragment (Header blk)
af PeerFetchStatus (Header blk)
status PeerFetchInFlight (Header blk)
inflight)
                        (Maybe
   (PeerFetchStatus (Header blk), PeerFetchInFlight (Header blk))
 -> Maybe (PeerT blk))
-> Maybe
     (PeerFetchStatus (Header blk), PeerFetchInFlight (Header blk))
-> Maybe (PeerT blk)
forall a b. (a -> b) -> a -> b
$ RemoteConnectionId
-> Map
     RemoteConnectionId
     (PeerFetchStatus (Header blk), PeerFetchInFlight (Header blk))
-> Maybe
     (PeerFetchStatus (Header blk), PeerFetchInFlight (Header blk))
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup RemoteConnectionId
cid Map
  RemoteConnectionId
  (PeerFetchStatus (Header blk), PeerFetchInFlight (Header blk))
peerStates
    [PeerT blk] -> IO [PeerT blk]
forall (f :: * -> *) a. Applicative f => a -> f a
pure ([PeerT blk] -> IO [PeerT blk])
-> (Map RemoteConnectionId (PeerT blk) -> [PeerT blk])
-> Map RemoteConnectionId (PeerT blk)
-> IO [PeerT blk]
forall k (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. Map RemoteConnectionId (PeerT blk) -> [PeerT blk]
forall k a. Map k a -> [a]
Map.elems (Map RemoteConnectionId (PeerT blk) -> IO [PeerT blk])
-> Map RemoteConnectionId (PeerT blk) -> IO [PeerT blk]
forall a b. (a -> b) -> a -> b
$ Map RemoteConnectionId (PeerT blk)
peers

--------------------------------------------------------------------------------
-- Peers Tracer
--------------------------------------------------------------------------------

namesForPeers :: [PeerT blk] -> [Text]
namesForPeers :: [PeerT blk] -> [Text]
namesForPeers [PeerT blk]
_ = []

severityPeers :: [PeerT blk] -> SeverityS
severityPeers :: [PeerT blk] -> SeverityS
severityPeers [] = SeverityS
Debug
severityPeers [PeerT blk]
_ = SeverityS
Notice

instance LogFormatting [PeerT blk] where
  forMachine :: DetailLevel -> [PeerT blk] -> Object
forMachine DetailLevel
_ []       = Object
forall a. Monoid a => a
mempty
  forMachine DetailLevel
dtal [PeerT blk]
xs    = [Object] -> Object
forall a. Monoid a => [a] -> a
mconcat
    [ Key
"kind"  Key -> Value -> Object
forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= Text -> Value
String Text
"NodeKernelPeers"
    , Key
"peers" Key -> Value -> Object
forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= [Object] -> Value
forall a. ToJSON a => a -> Value
toJSON (([Object] -> PeerT blk -> [Object])
-> [Object] -> [PeerT blk] -> [Object]
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' (\[Object]
acc PeerT blk
x -> DetailLevel -> PeerT blk -> Object
forall a. LogFormatting a => DetailLevel -> a -> Object
forMachine DetailLevel
dtal PeerT blk
x Object -> [Object] -> [Object]
forall a. a -> [a] -> [a]
: [Object]
acc) [] [PeerT blk]
xs)
    ]
  forHuman :: [PeerT blk] -> Text
forHuman [PeerT blk]
peers = [Text] -> Text
Text.concat ([Text] -> Text) -> [Text] -> Text
forall a b. (a -> b) -> a -> b
$ Text -> [Text] -> [Text]
forall a. a -> [a] -> [a]
intersperse Text
", " ((PeerT blk -> Text) -> [PeerT blk] -> [Text]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
map PeerT blk -> Text
forall blk. PeerT blk -> Text
ppPeer [PeerT blk]
peers)
  asMetrics :: [PeerT blk] -> [Metric]
asMetrics [PeerT blk]
peers = [Text -> Integer -> Metric
IntM Text
"peersFromNodeKernel" (Int -> Integer
forall a b. (Integral a, Num b) => a -> b
fromIntegral ([PeerT blk] -> Int
forall a. HasLength a => a -> Int
length [PeerT blk]
peers))]

instance LogFormatting (PeerT blk) where
  forMachine :: DetailLevel -> PeerT blk -> Object
forMachine DetailLevel
_dtal (PeerT RemoteConnectionId
cid AnchoredFragment (Header blk)
_af PeerFetchStatus (Header blk)
status PeerFetchInFlight (Header blk)
inflight) =
    [Object] -> Object
forall a. Monoid a => [a] -> a
mconcat [ Key
"peerAddress"   Key -> Value -> Object
forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= Text -> Value
String (String -> Text
Text.pack (String -> Text)
-> (RemoteConnectionId -> String) -> RemoteConnectionId -> Text
forall k (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. RemoteAddress -> String
forall a b. (Show a, ConvertText String b) => a -> b
show (RemoteAddress -> String)
-> (RemoteConnectionId -> RemoteAddress)
-> RemoteConnectionId
-> String
forall k (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. RemoteConnectionId -> RemoteAddress
forall addr. ConnectionId addr -> addr
remoteAddress (RemoteConnectionId -> Text) -> RemoteConnectionId -> Text
forall a b. (a -> b) -> a -> b
$ RemoteConnectionId
cid)
             , Key
"peerStatus"    Key -> Value -> Object
forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= Text -> Value
String (String -> Text
Text.pack (String -> Text)
-> (PeerFetchStatus (Header blk) -> String)
-> PeerFetchStatus (Header blk)
-> Text
forall k (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. PeerFetchStatus (Header blk) -> String
forall header. PeerFetchStatus header -> String
ppStatus (PeerFetchStatus (Header blk) -> Text)
-> PeerFetchStatus (Header blk) -> Text
forall a b. (a -> b) -> a -> b
$ PeerFetchStatus (Header blk)
status)
             , Key
"peerSlotNo"    Key -> Value -> Object
forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= Text -> Value
String (String -> Text
Text.pack (String -> Text)
-> (PeerFetchInFlight (Header blk) -> String)
-> PeerFetchInFlight (Header blk)
-> Text
forall k (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. MaxSlotNo -> String
ppMaxSlotNo (MaxSlotNo -> String)
-> (PeerFetchInFlight (Header blk) -> MaxSlotNo)
-> PeerFetchInFlight (Header blk)
-> String
forall k (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. PeerFetchInFlight (Header blk) -> MaxSlotNo
forall header. PeerFetchInFlight header -> MaxSlotNo
peerFetchMaxSlotNo (PeerFetchInFlight (Header blk) -> Text)
-> PeerFetchInFlight (Header blk) -> Text
forall a b. (a -> b) -> a -> b
$ PeerFetchInFlight (Header blk)
inflight)
             , Key
"peerReqsInF"   Key -> Value -> Object
forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= Text -> Value
String (Word -> Text
forall a b. (Show a, ConvertText String b) => a -> b
show (Word -> Text)
-> (PeerFetchInFlight (Header blk) -> Word)
-> PeerFetchInFlight (Header blk)
-> Text
forall k (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. PeerFetchInFlight (Header blk) -> Word
forall header. PeerFetchInFlight header -> Word
peerFetchReqsInFlight (PeerFetchInFlight (Header blk) -> Text)
-> PeerFetchInFlight (Header blk) -> Text
forall a b. (a -> b) -> a -> b
$ PeerFetchInFlight (Header blk)
inflight)
             , Key
"peerBlocksInF" Key -> Value -> Object
forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= Text -> Value
String (Int -> Text
forall a b. (Show a, ConvertText String b) => a -> b
show (Int -> Text)
-> (PeerFetchInFlight (Header blk) -> Int)
-> PeerFetchInFlight (Header blk)
-> Text
forall k (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. Set (Point (Header blk)) -> Int
forall a. Set a -> Int
Set.size (Set (Point (Header blk)) -> Int)
-> (PeerFetchInFlight (Header blk) -> Set (Point (Header blk)))
-> PeerFetchInFlight (Header blk)
-> Int
forall k (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. PeerFetchInFlight (Header blk) -> Set (Point (Header blk))
forall header. PeerFetchInFlight header -> Set (Point header)
peerFetchBlocksInFlight (PeerFetchInFlight (Header blk) -> Text)
-> PeerFetchInFlight (Header blk) -> Text
forall a b. (a -> b) -> a -> b
$ PeerFetchInFlight (Header blk)
inflight)
             , Key
"peerBytesInF"  Key -> Value -> Object
forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= Text -> Value
String (SizeInBytes -> Text
forall a b. (Show a, ConvertText String b) => a -> b
show (SizeInBytes -> Text)
-> (PeerFetchInFlight (Header blk) -> SizeInBytes)
-> PeerFetchInFlight (Header blk)
-> Text
forall k (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. PeerFetchInFlight (Header blk) -> SizeInBytes
forall header. PeerFetchInFlight header -> SizeInBytes
peerFetchBytesInFlight (PeerFetchInFlight (Header blk) -> Text)
-> PeerFetchInFlight (Header blk) -> Text
forall a b. (a -> b) -> a -> b
$ PeerFetchInFlight (Header blk)
inflight)
             ]

docPeers :: Documented [PeerT blk]
docPeers :: Documented [PeerT blk]
docPeers = [DocMsg [PeerT blk]] -> Documented [PeerT blk]
forall a. [DocMsg a] -> Documented a
Documented [
      [Text] -> [(Text, Text)] -> Text -> DocMsg [PeerT blk]
forall a. [Text] -> [(Text, Text)] -> Text -> DocMsg a
DocMsg
        []
        [(Text
"peersFromNodeKernel",Text
"TODO Doc")]
        Text
"TODO Doc"
    ]