{-# LANGUAGE ExistentialQuantification #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE DeriveFunctor #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE DerivingVia #-}
{-# LANGUAGE DerivingStrategies #-}
{-# LANGUAGE StandaloneDeriving #-}
module Network.Mux.Trace (
MuxError(..)
, MuxErrorType(..)
, handleIOException
, MuxTrace(..)
, MuxBearerState(..)
, WithMuxBearer(..)
, TraceLabelPeer(..)
) where
import Prelude hiding (read)
import Text.Printf
import Control.Monad.Class.MonadThrow
import Control.Monad.Class.MonadTime
import Control.Exception hiding (throwIO)
import GHC.Generics (Generic (..))
import Quiet (Quiet (..))
import Network.Mux.Types
data MuxError = MuxError {
MuxError -> MuxErrorType
errorType :: !MuxErrorType
, MuxError -> String
errorMsg :: !String
}
deriving (forall x. MuxError -> Rep MuxError x)
-> (forall x. Rep MuxError x -> MuxError) -> Generic MuxError
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
(Int -> MuxError -> ShowS)
-> (MuxError -> String) -> ([MuxError] -> ShowS) -> Show MuxError
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
data MuxErrorType = MuxUnknownMiniProtocol
| MuxDecodeError
| MuxBearerClosed
| MuxIngressQueueOverRun
| MuxInitiatorOnly
| MuxIOException IOException
| MuxSDUReadTimeout
| MuxSDUWriteTimeout
| MuxShutdown !(Maybe MuxErrorType)
| MuxCleanShutdown
| MuxBlockedOnCompletionVar !MiniProtocolNum
deriving (Int -> MuxErrorType -> ShowS
[MuxErrorType] -> ShowS
MuxErrorType -> String
(Int -> MuxErrorType -> ShowS)
-> (MuxErrorType -> String)
-> ([MuxErrorType] -> ShowS)
-> Show MuxErrorType
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
(MuxErrorType -> MuxErrorType -> Bool)
-> (MuxErrorType -> MuxErrorType -> Bool) -> Eq MuxErrorType
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}
= (MuxErrorType -> String
forall a. Show a => a -> String
show MuxErrorType
errorType) String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
" " String -> ShowS
forall a. [a] -> [a] -> [a]
++ (ShowS
forall a. Show a => a -> String
show String
errorMsg)
handleIOException :: MonadThrow m => String -> IOException -> m a
handleIOException :: String -> IOException -> m a
handleIOException String
errorMsg IOException
e = MuxError -> m a
forall (m :: * -> *) e a. (MonadThrow m, Exception e) => e -> m a
throwIO MuxError :: MuxErrorType -> String -> MuxError
MuxError {
errorType :: MuxErrorType
errorType = IOException -> MuxErrorType
MuxIOException IOException
e,
errorMsg :: String
errorMsg = Char
'(' Char -> ShowS
forall a. a -> [a] -> [a]
: String
errorMsg String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
")"
}
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
/= :: 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, a -> TraceLabelPeer peerid b -> TraceLabelPeer peerid a
(a -> b) -> TraceLabelPeer peerid a -> TraceLabelPeer peerid b
(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
<$ :: a -> TraceLabelPeer peerid b -> TraceLabelPeer peerid a
$c<$ :: forall peerid a b.
a -> TraceLabelPeer peerid b -> TraceLabelPeer peerid a
fmap :: (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
[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
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)
data WithMuxBearer peerid a = WithMuxBearer {
WithMuxBearer peerid a -> peerid
wmbPeerId :: !peerid
, WithMuxBearer peerid a -> a
wmbEvent :: !a
}
deriving ((forall x.
WithMuxBearer peerid a -> Rep (WithMuxBearer peerid a) x)
-> (forall x.
Rep (WithMuxBearer peerid a) x -> WithMuxBearer peerid a)
-> Generic (WithMuxBearer peerid a)
forall x. Rep (WithMuxBearer peerid a) x -> WithMuxBearer peerid a
forall x. WithMuxBearer peerid a -> Rep (WithMuxBearer peerid a) x
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
(Int -> WithMuxBearer peerid a -> ShowS)
-> (WithMuxBearer peerid a -> String)
-> ([WithMuxBearer peerid a] -> ShowS)
-> Show (WithMuxBearer peerid a)
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))
data MuxBearerState = Mature
| Dead
deriving (MuxBearerState -> MuxBearerState -> Bool
(MuxBearerState -> MuxBearerState -> Bool)
-> (MuxBearerState -> MuxBearerState -> Bool) -> Eq MuxBearerState
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
(Int -> MuxBearerState -> ShowS)
-> (MuxBearerState -> String)
-> ([MuxBearerState] -> ShowS)
-> Show MuxBearerState
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)
data MuxTrace =
| !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
| MuxTraceShutdown
instance Show MuxTrace where
show :: MuxTrace -> String
show MuxTrace
MuxTraceRecvHeaderStart = ShowS
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 }) = String -> Word32 -> String -> String -> Word16 -> String
forall r. PrintfType r => String -> r
printf String
"Bearer Receive Header End: ts: 0x%08x (%s) %s len %d"
(RemoteClockModel -> Word32
unRemoteClockModel RemoteClockModel
mhTimestamp) (MiniProtocolNum -> String
forall a. Show a => a -> String
show MiniProtocolNum
mhNum) (MiniProtocolDir -> String
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) = String -> Word32 -> String -> Word16 -> String
forall r. PrintfType r => String -> r
printf String
"Bearer DeltaQ observation: remote ts %d local ts %s length %d"
(RemoteClockModel -> Word32
unRemoteClockModel RemoteClockModel
mhTimestamp) (Time -> String
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) = String
-> Double
-> Int
-> Int
-> Double
-> Double
-> Double
-> Double
-> ShowS
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) = String -> Int -> String
forall r. PrintfType r => String -> r
printf String
"Bearer Receive Start: length %d" Int
len
show (MuxTraceRecvEnd Int
len) = String -> Int -> String
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 }) = String -> Word32 -> String -> String -> Word16 -> String
forall r. PrintfType r => String -> r
printf String
"Bearer Send Start: ts: 0x%08x (%s) %s length %d"
(RemoteClockModel -> Word32
unRemoteClockModel RemoteClockModel
mhTimestamp) (MiniProtocolNum -> String
forall a. Show a => a -> String
show MiniProtocolNum
mhNum) (MiniProtocolDir -> String
forall a. Show a => a -> String
show MiniProtocolDir
mhDir) Word16
mhLength
show MuxTrace
MuxTraceSendEnd = ShowS
forall r. PrintfType r => String -> r
printf String
"Bearer Send End"
show (MuxTraceState MuxBearerState
new) = String -> ShowS
forall r. PrintfType r => String -> r
printf String
"State: %s" (MuxBearerState -> String
forall a. Show a => a -> String
show MuxBearerState
new)
show (MuxTraceCleanExit MiniProtocolNum
mid MiniProtocolDir
dir) = String -> String -> ShowS
forall r. PrintfType r => String -> r
printf String
"Miniprotocol (%s) %s terminated cleanly" (MiniProtocolNum -> String
forall a. Show a => a -> String
show MiniProtocolNum
mid) (MiniProtocolDir -> String
forall a. Show a => a -> String
show MiniProtocolDir
dir)
show (MuxTraceExceptionExit MiniProtocolNum
mid MiniProtocolDir
dir SomeException
e) = String -> String -> String -> ShowS
forall r. PrintfType r => String -> r
printf String
"Miniprotocol %s %s terminated with exception %s" (MiniProtocolNum -> String
forall a. Show a => a -> String
show MiniProtocolNum
mid) (MiniProtocolDir -> String
forall a. Show a => a -> String
show MiniProtocolDir
dir) (SomeException -> String
forall a. Show a => a -> String
show SomeException
e)
show (MuxTraceChannelRecvStart MiniProtocolNum
mid) = String -> ShowS
forall r. PrintfType r => String -> r
printf String
"Channel Receive Start on %s" (MiniProtocolNum -> String
forall a. Show a => a -> String
show MiniProtocolNum
mid)
show (MuxTraceChannelRecvEnd MiniProtocolNum
mid Int
len) = String -> String -> Int -> String
forall r. PrintfType r => String -> r
printf String
"Channel Receive End on (%s) %d" (MiniProtocolNum -> String
forall a. Show a => a -> String
show MiniProtocolNum
mid)
Int
len
show (MuxTraceChannelSendStart MiniProtocolNum
mid Int
len) = String -> String -> Int -> String
forall r. PrintfType r => String -> r
printf String
"Channel Send Start on (%s) %d" (MiniProtocolNum -> String
forall a. Show a => a -> String
show MiniProtocolNum
mid)
Int
len
show (MuxTraceChannelSendEnd MiniProtocolNum
mid) = String -> ShowS
forall r. PrintfType r => String -> r
printf String
"Channel Send End on %s" (MiniProtocolNum -> String
forall a. Show a => a -> String
show MiniProtocolNum
mid)
show MuxTrace
MuxTraceHandshakeStart = String
"Handshake start"
show (MuxTraceHandshakeClientEnd DiffTime
duration) = String -> ShowS
forall r. PrintfType r => String -> r
printf String
"Handshake Client end, duration %s" (DiffTime -> String
forall a. Show a => a -> String
show DiffTime
duration)
show MuxTrace
MuxTraceHandshakeServerEnd = String
"Handshake Server end"
show (MuxTraceHandshakeClientError e
e DiffTime
duration) =
String -> String -> ShowS
forall r. PrintfType r => String -> r
printf String
"Handshake Client Error %s duration %s" (Int -> ShowS
forall a. Int -> [a] -> [a]
take Int
256 ShowS -> ShowS
forall a b. (a -> b) -> a -> b
$ e -> String
forall a. Show a => a -> String
show e
e) (DiffTime -> String
forall a. Show a => a -> String
show DiffTime
duration)
show (MuxTraceHandshakeServerError e
e) = String -> ShowS
forall r. PrintfType r => String -> r
printf String
"Handshake Server Error %s" (e -> String
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) = String -> String -> ShowS
forall r. PrintfType r => String -> r
printf String
"Eagerly started (%s) in %s" (MiniProtocolNum -> String
forall a. Show a => a -> String
show MiniProtocolNum
mid) (MiniProtocolDir -> String
forall a. Show a => a -> String
show MiniProtocolDir
dir)
show (MuxTraceStartOnDemand MiniProtocolNum
mid MiniProtocolDir
dir) = String -> String -> ShowS
forall r. PrintfType r => String -> r
printf String
"Preparing to start (%s) in %s" (MiniProtocolNum -> String
forall a. Show a => a -> String
show MiniProtocolNum
mid) (MiniProtocolDir -> String
forall a. Show a => a -> String
show MiniProtocolDir
dir)
show (MuxTraceStartedOnDemand MiniProtocolNum
mid MiniProtocolDir
dir) = String -> String -> ShowS
forall r. PrintfType r => String -> r
printf String
"Started on demand (%s) in %s" (MiniProtocolNum -> String
forall a. Show a => a -> String
show MiniProtocolNum
mid) (MiniProtocolDir -> String
forall a. Show a => a -> String
show MiniProtocolDir
dir)
show (MuxTraceTerminating MiniProtocolNum
mid MiniProtocolDir
dir) = String -> String -> ShowS
forall r. PrintfType r => String -> r
printf String
"Terminating (%s) in %s" (MiniProtocolNum -> String
forall a. Show a => a -> String
show MiniProtocolNum
mid) (MiniProtocolDir -> String
forall a. Show a => a -> String
show MiniProtocolDir
dir)
show MuxTrace
MuxTraceShutdown = String
"Mux shutdown"