hs-opentelemetry-instrumentation-yesod 0.0.1.3 → 0.1.0.0
raw patch · 5 files changed
+155/−81 lines, 5 filesdep +unordered-containersdep ~hs-opentelemetry-apidep ~hs-opentelemetry-instrumentation-waisetup-changedPVP ok
version bump matches the API change (PVP)
Dependencies added: unordered-containers
Dependency ranges changed: hs-opentelemetry-api, hs-opentelemetry-instrumentation-wai
API changes (from Hackage documentation)
Files
- ChangeLog.md +8/−1
- Setup.hs +2/−0
- hs-opentelemetry-instrumentation-yesod.cabal +20/−18
- src/OpenTelemetry/Instrumentation/Yesod.hs +124/−62
- test/Spec.hs +1/−0
ChangeLog.md view
@@ -1,5 +1,13 @@ # Changelog for hs-opentelemetry-instrumentation-yesod +## Unreleased changes++## 0.1.0.0++### Breaking changes++- Use `HashMap Text Attribute` instead of `[(Text, Attribute)]` as attributes+ ## 0.0.1.1 - Bump version bounds for hs-opentelemetry-api to == 0.0.2.0@@ -7,4 +15,3 @@ ## 0.0.1.0 - Initial release-## Unreleased changes
Setup.hs view
@@ -1,2 +1,4 @@ import Distribution.Simple++ main = defaultMain
hs-opentelemetry-instrumentation-yesod.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-yesod-version: 0.0.1.3-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-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-yesod+version: 0.1.0.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+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@@ -35,13 +35,14 @@ ghc-options: -Wall build-depends: base >=4.7 && <5- , hs-opentelemetry-api ==0.0.3.*- , hs-opentelemetry-instrumentation-wai ==0.0.1.*+ , hs-opentelemetry-api ==0.1.*+ , hs-opentelemetry-instrumentation-wai >=0.0.1 && <0.2 , microlens , mtl , template-haskell , text , unliftio+ , unordered-containers , wai , yesod-core default-language: Haskell2010@@ -56,14 +57,15 @@ ghc-options: -threaded -rtsopts -with-rtsopts=-N build-depends: base >=4.7 && <5- , hs-opentelemetry-api ==0.0.3.*- , hs-opentelemetry-instrumentation-wai ==0.0.1.*+ , hs-opentelemetry-api ==0.1.*+ , hs-opentelemetry-instrumentation-wai >=0.0.1 && <0.2 , hs-opentelemetry-instrumentation-yesod , microlens , mtl , template-haskell , text , unliftio+ , unordered-containers , wai , yesod-core default-language: Haskell2010
src/OpenTelemetry/Instrumentation/Yesod.hs view
@@ -1,55 +1,64 @@ {-# LANGUAGE CPP #-} {-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE TemplateHaskell #-} {-# OPTIONS_GHC -fno-warn-orphans #-}-module OpenTelemetry.Instrumentation.Yesod- (++module OpenTelemetry.Instrumentation.Yesod ( -- * Middleware functionality openTelemetryYesodMiddleware,- RouteRenderer(..),+ RouteRenderer (..), mkRouteToRenderer, mkRouteToPattern,+ -- * Utilities rheSiteL,- handlerEnvL- ) where+ handlerEnvL,+) where +import qualified Data.HashMap.Strict as H+import Data.List (intercalate) import Data.Maybe (catMaybes)+import Data.Text (Text) import qualified Data.Text as T import qualified Data.Text.Encoding as T+import Language.Haskell.TH.Syntax 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.Trace.Core hiding (inSpan, inSpan', inSpan'') import OpenTelemetry.Trace.Monad+import UnliftIO.Exception import Yesod.Core import Yesod.Core.Types-import Language.Haskell.TH.Syntax-import Network.Wai (requestHeaders) import Yesod.Routes.TH.Types-import UnliftIO.Exception-import Data.Text (Text)-import Data.List (intercalate) + handlerEnvL :: Lens' (HandlerData child site) (RunHandlerEnv child site)-handlerEnvL = lens handlerEnv (\h e -> h { handlerEnv = e })+handlerEnvL = lens handlerEnv (\h e -> h {handlerEnv = e}) {-# INLINE handlerEnvL #-} + rheSiteL :: Lens' (RunHandlerEnv child site) site-rheSiteL = lens rheSite (\rhe new -> rhe { rheSite = new })+rheSiteL = lens rheSite (\rhe new -> rhe {rheSite = new}) {-# INLINE rheSiteL #-} + instance MonadTracer (HandlerFor site) where getTracer = do tp <- getGlobalTracerProvider OpenTelemetry.Trace.Core.getTracer tp "hs-opentelemetry-instrumentation-yesod" tracerOptions --- | Template Haskell to generate a function named routeToRendererFunction.------ For a route like HomeR, this function returns "HomeR".------ For routes with parents, this function returns e.g. "FooR.BarR.BazR".++{- | Template Haskell to generate a function named routeToRendererFunction.++ For a route like HomeR, this function returns "HomeR".++ For routes with parents, this function returns e.g. "FooR.BarR.BazR".+-} mkRouteToRenderer :: Name -> [ResourceTree a] -> Q [Dec] mkRouteToRenderer appName ress = do let fnName = mkName "routeToRenderer"@@ -62,8 +71,10 @@ , FunD fnName $ concat clauses ] + goTree :: (Pat -> Pat) -> [String] -> ResourceTree a -> Q [Clause] goTree front names (ResourceLeaf res) = pure <$> goRes front names res+#if MIN_VERSION_template_haskell(2, 18, 0) goTree front names (ResourceParent name _check pieces trees) = concat <$> mapM (goTree front' newNames) trees where@@ -71,13 +82,21 @@ toIgnore = length $ filter isDynamic pieces isDynamic Dynamic {} = True isDynamic Static {} = False-#if MIN_VERSION_template_haskell(2, 18, 0) front' = front . ConP (mkName name) [] . ignored+ newNames = names <> [name] #else+goTree front names (ResourceParent name _check pieces trees) =+ concat <$> mapM (goTree front' newNames) trees+ where+ ignored = (replicate toIgnore WildP ++) . pure+ toIgnore = length $ filter isDynamic pieces+ isDynamic Dynamic {} = True+ isDynamic Static {} = False front' = front . ConP (mkName name) . ignored-#endif newNames = names <> [name]+#endif + goRes :: (Pat -> Pat) -> [String] -> Resource a -> Q Clause goRes front names Resource {..} = pure $@@ -88,7 +107,9 @@ where toText s = VarE 'T.pack `AppE` LitE (StringL s) + mkRouteToPattern :: Name -> [ResourceTree String] -> Q [Dec]+#if MIN_VERSION_template_haskell(2, 18, 0) mkRouteToPattern appName ress = do let fnName = mkName "routeToPattern" t1 `arrow` t2 = ArrowT `AppT` t1 `AppT` t2@@ -104,11 +125,33 @@ toText s = VarE 'T.pack `AppE` LitE (StringL s) isDynamic Dynamic {} = True isDynamic Static {} = False-#if MIN_VERSION_template_haskell(2, 18, 0) parentPieceWrapper (parentName, pieces) nestedPat = ConP (mkName parentName) [] $ mconcat+ [ replicate (length $ filter isDynamic pieces) WildP+ , [nestedPat]+ ]+ mkClause fr@FlatResource{..} = do+ let clausePattern = foldr parentPieceWrapper (RecP (mkName frName) []) frParentPieces+ pure $ Clause+ [clausePattern]+ (NormalB $ toText $ renderPattern fr)+ [] #else+mkRouteToPattern appName ress = do+ let fnName = mkName "routeToPattern"+ t1 `arrow` t2 = ArrowT `AppT` t1 `AppT` t2++ clauses <- mapM mkClause $ flatten ress++ pure+ [ SigD fnName ((ConT ''Route `AppT` ConT appName) `arrow` ConT ''Text)+ , FunD fnName clauses+ ]++ where+ toText s = VarE 'T.pack `AppE` LitE (StringL s)+ isDynamic Dynamic {} = True+ isDynamic Static {} = False parentPieceWrapper (parentName, pieces) nestedPat = ConP (mkName parentName) $ mconcat-#endif [ replicate (length $ filter isDynamic pieces) WildP , [nestedPat] ]@@ -118,21 +161,26 @@ [clausePattern] (NormalB $ toText $ renderPattern fr) []+#endif + renderPattern :: FlatResource String -> String-renderPattern FlatResource{..} = concat $ concat- [ if frCheck then [] else ["!"]- , case formattedParentPieces <> concatMap routePortionSection frPieces of- [] -> ["/"]- pieces -> pieces- , case frDispatch of- Methods{..} -> concat- [ case methodsMulti of- Nothing -> []- Just t -> ["/+", t]- ]- Subsite{} -> []- ]+renderPattern FlatResource {..} =+ concat $+ concat+ [ if frCheck then [] else ["!"]+ , case formattedParentPieces <> concatMap routePortionSection frPieces of+ [] -> ["/"]+ pieces -> pieces+ , case frDispatch of+ Methods {..} ->+ concat+ [ case methodsMulti of+ Nothing -> []+ Just t -> ["/+", t]+ ]+ Subsite {} -> []+ ] where routePortionSection :: Piece String -> [String] routePortionSection (Static t) = ["/", t]@@ -144,43 +192,57 @@ piece <- pieces routePortionSection piece + data RouteRenderer site = RouteRenderer { nameRender :: Route site -> T.Text , pathRender :: Route site -> T.Text } ++-- TODO figure out a way to get better code locations for these spans.++-- | This middleware works best when used with `OpenTelemetry.Instrumentation.Wai` middleware. openTelemetryYesodMiddleware :: (ToTypedContent res) => RouteRenderer site -> HandlerFor site res -> HandlerFor site res openTelemetryYesodMiddleware rr m = do- -- tracer <- OpenTelemetry.Trace.Monad.getTracer req <- waiRequest- mspan <- Context.lookupSpan <$> getContext mr <- getCurrentRoute- let sharedAttributes = catMaybes- [ do- r <- mr- pure ("http.route", toAttribute $ pathRender rr r)- , do- ff <- lookup "X-Forwarded-For" $ requestHeaders req- pure ("http.client_ip", toAttribute $ T.decodeUtf8 ff)- ]- args = defaultSpanArguments- { kind = maybe Server (const Internal) mspan- , attributes = sharedAttributes- }- mapM_ (`addAttributes` sharedAttributes) mspan- eResult <- inSpan' (maybe "yesod.handler.notFound" (\r -> "yesod.handler." <> nameRender rr r) 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 ()- pure (Left (e :: HandlerContents))- case eResult of- Left hc -> throwIO hc- Right normal -> pure normal+ 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)+ ]+ args =+ defaultSpanArguments+ { kind = maybe Server (const Internal) mspan+ , attributes = sharedAttributes+ }+ case mspan of+ Nothing -> do+ eResult <- inSpan' (maybe "notFound" (\r -> nameRender rr r) 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 ()+ pure (Left (e :: HandlerContents))+ case eResult of+ Left hc -> throwIO hc+ Right normal -> pure normal+ Just waiSpan -> do+ addAttributes waiSpan sharedAttributes+ m
test/Spec.hs view
@@ -1,2 +1,3 @@+ main :: IO () main = putStrLn "Test suite not yet implemented"