{-# LANGUAGE BlockArguments #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE StandaloneKindSignatures #-}
{-# LANGUAGE TypeInType #-}

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

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

    -- * setOnException
    OnExceptionCallback,
    onExceptionCallback,

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

    -- * Miscellaneous instrumentation
    renderRequest,
  )
where

import Control.Exception
import Control.Monad.IO.Unlift
import Data.Aeson
import Data.CaseInsensitive
import Data.Kind
import Data.Text.Encoding
import Network.HTTP.Types.Status
import Network.HTTP.Types.Version
import Network.Socket
import Network.Wai hiding (Application)
import qualified Network.Wai as W
import Network.Wai.Handler.Warp
import Network.Wai.Internal
import Observe.Event
import Observe.Event.Class
import Observe.Event.Render.JSON

-- | An instrumented 'W.Application'
type Application :: EventMonadKind -> ReferenceKind -> SelectorKind -> Type
type Application em r s = Request -> (Response -> em r s ResponseReceived) -> em r s ResponseReceived

-- | Run an 'Application' with generic 'Request'/'Response' instrumentation.
application ::
  (MonadUnliftIO (em r s), MonadWithEvent em r s) =>
  InjectSelector ServeRequest s ->
  Application em r s ->
  em r s W.Application
application :: forall (em :: * -> SelectorKind -> SelectorKind) r
       (s :: SelectorKind).
(MonadUnliftIO (em r s), MonadWithEvent em r s) =>
InjectSelector ServeRequest s
-> Application em r s -> em r s Application
application InjectSelector ServeRequest s
inj Application em r s
app = forall (m :: SelectorKind) b.
MonadUnliftIO m =>
((forall a. m a -> IO a) -> IO b) -> m b
withRunInIO \forall a. em r s a -> IO a
runInIO -> forall (f :: SelectorKind) a. Applicative f => a -> f a
pure \Request
req Response -> IO ResponseReceived
respond -> forall a. em r s a -> IO a
runInIO forall a b. (a -> b) -> a -> b
$
  InjectSelector ServeRequest s
inj ServeRequest RequestField
ServeRequest \s g
serveReq RequestField -> g
injField -> forall (em :: * -> SelectorKind -> SelectorKind) r
       (s :: SelectorKind) a f.
MonadWithEvent em r s =>
s f -> (EnvEvent em r s f -> em r s a) -> em r s a
withEvent s g
serveReq \EnvEvent em r s g
ev -> do
    forall (m :: SelectorKind) r f. Event m r f -> f -> m ()
addField EnvEvent em r s g
ev forall b c a. (b -> c) -> (a -> b) -> a -> c
. RequestField -> g
injField forall a b. (a -> b) -> a -> b
$ Request -> RequestField
ReqField Request
req
    Application em r s
app Request
req \Response
res -> do
      forall (m :: SelectorKind) r f. Event m r f -> f -> m ()
addField EnvEvent em r s g
ev forall b c a. (b -> c) -> (a -> b) -> a -> c
. RequestField -> g
injField forall a b. (a -> b) -> a -> b
$ Response -> RequestField
ResField Response
res
      forall (m :: SelectorKind) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ 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))

-- | An instrumented 'Network.Wai.Handler.Warp.setOnException' callback.
type OnExceptionCallback :: EventMonadKind -> ReferenceKind -> SelectorKind -> Type
type OnExceptionCallback em r s = Maybe Request -> SomeException -> em r s ()

-- | Convert an 'OnExceptionCallback' to a 'Network.Wai.Handler.Warp.setOnException' callback.
--
-- The 'OnExceptionCallback' is called as the child of an 'Event' rendering the exception, if
-- it's one that should be displayed according to 'defaultShouldDisplayException'.
--
-- 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 ::
  (MonadUnliftIO (em r s), MonadWithEvent em r s) =>
  InjectSelector OnException s ->
  OnExceptionCallback em r s ->
  em r s (Maybe Request -> SomeException -> IO ())
onExceptionCallback :: forall (em :: * -> SelectorKind -> SelectorKind) r
       (s :: SelectorKind).
(MonadUnliftIO (em r s), MonadWithEvent em r s) =>
InjectSelector OnException s
-> OnExceptionCallback em r s
-> em r s (Maybe Request -> SomeException -> IO ())
onExceptionCallback InjectSelector OnException s
inj OnExceptionCallback em r s
cb = forall (m :: SelectorKind) b.
MonadUnliftIO m =>
((forall a. m a -> IO a) -> IO b) -> m b
withRunInIO \forall a. em r s a -> IO a
runInIO -> forall (f :: SelectorKind) a. Applicative f => a -> f a
pure \Maybe Request
req SomeException
e -> forall a. em r s a -> IO a
runInIO forall a b. (a -> b) -> a -> b
$
  case SomeException -> Bool
defaultShouldDisplayException SomeException
e of
    Bool
True -> InjectSelector OnException s
inj OnException OnExceptionField
OnException \s g
onEx OnExceptionField -> g
injField -> forall (em :: * -> SelectorKind -> SelectorKind) r
       (s :: SelectorKind) a f.
MonadWithEvent em r s =>
s f -> (EnvEvent em r s f -> em r s a) -> em r s a
withEvent s g
onEx \EnvEvent em r s g
ev -> do
      forall (m :: SelectorKind) r f. Event m r f -> f -> m ()
addField EnvEvent em r s g
ev forall b c a. (b -> c) -> (a -> b) -> a -> c
. OnExceptionField -> g
injField forall a b. (a -> b) -> a -> b
$ Maybe Request -> SomeException -> OnExceptionField
OnExceptionField Maybe Request
req SomeException
e
      OnExceptionCallback em r s
cb Maybe Request
req SomeException
e
    Bool
False -> OnExceptionCallback em r s
cb Maybe Request
req SomeException
e

-- | 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 :: SelectorKind) 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 :: SelectorKind) 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 :: SelectorKind) 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
           )
    )