{-# LANGUAGE OverloadedStrings #-}

module OpenTelemetry.Network.Wai.Middleware where

import qualified Data.ByteString.Char8 as BS8
import Network.HTTP.Types
import Network.Wai
import OpenTelemetry.Eventlog
import OpenTelemetry.Propagation

-- Semantic conventions for HTTP spans:
-- https://github.com/open-telemetry/opentelemetry-specification/blob/master/specification/trace/semantic_conventions/http.md

mkMiddleware :: IO (Application -> Application)
mkMiddleware :: IO (Application -> Application)
mkMiddleware = do
  Counter
requestCounter <- InstrumentName -> IO Counter
forall (m :: * -> *). MonadIO m => InstrumentName -> m Counter
mkCounter InstrumentName
"requests"
  (Application -> Application) -> IO (Application -> Application)
forall (m :: * -> *) a. Monad m => a -> m a
return ((Application -> Application) -> IO (Application -> Application))
-> (Application -> Application) -> IO (Application -> Application)
forall a b. (a -> b) -> a -> b
$ \Application
app Request
req Response -> IO ResponseReceived
sendResp -> do
    InstrumentName
-> (SpanInFlight -> IO ResponseReceived) -> IO ResponseReceived
forall (m :: * -> *) a.
(MonadIO m, MonadMask m) =>
InstrumentName -> (SpanInFlight -> m a) -> m a
withSpan InstrumentName
"WAI handler" ((SpanInFlight -> IO ResponseReceived) -> IO ResponseReceived)
-> (SpanInFlight -> IO ResponseReceived) -> IO ResponseReceived
forall a b. (a -> b) -> a -> b
$ \SpanInFlight
sp -> do
      Counter -> Int -> IO ()
forall (m :: * -> *) (m' :: Monotonicity).
MonadIO m =>
Instrument 'Synchronous 'Additive m' -> Int -> m ()
add Counter
requestCounter Int
1
      case PropagationFormat
-> [(HeaderName, InstrumentName)] -> Maybe SpanContext
PropagationFormat
-> forall key.
   (Semigroup key, IsString key, Eq key) =>
   [(key, InstrumentName)] -> Maybe SpanContext
propagateFromHeaders PropagationFormat
w3cTraceContext (Request -> [(HeaderName, InstrumentName)]
requestHeaders Request
req) of
        Just SpanContext
ctx -> SpanInFlight -> SpanContext -> IO ()
forall (m :: * -> *).
MonadIO m =>
SpanInFlight -> SpanContext -> m ()
setParentSpanContext SpanInFlight
sp SpanContext
ctx
        Maybe SpanContext
_ -> () -> IO ()
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
      SpanInFlight -> InstrumentName -> InstrumentName -> IO ()
forall (m :: * -> *).
MonadIO m =>
SpanInFlight -> InstrumentName -> InstrumentName -> m ()
setTag SpanInFlight
sp InstrumentName
"span.kind" InstrumentName
"server"
      SpanInFlight -> InstrumentName -> InstrumentName -> IO ()
forall (m :: * -> *).
MonadIO m =>
SpanInFlight -> InstrumentName -> InstrumentName -> m ()
setTag SpanInFlight
sp InstrumentName
"component" InstrumentName
"http"
      SpanInFlight -> InstrumentName -> InstrumentName -> IO ()
forall (m :: * -> *).
MonadIO m =>
SpanInFlight -> InstrumentName -> InstrumentName -> m ()
setTag SpanInFlight
sp InstrumentName
"http.method" (InstrumentName -> IO ()) -> InstrumentName -> IO ()
forall a b. (a -> b) -> a -> b
$ Request -> InstrumentName
requestMethod Request
req
      SpanInFlight -> InstrumentName -> InstrumentName -> IO ()
forall (m :: * -> *).
MonadIO m =>
SpanInFlight -> InstrumentName -> InstrumentName -> m ()
setTag SpanInFlight
sp InstrumentName
"http.target" (InstrumentName -> IO ()) -> InstrumentName -> IO ()
forall a b. (a -> b) -> a -> b
$ Request -> InstrumentName
rawPathInfo Request
req
      SpanInFlight -> InstrumentName -> InstrumentName -> IO ()
forall (m :: * -> *).
MonadIO m =>
SpanInFlight -> InstrumentName -> InstrumentName -> m ()
setTag SpanInFlight
sp InstrumentName
"http.flavor" (InstrumentName -> IO ()) -> InstrumentName -> IO ()
forall a b. (a -> b) -> a -> b
$ String -> InstrumentName
BS8.pack (String -> InstrumentName) -> String -> InstrumentName
forall a b. (a -> b) -> a -> b
$ HttpVersion -> String
forall a. Show a => a -> String
show (Request -> HttpVersion
httpVersion Request
req)
      Application
app Request
req ((Response -> IO ResponseReceived) -> IO ResponseReceived)
-> (Response -> IO ResponseReceived) -> IO ResponseReceived
forall a b. (a -> b) -> a -> b
$ \Response
resp -> do
        SpanInFlight -> InstrumentName -> InstrumentName -> IO ()
forall (m :: * -> *).
MonadIO m =>
SpanInFlight -> InstrumentName -> InstrumentName -> m ()
setTag SpanInFlight
sp InstrumentName
"http.status_code" (String -> InstrumentName
BS8.pack (String -> InstrumentName) -> String -> InstrumentName
forall a b. (a -> b) -> a -> b
$ Int -> String
forall a. Show a => a -> String
show (Int -> String) -> Int -> String
forall a b. (a -> b) -> a -> b
$ Status -> Int
statusCode (Status -> Int) -> Status -> Int
forall a b. (a -> b) -> a -> b
$ Response -> Status
responseStatus Response
resp)
        Response -> IO ResponseReceived
sendResp Response
resp