{-# OPTIONS_GHC -Wno-orphans #-}
{-# LANGUAGE CPP #-}
{-# LANGUAGE OverloadedStrings #-}

{-|
Module      : Yesod.Katip.Orphans
Description : Orphan instances for logging HTTP structures in Katip contexts
Copyright   : (c) Isaac van Bakel, 2020
License     : BSD3
Maintainer  : ivb@vanbakel.io
Stability   : experimental
Portability : POSIX

If you configure your Yesod site to log HTTP structures to Yesod, you will need
instances of 'ToObject' and 'LogItem' for the structures you want to log.

By default, @KatipContextSite@ will add the WAI request to the context - which
is why its @Yesod@ instance requires those classes on the 'Request' type. This
module contains simple implementations for those classes on 'Request', to help
set up a quick and easy use of @KatipContextSite@.
-}

module Yesod.Katip.Orphans () where

import Data.Aeson
import Katip (LogItem (..), PayloadSelection (..), ToObject (..), Verbosity (..))
import Network.Wai

#if MIN_VERSION_wai_extra(3, 1, 4)
import Network.Wai.Middleware.RequestLogger.JSON (requestToJSON)
#else
-- Because the exposure of this particular API in Wai is relatively recent
-- (December 2020), this polyfills the implementation
import Data.CaseInsensitive (original)
import Data.IP (fromHostAddress, fromIPv4)
import qualified Data.Text as T
import Data.Text.Encoding (decodeUtf8With)
import Data.Text.Encoding.Error (lenientDecode)
import Network.HTTP.Types
import Network.Socket (SockAddr (..))

requestToJSON :: Request -> [String] -> Maybe () -> Value
requestToJSON req body _duration
  = object
      [ "method" .= decodeUtf8With lenientDecode (requestMethod req)
      , "path" .= decodeUtf8With lenientDecode (rawPathInfo req)
      , "queryString" .= map queryItemToJSON (queryString req)
      , "size" .= requestBodyLengthToJSON (requestBodyLength req)
      , "body" .= concat body
      , "remoteHost" .= sockToJSON (remoteHost req)
      , "httpVersion" .= httpVersionToJSON (httpVersion req)
      , "headers" .= requestHeadersToJSON (requestHeaders req)
      ]
  where
    requestHeadersToJSON = toJSON . map hToJ where
      -- Redact cookies
      hToJ ("Cookie", _) = toJSON ("Cookie" :: T.Text, "-RDCT-" :: T.Text)
      hToJ hd = headerToJSON hd

    queryItemToJSON (name, mValue) = toJSON (decodeUtf8With lenientDecode name, fmap (decodeUtf8With lenientDecode) mValue)

    requestBodyLengthToJSON ChunkedBody = String "Unknown"
    requestBodyLengthToJSON (KnownLength l) = toJSON l

    sockToJSON (SockAddrInet pn ha) =
      object
        [ "port" .= portToJSON pn
        , "hostAddress" .= word32ToHostAddress ha
        ]
    sockToJSON (SockAddrInet6 pn _ ha _) =
      object
        [ "port" .= portToJSON pn
        , "hostAddress" .= ha
        ]
    sockToJSON (SockAddrUnix sock) =
      object [ "unix" .= sock ]
#if !MIN_VERSION_network(3, 0, 0)
    sockToJSON (SockAddrCan i) =
      object [ "can" .= i ]
#endif

    headerToJSON (headerName, header) = toJSON (decodeUtf8With lenientDecode . original $ headerName, decodeUtf8With lenientDecode header)

    word32ToHostAddress = T.intercalate "." . map (T.pack . show) . fromIPv4 . fromHostAddress

    portToJSON = toJSON . toInteger

    httpVersionToJSON (HttpVersion major minor) = String $ T.pack (show major) <> "." <> T.pack (show minor)
#endif

instance ToObject Request where
  toObject :: Request -> Object
toObject Request
req
    = case Request -> [ByteString] -> Maybe NominalDiffTime -> Value
requestToJSON Request
req [ByteString
"<omitted by default>"] Maybe NominalDiffTime
forall a. Maybe a
Nothing of
        Object Object
obj -> Object
obj
        Value
_ -> [Char] -> Object
forall a. HasCallStack => [Char] -> a
error [Char]
"`requestToJSON` produced a JSON representation for `Request` that wasn't an object!"

instance LogItem Request where
  payloadKeys :: Verbosity -> Request -> PayloadSelection
payloadKeys Verbosity
verbosity Request
_req = case Verbosity
verbosity of
    Verbosity
V0 -> [Text] -> PayloadSelection
SomeKeys [Text
"method", Text
"path", Text
"queryString", Text
"remotehost"]
    Verbosity
V1 -> [Text] -> PayloadSelection
SomeKeys [Text
"size", Text
"body"]
    Verbosity
V2 -> [Text] -> PayloadSelection
SomeKeys [Text
"headers", Text
"httpVersion"]
    Verbosity
V3 -> PayloadSelection
AllKeys