diff --git a/ChangeLog.md b/ChangeLog.md new file mode 100644 --- /dev/null +++ b/ChangeLog.md @@ -0,0 +1,3 @@ +# Changelog for hs-opentelemetry-instrumentation-yesod + +## Unreleased changes diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -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. diff --git a/README.md b/README.md new file mode 100644 --- /dev/null +++ b/README.md @@ -0,0 +1,1 @@ +# hs-opentelemetry-instrumentation-yesod diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/hs-opentelemetry-instrumentation-yesod.cabal b/hs-opentelemetry-instrumentation-yesod.cabal new file mode 100644 --- /dev/null +++ b/hs-opentelemetry-instrumentation-yesod.cabal @@ -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 +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 diff --git a/src/OpenTelemetry/Instrumentation/Yesod.hs b/src/OpenTelemetry/Instrumentation/Yesod.hs new file mode 100644 --- /dev/null +++ b/src/OpenTelemetry/Instrumentation/Yesod.hs @@ -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 diff --git a/test/Spec.hs b/test/Spec.hs new file mode 100644 --- /dev/null +++ b/test/Spec.hs @@ -0,0 +1,2 @@ +main :: IO () +main = putStrLn "Test suite not yet implemented"