packages feed

hs-opentelemetry-instrumentation-auto (empty) → 0.1.0.0

raw patch · 12 files changed

+1004/−0 lines, 12 filesdep +basedep +bytestringdep +containers

Dependencies added: base, bytestring, containers, directory, ghc, hs-opentelemetry-api, hs-opentelemetry-exporter-in-memory, hs-opentelemetry-instrumentation-auto, hs-opentelemetry-sdk, parsec, tasty, tasty-hunit, text, time, toml-parser, unliftio, unordered-containers

Files

+ CHANGELOG.md view
@@ -0,0 +1,5 @@+# Revision history for auto-instrument++## 0.1.0.0 -- YYYY-mm-dd++* First version. Released on an unsuspecting world.
+ LICENSE view
@@ -0,0 +1,30 @@+Copyright (c) 2023, Aaron Allen++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 Aaron Allen 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,118 @@+# Open Telemetry Auto Instrumentation++This is a GHC plugin for automatically instrumenting a Haskell application with+open telemetry spans based on user configuration. The instrumentation+functionality is provided by+[`hs-opentelemetry`](https://github.com/iand675/hs-opentelemetry).++- [Quick start](#quick-start)+- [Configuration](#configuration)+  - [Config structure](#config-structure)+  - [Example config](#example-config)+- [Known pitfalls](#known-pitfalls)++### Quick start++- Add this package as a project dependency+- Create a file called `auto-instrument-config.toml` in the project root directory:+  ```toml+  [[targets]]+  type = "constructor"+  value = "MyAppMonad"+  ```+  Replace `MyAppMonad` with your application's primary monad. This monad needs+  to have an instance for `MonadUnliftIO`, otherwise you'll get a type error.+- Initialize the global tracer provider as part of application startup. The+  plugin will not insert spans until after the gobal tracer provider has been+  initialized. See the+  [`hs-opentelemetry-sdk` documentation](https://hackage.haskell.org/package/hs-opentelemetry-sdk)+  for instructions.+- Pass the `-fplugin AutoInstrument` argument to GHC when compiling the project.+  This can be done project-wide in the `*.cabal` or `package.yaml` file using+  `ghc-options: -fplugin AutoInstrument`, or by adding+  `{- OPTIONS_GHC -fplugin AutoInstrument -}` to individual modules.+- Only top-level functions that have type signatures with a return type that+  matches the target monad will be instrumented.++### Configuration++Configuration is supplied by a user defined TOML file that declares a set of+rules used to determine which functions should be instrumented. The plugin will+only consider top level functions that have type signatures when matching+against these rules. By default the plugin looks for a config file called+`auto-instrument-config.toml` in the project root. You can change this by+passing a config file path as a plugin option, for example: `-fplugin+AutoInstrument -fplugin-opt AutoInstrument:my-config.toml`.++#### Config structure++- The `targets` key is an array of tables that specify how to identify a function+  to instrument based on its type signature.+- These tables have a `type` field that can either `"constructor"` or `"constraints"`+  and a `value` key with the value corresponding to the chosen `type`.+  - `"constructor"` is used to target the return type of the function. This will+    typically be your application's monad. It is not necessary to provide all+    arguments to this type and arguments that should be ignored can replaced with+    an underscore.+  - `"constraints"` allows for a set of constraints to be specified which must+    all be present in the constraint context of a function in order for it to+    be instrumented. The `value` field should be an array of constraint types+    which do not need to be fully applied and can have underscore wildcards.+- The `exclusions` key is an array with the same structure as `targets`. If any+  of these rules match a type signature, the corresponding declaration(s) will+  not be instrumented.++#### Example config++```toml+# Targets are things that should be auto instrumented for tracing.+# "constructor" means that it should match the return type of the function+# while "constraints" means that all the constraints in the "value" array must+# be present in the constraint context of the function.++[[targets]]+type = "constructor"+value = "AppMonad"++[[targets]]+type = "constraints"+value = ["MonadUnliftIO"]++# Exclusions denote types that should not be instrumented. This is primarily+# needed for when a target constraint appears in a definition's context but+# doesn't apply directly to the return type, for example:+# server :: MonadUnliftIO m => ServerT Api m++[[exclusions]]+type = "constructor"+value = "ServerT"++[[exclusions]]+type = "constructor"+value = "ConduitT"+```++### Known pitfalls++Functions that loop can be problematic when instrumented if a new span is+entered for each iteration. For example, if an application has a process that+continually performs some polling action in a loop, then instrumenting that+process would result in a space leak due to the mass of nested spans being+allocated and retained on the heap. One way for dealing with this is to define+a type synonym `type NotInstrumented a = a`, add an exclusion rule for it to+the config, and apply it to the result type of any such looping functions:++```haskell+type NotInstrumented a = a++loop :: NotInstrumented (MyApp ())+loop = do+  ...+  loop+```+---+```toml+[[exclusions]]+type = "constructor"+value = "NotInstrumented"+```
+ hs-opentelemetry-instrumentation-auto.cabal view
@@ -0,0 +1,72 @@+cabal-version:      3.0+name:               hs-opentelemetry-instrumentation-auto+version:            0.1.0.0+synopsis:           Plugin for instrumenting an application+description:        A GHC plugin that auto-instruments an application for emitting open telementry tracing.+license:            BSD-3-Clause+license-file:       LICENSE+author:             Aaron Allen+maintainer:         aaronallen8455@gmail.com+-- copyright:+category:           Development+build-type:         Simple+extra-doc-files:+  CHANGELOG.md+  README.md+extra-source-files: test-config.toml+tested-with:+  GHC == 9.4.8+  GHC == 9.6.2++common warnings+    ghc-options: -Wall++library+    import:           warnings+    exposed-modules:+      AutoInstrument+      AutoInstrument.Internal.Plugin+      AutoInstrument.Internal.Plugin.Parser+      AutoInstrument.Internal.Config+      AutoInstrument.Internal.GhcFacade+      AutoInstrument.Internal.Types+    -- other-modules:+    -- other-extensions:+    build-depends:+      base >=4.17.0.0 && <4.20.0.0,+      ghc >=9.4.0 && <9.9.0,+      bytestring ^>= 0.11 || ^>= 0.12,+      directory ^>= 1.3,+      containers ^>= 0.6,+      unliftio ^>= 0.2,+      hs-opentelemetry-api ^>= 0.0.3 || ^>= 0.1,+      text ^>= 2.0,+      toml-parser >= 2.0.0.0 && < 3.0.0.0,+      parsec ^>= 3.1,+      time ^>= 1.12+    hs-source-dirs:   src+    default-language: GHC2021++test-suite auto-instrument-test+    import:           warnings+    default-language: GHC2021+    -- other-modules:+    -- other-extensions:+    type:             exitcode-stdio-1.0+    hs-source-dirs:   test+    main-is:          Main.hs+    build-depends:+      base >=4.17.0.0 && <4.20.0.0,+      unordered-containers,+      hs-opentelemetry-instrumentation-auto,+      hs-opentelemetry-exporter-in-memory,+      hs-opentelemetry-api,+      hs-opentelemetry-sdk,+      tasty-hunit,+      tasty,+      unliftio,+      text+    ghc-options:+      -threaded+      -fplugin AutoInstrument+      -fplugin-opt AutoInstrument:test-config.toml
+ src/AutoInstrument.hs view
@@ -0,0 +1,5 @@+module AutoInstrument+  ( plugin+  ) where++import           AutoInstrument.Internal.Plugin
+ src/AutoInstrument/Internal/Config.hs view
@@ -0,0 +1,193 @@+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE CPP #-}+module AutoInstrument.Internal.Config+  ( Config(..)+  , ConfigCache(..)+  , Target(..)+  , getConfigCache+  , getConfigFilePath+  , defaultConfigFile+  , TargetCon(..)+  , ConstraintSet+  ) where++import           Control.Applicative ((<|>))+import           Control.Concurrent.MVar+import           Data.IORef+import           Data.Maybe+import           Data.Set (Set)+import qualified Data.Set as S+import qualified Data.Text.IO as T+import           Data.Time+import qualified System.Directory as Dir+import           System.IO.Unsafe (unsafePerformIO)+import qualified Text.Parsec as P+import qualified Text.Parsec.Error as P+import qualified Text.Parsec.String as P+import qualified Toml.Schema.FromValue as Toml+import qualified Toml++import qualified AutoInstrument.Internal.GhcFacade as Ghc++data ConfigCache = MkConfigCache+  { timestamp :: !UTCTime+  , getConfig :: !Config+  , fingerprint :: !Ghc.Fingerprint+  }++configCache :: IORef (Maybe ConfigCache)+configCache = unsafePerformIO $ newIORef Nothing+{-# NOINLINE configCache #-}++-- | Used to ensure that the config file is only read by one thread when the+-- cache expires or needs to be initialized.+semaphore :: MVar ()+semaphore = unsafePerformIO $ newMVar ()+{-# NOINLINE semaphore #-}++-- Cache expires after 20 seconds+cacheDuration :: NominalDiffTime+cacheDuration = 20++data Config = MkConfig+  { targets :: [Target]+  , exclusions :: [Target]+  }++data Target+  = Constructor TargetCon+  | Constraints ConstraintSet++data TargetCon+  = TyVar String+  | WC+  | App TargetCon TargetCon+  | Unit+  | Tuple [TargetCon]+  deriving (Show, Eq, Ord)++skipSpaces :: P.Parser ()+skipSpaces = P.skipMany P.space++targetParser :: P.Parser TargetCon+targetParser = appP+  where+    appP = P.chainl1 (P.try unitP <|> varP <|> parenP) (pure App) <* skipSpaces+    unitP = Unit <$ P.string "()" <* skipSpaces+    varP = do+      v <- P.many1 (P.satisfy $ \c -> c `notElem` [' ', '(', ')', ',']) <* skipSpaces+      case v of+        "_" -> pure WC+        _ -> pure $ TyVar v+    parenP = do+      inParens <-+        P.between (P.char '(' <* skipSpaces) (P.char ')')+          (P.sepBy1 targetParser (P.char ',' <* skipSpaces))+          <* skipSpaces+      case inParens of+        [t] -> pure t+        _ -> pure $ Tuple inParens++type ConstraintSet = Set TargetCon++instance Toml.FromValue Config where+  fromValue = Toml.parseTableFromValue $+    MkConfig+      <$> Toml.reqKey "targets"+      <*> (fromMaybe [] <$> Toml.optKey "exclusions")++instance Toml.FromValue Target where+  fromValue = Toml.parseTableFromValue $ do+    tag <- Toml.reqKey "type"+    case tag of+      "constructor" -> do+        value <- Toml.reqKey "value"+        case P.parse (skipSpaces *> targetParser <* P.eof) "" value of+          Right target -> pure $ Constructor target+          Left err -> fail $ showParsecError err+      "constraints" -> do+        value <- Toml.reqKey "value"+        let parsePred v =+              case P.parse (skipSpaces *> targetParser <* P.eof) "" v of+                Right target -> pure target+                Left err -> fail $ showParsecError err+        Constraints . S.fromList <$> traverse parsePred value+      _ -> fail $ "Unrecognized targed type: " <> tag++-- | Doesn't show the source location+showParsecError :: P.ParseError -> String+showParsecError+  = drop 1+  . P.showErrorMessages "or" "unknown parse error" "expecting" "unexpected" "end of input"+  . P.errorMessages++getConfigCache :: [Ghc.CommandLineOption] -> IO (Maybe ConfigCache)+getConfigCache opts = do+  mCached <- readIORef configCache+  case mCached of+    Nothing -> getConfigOrRefresh opts+    Just cached -> do+      expired <- isCacheExpired cached+      if expired+      then getConfigOrRefresh opts+      else pure $ Just cached++-- | This blocks on the MVar to ensure that the file is only read by one thread when necessary.+-- contention for the MVar only occurs when the cache expires or hasn't been initialized.+getConfigOrRefresh :: [Ghc.CommandLineOption] -> IO (Maybe ConfigCache)+getConfigOrRefresh opts = do+  withMVar semaphore $ \_ -> do+    mCached <- readIORef configCache+    case mCached of+      Nothing -> refreshConfigCache opts+      Just existing -> do+        expired <- isCacheExpired existing+        if expired+        then refreshConfigCache opts+        else pure $ Just existing++isCacheExpired :: ConfigCache -> IO Bool+isCacheExpired cached = do+  now <- getCurrentTime+  let diff = diffUTCTime now $ timestamp cached+  pure $ diff >= cacheDuration++refreshConfigCache :: [Ghc.CommandLineOption] -> IO (Maybe ConfigCache)+refreshConfigCache opts = do+  newCache <- mkConfigCache opts+  writeIORef configCache newCache+  pure newCache++mkConfigCache :: [Ghc.CommandLineOption] -> IO (Maybe ConfigCache)+mkConfigCache opts = do+  let cfgFile = getConfigFilePath opts+  exists <- Dir.doesFileExist cfgFile+  if exists+     then do+       result <- Toml.decode <$> T.readFile cfgFile+       case result of+         Toml.Success _ config -> do+           now <- getCurrentTime+           fp <- Ghc.getFileHash cfgFile+           pure $ Just MkConfigCache+             { timestamp = now+             , getConfig = config+             , fingerprint = fp+             }+         Toml.Failure errs -> do+           putStr $ unlines+            $ "================================================================================"+            : "Failed to parse auto instrument config file:"+            : errs+            ++ ["================================================================================"]+           pure Nothing+     else do+       pure Nothing++getConfigFilePath :: [Ghc.CommandLineOption] -> FilePath+getConfigFilePath (opt : _) = opt+getConfigFilePath [] = defaultConfigFile++defaultConfigFile :: FilePath+defaultConfigFile = "auto-instrument-config.toml"
+ src/AutoInstrument/Internal/GhcFacade.hs view
@@ -0,0 +1,48 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE OverloadedStrings #-}+module AutoInstrument.Internal.GhcFacade+  ( module Ghc+  , mkParseError+  ) where++#if MIN_VERSION_ghc(9,6,0)+import           GHC.Plugins as Ghc hiding (getHscEnv, putMsg, fatalErrorMsg, errorMsg, debugTraceMsg)+import           GHC.Fingerprint as Ghc+import           GHC.Iface.Env as Ghc+import           GHC.Unit.Finder as Ghc+import           GHC.Driver.Main as Ghc+import           Language.Haskell.Syntax as Ghc+import           GHC.Hs as Ghc (HsParsedModule(..))+import           GHC.Hs.Extension as Ghc+import           GHC.Parser.Annotation as Ghc (SrcSpanAnn'(..), SrcSpanAnnA, noAnn, noSrcSpanA, realSrcSpan)+import           GHC.Parser.Errors.Types as Ghc+import           GHC.Types.SourceText as Ghc+import           GHC.Types.Error as Ghc+import           GHC.Utils.Error as Ghc+#elif MIN_VERSION_ghc(9,4,0)+import           GHC.Plugins as Ghc hiding (getHscEnv, putMsg, fatalErrorMsg, errorMsg, debugTraceMsg)+import           GHC.Fingerprint as Ghc+import           GHC.Iface.Env as Ghc+import           GHC.Unit.Finder as Ghc+import           GHC.Driver.Main as Ghc+import           Language.Haskell.Syntax as Ghc+import           GHC.Hs as Ghc (HsParsedModule(..), HsModule(..))+import           GHC.Hs.Extension as Ghc+import           GHC.Parser.Annotation as Ghc (SrcSpanAnn'(..), SrcSpanAnnA, noAnn, noSrcSpanA, realSrcSpan)+import           GHC.Parser.Errors.Types as Ghc+import           GHC.Types.SourceText as Ghc+import           GHC.Types.Error as Ghc+import           GHC.Utils.Error as Ghc+#endif++mkParseError :: String -> MsgEnvelope PsMessage+mkParseError+  = Ghc.mkPlainErrorMsgEnvelope (Ghc.mkGeneralSrcSpan "plugin")+  . Ghc.PsUnknownMessage+#if MIN_VERSION_ghc (9,8,0)+  . Ghc.mkUnknownDiagnostic+#elif MIN_VERSION_ghc (9,6,0)+  . Ghc.UnknownDiagnostic+#endif+  . Ghc.mkPlainError Ghc.noHints+  . Ghc.text
+ src/AutoInstrument/Internal/Plugin.hs view
@@ -0,0 +1,21 @@+module AutoInstrument.Internal.Plugin+  ( plugin+  ) where++import qualified AutoInstrument.Internal.Config as Cfg+import qualified AutoInstrument.Internal.GhcFacade as Ghc+import qualified AutoInstrument.Internal.Plugin.Parser as Parser++plugin :: Ghc.Plugin+plugin = Ghc.defaultPlugin+  { Ghc.pluginRecompile = pluginRecompile+  , Ghc.parsedResultAction = Parser.parsedResultAction+  }++pluginRecompile :: [Ghc.CommandLineOption] -> IO Ghc.PluginRecompile+pluginRecompile opts = do+  mCache <- Cfg.getConfigCache opts+  case mCache of+    Nothing -> pure Ghc.NoForceRecompile+    Just cache ->+     pure . Ghc.MaybeRecompile $ Cfg.fingerprint cache
+ src/AutoInstrument/Internal/Plugin/Parser.hs view
@@ -0,0 +1,178 @@+{-# LANGUAGE NamedFieldPuns #-}+{-# LANGUAGE LambdaCase #-}+module AutoInstrument.Internal.Plugin.Parser+  ( parsedResultAction+  ) where++import           Control.Monad.IO.Class (liftIO)+import qualified Data.ByteString.Char8 as BS8+import           Data.Maybe (mapMaybe)+import qualified Data.Set as S++import qualified AutoInstrument.Internal.GhcFacade as Ghc+import qualified AutoInstrument.Internal.Config as Cfg++parsedResultAction+  :: [Ghc.CommandLineOption]+  -> Ghc.ModSummary+  -> Ghc.ParsedResult+  -> Ghc.Hsc Ghc.ParsedResult+parsedResultAction opts modSummary+    parsedResult@Ghc.ParsedResult+      {Ghc.parsedResultModule = prm@Ghc.HsParsedModule+        {Ghc.hpm_module = Ghc.L modLoc mo@Ghc.HsModule{Ghc.hsmodDecls}}} = do++  let modName = Ghc.moduleName $ Ghc.ms_mod modSummary+      unitId = Ghc.toUnitId . Ghc.moduleUnit $ Ghc.ms_mod modSummary++  hscEnv <- Ghc.getHscEnv+  result <- liftIO $+    Ghc.findImportedModule hscEnv (Ghc.mkModuleName "AutoInstrument.Internal.Types") Ghc.NoPkgQual+  otelMod <-+    case result of+      Ghc.Found _ m -> pure m+      _ -> error "AutoInstrument.Internal.Types module not found"+  let occ = Ghc.mkVarOcc "autoInstrument"+  autoInstrumentName <- liftIO $ Ghc.lookupNameCache (Ghc.hsc_NC hscEnv) otelMod occ++  mConfig <- liftIO $ fmap Cfg.getConfig <$> Cfg.getConfigCache opts++  case mConfig of+    Nothing -> pure parsedResult+      { Ghc.parsedResultMessages = (Ghc.parsedResultMessages parsedResult)+        { Ghc.psErrors =+            let msg = Ghc.mkParseError "Failed to load auto instrumentation config"+             in Ghc.addMessage msg . Ghc.psErrors $ Ghc.parsedResultMessages parsedResult+        }+      }+    Just config -> do+      let matches = S.fromList $ getMatches config hsmodDecls++          newDecls = instrumentDecl modName unitId autoInstrumentName matches <$> hsmodDecls++      pure parsedResult+        { Ghc.parsedResultModule = prm+          { Ghc.hpm_module = Ghc.L modLoc mo+            { Ghc.hsmodDecls = newDecls+            }+          }+        }++getMatches+  :: Cfg.Config+  -> [Ghc.LHsDecl Ghc.GhcPs]+  -> [Ghc.OccName]+getMatches cfg = concat . mapMaybe go where+  go (Ghc.L _ (Ghc.SigD _ (Ghc.TypeSig _ lhs (Ghc.HsWC _ (Ghc.L _ (Ghc.HsSig _ _ (Ghc.L _ ty)))))))+    | isTargetTy [] ty = Just (Ghc.rdrNameOcc . Ghc.unLoc <$> lhs)+  go _ = Nothing+  isTargetTy preds = \case+    Ghc.HsForAllTy _ _ (Ghc.L _ body) -> isTargetTy preds body+    Ghc.HsQualTy _ (Ghc.L _ ctx) (Ghc.L _ body) ->+      isTargetTy (preds ++ fmap Ghc.unLoc ctx) body+    app@Ghc.HsAppTy{} -> check preds app+    var@Ghc.HsTyVar{} -> check preds var+    Ghc.HsFunTy _ _ _ (Ghc.L _ nxt) -> isTargetTy preds nxt+    Ghc.HsParTy _ (Ghc.L _ nxt) -> isTargetTy preds nxt+    Ghc.HsDocTy _ (Ghc.L _ nxt) _ -> isTargetTy preds nxt+    _ -> False++  check+    :: [Ghc.HsType Ghc.GhcPs]+    -> Ghc.HsType Ghc.GhcPs+    -> Bool+  check preds expr =+    any (matchTarget preds expr) (Cfg.targets cfg)+    && not (any (matchTarget preds expr) (Cfg.exclusions cfg))++  matchTarget preds expr = \case+    Cfg.Constructor conTarget -> checkTy True conTarget expr+    Cfg.Constraints predTarget -> checkPred preds predTarget++  checkTy+    :: Bool+    -> Cfg.TargetCon+    -> Ghc.HsType Ghc.GhcPs+    -> Bool+  checkTy top t (Ghc.HsParTy _ (Ghc.L _ x)) = checkTy top t x+  checkTy top t (Ghc.HsDocTy _ (Ghc.L _ x) _) = checkTy top t x+  checkTy _ (Cfg.TyVar name) (Ghc.HsTyVar _ _ (Ghc.L _ rdrName)) =+    BS8.pack name == Ghc.bytesFS (Ghc.occNameFS $ Ghc.rdrNameOcc rdrName)+  checkTy top target@(Cfg.App x y) (Ghc.HsAppTy _ (Ghc.L _ con) (Ghc.L _ arg)) =+    (checkTy False y arg && checkTy False x con )+    || (top && checkTy True target con)+  checkTy True target@(Cfg.TyVar _) (Ghc.HsAppTy _ (Ghc.L _ con) _) =+    checkTy True target con+  checkTy _ Cfg.Unit (Ghc.HsTupleTy _ Ghc.HsBoxedOrConstraintTuple []) = True+  checkTy _ (Cfg.Tuple targets) (Ghc.HsTupleTy _ Ghc.HsBoxedOrConstraintTuple exprs) =+    and $ zipWith (checkTy False) targets (Ghc.unLoc <$> exprs)+  checkTy _ Cfg.WC _ = True+  checkTy _ _ _ = False++  checkPred+    :: [Ghc.HsType Ghc.GhcPs]+    -> Cfg.ConstraintSet+    -> Bool+  checkPred preds predSet =+    all (\p -> any (checkTy True p) preds)+        (S.toList predSet)++instrumentDecl+  :: Ghc.ModuleName+  -> Ghc.UnitId+  -> Ghc.Name+  -> S.Set Ghc.OccName+  -> Ghc.LHsDecl Ghc.GhcPs+  -> Ghc.LHsDecl Ghc.GhcPs+instrumentDecl modName unitId instrName targets+    (Ghc.L loc (Ghc.ValD vX fb@Ghc.FunBind+      { Ghc.fun_matches = mg@Ghc.MG+        { Ghc.mg_alts = Ghc.L altsLoc alts }, Ghc.fun_id}))+  | Ghc.rdrNameOcc (Ghc.unLoc fun_id) `S.member` targets+  = let newAlts = (fmap . fmap)+          (instrumentMatch modName unitId (Ghc.unLoc fun_id) instrName)+          alts+     in Ghc.L loc (Ghc.ValD vX (fb+       { Ghc.fun_matches = mg+         { Ghc.mg_alts = Ghc.L altsLoc newAlts }}))+instrumentDecl _ _ _ _ x = x++instrumentMatch+  :: Ghc.ModuleName+  -> Ghc.UnitId+  -> Ghc.RdrName+  -> Ghc.Name+  -> Ghc.Match Ghc.GhcPs (Ghc.GenLocated Ghc.SrcSpanAnnA (Ghc.HsExpr Ghc.GhcPs))+  -> Ghc.Match Ghc.GhcPs (Ghc.GenLocated Ghc.SrcSpanAnnA (Ghc.HsExpr Ghc.GhcPs))+instrumentMatch modName unitId bindName instrName match =+  match+    { Ghc.m_grhss = (Ghc.m_grhss match)+      { Ghc.grhssGRHSs = (fmap . fmap) modifyGRH (Ghc.grhssGRHSs (Ghc.m_grhss match)) }+    }+  where+    modifyGRH :: Ghc.GRHS Ghc.GhcPs (Ghc.LHsExpr Ghc.GhcPs)+              -> Ghc.GRHS Ghc.GhcPs (Ghc.LHsExpr Ghc.GhcPs)+    modifyGRH (Ghc.GRHS x guards body) =+      Ghc.GRHS x guards (go body)+    go :: Ghc.LHsExpr Ghc.GhcPs -> Ghc.LHsExpr Ghc.GhcPs+    go (Ghc.L loc x) =+      let instrVar = Ghc.HsVar Ghc.noExtField (Ghc.L Ghc.noSrcSpanA (Ghc.Exact instrName))+          mkStringExpr = Ghc.L Ghc.noSrcSpanA . Ghc.HsLit Ghc.noAnn+                       . Ghc.HsString Ghc.NoSourceText+          app :: Ghc.LHsExpr Ghc.GhcPs -> Ghc.LHsExpr Ghc.GhcPs -> Ghc.LHsExpr Ghc.GhcPs+          app l r = Ghc.L Ghc.noSrcSpanA $ Ghc.HsApp Ghc.noAnn l r+          srcSpan = Ghc.realSrcSpan . Ghc.locA $ loc :: Ghc.RealSrcSpan+          instr =+            Ghc.L Ghc.noSrcSpanA instrVar+              `app`+            (mkStringExpr . Ghc.occNameFS $ Ghc.rdrNameOcc bindName)+              `app`+            mkStringExpr (Ghc.moduleNameFS modName)+              `app`+            mkStringExpr (Ghc.srcSpanFile srcSpan)+              `app`+            (mkStringExpr . Ghc.fsLit . show $ Ghc.srcSpanStartLine srcSpan)+              `app`+            mkStringExpr (Ghc.unitIdFS unitId)++       in Ghc.L loc $ Ghc.HsApp Ghc.noAnn instr (Ghc.L loc x)
+ src/AutoInstrument/Internal/Types.hs view
@@ -0,0 +1,56 @@+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE OverloadedLists #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE CPP #-}+module AutoInstrument.Internal.Types+  ( AutoInstrument(..)+  ) where++import qualified Data.Text as T+import           UnliftIO++import qualified OpenTelemetry.Propagator as Otel+import qualified OpenTelemetry.Trace.Core as Otel++class AutoInstrument a where+  autoInstrument+    :: String -- function name+    -> String -- module name+    -> String -- file path+    -> String -- line number+    -> String -- package name+    -> a -> a++instance {-# INCOHERENT #-} AutoInstrument b => AutoInstrument (a -> b) where+  autoInstrument funName modName filePath lineNum pkgName f =+    autoInstrument funName modName filePath lineNum pkgName . f++instance MonadUnliftIO m+    => AutoInstrument (m a) where+  autoInstrument funName modName filePath lineNum pkgName body = do+    tp <- Otel.getGlobalTracerProvider+    -- If the global tracer provider hasn't been initialized then there will+    -- be no propagators. Don't create a span if this is the case because if+    -- the function that initializes the tracer provider gets auto instrumented+    -- then its span will not emit traces and nor will its child spans.+    if null $ Otel.propagatorNames (Otel.getTracerProviderPropagators tp)+    then body -- no providers - don't create a span+    else+      -- TODO store this in a global var as an optimization? might not want to+      -- since the global tracer provider can potentially change.+      let tracer = Otel.makeTracer tp "hs-opentelemetry-instrumentation-auto" Otel.tracerOptions++          attrs =+            [ (T.pack "code.function", Otel.toAttribute $ T.pack funName)+            , (T.pack "code.namespace", Otel.toAttribute $ T.pack modName)+            , (T.pack "code.filepath", Otel.toAttribute $ T.pack filePath)+            , (T.pack "code.lineno", Otel.toAttribute $ T.pack lineNum)+            , (T.pack "code.package", Otel.toAttribute $ T.pack pkgName)+            ]+#if MIN_VERSION_hs_opentelemetry_api(0,1,0)+          spanArgs = Otel.addAttributesToSpanArguments attrs Otel.defaultSpanArguments+       in Otel.inSpan tracer (T.pack funName) spanArgs body+#else+          spanArgs = Otel.defaultSpanArguments { Otel.attributes = attrs }+       in Otel.inSpan'' tracer [] (T.pack funName) spanArgs (const body)+#endif
+ test-config.toml view
@@ -0,0 +1,14 @@+targets = [+  { type = "constructor", value = "Instrumented" },+  { type = "constructor", value = "Partial ()" },+  { type = "constructor", value = "WildCard (Maybe _)" },+  { type = "constraints", value = ["InstrumentC"] },+  { type = "constraints", value = ["C1", "C2"] }+]++exclusions = [+  { type = "constructor", value = "NotInstrumented" },+  { type = "constraints", value = ["NoInstrumentC"] },+  { type = "constructor", value = "WildCardX (Maybe _)" },+  { type = "constraints", value = ["X1", "X2"] }+]
+ test/Main.hs view
@@ -0,0 +1,264 @@+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE OverloadedLists #-}+{-# LANGUAGE LambdaCase #-}+module Main (main) where++import           Data.Kind (Constraint)+import           Data.Text (Text)+import qualified Data.HashMap.Strict as H+import           OpenTelemetry.Attributes+import qualified OpenTelemetry.Context as Context+import           OpenTelemetry.Context.ThreadLocal+import           OpenTelemetry.Exporter.InMemory+import           OpenTelemetry.Trace+import           OpenTelemetry.Trace.Core+import           OpenTelemetry.Trace.Sampler+import           Test.Tasty+import           Test.Tasty.HUnit+import           UnliftIO hiding (getChanContents)++data SpanInfo = SpanInfo+  { name :: Text+  , parentName :: Maybe Text+  , attrs :: H.HashMap Text Attribute+  } deriving (Show, Eq)++mkSpanInfo :: ImmutableSpan -> IO SpanInfo+mkSpanInfo s = do+  parentSpan <- traverse unsafeReadSpan $ spanParent s+  pure SpanInfo+    { name = spanName s+    , parentName = spanName <$> parentSpan+    , attrs = H.delete "thread.id" . snd . getAttributes $ spanAttributes s+    }++withGlobalTracing :: (OutChan ImmutableSpan -> IO a) -> IO a+withGlobalTracing act = do+  _ <- attachContext Context.empty+  bracket+    initializeTracing+    (shutdownTracerProvider . fst)+    (\(_, ref) -> act ref)++initializeTracing :: IO (TracerProvider, OutChan ImmutableSpan)+initializeTracing = do+  (_, tracerOptions') <- getTracerProviderInitializationOptions++  (inMemoryProc, spansChan) <- inMemoryChannelExporter+  let processors' = [inMemoryProc]++  provider <-+    createTracerProvider+      processors'+      tracerOptions' {tracerProviderOptionsSampler = alwaysOn}+  setGlobalTracerProvider provider++  pure (provider, spansChan)++type Instrumented a = IO a++t1 :: Instrumented ()+t1 = do+  t2+  t3+  t2++t2 :: Instrumented ()+t2 = pure ()++t3 :: IO ()+t3 = pure ()++type NotInstrumented = IO++t4 :: NotInstrumented ()+t4 = t2++type InstrumentC :: Constraint+type InstrumentC = ()++t5 :: InstrumentC => IO ()+t5 = t2++type NoInstrumentC :: Constraint+type NoInstrumentC = ()++t6 :: NoInstrumentC => Instrumented ()+t6 = t2++type Partial a b = IO b++t7 :: Partial Bool ()+t7 = t2++t8 :: Partial () ()+t8 = t2++type WildCard = IO+type WildCardX = IO++t9 :: WildCard (Maybe Bool)+t9 = pure Nothing++t10 :: WildCard ()+t10 = pure ()++t11 :: WildCardX (Maybe Bool)+t11 = pure Nothing++type C1 :: Constraint+type C1 = ()++type C2 :: Constraint+type C2 = ()++t12 :: C1 => IO ()+t12 = pure ()++t13 :: (C1, C2) => IO ()+t13 = pure ()++type X1 :: Constraint+type X1 = ()++type X2 :: Constraint+type X2 = ()++t14 :: (C1, X1, C2, X2) => IO ()+t14 = pure ()++t15 :: (X1, X2) => Instrumented ()+t15 = pure ()++t16 :: X2 => Instrumented ()+t16 = pure ()++t17 :: a -> Instrumented a+t17 = pure++main :: IO ()+main =+  withGlobalTracing $ \spansChan -> do+    defaultMain (testTree spansChan)++testTree :: OutChan ImmutableSpan -> TestTree+testTree spansChan = testGroup "Tests"+  [ testCase "nested spans" (nestedSpans spansChan)+  , testCase "ignore excluded constructor" (excludedCon spansChan)+  , testCase "simple constraint rule" (simpleConstraint spansChan)+  , testCase "ignore excluded constraint" (excludeConstraint spansChan)+  , testCase "partially applied constructor rule" (partialCon spansChan)+  , testCase "rule with wildcard placeholder" (wildCard spansChan)+  , testCase "multi constraint rule" (multiPred spansChan)+  , testCase "multi constraint exclusion" (multiPredX spansChan)+  , testCase "point-free" (pointFree spansChan)+  ]++nestedSpans :: OutChan ImmutableSpan -> Assertion+nestedSpans spansChan = do+  t1+  spans <- getSpans spansChan+  spans @?=+    [ spanInfo "67" "t2" (Just "t1")+    , spanInfo "67" "t2" (Just "t1")+    , spanInfo "61" "t1" Nothing+    ]++excludedCon :: OutChan ImmutableSpan -> Assertion+excludedCon spansChan = do+  t4+  spans <- getSpans spansChan+  spans @?=+    [ spanInfo "67" "t2" Nothing+    ]++simpleConstraint :: OutChan ImmutableSpan -> Assertion+simpleConstraint spansChan = do+  t5+  spans <- getSpans spansChan+  spans @?=+    [ spanInfo "67" "t2" (Just "t5")+    , spanInfo "81" "t5" Nothing+    ]++excludeConstraint :: OutChan ImmutableSpan -> Assertion+excludeConstraint spansChan = do+  t6+  spans <- getSpans spansChan+  spans @?=+    [ spanInfo "67" "t2" Nothing ]++partialCon :: OutChan ImmutableSpan -> Assertion+partialCon spansChan = do+  t7+  t8+  spans <- getSpans spansChan+  spans @?=+    [ spanInfo "67" "t2" Nothing+    , spanInfo "67" "t2" (Just "t8")+    , spanInfo "95" "t8" Nothing+    ]++wildCard :: OutChan ImmutableSpan -> Assertion+wildCard spansChan = do+  _ <- t9+  t10+  _ <- t11+  spans <- getSpans spansChan+  spans @?=+    [ spanInfo "101" "t9" Nothing ]++multiPred :: OutChan ImmutableSpan -> Assertion+multiPred spansChan = do+  t12+  t13+  spans <- getSpans spansChan+  spans @?=+    [ spanInfo "119" "t13" Nothing ]++multiPredX :: OutChan ImmutableSpan -> Assertion+multiPredX spansChan = do+  t14+  t15+  t16+  spans <- getSpans spansChan+  spans @?=+    [ spanInfo "134" "t16" Nothing ]++pointFree :: OutChan ImmutableSpan -> Assertion+pointFree spansChan = do+  t17 ()+  spans <- getSpans spansChan+  spans @?=+    [ spanInfo "137" "t17" Nothing ]++spanInfo :: Text -> Text -> Maybe Text -> SpanInfo+spanInfo lineNo funName mParentName =+  SpanInfo+    { name = funName+    , parentName = mParentName+    , attrs =+      [ ("code.lineno", AttributeValue (TextAttribute lineNo))+      , ("code.filepath", AttributeValue (TextAttribute "test/Main.hs"))+      , ("code.function", AttributeValue (TextAttribute funName))+      , ("code.namespace", AttributeValue (TextAttribute "Main"))+      , ("code.package", AttributeValue (TextAttribute "main"))+      ]+    }++getSpans :: OutChan ImmutableSpan -> IO [SpanInfo]+getSpans chan = do+  (element, _) <- tryReadChan chan+  tryRead element >>= \case+    Nothing -> do+      addPlaceholderSpan+      pure []+    Just e -> do+      si <- mkSpanInfo e+      (si :) <$> getSpans chan++addPlaceholderSpan :: IO ()+addPlaceholderSpan = do+  tp <- getGlobalTracerProvider+  let tracer = makeTracer tp "test" tracerOptions+  inSpan tracer "_placeholder_" defaultSpanArguments $ pure ()