{-# 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 v. ToJSON v => Key -> v -> Pair
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= 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 v. ToJSON v => Key -> v -> Pair
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= [Pair] -> Value
object
                        [ Key
"status" Key -> Int -> Pair
forall v. ToJSON v => Key -> v -> Pair
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= Status -> Int
statusCode Status
status
                        , Key
"size" Key -> Maybe Integer -> Pair
forall v. ToJSON v => Key -> v -> Pair
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= Maybe Integer
responseSize
                        , Key
"body"
                            Key -> Maybe Text -> Pair
forall v. ToJSON v => Key -> v -> Pair
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= 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 v. ToJSON v => Key -> v -> Pair
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= 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 v. ToJSON v => Key -> v -> Pair
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= 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 v. ToJSON v => Key -> v -> Pair
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= [Pair] -> Value
object
                        [ Key
"status" Key -> Int -> Pair
forall v. ToJSON v => Key -> v -> Pair
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= Status -> Int
statusCode Status
status
                        , Key
"size" Key -> Maybe Integer -> Pair
forall v. ToJSON v => Key -> v -> Pair
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= Maybe Integer
resSize
                        , Key
"headers" Key -> Value -> Pair
forall v. ToJSON v => Key -> v -> Pair
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= [Header] -> Value
responseHeadersToJSON [Header]
resHeaders
                        , Key
"body"
                            Key -> Maybe Text -> Pair
forall v. ToJSON v => Key -> v -> Pair
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= 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 v. ToJSON v => Key -> v -> Pair
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= 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 v. ToJSON v => Key -> v -> Pair
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= OnDecodeError -> ZonedDate -> Text
decodeUtf8With OnDecodeError
lenientDecode (Request -> ZonedDate
requestMethod Request
req)
        , Key
"path" Key -> Text -> Pair
forall v. ToJSON v => Key -> v -> Pair
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= OnDecodeError -> ZonedDate -> Text
decodeUtf8With OnDecodeError
lenientDecode (Request -> ZonedDate
rawPathInfo Request
req)
        , Key
"queryString" Key -> [Value] -> Pair
forall v. ToJSON v => Key -> v -> Pair
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= (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 v. ToJSON v => Key -> v -> Pair
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= RequestBodyLength -> Value
requestBodyLengthToJSON (Request -> RequestBodyLength
requestBodyLength Request
req)
        , Key
"body" Key -> Text -> Pair
forall v. ToJSON v => Key -> v -> Pair
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= OnDecodeError -> ZonedDate -> Text
decodeUtf8With OnDecodeError
lenientDecode ([ZonedDate] -> ZonedDate
S8.concat [ZonedDate]
reqBody)
        , Key
"remoteHost" Key -> Value -> Pair
forall v. ToJSON v => Key -> v -> Pair
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= SockAddr -> Value
sockToJSON (Request -> SockAddr
remoteHost Request
req)
        , Key
"httpVersion" Key -> Value -> Pair
forall v. ToJSON v => Key -> v -> Pair
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= HttpVersion -> Value
httpVersionToJSON (Request -> HttpVersion
httpVersion Request
req)
        , Key
"headers" Key -> Value -> Pair
forall v. ToJSON v => Key -> v -> Pair
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= [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 v. ToJSON v => Key -> v -> Pair
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.=)
                    (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 v. ToJSON v => Key -> v -> Pair
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= PortNumber -> Value
portToJSON PortNumber
pn
        , Key
"hostAddress" Key -> Text -> Pair
forall v. ToJSON v => Key -> v -> Pair
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= Word32 -> Text
word32ToHostAddress Word32
ha
        ]
sockToJSON (SockAddrInet6 PortNumber
pn Word32
_ HostAddress6
ha Word32
_) =
    [Pair] -> Value
object
        [ Key
"port" Key -> Value -> Pair
forall v. ToJSON v => Key -> v -> Pair
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= PortNumber -> Value
portToJSON PortNumber
pn
        , Key
"hostAddress" Key -> HostAddress6 -> Pair
forall v. ToJSON v => Key -> v -> Pair
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= HostAddress6
ha
        ]
sockToJSON (SockAddrUnix String
sock) =
    [Pair] -> Value
object [Key
"unix" Key -> String -> Pair
forall v. ToJSON v => Key -> v -> Pair
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> 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 (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