content: {-# LANGUAGE LambdaCase #-}
  {-# LANGUAGE OverloadedLists #-}
  {-# LANGUAGE OverloadedStrings #-}
  {-# LANGUAGE TemplateHaskell #-}
  
  {- |
  [New HTTP semantic conventions have been declared stable.](https://opentelemetry.io/blog/2023/http-conventions-declared-stable/#migration-plan) Opt-in by setting the environment variable OTEL_SEMCONV_STABILITY_OPT_IN to
  - "http" - to use the stable conventions
  - "http/dup" - to emit both the old and the stable conventions
  Otherwise, the old conventions will be used. The stable conventions will replace the old conventions in the next major release of this library.
  -}
  module OpenTelemetry.Instrumentation.Wai (
    newOpenTelemetryWaiMiddleware,
    newOpenTelemetryWaiMiddleware',
    requestContext,
  ) where
  
  import Control.Exception (bracket)
  import Control.Monad
  import qualified Data.HashMap.Strict as H
  import Data.IP (fromHostAddress, fromHostAddress6)
  import qualified Data.Text as T
  import qualified Data.Text.Encoding as T
  import qualified Data.Vault.Lazy as Vault
  import GHC.Stack (HasCallStack)
  import Network.HTTP.Types
  import Network.Socket
  import Network.Wai
  import OpenTelemetry.Attributes (lookupAttribute)
  import qualified OpenTelemetry.Context as Context
  import OpenTelemetry.Context.ThreadLocal
  import OpenTelemetry.Propagator
  import OpenTelemetry.SemanticsConfig
  import OpenTelemetry.Trace.Core
  import System.IO.Unsafe
  
  
  newOpenTelemetryWaiMiddleware :: (HasCallStack) => IO Middleware
  newOpenTelemetryWaiMiddleware = newOpenTelemetryWaiMiddleware' <$> getGlobalTracerProvider
  
  
  newOpenTelemetryWaiMiddleware'
    :: (HasCallStack)
    => TracerProvider
    -> Middleware
  newOpenTelemetryWaiMiddleware' tp =
    let waiTracer =
          makeTracer
            tp
            $detectInstrumentationLibrary
            (TracerOptions Nothing)
    in middleware waiTracer
    where
      usefulCallsite = callerAttributes
      middleware :: Tracer -> Middleware
      middleware tracer app req sendResp = do
        let propagator = getTracerProviderPropagators $ getTracerTracerProvider tracer
        let parentContextM = do
              ctx <- getContext
              ctxt <- extract propagator (requestHeaders req) ctx
              attachContext ctxt
        let path_ = T.decodeUtf8 $ rawPathInfo req
        -- peer = remoteHost req
  
        semanticsOptions <- getSemanticsOptions
        let args =
              defaultSpanArguments
                { kind = Server
                , attributes =
                    case httpOption semanticsOptions of
                      Stable ->
                        usefulCallsite
                          `H.union` [
                                      ( "user_agent.original"
                                      , toAttribute $ maybe "" T.decodeUtf8 (lookup hUserAgent $ requestHeaders req)
                                      )
                                    ]
                      StableAndOld ->
                        usefulCallsite
                          `H.union` [
                                      ( "user_agent.original"
                                      , toAttribute $ maybe "" T.decodeUtf8 (lookup hUserAgent $ requestHeaders req)
                                      )
                                    ]
                      Old -> usefulCallsite
                }
        -- The cleanup action in this bracket is used to prevent propagated
        -- context from being inherited by any subsequent requests served by the
        -- same thread. Warp supports HTTP keep-alive/persistent connections,
        -- which means a thread can handle multiple requests before exiting.
        bracket parentContextM (const $ void detachContext) $ \_ -> inSpan'' tracer path_ args $ \requestSpan -> do
          ctxt <- getContext
  
          let addStableAttributes = do
                addAttributes
                  requestSpan
                  [ ("http.request.method", toAttribute $ T.decodeUtf8 $ requestMethod req)
                  , -- , ( "url.full",
                    --     toAttribute $
                    --     T.decodeUtf8
                    --     ((if secure req then "https://" else "http://") <> host req <> ":" <> B.pack (show $ port req) <> path req <> queryString req)
                    --   )
                    ("url.path", toAttribute $ T.decodeUtf8 $ rawPathInfo req)
                  , ("url.query", toAttribute $ T.decodeUtf8 $ rawQueryString req)
                  , -- , ( "http.host", toAttribute $ T.decodeUtf8 $ host req)
                    -- , ( "url.scheme", toAttribute $ TextAttribute $ if secure req then "https" else "http")
  
                    ( "network.protocol.version"
                    , toAttribute $ case httpVersion req of
                        (HttpVersion major minor) ->
                          T.pack $
                            if minor == 0
                              then show major
                              else show major <> "." <> show minor
                    )
                  , -- TODO HTTP/3 will require detecting this dynamically
                    ("net.transport", toAttribute ("ip_tcp" :: T.Text))
                  ]
  
                addAttributes requestSpan $ case remoteHost req of
                  SockAddrInet port addr ->
                    [ ("server.port", toAttribute (fromIntegral port :: Int))
                    , ("server.address", toAttribute $ T.pack $ show $ fromHostAddress addr)
                    ]
                  SockAddrInet6 port _ addr _ ->
                    [ ("server.port", toAttribute (fromIntegral port :: Int))
                    , ("server.address", toAttribute $ T.pack $ show $ fromHostAddress6 addr)
                    ]
                  SockAddrUnix path ->
                    [ ("server.address", toAttribute $ T.pack path)
                    ]
              addOldAttributes = do
                addAttributes
                  requestSpan
                  [ ("http.method", toAttribute $ T.decodeUtf8 $ requestMethod req)
                  , -- , ( "http.url",
                    --     toAttribute $
                    --     T.decodeUtf8
                    --     ((if secure req then "https://" else "http://") <> host req <> ":" <> B.pack (show $ port req) <> path req <> queryString req)
                    --   )
                    ("http.target", toAttribute $ T.decodeUtf8 (rawPathInfo req <> rawQueryString req))
                  , -- , ( "http.host", toAttribute $ T.decodeUtf8 $ host req)
                    -- , ( "http.scheme", toAttribute $ TextAttribute $ if secure req then "https" else "http")
  
                    ( "http.flavor"
                    , toAttribute $ case httpVersion req of
                        (HttpVersion major minor) -> T.pack (show major <> "." <> show minor)
                    )
                  ,
                    ( "http.user_agent"
                    , toAttribute $ maybe "" T.decodeUtf8 (lookup hUserAgent $ requestHeaders req)
                    )
                  , -- TODO HTTP/3 will require detecting this dynamically
                    ("net.transport", toAttribute ("ip_tcp" :: T.Text))
                  ]
  
                -- TODO this is warp dependent, probably.
                -- , ( "net.host.ip")
                -- , ( "net.host.port")
                -- , ( "net.host.name")
                addAttributes requestSpan $ case remoteHost req of
                  SockAddrInet port addr ->
                    [ ("net.peer.port", toAttribute (fromIntegral port :: Int))
                    , ("net.peer.ip", toAttribute $ T.pack $ show $ fromHostAddress addr)
                    ]
                  SockAddrInet6 port _ addr _ ->
                    [ ("net.peer.port", toAttribute (fromIntegral port :: Int))
                    , ("net.peer.ip", toAttribute $ T.pack $ show $ fromHostAddress6 addr)
                    ]
                  SockAddrUnix path ->
                    [ ("net.peer.name", toAttribute $ T.pack path)
                    ]
  
          case httpOption semanticsOptions of
            Stable -> addStableAttributes
            StableAndOld -> addOldAttributes >> addStableAttributes
            Old -> addOldAttributes
  
          let req' =
                req
                  { vault =
                      Vault.insert
                        contextKey
                        ctxt
                        (vault req)
                  }
          app req' $ \resp -> do
            ctxt' <- getContext
            hs <- inject propagator (Context.insertSpan requestSpan ctxt') []
            let resp' = mapResponseHeaders (hs ++) resp
            attrs <- spanGetAttributes requestSpan
            forM_ (lookupAttribute attrs "http.route") $ \case
              AttributeValue (TextAttribute route) -> updateName requestSpan route
              _ -> pure ()
  
            case httpOption semanticsOptions of
              Stable ->
                addAttributes
                  requestSpan
                  [ ("http.response.status_code", toAttribute $ statusCode $ responseStatus resp)
                  ]
              StableAndOld ->
                addAttributes
                  requestSpan
                  [ ("http.response.status_code", toAttribute $ statusCode $ responseStatus resp)
                  , ("http.status_code", toAttribute $ statusCode $ responseStatus resp)
                  ]
              Old ->
                addAttributes
                  requestSpan
                  [ ("http.status_code", toAttribute $ statusCode $ responseStatus resp)
                  ]
            when (statusCode (responseStatus resp) >= 500) $ do
              setStatus requestSpan (Error "")
            respReceived <- sendResp resp'
            ts <- getTimestamp
            endSpan requestSpan (Just ts)
            pure respReceived
  
  
  contextKey :: Vault.Key Context.Context
  contextKey = unsafePerformIO Vault.newKey
  {-# NOINLINE contextKey #-}
  
  
  requestContext :: Request -> Maybe Context.Context
  requestContext =
    Vault.lookup contextKey
      . vault
  