{-# LANGUAGE CPP                       #-}
{-# LANGUAGE DeriveFunctor             #-}
{-# LANGUAGE DeriveGeneric             #-}
{-# LANGUAGE DerivingStrategies        #-}
{-# LANGUAGE DerivingVia               #-}
{-# LANGUAGE ExistentialQuantification #-}
{-# LANGUAGE NamedFieldPuns            #-}
{-# LANGUAGE StandaloneDeriving        #-}

module Network.Mux.Trace
  ( MuxError (..)
  , MuxErrorType (..)
  , handleIOException
  , MuxTrace (..)
  , MuxBearerState (..)
  , WithMuxBearer (..)
  , TraceLabelPeer (..)
  ) where

import           Prelude hiding (read)

import           Text.Printf

import           Control.Exception hiding (throwIO)
import           Control.Monad.Class.MonadThrow
import           Control.Monad.Class.MonadTime.SI
import           Data.Bifunctor (Bifunctor (..))
import           Data.Word
import           GHC.Generics (Generic (..))
import           Quiet (Quiet (..))

import           Network.Mux.TCPInfo
import           Network.Mux.Types


--
-- Errors
--

-- | Error type used in across the mux layer.
--
data MuxError = MuxError {
      MuxError -> MuxErrorType
errorType :: !MuxErrorType
    , MuxError -> String
errorMsg  :: !String
    }
  deriving forall x. Rep MuxError x -> MuxError
forall x. MuxError -> Rep MuxError x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cto :: forall x. Rep MuxError x -> MuxError
$cfrom :: forall x. MuxError -> Rep MuxError x
Generic
  deriving Int -> MuxError -> ShowS
[MuxError] -> ShowS
MuxError -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [MuxError] -> ShowS
$cshowList :: [MuxError] -> ShowS
show :: MuxError -> String
$cshow :: MuxError -> String
showsPrec :: Int -> MuxError -> ShowS
$cshowsPrec :: Int -> MuxError -> ShowS
Show via Quiet MuxError


-- | Enumeration of error conditions.
--
data MuxErrorType = MuxUnknownMiniProtocol
                  -- ^ returned by 'decodeMuxSDUHeader', thrown by 'MuxBearer'.
                  | MuxDecodeError
                  -- ^ return by 'decodeMuxSDUHeader', thrown by 'MuxBearer'.
                  | MuxBearerClosed
                  -- ^ thrown by 'MuxBearer' when received a null byte.
                  | MuxIngressQueueOverRun
                  -- ^ thrown by 'demux' when violating 'maximumIngressQueue'
                  -- byte limit.
                  | MuxInitiatorOnly
                  -- ^ thrown when data arrives on a responder channel when the
                  -- mux was set up as an 'InitiatorApp'.
                  | MuxIOException IOException
                  -- ^ 'IOException' thrown by
                  | MuxSDUReadTimeout
                  -- ^ thrown when reading of a single SDU takes too long
                  | MuxSDUWriteTimeout
                  -- ^ thrown when writing a single SDU takes too long
                  | MuxShutdown !(Maybe MuxErrorType)
                  -- ^ 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.
                  | MuxCleanShutdown
                  -- ^ Mux stopped by 'stopMux'
                  deriving (Int -> MuxErrorType -> ShowS
[MuxErrorType] -> ShowS
MuxErrorType -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [MuxErrorType] -> ShowS
$cshowList :: [MuxErrorType] -> ShowS
show :: MuxErrorType -> String
$cshow :: MuxErrorType -> String
showsPrec :: Int -> MuxErrorType -> ShowS
$cshowsPrec :: Int -> MuxErrorType -> ShowS
Show, MuxErrorType -> MuxErrorType -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: MuxErrorType -> MuxErrorType -> Bool
$c/= :: MuxErrorType -> MuxErrorType -> Bool
== :: MuxErrorType -> MuxErrorType -> Bool
$c== :: MuxErrorType -> MuxErrorType -> Bool
Eq)

instance Exception MuxError where
    displayException :: MuxError -> String
displayException MuxError{MuxErrorType
errorType :: MuxErrorType
errorType :: MuxError -> MuxErrorType
errorType, String
errorMsg :: String
errorMsg :: MuxError -> String
errorMsg}
      = forall a. Show a => a -> String
show MuxErrorType
errorType forall a. [a] -> [a] -> [a]
++ String
" " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show String
errorMsg

-- | Handler for 'IOException's which wraps them in 'MuxError'.
--
-- It is used various 'MuxBearer' implementations:
-- * 'socketAsMuxBearer'
-- * 'pipeAsMuxBearer'
--
handleIOException :: MonadThrow m => String -> IOException -> m a
handleIOException :: forall (m :: * -> *) a.
MonadThrow m =>
String -> IOException -> m a
handleIOException String
errorMsg IOException
e = forall (m :: * -> *) e a. (MonadThrow m, Exception e) => e -> m a
throwIO MuxError {
    errorType :: MuxErrorType
errorType  = IOException -> MuxErrorType
MuxIOException IOException
e,
    errorMsg :: String
errorMsg   = Char
'(' forall a. a -> [a] -> [a]
: String
errorMsg forall a. [a] -> [a] -> [a]
++ String
")"
  }


--
-- 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
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
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
$c== :: forall peerid a.
(Eq peerid, Eq a) =>
TraceLabelPeer peerid a -> TraceLabelPeer peerid a -> Bool
Eq, 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
<$ :: forall a b. a -> TraceLabelPeer peerid b -> TraceLabelPeer peerid a
$c<$ :: forall peerid a b.
a -> TraceLabelPeer peerid b -> TraceLabelPeer peerid a
fmap :: forall a b.
(a -> b) -> TraceLabelPeer peerid a -> TraceLabelPeer peerid b
$cfmap :: forall peerid a b.
(a -> b) -> TraceLabelPeer peerid a -> TraceLabelPeer peerid b
Functor, Int -> TraceLabelPeer peerid a -> ShowS
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
showList :: [TraceLabelPeer peerid a] -> ShowS
$cshowList :: forall peerid a.
(Show peerid, Show a) =>
[TraceLabelPeer peerid a] -> ShowS
show :: TraceLabelPeer peerid a -> String
$cshow :: forall peerid a.
(Show peerid, Show a) =>
TraceLabelPeer peerid a -> String
showsPrec :: Int -> TraceLabelPeer peerid a -> ShowS
$cshowsPrec :: forall peerid a.
(Show peerid, Show a) =>
Int -> 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) = 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 WithMuxBearer peerid a = WithMuxBearer {
      forall peerid a. WithMuxBearer peerid a -> peerid
wmbPeerId :: !peerid
      -- ^ A tag that should identify a specific mux bearer.
    , forall peerid a. WithMuxBearer peerid a -> a
wmbEvent  :: !a
  }
  deriving (forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
forall peerid a x.
Rep (WithMuxBearer peerid a) x -> WithMuxBearer peerid a
forall peerid a x.
WithMuxBearer peerid a -> Rep (WithMuxBearer peerid a) x
$cto :: forall peerid a x.
Rep (WithMuxBearer peerid a) x -> WithMuxBearer peerid a
$cfrom :: forall peerid a x.
WithMuxBearer peerid a -> Rep (WithMuxBearer peerid a) x
Generic)
  deriving Int -> WithMuxBearer peerid a -> ShowS
[WithMuxBearer peerid a] -> ShowS
WithMuxBearer peerid a -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
forall peerid a.
(Show peerid, Show a) =>
Int -> WithMuxBearer peerid a -> ShowS
forall peerid a.
(Show peerid, Show a) =>
[WithMuxBearer peerid a] -> ShowS
forall peerid a.
(Show peerid, Show a) =>
WithMuxBearer peerid a -> String
showList :: [WithMuxBearer peerid a] -> ShowS
$cshowList :: forall peerid a.
(Show peerid, Show a) =>
[WithMuxBearer peerid a] -> ShowS
show :: WithMuxBearer peerid a -> String
$cshow :: forall peerid a.
(Show peerid, Show a) =>
WithMuxBearer peerid a -> String
showsPrec :: Int -> WithMuxBearer peerid a -> ShowS
$cshowsPrec :: forall peerid a.
(Show peerid, Show a) =>
Int -> WithMuxBearer peerid a -> ShowS
Show via (Quiet (WithMuxBearer peerid a))
--TODO: probably remove this type


data MuxBearerState = Mature
                    -- ^ MuxBearer has successfully completed the handshake.
                    | Dead
                    -- ^ MuxBearer is dead and the underlying bearer has been
                    -- closed.
                    deriving (MuxBearerState -> MuxBearerState -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: MuxBearerState -> MuxBearerState -> Bool
$c/= :: MuxBearerState -> MuxBearerState -> Bool
== :: MuxBearerState -> MuxBearerState -> Bool
$c== :: MuxBearerState -> MuxBearerState -> Bool
Eq, Int -> MuxBearerState -> ShowS
[MuxBearerState] -> ShowS
MuxBearerState -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [MuxBearerState] -> ShowS
$cshowList :: [MuxBearerState] -> ShowS
show :: MuxBearerState -> String
$cshow :: MuxBearerState -> String
showsPrec :: Int -> MuxBearerState -> ShowS
$cshowsPrec :: Int -> MuxBearerState -> ShowS
Show)

-- | Enumeration of Mux events that can be traced.
--
data MuxTrace =
      MuxTraceRecvHeaderStart
    | MuxTraceRecvHeaderEnd MuxSDUHeader
    | MuxTraceRecvDeltaQObservation MuxSDUHeader Time
    | MuxTraceRecvDeltaQSample Double Int Int Double Double Double Double String
    | MuxTraceRecvStart Int
    | MuxTraceRecvEnd Int
    | MuxTraceSendStart MuxSDUHeader
    | MuxTraceSendEnd
    | MuxTraceState MuxBearerState
    | MuxTraceCleanExit MiniProtocolNum MiniProtocolDir
    | MuxTraceExceptionExit MiniProtocolNum MiniProtocolDir SomeException
    | MuxTraceChannelRecvStart MiniProtocolNum
    | MuxTraceChannelRecvEnd MiniProtocolNum Int
    | MuxTraceChannelSendStart MiniProtocolNum Int
    | MuxTraceChannelSendEnd MiniProtocolNum
    | MuxTraceHandshakeStart
    | MuxTraceHandshakeClientEnd DiffTime
    | MuxTraceHandshakeServerEnd
    | forall e. Exception e => MuxTraceHandshakeClientError e DiffTime
    | forall e. Exception e => MuxTraceHandshakeServerError e
    | MuxTraceSDUReadTimeoutException
    | MuxTraceSDUWriteTimeoutException
    | MuxTraceStartEagerly MiniProtocolNum MiniProtocolDir
    | MuxTraceStartOnDemand MiniProtocolNum MiniProtocolDir
    | MuxTraceStartedOnDemand MiniProtocolNum MiniProtocolDir
    | MuxTraceTerminating MiniProtocolNum MiniProtocolDir
    | MuxTraceStopping
    | MuxTraceStopped
    | MuxTraceTCPInfo StructTCPInfo Word16

instance Show MuxTrace where
    show :: MuxTrace -> String
show MuxTrace
MuxTraceRecvHeaderStart = forall r. PrintfType r => String -> r
printf String
"Bearer Receive Header Start"
    show (MuxTraceRecvHeaderEnd MuxSDUHeader { RemoteClockModel
mhTimestamp :: MuxSDUHeader -> RemoteClockModel
mhTimestamp :: RemoteClockModel
mhTimestamp, MiniProtocolNum
mhNum :: MuxSDUHeader -> MiniProtocolNum
mhNum :: MiniProtocolNum
mhNum, MiniProtocolDir
mhDir :: MuxSDUHeader -> MiniProtocolDir
mhDir :: MiniProtocolDir
mhDir, Word16
mhLength :: MuxSDUHeader -> Word16
mhLength :: Word16
mhLength }) = forall r. PrintfType r => String -> r
printf String
"Bearer Receive Header End: ts: 0x%08x (%s) %s len %d"
        (RemoteClockModel -> Word32
unRemoteClockModel RemoteClockModel
mhTimestamp) (forall a. Show a => a -> String
show MiniProtocolNum
mhNum) (forall a. Show a => a -> String
show MiniProtocolDir
mhDir) Word16
mhLength
    show (MuxTraceRecvDeltaQObservation MuxSDUHeader { RemoteClockModel
mhTimestamp :: RemoteClockModel
mhTimestamp :: MuxSDUHeader -> RemoteClockModel
mhTimestamp, Word16
mhLength :: Word16
mhLength :: MuxSDUHeader -> Word16
mhLength } Time
ts) = forall r. PrintfType r => String -> r
printf String
"Bearer DeltaQ observation: remote ts %d local ts %s length %d"
        (RemoteClockModel -> Word32
unRemoteClockModel RemoteClockModel
mhTimestamp) (forall a. Show a => a -> String
show Time
ts) Word16
mhLength
    show (MuxTraceRecvDeltaQSample Double
d Int
sp Int
so Double
dqs Double
dqvm Double
dqvs Double
estR String
sdud) = forall r. PrintfType r => String -> r
printf String
"Bearer DeltaQ Sample: duration %.3e packets %d sumBytes %d DeltaQ_S %.3e DeltaQ_VMean %.3e DeltaQ_VVar %.3e DeltaQ_estR %.3e sizeDist %s"
         Double
d Int
sp Int
so Double
dqs Double
dqvm Double
dqvs Double
estR String
sdud
    show (MuxTraceRecvStart Int
len) = forall r. PrintfType r => String -> r
printf String
"Bearer Receive Start: length %d" Int
len
    show (MuxTraceRecvEnd Int
len) = forall r. PrintfType r => String -> r
printf String
"Bearer Receive End: length %d" Int
len
    show (MuxTraceSendStart MuxSDUHeader { RemoteClockModel
mhTimestamp :: RemoteClockModel
mhTimestamp :: MuxSDUHeader -> RemoteClockModel
mhTimestamp, MiniProtocolNum
mhNum :: MiniProtocolNum
mhNum :: MuxSDUHeader -> MiniProtocolNum
mhNum, MiniProtocolDir
mhDir :: MiniProtocolDir
mhDir :: MuxSDUHeader -> MiniProtocolDir
mhDir, Word16
mhLength :: Word16
mhLength :: MuxSDUHeader -> Word16
mhLength }) = forall r. PrintfType r => String -> r
printf String
"Bearer Send Start: ts: 0x%08x (%s) %s length %d"
        (RemoteClockModel -> Word32
unRemoteClockModel RemoteClockModel
mhTimestamp) (forall a. Show a => a -> String
show MiniProtocolNum
mhNum) (forall a. Show a => a -> String
show MiniProtocolDir
mhDir) Word16
mhLength
    show MuxTrace
MuxTraceSendEnd = forall r. PrintfType r => String -> r
printf String
"Bearer Send End"
    show (MuxTraceState MuxBearerState
new) = forall r. PrintfType r => String -> r
printf String
"State: %s" (forall a. Show a => a -> String
show MuxBearerState
new)
    show (MuxTraceCleanExit MiniProtocolNum
mid MiniProtocolDir
dir) = forall r. PrintfType r => String -> r
printf String
"Miniprotocol (%s) %s terminated cleanly" (forall a. Show a => a -> String
show MiniProtocolNum
mid) (forall a. Show a => a -> String
show MiniProtocolDir
dir)
    show (MuxTraceExceptionExit MiniProtocolNum
mid MiniProtocolDir
dir SomeException
e) = forall r. PrintfType r => String -> r
printf String
"Miniprotocol %s %s terminated with exception %s" (forall a. Show a => a -> String
show MiniProtocolNum
mid) (forall a. Show a => a -> String
show MiniProtocolDir
dir) (forall a. Show a => a -> String
show SomeException
e)
    show (MuxTraceChannelRecvStart MiniProtocolNum
mid) = forall r. PrintfType r => String -> r
printf String
"Channel Receive Start on %s" (forall a. Show a => a -> String
show MiniProtocolNum
mid)
    show (MuxTraceChannelRecvEnd MiniProtocolNum
mid Int
len) = forall r. PrintfType r => String -> r
printf String
"Channel Receive End on (%s) %d" (forall a. Show a => a -> String
show MiniProtocolNum
mid)
        Int
len
    show (MuxTraceChannelSendStart MiniProtocolNum
mid Int
len) = forall r. PrintfType r => String -> r
printf String
"Channel Send Start on (%s) %d" (forall a. Show a => a -> String
show MiniProtocolNum
mid)
        Int
len
    show (MuxTraceChannelSendEnd MiniProtocolNum
mid) = forall r. PrintfType r => String -> r
printf String
"Channel Send End on %s" (forall a. Show a => a -> String
show MiniProtocolNum
mid)
    show MuxTrace
MuxTraceHandshakeStart = String
"Handshake start"
    show (MuxTraceHandshakeClientEnd DiffTime
duration) = forall r. PrintfType r => String -> r
printf String
"Handshake Client end, duration %s" (forall a. Show a => a -> String
show DiffTime
duration)
    show MuxTrace
MuxTraceHandshakeServerEnd = String
"Handshake Server end"
    show (MuxTraceHandshakeClientError e
e DiffTime
duration) =
         -- Client Error can include an error string from the peer which could be very large.
        forall r. PrintfType r => String -> r
printf String
"Handshake Client Error %s duration %s" (forall a. Int -> [a] -> [a]
take Int
256 forall a b. (a -> b) -> a -> b
$ forall a. Show a => a -> String
show e
e) (forall a. Show a => a -> String
show DiffTime
duration)
    show (MuxTraceHandshakeServerError e
e) = forall r. PrintfType r => String -> r
printf String
"Handshake Server Error %s" (forall a. Show a => a -> String
show e
e)
    show MuxTrace
MuxTraceSDUReadTimeoutException = String
"Timed out reading SDU"
    show MuxTrace
MuxTraceSDUWriteTimeoutException = String
"Timed out writing SDU"
    show (MuxTraceStartEagerly MiniProtocolNum
mid MiniProtocolDir
dir) = forall r. PrintfType r => String -> r
printf String
"Eagerly started (%s) in %s" (forall a. Show a => a -> String
show MiniProtocolNum
mid) (forall a. Show a => a -> String
show MiniProtocolDir
dir)
    show (MuxTraceStartOnDemand MiniProtocolNum
mid MiniProtocolDir
dir) = forall r. PrintfType r => String -> r
printf String
"Preparing to start (%s) in %s" (forall a. Show a => a -> String
show MiniProtocolNum
mid) (forall a. Show a => a -> String
show MiniProtocolDir
dir)
    show (MuxTraceStartedOnDemand MiniProtocolNum
mid MiniProtocolDir
dir) = forall r. PrintfType r => String -> r
printf String
"Started on demand (%s) in %s" (forall a. Show a => a -> String
show MiniProtocolNum
mid) (forall a. Show a => a -> String
show MiniProtocolDir
dir)
    show (MuxTraceTerminating MiniProtocolNum
mid MiniProtocolDir
dir) = forall r. PrintfType r => String -> r
printf String
"Terminating (%s) in %s" (forall a. Show a => a -> String
show MiniProtocolNum
mid) (forall a. Show a => a -> String
show MiniProtocolDir
dir)
    show MuxTrace
MuxTraceStopping = String
"Mux stopping"
    show MuxTrace
MuxTraceStopped  = String
"Mux stoppped"
#ifdef os_HOST_linux
    show (MuxTraceTCPInfo StructTCPInfo
            { tcpi_snd_mss, tcpi_rcv_mss, tcpi_lost, tcpi_retrans
            , tcpi_rtt, tcpi_rttvar, tcpi_snd_cwnd }
            len)
                                     =
      printf "TCPInfo rtt %d rttvar %d cwnd %d smss %d rmss %d lost %d retrans %d len %d"
        (fromIntegral tcpi_rtt :: Word) (fromIntegral tcpi_rttvar :: Word)
        (fromIntegral tcpi_snd_cwnd :: Word) (fromIntegral tcpi_snd_mss :: Word)
        (fromIntegral tcpi_rcv_mss :: Word) (fromIntegral tcpi_lost :: Word)
        (fromIntegral tcpi_retrans :: Word)
        len
#else
    show (MuxTraceTCPInfo StructTCPInfo
_ Word16
len) = forall r. PrintfType r => String -> r
printf String
"TCPInfo len %d" Word16
len
#endif