    {-# LANGUAGE CPP #-}

    module Network.Wai.Middleware.RequestLogger.JSON (
        formatAsJSON,
        formatAsJSONWithHeaders,
        requestToJSON,
    ) where

    import Data.Aeson
    import qualified Data.ByteString.Builder as BB (toLazyByteString)
    import qualified Data.ByteString.Char8 as S8
    import Data.ByteString.Lazy (toStrict)
    import Data.CaseInsensitive (original)
    import Data.IP (fromHostAddress, fromIPv4)
    import Data.Maybe (maybeToList)
    #if __GLASGOW_HASKELL__ < 804
    import Data.Monoid ((<>))
    #endif
    import Data.Text (Text)
    import qualified Data.Text as T
    import Data.Text.Encoding (decodeUtf8With)
    import Data.Text.Encoding.Error (lenientDecode)
    import Data.Time (NominalDiffTime)
    import Data.Word (Word32)
    import Network.HTTP.Types as H
    import Network.Socket (PortNumber, SockAddr (..))
    import Network.Wai
    import System.Log.FastLogger (toLogStr)
    import Text.Printf (printf)

    import Network.Wai.Middleware.RequestLogger

    formatAsJSON :: OutputFormatterWithDetails
    formatAsJSON :: OutputFormatterWithDetails
    formatAsJSON ZonedDate
    date Request
    req Status
    status Maybe Integer
    responseSize NominalDiffTime
    duration [ZonedDate]
    reqBody Builder
    response =
        ByteString -> LogStr
    forall msg. ToLogStr msg => msg -> LogStr
    toLogStr
            ( Value -> ByteString
    forall a. ToJSON a => a -> ByteString
    encode (Value -> ByteString) -> Value -> ByteString
    forall a b. (a -> b) -> a -> b
    $
                [Pair] -> Value
    object
                    [ Key
    "request" Key -> Value -> Pair
    forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
    forall v. ToJSON v => Key -> v -> Pair
    .= Request -> [ZonedDate] -> Maybe NominalDiffTime -> Value
    requestToJSON Request
    req [ZonedDate]
    reqBody (NominalDiffTime -> Maybe NominalDiffTime
    forall a. a -> Maybe a
    Just NominalDiffTime
    duration)
                    , Key
    "response"
                        Key -> Value -> Pair
    forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
    forall v. ToJSON v => Key -> v -> Pair
    .= [Pair] -> Value
    object
                            [ Key
    "status" Key -> Int -> Pair
    forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
    forall v. ToJSON v => Key -> v -> Pair
    .= Status -> Int
    statusCode Status
    status
                            , Key
    "size" Key -> Maybe Integer -> Pair
    forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
    forall v. ToJSON v => Key -> v -> Pair
    .= Maybe Integer
    responseSize
                            , Key
    "body"
                                Key -> Maybe Text -> Pair
    forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
    forall v. ToJSON v => Key -> v -> Pair
    .= if Status -> Int
    statusCode Status
    status Int -> Int -> Bool
    forall a. Ord a => a -> a -> Bool
    >= Int
    400
                                    then Text -> Maybe Text
    forall a. a -> Maybe a
    Just (Text -> Maybe Text) -> (Builder -> Text) -> Builder -> Maybe Text
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    . OnDecodeError -> ZonedDate -> Text
    decodeUtf8With OnDecodeError
    lenientDecode (ZonedDate -> Text) -> (Builder -> ZonedDate) -> Builder -> Text
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    . ByteString -> ZonedDate
    toStrict (ByteString -> ZonedDate)
    -> (Builder -> ByteString) -> Builder -> ZonedDate
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    . Builder -> ByteString
    BB.toLazyByteString (Builder -> Maybe Text) -> Builder -> Maybe Text
    forall a b. (a -> b) -> a -> b
    $ Builder
    response
                                    else Maybe Text
    forall a. Maybe a
    Nothing
                            ]
                    , Key
    "time" Key -> Text -> Pair
    forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
    forall v. ToJSON v => Key -> v -> Pair
    .= OnDecodeError -> ZonedDate -> Text
    decodeUtf8With OnDecodeError
    lenientDecode ZonedDate
    date
                    ]
            )
            LogStr -> LogStr -> LogStr
    forall a. Semigroup a => a -> a -> a
    <> LogStr
    "\n"

    -- | Same as @formatAsJSON@ but with response headers included
    --
    -- This is useful for passing arbitrary data from your application out to the
    -- WAI layer for it to be logged, but you may need to be careful to
    -- subsequently redact any headers which may contain sensitive data.
    --
    -- @since 3.0.27
    formatAsJSONWithHeaders :: OutputFormatterWithDetailsAndHeaders
    formatAsJSONWithHeaders :: OutputFormatterWithDetailsAndHeaders
    formatAsJSONWithHeaders ZonedDate
    date Request
    req Status
    status Maybe Integer
    resSize NominalDiffTime
    duration [ZonedDate]
    reqBody Builder
    res [Header]
    resHeaders =
        ByteString -> LogStr
    forall msg. ToLogStr msg => msg -> LogStr
    toLogStr
            ( Value -> ByteString
    forall a. ToJSON a => a -> ByteString
    encode (Value -> ByteString) -> Value -> ByteString
    forall a b. (a -> b) -> a -> b
    $
                [Pair] -> Value
    object
                    [ Key
    "request" Key -> Value -> Pair
    forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
    forall v. ToJSON v => Key -> v -> Pair
    .= Request -> [ZonedDate] -> Maybe NominalDiffTime -> Value
    requestToJSON Request
    req [ZonedDate]
    reqBody (NominalDiffTime -> Maybe NominalDiffTime
    forall a. a -> Maybe a
    Just NominalDiffTime
    duration)
                    , Key
    "response"
                        Key -> Value -> Pair
    forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
    forall v. ToJSON v => Key -> v -> Pair
    .= [Pair] -> Value
    object
                            [ Key
    "status" Key -> Int -> Pair
    forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
    forall v. ToJSON v => Key -> v -> Pair
    .= Status -> Int
    statusCode Status
    status
                            , Key
    "size" Key -> Maybe Integer -> Pair
    forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
    forall v. ToJSON v => Key -> v -> Pair
    .= Maybe Integer
    resSize
                            , Key
    "headers" Key -> Value -> Pair
    forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
    forall v. ToJSON v => Key -> v -> Pair
    .= [Header] -> Value
    responseHeadersToJSON [Header]
    resHeaders
                            , Key
    "body"
                                Key -> Maybe Text -> Pair
    forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
    forall v. ToJSON v => Key -> v -> Pair
    .= if Status -> Int
    statusCode Status
    status Int -> Int -> Bool
    forall a. Ord a => a -> a -> Bool
    >= Int
    400
                                    then Text -> Maybe Text
    forall a. a -> Maybe a
    Just (Text -> Maybe Text) -> (Builder -> Text) -> Builder -> Maybe Text
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    . OnDecodeError -> ZonedDate -> Text
    decodeUtf8With OnDecodeError
    lenientDecode (ZonedDate -> Text) -> (Builder -> ZonedDate) -> Builder -> Text
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    . ByteString -> ZonedDate
    toStrict (ByteString -> ZonedDate)
    -> (Builder -> ByteString) -> Builder -> ZonedDate
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    . Builder -> ByteString
    BB.toLazyByteString (Builder -> Maybe Text) -> Builder -> Maybe Text
    forall a b. (a -> b) -> a -> b
    $ Builder
    res
                                    else Maybe Text
    forall a. Maybe a
    Nothing
                            ]
                    , Key
    "time" Key -> Text -> Pair
    forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
    forall v. ToJSON v => Key -> v -> Pair
    .= OnDecodeError -> ZonedDate -> Text
    decodeUtf8With OnDecodeError
    lenientDecode ZonedDate
    date
                    ]
            )
            LogStr -> LogStr -> LogStr
    forall a. Semigroup a => a -> a -> a
    <> LogStr
    "\n"

    word32ToHostAddress :: Word32 -> Text
    word32ToHostAddress :: Word32 -> Text
    word32ToHostAddress = Text -> [Text] -> Text
    T.intercalate Text
    "." ([Text] -> Text) -> (Word32 -> [Text]) -> Word32 -> Text
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    . (Int -> Text) -> [Int] -> [Text]
    forall a b. (a -> b) -> [a] -> [b]
    map (String -> Text
    T.pack (String -> Text) -> (Int -> String) -> Int -> Text
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    . Int -> String
    forall a. Show a => a -> String
    show) ([Int] -> [Text]) -> (Word32 -> [Int]) -> Word32 -> [Text]
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    . IPv4 -> [Int]
    fromIPv4 (IPv4 -> [Int]) -> (Word32 -> IPv4) -> Word32 -> [Int]
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    . Word32 -> IPv4
    fromHostAddress

    readAsDouble :: String -> Double
    readAsDouble :: String -> Double
    readAsDouble = String -> Double
    forall a. Read a => String -> a
    read

    -- | Get the JSON representation for a request
    --
    -- This representation is identical to that used in 'formatAsJSON' for the
    -- request. It includes:
    --
    --   [@method@]:
    --   [@path@]:
    --   [@queryString@]:
    --   [@size@]: The size of the body, as defined in the request. This may differ
    --   from the size of the data passed in the second argument.
    --   [@body@]: The body, concatenated directly from the chunks passed in
    --   [@remoteHost@]:
    --   [@httpVersion@]:
    --   [@headers@]:
    --
    -- If a @'Just' duration@ is passed in, then additionally the JSON includes:
    --
    --   [@durationMs@] The duration, formatted in milliseconds, to 2 decimal
    --   places
    --
    -- This representation is not an API, and may change at any time (within reason)
    -- without a major version bump.
    --
    -- @since 3.1.4
    requestToJSON
        :: Request
        -- ^ The WAI request
        -> [S8.ByteString]
        -- ^ Chunked request body
        -> Maybe NominalDiffTime
        -- ^ Optional request duration
        -> Value
    requestToJSON :: Request -> [ZonedDate] -> Maybe NominalDiffTime -> Value
    requestToJSON Request
    req [ZonedDate]
    reqBody Maybe NominalDiffTime
    duration =
        [Pair] -> Value
    object ([Pair] -> Value) -> [Pair] -> Value
    forall a b. (a -> b) -> a -> b
    $
            [ Key
    "method" Key -> Text -> Pair
    forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
    forall v. ToJSON v => Key -> v -> Pair
    .= OnDecodeError -> ZonedDate -> Text
    decodeUtf8With OnDecodeError
    lenientDecode (Request -> ZonedDate
    requestMethod Request
    req)
            , Key
    "path" Key -> Text -> Pair
    forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
    forall v. ToJSON v => Key -> v -> Pair
    .= OnDecodeError -> ZonedDate -> Text
    decodeUtf8With OnDecodeError
    lenientDecode (Request -> ZonedDate
    rawPathInfo Request
    req)
            , Key
    "queryString" Key -> [Value] -> Pair
    forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
    forall v. ToJSON v => Key -> v -> Pair
    .= (QueryItem -> Value) -> [QueryItem] -> [Value]
    forall a b. (a -> b) -> [a] -> [b]
    map QueryItem -> Value
    queryItemToJSON (Request -> [QueryItem]
    queryString Request
    req)
            , Key
    "size" Key -> Value -> Pair
    forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
    forall v. ToJSON v => Key -> v -> Pair
    .= RequestBodyLength -> Value
    requestBodyLengthToJSON (Request -> RequestBodyLength
    requestBodyLength Request
    req)
            , Key
    "body" Key -> Text -> Pair
    forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
    forall v. ToJSON v => Key -> v -> Pair
    .= OnDecodeError -> ZonedDate -> Text
    decodeUtf8With OnDecodeError
    lenientDecode ([ZonedDate] -> ZonedDate
    S8.concat [ZonedDate]
    reqBody)
            , Key
    "remoteHost" Key -> Value -> Pair
    forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
    forall v. ToJSON v => Key -> v -> Pair
    .= SockAddr -> Value
    sockToJSON (Request -> SockAddr
    remoteHost Request
    req)
            , Key
    "httpVersion" Key -> Value -> Pair
    forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
    forall v. ToJSON v => Key -> v -> Pair
    .= HttpVersion -> Value
    httpVersionToJSON (Request -> HttpVersion
    httpVersion Request
    req)
            , Key
    "headers" Key -> Value -> Pair
    forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
    forall v. ToJSON v => Key -> v -> Pair
    .= [Header] -> Value
    requestHeadersToJSON (Request -> [Header]
    requestHeaders Request
    req)
            ]
                [Pair] -> [Pair] -> [Pair]
    forall a. Semigroup a => a -> a -> a
    <> Maybe Pair -> [Pair]
    forall a. Maybe a -> [a]
    maybeToList
                    ( (Key
    "durationMs" Key -> Double -> Pair
    forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
    forall v. ToJSON v => Key -> v -> Pair
    .=)
                        (Double -> Pair)
    -> (NominalDiffTime -> Double) -> NominalDiffTime -> Pair
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    . String -> Double
    readAsDouble
                        (String -> Double)
    -> (NominalDiffTime -> String) -> NominalDiffTime -> Double
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    . String -> Double -> String
    forall r. PrintfType r => String -> r
    printf String
    "%.2f"
                        (Double -> String)
    -> (NominalDiffTime -> Double) -> NominalDiffTime -> String
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    . Rational -> Double
    rationalToDouble
                        (Rational -> Double)
    -> (NominalDiffTime -> Rational) -> NominalDiffTime -> Double
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    . (Rational -> Rational -> Rational
    forall a. Num a => a -> a -> a
    * Rational
    1000)
                        (Rational -> Rational)
    -> (NominalDiffTime -> Rational) -> NominalDiffTime -> Rational
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    . NominalDiffTime -> Rational
    forall a. Real a => a -> Rational
    toRational
                        (NominalDiffTime -> Pair) -> Maybe NominalDiffTime -> Maybe Pair
    forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
    <$> Maybe NominalDiffTime
    duration
                    )
      where
        rationalToDouble :: Rational -> Double
        rationalToDouble :: Rational -> Double
    rationalToDouble = Rational -> Double
    forall a. Fractional a => Rational -> a
    fromRational

    sockToJSON :: SockAddr -> Value
    sockToJSON :: SockAddr -> Value
    sockToJSON (SockAddrInet PortNumber
    pn Word32
    ha) =
        [Pair] -> Value
    object
            [ Key
    "port" Key -> Value -> Pair
    forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
    forall v. ToJSON v => Key -> v -> Pair
    .= PortNumber -> Value
    portToJSON PortNumber
    pn
            , Key
    "hostAddress" Key -> Text -> Pair
    forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
    forall v. ToJSON v => Key -> v -> Pair
    .= Word32 -> Text
    word32ToHostAddress Word32
    ha
            ]
    sockToJSON (SockAddrInet6 PortNumber
    pn Word32
    _ HostAddress6
    ha Word32
    _) =
        [Pair] -> Value
    object
            [ Key
    "port" Key -> Value -> Pair
    forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
    forall v. ToJSON v => Key -> v -> Pair
    .= PortNumber -> Value
    portToJSON PortNumber
    pn
            , Key
    "hostAddress" Key -> HostAddress6 -> Pair
    forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
    forall v. ToJSON v => Key -> v -> Pair
    .= HostAddress6
    ha
            ]
    sockToJSON (SockAddrUnix String
    sock) =
        [Pair] -> Value
    object [Key
    "unix" Key -> String -> Pair
    forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
    forall v. ToJSON v => Key -> v -> Pair
    .= String
    sock]
    #if !MIN_VERSION_network(3,0,0)
    sockToJSON (SockAddrCan i) =
      object [ "can" .= i ]
    #endif

    queryItemToJSON :: QueryItem -> Value
    queryItemToJSON :: QueryItem -> Value
    queryItemToJSON (ZonedDate
    name, Maybe ZonedDate
    mValue) =
        (Text, Maybe Text) -> Value
    forall a. ToJSON a => a -> Value
    toJSON
            (OnDecodeError -> ZonedDate -> Text
    decodeUtf8With OnDecodeError
    lenientDecode ZonedDate
    name, (ZonedDate -> Text) -> Maybe ZonedDate -> Maybe Text
    forall a b. (a -> b) -> Maybe a -> Maybe b
    forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
    fmap (OnDecodeError -> ZonedDate -> Text
    decodeUtf8With OnDecodeError
    lenientDecode) Maybe ZonedDate
    mValue)

    requestHeadersToJSON :: RequestHeaders -> Value
    requestHeadersToJSON :: [Header] -> Value
    requestHeadersToJSON = [Value] -> Value
    forall a. ToJSON a => a -> Value
    toJSON ([Value] -> Value) -> ([Header] -> [Value]) -> [Header] -> Value
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    . (Header -> Value) -> [Header] -> [Value]
    forall a b. (a -> b) -> [a] -> [b]
    map Header -> Value
    hToJ
      where
        -- Redact cookies
        hToJ :: Header -> Value
    hToJ (HeaderName
    "Cookie", ZonedDate
    _) = (Text, Text) -> Value
    forall a. ToJSON a => a -> Value
    toJSON (Text
    "Cookie" :: Text, Text
    "-RDCT-" :: Text)
        hToJ Header
    hd = Header -> Value
    headerToJSON Header
    hd

    responseHeadersToJSON :: [Header] -> Value
    responseHeadersToJSON :: [Header] -> Value
    responseHeadersToJSON = [Value] -> Value
    forall a. ToJSON a => a -> Value
    toJSON ([Value] -> Value) -> ([Header] -> [Value]) -> [Header] -> Value
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    . (Header -> Value) -> [Header] -> [Value]
    forall a b. (a -> b) -> [a] -> [b]
    map Header -> Value
    hToJ
      where
        -- Redact cookies
        hToJ :: Header -> Value
    hToJ (HeaderName
    "Set-Cookie", ZonedDate
    _) = (Text, Text) -> Value
    forall a. ToJSON a => a -> Value
    toJSON (Text
    "Set-Cookie" :: Text, Text
    "-RDCT-" :: Text)
        hToJ Header
    hd = Header -> Value
    headerToJSON Header
    hd

    headerToJSON :: Header -> Value
    headerToJSON :: Header -> Value
    headerToJSON (HeaderName
    headerName, ZonedDate
    header) =
        (Text, Text) -> Value
    forall a. ToJSON a => a -> Value
    toJSON
            ( OnDecodeError -> ZonedDate -> Text
    decodeUtf8With OnDecodeError
    lenientDecode (ZonedDate -> Text)
    -> (HeaderName -> ZonedDate) -> HeaderName -> Text
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    . HeaderName -> ZonedDate
    forall s. CI s -> s
    original (HeaderName -> Text) -> HeaderName -> Text
    forall a b. (a -> b) -> a -> b
    $ HeaderName
    headerName
            , OnDecodeError -> ZonedDate -> Text
    decodeUtf8With OnDecodeError
    lenientDecode ZonedDate
    header
            )

    portToJSON :: PortNumber -> Value
    portToJSON :: PortNumber -> Value
    portToJSON = Integer -> Value
    forall a. ToJSON a => a -> Value
    toJSON (Integer -> Value)
    -> (PortNumber -> Integer) -> PortNumber -> Value
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    . PortNumber -> Integer
    forall a. Integral a => a -> Integer
    toInteger

    httpVersionToJSON :: HttpVersion -> Value
    httpVersionToJSON :: HttpVersion -> Value
    httpVersionToJSON (HttpVersion Int
    major Int
    minor) = Text -> Value
    String (Text -> Value) -> Text -> Value
    forall a b. (a -> b) -> a -> b
    $ String -> Text
    T.pack (Int -> String
    forall a. Show a => a -> String
    show Int
    major) Text -> Text -> Text
    forall a. Semigroup a => a -> a -> a
    <> Text
    "." Text -> Text -> Text
    forall a. Semigroup a => a -> a -> a
    <> String -> Text
    T.pack (Int -> String
    forall a. Show a => a -> String
    show Int
    minor)

    requestBodyLengthToJSON :: RequestBodyLength -> Value
    requestBodyLengthToJSON :: RequestBodyLength -> Value
    requestBodyLengthToJSON RequestBodyLength
    ChunkedBody = Text -> Value
    String Text
    "Unknown"
    requestBodyLengthToJSON (KnownLength Word64
    l) = Word64 -> Value
    forall a. ToJSON a => a -> Value
    toJSON Word64
    l