Qlog.hs

{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RecordWildCards #-}

module Network.QUIC.Qlog (
    QLogger,
    newQlogger,
    Qlog (..),
    KeepQlog (..),
    QlogMsg (..),
    qlogReceived,
    qlogDropped,
    qlogRecvInitial,
    qlogSentRetry,
    qlogParamsSet,
    qlogDebug,
    qlogCIDUpdate,
    Debug (..),
    LR (..),
    packetType,
    sw,
) where

import qualified Data.ByteString as BS

import qualified Data.ByteString.Short as Short
import Data.List (intersperse)
import System.Log.FastLogger
import Text.Printf

import Network.QUIC.Imports
import Network.QUIC.Parameters
import Network.QUIC.Types

class Qlog a where
    qlog :: a -> LogStr

newtype Debug = Debug LogStr
data LR = Local CID | Remote CID

instance Show Debug where
    show (Debug msg) = show msg

instance Qlog Debug where
    qlog (Debug msg) = "{\"message\":\"" <> msg <> "\"}"

instance Qlog LR where
    qlog (Local cid) = "{\"owner\":\"local\",\"new\":\"" <> sw cid <> "\"}"
    qlog (Remote cid) = "{\"owner\":\"remote\",\"new\":\"" <> sw cid <> "\"}"

instance Qlog RetryPacket where
    qlog RetryPacket{} = "{\"header\":{\"packet_type\":\"retry\",\"packet_number\":\"\"}}"

instance Qlog VersionNegotiationPacket where
    qlog VersionNegotiationPacket{} =
        "{\"header\":{\"packet_type\":\"version_negotiation\",\"packet_number\":\"\"}}"

instance Qlog Header where
    qlog hdr = "{\"header\":{\"packet_type\":\"" <> packetType hdr <> "\"}}"

instance Qlog (Header, String) where
    qlog (hdr, str) =
        "{\"header\":{\"packet_type\":\""
            <> packetType hdr
            <> "\", \"trigger\":\""
            <> toLogStr str
            <> "\"}}"

instance Qlog CryptPacket where
    qlog (CryptPacket hdr _) = qlog hdr

instance Qlog PlainPacket where
    qlog (PlainPacket hdr Plain{..}) =
        "{\"header\":{\"packet_type\":\""
            <> toLogStr (packetType hdr)
            <> "\",\"packet_number\":\""
            <> sw plainPacketNumber
            <> "\",\"dcid\":\""
            <> sw (headerMyCID hdr)
            <> "\"},\"frames\":["
            <> foldr (<>) "" (intersperse "," (map qlog plainFrames))
            <> "]}"

instance Qlog StatelessReset where
    qlog StatelessReset = "{\"header\":{\"packet_type\":\"stateless_reset\",\"packet_number\":\"\"}}"

packetType :: Header -> LogStr
packetType Initial{} = "initial"
packetType RTT0{} = "0RTT"
packetType Handshake{} = "handshake"
packetType Short{} = "1RTT"

instance Qlog Frame where
    qlog frame = "{\"frame_type\":\"" <> frameType frame <> "\"" <> frameExtra frame <> "}"

frameType :: Frame -> LogStr
frameType Padding{} = "padding"
frameType Ping = "ping"
frameType Ack{} = "ack"
frameType ResetStream{} = "reset_stream"
frameType StopSending{} = "stop_sending"
frameType CryptoF{} = "crypto"
frameType NewToken{} = "new_token"
frameType StreamF{} = "stream"
frameType MaxData{} = "max_data"
frameType MaxStreamData{} = "max_stream_data"
frameType MaxStreams{} = "max_streams"
frameType DataBlocked{} = "data_blocked"
frameType StreamDataBlocked{} = "stream_data_blocked"
frameType StreamsBlocked{} = "streams_blocked"
frameType NewConnectionID{} = "new_connection_id"
frameType RetireConnectionID{} = "retire_connection_id"
frameType PathChallenge{} = "path_challenge"
frameType PathResponse{} = "path_response"
frameType ConnectionClose{} = "connection_close"
frameType ConnectionCloseApp{} = "connection_close"
frameType HandshakeDone{} = "handshake_done"
frameType Datagram{} = "datagram"
frameType UnknownFrame{} = "unknown"

{-# INLINE frameExtra #-}
frameExtra :: Frame -> LogStr
frameExtra (Padding n) = ",\"payload_length\":" <> sw n
frameExtra Ping = ""
frameExtra (Ack ai _Delay) = ",\"acked_ranges\":" <> ack ai
frameExtra ResetStream{} = ""
frameExtra (StopSending _StreamId _ApplicationError) = ""
frameExtra (CryptoF off dat) = ",\"offset\":\"" <> sw off <> "\",\"length\":" <> sw (BS.length dat)
frameExtra (NewToken _Token) = ""
frameExtra (StreamF sid off dat fin) =
    ",\"stream_id\":\""
        <> sw sid
        <> "\",\"offset\":\""
        <> sw off
        <> "\",\"length\":"
        <> sw (sum' $ map BS.length dat)
        <> ",\"fin\":"
        <> if fin then "true" else "false"
frameExtra (MaxData mx) = ",\"maximum\":\"" <> sw mx <> "\""
frameExtra (MaxStreamData sid mx) = ",\"stream_id\":\"" <> sw sid <> "\",\"maximum\":\"" <> sw mx <> "\""
frameExtra (MaxStreams _Direction ms) = ",\"maximum\":\"" <> sw ms <> "\""
frameExtra DataBlocked{} = ""
frameExtra StreamDataBlocked{} = ""
frameExtra StreamsBlocked{} = ""
frameExtra (NewConnectionID cidinfo rpt) =
    ",\"sequence_number\":\""
        <> sw (cidInfoSeq cidinfo)
        <> "\",\"connection_id:\":\""
        <> sw (cidInfoCID cidinfo)
        <> "\",\"retire_prior_to\":\""
        <> sw rpt
        <> "\",\"stateless_reset_token\":\""
        <> sw (cidInfoSRT cidinfo)
        <> "\""
frameExtra (RetireConnectionID sn) = ",\"sequence_number\":\"" <> sw sn <> "\""
frameExtra (PathChallenge _PathData) = ""
frameExtra (PathResponse _PathData) = ""
frameExtra (ConnectionClose err _FrameType reason) =
    ",\"error_space\":\"transport\",\"error_code\":\""
        <> transportError err
        <> "\",\"raw_error_code\":"
        <> transportError' err
        <> ",\"reason\":\""
        <> toLogStr (Short.fromShort reason)
        <> "\""
frameExtra (ConnectionCloseApp err reason) =
    ",\"error_space\":\"application\",\"error_code\":"
        <> applicationProtoclError err
        <> ",\"reason\":\""
        <> toLogStr (Short.fromShort reason)
        <> "\"" -- fixme
frameExtra HandshakeDone{} = ""
frameExtra (Datagram _ dat) = ",\"length\":" <> sw (BS.length dat)
frameExtra (UnknownFrame _Int) = ""

transportError :: TransportError -> LogStr
transportError NoError = "no_error"
transportError InternalError = "internal_error"
transportError ConnectionRefused = "connection_refused"
transportError FlowControlError = "flow_control_error"
transportError StreamLimitError = "stream_limit_error"
transportError StreamStateError = "stream_state_error"
transportError FinalSizeError = "final_size_error"
transportError FrameEncodingError = "frame_encoding_error"
transportError TransportParameterError = "transport_parameter_err"
transportError ConnectionIdLimitError = "connection_id_limit_error"
transportError ProtocolViolation = "protocol_violation"
transportError InvalidToken = "invalid_migration"
transportError CryptoBufferExceeded = "crypto_buffer_exceeded"
transportError KeyUpdateError = "key_update_error"
transportError AeadLimitReached = "aead_limit_reached"
transportError NoViablePath = "no_viablpath"
transportError (TransportError n) = sw n

transportError' :: TransportError -> LogStr
transportError' (TransportError n) = sw n

applicationProtoclError :: ApplicationProtocolError -> LogStr
applicationProtoclError (ApplicationProtocolError n) = sw n

{-# INLINE ack #-}
ack :: AckInfo -> LogStr
ack (AckInfo lpn r rs) = "[" <> ack1 fr fpn rs <> "]"
  where
    fpn = fromIntegral lpn - r
    fr
        | r == 0 = "[" <> sw lpn <> "]"
        | otherwise = "[" <> sw fpn <> "," <> sw lpn <> "]"

ack1 :: LogStr -> Range -> [(Gap, Range)] -> LogStr
ack1 ret _ [] = ret
ack1 ret fpn ((g, r) : grs) = ack1 ret' f grs
  where
    ret' = "[" <> sw f <> "," <> sw l <> "]," <> ret
    l = fpn - g - 2
    f = l - r

----------------------------------------------------------------

instance Qlog (Parameters, String) where
    qlog (Parameters{..}, owner) =
        "{\"owner\":\""
            <> toLogStr owner
            <> "\",\"initial_max_data\":\""
            <> sw initialMaxData
            <> "\",\"initial_max_stream_data_bidi_local\":\""
            <> sw initialMaxStreamDataBidiLocal
            <> "\",\"initial_max_stream_data_bidi_remote\":\""
            <> sw initialMaxStreamDataBidiRemote
            <> "\",\"initial_max_stream_data_uni\":\""
            <> sw initialMaxStreamDataUni
            <> "\"}"

----------------------------------------------------------------

data QlogMsg
    = QRecvInitial
    | QSentRetry
    | QSent LogStr TimeMicrosecond
    | QReceived LogStr TimeMicrosecond
    | QDropped LogStr TimeMicrosecond
    | QMetricsUpdated LogStr TimeMicrosecond
    | QPacketLost LogStr TimeMicrosecond
    | QCongestionStateUpdated LogStr TimeMicrosecond
    | QLossTimerUpdated LogStr TimeMicrosecond
    | QDebug LogStr TimeMicrosecond
    | QParamsSet LogStr TimeMicrosecond
    | QCIDUpdate LogStr TimeMicrosecond

{-# INLINE toLogStrTime #-}
toLogStrTime :: QlogMsg -> TimeMicrosecond -> LogStr
toLogStrTime QRecvInitial _ =
    "{\"time\":0,\"name\":\"transport:packet_received\",\"data\":{\"header\":{\"packet_type\":\"initial\",\"packet_number\":\"\"}}}\n"
toLogStrTime QSentRetry _ =
    "{\"time\":0,\"name\":\"transport:packet_sent\",\"data\":{\"header\":{\"packet_type\":\"retry\",\"packet_number\":\"\"}}}\n"
toLogStrTime (QReceived msg tim) base =
    "{\"time\":"
        <> swtim tim base
        <> ",\"name\":\"transport:packet_received\",\"data\":"
        <> msg
        <> "}\n"
toLogStrTime (QSent msg tim) base =
    "{\"time\":"
        <> swtim tim base
        <> ",\"name\":\"transport:packet_sent\",\"data\":"
        <> msg
        <> "}\n"
toLogStrTime (QDropped msg tim) base =
    "{\"time\":"
        <> swtim tim base
        <> ",\"name\":\"transport:packet_dropped\",\"data\":"
        <> msg
        <> "}\n"
toLogStrTime (QParamsSet msg tim) base =
    "{\"time\":"
        <> swtim tim base
        <> ",\"name\":\"transport:parameters_set\",\"data\":"
        <> msg
        <> "}\n"
toLogStrTime (QMetricsUpdated msg tim) base =
    "{\"time\":"
        <> swtim tim base
        <> ",\"name\":\"recovery:metrics_updated\",\"data\":"
        <> msg
        <> "}\n"
toLogStrTime (QPacketLost msg tim) base =
    "{\"time\":"
        <> swtim tim base
        <> ",\"name\":\"recovery:packet_lost\",\"data\":"
        <> msg
        <> "}\n"
toLogStrTime (QCongestionStateUpdated msg tim) base =
    "{\"time\":"
        <> swtim tim base
        <> ",\"name\":\"recovery:congestion_state_updated\",\"data\":"
        <> msg
        <> "}\n"
toLogStrTime (QLossTimerUpdated msg tim) base =
    "{\"time\":"
        <> swtim tim base
        <> ",\"name\":\"recovery:loss_timer_updated\",\"data\":"
        <> msg
        <> "}\n"
toLogStrTime (QDebug msg tim) base =
    "{\"time\":"
        <> swtim tim base
        <> ",\"name\":\"debug\",\"data\":"
        <> msg
        <> "}\n"
toLogStrTime (QCIDUpdate msg tim) base =
    "{\"time\":"
        <> swtim tim base
        <> ",\"name\":\"connectivity:connection_id_updated\",\"data\":"
        <> msg
        <> "}\n"

----------------------------------------------------------------

{-# INLINE sw #-}
sw :: Show a => a -> LogStr
sw = toLogStr . show

{-# INLINE swtim #-}
swtim :: TimeMicrosecond -> TimeMicrosecond -> LogStr
swtim tim base = toLogStr (show m ++ "." ++ printf "%03d" u)
  where
    Microseconds x = elapsedTimeMicrosecond tim base
    (m, u) = x `divMod` 1000

----------------------------------------------------------------

type QLogger = QlogMsg -> IO ()

newQlogger :: TimeMicrosecond -> ByteString -> CID -> FastLogger -> IO QLogger
newQlogger base rl ocid fastLogger = do
    let ocid' = toLogStr $ enc16 $ fromCID ocid
    fastLogger $
        "{\"qlog_format\":\"NDJSON\",\"qlog_version\":\"draft-02\",\"title\":\"Haskell quic qlog\",\"trace\":{\"vantage_point\":{\"type\":\""
            <> toLogStr rl
            <> "\"},\"common_fields\":{\"ODCID\":\""
            <> ocid'
            <> "\",\"group_id\":\""
            <> ocid'
            <> "\",\"reference_time\":"
            <> swtim base timeMicrosecond0
            <> "}}}\n"
    let qlogger qmsg = do
            let msg = toLogStrTime qmsg base
            fastLogger msg
    return qlogger

----------------------------------------------------------------

class KeepQlog a where
    keepQlog :: a -> QLogger

qlogReceived :: (KeepQlog q, Qlog a) => q -> a -> TimeMicrosecond -> IO ()
qlogReceived q pkt tim = keepQlog q $ QReceived (qlog pkt) tim

qlogDropped :: (KeepQlog q, Qlog a) => q -> a -> IO ()
qlogDropped q pkt = do
    tim <- getTimeMicrosecond
    keepQlog q $ QDropped (qlog pkt) tim

qlogRecvInitial :: KeepQlog q => q -> IO ()
qlogRecvInitial q = keepQlog q QRecvInitial

qlogSentRetry :: KeepQlog q => q -> IO ()
qlogSentRetry q = keepQlog q QSentRetry

qlogParamsSet :: KeepQlog q => q -> (Parameters, String) -> IO ()
qlogParamsSet q params = do
    tim <- getTimeMicrosecond
    keepQlog q $ QParamsSet (qlog params) tim

qlogDebug :: KeepQlog q => q -> Debug -> IO ()
qlogDebug q msg = do
    tim <- getTimeMicrosecond
    keepQlog q $ QDebug (qlog msg) tim

qlogCIDUpdate :: KeepQlog q => q -> LR -> IO ()
qlogCIDUpdate q lr = do
    tim <- getTimeMicrosecond
    keepQlog q $ QCIDUpdate (qlog lr) tim