{-# LANGUAGE DeriveFunctor             #-}
{-# LANGUAGE DeriveGeneric             #-}
{-# LANGUAGE DerivingVia               #-}
{-# LANGUAGE ExistentialQuantification #-}
{-# LANGUAGE LambdaCase                #-}
{-# LANGUAGE NamedFieldPuns            #-}
{-# LANGUAGE OverloadedStrings         #-}
{-# LANGUAGE PatternSynonyms           #-}
{-# LANGUAGE RankNTypes                #-}
{-# LANGUAGE ViewPatterns              #-}

-- TODO: needed with GHC-8.10
{-# OPTIONS_GHC -Wno-name-shadowing #-}
module Network.Mux.Trace
  ( -- * Exceptions
    Error (..)
  , handleIOException
    -- * Trace events
  , Trace (..)
  , ChannelTrace (..)
  , BearerTrace (..)
    -- * Tracers
  , Tracers' (.., TracersI, tracer_, channelTracer_, bearerTracer_)
  , contramapTracers'
  , Tracers
  , nullTracers
  , tracersWith
  , TracersWithBearer
  , tracersWithBearer
    -- * Tracing wrappers
  , WithBearer (..)
  , TraceLabelPeer (..)
    -- * State
  , State (..)
  ) where

import Prelude hiding (read)

import Formatting (formatToString, (%+))
import Formatting qualified as F

import Control.Exception hiding (throwIO)
import Control.Monad.Class.MonadThrow
import Control.Tracer (Tracer, nullTracer)
import Data.Bifunctor (Bifunctor (..))
import Data.Functor.Contravariant (contramap, (>$<))
import Data.Functor.Identity
import GHC.Generics (Generic (..))
import Quiet (Quiet (..))

import Network.Mux.Types


--
-- Errors
--

-- | Enumeration of error conditions.
--
data Error = UnknownMiniProtocol MiniProtocolNum
           -- ^ returned by 'decodeSDUHeader', thrown by 'Bearer'.
           | BearerClosed String
           -- ^ thrown by 'Bearer' when received a null byte.
           | IngressQueueOverRun MiniProtocolNum MiniProtocolDir
           -- ^ thrown by 'demux' when violating 'maximumIngressQueue'
           -- byte limit.
           | InitiatorOnly MiniProtocolNum
           -- ^ thrown when data arrives on a responder channel when the
           -- mux was set up as an 'InitiatorApp'.
           | IOException IOException String
           -- ^ 'IOException' thrown by

           | SDUDecodeError String
           -- ^ return by 'decodeSDUHeader', thrown by 'Bearer'.
           | SDUReadTimeout
           -- ^ thrown when reading of a single SDU takes too long
           | SDUWriteTimeout
           -- ^ thrown when writing a single SDU takes too long

           | Shutdown (Maybe SomeException) Status
           -- ^ Result of runMiniProtocol's completionAction in case of
           -- an error or mux being closed while a mini-protocol was
           -- still running, this is not a clean exit.
           deriving Int -> Error -> ShowS
[Error] -> ShowS
Error -> String
(Int -> Error -> ShowS)
-> (Error -> String) -> ([Error] -> ShowS) -> Show Error
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> Error -> ShowS
showsPrec :: Int -> Error -> ShowS
$cshow :: Error -> String
show :: Error -> String
$cshowList :: [Error] -> ShowS
showList :: [Error] -> ShowS
Show

instance Exception Error where
  displayException :: Error -> String
displayException = \case
    UnknownMiniProtocol MiniProtocolNum
pnum      -> Format String (MiniProtocolNum -> String)
-> MiniProtocolNum -> String
forall a. Format String a -> a
formatToString (Format (MiniProtocolNum -> String) (MiniProtocolNum -> String)
"unknown mini-protocol" Format (MiniProtocolNum -> String) (MiniProtocolNum -> String)
-> Format String (MiniProtocolNum -> String)
-> Format String (MiniProtocolNum -> String)
forall r a r'. Format r a -> Format r' r -> Format r' a
%+ Format String (MiniProtocolNum -> String)
forall a r. Show a => Format r (a -> r)
F.shown) MiniProtocolNum
pnum
    BearerClosed String
msg              -> Format String ShowS -> ShowS
forall a. Format String a -> a
formatToString ( Format ShowS ShowS
"bearer closed:" Format ShowS ShowS -> Format String ShowS -> Format String ShowS
forall r a r'. Format r a -> Format r' r -> Format r' a
%+ Format String ShowS
forall a r. Show a => Format r (a -> r)
F.shown) String
msg
    IngressQueueOverRun MiniProtocolNum
pnum MiniProtocolDir
pdir -> Format String (MiniProtocolNum -> MiniProtocolDir -> String)
-> MiniProtocolNum -> MiniProtocolDir -> String
forall a. Format String a -> a
formatToString (Format
  (MiniProtocolNum -> MiniProtocolDir -> String)
  (MiniProtocolNum -> MiniProtocolDir -> String)
"ingress queue overrun for" Format
  (MiniProtocolNum -> MiniProtocolDir -> String)
  (MiniProtocolNum -> MiniProtocolDir -> String)
-> Format String (MiniProtocolNum -> MiniProtocolDir -> String)
-> Format String (MiniProtocolNum -> MiniProtocolDir -> String)
forall r a r'. Format r a -> Format r' r -> Format r' a
%+ Format
  (MiniProtocolDir -> String)
  (MiniProtocolNum -> MiniProtocolDir -> String)
forall a r. Show a => Format r (a -> r)
F.shown Format
  (MiniProtocolDir -> String)
  (MiniProtocolNum -> MiniProtocolDir -> String)
-> Format String (MiniProtocolDir -> String)
-> Format String (MiniProtocolNum -> MiniProtocolDir -> String)
forall r a r'. Format r a -> Format r' r -> Format r' a
%+ Format String (MiniProtocolDir -> String)
forall a r. Show a => Format r (a -> r)
F.shown) MiniProtocolNum
pnum MiniProtocolDir
pdir
    InitiatorOnly MiniProtocolNum
pnum            -> Format String (MiniProtocolNum -> String)
-> MiniProtocolNum -> String
forall a. Format String a -> a
formatToString (Format (MiniProtocolNum -> String) (MiniProtocolNum -> String)
"received data on initiator only protocol" Format (MiniProtocolNum -> String) (MiniProtocolNum -> String)
-> Format String (MiniProtocolNum -> String)
-> Format String (MiniProtocolNum -> String)
forall r a r'. Format r a -> Format r' r -> Format r' a
%+ Format String (MiniProtocolNum -> String)
forall a r. Show a => Format r (a -> r)
F.shown) MiniProtocolNum
pnum
    IOException IOException
e String
msg             -> Format String (String -> ShowS) -> String -> ShowS
forall a. Format String a -> a
formatToString (Format ShowS (String -> ShowS)
forall r. Format r (String -> r)
F.string Format ShowS (String -> ShowS)
-> Format String ShowS -> Format String (String -> ShowS)
forall r a r'. Format r a -> Format r' r -> Format r' a
F.% Format ShowS ShowS
":" Format ShowS ShowS -> Format String ShowS -> Format String ShowS
forall r a r'. Format r a -> Format r' r -> Format r' a
%+ Format String ShowS
forall r. Format r (String -> r)
F.string) (IOException -> String
forall e. Exception e => e -> String
displayException IOException
e) String
msg
    SDUDecodeError String
msg            -> Format String ShowS -> ShowS
forall a. Format String a -> a
formatToString (Format ShowS ShowS
"SDU decode error:" Format ShowS ShowS -> Format String ShowS -> Format String ShowS
forall r a r'. Format r a -> Format r' r -> Format r' a
%+ Format String ShowS
forall r. Format r (String -> r)
F.string) String
msg
    Error
SDUReadTimeout                -> String
"SDU read timeout expired"
    Error
SDUWriteTimeout               -> String
"SDU write timeout expired"
    Shutdown Maybe SomeException
Nothing Status
st           -> Format String (Status -> String) -> Status -> String
forall a. Format String a -> a
formatToString (Format (Status -> String) (Status -> String)
"mux shutdown error in state" Format (Status -> String) (Status -> String)
-> Format String (Status -> String)
-> Format String (Status -> String)
forall r a r'. Format r a -> Format r' r -> Format r' a
%+ Format String (Status -> String)
forall a r. Show a => Format r (a -> r)
F.shown) Status
st
    Shutdown (Just SomeException
e) Status
st          -> Format String (String -> Status -> String)
-> String -> Status -> String
forall a. Format String a -> a
formatToString (Format (String -> Status -> String) (String -> Status -> String)
"mux shutdown error" Format (String -> Status -> String) (String -> Status -> String)
-> Format String (String -> Status -> String)
-> Format String (String -> Status -> String)
forall r a r'. Format r a -> Format r' r -> Format r' a
%+ Format (Status -> String) (String -> Status -> String)
-> Format (Status -> String) (String -> Status -> String)
forall r a. Format r a -> Format r a
F.parenthesised Format (Status -> String) (String -> Status -> String)
forall r. Format r (String -> r)
F.string Format (Status -> String) (String -> Status -> String)
-> Format String (Status -> String)
-> Format String (String -> Status -> String)
forall r a r'. Format r a -> Format r' r -> Format r' a
%+ Format (Status -> String) (Status -> String)
"in state" Format (Status -> String) (Status -> String)
-> Format String (Status -> String)
-> Format String (Status -> String)
forall r a r'. Format r a -> Format r' r -> Format r' a
%+ Format String (Status -> String)
forall a r. Show a => Format r (a -> r)
F.shown) (SomeException -> String
forall e. Exception e => e -> String
displayException SomeException
e) Status
st

-- | Handler for 'IOException's which wraps them in 'Error'.
--
-- It is used various 'Bearer' implementations:
-- * 'socketAsBearer'
-- * 'pipeAsBearer'
--
handleIOException :: MonadThrow m => String -> IOException -> m a
handleIOException :: forall (m :: * -> *) a.
MonadThrow m =>
String -> IOException -> m a
handleIOException String
msg IOException
e = Error -> m a
forall e a. Exception e => e -> m a
forall (m :: * -> *) e a. (MonadThrow m, Exception e) => e -> m a
throwIO (IOException -> String -> Error
IOException IOException
e String
msg)


--
-- Tracing
--

-- | A peer label for use in 'Tracer's. This annotates tracer output as being
-- associated with a given peer identifier.
--
data TraceLabelPeer peerid a = TraceLabelPeer peerid a
  deriving (TraceLabelPeer peerid a -> TraceLabelPeer peerid a -> Bool
(TraceLabelPeer peerid a -> TraceLabelPeer peerid a -> Bool)
-> (TraceLabelPeer peerid a -> TraceLabelPeer peerid a -> Bool)
-> Eq (TraceLabelPeer peerid a)
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
forall peerid a.
(Eq peerid, Eq a) =>
TraceLabelPeer peerid a -> TraceLabelPeer peerid a -> Bool
$c== :: forall peerid a.
(Eq peerid, Eq a) =>
TraceLabelPeer peerid a -> TraceLabelPeer peerid a -> Bool
== :: TraceLabelPeer peerid a -> TraceLabelPeer peerid a -> Bool
$c/= :: forall peerid a.
(Eq peerid, Eq a) =>
TraceLabelPeer peerid a -> TraceLabelPeer peerid a -> Bool
/= :: TraceLabelPeer peerid a -> TraceLabelPeer peerid a -> Bool
Eq, (forall a b.
 (a -> b) -> TraceLabelPeer peerid a -> TraceLabelPeer peerid b)
-> (forall a b.
    a -> TraceLabelPeer peerid b -> TraceLabelPeer peerid a)
-> Functor (TraceLabelPeer peerid)
forall a b. a -> TraceLabelPeer peerid b -> TraceLabelPeer peerid a
forall a b.
(a -> b) -> TraceLabelPeer peerid a -> TraceLabelPeer peerid b
forall peerid a b.
a -> TraceLabelPeer peerid b -> TraceLabelPeer peerid a
forall peerid a b.
(a -> b) -> TraceLabelPeer peerid a -> TraceLabelPeer peerid b
forall (f :: * -> *).
(forall a b. (a -> b) -> f a -> f b)
-> (forall a b. a -> f b -> f a) -> Functor f
$cfmap :: forall peerid a b.
(a -> b) -> TraceLabelPeer peerid a -> TraceLabelPeer peerid b
fmap :: forall a b.
(a -> b) -> TraceLabelPeer peerid a -> TraceLabelPeer peerid b
$c<$ :: forall peerid a b.
a -> TraceLabelPeer peerid b -> TraceLabelPeer peerid a
<$ :: forall a b. a -> TraceLabelPeer peerid b -> TraceLabelPeer peerid a
Functor, Int -> TraceLabelPeer peerid a -> ShowS
[TraceLabelPeer peerid a] -> ShowS
TraceLabelPeer peerid a -> String
(Int -> TraceLabelPeer peerid a -> ShowS)
-> (TraceLabelPeer peerid a -> String)
-> ([TraceLabelPeer peerid a] -> ShowS)
-> Show (TraceLabelPeer peerid a)
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
forall peerid a.
(Show peerid, Show a) =>
Int -> TraceLabelPeer peerid a -> ShowS
forall peerid a.
(Show peerid, Show a) =>
[TraceLabelPeer peerid a] -> ShowS
forall peerid a.
(Show peerid, Show a) =>
TraceLabelPeer peerid a -> String
$cshowsPrec :: forall peerid a.
(Show peerid, Show a) =>
Int -> TraceLabelPeer peerid a -> ShowS
showsPrec :: Int -> TraceLabelPeer peerid a -> ShowS
$cshow :: forall peerid a.
(Show peerid, Show a) =>
TraceLabelPeer peerid a -> String
show :: TraceLabelPeer peerid a -> String
$cshowList :: forall peerid a.
(Show peerid, Show a) =>
[TraceLabelPeer peerid a] -> ShowS
showList :: [TraceLabelPeer peerid a] -> ShowS
Show)

instance Bifunctor TraceLabelPeer where
  bimap :: forall a b c d.
(a -> b) -> (c -> d) -> TraceLabelPeer a c -> TraceLabelPeer b d
bimap a -> b
f c -> d
g (TraceLabelPeer a
a c
b) = b -> d -> TraceLabelPeer b d
forall peerid a. peerid -> a -> TraceLabelPeer peerid a
TraceLabelPeer (a -> b
f a
a) (c -> d
g c
b)

-- | Type used for tracing mux events.
--
data WithBearer peerid a = WithBearer {
      forall peerid a. WithBearer peerid a -> peerid
wbPeerId :: !peerid
      -- ^ A tag that should identify a specific mux bearer.
    , forall peerid a. WithBearer peerid a -> a
wbEvent  :: !a
  }
  deriving ((forall x. WithBearer peerid a -> Rep (WithBearer peerid a) x)
-> (forall x. Rep (WithBearer peerid a) x -> WithBearer peerid a)
-> Generic (WithBearer peerid a)
forall x. Rep (WithBearer peerid a) x -> WithBearer peerid a
forall x. WithBearer peerid a -> Rep (WithBearer peerid a) x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
forall peerid a x.
Rep (WithBearer peerid a) x -> WithBearer peerid a
forall peerid a x.
WithBearer peerid a -> Rep (WithBearer peerid a) x
$cfrom :: forall peerid a x.
WithBearer peerid a -> Rep (WithBearer peerid a) x
from :: forall x. WithBearer peerid a -> Rep (WithBearer peerid a) x
$cto :: forall peerid a x.
Rep (WithBearer peerid a) x -> WithBearer peerid a
to :: forall x. Rep (WithBearer peerid a) x -> WithBearer peerid a
Generic)
  deriving Int -> WithBearer peerid a -> ShowS
[WithBearer peerid a] -> ShowS
WithBearer peerid a -> String
(Int -> WithBearer peerid a -> ShowS)
-> (WithBearer peerid a -> String)
-> ([WithBearer peerid a] -> ShowS)
-> Show (WithBearer peerid a)
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
forall peerid a.
(Show peerid, Show a) =>
Int -> WithBearer peerid a -> ShowS
forall peerid a.
(Show peerid, Show a) =>
[WithBearer peerid a] -> ShowS
forall peerid a.
(Show peerid, Show a) =>
WithBearer peerid a -> String
$cshowsPrec :: forall peerid a.
(Show peerid, Show a) =>
Int -> WithBearer peerid a -> ShowS
showsPrec :: Int -> WithBearer peerid a -> ShowS
$cshow :: forall peerid a.
(Show peerid, Show a) =>
WithBearer peerid a -> String
show :: WithBearer peerid a -> String
$cshowList :: forall peerid a.
(Show peerid, Show a) =>
[WithBearer peerid a] -> ShowS
showList :: [WithBearer peerid a] -> ShowS
Show via (Quiet (WithBearer peerid a))
--TODO: probably remove this type


-- | Mid-level channel events traced independently by each mini protocol job.
--
data ChannelTrace =
      TraceChannelRecvStart MiniProtocolNum
    | TraceChannelRecvEnd MiniProtocolNum Int
    | TraceChannelSendStart MiniProtocolNum Int
    | TraceChannelSendEnd MiniProtocolNum

instance Show ChannelTrace where
    show :: ChannelTrace -> String
show (TraceChannelRecvStart MiniProtocolNum
mid) =
      Format String (MiniProtocolNum -> String)
-> MiniProtocolNum -> String
forall a. Format String a -> a
formatToString (Format (MiniProtocolNum -> String) (MiniProtocolNum -> String)
"Channel Receive Start on" Format (MiniProtocolNum -> String) (MiniProtocolNum -> String)
-> Format String (MiniProtocolNum -> String)
-> Format String (MiniProtocolNum -> String)
forall r a r'. Format r a -> Format r' r -> Format r' a
%+ Format String (MiniProtocolNum -> String)
forall a r. Show a => Format r (a -> r)
F.shown) MiniProtocolNum
mid
    show (TraceChannelRecvEnd MiniProtocolNum
mid Int
len)   =
      Format String (MiniProtocolNum -> Int -> String)
-> MiniProtocolNum -> Int -> String
forall a. Format String a -> a
formatToString (Format
  (MiniProtocolNum -> Int -> String)
  (MiniProtocolNum -> Int -> String)
"Channel Receive End on" Format
  (MiniProtocolNum -> Int -> String)
  (MiniProtocolNum -> Int -> String)
-> Format String (MiniProtocolNum -> Int -> String)
-> Format String (MiniProtocolNum -> Int -> String)
forall r a r'. Format r a -> Format r' r -> Format r' a
%+ Format (Int -> String) (MiniProtocolNum -> Int -> String)
-> Format (Int -> String) (MiniProtocolNum -> Int -> String)
forall r a. Format r a -> Format r a
F.parenthesised Format (Int -> String) (MiniProtocolNum -> Int -> String)
forall a r. Show a => Format r (a -> r)
F.shown Format (Int -> String) (MiniProtocolNum -> Int -> String)
-> Format String (Int -> String)
-> Format String (MiniProtocolNum -> Int -> String)
forall r a r'. Format r a -> Format r' r -> Format r' a
%+ Format String (Int -> String)
forall a r. Integral a => Format r (a -> r)
F.int) MiniProtocolNum
mid Int
len
    show (TraceChannelSendStart MiniProtocolNum
mid Int
len) =
      Format String (MiniProtocolNum -> Int -> String)
-> MiniProtocolNum -> Int -> String
forall a. Format String a -> a
formatToString (Format
  (MiniProtocolNum -> Int -> String)
  (MiniProtocolNum -> Int -> String)
"Channel Send Start on" Format
  (MiniProtocolNum -> Int -> String)
  (MiniProtocolNum -> Int -> String)
-> Format String (MiniProtocolNum -> Int -> String)
-> Format String (MiniProtocolNum -> Int -> String)
forall r a r'. Format r a -> Format r' r -> Format r' a
%+ Format (Int -> String) (MiniProtocolNum -> Int -> String)
-> Format (Int -> String) (MiniProtocolNum -> Int -> String)
forall r a. Format r a -> Format r a
F.parenthesised Format (Int -> String) (MiniProtocolNum -> Int -> String)
forall a r. Show a => Format r (a -> r)
F.shown Format (Int -> String) (MiniProtocolNum -> Int -> String)
-> Format String (Int -> String)
-> Format String (MiniProtocolNum -> Int -> String)
forall r a r'. Format r a -> Format r' r -> Format r' a
%+ Format String (Int -> String)
forall a r. Integral a => Format r (a -> r)
F.int) MiniProtocolNum
mid Int
len
    show (TraceChannelSendEnd MiniProtocolNum
mid) =
      Format String (MiniProtocolNum -> String)
-> MiniProtocolNum -> String
forall a. Format String a -> a
formatToString (Format (MiniProtocolNum -> String) (MiniProtocolNum -> String)
"Channel Send End on" Format (MiniProtocolNum -> String) (MiniProtocolNum -> String)
-> Format String (MiniProtocolNum -> String)
-> Format String (MiniProtocolNum -> String)
forall r a r'. Format r a -> Format r' r -> Format r' a
%+ Format String (MiniProtocolNum -> String)
forall a r. Show a => Format r (a -> r)
F.shown) MiniProtocolNum
mid


data State = Mature
             -- ^ `Mux started ingress, and egress threads
           | Dead
             -- ^ Mux is being shutdown.
           deriving (State -> State -> Bool
(State -> State -> Bool) -> (State -> State -> Bool) -> Eq State
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: State -> State -> Bool
== :: State -> State -> Bool
$c/= :: State -> State -> Bool
/= :: State -> State -> Bool
Eq, Int -> State -> ShowS
[State] -> ShowS
State -> String
(Int -> State -> ShowS)
-> (State -> String) -> ([State] -> ShowS) -> Show State
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> State -> ShowS
showsPrec :: Int -> State -> ShowS
$cshow :: State -> String
show :: State -> String
$cshowList :: [State] -> ShowS
showList :: [State] -> ShowS
Show)

-- | High-level mux events.
--
data Trace =
      TraceState State
    | TraceCleanExit MiniProtocolNum MiniProtocolDir
    | TraceExceptionExit MiniProtocolNum MiniProtocolDir SomeException
    | TraceStartEagerly MiniProtocolNum MiniProtocolDir
    | TraceStartOnDemand MiniProtocolNum MiniProtocolDir
    | TraceStartOnDemandAny MiniProtocolNum MiniProtocolDir
    | TraceStartedOnDemand MiniProtocolNum MiniProtocolDir
    | TraceTerminating MiniProtocolNum MiniProtocolDir
    | forall mode. TraceNewMux [MiniProtocolInfo mode]
    | TraceStarting
    | TraceStopping
    | TraceStopped

instance Show Trace where
    show :: Trace -> String
show (TraceState State
new) =
      Format String (State -> String) -> State -> String
forall a. Format String a -> a
formatToString (Format (State -> String) (State -> String)
"State:" Format (State -> String) (State -> String)
-> Format String (State -> String)
-> Format String (State -> String)
forall r a r'. Format r a -> Format r' r -> Format r' a
%+ Format String (State -> String)
forall a r. Show a => Format r (a -> r)
F.shown) State
new
    show (TraceCleanExit MiniProtocolNum
mid MiniProtocolDir
dir) =
      Format String (MiniProtocolNum -> MiniProtocolDir -> String)
-> MiniProtocolNum -> MiniProtocolDir -> String
forall a. Format String a -> a
formatToString
        (Format
  (MiniProtocolNum -> MiniProtocolDir -> String)
  (MiniProtocolNum -> MiniProtocolDir -> String)
"Miniprotocol" Format
  (MiniProtocolNum -> MiniProtocolDir -> String)
  (MiniProtocolNum -> MiniProtocolDir -> String)
-> Format String (MiniProtocolNum -> MiniProtocolDir -> String)
-> Format String (MiniProtocolNum -> MiniProtocolDir -> String)
forall r a r'. Format r a -> Format r' r -> Format r' a
%+ Format
  (MiniProtocolDir -> String)
  (MiniProtocolNum -> MiniProtocolDir -> String)
-> Format
     (MiniProtocolDir -> String)
     (MiniProtocolNum -> MiniProtocolDir -> String)
forall r a. Format r a -> Format r a
F.parenthesised Format
  (MiniProtocolDir -> String)
  (MiniProtocolNum -> MiniProtocolDir -> String)
forall a r. Show a => Format r (a -> r)
F.shown Format
  (MiniProtocolDir -> String)
  (MiniProtocolNum -> MiniProtocolDir -> String)
-> Format String (MiniProtocolDir -> String)
-> Format String (MiniProtocolNum -> MiniProtocolDir -> String)
forall r a r'. Format r a -> Format r' r -> Format r' a
%+ Format String (MiniProtocolDir -> String)
forall a r. Show a => Format r (a -> r)
F.shown Format String (MiniProtocolDir -> String)
-> Format String String
-> Format String (MiniProtocolDir -> String)
forall r a r'. Format r a -> Format r' r -> Format r' a
%+ Format String String
"terminated cleanly")
        MiniProtocolNum
mid MiniProtocolDir
dir
    show (TraceExceptionExit MiniProtocolNum
mid MiniProtocolDir
dir SomeException
e) =
      Format
  String
  (MiniProtocolNum -> MiniProtocolDir -> SomeException -> String)
-> MiniProtocolNum -> MiniProtocolDir -> SomeException -> String
forall a. Format String a -> a
formatToString
        (Format
  (MiniProtocolNum -> MiniProtocolDir -> SomeException -> String)
  (MiniProtocolNum -> MiniProtocolDir -> SomeException -> String)
"Miniprotocol" Format
  (MiniProtocolNum -> MiniProtocolDir -> SomeException -> String)
  (MiniProtocolNum -> MiniProtocolDir -> SomeException -> String)
-> Format
     String
     (MiniProtocolNum -> MiniProtocolDir -> SomeException -> String)
-> Format
     String
     (MiniProtocolNum -> MiniProtocolDir -> SomeException -> String)
forall r a r'. Format r a -> Format r' r -> Format r' a
%+ Format
  (MiniProtocolDir -> SomeException -> String)
  (MiniProtocolNum -> MiniProtocolDir -> SomeException -> String)
forall a r. Show a => Format r (a -> r)
F.shown Format
  (MiniProtocolDir -> SomeException -> String)
  (MiniProtocolNum -> MiniProtocolDir -> SomeException -> String)
-> Format String (MiniProtocolDir -> SomeException -> String)
-> Format
     String
     (MiniProtocolNum -> MiniProtocolDir -> SomeException -> String)
forall r a r'. Format r a -> Format r' r -> Format r' a
%+ Format
  (SomeException -> String)
  (MiniProtocolDir -> SomeException -> String)
forall a r. Show a => Format r (a -> r)
F.shown Format
  (SomeException -> String)
  (MiniProtocolDir -> SomeException -> String)
-> Format String (SomeException -> String)
-> Format String (MiniProtocolDir -> SomeException -> String)
forall r a r'. Format r a -> Format r' r -> Format r' a
%+ Format (SomeException -> String) (SomeException -> String)
"terminated with exception" Format (SomeException -> String) (SomeException -> String)
-> Format String (SomeException -> String)
-> Format String (SomeException -> String)
forall r a r'. Format r a -> Format r' r -> Format r' a
%+ Format String (SomeException -> String)
forall a r. Show a => Format r (a -> r)
F.shown)
        MiniProtocolNum
mid MiniProtocolDir
dir SomeException
e
    show (TraceStartEagerly MiniProtocolNum
mid MiniProtocolDir
dir) =
      Format String (MiniProtocolNum -> MiniProtocolDir -> String)
-> MiniProtocolNum -> MiniProtocolDir -> String
forall a. Format String a -> a
formatToString
        (Format
  (MiniProtocolNum -> MiniProtocolDir -> String)
  (MiniProtocolNum -> MiniProtocolDir -> String)
"Eagerly started" Format
  (MiniProtocolNum -> MiniProtocolDir -> String)
  (MiniProtocolNum -> MiniProtocolDir -> String)
-> Format String (MiniProtocolNum -> MiniProtocolDir -> String)
-> Format String (MiniProtocolNum -> MiniProtocolDir -> String)
forall r a r'. Format r a -> Format r' r -> Format r' a
%+ Format
  (MiniProtocolDir -> String)
  (MiniProtocolNum -> MiniProtocolDir -> String)
-> Format
     (MiniProtocolDir -> String)
     (MiniProtocolNum -> MiniProtocolDir -> String)
forall r a. Format r a -> Format r a
F.parenthesised Format
  (MiniProtocolDir -> String)
  (MiniProtocolNum -> MiniProtocolDir -> String)
forall a r. Show a => Format r (a -> r)
F.shown Format
  (MiniProtocolDir -> String)
  (MiniProtocolNum -> MiniProtocolDir -> String)
-> Format String (MiniProtocolDir -> String)
-> Format String (MiniProtocolNum -> MiniProtocolDir -> String)
forall r a r'. Format r a -> Format r' r -> Format r' a
%+ Format (MiniProtocolDir -> String) (MiniProtocolDir -> String)
"in" Format (MiniProtocolDir -> String) (MiniProtocolDir -> String)
-> Format String (MiniProtocolDir -> String)
-> Format String (MiniProtocolDir -> String)
forall r a r'. Format r a -> Format r' r -> Format r' a
%+ Format String (MiniProtocolDir -> String)
forall a r. Show a => Format r (a -> r)
F.shown)
        MiniProtocolNum
mid MiniProtocolDir
dir
    show (TraceStartOnDemand MiniProtocolNum
mid MiniProtocolDir
dir) =
      Format String (MiniProtocolNum -> MiniProtocolDir -> String)
-> MiniProtocolNum -> MiniProtocolDir -> String
forall a. Format String a -> a
formatToString
        (Format
  (MiniProtocolNum -> MiniProtocolDir -> String)
  (MiniProtocolNum -> MiniProtocolDir -> String)
"Preparing to start" Format
  (MiniProtocolNum -> MiniProtocolDir -> String)
  (MiniProtocolNum -> MiniProtocolDir -> String)
-> Format String (MiniProtocolNum -> MiniProtocolDir -> String)
-> Format String (MiniProtocolNum -> MiniProtocolDir -> String)
forall r a r'. Format r a -> Format r' r -> Format r' a
%+ Format
  (MiniProtocolDir -> String)
  (MiniProtocolNum -> MiniProtocolDir -> String)
-> Format
     (MiniProtocolDir -> String)
     (MiniProtocolNum -> MiniProtocolDir -> String)
forall r a. Format r a -> Format r a
F.parenthesised Format
  (MiniProtocolDir -> String)
  (MiniProtocolNum -> MiniProtocolDir -> String)
forall a r. Show a => Format r (a -> r)
F.shown Format
  (MiniProtocolDir -> String)
  (MiniProtocolNum -> MiniProtocolDir -> String)
-> Format String (MiniProtocolDir -> String)
-> Format String (MiniProtocolNum -> MiniProtocolDir -> String)
forall r a r'. Format r a -> Format r' r -> Format r' a
%+ Format (MiniProtocolDir -> String) (MiniProtocolDir -> String)
"in" Format (MiniProtocolDir -> String) (MiniProtocolDir -> String)
-> Format String (MiniProtocolDir -> String)
-> Format String (MiniProtocolDir -> String)
forall r a r'. Format r a -> Format r' r -> Format r' a
%+ Format String (MiniProtocolDir -> String)
forall a r. Show a => Format r (a -> r)
F.shown)
        MiniProtocolNum
mid MiniProtocolDir
dir
    show (TraceStartOnDemandAny MiniProtocolNum
mid MiniProtocolDir
dir) =
      Format String (MiniProtocolNum -> MiniProtocolDir -> String)
-> MiniProtocolNum -> MiniProtocolDir -> String
forall a. Format String a -> a
formatToString
        (Format
  (MiniProtocolNum -> MiniProtocolDir -> String)
  (MiniProtocolNum -> MiniProtocolDir -> String)
"Preparing to start on any" Format
  (MiniProtocolNum -> MiniProtocolDir -> String)
  (MiniProtocolNum -> MiniProtocolDir -> String)
-> Format String (MiniProtocolNum -> MiniProtocolDir -> String)
-> Format String (MiniProtocolNum -> MiniProtocolDir -> String)
forall r a r'. Format r a -> Format r' r -> Format r' a
%+ Format
  (MiniProtocolDir -> String)
  (MiniProtocolNum -> MiniProtocolDir -> String)
-> Format
     (MiniProtocolDir -> String)
     (MiniProtocolNum -> MiniProtocolDir -> String)
forall r a. Format r a -> Format r a
F.parenthesised Format
  (MiniProtocolDir -> String)
  (MiniProtocolNum -> MiniProtocolDir -> String)
forall a r. Show a => Format r (a -> r)
F.shown Format
  (MiniProtocolDir -> String)
  (MiniProtocolNum -> MiniProtocolDir -> String)
-> Format String (MiniProtocolDir -> String)
-> Format String (MiniProtocolNum -> MiniProtocolDir -> String)
forall r a r'. Format r a -> Format r' r -> Format r' a
%+ Format (MiniProtocolDir -> String) (MiniProtocolDir -> String)
"in" Format (MiniProtocolDir -> String) (MiniProtocolDir -> String)
-> Format String (MiniProtocolDir -> String)
-> Format String (MiniProtocolDir -> String)
forall r a r'. Format r a -> Format r' r -> Format r' a
%+ Format String (MiniProtocolDir -> String)
forall a r. Show a => Format r (a -> r)
F.shown)
        MiniProtocolNum
mid MiniProtocolDir
dir
    show (TraceStartedOnDemand MiniProtocolNum
mid MiniProtocolDir
dir) =
      Format String (MiniProtocolNum -> MiniProtocolDir -> String)
-> MiniProtocolNum -> MiniProtocolDir -> String
forall a. Format String a -> a
formatToString
        (Format
  (MiniProtocolNum -> MiniProtocolDir -> String)
  (MiniProtocolNum -> MiniProtocolDir -> String)
"Started on demand" Format
  (MiniProtocolNum -> MiniProtocolDir -> String)
  (MiniProtocolNum -> MiniProtocolDir -> String)
-> Format String (MiniProtocolNum -> MiniProtocolDir -> String)
-> Format String (MiniProtocolNum -> MiniProtocolDir -> String)
forall r a r'. Format r a -> Format r' r -> Format r' a
%+ Format
  (MiniProtocolDir -> String)
  (MiniProtocolNum -> MiniProtocolDir -> String)
-> Format
     (MiniProtocolDir -> String)
     (MiniProtocolNum -> MiniProtocolDir -> String)
forall r a. Format r a -> Format r a
F.parenthesised Format
  (MiniProtocolDir -> String)
  (MiniProtocolNum -> MiniProtocolDir -> String)
forall a r. Show a => Format r (a -> r)
F.shown Format
  (MiniProtocolDir -> String)
  (MiniProtocolNum -> MiniProtocolDir -> String)
-> Format String (MiniProtocolDir -> String)
-> Format String (MiniProtocolNum -> MiniProtocolDir -> String)
forall r a r'. Format r a -> Format r' r -> Format r' a
%+ Format (MiniProtocolDir -> String) (MiniProtocolDir -> String)
"in" Format (MiniProtocolDir -> String) (MiniProtocolDir -> String)
-> Format String (MiniProtocolDir -> String)
-> Format String (MiniProtocolDir -> String)
forall r a r'. Format r a -> Format r' r -> Format r' a
%+ Format String (MiniProtocolDir -> String)
forall a r. Show a => Format r (a -> r)
F.shown)
        MiniProtocolNum
mid MiniProtocolDir
dir
    show (TraceTerminating MiniProtocolNum
mid MiniProtocolDir
dir) =
      Format String (MiniProtocolNum -> MiniProtocolDir -> String)
-> MiniProtocolNum -> MiniProtocolDir -> String
forall a. Format String a -> a
formatToString
        (Format
  (MiniProtocolNum -> MiniProtocolDir -> String)
  (MiniProtocolNum -> MiniProtocolDir -> String)
"Terminating" Format
  (MiniProtocolNum -> MiniProtocolDir -> String)
  (MiniProtocolNum -> MiniProtocolDir -> String)
-> Format String (MiniProtocolNum -> MiniProtocolDir -> String)
-> Format String (MiniProtocolNum -> MiniProtocolDir -> String)
forall r a r'. Format r a -> Format r' r -> Format r' a
%+ Format
  (MiniProtocolDir -> String)
  (MiniProtocolNum -> MiniProtocolDir -> String)
-> Format
     (MiniProtocolDir -> String)
     (MiniProtocolNum -> MiniProtocolDir -> String)
forall r a. Format r a -> Format r a
F.parenthesised Format
  (MiniProtocolDir -> String)
  (MiniProtocolNum -> MiniProtocolDir -> String)
forall a r. Show a => Format r (a -> r)
F.shown Format
  (MiniProtocolDir -> String)
  (MiniProtocolNum -> MiniProtocolDir -> String)
-> Format String (MiniProtocolDir -> String)
-> Format String (MiniProtocolNum -> MiniProtocolDir -> String)
forall r a r'. Format r a -> Format r' r -> Format r' a
%+ Format (MiniProtocolDir -> String) (MiniProtocolDir -> String)
"in" Format (MiniProtocolDir -> String) (MiniProtocolDir -> String)
-> Format String (MiniProtocolDir -> String)
-> Format String (MiniProtocolDir -> String)
forall r a r'. Format r a -> Format r' r -> Format r' a
%+ Format String (MiniProtocolDir -> String)
forall a r. Show a => Format r (a -> r)
F.shown)
        MiniProtocolNum
mid MiniProtocolDir
dir
    show (TraceNewMux [MiniProtocolInfo mode]
infos) =
      Format String ([MiniProtocolInfo mode] -> String)
-> [MiniProtocolInfo mode] -> String
forall a. Format String a -> a
formatToString
        (Format
  ([MiniProtocolInfo mode] -> String)
  ([MiniProtocolInfo mode] -> String)
"New mux with protocols:" Format
  ([MiniProtocolInfo mode] -> String)
  ([MiniProtocolInfo mode] -> String)
-> Format String ([MiniProtocolInfo mode] -> String)
-> Format String ([MiniProtocolInfo mode] -> String)
forall r a r'. Format r a -> Format r' r -> Format r' a
%+ Format Builder (MiniProtocolInfo mode -> Builder)
-> Format String ([MiniProtocolInfo mode] -> String)
forall (t :: * -> *) a r.
Foldable t =>
Format Builder (a -> Builder) -> Format r (t a -> r)
F.commaSpaceSep Format Builder (MiniProtocolInfo mode -> Builder)
forall a r. Show a => Format r (a -> r)
F.shown)
        [MiniProtocolInfo mode]
infos
    show Trace
TraceStarting = String
"Mux starting"
    show Trace
TraceStopping = String
"Mux stopping"
    show Trace
TraceStopped  = String
"Mux stoppped"


-- | Bundle of tracers used directly by mux.
--
data Tracers' m f = Tracers {
    forall (m :: * -> *) (f :: * -> *).
Tracers' m f -> Tracer m (f Trace)
tracer        :: Tracer m (f Trace),
    -- ^ high-level tracer of mux state events

    forall (m :: * -> *) (f :: * -> *).
Tracers' m f -> Tracer m (f ChannelTrace)
channelTracer :: Tracer m (f ChannelTrace),
    -- ^ channel tracer

    forall (m :: * -> *) (f :: * -> *).
Tracers' m f -> Tracer m (f BearerTrace)
bearerTracer  :: Tracer m (f BearerTrace)
    -- ^ high-frequency tracer
  }

type Tracers m = Tracers' m Identity


-- | Trace all events through one polymorphic tracer.
--
tracersWith :: (forall x. Tracer m x) -> Tracers' m f
tracersWith :: forall (m :: * -> *) (f :: * -> *).
(forall x. Tracer m x) -> Tracers' m f
tracersWith forall x. Tracer m x
tr = Tracers {
    tracer :: Tracer m (f Trace)
tracer        = Tracer m (f Trace)
forall x. Tracer m x
tr,
    channelTracer :: Tracer m (f ChannelTrace)
channelTracer = Tracer m (f ChannelTrace)
forall x. Tracer m x
tr,
    bearerTracer :: Tracer m (f BearerTrace)
bearerTracer  = Tracer m (f BearerTrace)
forall x. Tracer m x
tr
  }


nullTracers :: Monad m => Tracers' m f
nullTracers :: forall (m :: * -> *) (f :: * -> *). Monad m => Tracers' m f
nullTracers = (forall x. Tracer m x) -> Tracers' m f
forall (m :: * -> *) (f :: * -> *).
(forall x. Tracer m x) -> Tracers' m f
tracersWith Tracer m x
forall x. Tracer m x
forall (m :: * -> *) a. Monad m => Tracer m a
nullTracer


-- | A convenient bidirectional pattern synonym which (un)wraps the `Identity`
-- functor in the `Tracer` type.
--
pattern TracersI :: forall m.
                    Monad m =>
                    Tracer m Trace
                 -> Tracer m ChannelTrace
                 -> Tracer m BearerTrace
                 -> Tracers m
pattern $bTracersI :: forall (m :: * -> *).
Monad m =>
Tracer m Trace
-> Tracer m ChannelTrace -> Tracer m BearerTrace -> Tracers m
$mTracersI :: forall {r} {m :: * -> *}.
Monad m =>
Tracers m
-> (Tracer m Trace
    -> Tracer m ChannelTrace -> Tracer m BearerTrace -> r)
-> ((# #) -> r)
-> r
TracersI { forall (m :: * -> *). Monad m => Tracers m -> Tracer m Trace
tracer_, forall (m :: * -> *). Monad m => Tracers m -> Tracer m ChannelTrace
channelTracer_, forall (m :: * -> *). Monad m => Tracers m -> Tracer m BearerTrace
bearerTracer_ } <-
    Tracers { tracer        = contramap Identity -> tracer_,
              channelTracer = contramap Identity -> channelTracer_,
              bearerTracer  = contramap Identity -> bearerTracer_
            }
  where
    TracersI Tracer m Trace
tracer' Tracer m ChannelTrace
channelTracer' Tracer m BearerTrace
bearerTracer' =
      Tracers {
         tracer :: Tracer m (Identity Trace)
tracer        = Identity Trace -> Trace
forall a. Identity a -> a
runIdentity (Identity Trace -> Trace)
-> Tracer m Trace -> Tracer m (Identity Trace)
forall (f :: * -> *) a b. Contravariant f => (a -> b) -> f b -> f a
>$< Tracer m Trace
tracer',
         channelTracer :: Tracer m (Identity ChannelTrace)
channelTracer = Identity ChannelTrace -> ChannelTrace
forall a. Identity a -> a
runIdentity (Identity ChannelTrace -> ChannelTrace)
-> Tracer m ChannelTrace -> Tracer m (Identity ChannelTrace)
forall (f :: * -> *) a b. Contravariant f => (a -> b) -> f b -> f a
>$< Tracer m ChannelTrace
channelTracer',
         bearerTracer :: Tracer m (Identity BearerTrace)
bearerTracer  = Identity BearerTrace -> BearerTrace
forall a. Identity a -> a
runIdentity (Identity BearerTrace -> BearerTrace)
-> Tracer m BearerTrace -> Tracer m (Identity BearerTrace)
forall (f :: * -> *) a b. Contravariant f => (a -> b) -> f b -> f a
>$< Tracer m BearerTrace
bearerTracer'
       }

{-# COMPLETE TracersI #-}

-- | Contravariant natural transformation of `Tracers' m`.
--
contramapTracers' :: Monad m
                  => (forall x. f' x -> f x)
                  -> Tracers' m f -> Tracers' m f'
contramapTracers' :: forall (m :: * -> *) (f' :: * -> *) (f :: * -> *).
Monad m =>
(forall x. f' x -> f x) -> Tracers' m f -> Tracers' m f'
contramapTracers'
  forall x. f' x -> f x
f
  Tracers { Tracer m (f Trace)
tracer :: forall (m :: * -> *) (f :: * -> *).
Tracers' m f -> Tracer m (f Trace)
tracer :: Tracer m (f Trace)
tracer,
            Tracer m (f ChannelTrace)
channelTracer :: forall (m :: * -> *) (f :: * -> *).
Tracers' m f -> Tracer m (f ChannelTrace)
channelTracer :: Tracer m (f ChannelTrace)
channelTracer,
            Tracer m (f BearerTrace)
bearerTracer :: forall (m :: * -> *) (f :: * -> *).
Tracers' m f -> Tracer m (f BearerTrace)
bearerTracer :: Tracer m (f BearerTrace)
bearerTracer
          }
  =
  Tracers { tracer :: Tracer m (f' Trace)
tracer        = f' Trace -> f Trace
forall x. f' x -> f x
f (f' Trace -> f Trace) -> Tracer m (f Trace) -> Tracer m (f' Trace)
forall (f :: * -> *) a b. Contravariant f => (a -> b) -> f b -> f a
>$< Tracer m (f Trace)
tracer,
            channelTracer :: Tracer m (f' ChannelTrace)
channelTracer = f' ChannelTrace -> f ChannelTrace
forall x. f' x -> f x
f (f' ChannelTrace -> f ChannelTrace)
-> Tracer m (f ChannelTrace) -> Tracer m (f' ChannelTrace)
forall (f :: * -> *) a b. Contravariant f => (a -> b) -> f b -> f a
>$< Tracer m (f ChannelTrace)
channelTracer,
            bearerTracer :: Tracer m (f' BearerTrace)
bearerTracer  = f' BearerTrace -> f BearerTrace
forall x. f' x -> f x
f (f' BearerTrace -> f BearerTrace)
-> Tracer m (f BearerTrace) -> Tracer m (f' BearerTrace)
forall (f :: * -> *) a b. Contravariant f => (a -> b) -> f b -> f a
>$< Tracer m (f BearerTrace)
bearerTracer
          }


type TracersWithBearer connId m = Tracers' m (WithBearer connId)

tracersWithBearer :: Monad m => peerId -> TracersWithBearer peerId m -> Tracers m
tracersWithBearer :: forall (m :: * -> *) peerId.
Monad m =>
peerId -> TracersWithBearer peerId m -> Tracers m
tracersWithBearer peerId
peerId = (forall x. Identity x -> WithBearer peerId x)
-> Tracers' m (WithBearer peerId) -> Tracers' m Identity
forall (m :: * -> *) (f' :: * -> *) (f :: * -> *).
Monad m =>
(forall x. f' x -> f x) -> Tracers' m f -> Tracers' m f'
contramapTracers' (peerId -> x -> WithBearer peerId x
forall peerid a. peerid -> a -> WithBearer peerid a
WithBearer peerId
peerId (x -> WithBearer peerId x)
-> (Identity x -> x) -> Identity x -> WithBearer peerId x
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Identity x -> x
forall a. Identity a -> a
runIdentity)