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

module Bcc.Tracing.Peer
  ( Peer (..)
  , getCurrentPeers
  , ppPeer
  , tracePeers
  ) where

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

import qualified Control.Monad.Class.MonadSTM.Strict as STM

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           NoThunks.Class (NoThunks, AllowThunk (..))

import           Bcc.BM.Data.LogItem (LOContent (..))
import           Bcc.BM.Data.Tracer (emptyObject, mkObject)
import           Bcc.BM.Trace (traceNamedObject)
import           Bcc.BM.Tracing

import           Shardagnostic.Consensus.Block (Header)
import           Shardagnostic.Consensus.Node (remoteAddress)
import           Shardagnostic.Consensus.Util.Orphans ()

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

import           Bcc.Tracing.Kernel

data Peer blk =
  Peer
  !RemoteConnectionId
  !(Net.AnchoredFragment (Header blk))
  !(PeerFetchStatus (Header blk))
  !(PeerFetchInFlight (Header blk))
  deriving ((forall x. Peer blk -> Rep (Peer blk) x)
-> (forall x. Rep (Peer blk) x -> Peer blk) -> Generic (Peer blk)
forall x. Rep (Peer blk) x -> Peer blk
forall x. Peer blk -> Rep (Peer blk) x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
forall blk x. Rep (Peer blk) x -> Peer blk
forall blk x. Peer blk -> Rep (Peer blk) x
$cto :: forall blk x. Rep (Peer blk) x -> Peer blk
$cfrom :: forall blk x. Peer blk -> Rep (Peer blk) x
Generic)
  deriving Context -> Peer blk -> IO (Maybe ThunkInfo)
Proxy (Peer blk) -> String
(Context -> Peer blk -> IO (Maybe ThunkInfo))
-> (Context -> Peer blk -> IO (Maybe ThunkInfo))
-> (Proxy (Peer blk) -> String)
-> NoThunks (Peer blk)
forall blk. Context -> Peer blk -> IO (Maybe ThunkInfo)
forall blk. Proxy (Peer blk) -> String
forall a.
(Context -> a -> IO (Maybe ThunkInfo))
-> (Context -> a -> IO (Maybe ThunkInfo))
-> (Proxy a -> String)
-> NoThunks a
showTypeOf :: Proxy (Peer blk) -> String
$cshowTypeOf :: forall blk. Proxy (Peer blk) -> String
wNoThunks :: Context -> Peer blk -> IO (Maybe ThunkInfo)
$cwNoThunks :: forall blk. Context -> Peer blk -> IO (Maybe ThunkInfo)
noThunks :: Context -> Peer blk -> IO (Maybe ThunkInfo)
$cnoThunks :: forall blk. Context -> Peer blk -> IO (Maybe ThunkInfo)
NoThunks via AllowThunk (Peer blk)

instance NFData (Peer blk) where
    rnf :: Peer blk -> ()
rnf Peer blk
_ = ()

