OpenTelemetry.hs

{-# LANGUAGE Trustworthy #-}

-- |
-- Module      : Effectful.Wai.OpenTelemetry
-- Copyright   : (c) 2026 Institute for Digital Autonomy
-- License     : EUPL-1.2
-- Maintainer  : IDA
--
-- This library provides <https://opentelemetry.io/ OpenTelemetry> instrumentation for
-- @<http://hackage.haskell.org/package/wai-effectful wai-effectful>@ 'Application's.
--
-- > import Effectful
-- > import Effectful.Wai.Handler.Warp qualified as Warp
-- > import Effectful.Wai.OpenTelemetry qualified as OpenTelemetry
-- > import Effectful.OpenTelemetry.Tracing (runTracing)
-- >
-- > main :: IO ()
-- > main = runEff . runTracing . Warp.run 8080 $ OpenTelemetry.middleware app
module Effectful.Wai.OpenTelemetry where

import Data.Aeson (toJSON)
import Data.Text (Text)
import Data.Text qualified as Text
import Data.Text.Encoding qualified as Text
import Effectful
import Effectful.OpenTelemetry.Protocol.Attributes (Attributes)
import Effectful.OpenTelemetry.Protocol.Attributes qualified as Attributes
import Effectful.OpenTelemetry.Tracing (Tracing, currentContext, inSpan, withContext)
import Effectful.OpenTelemetry.Tracing.Propagator
import Effectful.OpenTelemetry.Tracing.Propagator qualified as Propagator
import Effectful.OpenTelemetry.Tracing.Span.Kind qualified as Kind
import Effectful.Wai
    ( Middleware
    , Request (remoteHost)
    , httpVersion
    , isSecure
    , mapResponseHeaders
    , rawPathInfo
    , rawQueryString
    , requestHeaders
    , requestMethod
    , responseHeaders
    )
import Network.HTTP.Types (HttpVersion (..))
import Network.Socket (SockAddr (..))
import Prelude

-- | Instrument an 'Application' using the 'Propagator.w3cTraceContext' propagator.
--
-- For every request:
--
--   1. extract the incoming tracing 'Context' from the request headers,
--   2. run the wrapped application inside a 'Kind.Server' span whose name is
--      derived from the request and tagged with HTTP semantic-convention
--      attributes, and
--   3. inject the current context into the response headers, if the caller
--      took part in the trace.
middleware :: (Tracing :> es) => Middleware es
middleware app request respond =
    currentContext >>= Propagator.w3cTraceContext.extract (requestHeaders request) >>= \context ->
        maybe id withContext context
            . inSpan name Kind.Server attrs
            . app request
            $ case context of
                Nothing -> respond
                Just _ -> \response -> do
                    curr <- currentContext
                    headers <- Propagator.w3cTraceContext.inject curr . responseHeaders $ response
                    respond . mapResponseHeaders (const headers) $ response
  where
    name = Text.unwords $ Text.decodeUtf8Lenient . ($ request) <$> [requestMethod, rawPathInfo]
    attrs :: Attributes
    attrs =
        Attributes.fromList . mconcat $
            [
                [ ("http.request.method", encodeByteString . requestMethod $ request)
                , ("url.path", encodeByteString . rawPathInfo $ request)
                , ("url.scheme", toJSON @Text if isSecure request then "https" else "http")
                , ("net.transport", "ip_tcp")
                , ("network.protocol.version", toJSON . httpVersionText . httpVersion $ request)
                ]
            , case remoteHost request of
                SockAddrInet port host ->
                    [ ("server.port", toJSON @Int . fromIntegral $ port)
                    , ("server.address", toJSON host)
                    ]
                SockAddrInet6 port _ host _ ->
                    [ ("server.port", toJSON @Int . fromIntegral $ port)
                    , ("server.address", toJSON host)
                    ]
                SockAddrUnix path -> [("server.address", toJSON path)]
            , [ ("url.query", encodeByteString query)
              | let query = rawQueryString request
              , query /= "" && query /= "?"
              ]
            , [ ("user_agent.original", encodeByteString ua)
              | Just ua <- [lookup "User-Agent" . requestHeaders $ request]
              ]
            ]
      where
        encodeByteString = toJSON . Text.decodeUtf8Lenient
        httpVersionText (HttpVersion major minor) =
            Text.pack (show major) <> "." <> Text.pack (show minor)