hs-opentelemetry-instrumentation-yesod (empty) → 0.0.1.0

raw patch · 7 files changed

+284/−0 lines, 7 filesdep +basedep +hs-opentelemetry-apidep +hs-opentelemetry-instrumentation-waisetup-changed

Dependencies added: base, hs-opentelemetry-api, hs-opentelemetry-instrumentation-wai, hs-opentelemetry-instrumentation-yesod, microlens, mtl, template-haskell, text, unliftio, wai, yesod-core

Files

ChangeLog.md +3/−0
LICENSE +30/−0
README.md +1/−0
Setup.hs +2/−0
hs-opentelemetry-instrumentation-yesod.cabal +69/−0
src/OpenTelemetry/Instrumentation/Yesod.hs +177/−0
test/Spec.hs +2/−0

+ ChangeLog.md view

@@ -0,0 +1,3 @@+# Changelog for hs-opentelemetry-instrumentation-yesod++## Unreleased changes

+ LICENSE view

@@ -0,0 +1,30 @@+Copyright Ian Duncan (c) 2021++All rights reserved.++Redistribution and use in source and binary forms, with or without+modification, are permitted provided that the following conditions are met:++    * Redistributions of source code must retain the above copyright+      notice, this list of conditions and the following disclaimer.++    * Redistributions in binary form must reproduce the above+      copyright notice, this list of conditions and the following+      disclaimer in the documentation and/or other materials provided+      with the distribution.++    * Neither the name of Ian Duncan nor the names of other+      contributors may be used to endorse or promote products derived+      from this software without specific prior written permission.++THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS+"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT+LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR+A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT+OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,+SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT+LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,+DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY+THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT+(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE+OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.

+ README.md view

@@ -0,0 +1,1 @@+# hs-opentelemetry-instrumentation-yesod

+ Setup.hs view

@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain

+ hs-opentelemetry-instrumentation-yesod.cabal view

@@ -0,0 +1,69 @@+cabal-version: 1.12++-- This file has been generated from package.yaml by hpack version 0.34.4.+--+-- see: https://github.com/sol/hpack++name:           hs-opentelemetry-instrumentation-yesod+version:        0.0.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+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+extra-source-files:+    README.md+    ChangeLog.md++source-repository head+  type: git+  location: https://github.com/iand675/hs-opentelemetry++library+  exposed-modules:+      OpenTelemetry.Instrumentation.Yesod+  other-modules:+      Paths_hs_opentelemetry_instrumentation_yesod+  hs-source-dirs:+      src+  ghc-options: -Wall+  build-depends:+      base >=4.7 && <5+    , hs-opentelemetry-api+    , hs-opentelemetry-instrumentation-wai+    , microlens+    , mtl+    , template-haskell+    , text+    , unliftio+    , 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+    , hs-opentelemetry-instrumentation-wai+    , hs-opentelemetry-instrumentation-yesod+    , microlens+    , mtl+    , template-haskell+    , text+    , unliftio+    , wai+    , yesod-core+  default-language: Haskell2010

+ src/OpenTelemetry/Instrumentation/Yesod.hs view

@@ -0,0 +1,177 @@+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE RecordWildCards #-}+{-# OPTIONS_GHC -fno-warn-orphans #-}+module OpenTelemetry.Instrumentation.Yesod+  (+  -- * Middleware functionality+  openTelemetryYesodMiddleware,+  RouteRenderer(..),+  mkRouteToRenderer,+  mkRouteToPattern,+  -- * Utilities+  rheSiteL,+  handlerEnvL+  ) where++import Data.Maybe (catMaybes)+import qualified Data.Text as T+import qualified Data.Text.Encoding as T+import Lens.Micro+import qualified OpenTelemetry.Context as Context+import OpenTelemetry.Context.ThreadLocal+import OpenTelemetry.Trace.Core hiding (inSpan, inSpan', inSpan'')+import OpenTelemetry.Trace.Monad+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 })+{-# INLINE handlerEnvL #-}++rheSiteL :: Lens' (RunHandlerEnv child site) site+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".+mkRouteToRenderer :: Name -> [ResourceTree a] -> Q [Dec]+mkRouteToRenderer appName ress = do+  let fnName = mkName "routeToRenderer"+      t1 `arrow` t2 = ArrowT `AppT` t1 `AppT` t2++  clauses <- mapM (goTree id []) ress++  pure+    [ SigD fnName ((ConT ''Route `AppT` ConT appName) `arrow` ConT ''Text)+    , FunD fnName $ concat clauses+    ]++goTree :: (Pat -> Pat) -> [String] -> ResourceTree a -> Q [Clause]+goTree front names (ResourceLeaf res) = pure <$> goRes front names res+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+    newNames = names <> [name]++goRes :: (Pat -> Pat) -> [String] -> Resource a -> Q Clause+goRes front names Resource {..} =+  pure $+    Clause+      [front $ RecP (mkName resourceName) []]+      (NormalB $ toText $ intercalate "." (names <> [resourceName]))+      []+  where+    toText s = VarE 'T.pack `AppE` LitE (StringL s)++mkRouteToPattern :: Name -> [ResourceTree String] -> Q [Dec]+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+      [ 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)+        []++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{} -> []+  ]+  where+    routePortionSection :: Piece String -> [String]+    routePortionSection (Static t) = ["/", t]+    routePortionSection (Dynamic t) = ["/#{", t, "}"]++    formattedParentPieces :: [String]+    formattedParentPieces = do+      (_parentName, pieces) <- frParentPieces+      piece <- pieces+      routePortionSection piece++data RouteRenderer site = RouteRenderer+  { nameRender :: Route site -> T.Text+  , pathRender :: Route site -> T.Text+  }++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

+ test/Spec.hs view

@@ -0,0 +1,2 @@+main :: IO ()+main = putStrLn "Test suite not yet implemented"