{-# LANGUAGE BlockArguments #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE RecordWildCards #-}

-- |
-- Description : Instrument wai with eventuo11y
-- Copyright   : Copyright 2022 Shea Levy.
-- License     : Apache-2.0
-- Maintainer  : shea@shealevy.com
module Observe.Event.Wai
  ( -- * Application
    application,

    -- ** Instrumentation
    ServeRequest (..),
    renderServeRequest,
    RequestField (..),
    renderRequestField,

    -- * setOnException
    onExceptionCallback,

    -- ** Instrumentation
    OnException (..),
    renderOnException,
    OnExceptionField (..),
    renderOnExceptionField,

    -- * Miscellaneous instrumentation
    renderRequest,
  )
where

import Control.Exception
import Data.Aeson
import Data.CaseInsensitive
import Data.Text.Encoding
import Network.HTTP.Types.Status
import Network.HTTP.Types.Version
import Network.Socket
import Network.Wai
import Network.Wai.Handler.Warp
import Network.Wai.Internal
import Observe.Event
import Observe.Event.Render.JSON

-- | Run an 'Application' with generic 'Request'/'Response' instrumentation.
application ::
  EventBackend IO r ServeRequest ->
  -- | The application, called with a reference to the parent event.
  (r -> Application) ->
  Application
application :: forall r.
EventBackend IO r ServeRequest -> (r -> Application) -> Application
application EventBackend IO r ServeRequest
backend r -> Application
app Request
req Response -> IO ResponseReceived
respond = forall (m :: * -> *) r (s :: * -> *) a.
MonadMask m =>
EventBackend m r s
-> forall f. s f -> (Event m r s f -> m a) -> m a
withEvent EventBackend IO r ServeRequest
backend ServeRequest RequestField
ServeRequest \Event IO r ServeRequest RequestField
ev -> do
  forall (m :: * -> *) r (s :: * -> *) f. Event m r s f -> f -> m ()
addField Event IO r ServeRequest RequestField
ev forall a b. (a -> b) -> a -> b
$ Request -> RequestField
ReqField Request
req
  r -> Application
app (forall (m :: * -> *) r (s :: * -> *) f. Event m r s f -> r
reference Event IO r ServeRequest RequestField
ev) Request
req \Response
res -> do
    forall (m :: * -> *) r (s :: * -> *) f. Event m r s f -> f -> m ()
addField Event IO r ServeRequest RequestField
ev forall a b. (a -> b) -> a -> b
$ Response -> RequestField
ResField Response
res
    Response -> IO ResponseReceived
respond Response
res

-- | Event selector for 'application'.
data ServeRequest f where
  ServeRequest :: ServeRequest RequestField

-- | Render a 'ServeRequest', and any 'Event's selected by it, to JSON
renderServeRequest :: RenderSelectorJSON ServeRequest
renderServeRequest :: RenderSelectorJSON ServeRequest
renderServeRequest ServeRequest f
ServeRequest = (Key
"serve-request", RenderFieldJSON RequestField
renderRequestField)

-- | A field for v'ServeRequest' 'Event's.
data RequestField
  = ReqField Request
  | ResField Response

-- | Render a 'RequestField' to JSON
renderRequestField :: RenderFieldJSON RequestField
renderRequestField :: RenderFieldJSON RequestField
renderRequestField (ReqField Request
req) =
  ( Key
"request",
    Request -> Value
renderRequest Request
req
  )
renderRequestField (ResField Response
res) = (Key
"response-status" forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= (Status -> Int
statusCode forall a b. (a -> b) -> a -> b
$ Response -> Status
responseStatus Response
res))

-- | A 'Network.Wai.Handler.Warp.setOnException' callback which creates an 'Event' rendering
-- 'Exception's.
--
-- Ideally this would have a way to get a parent 'Event' from 'application'. Would be nice to
-- use 'vault', but there doesn't seem to be a way to get at the 'Request' that Warp will pass
-- here.
onExceptionCallback :: EventBackend IO r OnException -> Maybe Request -> SomeException -> IO ()
onExceptionCallback :: forall r.
EventBackend IO r OnException
-> Maybe Request -> SomeException -> IO ()
onExceptionCallback EventBackend IO r OnException
backend Maybe Request
req SomeException
e =
  if SomeException -> Bool
defaultShouldDisplayException SomeException
e
    then forall (m :: * -> *) r (s :: * -> *) a.
MonadMask m =>
EventBackend m r s
-> forall f. s f -> (Event m r s f -> m a) -> m a
withEvent EventBackend IO r OnException
backend OnException OnExceptionField
OnException \Event IO r OnException OnExceptionField
ev -> forall (m :: * -> *) r (s :: * -> *) f. Event m r s f -> f -> m ()
addField Event IO r OnException OnExceptionField
ev forall a b. (a -> b) -> a -> b
$ Maybe Request -> SomeException -> OnExceptionField
OnExceptionField Maybe Request
req SomeException
e
    else forall (f :: * -> *) a. Applicative f => a -> f a
pure ()

-- | Selector for 'Observe.Event.Wai.onException'
data OnException f where
  OnException :: OnException OnExceptionField

-- | Render an 'OnException', and its selected-for 'Event's, as JSON, with a provided base structured exception type.
renderOnException :: (Exception stex) => RenderExJSON stex -> RenderSelectorJSON OnException
renderOnException :: forall stex.
Exception stex =>
RenderExJSON stex -> RenderSelectorJSON OnException
renderOnException RenderExJSON stex
renderEx OnException f
OnException = (Key
"on-exception", forall stex.
Exception stex =>
RenderExJSON stex -> RenderFieldJSON OnExceptionField
renderOnExceptionField RenderExJSON stex
renderEx)

-- | A field for a v'OnException' 'Event'.
data OnExceptionField = OnExceptionField (Maybe Request) SomeException

-- | Render an 'OnExceptionField' as JSON, with a provided base structured exception type.
renderOnExceptionField :: (Exception stex) => RenderExJSON stex -> RenderFieldJSON OnExceptionField
renderOnExceptionField :: forall stex.
Exception stex =>
RenderExJSON stex -> RenderFieldJSON OnExceptionField
renderOnExceptionField RenderExJSON stex
renderEx (OnExceptionField Maybe Request
mreq SomeException
e) =
  ( Key
"uncaught-exception",
    Object -> Value
Object
      ( forall b a. b -> (a -> b) -> Maybe a -> b
maybe forall a. Monoid a => a
mempty ((Key
"request" forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.=) forall b c a. (b -> c) -> (a -> b) -> a -> c
. Request -> Value
renderRequest) Maybe Request
mreq
          forall a. Semigroup a => a -> a -> a
<> forall b a. b -> (a -> b) -> Maybe a -> b
maybe (Key
"unstructured-exception" forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= forall a. Show a => a -> String
show SomeException
e) ((Key
"structured-exception" forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.=) forall b c a. (b -> c) -> (a -> b) -> a -> c
. RenderExJSON stex
renderEx) (forall e. Exception e => SomeException -> Maybe e
fromException SomeException
e)
      )
  )

-- | Render a 'Request' to JSON.
renderRequest :: Request -> Value
renderRequest :: Request -> Value
renderRequest (Request {Bool
Query
RequestHeaders
[Text]
Maybe ByteString
IO ByteString
ByteString
HttpVersion
SockAddr
Vault
RequestBodyLength
requestMethod :: Request -> ByteString
httpVersion :: Request -> HttpVersion
rawPathInfo :: Request -> ByteString
rawQueryString :: Request -> ByteString
requestHeaders :: Request -> RequestHeaders
isSecure :: Request -> Bool
remoteHost :: Request -> SockAddr
pathInfo :: Request -> [Text]
queryString :: Request -> Query
requestBody :: Request -> IO ByteString
vault :: Request -> Vault
requestBodyLength :: Request -> RequestBodyLength
requestHeaderHost :: Request -> Maybe ByteString
requestHeaderRange :: Request -> Maybe ByteString
requestHeaderReferer :: Request -> Maybe ByteString
requestHeaderUserAgent :: Request -> Maybe ByteString
requestHeaderUserAgent :: Maybe ByteString
requestHeaderReferer :: Maybe ByteString
requestHeaderRange :: Maybe ByteString
requestHeaderHost :: Maybe ByteString
requestBodyLength :: RequestBodyLength
vault :: Vault
requestBody :: IO ByteString
queryString :: Query
pathInfo :: [Text]
remoteHost :: SockAddr
isSecure :: Bool
requestHeaders :: RequestHeaders
rawQueryString :: ByteString
rawPathInfo :: ByteString
httpVersion :: HttpVersion
requestMethod :: ByteString
..}) =
  Object -> Value
Object
    ( Key
"remote-addr" forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= Object -> Value
Object case SockAddr
remoteHost of
        SockAddrInet PortNumber
port FlowInfo
addr ->
          ( Key
"port" forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= forall a. Integral a => a -> Integer
toInteger PortNumber
port
              forall a. Semigroup a => a -> a -> a
<> Key
"addr" forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= FlowInfo -> (Word8, Word8, Word8, Word8)
hostAddressToTuple FlowInfo
addr
          )
        SockAddrInet6 PortNumber
port FlowInfo
flow HostAddress6
addr FlowInfo
scope ->
          ( Key
"port" forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= forall a. Integral a => a -> Integer
toInteger PortNumber
port
              forall a. Semigroup a => a -> a -> a
<> Key
"flow" forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= FlowInfo
flow
              forall a. Semigroup a => a -> a -> a
<> Key
"addr" forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= HostAddress6
-> (Word16, Word16, Word16, Word16, Word16, Word16, Word16, Word16)
hostAddress6ToTuple HostAddress6
addr
              forall a. Semigroup a => a -> a -> a
<> Key
"scope" forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= FlowInfo
scope
          )
        SockAddrUnix String
path -> Key
"path" forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= String
path
        forall a. Semigroup a => a -> a -> a
<> Key
"method" forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= ByteString -> Text
decodeUtf8 ByteString
requestMethod
        forall a. Semigroup a => a -> a -> a
<> Key
"http-version" forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= Object -> Value
Object (Key
"major" forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= HttpVersion -> Int
httpMajor HttpVersion
httpVersion forall a. Semigroup a => a -> a -> a
<> Key
"minor" forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= HttpVersion -> Int
httpMinor HttpVersion
httpVersion)
        forall a. Semigroup a => a -> a -> a
<> Key
"path" forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= [Text]
pathInfo
        forall a. Semigroup a => a -> a -> a
<> Key
"query"
          forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap
            ( \(ByteString
k, Maybe ByteString
mv) ->
                Object -> Value
Object
                  ( Key
"param" forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= ByteString -> Text
decodeUtf8 ByteString
k forall a. Semigroup a => a -> a -> a
<> case Maybe ByteString
mv of
                      Just ByteString
v -> Key
"value" forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= ByteString -> Text
decodeUtf8 ByteString
v
                      Maybe ByteString
Nothing -> forall a. Monoid a => a
mempty
                  )
            )
            Query
queryString
        forall a. Semigroup a => a -> a -> a
<> ( case RequestBodyLength
requestBodyLength of
               RequestBodyLength
ChunkedBody -> forall a. Monoid a => a
mempty
               KnownLength Word64
l -> Key
"length" forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= Word64
l
           )
        forall a. Semigroup a => a -> a -> a
<> ( if forall (t :: * -> *) a. Foldable t => t a -> Bool
null RequestHeaders
requestHeaders
               then forall a. Monoid a => a
mempty
               else Key
"headers" forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (\(CI ByteString
nm, ByteString
val) -> Object -> Value
Object (Key
"name" forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= ByteString -> Text
decodeUtf8 (forall s. CI s -> s
original CI ByteString
nm) forall a. Semigroup a => a -> a -> a
<> (if CI ByteString
nm forall a. Eq a => a -> a -> Bool
== CI ByteString
"Authorization" then forall a. Monoid a => a
mempty else Key
"val" forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= ByteString -> Text
decodeUtf8 ByteString
val))) RequestHeaders
requestHeaders
           )
    )