hs-opentelemetry-instrumentation-wai 0.0.1.3 → 0.0.1.4
raw patch · 4 files changed
+112/−103 lines, 4 filessetup-changedPVP ok
version bump matches the API change (PVP)
API changes (from Hackage documentation)
Files
- Setup.hs +2/−0
- hs-opentelemetry-instrumentation-wai.cabal +14/−14
- src/OpenTelemetry/Instrumentation/Wai.hs +95/−89
- test/Spec.hs +1/−0
Setup.hs view
@@ -1,2 +1,4 @@ import Distribution.Simple++ main = defaultMain
hs-opentelemetry-instrumentation-wai.cabal view
@@ -1,22 +1,22 @@ cabal-version: 1.12 --- This file has been generated from package.yaml by hpack version 0.34.4.+-- This file has been generated from package.yaml by hpack version 0.35.2. -- -- see: https://github.com/sol/hpack -name: hs-opentelemetry-instrumentation-wai-version: 0.0.1.3-synopsis: WAI instrumentation middleware for OpenTelemetry-description: Please see the README on GitHub at <https://github.com/iand675/hs-opentelemetry/tree/main/instrumentation/wai#readme>-category: OpenTelemetry, Web-homepage: https://github.com/iand675/hs-opentelemetry#readme-bug-reports: https://github.com/iand675/hs-opentelemetry/issues-author: Ian Duncan-maintainer: ian@iankduncan.com-copyright: 2021 Ian Duncan-license: BSD3-license-file: LICENSE-build-type: Simple+name: hs-opentelemetry-instrumentation-wai+version: 0.0.1.4+synopsis: WAI instrumentation middleware for OpenTelemetry+description: Please see the README on GitHub at <https://github.com/iand675/hs-opentelemetry/tree/main/instrumentation/wai#readme>+category: OpenTelemetry, Web+homepage: https://github.com/iand675/hs-opentelemetry#readme+bug-reports: https://github.com/iand675/hs-opentelemetry/issues+author: Ian Duncan, Jade Lovelace+maintainer: ian@iankduncan.com+copyright: 2023 Ian Duncan, Mercury Technologies+license: BSD3+license-file: LICENSE+build-type: Simple extra-source-files: README.md ChangeLog.md
src/OpenTelemetry/Instrumentation/Wai.hs view
@@ -1,38 +1,42 @@-{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE LambdaCase #-}-module OpenTelemetry.Instrumentation.Wai - ( newOpenTelemetryWaiMiddleware- , newOpenTelemetryWaiMiddleware'- , requestContext- ) where+{-# LANGUAGE OverloadedStrings #-} +module OpenTelemetry.Instrumentation.Wai (+ newOpenTelemetryWaiMiddleware,+ newOpenTelemetryWaiMiddleware',+ requestContext,+) where++import Control.Exception (bracket)+import Control.Monad+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 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.Trace.Core import System.IO.Unsafe-import qualified Data.Text.Encoding as T-import qualified Data.Text as T-import Control.Monad-import Network.Socket-import Data.IP (fromHostAddress, fromHostAddress6)-import OpenTelemetry.Attributes (lookupAttribute)-import Control.Exception (bracket) + newOpenTelemetryWaiMiddleware :: IO Middleware newOpenTelemetryWaiMiddleware = getGlobalTracerProvider >>= newOpenTelemetryWaiMiddleware' + newOpenTelemetryWaiMiddleware'- :: TracerProvider + :: TracerProvider -> IO Middleware newOpenTelemetryWaiMiddleware' tp = do- waiTracer <- getTracer - tp- "opentelemetry-instrumentation-wai" - (TracerOptions Nothing)+ let waiTracer =+ makeTracer+ tp+ "opentelemetry-instrumentation-wai"+ (TracerOptions Nothing) pure $ middleware waiTracer where middleware :: Tracer -> Middleware@@ -43,83 +47,85 @@ ctxt <- extract propagator (requestHeaders req) ctx attachContext ctxt let path_ = T.decodeUtf8 $ rawPathInfo req- -- peer = remoteHost req- bracket - parentContextM- (\case- Nothing -> void detachContext- Just p -> void (attachContext p)- )- $ \_ -> do- inSpan' tracer path_ (defaultSpanArguments { kind = Server }) $ \requestSpan -> do- ctxt <- getContext- 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))- ]+ -- peer = remoteHost req+ parentContextM+ inSpan' tracer path_ (defaultSpanArguments {kind = Server}) $ \requestSpan -> do+ ctxt <- getContext+ 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") - -- 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)- ]- let req' = req - { vault = Vault.insert - contextKey + ( "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)+ ]+ 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 ()+ (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 () - 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+ 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+requestContext =+ Vault.lookup contextKey+ . vault
test/Spec.hs view
@@ -1,2 +1,3 @@+ main :: IO () main = putStrLn "Test suite not yet implemented"