diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -1,3 +1,24 @@ +### 0.9.0.0 + +- Add support for the following OTLP exporter configuration options: + - `OTEL_EXPORTER_OTLP_TIMEOUT` (full support with both `grpc` and `http/protobuf`) + - `OTEL_EXPORTER_OTLP_COMPRESSION` (full support with both `grpc` and `http/protobuf`) + - `OTEL_EXPORTER_OTLP_CLIENT_KEY` (not parsed, as mTLS is unsupported) + - `OTEL_EXPORTER_OTLP_CLIENT_CERTIFICATE` (not parsed, as mTLS is unsupported) + +- Add support for `console` exporter (e.g., via `OTEL_METRICS_EXPORTER=console`). + +- Add support for HTTP proxy environment variables (`http_proxy` and `https_proxy`) + when using HTTP/Protobuf exporter. + +- Fix bug where `OTEL_EXPORTER_OTLP_INSECURE` applied to `http/protobuf` exporters. + +- Fix bug where `OTEL_EXPORTER_OTLP_ENDPOINT` accepted URLs without scheme for `http/protobuf` exporters. + +- Fix bug where `writeLog` shows in the backtraces for error messages. + +- Add documentation for OpenTelemetry environment variables to command-line `--help`. + ### 0.8.0.0 The version 0.7.0.0 was skipped to avoid confusion with `eventlog-live-otelcol-0.7.0.0`. diff --git a/README.md b/README.md --- a/README.md +++ b/README.md @@ -11,9 +11,9 @@ Eventlog Live analyses the [eventlog](https://ghc.gitlab.haskell.org/ghc/doc/users_guide/runtime_control.html#rts-eventlog) of any Haskell program and streams the resulting telemetry data to any observability platform that supports the OpenTelemetry protocol, such as [Grafana Cloud](https://grafana.com), [HoneyComb](https://www.honeycomb.io/), or [Prometheus](https://prometheus.io/docs/guides/opentelemetry/). -The following shows the Grafana Heap Profiles dashboard for [`oddball`](examples/oddball/oddball-with-pipe.sh) running with _zero instrumentation_. +The following shows the Grafana Heap Profiles dashboard for [`oddball`](https://github.com/well-typed/eventlog-live/blob/eventlog-live-v0.9.0.0/examples/oddball/oddball-with-pipe.sh) running with _zero instrumentation_. -![A screen recording of the Grafana Heap Profiles dashboard for the oddball example program.](https://github.com/well-typed/eventlog-live/blob/3bf7a7e09219bd469e1f5a354094a5a18a753138/assets/oddball-with-pipe-2026-07-31.gif?raw=true) +![A screen recording of the Grafana Heap Profiles dashboard for the oddball example program.](https://github.com/well-typed/eventlog-live/blob/eventlog-live-v0.9.0.0/assets/oddball-with-pipe-2026-07-31.gif?raw=true) Eventlog Live is designed to be _lightweight_, running alongside your application using only in a few megabytes of memory, and _highly configurable_, so that you only send the telemetry data you are interested in. While Eventlog Live works with zero instrumentation, it has support for several Haskell profiling packages that can enable new features. @@ -21,9 +21,9 @@ The [`eventlog-socket`](https://github.com/well-typed/eventlog-socket) package adds two features. First, it lets you to stream the eventlog over Unix domain and TCP/IP sockets. Secondly, it lets you control your program from the observability dashboard. The `eventlog-socket` instrumentation has builtin support that lets you toggle RTS features such as heap and stack profiling at runtime, but its control protocol has an easy-to-use plugin mechanism that lets you integrate other actions into your telemetry platform. - The following shows dynamic control of heap profiling from the Grafana Heap Profiles dashboard for [`oddball`](examples/oddball/oddball-with-hT.sh) instrumented with `eventlog-socket`. When the _Stop_ button is pressed, the heap profiling is stopped, and the heap profile flatlines. When the _Start_ button is pressed, heap profiling is restarted. + The following shows dynamic control of heap profiling from the Grafana Heap Profiles dashboard for [`oddball`](https://github.com/well-typed/eventlog-live/blob/eventlog-live-v0.9.0.0/examples/oddball/oddball-with-hT.sh) instrumented with `eventlog-socket`. When the _Stop_ button is pressed, the heap profiling is stopped, and the heap profile flatlines. When the _Start_ button is pressed, heap profiling is restarted. - ![A screen recording of the Grafana Heap Profiles dashboard for the oddball example program that shows dynamic control of heap profiling.](https://github.com/well-typed/eventlog-live/blob/3bf7a7e09219bd469e1f5a354094a5a18a753138/assets/oddball-control-2026-07-31.gif?raw=true) + ![A screen recording of the Grafana Heap Profiles dashboard for the oddball example program that shows dynamic control of heap profiling.](https://github.com/well-typed/eventlog-live/blob/eventlog-live-v0.9.0.0/assets/oddball-control-2026-07-31.gif?raw=true) - **GHC Stack Profiler – Lightweight Call-Stack Profiles** @@ -31,13 +31,13 @@ The lightweight call-stack sampler has an approximate 5-10% overhead while running with a sampling interval of 10ms, whereas [GHC's builtin cost-centre profiling](https/downloads.haskell.org/ghc/latest/docs/users_guide/profiling.html#time-and-allocation-profiling) has an approximate 50% overhead for the instrumentation alone, i.e., prior to any cost-centres and without sampling. - The following shows the Grafana Call-Stack Profiles dashboard for [`jumpy-jump`](examples/jumpy-jump/jumpy-jump-with-ghc-stack-profiler.sh) instrumented with `ghc-stack-profiler`. + The following shows the Grafana Call-Stack Profiles dashboard for [`jumpy-jump`](https://github.com/well-typed/eventlog-live/blob/eventlog-live-v0.9.0.0/examples/jumpy-jump/jumpy-jump-with-ghc-stack-profiler.sh) instrumented with `ghc-stack-profiler`. - ![A screen recording of the Grafana Call-Stack Profiles dashboard for the jumpy-jump example program.](https://github.com/well-typed/eventlog-live/blob/3bf7a7e09219bd469e1f5a354094a5a18a753138/assets/jumpy-jump-with-ghc-stack-profiler-2026-07-31.gif?raw=true) + ![A screen recording of the Grafana Call-Stack Profiles dashboard for the jumpy-jump example program.](https://github.com/well-typed/eventlog-live/blob/eventlog-live-v0.9.0.0/assets/jumpy-jump-with-ghc-stack-profiler-2026-07-31.gif?raw=true) ## Demos -The [`demo`](demo/) directory contains a [Docker Compose](https://docs.docker.com/compose/) configuration that runs Grafana and all required data sources and opens an OTLP gRPC receiver on port 4317. This configuration is used in [Getting Started](#getting-started) and by the various scripts under the [`examples`](examples/) directory. +The [`demo`](demo/) directory contains a [Docker Compose](https://docs.docker.com/compose/) configuration that runs Grafana and all required data sources and opens an OTLP gRPC receiver on port 4317. This configuration is used in [Getting Started](#getting-started) and by the various scripts under the [`examples`](https://github.com/well-typed/eventlog-live/blob/eventlog-live-v0.9.0.0/examples/) directory. You can import the dashboards under [`demo/config/grafana-dashboards`](demo/config/grafana-dashboards/) into your Grafana setup, but beware that you'll have to change the variables and visualisations to use your data sources and change the buttons to use your control server. The dashboards under [`demo-grafana-cloud`](demo-grafana-cloud/grafana-dashboards/) were prepared to be shared with other Grafana instances. @@ -143,17 +143,17 @@ You should be greeted by a dashboard that looks something like this: - ![A screen recording of the Grafana Heap Profiles dashboard for the oddball example program.](https://github.com/well-typed/eventlog-live/blob/3bf7a7e09219bd469e1f5a354094a5a18a753138/assets/oddball-with-pipe-2026-07-31.gif?raw=true) + ![A screen recording of the Grafana Heap Profiles dashboard for the oddball example program.](https://github.com/well-typed/eventlog-live/blob/eventlog-live-v0.9.0.0/assets/oddball-with-pipe-2026-07-31.gif?raw=true) - Select '☰ > Dashboards > Logs' You should be greeted by a dashboard that looks something like this: - ![A screen capture of the Grafana Logs dashboard for the oddball example program.](https://github.com/well-typed/eventlog-live/blob/3bf7a7e09219bd469e1f5a354094a5a18a753138/assets/oddball-with-pipe-logs-2026-07-31.png?raw=true) + ![A screen capture of the Grafana Logs dashboard for the oddball example program.](https://github.com/well-typed/eventlog-live/blob/eventlog-live-v0.9.0.0/assets?raw=true/oddball-with-pipe-logs-2026-07-31.png) This dashboard will include a separate tab that shows the logs for `eventlog-live-otlp`: - ![A screen capture of the Grafana Logs dashboard for the eventlog-live-otlp program for oddball.](https://github.com/well-typed/eventlog-live/blob/3bf7a7e09219bd469e1f5a354094a5a18a753138/assets/eventlog-live-otlp-for-oddball-with-pipe-logs-2026-07-31.png?raw=true) + ![A screen capture of the Grafana Logs dashboard for the eventlog-live-otlp program for oddball.](https://github.com/well-typed/eventlog-live/blob/eventlog-live-v0.9.0.0/assets/eventlog-live-otlp-for-oddball-with-pipe-logs-2026-07-31.png?raw=true) Let's briefly discuss what this script does: @@ -319,7 +319,7 @@ If you run these commands, you should be greeted by a dashboard that looks something like this: -![A screen recording of the Grafana Heap Profiles dashboard for the oddball example program that shows dynamic control of heap profiling.](https://github.com/well-typed/eventlog-live/blob/3bf7a7e09219bd469e1f5a354094a5a18a753138/assets/oddball-control-2026-07-31.gif?raw=true) +![A screen recording of the Grafana Heap Profiles dashboard for the oddball example program that shows dynamic control of heap profiling.](https://github.com/well-typed/eventlog-live/blob/eventlog-live-v0.9.0.0/assets/oddball-control-2026-07-31.gif?raw=true) The Start and Stop buttons can now be used to enable/disable Heap Profiling and the Census button can now be used to request a single heap census. @@ -414,7 +414,7 @@ You should be greeted by a dashboard that looks something like this: - ![A screen capture of the Grafana Cost-Centre Stack Profiles dashboard for the jumpy-jump example program.](https://github.com/well-typed/eventlog-live/blob/3bf7a7e09219bd469e1f5a354094a5a18a753138/assets/jumpy-jump-with-cost-centre-profiler-2026-07-31.png?raw=true) + ![A screen capture of the Grafana Cost-Centre Stack Profiles dashboard for the jumpy-jump example program.](https://github.com/well-typed/eventlog-live/blob/eventlog-live-v0.9.0.0/assets/jumpy-jump-with-cost-centre-profiler-2026-07-31.png?raw=true) If your application is instrumented with Eventlog Socket, the Start and Stop buttons should enable/disable cost-centre stack profiling. @@ -502,7 +502,7 @@ If you run these commands, you should be greeted by a dashboard that looks something like this: -![A screen recording of the Grafana Heap Profiles dashboard for the oddball example program using Heap Profiling by Info Table.](https://github.com/well-typed/eventlog-live/blob/3bf7a7e09219bd469e1f5a354094a5a18a753138/assets/oddball-with-hi-2026-07-31.gif?raw=true) +![A screen recording of the Grafana Heap Profiles dashboard for the oddball example program using Heap Profiling by Info Table.](https://github.com/well-typed/eventlog-live/blob/eventlog-live-v0.9.0.0/assets/oddball-with-hi-2026-07-31.gif?raw=true) Notably, your Heap Profile should show Info Table information. If you ran Heap Profiles with different breakdowns, you can select the appropriate breakdown in the Heap Profile Breakdown dropdown menu. @@ -590,7 +590,7 @@ You should be greeted by a dashboard that looks something like this: - ![A screen recording of the Grafana Call-Stack Profiles dashboard for the jumpy-jump example program.](https://github.com/well-typed/eventlog-live/blob/3bf7a7e09219bd469e1f5a354094a5a18a753138/assets/jumpy-jump-with-ghc-stack-profiler-2026-07-31.gif?raw=true) + ![A screen recording of the Grafana Call-Stack Profiles dashboard for the jumpy-jump example program.](https://github.com/well-typed/eventlog-live/blob/eventlog-live-v0.9.0.0/assets/jumpy-jump-with-ghc-stack-profiler-2026-07-31.gif?raw=true) If your application is instrumented with Eventlog Socket, the Start and Stop buttons should enable/disable call-stack profiling. diff --git a/data/help.footer.txt b/data/help.footer.txt new file mode 100644 --- /dev/null +++ b/data/help.footer.txt @@ -0,0 +1,35 @@ +OpenTelemetry options: + + OTEL_LOG_LEVEL Log level used by Eventlog Live's internal logger. Defaults to "info". + OTEL_SERVICE_NAME Sets the value of the service.name resource attribute. + + If service.name is also provided in OTEL_RESOURCE_ATTRIBUTES, then OTEL_SERVICE_NAME takes precedence. + OTEL_RESOURCE_ATTRIBUTES Key-value pairs to be used as resource attributes. + + https://opentelemetry.io/docs/specs/otel/configuration/sdk-environment-variables/#general-sdk-configuration + +OpenTelemetry Exporter selection: + + OTEL_LOGS_EXPORTER Logs exporter to be used. + OTEL_METRICS_EXPORTER Metrics exporter to be used. + OTEL_PROFILES_EXPORTER Profiles exporter to be used. + OTEL_TRACES_EXPORTER Trace exporter to be used. + + Each option supports the values "console", "none" and "otlp" and defaults to "otlp". + + https://opentelemetry.io/docs/specs/otel/configuration/sdk-environment-variables/#exporter-selection + +OpenTelemetry OTLP Exporter options: + + OTEL_EXPORTER_OTLP_PROTOCOL The OTLP transport protocol. Defaults to "http/protobuf". Supported values are "http/protobuf" for protobuf-encoded data over HTTP connection and "grpc" for protobuf-encoded data using gRPC wire format over HTTP/2 connection. + OTEL_EXPORTER_OTLP_ENDPOINT Target to which the exporter is going to send telemetry data. A scheme of "https" indicates a secure connection and takes precendence over the insecure option. Defaults to "http://localhost:4318" if the OTLP transport protocol is "http/protobuf" and to "http://localhost:4317" if the OTLP transport protocol is "grpc". + OTEL_EXPORTER_OTLP_INSECURE Whether to enable client transport security for the exporter's gRPC connection. Defaults to "false". + OTEL_EXPORTER_OTLP_CERTIFICATE The trusted certificate to use when verifying a server's TLS credentials. Should only be used for a secure connection. + OTEL_EXPORTER_OTLP_HEADERS Key-value pairs to be used as headers associated with HTTP requests. + N.B. This setting is only respected if the OTLP transport protocol is "http/protobuf". + OTEL_EXPORTER_OTLP_COMPRESSION The compression algorithm to be used by gRPC and HTTP requests. Supported values are "none" and "gzip". Defaults to "none". + OTEL_EXPORTER_OTLP_TIMEOUT The maximum time the OTLP exporter will wait for each batch export. Specified in milliseconds. A value of "0" means no timeout. Defaults to 10 seconds. + + Each option also supports signal-specific variants that only apply to the exporter for that specific signal. For instance, the signal-specific variants for OTEL_EXPORTER_OTLP_ENDPOINT are OTEL_EXPORTER_OTLP_LOGS_ENDPOINT, OTEL_EXPORTER_OTLP_METRICS_ENDPOINT, OTEL_EXPORTER_OTLP_PROFILES_ENDPOINT, and OTEL_EXPORTER_OTLP_TRACES_ENDPOINT. + + https://opentelemetry.io/docs/specs/otel/protocol/exporter/ diff --git a/data/help.header.txt b/data/help.header.txt new file mode 100644 --- /dev/null +++ b/data/help.header.txt diff --git a/data/help.progDesc.txt b/data/help.progDesc.txt new file mode 100644 --- /dev/null +++ b/data/help.progDesc.txt @@ -0,0 +1,27 @@ +Use eventlog-live-otlp to export eventlog telemetry to an OTLP endpoint. + +The following sends your application's eventlog over a named pipe and exports the resulting telemetry to an OTLP gRPC endpoint at "localhost:4317". + + # Configure OpenTelemetry exporter + export OTEL_SERVICE_NAME="your-application" + export OTEL_EXPORTER_OTLP_PROTOCOL="grpc" + export OTEL_EXPORTER_OTLP_ENDPOINT="localhost:4317" + + # Create a pipe for the eventlog + mkfifo "/tmp/your-application.eventlog" + + # Start your application + your-application \ + +RTS \ + -l \ + -ol"/tmp/your-application.eventlog" \ + -hT \ + --eventlog-flush-interval=1 + + # Start eventlog-live-otlp + eventlog-live-otlp \ + --eventlog-file="/tmp/your-application.eventlog" \ + -hT \ + --eventlog-flush-interval=1 + +For instructions and more in-depth examples, see the README. diff --git a/eventlog-live.cabal b/eventlog-live.cabal --- a/eventlog-live.cabal +++ b/eventlog-live.cabal @@ -1,6 +1,6 @@ cabal-version: 3.0 name: eventlog-live -version: 0.8.0.0 +version: 0.9.0.0 synopsis: Real-time monitoring for any Haskell application with little to no instrumentation description: Real-time monitoring for any Haskell application with little to no instrumentation! license: BSD-3-Clause @@ -17,6 +17,9 @@ extra-source-files: data/config.schema.json data/default.yaml + data/help.footer.txt + data/help.header.txt + data/help.progDesc.txt tested-with: ghc ==9.2.8 || ==9.4.8 || ==9.6.7 || ==9.8.4 || ==9.10.3 || ==9.12.4 @@ -29,7 +32,7 @@ source-repository this type: git location: https://github.com/well-typed/eventlog-live.git - tag: eventlog-live-v0.8.0.0 + tag: eventlog-live-v0.9.0.0 subdir: eventlog-live -- This flag enables the control command server, which is an HTTP endpoint @@ -246,6 +249,7 @@ GHC.Eventlog.Live.Otlp.Exporter.Profiles GHC.Eventlog.Live.Otlp.Exporter.Traces GHC.Eventlog.Live.Otlp.Options + GHC.Eventlog.Live.Otlp.Options.Raw GHC.Eventlog.Live.Otlp.Processor.Common.Core GHC.Eventlog.Live.Otlp.Processor.Common.Logs GHC.Eventlog.Live.Otlp.Processor.Common.Metrics @@ -287,7 +291,7 @@ hs-opentelemetry-otlp >=0.2.0 && <0.3, HsYAML >=0.2 && <0.3, http-client >=0.7 && <0.8, - http-client-tls >=0.3 && <0.4, + http-client-tls >=0.3.5 && <0.4, http-types >=0.12 && <0.13, ipedb >=0.2.0.1 && <0.3, lens-family >=2.1.3 && <2.2, @@ -303,6 +307,7 @@ transformers >=0.2 && <0.7, unordered-containers >=0.2.20 && <0.3, vector >=0.11 && <0.14, + zlib >=0.2 && <0.8, if flag(control) build-depends: diff --git a/src-app/GHC/Eventlog/Live/Otlp.hs b/src-app/GHC/Eventlog/Live/Otlp.hs --- a/src-app/GHC/Eventlog/Live/Otlp.hs +++ b/src-app/GHC/Eventlog/Live/Otlp.hs @@ -35,7 +35,7 @@ import GHC.Eventlog.Live.Otlp.Config qualified as C import GHC.Eventlog.Live.Otlp.Config.Types (FullConfig (..)) import GHC.Eventlog.Live.Otlp.Control (ControlServerApi (..), startControlServer) -import GHC.Eventlog.Live.Otlp.Environment (PerSignal, ServiceName (..), Signal (..), forSignal, lookupExporterOptions, lookupLogLevel, lookupResourceAttributes) +import GHC.Eventlog.Live.Otlp.Environment (OpenTelemetrySdkOptions (..), PerSignal, ServiceName (..), Signal (..), forSignal, lookupLogLevel, lookupOpenTelemetrySdkOptions) import GHC.Eventlog.Live.Otlp.Exporter.Core (Exporter, withExporters) import GHC.Eventlog.Live.Otlp.Exporter.Logs (exportResourceLogs) import GHC.Eventlog.Live.Otlp.Exporter.Metrics (exportResourceMetrics) @@ -78,21 +78,18 @@ -- Parse the command-line options Options{..} <- O.execParser options - -- Lookup the OpenTelemetry log level - logLevel <- - either die pure =<< runExceptT lookupLogLevel - - -- Construct the logging action + -- Construct a channel for internal telemetry myTelemetryDataChan <- newTChanIO - let logger = M.filterBySeverity logLevel (M.stderrLogger <> M.chanLogger myTelemetryDataChan) - -- Lookup the OpenTelemetry Exporter Options - exporterOptions <- - either die pure =<< runExceptT (lookupExporterOptions logger) + -- Construct a logger + logLevel <- either die pure =<< runExceptT lookupLogLevel + let logger = + M.filterBySeverity logLevel $ + M.stderrLogger <> M.chanLogger myTelemetryDataChan - -- Lookup the OpenTelemetry Resource Attributes - maybeResourceAttributes <- - either die pure =<< runExceptT (lookupResourceAttributes logger) + -- Lookup the OpenTelemetry SDK options + OpenTelemetrySdkOptions{..} <- + either die pure =<< runExceptT (lookupOpenTelemetrySdkOptions logger) -- Instument THIS PROGRAM with eventlog-socket and/or ghc-debug. let MyDebugOptions{..} = myDebugOptions diff --git a/src-app/GHC/Eventlog/Live/Otlp/Control.hs b/src-app/GHC/Eventlog/Live/Otlp/Control.hs --- a/src-app/GHC/Eventlog/Live/Otlp/Control.hs +++ b/src-app/GHC/Eventlog/Live/Otlp/Control.hs @@ -608,7 +608,7 @@ controlOptionsParser :: O.Parser ControlOptions controlOptionsParser = - OC.parserOptionGroup "Control Server Options" $ + OC.parserOptionGroup "Control options:" $ ControlOptions <$> controlEnabledParser <*> controlPortParser diff --git a/src-app/GHC/Eventlog/Live/Otlp/Environment.hs b/src-app/GHC/Eventlog/Live/Otlp/Environment.hs --- a/src-app/GHC/Eventlog/Live/Otlp/Environment.hs +++ b/src-app/GHC/Eventlog/Live/Otlp/Environment.hs @@ -2,25 +2,30 @@ {-# LANGUAGE QuasiQuotes #-} module GHC.Eventlog.Live.Otlp.Environment ( - -- * OpenTelemetry Exporter Options + -- * OpenTelemetry SDK Options + OpenTelemetrySdkOptions (..), + lookupOpenTelemetrySdkOptions, + Severity (..), lookupLogLevel, ServiceName (..), ResourceAttributes (..), - lookupResourceAttributes, - -- ** OpenTelemetry Exporter Options + -- * OpenTelemetry Exporter Options + ExporterOptions (..), + + -- ** OpenTelemetry Signals and Per-Signal Options PerSignal (..), Signal (..), forSignal, - ExporterOptions (..), - lookupExporterOptions, + + -- ** OpenTelemetry OTLP Exporter Options + OtlpExporterOptions (..), Protocol (..), Endpoint (..), - defaultEndpointFor, - defaultPortFor, Compression (..), Timeout (..), - OtlpExporterOptions (..), + defaultEndpointFor, + defaultPortFor, ) where import Control.Monad (join, unless) @@ -50,119 +55,33 @@ import Text.Read (readMaybe) -------------------------------------------------------------------------------- --- OpenTelemetry Signals --------------------------------------------------------------------------------- - -{- | -The signals supported by OTLP. --} -data Signal - = TRACES - | METRICS - | LOGS - | PROFILES - deriving (Show, Enum, Bounded) - -{- | -A collection of values for per signal. --} -data PerSignal a - = Shared !a - | PerSignal - { forTRACES :: !a - , forMETRICS :: !a - , forLOGS :: !a - , forPROFILES :: !a - } - deriving stock (Functor, Foldable, Traversable) - -{- | -Get the element for a specific signal. --} -forSignal :: PerSignal a -> Signal -> a -forSignal = \case - Shared a -> const a - PerSignal{..} -> \case - TRACES -> forTRACES - METRICS -> forMETRICS - LOGS -> forLOGS - PROFILES -> forPROFILES - --------------------------------------------------------------------------------- -- OpenTelemetry SDK Options -------------------------------------------------------------------------------- {- | -Supported exporters. --} -data ExporterType = Otlp - deriving (Eq, Show) - -{- | -Lookup the OpenTelemetry exporter type for a signal from the environment. +The OpenTelemetry SDK configuration options. -See: https://opentelemetry.io/docs/specs/otel/configuration/sdk-environment-variables/#exporter-selection --} -lookupExporterType :: - Logger IO -> - Signal -> - ExceptT String IO (Maybe ExporterType) -lookupExporterType logger signal = do - let otelExporter = "OTEL_" <> show signal <> "_EXPORTER" - lift (lookupEnv otelExporter) >>= \case - Nothing -> - pure (Just Otlp) - Just otelExporterType -> - readExporterType logger otelExporter otelExporterType +Read these values from the environment using `lookupOpenTelemetrySdkOptions`. +This function writes to a `Logger` when it encounters configuration errors. +Hence, it does not read @OTEL_LOG_LEVEL@, which is needed to construct a logger. -{- | -Exporter options for each exporter type. +See: https://opentelemetry.io/docs/specs/otel/configuration/sdk-environment-variables -} -newtype ExporterOptions = ExporterOptions'Otlp OtlpExporterOptions - deriving (Eq, Show) - -{- | -Lookup the OpenTelemetry OTLP Exporter options from the environment. +data OpenTelemetrySdkOptions = OpenTelemetrySdkOptions + { maybeResourceAttributes :: !(Maybe ResourceAttributes) + , exporterOptions :: !(PerSignal (Maybe ExporterOptions)) + } -See: https://opentelemetry.io/docs/specs/otel/protocol/exporter --} -lookupExporterOptions :: +lookupOpenTelemetrySdkOptions :: Logger IO -> - ExceptT String IO (PerSignal (Maybe ExporterOptions)) -lookupExporterOptions logger = do - !tracesExporterType <- lookupExporterType logger TRACES - !tracesExporterOptions <- - for tracesExporterType $ \Otlp -> - ExporterOptions'Otlp <$> lookupOtlpExporterOptions logger (Just TRACES) - - !metricsExporterType <- lookupExporterType logger METRICS - !metricsExporterOptions <- - for metricsExporterType $ \Otlp -> - ExporterOptions'Otlp <$> lookupOtlpExporterOptions logger (Just METRICS) - - !logsExporterType <- lookupExporterType logger LOGS - !logsExporterOptions <- - for logsExporterType $ \Otlp -> - ExporterOptions'Otlp <$> lookupOtlpExporterOptions logger (Just LOGS) - - !profilesExporterType <- lookupExporterType logger PROFILES - !profilesExporterOptions <- - for profilesExporterType $ \Otlp -> - ExporterOptions'Otlp <$> lookupOtlpExporterOptions logger (Just PROFILES) + ExceptT String IO OpenTelemetrySdkOptions +lookupOpenTelemetrySdkOptions logger = do + maybeResourceAttributes <- lookupResourceAttributes logger + exporterOptions <- lookupExporterOptions logger + pure OpenTelemetrySdkOptions{..} - let exporterOptions = - [tracesExporterOptions, metricsExporterOptions, logsExporterOptions, profilesExporterOptions] - pure $ - if allSame exporterOptions - then - Shared tracesExporterOptions - else - PerSignal - { forTRACES = tracesExporterOptions - , forMETRICS = metricsExporterOptions - , forLOGS = logsExporterOptions - , forPROFILES = profilesExporterOptions - } +-------------------------------------------------------------------------------- +-- OpenTelemetry Log Level {- | Lookup the OpenTelemetry Log Level from the environment. @@ -176,6 +95,9 @@ <$> traverse (readSeverity otelLogLevel) =<< lift (lookupEnv otelLogLevel) +-------------------------------------------------------------------------------- +-- OpenTelemetry Resource Attributes + {- | OpenTelemetry Service Name. -} @@ -215,8 +137,6 @@ Lookup the OpenTelemetry Resource Attributes from the environment. This function reads both @OTEL_RESOURCE_ATTRIBUTES@ and @OTEL_SERVICE_NAME@. - -See: https://opentelemetry.io/docs/specs/otel/configuration/sdk-environment-variables/#general-sdk-configuration -} lookupResourceAttributes :: Logger IO -> @@ -249,6 +169,95 @@ -------------------------------------------------------------------------------- {- | +Supported exporters. +-} +data ExporterType = Console | Otlp + deriving (Eq, Show) + +{- | +Lookup the OpenTelemetry Exporter Type for a signal from the environment. + +See: https://opentelemetry.io/docs/specs/otel/configuration/sdk-environment-variables/#exporter-selection +-} +lookupExporterType :: + Logger IO -> + Signal -> + ExceptT String IO (Maybe ExporterType) +lookupExporterType logger signal = do + let otelExporter = "OTEL_" <> show signal <> "_EXPORTER" + lift (lookupEnv otelExporter) >>= \case + Nothing -> + pure (Just Otlp) + Just otelExporterType -> + readExporterType logger otelExporter otelExporterType + +{- | +Exporter options for each exporter type. +-} +data ExporterOptions + = ExporterOptions'Console + | ExporterOptions'Otlp OtlpExporterOptions + deriving (Eq, Show) + +{- | +Lookup the OpenTelemetry Exporter options from the environment. + +See: https://opentelemetry.io/docs/specs/otel/protocol/exporter +-} +lookupExporterOptions :: + Logger IO -> + ExceptT String IO (PerSignal (Maybe ExporterOptions)) +lookupExporterOptions logger = do + !tracesExporterType <- lookupExporterType logger TRACES + !tracesExporterOptions <- + for tracesExporterType $ \case + Console -> + pure ExporterOptions'Console + Otlp -> + ExporterOptions'Otlp <$> lookupOtlpExporterOptions logger (Just TRACES) + + !metricsExporterType <- lookupExporterType logger METRICS + !metricsExporterOptions <- + for metricsExporterType $ \case + Console -> + pure ExporterOptions'Console + Otlp -> + ExporterOptions'Otlp <$> lookupOtlpExporterOptions logger (Just METRICS) + + !logsExporterType <- lookupExporterType logger LOGS + !logsExporterOptions <- + for logsExporterType $ \case + Console -> + pure ExporterOptions'Console + Otlp -> + ExporterOptions'Otlp <$> lookupOtlpExporterOptions logger (Just LOGS) + + !profilesExporterType <- lookupExporterType logger PROFILES + !profilesExporterOptions <- + for profilesExporterType $ \case + Console -> + pure ExporterOptions'Console + Otlp -> + ExporterOptions'Otlp <$> lookupOtlpExporterOptions logger (Just PROFILES) + + let exporterOptions = + [tracesExporterOptions, metricsExporterOptions, logsExporterOptions, profilesExporterOptions] + pure $ + if allSame exporterOptions + then + Shared tracesExporterOptions + else + PerSignal + { forTRACES = tracesExporterOptions + , forMETRICS = metricsExporterOptions + , forLOGS = logsExporterOptions + , forPROFILES = profilesExporterOptions + } + +-------------------------------------------------------------------------------- +-- OpenTelemetry OTLP Exporter Options + +{- | OTLP protocol. -} data Protocol = Grpc | HttpProtobuf @@ -309,9 +318,13 @@ The value is specified in milliseconds. The value @0@ should be interpreted as "no timeout". -} -newtype Timeout = Timeout {timeoutMillis :: Word} +newtype Timeout = Timeout {milliseconds :: Word} deriving (Eq, Show) +instance HasField "microseconds" Timeout Word where + getField :: Timeout -> Word + getField timeout = 1_000 * timeout.milliseconds + instance Default Timeout where def :: Timeout def = Timeout 10_000 @@ -323,8 +336,6 @@ { protocol :: !Protocol , endpoint :: !Endpoint , maybeCertificate :: !(Maybe String) - , maybeClientKey :: !(Maybe String) - , maybeClientCertificate :: !(Maybe String) , maybeHeaders :: !(Maybe Baggage) , maybeCompression :: !(Maybe Compression) , timeout :: !Timeout @@ -346,11 +357,9 @@ -- The INSECURE option should be used to infer http/https, but whenever -- http/https is specified in the endpoint, this should take precedence. maybeInsecure <- lookupOtlpExporterOption logger signal INSECURE readBoolean - maybeEndpoint <- lookupOtlpExporterOption logger signal ENDPOINT (readEndpoint maybeInsecure) + maybeEndpoint <- lookupOtlpExporterOption logger signal ENDPOINT (readEndpoint protocol maybeInsecure) let !endpoint = fromMaybe (defaultEndpointFor protocol) maybeEndpoint maybeCertificate <- lookupOtlpExporterOption logger signal CERTIFICATE readString - maybeClientKey <- lookupOtlpExporterOption logger signal CLIENT_KEY readString - maybeClientCertificate <- lookupOtlpExporterOption logger signal CLIENT_CERTIFICATE readString maybeHeaders <- lookupOtlpExporterOption logger signal HEADERS readBaggage maybeCompression <- join <$> lookupOtlpExporterOption logger signal COMPRESSION readCompression maybeTimeout <- lookupOtlpExporterOption logger signal TIMEOUT readTimeout @@ -367,8 +376,6 @@ | ENDPOINT | INSECURE | CERTIFICATE - | CLIENT_KEY - | CLIENT_CERTIFICATE | HEADERS | COMPRESSION | TIMEOUT @@ -477,8 +484,15 @@ @`readEndpoint` maybeInsecure@ uses the value of @maybeInsecure@, to determine whether or not to infer the URI scheme as http or https, if unspecified. -} -readEndpoint :: (Monad m) => Maybe Bool -> Logger m -> String -> String -> ExceptT String m Endpoint -readEndpoint maybeInsecure logger optionName = go True +readEndpoint :: + (Monad m) => + Protocol -> + Maybe Bool -> + Logger m -> + String -> + String -> + ExceptT String m Endpoint +readEndpoint protocol maybeInsecure logger optionName = go True where go retry endpoint = do let maybeURI = URI.parseAbsoluteURI endpoint @@ -487,7 +501,10 @@ "Environment variable " <> optionName <> " specifies URI: " <> showURI uri case maybeURI of Nothing - | retry -> do + -- If the endpoint was specified without a scheme, then we retry with a + -- scheme that is either based on the value of the insecure setting or + -- the default insecure http scheme, but this applies *only* to gRPC. + | protocol == Grpc && retry -> do if maybeInsecure == Just False then go False ("https://" <> endpoint) else go False ("http://" <> endpoint) @@ -551,8 +568,8 @@ -} readTimeout :: (Monad m) => Logger m -> String -> String -> ExceptT String m Timeout readTimeout logger optionName timeout - | Just timeoutMillis <- readMaybe @Word timeout = - pure (Timeout timeoutMillis) + | Just milliseconds <- readMaybe @Word timeout = + pure (Timeout milliseconds) | otherwise = do lift . writeLog logger WARN . T.pack $ "Environment variable " <> optionName <> " specifies malformed timeout '" <> timeout <> "'." @@ -581,7 +598,8 @@ readExporterType _logger optionName exporterType | CI.mk exporterType == "none" = pure Nothing | CI.mk exporterType == "otlp" = pure (Just Otlp) - | CI.mk exporterType `elem` ["zipkin", "prometheus", "console", "logging"] = + | CI.mk exporterType == "console" = pure (Just Console) + | CI.mk exporterType `elem` ["zipkin", "prometheus", "logging"] = throwE $ "Environment variable " <> optionName <> " specifies unsupported exporter '" <> exporterType <> "'." | otherwise = @@ -596,3 +614,41 @@ allSame :: (Eq a) => [a] -> Bool allSame [] = True allSame (x : xs) = all (== x) xs + +-------------------------------------------------------------------------------- +-- OpenTelemetry Signals and Options per Signal + +{- | +The signals supported by OTLP. +-} +data Signal + = TRACES + | METRICS + | LOGS + | PROFILES + deriving (Show, Enum, Bounded) + +{- | +A collection of values for per signal. +-} +data PerSignal a + = Shared !a + | PerSignal + { forTRACES :: !a + , forMETRICS :: !a + , forLOGS :: !a + , forPROFILES :: !a + } + deriving stock (Functor, Foldable, Traversable) + +{- | +Get the element for a specific signal. +-} +forSignal :: PerSignal a -> Signal -> a +forSignal = \case + Shared a -> const a + PerSignal{..} -> \case + TRACES -> forTRACES + METRICS -> forMETRICS + LOGS -> forLOGS + PROFILES -> forPROFILES diff --git a/src-app/GHC/Eventlog/Live/Otlp/Exporter/Core.hs b/src-app/GHC/Eventlog/Live/Otlp/Exporter/Core.hs --- a/src-app/GHC/Eventlog/Live/Otlp/Exporter/Core.hs +++ b/src-app/GHC/Eventlog/Live/Otlp/Exporter/Core.hs @@ -2,19 +2,24 @@ {-# LANGUAGE OverloadedStrings #-} module GHC.Eventlog.Live.Otlp.Exporter.Core ( + -- * Exporter Exporter (..), withExporter, withExporters, export, - -- * Export via gRPC - CanExportViaGrpc, + -- ** Export via gRPC + CanExportToConsole, - -- * Export via HTTP/Protobuf - CanExportViaHttpProtobuf (..), + -- ** Export via gRPC + CanExportToOltpViaGrpc, + + -- ** Export via HTTP/Protobuf + CanExportToOltpViaHttpProtobuf (..), HttpError (..), ) where +import Codec.Compression.GZip qualified as GZip import Control.Exception (Exception (..), throwIO) import Data.ByteString (ByteString) import Data.ByteString qualified as BS @@ -25,15 +30,19 @@ import Data.ProtoLens.Encoding qualified as Proto import Data.ProtoLens.Message (Message (defMessage)) import Data.ProtoLens.Service.Types (HasMethodImpl (..)) +import Data.Text (Text) import Data.Text qualified as T import Data.Text.Encoding qualified as TE +import Data.Text.IO qualified as TIO import GHC.Eventlog.Live.Data.Severity (Severity (..)) import GHC.Eventlog.Live.Logger (Logger, writeLog) -import GHC.Eventlog.Live.Otlp.Environment (Endpoint (..), ExporterOptions (..), OtlpExporterOptions (..), PerSignal (..), Protocol (..), defaultPortFor) +import GHC.Eventlog.Live.Otlp.Environment (Compression (..)) +import GHC.Eventlog.Live.Otlp.Environment qualified as E (Endpoint (..), ExporterOptions (..), OtlpExporterOptions (..), PerSignal (..), Protocol (..), Timeout (..), defaultPortFor) import GHC.IsList qualified as IsList import Network.GRPC.Client qualified as G import Network.GRPC.Client.StreamType.IO qualified as G import Network.GRPC.Common qualified as G +import Network.GRPC.Common.Compression qualified as G import Network.GRPC.Common.Protobuf (Protobuf, StreamingType (..)) import Network.GRPC.Common.Protobuf qualified as G import Network.GRPC.Common.StreamType qualified as G @@ -48,7 +57,8 @@ -------------------------------------------------------------------------------- data Exporter - = Exporter'OtlpGrpc !OtlpGrpcExporter + = Exporter'Console + | Exporter'OtlpGrpc !OtlpGrpcExporter | Exporter'OtlpHttpProtobuf !OtlpHttpProtobufExporter {- | @@ -56,24 +66,24 @@ -} withExporters :: Logger IO -> - PerSignal (Maybe ExporterOptions) -> - (PerSignal (Maybe Exporter) -> IO a) -> + E.PerSignal (Maybe E.ExporterOptions) -> + (E.PerSignal (Maybe Exporter) -> IO a) -> IO a -withExporters logger (Shared maybeOptions) action = - withMaybeExporter logger maybeOptions $ action . Shared -withExporters logger PerSignal{..} action = +withExporters logger (E.Shared maybeOptions) action = + withMaybeExporter logger maybeOptions $ action . E.Shared +withExporters logger E.PerSignal{..} action = withMaybeExporter logger forTRACES $ \exporterForTRACES -> withMaybeExporter logger forMETRICS $ \exporterForMETRICS -> withMaybeExporter logger forLOGS $ \exporterForLOGS -> withMaybeExporter logger forPROFILES $ \exporterForPROFILES -> - action $ PerSignal exporterForTRACES exporterForMETRICS exporterForLOGS exporterForPROFILES + action $ E.PerSignal exporterForTRACES exporterForMETRICS exporterForLOGS exporterForPROFILES {- | Construct a @Maybe t`Exporter`@ from @Maybe t`OtlpExporterOptions`@. -} withMaybeExporter :: Logger IO -> - Maybe ExporterOptions -> + Maybe E.ExporterOptions -> (Maybe Exporter -> IO a) -> IO a withMaybeExporter logger maybeOptions action = @@ -88,23 +98,28 @@ -} withExporter :: Logger IO -> - ExporterOptions -> + E.ExporterOptions -> (Exporter -> IO a) -> IO a -withExporter logger (ExporterOptions'Otlp options) action = - case options.protocol of - Grpc -> - withOtlpGrpcExporter logger options $ action . Exporter'OtlpGrpc - HttpProtobuf -> - withOtlpHttpProtobufExporter logger options $ action . Exporter'OtlpHttpProtobuf +withExporter logger options action = + case options of + E.ExporterOptions'Console -> + action Exporter'Console + E.ExporterOptions'Otlp otlpExporterOptions -> + case otlpExporterOptions.protocol of + E.Grpc -> + withOtlpGrpcExporter logger otlpExporterOptions $ action . Exporter'OtlpGrpc + E.HttpProtobuf -> + withOtlpHttpProtobufExporter logger otlpExporterOptions $ action . Exporter'OtlpHttpProtobuf {- | Export telemetry data to the t`OtlpExporter`. -} export :: forall serv meth. - ( CanExportViaGrpc serv meth - , CanExportViaHttpProtobuf serv meth + ( CanExportToConsole serv meth + , CanExportToOltpViaGrpc serv meth + , CanExportToOltpViaHttpProtobuf serv meth ) => Logger IO -> -- | The HTTP/Protobuf exporter. @@ -113,12 +128,36 @@ MethodInput serv meth -> IO (MethodOutput serv meth) export logger = \case + Exporter'Console -> \req -> do + TIO.putStrLn (displayExportRequest @serv @meth req) + pure (makeExportResponse @serv @meth req) Exporter'OtlpGrpc exporter -> exportGrpc @serv @meth logger exporter Exporter'OtlpHttpProtobuf exporter -> exportHttpProtobuf @serv @meth logger exporter -------------------------------------------------------------------------------- +-- Console Exporter +-------------------------------------------------------------------------------- + +class CanExportToConsole serv meth where + {- | + Display an export request message. + -} + displayExportRequest :: MethodInput serv meth -> Text + default displayExportRequest :: (Show (MethodInput serv meth)) => MethodInput serv meth -> Text + displayExportRequest = T.pack . show + {-# INLINE displayExportRequest #-} + + {- | + Construct an export response. + -} + makeExportResponse :: MethodInput serv meth -> MethodOutput serv meth + default makeExportResponse :: (Message (MethodOutput serv meth)) => MethodInput serv meth -> MethodOutput serv meth + makeExportResponse = const defMessage + {-# INLINE makeExportResponse #-} + +-------------------------------------------------------------------------------- -- OTLP gRPC Exporter -------------------------------------------------------------------------------- @@ -129,7 +168,7 @@ { connection :: G.Connection } -type CanExportViaGrpc serv meth = +type CanExportToOltpViaGrpc serv meth = ( G.SupportsClientRpc (Protobuf serv meth) , G.SupportsStreamingType (Protobuf serv meth) 'NonStreaming , G.RequestMetadata (Protobuf serv meth) ~ G.NoMetadata @@ -137,32 +176,48 @@ withOtlpGrpcExporter :: Logger IO -> - OtlpExporterOptions -> + E.OtlpExporterOptions -> (OtlpGrpcExporter -> IO a) -> IO a withOtlpGrpcExporter logger options action = do writeLog logger DEBUG . T.pack $ "OTLP gRPC Exporter - Endpoint: " <> show options.endpoint - G.withConnection G.def server $ \connection -> action OtlpGrpcExporter{..} + let !connParams = + G.def + { -- The compression negotiation strategy: + G.connCompression = + case options.maybeCompression of + Nothing -> G.none + Just GZip -> G.only G.gzip + , -- The default timeout: + G.connDefaultTimeout = + if options.timeout.milliseconds == 0 + then Nothing + else Just (G.Timeout G.Millisecond (G.TimeoutValue options.timeout.milliseconds)) + } + G.withConnection connParams server $ \connection -> + action OtlpGrpcExporter{..} where server :: G.Server server | options.endpoint.secure = G.ServerSecure serverValidation G.SslKeyLogNone address | otherwise = G.ServerInsecure address where - port = fromIntegral $ fromMaybe (defaultPortFor options.protocol) options.endpoint.port + port = fromIntegral $ fromMaybe (E.defaultPortFor options.protocol) options.endpoint.port address = G.Address options.endpoint.host port Nothing serverValidation = G.ValidateServer $ maybe G.certStoreFromSystem G.certStoreFromPath options.maybeCertificate exportGrpc :: forall serv meth. - (CanExportViaGrpc serv meth) => + (CanExportToOltpViaGrpc serv meth) => Logger IO -> OtlpGrpcExporter -> MethodInput serv meth -> IO (MethodOutput serv meth) exportGrpc _logger grpcExporter input = - G.getProto <$> G.nonStreaming grpcExporter.connection (G.rpc @(G.Protobuf serv meth)) (G.Proto input) + let callParams :: G.CallParams (G.Protobuf serv meth) + callParams = G.def + in G.getProto <$> G.nonStreaming grpcExporter.connection (G.rpcWith callParams) (G.Proto input) -------------------------------------------------------------------------------- -- OTLP HTTP/Protobuf Exporter @@ -180,6 +235,7 @@ { manager :: H.Manager , baseUrl :: String , headers :: HTTP.RequestHeaders + , maybeCompression :: Maybe Compression } data HttpError @@ -214,14 +270,26 @@ -} withOtlpHttpProtobufExporter :: Logger IO -> - OtlpExporterOptions -> + E.OtlpExporterOptions -> (OtlpHttpProtobufExporter -> IO a) -> IO a withOtlpHttpProtobufExporter logger options action = do writeLog logger DEBUG . T.pack $ "OTLP HTTP/Protobuf Exporter - Endpoint: " <> show options.endpoint + -- Create HTTP manager settings. + let responseTimeout + | options.timeout.microseconds == 0 = + H.responseTimeoutNone + | options.timeout.microseconds <= fromIntegral (maxBound @Int) = + H.responseTimeoutMicro (fromIntegral options.timeout.microseconds) + | otherwise = + -- NOTE: Oh no, this truncates the response timeout to 292,271 years! + H.responseTimeoutMicro maxBound -- Create an HTTP manager. - manager <- H.newManager H.tlsManagerSettings + -- + -- NOTE: newTlsManagerWith respects proxy environment variables + manager <- + H.newTlsManagerWith H.tlsManagerSettings{H.managerResponseTimeout = responseTimeout} -- Create the HTTP headers. writeLog logger TRACE . T.pack $ "OTLP HTTP/Protobuf Exporter - Headers: " <> show options.maybeHeaders @@ -231,13 +299,18 @@ IsList.toList (maybe mempty Baggage.values options.maybeHeaders) ] -- Run the action. - action OtlpHttpProtobufExporter{baseUrl = show options.endpoint, ..} + action + OtlpHttpProtobufExporter + { baseUrl = show options.endpoint + , maybeCompression = options.maybeCompression + , .. + } class ( Message (MethodInput serv meth) , Message (MethodOutput serv meth) ) => - CanExportViaHttpProtobuf serv meth + CanExportToOltpViaHttpProtobuf serv meth where apiPath :: String @@ -246,7 +319,7 @@ -} exportHttpProtobuf :: forall serv meth. - (CanExportViaHttpProtobuf serv meth) => + (CanExportToOltpViaHttpProtobuf serv meth) => Logger IO -> -- | The HTTP/Protobuf exporter. OtlpHttpProtobufExporter -> @@ -255,16 +328,19 @@ IO (MethodOutput serv meth) exportHttpProtobuf logger OtlpHttpProtobufExporter{..} req = do baseRequest <- H.parseRequest (baseUrl <> apiPath @serv @meth) + let (compressionHeaders, compress) = httpCompression maybeCompression + let !requestBody = H.RequestBodyBS (compress (Proto.encodeMessage req)) let request = baseRequest { H.method = "POST" - , H.requestBody = H.RequestBodyBS (Proto.encodeMessage req) + , H.requestBody = requestBody , H.checkResponse = \_ _ -> pure () , H.requestHeaders = [ (HTTP.hContentType, "application/x-protobuf") , (HTTP.hAccept, "application/x-protobuf") ] - <> headers + <> headers -- user-provided + <> compressionHeaders } writeLog logger TRACE . T.pack $ "HTTP/Protobuf Exporter - HTTP Request: " <> show request response <- H.httpLbs request manager @@ -293,3 +369,13 @@ case Proto.decodeMessage body of Left errorMessage -> throwIO HttpDecodeError{..} Right msg -> pure msg + +{- | +Internal helper. + +Determine HTTP compression headers and algorithms. +-} +httpCompression :: Maybe Compression -> ([HTTP.Header], ByteString -> ByteString) +httpCompression = \case + Nothing -> ([], id) + Just GZip -> ([(HTTP.hContentEncoding, "gzip")], BSL.toStrict . GZip.compress . BSL.fromStrict) diff --git a/src-app/GHC/Eventlog/Live/Otlp/Exporter/Logs.hs b/src-app/GHC/Eventlog/Live/Otlp/Exporter/Logs.hs --- a/src-app/GHC/Eventlog/Live/Otlp/Exporter/Logs.hs +++ b/src-app/GHC/Eventlog/Live/Otlp/Exporter/Logs.hs @@ -17,7 +17,7 @@ import Data.Vector qualified as V import GHC.Eventlog.Live.Logger (Logger) import GHC.Eventlog.Live.Machine.Core (Tick (..)) -import GHC.Eventlog.Live.Otlp.Exporter.Core (CanExportViaHttpProtobuf (..), Exporter (..), export) +import GHC.Eventlog.Live.Otlp.Exporter.Core (CanExportToConsole, CanExportToOltpViaHttpProtobuf (..), Exporter (..), export) import Lens.Family2 ((^.)) import Network.GRPC.Common qualified as G import Network.GRPC.Common.Protobuf (Protobuf) @@ -103,11 +103,22 @@ handleSomeException :: SomeException -> IO ExportLogsResult handleSomeException someException = pure $ ExportLogsError 0 exportedLogRecords someException +-------------------------------------------------------------------------------- +-- CanExportToConsole + +instance CanExportToConsole OLS.LogsService "export" + +-------------------------------------------------------------------------------- +-- CanExportToOltpViaGrpc + type instance G.RequestMetadata (Protobuf OLS.LogsService meth) = G.NoMetadata type instance G.ResponseInitialMetadata (Protobuf OLS.LogsService meth) = G.NoMetadata type instance G.ResponseTrailingMetadata (Protobuf OLS.LogsService meth) = G.NoMetadata -instance CanExportViaHttpProtobuf OLS.LogsService "export" where +-------------------------------------------------------------------------------- +-- CanExportToOltpViaHttpProtobuf + +instance CanExportToOltpViaHttpProtobuf OLS.LogsService "export" where apiPath :: String apiPath = "/v1/logs" diff --git a/src-app/GHC/Eventlog/Live/Otlp/Exporter/Metrics.hs b/src-app/GHC/Eventlog/Live/Otlp/Exporter/Metrics.hs --- a/src-app/GHC/Eventlog/Live/Otlp/Exporter/Metrics.hs +++ b/src-app/GHC/Eventlog/Live/Otlp/Exporter/Metrics.hs @@ -17,7 +17,7 @@ import Data.Vector qualified as V import GHC.Eventlog.Live.Logger (Logger) import GHC.Eventlog.Live.Machine.Core (Tick (..)) -import GHC.Eventlog.Live.Otlp.Exporter.Core (CanExportViaHttpProtobuf (..), Exporter (..), export) +import GHC.Eventlog.Live.Otlp.Exporter.Core (CanExportToConsole, CanExportToOltpViaHttpProtobuf (..), Exporter (..), export) import Lens.Family2 ((^.)) import Network.GRPC.Common qualified as G import Network.GRPC.Common.Protobuf (Protobuf) @@ -103,11 +103,22 @@ handleSomeException :: SomeException -> IO ExportMetricsResult handleSomeException someException = pure $ ExportMetricsError 0 exportedDataPoints someException +-------------------------------------------------------------------------------- +-- CanExportToConsole + +instance CanExportToConsole OMS.MetricsService "export" + +-------------------------------------------------------------------------------- +-- CanExportToOltpViaGrpc + type instance G.RequestMetadata (Protobuf OMS.MetricsService meth) = G.NoMetadata type instance G.ResponseInitialMetadata (Protobuf OMS.MetricsService meth) = G.NoMetadata type instance G.ResponseTrailingMetadata (Protobuf OMS.MetricsService meth) = G.NoMetadata -instance CanExportViaHttpProtobuf OMS.MetricsService "export" where +-------------------------------------------------------------------------------- +-- CanExportToOltpViaHttpProtobuf + +instance CanExportToOltpViaHttpProtobuf OMS.MetricsService "export" where apiPath :: String apiPath = "/v1/metrics" diff --git a/src-app/GHC/Eventlog/Live/Otlp/Exporter/Profiles.hs b/src-app/GHC/Eventlog/Live/Otlp/Exporter/Profiles.hs --- a/src-app/GHC/Eventlog/Live/Otlp/Exporter/Profiles.hs +++ b/src-app/GHC/Eventlog/Live/Otlp/Exporter/Profiles.hs @@ -18,7 +18,7 @@ import Data.Vector qualified as V import GHC.Eventlog.Live.Logger (Logger) import GHC.Eventlog.Live.Machine.Core (Tick (..)) -import GHC.Eventlog.Live.Otlp.Exporter.Core (CanExportViaHttpProtobuf (..), Exporter (..), export) +import GHC.Eventlog.Live.Otlp.Exporter.Core (CanExportToConsole, CanExportToOltpViaHttpProtobuf (..), Exporter (..), export) import Lens.Family2 ((^.)) import Network.GRPC.Common qualified as G import Network.GRPC.Common.Protobuf (Protobuf) @@ -98,13 +98,28 @@ handleSomeException :: SomeException -> IO ExportProfileResult handleSomeException someException = pure $ ExportProfileError 0 exportedProfiles someException +-------------------------------------------------------------------------------- +-- CanExportToConsole + +instance CanExportToConsole OPS.ProfilesService "export" + +-------------------------------------------------------------------------------- +-- CanExportToOltpViaGrpc + type instance G.RequestMetadata (Protobuf OPS.ProfilesService meth) = G.NoMetadata type instance G.ResponseInitialMetadata (Protobuf OPS.ProfilesService meth) = G.NoMetadata type instance G.ResponseTrailingMetadata (Protobuf OPS.ProfilesService meth) = G.NoMetadata -instance CanExportViaHttpProtobuf OPS.ProfilesService "export" where +-------------------------------------------------------------------------------- +-- CanExportToOltpViaHttpProtobuf + +instance CanExportToOltpViaHttpProtobuf OPS.ProfilesService "export" where apiPath :: String apiPath = "/v1development/profiles" + +-------------------------------------------------------------------------------- +-- Internal Helpers +-------------------------------------------------------------------------------- {- | Internal helper. diff --git a/src-app/GHC/Eventlog/Live/Otlp/Exporter/Traces.hs b/src-app/GHC/Eventlog/Live/Otlp/Exporter/Traces.hs --- a/src-app/GHC/Eventlog/Live/Otlp/Exporter/Traces.hs +++ b/src-app/GHC/Eventlog/Live/Otlp/Exporter/Traces.hs @@ -17,7 +17,7 @@ import Data.Vector qualified as V import GHC.Eventlog.Live.Logger (Logger) import GHC.Eventlog.Live.Machine.Core (Tick (..)) -import GHC.Eventlog.Live.Otlp.Exporter.Core (CanExportViaHttpProtobuf (..), Exporter (..), export) +import GHC.Eventlog.Live.Otlp.Exporter.Core (CanExportToConsole, CanExportToOltpViaHttpProtobuf (..), Exporter (..), export) import Lens.Family2 ((^.)) import Network.GRPC.Common qualified as G import Network.GRPC.Common.Protobuf (Protobuf) @@ -100,11 +100,22 @@ handleSomeException :: SomeException -> IO ExportTraceResult handleSomeException someException = pure $ ExportTraceError 0 exportedSpans someException +-------------------------------------------------------------------------------- +-- CanExportToConsole + +instance CanExportToConsole OTS.TraceService "export" + +-------------------------------------------------------------------------------- +-- CanExportToOltpViaGrpc + type instance G.RequestMetadata (Protobuf OTS.TraceService meth) = G.NoMetadata type instance G.ResponseInitialMetadata (Protobuf OTS.TraceService meth) = G.NoMetadata type instance G.ResponseTrailingMetadata (Protobuf OTS.TraceService meth) = G.NoMetadata -instance CanExportViaHttpProtobuf OTS.TraceService "export" where +-------------------------------------------------------------------------------- +-- CanExportToOltpViaHttpProtobuf + +instance CanExportToOltpViaHttpProtobuf OTS.TraceService "export" where apiPath :: String apiPath = "/v1/traces" diff --git a/src-app/GHC/Eventlog/Live/Otlp/Options.hs b/src-app/GHC/Eventlog/Live/Otlp/Options.hs --- a/src-app/GHC/Eventlog/Live/Otlp/Options.hs +++ b/src-app/GHC/Eventlog/Live/Otlp/Options.hs @@ -4,7 +4,9 @@ options, ) where +import Data.Char (isSpace) import Data.Default (Default (..)) +import Data.List qualified as L import Data.Text qualified as T import Data.Version (showVersion) import GHC.Debug.Stub.Compat (MyGhcDebugSocket, maybeMyGhcDebugSocketParser) @@ -13,12 +15,15 @@ import GHC.Eventlog.Live.Otlp.Config.Default.Raw (defaultConfigJSONSchemaString, defaultConfigString) import GHC.Eventlog.Live.Otlp.Config.Types (Config) import GHC.Eventlog.Live.Otlp.Control (ControlOptions, controlOptionsParser) +import GHC.Eventlog.Live.Otlp.Options.Raw (footerString, headerString, progDescString) import GHC.Eventlog.Live.Source.Core (EventlogSourceOptions (..)) import GHC.Eventlog.Socket.Compat (MyEventlogSocket (..), maybeMyEventlogSocketParser) import GHC.RTS.Events (HeapProfBreakdown (..)) import Options.Applicative qualified as O import Options.Applicative.Compat qualified as OC import Options.Applicative.Extra qualified as OE +import Options.Applicative.Help.Chunk qualified as OHC +import Options.Applicative.Help.Pretty qualified as OHP import Paths_eventlog_live qualified as EventlogLive options :: O.ParserInfo Options @@ -31,8 +36,65 @@ O.<**> OE.helperWith (O.long "help" <> O.help "Show this help text.") O.<**> OC.simpleVersioner (showVersion EventlogLive.version) ) - O.idm + ( O.headerDoc (helpDoc headerString) + <> O.progDescDoc (helpDoc progDescString) + <> O.footerDoc (helpDoc footerString) + ) +{- | +Internal helper. + +Render a text as an `OHP.Doc`. +-} +helpDoc :: String -> Maybe OHP.Doc +helpDoc doc + | OHC.isEmpty (OHC.vcatChunks docChunks) = Nothing + | otherwise = OHC.unChunk $ vcatChunks docChunks + where + docChunks :: [OHC.Chunk OHP.Doc] + docChunks = helpDocLine <$> lines doc + + -- NOTE: Variant of vcatChunks that uses hardline + vcatChunks :: [OHC.Chunk OHP.Doc] -> OHC.Chunk OHP.Doc + vcatChunks = mconcat . L.intersperse (OHC.Chunk $ Just OHP.hardline) + +{- | +Internal helper. + +Internal accumulated state for `helpDocLine`. +-} +data LineAcc + = Space {count :: !Int, chunk :: !(OHC.Chunk OHP.Doc)} + | Token {token :: !String, chunk :: !(OHC.Chunk OHP.Doc)} + +{- | +Internal helper. + +Render a line as an `OHP.Doc`. +-} +helpDocLine :: String -> OHC.Chunk OHP.Doc +helpDocLine = + asDoc True . L.foldl' trans empty . reverse + where + empty :: LineAcc + empty = Space 0 mempty + + trans :: LineAcc -> Char -> LineAcc + trans la@Space{..} c + | isSpace c = Space{count = count + 1, ..} + | count >= 2 = Token{token = [c], chunk = asDoc False la} + | otherwise = Token{token = [c], ..} + trans la@Token{..} c + | isSpace c = Space{count = 1, chunk = asDoc False la} + | otherwise = Token{token = c : token, ..} + + asDoc :: Bool -> LineAcc -> OHC.Chunk OHP.Doc + asDoc isFinal = \case + Space{..} -> + OHP.indent (if isFinal then count else count - 1) <$> chunk + Token{..} -> + OHC.stringChunk token OHC.<> chunk + data Options = Options { eventlogSourceOptions :: EventlogSourceOptions , eventlogSocketTimeoutS :: Double @@ -132,7 +194,7 @@ myDebugOptionsParser :: O.Parser MyDebugOptions myDebugOptionsParser = - OC.parserOptionGroup "Debug Options" $ + OC.parserOptionGroup "Debug options:" $ MyDebugOptions <$> maybeMyEventlogSocketParser <*> maybeMyGhcDebugSocketParser diff --git a/src-app/GHC/Eventlog/Live/Otlp/Options/Raw.hs b/src-app/GHC/Eventlog/Live/Otlp/Options/Raw.hs new file mode 100644 --- /dev/null +++ b/src-app/GHC/Eventlog/Live/Otlp/Options/Raw.hs @@ -0,0 +1,73 @@ +{-# LANGUAGE TemplateHaskell #-} + +{- | +Module : GHC.Eventlog.Live.Otlp.Options.Raw +Description : The implementation of @eventlog-live-otlp@. +Stability : experimental +Portability : portable +-} +module GHC.Eventlog.Live.Otlp.Options.Raw ( + headerString, + progDescString, + footerString, +) where + +import Data.ByteString (ByteString) +import Data.FileEmbed (embedFileRelative) +import Data.Text qualified as T +import Data.Text.Encoding qualified as TE + +{- | +Internal helper. + +The help header as a `ByteString`. +-} +headerByteString :: ByteString +headerByteString = $(embedFileRelative "data/help.header.txt") + +{- | +Internal helper. + +The help header as a `String`. +-} +headerString :: String +headerString = fromByteString headerByteString + +{- | +Internal helper. + +The help program description as a `ByteString`. +-} +progDescByteString :: ByteString +progDescByteString = $(embedFileRelative "data/help.progDesc.txt") + +{- | +Internal helper. + +The help program description as a `String`. +-} +progDescString :: String +progDescString = fromByteString progDescByteString + +{- | +Internal helper. + +The help footer as a `ByteString`. +-} +footerByteString :: ByteString +footerByteString = $(embedFileRelative "data/help.footer.txt") + +{- | +Internal helper. + +The help footer as a `String`. +-} +footerString :: String +footerString = fromByteString footerByteString + +{- | +Internal helper. +Decode a `ByteString` to a `String`. +-} +fromByteString :: ByteString -> String +fromByteString = T.unpack . TE.decodeUtf8Lenient diff --git a/src-lib/GHC/Eventlog/Live/Logger.hs b/src-lib/GHC/Eventlog/Live/Logger.hs --- a/src-lib/GHC/Eventlog/Live/Logger.hs +++ b/src-lib/GHC/Eventlog/Live/Logger.hs @@ -40,8 +40,9 @@ import GHC.Eventlog.Live.Data.LogRecord (LogRecord (..)) import GHC.Eventlog.Live.Data.Metric (KnownMetricType, Metric (..), SomeMetric (..)) import GHC.Eventlog.Live.Data.Severity (Severity (..), toSeverityString) +import GHC.IsList qualified as IsList import GHC.RTS.Events (Timestamp) -import GHC.Stack (callStack, prettyCallStack, withFrozenCallStack) +import GHC.Stack (CallStack, callStack, popCallStack, prettyCallStack) import GHC.Stack.Types (HasCallStack) import System.Clock (Clock (..), TimeSpec (..), getTime) import System.Console.ANSI (Color (..), ColorIntensity (..), ConsoleLayer (..), SGR (..), hNowSupportsANSI, hSetSGR) @@ -62,17 +63,17 @@ -} writeLog :: (HasCallStack) => Logger m -> Severity -> Text -> m () writeLog logger severity body = - withFrozenCallStack $ - logger - <& MyTelemetryData'LogRecord - { logRecord = - LogRecord - { body - , maybeSeverity = Just severity - , maybeTimeUnixNano = Nothing - , attrs = ["call-stack" ~= prettyCallStack callStack] - } - } + let !maybeCallStack = popCallStack callStack `onlyIf` (not . isEmptyCallStack) + in logger + <& MyTelemetryData'LogRecord + { logRecord = + LogRecord + { body + , maybeSeverity = Just severity + , maybeTimeUnixNano = Nothing + , attrs = ["call-stack" ~= (prettyCallStack <$> maybeCallStack)] + } + } {- | Use a `Logger` to log an exception. @@ -248,3 +249,19 @@ -- What's that like? toNanos :: TimeSpec -> Timestamp toNanos t = 1_000_000_000 * fromIntegral t.sec + fromIntegral t.nsec + +{- | +Internal helper. + +Return the first argument only if the predicate holds. +-} +onlyIf :: a -> (a -> Bool) -> Maybe a +onlyIf a p = if p a then Just a else Nothing + +{- | +Internal helper. + +Test if a `CallStack` is empty. +-} +isEmptyCallStack :: CallStack -> Bool +isEmptyCallStack = null . IsList.toList