hs-opentelemetry-instrumentation-yesod 0.1.0.0 → 0.1.1.0
raw patch · 4 files changed
+67/−61 lines, 4 filesdep −hs-opentelemetry-instrumentation-yesoddep −mtldep ~hs-opentelemetry-apinew-uploader
Dependencies removed: hs-opentelemetry-instrumentation-yesod, mtl
Dependency ranges changed: hs-opentelemetry-api
Files
- ChangeLog.md +3/−1
- hs-opentelemetry-instrumentation-yesod.cabal +4/−28
- src/OpenTelemetry/Instrumentation/Yesod.hs +60/−29
- test/Spec.hs +0/−3
ChangeLog.md view
@@ -1,6 +1,8 @@ # Changelog for hs-opentelemetry-instrumentation-yesod -## Unreleased changes+## 0.1.1.0++- Set exception details when using WAI and Yesod instrumentation together (#121). ## 0.1.0.0
hs-opentelemetry-instrumentation-yesod.cabal view
@@ -1,11 +1,11 @@ cabal-version: 1.12 --- This file has been generated from package.yaml by hpack version 0.35.2.+-- This file has been generated from package.yaml by hpack version 0.36.0. -- -- see: https://github.com/sol/hpack name: hs-opentelemetry-instrumentation-yesod-version: 0.1.0.0+version: 0.1.1.0 synopsis: Yesod middleware for providing OpenTelemetry instrumentation description: Please see the README on GitHub at <https://github.com/iand675/hs-opentelemetry/tree/main/instrumentation/yesod#readme> category: OpenTelemetry, Web@@ -13,7 +13,7 @@ bug-reports: https://github.com/iand675/hs-opentelemetry/issues author: Ian Duncan, Jade Lovelace maintainer: ian@iankduncan.com-copyright: 2023 Ian Duncan, Mercury Technologies+copyright: 2024 Ian Duncan, Mercury Technologies license: BSD3 license-file: LICENSE build-type: Simple@@ -35,33 +35,9 @@ ghc-options: -Wall build-depends: base >=4.7 && <5- , hs-opentelemetry-api ==0.1.*+ , hs-opentelemetry-api ==0.2.* , hs-opentelemetry-instrumentation-wai >=0.0.1 && <0.2 , microlens- , mtl- , template-haskell- , text- , unliftio- , unordered-containers- , wai- , yesod-core- default-language: Haskell2010--test-suite hs-opentelemetry-instrumentation-yesod-test- type: exitcode-stdio-1.0- main-is: Spec.hs- other-modules:- Paths_hs_opentelemetry_instrumentation_yesod- hs-source-dirs:- test- ghc-options: -threaded -rtsopts -with-rtsopts=-N- build-depends:- base >=4.7 && <5- , hs-opentelemetry-api ==0.1.*- , hs-opentelemetry-instrumentation-wai >=0.0.1 && <0.2- , hs-opentelemetry-instrumentation-yesod- , microlens- , mtl , template-haskell , text , unliftio
src/OpenTelemetry/Instrumentation/Yesod.hs view
@@ -1,9 +1,16 @@ {-# LANGUAGE CPP #-}+{-# LANGUAGE LambdaCase #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE TemplateHaskell #-} {-# OPTIONS_GHC -fno-warn-orphans #-} +{- |+[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.Yesod ( -- * Middleware functionality openTelemetryYesodMiddleware,@@ -16,6 +23,7 @@ handlerEnvL, ) where +import Control.Monad (when) import qualified Data.HashMap.Strict as H import Data.List (intercalate) import Data.Maybe (catMaybes)@@ -26,9 +34,8 @@ import Lens.Micro import Network.Wai (requestHeaders) import qualified OpenTelemetry.Context as Context-import OpenTelemetry.Context.ThreadLocal-import OpenTelemetry.Contrib.SpanTraversals import OpenTelemetry.Instrumentation.Wai (requestContext)+import OpenTelemetry.SemanticsConfig import OpenTelemetry.Trace.Core hiding (inSpan, inSpan', inSpan'') import OpenTelemetry.Trace.Monad import UnliftIO.Exception@@ -50,7 +57,7 @@ instance MonadTracer (HandlerFor site) where getTracer = do tp <- getGlobalTracerProvider- OpenTelemetry.Trace.Core.getTracer tp "hs-opentelemetry-instrumentation-yesod" tracerOptions+ pure $ makeTracer tp $detectInstrumentationLibrary tracerOptions {- | Template Haskell to generate a function named routeToRendererFunction.@@ -174,11 +181,9 @@ pieces -> pieces , case frDispatch of Methods {..} ->- concat- [ case methodsMulti of- Nothing -> []- Just t -> ["/+", t]- ]+ case methodsMulti of+ Nothing -> []+ Just t -> ["/+", t] Subsite {} -> [] ] where@@ -210,20 +215,31 @@ openTelemetryYesodMiddleware rr m = do req <- waiRequest mr <- getCurrentRoute+ semanticsOptions <- liftIO getSemanticsOptions let mspan = requestContext req >>= Context.lookupSpan- sharedAttributes = H.fromList $- ("http.framework", toAttribute ("yesod" :: Text))- : catMaybes- [ do- r <- mr- pure ("http.route", toAttribute $ pathRender rr r)- , do- r <- mr- pure ("http.handler", toAttribute $ nameRender rr r)- , do- ff <- lookup "X-Forwarded-For" $ requestHeaders req- pure ("http.client_ip", toAttribute $ T.decodeUtf8 ff)- ]+ sharedAttributes =+ H.fromList $+ ("http.framework", toAttribute ("yesod" :: Text))+ : catMaybes+ [ do+ r <- mr+ Just ("http.route", toAttribute $ pathRender rr r)+ , do+ r <- mr+ Just ("http.handler", toAttribute $ nameRender rr r)+ , do+ ff <- lookup "X-Forwarded-For" $ requestHeaders req+ case httpOption semanticsOptions of+ Stable -> Just ("client.address", toAttribute $ T.decodeUtf8 ff)+ StableAndOld -> Just ("client.address", toAttribute $ T.decodeUtf8 ff)+ Old -> Nothing+ , do+ ff <- lookup "X-Forwarded-For" $ requestHeaders req+ case httpOption semanticsOptions of+ Stable -> Nothing+ StableAndOld -> Just ("http.client_ip", toAttribute $ T.decodeUtf8 ff)+ Old -> Just ("http.client_ip", toAttribute $ T.decodeUtf8 ff)+ ] args = defaultSpanArguments { kind = maybe Server (const Internal) mspan@@ -231,18 +247,33 @@ } case mspan of Nothing -> do- eResult <- inSpan' (maybe "notFound" (\r -> nameRender rr r) mr) args $ \_s -> do+ eResult <- inSpan' (maybe "notFound" (nameRender rr) mr) args $ \_s -> do catch (Right <$> m) $ \e -> do- -- We want to mark the span as an error if it's an InternalError,- -- the other HCError values are 4xx status codes which don't- -- really count as a server error in OpenTelemetry spec parlance.- case e of- HCError (InternalError _) -> throwIO e- _ -> pure ()+ when (isInternalError e) $ throwIO e pure (Left (e :: HandlerContents)) case eResult of Left hc -> throwIO hc Right normal -> pure normal Just waiSpan -> do addAttributes waiSpan sharedAttributes- m++ -- Explicitly record any exceptions here. When Yesod is in use, exceptions+ -- are handled as error-pages before reaching the WAI middleware's inSpan,+ -- meaning the exception details would not be otherwise attached.+ withException m $ \ex -> do+ when (shouldMarkException ex) $ do+ recordException waiSpan mempty Nothing ex+ setStatus waiSpan $ Error $ T.pack $ displayException ex+++shouldMarkException :: SomeException -> Bool+shouldMarkException = maybe True isInternalError . fromException+++-- We want to mark the span as an error if it's an InternalError, the other+-- HCError values are 4xx status codes which don't really count as a server+-- error in OpenTelemetry spec parlance.+isInternalError :: HandlerContents -> Bool+isInternalError = \case+ HCError (InternalError _) -> True+ _ -> False
− test/Spec.hs
@@ -1,3 +0,0 @@--main :: IO ()-main = putStrLn "Test suite not yet implemented"