{-# LANGUAGE RecordWildCards #-}
{-# 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 =
  forall msg. ToLogStr msg => msg -> LogStr
toLogStr (forall a. ToJSON a => a -> ByteString
encode forall a b. (a -> b) -> a -> b
$
    [Pair] -> Value
object
      [ Key
"request"  forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= Request -> [ZonedDate] -> Maybe NominalDiffTime -> Value
requestToJSON Request
req [ZonedDate]
reqBody (forall a. a -> Maybe a
Just NominalDiffTime
duration)
      , Key
"response" forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.=
      [Pair] -> Value
object
        [ Key
"status" forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= Status -> Int
statusCode Status
status
        , Key
"size"   forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= Maybe Integer
responseSize
        , Key
"body"   forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.=
          if Status -> Int
statusCode Status
status forall a. Ord a => a -> a -> Bool
>= Int
400
            then forall a. a -> Maybe a
Just forall b c a. (b -> c) -> (a -> b) -> a -> c
. OnDecodeError -> ZonedDate -> Text
decodeUtf8With OnDecodeError
lenientDecode forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> ZonedDate
toStrict forall b c a. (b -> c) -> (a -> b) -> a -> c
. Builder -> ByteString
BB.toLazyByteString forall a b. (a -> b) -> a -> b
$ Builder
response
            else forall a. Maybe a
Nothing
        ]
      , Key
"time"     forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= OnDecodeError -> ZonedDate -> Text
decodeUtf8With OnDecodeError
lenientDecode ZonedDate
date
      ]) 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 =
  forall msg. ToLogStr msg => msg -> LogStr
toLogStr (forall a. ToJSON a => a -> ByteString
encode forall a b. (a -> b) -> a -> b
$
    [Pair] -> Value
object
      [ Key
"request"  forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= Request -> [ZonedDate] -> Maybe NominalDiffTime -> Value
requestToJSON Request
req [ZonedDate]
reqBody (forall a. a -> Maybe a
Just NominalDiffTime
duration)
      , Key
"response" forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= [Pair] -> Value
object
        [ Key
"status" forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= Status -> Int
statusCode Status
status
        , Key
"size"   forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= Maybe Integer
resSize
        , Key
"headers" forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= [Header] -> Value
responseHeadersToJSON [Header]
resHeaders
        , Key
"body"   forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.=
          if Status -> Int
statusCode Status
status forall a. Ord a => a -> a -> Bool
>= Int
400
            then forall a. a -> Maybe a
Just forall b c a. (b -> c) -> (a -> b) -> a -> c
. OnDecodeError -> ZonedDate -> Text
decodeUtf8With OnDecodeError
lenientDecode forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> ZonedDate
toStrict forall b c a. (b -> c) -> (a -> b) -> a -> c
. Builder -> ByteString
BB.toLazyByteString forall a b. (a -> b) -> a -> b
$ Builder
res
            else forall a. Maybe a
Nothing
        ]
      , Key
"time"     forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= OnDecodeError -> ZonedDate -> Text
decodeUtf8With OnDecodeError
lenientDecode ZonedDate
date
      ]) forall a. Semigroup a => a -> a -> a
<> LogStr
"\n"

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

readAsDouble :: String -> Double
readAsDouble :: String -> Double
readAsDouble = 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 forall a b. (a -> b) -> a -> b
$
    [ Key
"method" forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= OnDecodeError -> ZonedDate -> Text
decodeUtf8With OnDecodeError
lenientDecode (Request -> ZonedDate
requestMethod Request
req)
    , Key
"path" forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= OnDecodeError -> ZonedDate -> Text
decodeUtf8With OnDecodeError
lenientDecode (Request -> ZonedDate
rawPathInfo Request
req)
    , Key
"queryString" forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= forall a b. (a -> b) -> [a] -> [b]
map QueryItem -> Value
queryItemToJSON (Request -> Query
queryString Request
req)
    , Key
"size" forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= RequestBodyLength -> Value
requestBodyLengthToJSON (Request -> RequestBodyLength
requestBodyLength Request
req)
    , Key
"body" forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= OnDecodeError -> ZonedDate -> Text
decodeUtf8With OnDecodeError
lenientDecode ([ZonedDate] -> ZonedDate
S8.concat [ZonedDate]
reqBody)
    , Key
"remoteHost" forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= SockAddr -> Value
sockToJSON (Request -> SockAddr
remoteHost Request
req)
    , Key
"httpVersion" forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= HttpVersion -> Value
httpVersionToJSON (Request -> HttpVersion
httpVersion Request
req)
    , Key
"headers" forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= [Header] -> Value
requestHeadersToJSON (Request -> [Header]
requestHeaders Request
req)
    ]
    forall a. Semigroup a => a -> a -> a
<>
    forall a. Maybe a -> [a]
maybeToList ((Key
"durationMs" forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.=) forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Double
readAsDouble forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall r. PrintfType r => String -> r
printf String
"%.2f" forall b c a. (b -> c) -> (a -> b) -> a -> c
. Rational -> Double
rationalToDouble forall b c a. (b -> c) -> (a -> b) -> a -> c
. (forall a. Num a => a -> a -> a
* Rational
1000) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Real a => a -> Rational
toRational forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe NominalDiffTime
duration)
  where
    rationalToDouble :: Rational -> Double
    rationalToDouble :: Rational -> Double
rationalToDouble = forall a. Fractional a => Rational -> a
fromRational

sockToJSON :: SockAddr -> Value
sockToJSON :: SockAddr -> Value
sockToJSON (SockAddrInet PortNumber
pn Word32
ha) =
  [Pair] -> Value
object
    [ Key
"port" forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= PortNumber -> Value
portToJSON PortNumber
pn
    , Key
"hostAddress" 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" forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= PortNumber -> Value
portToJSON PortNumber
pn
    , Key
"hostAddress" forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= HostAddress6
ha
    ]
sockToJSON (SockAddrUnix String
sock) =
  [Pair] -> Value
object [ Key
"unix" 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) = forall a. ToJSON a => a -> Value
toJSON (OnDecodeError -> ZonedDate -> Text
decodeUtf8With OnDecodeError
lenientDecode ZonedDate
name, 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 = forall a. ToJSON a => a -> Value
toJSON forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a -> b) -> [a] -> [b]
map Header -> Value
hToJ where
  -- Redact cookies
  hToJ :: Header -> Value
hToJ (HeaderName
"Cookie", ZonedDate
_) = 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 = forall a. ToJSON a => a -> Value
toJSON forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a -> b) -> [a] -> [b]
map Header -> Value
hToJ where
  -- Redact cookies
  hToJ :: Header -> Value
hToJ (HeaderName
"Set-Cookie", ZonedDate
_) = 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) = forall a. ToJSON a => a -> Value
toJSON (OnDecodeError -> ZonedDate -> Text
decodeUtf8With OnDecodeError
lenientDecode forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall s. CI s -> s
original forall a b. (a -> b) -> a -> b
$ HeaderName
headerName, OnDecodeError -> ZonedDate -> Text
decodeUtf8With OnDecodeError
lenientDecode ZonedDate
header)

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

httpVersionToJSON :: HttpVersion -> Value
httpVersionToJSON :: HttpVersion -> Value
httpVersionToJSON (HttpVersion Int
major Int
minor) = Text -> Value
String forall a b. (a -> b) -> a -> b
$ String -> Text
T.pack (forall a. Show a => a -> String
show Int
major) forall a. Semigroup a => a -> a -> a
<> Text
"." forall a. Semigroup a => a -> a -> a
<> String -> Text
T.pack (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) = forall a. ToJSON a => a -> Value
toJSON Word64
l