ppPeer :: Peer blk -> Text
ppPeer :: Peer blk -> Text
ppPeer (Peer 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 [Peer blk]
getCurrentPeers :: NodeKernelData blk -> IO [Peer blk]
getCurrentPeers NodeKernelData blk
nkd = (NodeKernel IO RemoteConnectionId LocalConnectionId blk
 -> IO [Peer blk])
-> NodeKernelData blk -> IO (StrictMaybe [Peer blk])
forall blk a.
(NodeKernel IO RemoteConnectionId LocalConnectionId blk -> IO a)
-> NodeKernelData blk -> IO (StrictMaybe a)
mapNodeKernelDataIO NodeKernel IO RemoteConnectionId LocalConnectionId blk
-> IO [Peer blk]
forall blk.
NodeKernel IO RemoteConnectionId LocalConnectionId blk
-> IO [Peer blk]
extractPeers NodeKernelData blk
nkd
                      IO (StrictMaybe [Peer blk])
-> (StrictMaybe [Peer blk] -> [Peer blk]) -> IO [Peer blk]
forall (f :: * -> *) a b. Functor f => f a -> (a -> b) -> f b
<&> [Peer blk] -> StrictMaybe [Peer blk] -> [Peer blk]
forall a. a -> StrictMaybe a -> a
fromSMaybe [Peer 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 [Peer blk]
  extractPeers :: NodeKernel IO RemoteConnectionId LocalConnectionId blk
-> IO [Peer 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 (Peer blk)
peers = ((RemoteConnectionId
  -> AnchoredFragment (Header blk) -> Maybe (Peer blk))
 -> Map RemoteConnectionId (AnchoredFragment (Header blk))
 -> Map RemoteConnectionId (Peer blk))
-> Map RemoteConnectionId (AnchoredFragment (Header blk))
-> (RemoteConnectionId
    -> AnchoredFragment (Header blk) -> Maybe (Peer blk))
-> Map RemoteConnectionId (Peer blk)
forall a b c. (a -> b -> c) -> b -> a -> c
flip (RemoteConnectionId
 -> AnchoredFragment (Header blk) -> Maybe (Peer blk))
-> Map RemoteConnectionId (AnchoredFragment (Header blk))
-> Map RemoteConnectionId (Peer 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 (Peer blk))
 -> Map RemoteConnectionId (Peer blk))
-> (RemoteConnectionId
    -> AnchoredFragment (Header blk) -> Maybe (Peer blk))
-> Map RemoteConnectionId (Peer blk)
forall a b. (a -> b) -> a -> b
$ \RemoteConnectionId
cid AnchoredFragment (Header blk)
af ->
                  Maybe (Peer blk)
-> ((PeerFetchStatus (Header blk), PeerFetchInFlight (Header blk))
    -> Maybe (Peer blk))
-> Maybe
     (PeerFetchStatus (Header blk), PeerFetchInFlight (Header blk))
-> Maybe (Peer blk)
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Maybe (Peer blk)
forall a. Maybe a
Nothing
                        (\(PeerFetchStatus (Header blk)
status, PeerFetchInFlight (Header blk)
inflight) -> Peer blk -> Maybe (Peer blk)
forall a. a -> Maybe a
Just (Peer blk -> Maybe (Peer blk)) -> Peer blk -> Maybe (Peer blk)
forall a b. (a -> b) -> a -> b
$ RemoteConnectionId
-> AnchoredFragment (Header blk)
-> PeerFetchStatus (Header blk)
-> PeerFetchInFlight (Header blk)
-> Peer blk
forall blk.
RemoteConnectionId
-> AnchoredFragment (Header blk)
-> PeerFetchStatus (Header blk)
-> PeerFetchInFlight (Header blk)
-> Peer blk
Peer RemoteConnectionId
cid AnchoredFragment (Header blk)
af PeerFetchStatus (Header blk)
status PeerFetchInFlight (Header blk)
inflight)
                        (Maybe
   (PeerFetchStatus (Header blk), PeerFetchInFlight (Header blk))
 -> Maybe (Peer blk))
-> Maybe
     (PeerFetchStatus (Header blk), PeerFetchInFlight (Header blk))
-> Maybe (Peer 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
    [Peer blk] -> IO [Peer blk]
forall (f :: * -> *) a. Applicative f => a -> f a
pure ([Peer blk] -> IO [Peer blk])
-> (Map RemoteConnectionId (Peer blk) -> [Peer blk])
-> Map RemoteConnectionId (Peer blk)
-> IO [Peer 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 (Peer blk) -> [Peer blk]
forall k a. Map k a -> [a]
Map.elems (Map RemoteConnectionId (Peer blk) -> IO [Peer blk])
-> Map RemoteConnectionId (Peer blk) -> IO [Peer blk]
forall a b. (a -> b) -> a -> b
$ Map RemoteConnectionId (Peer blk)
peers

-- | Trace peers list, it will be forwarded to an external process
--   (for example, to RTView service).
tracePeers
  :: Trace IO Text
  -> [Peer blk]
  -> IO ()
tracePeers :: Trace IO Text -> [Peer blk] -> IO ()
tracePeers Trace IO Text
tr [Peer blk]
peers = do
  let tr' :: Trace IO Text
tr' = Text -> Trace IO Text -> Trace IO Text
forall (m :: * -> *) a. Text -> Trace m a -> Trace m a
appendName Text
"metrics" Trace IO Text
tr
  let tr'' :: Trace IO Text
tr'' = Text -> Trace IO Text -> Trace IO Text
forall (m :: * -> *) a. Text -> Trace m a -> Trace m a
appendName Text
"peersFromNodeKernel" Trace IO Text
tr'
  LOMeta
meta <- Severity -> PrivacyAnnotation -> IO LOMeta
forall (m :: * -> *).
MonadIO m =>
Severity -> PrivacyAnnotation -> m LOMeta
mkLOMeta Severity
Notice PrivacyAnnotation
Public
  Trace IO Text -> (LOMeta, LOContent Text) -> IO ()
forall (m :: * -> *) a.
MonadIO m =>
Trace m a -> (LOMeta, LOContent a) -> m ()
traceNamedObject Trace IO Text
tr'' (LOMeta
meta, Object -> LOContent Text
forall a. Object -> LOContent a
LogStructured (Object -> LOContent Text) -> Object -> LOContent Text
forall a b. (a -> b) -> a -> b
$ TracingVerbosity -> [Peer blk] -> Object
forall a. ToObject a => TracingVerbosity -> a -> Object
toObject TracingVerbosity
MaximalVerbosity [Peer blk]
peers)

-- | Instances for converting [Peer blk] to Object.

instance ToObject [Peer blk] where
  toObject :: TracingVerbosity -> [Peer blk] -> Object
toObject TracingVerbosity
MinimalVerbosity [Peer blk]
_ = Object
forall a. ToObject a => HashMap Text a
emptyObject
  toObject TracingVerbosity
_ [] = Object
forall a. ToObject a => HashMap Text a
emptyObject
  toObject TracingVerbosity
verb [Peer blk]
xs = [(Text, Value)] -> Object
forall a. ToObject a => [(Text, a)] -> HashMap Text a
mkObject
    [ Text
"kind"  Text -> Value -> (Text, Value)
forall kv v. (KeyValue kv, ToJSON v) => Text -> v -> kv
.= Text -> Value
String Text
"NodeKernelPeers"
    , Text
"peers" Text -> Value -> (Text, Value)
forall kv v. (KeyValue kv, ToJSON v) => Text -> v -> kv
.= [Object] -> Value
forall a. ToJSON a => a -> Value
toJSON
      (([Object] -> Peer blk -> [Object])
-> [Object] -> [Peer blk] -> [Object]
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' (\[Object]
acc Peer blk
x -> TracingVerbosity -> Peer blk -> Object
forall a. ToObject a => TracingVerbosity -> a -> Object
toObject TracingVerbosity
verb Peer blk
x Object -> [Object] -> [Object]
forall a. a -> [a] -> [a]
: [Object]
acc) [] [Peer blk]
xs)
    ]

instance ToObject (Peer blk) where
  toObject :: TracingVerbosity -> Peer blk -> Object
toObject TracingVerbosity
_verb (Peer RemoteConnectionId
cid AnchoredFragment (Header blk)
_af PeerFetchStatus (Header blk)
status PeerFetchInFlight (Header blk)
inflight) =
    [(Text, Value)] -> Object
forall a. ToObject a => [(Text, a)] -> HashMap Text a
mkObject [ Text
"peerAddress"   Text -> Value -> (Text, Value)
forall kv v. (KeyValue kv, ToJSON v) => Text -> 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)
             , Text
"peerStatus"    Text -> Value -> (Text, Value)
forall kv v. (KeyValue kv, ToJSON v) => Text -> 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)
             , Text
"peerSlotNo"    Text -> Value -> (Text, Value)
forall kv v. (KeyValue kv, ToJSON v) => Text -> 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)
             , Text
"peerReqsInF"   Text -> Value -> (Text, Value)
forall kv v. (KeyValue kv, ToJSON v) => Text -> 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)
             , Text
"peerBlocksInF" Text -> Value -> (Text, Value)
forall kv v. (KeyValue kv, ToJSON v) => Text -> 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)
             , Text
"peerBytesInF"  Text -> Value -> (Text, Value)
forall kv v. (KeyValue kv, ToJSON v) => Text -> 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)
             ]