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

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

  , requestToJSON
  ) where

import qualified Data.ByteString.Builder as BB (toLazyByteString)
import Data.ByteString.Lazy (toStrict)
import Data.Aeson
import Data.CaseInsensitive (original)
import Data.Maybe (maybeToList)
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 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
.= 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
.=
      [Pair] -> Value
object
        [ Key
"status" Key -> Int -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= Status -> Int
statusCode Status
status
        , Key
"size"   Key -> Maybe Integer -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= Maybe Integer
responseSize
        , Key
"body"   Key -> Maybe Text -> Pair
forall kv v. (KeyValue 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 kv v. (KeyValue 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 kv v. (KeyValue 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 kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= [Pair] -> Value
object
        [ Key
"status" Key -> Int -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= Status -> Int
statusCode Status
status
        , Key
"size"   Key -> Maybe Integer -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= Maybe Integer
resSize
        , Key
"headers" Key -> Value -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= [Header] -> Value
responseHeadersToJSON [Header]
resHeaders
        , Key
"body"   Key -> Maybe Text -> Pair
forall kv v. (KeyValue 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 kv v. (KeyValue 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 kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= 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
.= 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
.= (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
.= RequestBodyLength -> Value
requestBodyLengthToJSON (Request -> RequestBodyLength
requestBodyLength Request
req)
    , Key
"body" Key -> Text -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= 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
.= SockAddr -> Value
sockToJSON (Request -> SockAddr
remoteHost Request
req)
    , Key
"httpVersion" Key -> Value -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= HttpVersion -> Value
httpVersionToJSON (Request -> HttpVersion
httpVersion Request
req)
    , Key
"headers" Key -> Value -> Pair
forall kv v. (KeyValue 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 kv v. (KeyValue 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 kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= PortNumber -> Value
portToJSON PortNumber
pn
    , Key
"hostAddress" Key -> Text -> Pair
forall kv v. (KeyValue 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 kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= PortNumber -> Value
portToJSON PortNumber
pn
    , Key
"hostAddress" Key -> HostAddress6 -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= HostAddress6
ha
    ]
sockToJSON (SockAddrUnix String
sock) =
  [Pair] -> Value
object [ Key
"unix" Key -> String -> Pair
forall kv v. (KeyValue 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 (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