{-# LANGUAGE OverloadedStrings #-}

-- |Contains functions to log WAI request in JSON format
module Chakra.RequestLogging
  (jsonRequestLogger)
where

import           Data.Aeson                           as X (KeyValue ((.=)),
                                                            ToJSON (toJSON),
                                                            Value (String),
                                                            encode, object)
import qualified Data.ByteString.Builder              as BB (toLazyByteString)
import qualified Data.ByteString.Char8                as S8
import           Data.ByteString.Lazy                 (toStrict)
import           Data.Default                         (Default (def))
import           Data.IP                              (fromHostAddress,
                                                       fromIPv4)
import qualified Data.Text                            as T
import           Data.Text.Encoding                   (decodeUtf8With)
import           Data.Text.Encoding.Error             (lenientDecode)
import           Data.Time                            (NominalDiffTime)
import           Network.HTTP.Types                   as H (HttpVersion (HttpVersion),
                                                            QueryItem,
                                                            Status (statusCode))
import           Network.Socket                       (PortNumber,
                                                       SockAddr (..))
import           Network.Wai
import           Network.Wai.Middleware.RequestLogger (OutputFormat (..), OutputFormatterWithDetails,
                                                       mkRequestLogger,
                                                       outputFormat)
import           RIO                                  (Text, Word32,
                                                       maybeToList)
import           System.Log.FastLogger                (toLogStr)
import           Text.Printf                          (printf)

-- | JSON formatted request log middleware for WAI applications
-- | it logs the given appName and appVer values
jsonRequestLogger :: Text -> Text -> IO Middleware
jsonRequestLogger :: Text -> Text -> IO Middleware
jsonRequestLogger Text
envName Text
appVer =
  RequestLoggerSettings -> IO Middleware
mkRequestLogger (RequestLoggerSettings -> IO Middleware)
-> RequestLoggerSettings -> IO Middleware
forall a b. (a -> b) -> a -> b
$
  RequestLoggerSettings
forall a. Default a => a
def {outputFormat :: OutputFormat
outputFormat = OutputFormatterWithDetails -> OutputFormat
CustomOutputFormatWithDetails (Text -> Text -> OutputFormatterWithDetails
formatAsJSONCustom Text
envName Text
appVer)}

formatAsJSONCustom :: Text -> Text -> OutputFormatterWithDetails
formatAsJSONCustom :: Text -> Text -> OutputFormatterWithDetails
formatAsJSONCustom Text
envName Text
appVer 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
       [ Text
"env" Text -> Text -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Text -> v -> kv
.= Text
envName
       , Text
"appVersion" Text -> Text -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Text -> v -> kv
.= Text
appVer
       , Text
"request" Text -> Value -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Text -> v -> kv
.= Request -> [ZonedDate] -> Maybe NominalDiffTime -> Value
requestToJSON Request
req [ZonedDate]
reqBody (NominalDiffTime -> Maybe NominalDiffTime
forall a. a -> Maybe a
Just NominalDiffTime
duration)
       , Text
"response" Text -> Value -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Text -> v -> kv
.=
         [Pair] -> Value
object
           [ Text
"status" Text -> Int -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Text -> v -> kv
.= Status -> Int
statusCode Status
status
           , Text
"size" Text -> Maybe Integer -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Text -> v -> kv
.= Maybe Integer
responseSize
           , Text
"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
>= 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
           ]
       , Text
"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
<>
  LogStr
"\n"

requestToJSON :: Request -> [S8.ByteString] -> Maybe NominalDiffTime -> 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
$
  [ Text
"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)
  , Text
"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)
  , Text
"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)
  , Text
"size" Text -> Value -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Text -> v -> kv
.= RequestBodyLength -> Value
requestBodyLengthToJSON (Request -> RequestBodyLength
requestBodyLength Request
req)
  , Text
"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)
  , Text
"remoteHost" Text -> Value -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Text -> v -> kv
.= SockAddr -> Value
sockToJSON (Request -> SockAddr
remoteHost Request
req)
  , Text
"httpVersion" Text -> Value -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Text -> v -> kv
.= HttpVersion -> Value
httpVersionToJSON (Request -> HttpVersion
httpVersion Request
req)
      -- , "headers" .= requestHeadersToJSON (requestHeaders req)
  ] [Pair] -> [Pair] -> [Pair]
forall a. Semigroup a => a -> a -> a
<>
  Maybe Pair -> [Pair]
forall a. Maybe a -> [a]
maybeToList
    ((Text
"durationMs" Text -> Double -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Text -> 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

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

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)

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

sockToJSON :: SockAddr -> Value
sockToJSON :: SockAddr -> Value
sockToJSON (SockAddrInet PortNumber
pn Word32
ha) =
  [Pair] -> Value
object [Text
"port" Text -> Value -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Text -> v -> kv
.= PortNumber -> Value
portToJSON PortNumber
pn, Text
"hostAddress" Text -> Text -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Text -> v -> kv
.= Word32 -> Text
word32ToHostAddress Word32
ha]
sockToJSON (SockAddrInet6 PortNumber
pn Word32
_ HostAddress6
ha Word32
_) =
  [Pair] -> Value
object [Text
"port" Text -> Value -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Text -> v -> kv
.= PortNumber -> Value
portToJSON PortNumber
pn, Text
"hostAddress" Text -> HostAddress6 -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Text -> v -> kv
.= HostAddress6
ha]
sockToJSON (SockAddrUnix String
sock) =
  [Pair] -> Value
object [Text
"unix" Text -> String -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Text -> v -> kv
.= String
sock]

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