    {-# LANGUAGE RecordWildCards #-}
    {-# LANGUAGE CPP #-}

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

    import qualified Data.ByteString.Builder as BB (toLazyByteString)
    import Data.ByteString.Lazy (toStrict)
    import Data.Aeson
    import Data.CaseInsensitive (original)
    import Data.Monoid ((<>))
    import qualified Data.ByteString.Char8 as S8
    import Data.IP
    import qualified Data.Text as T
    import Data.Text (Text)
    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 (SockAddr (..), PortNumber)
    import Network.Wai
    import Network.Wai.Middleware.RequestLogger
    import System.Log.FastLogger (toLogStr)
    import Text.Printf (printf)

    formatAsJSON :: OutputFormatterWithDetails
    formatAsJSON :: OutputFormatterWithDetails
    formatAsJSON date :: ZonedDate
    date req :: Request
    req status :: Status
    status responseSize :: Maybe Integer
    responseSize duration :: NominalDiffTime
    duration reqBody :: [ZonedDate]
    reqBody response :: 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
          [ "request"  Text -> Value -> Pair
    forall kv v. (KeyValue kv, ToJSON v) => Text -> v -> kv
    .= NominalDiffTime -> Request -> [ZonedDate] -> Value
    requestToJSON NominalDiffTime
    duration Request
    req [ZonedDate]
    reqBody
          , "response" Text -> Value -> Pair
    forall kv v. (KeyValue kv, ToJSON v) => Text -> v -> kv
    .=
          [Pair] -> Value
    object
            [ "status" Text -> Int -> Pair
    forall kv v. (KeyValue kv, ToJSON v) => Text -> v -> kv
    .= Status -> Int
    statusCode Status
    status
            , "size"   Text -> Maybe Integer -> Pair
    forall kv v. (KeyValue kv, ToJSON v) => Text -> v -> kv
    .= Maybe Integer
    responseSize
            , "body"   Text -> Maybe Text -> Pair
    forall kv v. (KeyValue kv, ToJSON v) => Text -> v -> kv
    .=
              if Status -> Int
    statusCode Status
    status Int -> Int -> Bool
    forall a. Ord a => a -> a -> Bool
    >= 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
            ]
          , "time"     Text -> Text -> Pair
    forall kv v. (KeyValue kv, ToJSON v) => Text -> v -> kv
    .= OnDecodeError -> ZonedDate -> Text
    decodeUtf8With OnDecodeError
    lenientDecode ZonedDate
    date
          ]) LogStr -> LogStr -> LogStr
    forall a. Semigroup a => a -> a -> a
    <> "\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 date :: ZonedDate
    date req :: Request
    req status :: Status
    status resSize :: Maybe Integer
    resSize duration :: NominalDiffTime
    duration reqBody :: [ZonedDate]
    reqBody res :: Builder
    res resHeaders :: [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
          [ "request"  Text -> Value -> Pair
    forall kv v. (KeyValue kv, ToJSON v) => Text -> v -> kv
    .= NominalDiffTime -> Request -> [ZonedDate] -> Value
    requestToJSON NominalDiffTime
    duration Request
    req [ZonedDate]
    reqBody
          , "response" Text -> Value -> Pair
    forall kv v. (KeyValue kv, ToJSON v) => Text -> v -> kv
    .= [Pair] -> Value
    object
            [ "status" Text -> Int -> Pair
    forall kv v. (KeyValue kv, ToJSON v) => Text -> v -> kv
    .= Status -> Int
    statusCode Status
    status
            , "size"   Text -> Maybe Integer -> Pair
    forall kv v. (KeyValue kv, ToJSON v) => Text -> v -> kv
    .= Maybe Integer
    resSize
            , "headers" Text -> Value -> Pair
    forall kv v. (KeyValue kv, ToJSON v) => Text -> v -> kv
    .= [Header] -> Value
    responseHeadersToJSON [Header]
    resHeaders
            , "body"   Text -> Maybe Text -> Pair
    forall kv v. (KeyValue kv, ToJSON v) => Text -> v -> kv
    .=
              if Status -> Int
    statusCode Status
    status Int -> Int -> Bool
    forall a. Ord a => a -> a -> Bool
    >= 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
            ]
          , "time"     Text -> Text -> Pair
    forall kv v. (KeyValue kv, ToJSON v) => Text -> v -> kv
    .= OnDecodeError -> ZonedDate -> Text
    decodeUtf8With OnDecodeError
    lenientDecode ZonedDate
    date
          ]) LogStr -> LogStr -> LogStr
    forall a. Semigroup a => a -> a -> a
    <> "\n"

    word32ToHostAddress :: Word32 -> Text
    word32ToHostAddress :: Word32 -> Text
    word32ToHostAddress = Text -> [Text] -> Text
    T.intercalate "." ([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

    requestToJSON :: NominalDiffTime -> Request -> [S8.ByteString] -> Value
    requestToJSON :: NominalDiffTime -> Request -> [ZonedDate] -> Value
    requestToJSON duration :: NominalDiffTime
    duration req :: Request
    req reqBody :: [ZonedDate]
    reqBody =
      [Pair] -> Value
    object
        [ "method" Text -> Text -> Pair
    forall kv v. (KeyValue kv, ToJSON v) => Text -> v -> kv
    .= OnDecodeError -> ZonedDate -> Text
    decodeUtf8With OnDecodeError
    lenientDecode (Request -> ZonedDate
    requestMethod Request
    req)
        , "path" Text -> Text -> Pair
    forall kv v. (KeyValue kv, ToJSON v) => Text -> v -> kv
    .= OnDecodeError -> ZonedDate -> Text
    decodeUtf8With OnDecodeError
    lenientDecode (Request -> ZonedDate
    rawPathInfo Request
    req)
        , "queryString" Text -> [Value] -> Pair
    forall kv v. (KeyValue kv, ToJSON v) => Text -> v -> kv
    .= (QueryItem -> Value) -> [QueryItem] -> [Value]
    forall a b. (a -> b) -> [a] -> [b]
    map QueryItem -> Value
    queryItemToJSON (Request -> [QueryItem]
    queryString Request
    req)
        , "durationMs" Text -> Double -> Pair
    forall kv v. (KeyValue kv, ToJSON v) => Text -> v -> kv
    .= (String -> Double
    readAsDouble (String -> Double) -> (Rational -> String) -> Rational -> Double
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    . String -> Double -> String
    forall r. PrintfType r => String -> r
    printf "%.2f" (Double -> String) -> (Rational -> Double) -> Rational -> String
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    . Rational -> Double
    rationalToDouble (Rational -> Double) -> Rational -> Double
    forall a b. (a -> b) -> a -> b
    $ NominalDiffTime -> Rational
    forall a. Real a => a -> Rational
    toRational NominalDiffTime
    duration Rational -> Rational -> Rational
    forall a. Num a => a -> a -> a
    * 1000)
        , "size" Text -> Value -> Pair
    forall kv v. (KeyValue kv, ToJSON v) => Text -> v -> kv
    .= RequestBodyLength -> Value
    requestBodyLengthToJSON (Request -> RequestBodyLength
    requestBodyLength Request
    req)
        , "body" Text -> Text -> Pair
    forall kv v. (KeyValue kv, ToJSON v) => Text -> v -> kv
    .= OnDecodeError -> ZonedDate -> Text
    decodeUtf8With OnDecodeError
    lenientDecode ([ZonedDate] -> ZonedDate
    S8.concat [ZonedDate]
    reqBody)
        , "remoteHost" Text -> Value -> Pair
    forall kv v. (KeyValue kv, ToJSON v) => Text -> v -> kv
    .= SockAddr -> Value
    sockToJSON (Request -> SockAddr
    remoteHost Request
    req)
        , "httpVersion" Text -> Value -> Pair
    forall kv v. (KeyValue kv, ToJSON v) => Text -> v -> kv
    .= HttpVersion -> Value
    httpVersionToJSON (Request -> HttpVersion
    httpVersion Request
    req)
        , "headers" Text -> Value -> Pair
    forall kv v. (KeyValue kv, ToJSON v) => Text -> v -> kv
    .= [Header] -> Value
    requestHeadersToJSON (Request -> [Header]
    requestHeaders Request
    req)
        ]
      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 pn :: PortNumber
    pn ha :: Word32
    ha) =
      [Pair] -> Value
    object
        [ "port" Text -> Value -> Pair
    forall kv v. (KeyValue kv, ToJSON v) => Text -> v -> kv
    .= PortNumber -> Value
    portToJSON PortNumber
    pn
        , "hostAddress" Text -> Text -> Pair
    forall kv v. (KeyValue kv, ToJSON v) => Text -> v -> kv
    .= Word32 -> Text
    word32ToHostAddress Word32
    ha
        ]
    sockToJSON (SockAddrInet6 pn :: PortNumber
    pn _ ha :: HostAddress6
    ha _) =
      [Pair] -> Value
    object
        [ "port" Text -> Value -> Pair
    forall kv v. (KeyValue kv, ToJSON v) => Text -> v -> kv
    .= PortNumber -> Value
    portToJSON PortNumber
    pn
        , "hostAddress" Text -> HostAddress6 -> Pair
    forall kv v. (KeyValue kv, ToJSON v) => Text -> v -> kv
    .= HostAddress6
    ha
        ]
    sockToJSON (SockAddrUnix sock :: String
    sock) =
      [Pair] -> Value
    object [ "unix" Text -> String -> Pair
    forall kv v. (KeyValue kv, ToJSON v) => Text -> v -> kv
    .= String
    sock ]
    #if !MIN_VERSION_network(3,0,0)
    sockToJSON (SockAddrCan i) =
      object [ "can" .= i ]
    #endif

    queryItemToJSON :: QueryItem -> Value
    queryItemToJSON :: QueryItem -> Value
    queryItemToJSON (name :: ZonedDate
    name, mValue :: 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 (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 ("Cookie", _) = (Text, Text) -> Value
    forall a. ToJSON a => a -> Value
    toJSON ("Cookie" :: Text, "-RDCT-" :: Text)
      hToJ hd :: 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 ("Set-Cookie", _) = (Text, Text) -> Value
    forall a. ToJSON a => a -> Value
    toJSON ("Set-Cookie" :: Text, "-RDCT-" :: Text)
      hToJ hd :: Header
    hd = Header -> Value
    headerToJSON Header
    hd

    headerToJSON :: Header -> Value
    headerToJSON :: Header -> Value
    headerToJSON (headerName :: HeaderName
    headerName, header :: 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 major :: Int
    major minor :: 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
    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 ChunkedBody = Text -> Value
    String "Unknown"
    requestBodyLengthToJSON (KnownLength l :: Word64
    l) = Word64 -> Value
    forall a. ToJSON a => a -> Value
    toJSON Word64
    l