diff --git a/CHANGELOG.md b/CHANGELOG.md new file mode 100644 --- /dev/null +++ b/CHANGELOG.md @@ -0,0 +1,3 @@ +# 1.0.0 + +- Initial release diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,30 @@ +Copyright (c) 2023, Mercury Technologies + +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 Mercury Technologies 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,66 @@ +# `opentelemetry-plugin` - a GHC plugin for open telemetry + +This GHC plugin lets you export granular open telemetry metrics for your Haskell +builds. Specifically, this creates a trace with: + +- One span for each module build +- One sub-span for each phase of each module build + +![Example trace generated by this GHC plugin](https://user-images.githubusercontent.com/1313787/272098736-1d1e4e7b-4122-45be-8f7b-e74f2ccddab0.png) + +Note that due to limitations of GHC's `Plugin` interface the root span generated +by this plugin will have a duration of 0 (by default) and will not be the +correct duration (for the entire build). However, the `Plugin` will reuse any +surrounding span inherited via +[the standard `TRACEPARENT` and `TRACESTATE` environment variables](https://www.w3.org/TR/trace-context/), +so if you wrap your build in something like the `hotel` executable (from +[the `hotel-california` package](https://github.com/parsonsmatt/hotel-california)) +then you will get the correct duration for the outermost span. + +This plugin also supports +[the standard `BAGGAGE` environment variable](https://www.w3.org/TR/baggage/), +too. + +To use this plugin: + +- add the `opentelemetry-plugin` package as a build dependency of your package + +- add `ghc-options: -fplugin OpenTelemetry.Plugin` to your package + +- configure the appropriate open telemetry environment variables + + In other words, you'll probably want to set at least + `OTEL_EXPORTER_OTLP_ENDPOINT` and maybe other environment variables depending + on your open telemetry backend. For example, if you're using + [Honeycomb](https://docs.honeycomb.io/getting-data-in/opentelemetry-overview/#using-the-honeycomb-opentelemetry-endpoint) + then you'd also want to set `OTEL_EXPORTER_OTLP_HEADERS` and + `OTEL_SERVICE_NAME`. + +Then any time you build your project the build will export open telemetry +metrics. The overhead of metrics export is negligible. + +## Development + +This repository uses Nix for development. You can build this package entirely +using Nix for a specific version of `ghc` by running: + +```ShellSession +$ nix develop .#ghc${MAJOR}${MINOR} +``` + +… replacing `${MAJOR}` and `${MINOR}` with the major and minor version of the +`ghc` that you're using. For example, if you're using GHC 9.4, then you'd run: + +```ShellSession +$ nix build .#ghc94 +``` + +If you want to develop interactively using Cabal inside of a Nix shell, run: + +```ShellSession +$ nix develop .#ghc${MAJOR}${MINOR} +``` + +Once you are inside that Nix shell, then you can use `cabal` commands, like +`cabal build` or `cabal repl`. You can also use `ghcid` or launch your favorite +IDE from inside this shell. diff --git a/opentelemetry-plugin.cabal b/opentelemetry-plugin.cabal new file mode 100644 --- /dev/null +++ b/opentelemetry-plugin.cabal @@ -0,0 +1,31 @@ +cabal-version: 3.0 +name: opentelemetry-plugin +version: 1.0.0 +synopsis: GHC plugin for open telemetry +description: This package provides a GHC plugin that exports each module's build times to an open telemetry collector. See the included `README` below for more details. +license: BSD-3-Clause +license-file: LICENSE +author: Mercury Technologies +maintainer: gabriella@mercury.com +copyright: 2023 Mercury Technologies +build-type: Simple +extra-doc-files: CHANGELOG.md README.md + +library + hs-source-dirs: src + exposed-modules: OpenTelemetry.Plugin + build-depends: base >=4.15.0.0 && < 5 + , bytestring + , containers + , ghc >= 9.2 && < 9.8 + , hs-opentelemetry-api >= 0.1.0.0 && < 0.2 + , hs-opentelemetry-propagator-w3c + , hs-opentelemetry-sdk >= 0.0.3.0 && < 0.1 + , mwc-random >= 0.13.1.0 + , text + , unordered-containers + other-modules: OpenTelemetry.Plugin.Shared + , Paths_opentelemetry_plugin + autogen-modules: Paths_opentelemetry_plugin + default-language: Haskell2010 + ghc-options: -Wall diff --git a/src/OpenTelemetry/Plugin.hs b/src/OpenTelemetry/Plugin.hs new file mode 100644 --- /dev/null +++ b/src/OpenTelemetry/Plugin.hs @@ -0,0 +1,123 @@ +{-# LANGUAGE BlockArguments #-} +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE OverloadedStrings #-} + +{-| This module provides a GHC plugin that will export open telemetry metrics + for your build. Specifically, this plugin will create one span per module + (recording how long that module took to build) and one sub-span per phase + of that module's build (recording how long that phase took). +-} +module OpenTelemetry.Plugin + ( -- * Plugin + plugin + ) where + +import Control.Monad.IO.Class (MonadIO(..)) +import GHC.Types.Target (Target(..), TargetId(..)) +import OpenTelemetry.Context (Context) + +import GHC.Plugins + ( CoreToDo(..) + , GenModule(..) + , HscEnv(..) + , Plugin(..) + ) +import qualified Control.Monad as Monad +import qualified Data.Text as Text +import qualified GHC.Plugins as Plugins +import qualified GHC.Utils.Outputable as Outputable +import qualified OpenTelemetry.Plugin.Shared as Shared + +wrapTodo :: MonadIO io => IO Context -> CoreToDo -> io CoreToDo +wrapTodo getParentContext todo = + case todo of + CoreDoPasses passes -> + fmap CoreDoPasses (traverse (wrapTodo getParentContext) passes) + + _ -> liftIO do + let sdoc = Outputable.ppr todo + + let label = + Outputable.showSDocOneLine Outputable.defaultSDocContext sdoc + + (_, beginPass, endPass) <- do + Shared.makeWrapperPluginPasses False getParentContext (Text.pack label) + + let beginPluginPass = + CoreDoPluginPass ("begin " <> label) \modGuts -> liftIO do + beginPass + + pure modGuts + + let endPluginPass = + CoreDoPluginPass ("end " <> label) \modGuts -> liftIO do + endPass + + pure modGuts + + pure (CoreDoPasses [ beginPluginPass, todo, endPluginPass ]) + +-- | GHC plugin that exports open telemetry metrics about the build +plugin :: Plugin +plugin = + Plugins.defaultPlugin + { driverPlugin + , pluginRecompile + , installCoreToDos + } + where + driverPlugin _ hscEnv@HscEnv{ hsc_targets } = do + let rootModuleNames = do + Target{ targetId = TargetModule rootModuleName } <- hsc_targets + + pure (Plugins.moduleNameString rootModuleName) + + Shared.setRootModuleNames rootModuleNames + + Shared.initializeTopLevelContext + + pure hscEnv + + installCoreToDos _ todos = do + module_ <- Plugins.getModule + + let moduleName_ = moduleName module_ + + let moduleText = Text.pack (Plugins.moduleNameString moduleName_) + + (getCurrentContext, firstPluginPass, lastPluginPass) <- do + liftIO (Shared.makeWrapperPluginPasses True Shared.getTopLevelContext moduleText) + + let firstPass = + CoreDoPluginPass "begin module" \modGuts -> liftIO do + firstPluginPass + + pure modGuts + + let lastPass = + CoreDoPluginPass "end module" \modGuts -> liftIO do + lastPluginPass + + isRoot <- Shared.isRootModule (Plugins.moduleNameString moduleName_) + + -- Flush metrics if we're compiling one of the root + -- modules. This is to work around the fact that we don't + -- have a proper way to finalize the `TracerProvider` + -- (since the finalizer would normally be responsible for + -- flushing any last metrics). + -- + -- You might wonder: why don't we end the top-level span + -- here? Well, we don't know which one of the root modules + -- will be the last one to be compiled. However, flushing + -- once per root module is still fine because flushing is + -- safe to run at any time and in practice there will only + -- be a few root modules. + Monad.when isRoot Shared.flush + + pure modGuts + + newTodos <- traverse (wrapTodo getCurrentContext) todos + + pure ([ firstPass ] <> newTodos <> [ lastPass ]) + + pluginRecompile = Plugins.purePlugin diff --git a/src/OpenTelemetry/Plugin/Shared.hs b/src/OpenTelemetry/Plugin/Shared.hs new file mode 100644 --- /dev/null +++ b/src/OpenTelemetry/Plugin/Shared.hs @@ -0,0 +1,328 @@ +{-# LANGUAGE BlockArguments #-} +{-# LANGUAGE OverloadedStrings #-} + +{-| This module provides the GHC-API-agnostic logic for this plugin (mostly + open telemetry utilities) + + Because of how GHC plugins work, this module has to do some evil stuff + under the hood to work within the confines of the plugin API. That means + that you should take care to use the utilities in this module correctly + in order to avoid the plugin hanging. +-} +module OpenTelemetry.Plugin.Shared + ( -- * Plugin passes + makeWrapperPluginPasses + + -- * Top-level context + , initializeTopLevelContext + , getTopLevelContext + + -- * Root module names + , setRootModuleNames + , isRootModule + + -- * Flushing + , flush + + , getSampler + ) where + +import Control.Concurrent.MVar (MVar) +import Control.Monad.IO.Class (liftIO) +import Data.ByteString (ByteString) +import Data.Set (Set) +import Data.Text (Text) +import OpenTelemetry.Context (Context) +import OpenTelemetry.Trace.Sampler (Sampler(..), SamplingResult(..)) +import Prelude hiding (span) +import System.Random.MWC (GenIO) + +import OpenTelemetry.Trace + ( Attribute(..) + , PrimitiveAttribute(..) + , InstrumentationLibrary(..) + , Span + , SpanArguments(..) + , SpanContext(..) + , Tracer + , TracerProvider + , TracerProviderOptions(..) + ) + +import qualified Control.Concurrent.MVar as MVar +import qualified Data.HashMap.Strict as HashMap +import qualified Data.Set as Set +import qualified Data.Text as Text +import qualified Data.Text.Encoding as Text.Encoding +import qualified Data.Version as Version +import qualified OpenTelemetry.Context as Context +import qualified OpenTelemetry.Propagator.W3CBaggage as W3CBaggage +import qualified OpenTelemetry.Propagator.W3CTraceContext as W3CTraceContext +import qualified OpenTelemetry.Trace as Trace +import qualified OpenTelemetry.Trace.Core as Trace.Core +import qualified OpenTelemetry.Trace.Sampler as Sampler +import qualified OpenTelemetry.Trace.TraceState as TraceState +import qualified Paths_opentelemetry_plugin as Paths +import qualified System.Environment as Environment +import qualified System.IO.Unsafe as Unsafe +import qualified System.Random.MWC as MWC +import qualified Text.Read as Read + +{-| Very large Haskell builds can generate an enormous number of spans, + but none of the stock samplers provide a way to sample a subset of + the `Span`s within a trace. + + This adds a new "spanratio" sampler which can be used to sample subset of + module spans. +-} +getSampler :: IO (Maybe Sampler) +getSampler = do + maybeSampler <- Environment.lookupEnv "OTEL_TRACES_SAMPLER" + + maybeRatio <- Environment.lookupEnv "OTEL_TRACES_SAMPLER_ARG" + + pure do + "spanratio" <- maybeSampler + ratioString <- maybeRatio + ratio <- Read.readMaybe ratioString + pure (spanRatioBased ratio) + +{-| Like a lot of other uses of `Unsafe.unsafePerformIO` in this module, we're + doing this because the plugin interface doesn't provide a way for us to + acquire resources before returning the plugin. +-} +generator :: GenIO +generator = Unsafe.unsafePerformIO MWC.createSystemRandom +{-# NOINLINE generator #-} + +spanRatioBased :: Double -> Sampler +spanRatioBased fraction = Sampler + { getDescription = + "SpanRatioBased{" <> Text.pack (show fraction) <> "}" + , shouldSample = \context traceId_ name spanArguments -> do + case HashMap.lookup "sample" (attributes spanArguments) of + Just (AttributeValue (BoolAttribute True)) -> do + random <- MWC.uniformR (0, 1) generator + + let samplingResult = + if random < fraction then RecordAndSample else Drop + + traceState_ <- case Context.lookupSpan context of + Nothing -> + pure TraceState.empty + + Just span -> + fmap traceState (Trace.Core.getSpanContext span) + + pure (samplingResult, HashMap.empty, traceState_) + + _ -> + shouldSample Sampler.alwaysOn context traceId_ name spanArguments + } + +{-| Note: We don't properly shut this down using `Trace.shutdownTracerProvider`, + but all that the shutdown does is flush metrics, so instead we flush metrics + (using `flush`) at the end of compilation to make up for the lack of a + proper shutdown. +-} +tracerProvider :: TracerProvider +tracerProvider = Unsafe.unsafePerformIO do + (processors, options) <- Trace.getTracerProviderInitializationOptions + + maybeSampler <- getSampler + + let newOptions = + case maybeSampler of + Nothing -> options + Just sampler -> options{ tracerProviderOptionsSampler = sampler } + + tracerProvider_ <- Trace.createTracerProvider processors newOptions + + Trace.setGlobalTracerProvider tracerProvider_ + + pure tracerProvider_ +{-# NOINLINE tracerProvider #-} + +tracer :: Tracer +tracer = + Trace.makeTracer tracerProvider instrumentationLibrary Trace.tracerOptions + where + instrumentationLibrary = + InstrumentationLibrary + { libraryName = "opentelemetry-plugin" + , libraryVersion = Text.pack (Version.showVersion Paths.version) + } + +{-| This used by the GHC plugin to create two plugin passes that start and stop + a `Span`, respectively. + + In order for `Span` ancestry to be tracked correctly this takes an + @`IO` `Context`@ as an input (to read the parent `Span`'s `Context`) and + returns an @`IO` `Context`@ as an output (to read the current `Span`'s + `Context`). +-} +makeWrapperPluginPasses + :: Bool + -- ^ Whether to sample a subset of spans + -> IO Context + -- ^ Action to ead the parent span's `Context` + -> Text + -- ^ Label for the current span + -> IO (IO Context, IO (), IO ()) +makeWrapperPluginPasses sample getParentContext label = liftIO do + spanMVar <- liftIO MVar.newEmptyMVar + currentContextMVar <- liftIO MVar.newEmptyMVar + + let beginPass = do + parentContext <- getParentContext + + let spanArguments = + if sample + then + Trace.defaultSpanArguments + { attributes = + HashMap.singleton "sample" (AttributeValue (BoolAttribute True)) + } + else + Trace.defaultSpanArguments + + passSpan <- Trace.createSpan tracer parentContext label spanArguments + + _ <- MVar.tryPutMVar spanMVar passSpan + + let currentContext = Context.insertSpan passSpan parentContext + + _ <- MVar.tryPutMVar currentContextMVar currentContext + + pure () + + let endPass = do + passSpan <- MVar.readMVar spanMVar + + Trace.endSpan passSpan Nothing + + pure (MVar.readMVar currentContextMVar, beginPass, endPass) + +{-| We're intentionally **NOT** using `OpenTelemetry.Context.ThreadLocal` + here since the `GHC.Plugins.Plugin` logic doesn't necessarily run in a + single thread (@ghc@ builds can be multi-threaded). Instead, we provide + our own `Context` global variable. +-} +topLevelContextMVar :: MVar Context +topLevelContextMVar = Unsafe.unsafePerformIO MVar.newEmptyMVar +{-# NOINLINE topLevelContextMVar #-} + +getTopLevelSpan :: IO Span +getTopLevelSpan = do + traceParent <- lookupEnv "TRACEPARENT" + traceState_ <- lookupEnv "TRACESTATE" + + case W3CTraceContext.decodeSpanContext traceParent traceState_ of + Just spanContext -> + pure (Trace.Core.wrapSpanContext spanContext) + + Nothing -> do + -- If we're not inheriting a span from + -- `TRACEPARENT`/`TRACESTATE`, then create a zero-duration span + -- whose sole purpose is to be a parent span for each module's + -- spans. + -- + -- Ideally we'd like this span's duration to last for the + -- entirety of compilation, but there isn't a good way to end + -- the span when compilation is done. Also, we still need + -- *some* parent span for each module's spans, otherwise an + -- entirely new trace will be created for each new span. + -- Creating a zero-duration span is the least-worst solution. + -- + -- Note that there aren't any issues with the child spans + -- lasting longer than the parent span. This is supported by + -- open telemetry and the Haskell API. + timestamp <- Trace.Core.getTimestamp + + let arguments = + Trace.defaultSpanArguments + { startTime = Just timestamp } + + span <- Trace.createSpan tracer Context.empty "opentelemetry GHC plugin" arguments + + Trace.endSpan span (Just timestamp) + + pure span + +getTopLevelBaggage :: IO Context +getTopLevelBaggage = do + maybeBytes <- lookupEnv "BAGGAGE" + case maybeBytes >>= W3CBaggage.decodeBaggage of + Nothing -> pure Context.empty + Just baggage -> pure (Context.insertBaggage baggage Context.empty) + +lookupEnv :: String -> IO (Maybe ByteString) +lookupEnv = fmap (fmap (fmap encode)) Environment.lookupEnv + where + encode = Text.Encoding.encodeUtf8 . Text.pack + +{-| This initializes the top-level `Context` using the @TRACEPARENT@ \/ + @TRACESTATE@ \/ @BAGGAGE@ environment variables (if present) and otherwise + sets it to the empty `Context` + + You have to run this command before calling `getTopLevelContext` otherwise + the latter will hang. +-} +initializeTopLevelContext :: IO () +initializeTopLevelContext = do + span <- getTopLevelSpan + + context <- getTopLevelBaggage + + let contextWithSpan = Context.insertSpan span context + + _ <- MVar.tryPutMVar topLevelContextMVar contextWithSpan + + return () + +-- | Access the top-level `Context` computed by `initializeTopLevelContext` +getTopLevelContext :: IO Context +getTopLevelContext = MVar.readMVar topLevelContextMVar + +{-| This is used for communicating between `GHC.Plugins.driverPlugin` and + `GHC.Plugins.installCoreToDos`, because only `GHC.Plugins.driverPlugin` has + access to the full module graph, but there isn't a good way within the + `GHC.Plugins.Plugin` API to share that information with the rest of the + plugin other than a global variable. +-} +rootModuleNamesMVar :: MVar (Set Text) +rootModuleNamesMVar = Unsafe.unsafePerformIO MVar.newEmptyMVar +{-# NOINLINE rootModuleNamesMVar #-} + +{-| Set the root module names (computed by `GHC.Plugins.driverPlugin`) + + You have to run this command before calling `isRootModule` otherwise + the latter will hang. +-} +setRootModuleNames :: [String] -> IO () +setRootModuleNames rootModuleNames = do + let set = Set.fromList (map Text.pack rootModuleNames) + + _ <- MVar.tryPutMVar rootModuleNamesMVar set + + pure () + +-- | Check if a module is one of the root modules +isRootModule :: String -> IO Bool +isRootModule moduleName = do + rootModuleNames <- MVar.readMVar rootModuleNamesMVar + + pure (Set.member (Text.pack moduleName) rootModuleNames) + +-- | Flush all metrics +flush :: IO () +flush = do + _ <- Trace.Core.forceFlushTracerProvider tracerProvider Nothing + -- We can't check the result yet because + -- `FlushResult` is not exported by + -- `hs-opentelemetry-api` + -- + -- https://github.com/iand675/hs-opentelemetry/pull/96 + _ <- Trace.Core.forceFlushTracerProvider tracerProvider Nothing + + pure ()