diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -1,3 +1,88 @@ +### 0.8.0.0 + +The version 0.7.0.0 was skipped to avoid confusion with `eventlog-live-otelcol-0.7.0.0`. + +- Merge the executable `eventlog-live-otelcol` into this package as `eventlog-live-otlp`. + +- Add support for OpenTelemetry Environment Variable Configuration: + + The following SDK configuration options are supported: + https://opentelemetry.io/docs/specs/otel/configuration/sdk-environment-variables/#general-sdk-configuration + - `OTEL_RESOURCE_ATTRIBUTES` + - `OTEL_SERVICE_NAME` + - `OTEL_LOG_LEVEL` + - `OTEL_TRACES_EXPORTER`, `OTEL_METRICS_EXPORTER`, `OTEL_LOGS_EXPORTER`, and `OTEL_PROFILES_EXPORTER` + + The following OTLP exporter configuration options are supported: + https://opentelemetry.io/docs/specs/otel/protocol/exporter/ + - `OTEL_EXPORTER_OTLP_ENDPOINT` + - `OTEL_EXPORTER_OTLP_INSECURE` + - `OTEL_EXPORTER_OTLP_CERTIFICATE` (only by `grpc` protocol) + - `OTEL_EXPORTER_OTLP_CLIENT_KEY` (parsed but ignored) + - `OTEL_EXPORTER_OTLP_CLIENT_CERTIFICATE` (parsed but ignored) + - `OTEL_EXPORTER_OTLP_HEADERS` (only by `http/protobuf` protocol) + - `OTEL_EXPORTER_OTLP_TIMEOUT` (parsed but ignored, support to be added in next version) + - `OTEL_EXPORTER_OTLP_PROTOCOL` (only `grpc` and `http/protobuf` protocols are supported) + + All special-specific variants of the above environment variables are supported, e.g., `OTEL_EXPORTER_OTLP_TRACES_ENDPOINT`, `OTEL_EXPORTER_OTLP_METRICS_ENDPOINT`, `OTEL_EXPORTER_OTLP_LOGS_ENDPOINT`, and `OTEL_EXPORTER_OTLP_PROFILES_ENDPOINT` are all parsed and used. + + The command-line arguments that controlled these options have been removed: + + ``` + --service-name -> OTEL_SERVICE_NAME + --verbosity -> OTEL_LOG_LEVEL + --otlp-protocol -> OTEL_EXPORTER_OTLP_PROTOCOL + --otlp-endpoint -> OTEL_EXPORTER_OTLP_ENDPOINT + --otlp-grpc-certificate-store -> OTEL_EXPORTER_OTLP_CERTIFICATE + --otlp-http-headers -> OTEL_EXPORTER_OTLP_HEADERS + ``` + +- The `--otlp-grpc-ssl-key-log` and `--otlp-grpc-ssl-key-log-from-env` options were removed. + + Support for setting a gRPC SSL keylog was removed. If you relied on this, please open an issue. + +- Support was added for _signal-specific exporters_, e.g., if you supply different values for `OTEL_EXPORTER_OTLP_TRACES_ENDPOINT` and `OTEL_EXPORTER_OTLP_METRICS_ENDPOINT` then traces and metrics are exported to different endpoints. + + You can use signal-specific exporter selection to disable certain signals altogether, e.g., `OTEL_TRACES_EXPORTER=none` causes no traces to be exported. + +### 0.6.0.0 + +- Add support for `ipedb` databases for IPE and cost-centre information. +- **BREAKING**: Refactor profiles processors. +- **BREAKING**: Use `InfoProv`, `CostCentre`, and `SrcLoc` types from `ipedb`. + +### 0.5.0.0 + +- Overhaul documentation for `GHC.Eventlog.Live.Machine.Core`. +- **BREAKING**: Drop `counterBy` and `counterByTick`. +- **BREAKING**: Drop `batchListToTick` and `batchListToTicks`. +- **BREAKING**: Drop `batchToTick` and `batchToTicks`. +- **BREAKING**: Drop `aggregateByTick` and `aggregateByTicks`. +- **BREAKING**: Drop `liftBatch`. +- **BREAKING**: Rename `sortByBatchTick` to `sortByTick`. +- **BREAKING**: Change `batchByTick` and `batchByTicks` to preserve ticks. +- **BREAKING**: Generalise `sortByBatch`, `sortByTick`, and `validateOrder` to work on arbitrary keys. +- **BREAKING**: Rename `between` to `betweenFirst`. +- **BREAKING**: Generalise `betweenFirst` and `delimit` to work on arbitrary items. +- Add `betweenEach`. +- **BREAKING**: Change `liftRouter` to ignore inputs after the child process stops. +- Add `fanoutTick`. +- **BREAKING**: Add implicit `TickInfo` to each `Tick` via `HasTickInfo`. +- **BREAKING**: Change `onlyTick` to yield actual `Tick` values. +- **BREAKING**: Change interval argument for `runWithEventlogSource` and `sourceHandleBatch` to batch in milliseconds. +- **BREAKING**: Add `AttrBoot` to `AttrValue`. +- Add support for user messages and markers. +- **BREAKING**: Replace logging with `co-log-core` contravariant `LogAction`. +- Add support for concurrent `fanoutTickCC` and `mergeWithTickCC`. +- **BREAKING**: Rename `EventlogSource` to `EventlogSourceOptions`. +- **BREAKING**: Rename `GHC.Eventlog.Live.Socket` to `GHC.Eventlog.Live.Source`. +- Add `GHC.Eventlog.Live.Source.Core`. +- **BREAKING**: Move `EventlogSourceOptions` to `GHC.Eventlog.Live.Source.Core`. +- Add `EventlogSourceHandle`. +- **BREAKING**: Rename `runWithEventlogSource` to `runWithEventlogSourceOptions`. +- Add `withEventlogSourceHandle` and `runWithEventlogSourceHandle` to `GHC.Eventlog.Live.Source`. +- **BREAKING**: Rename `sourceHandleBatch` to `eventlogSourceTick`. + ### 0.4.0.0 - Add parser for `--stats` flag (`statsParser`). diff --git a/LICENSE b/LICENSE --- a/LICENSE +++ b/LICENSE @@ -1,4 +1,4 @@ -Copyright (c) 2021-2025 Well-Typed +Copyright (c) 2021-2026 Well-Typed Redistribution and use in source and binary forms, with or without diff --git a/README.md b/README.md new file mode 100644 --- /dev/null +++ b/README.md @@ -0,0 +1,667 @@ +![GitHub Actions Workflow Status](https://img.shields.io/github/actions/workflow/status/well-typed/eventlog-live/ci.yml?style=for-the-badge) ![Hackage Version](https://img.shields.io/hackage/v/eventlog-live?style=for-the-badge) ![License: BSD-3-Clause](https://img.shields.io/badge/license-BSD--3--Clause-blue?style=for-the-badge) ![Stability: Experimental](https://img.shields.io/badge/stability-experimental-yellow?style=for-the-badge) + +_Real-time monitoring for any Haskell application with little to no instrumentation!_ + +# Eventlog Live + +> ⚠️ **Warning:** +> This package is experimental. +> It is versioned according to the [PVP](https://pvp.haskell.org). +> Breaking changes should be expected and no effort will be made to avoid major version bumps until at least version 1.0.0.0. + +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_. + +![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) + +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. + +- **Eventlog Socket – Sockets and Dynamic Control** + + 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. + + ![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) + +- **GHC Stack Profiler – Lightweight Call-Stack Profiles** + + The [`ghc-stack-profiler`](https://github.com/well-typed/ghc-stack-profiler) package lets you sample your application's call-stack using a lightweight sampler that can be turned on and off at runtime using `eventlog-socket`'s control protocol. + + 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`. + + ![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) + +## 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. +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. + +The [`demo-grafana-cloud`](demo-grafana-cloud/) directory contains an example that runs `jumpy-jump` and Eventlog Live, and sends data directory to Grafana Cloud. This demo shows heap profiles, logs, and cost-centre stack profiles. + +The [`demo-nix`](demo-nix/) directory contains a [Nix](https://nixos.org) configuration that builds a self-contained virtual machine that runs `oddball`, Eventlog Live, Grafana, and Prometheus. This demo shows heap profiles. + +## Getting Started + +Let's get Evenlog Live working with your application, which we'll conveniently call `your-application`. + +We'll start by getting the basic version of Evenlog Live working and progressively add features. + +### Eventlog Live – The Basic Version + +For the barebones version, you need three things: + +1. You need Eventlog Live, specifically the `eventlog-live-otlp` executable. + + To build Eventlog Live from source, you'll need: + - GHC version 9.4 up to 9.12 (inclusive). + - Cabal version 3.12 or later. + - A recent [Protocol Buffer Compiler](https://protobuf.dev/installation/). + + Run: + + ```sh + cabal install eventlog-live:eventlog-live-otlp \ + --constraint='blockio +serialblockio' \ + --constraint='grpc-spec -snappy' + ``` + + The `+serialblockio` flag makes `blockio` use serial I/O, as opposed to parallel I/O. If you are on Linux and have [`liburing`](https://github.com/axboe/liburing) installed, you can omit this flag and get slightly faster disk I/O. + + The `-snappy` flag makes `grpc-spec` support snappy compression. If you have [snappy](https://github.com/google/snappy) installed, you can omit this flag and get slightly faster gRPC compression. + +2. You must have _somewhere_ to send the telemetry data. + + Any observability platform that supports OpenTelemetry works. The [demo-grafana-cloud](demo-grafana-cloud/) has a guide for setting up [Grafana Cloud](https://grafana.com). + For the purposes of this guide, you can run the following [Docker Compose](https://docs.docker.com/compose/) from the root of the repository. + + ```sh + docker compose -f demo/docker-compose-external.yml up --build --detach + ``` + + Eventlog Live supports [OpenTelemetry environment variables](https://opentelemetry.io/docs/specs/otel/configuration/sdk-environment-variables). For this guide, we'll assume you used the docker command, which starts an OLTP gRPC receiver on port 4317. If you're using some other endpoint, you'll have to adapt these configuration options. + +3. Your application must be compiled with support for RTS options, the threaded runtime, and the eventlog. + + Add the following to the `executable` section of `your-application.cabal`: + + ```diff + executable my-app + ... + + + ghc-options: -rtsopts + + ghc-options: -threaded + + if impl(ghc < 9.4) + + ghc-options: -eventlog + ``` + + The [`-rtsopts`](https://downloads.haskell.org/ghc/latest/docs/users_guide/phases.html#ghc-flag-rtsopts-none-some-all-ignore-ignoreAll) flag enables the RTS options for your application. This allows us to enable the eventlog at runtime and enable various kinds of profiling. Setting this option may pose a security risk. If this is a concern, you can set all the required RTS options at compile time using [`-with-rtsopts`](https://downloads.haskell.org/ghc/latest/docs/users_guide/phases.html#ghc-flag-with-rtsopts-opts). (See [the next section](#configuring-your-application-for-monitoring) for the necessary RTS options). + + The [`-eventlog`](https://downloads.haskell.org/ghc/latest/docs/users_guide/phases.html#ghc-flag-with-rtsopts-opts) flag builds eventlog support into your application. This is enabled unconditionally since GHC 9.4, but if you're using GHC 9.2 or earlier, you must explicitly pass this flag. + + The [`-threaded`](https://downloads.haskell.org/ghc/latest/docs/users_guide/phases.html#ghc-flag-threaded) flag builds your application with the threaded RTS. This is required because one crucial RTS option, `--eventlog-flush-interval`, is only safe to use with the threaded RTS. + +To start monitoring your application, pipe its eventlog to Eventlog Live: + +```sh +# OpenTelemetry Configuration +export OTEL_LOG_LEVEL="debug" +export OTEL_SERVICE_NAME="your-application" +export OTEL_EXPORTER_OTLP_PROTOCOL="grpc" + +# Create a pipe for the eventlog +EVENTLOG_PIPE="/tmp/eventlog.pipe" +mkfifo "${EVENTLOG_PIPE}" + +# Start your application +your-application \ + +RTS \ + -l \ + -ol"${EVENTLOG_PIPE}" \ + -hT \ + --eventlog-flush-interval=1 \ + -RTS & + +# Start eventlog-live-otlp +eventlog-live-otlp \ + --eventlog-file="${EVENTLOG_PIPE}" \ + -hT \ + --eventlog-flush-interval=1 + +# See: examples/oddball/oddball-with-pipe.sh +``` + +If you run these commands, you should start seeing telemetry show up on your dashboard. + +- Navigate to Grafana at . +- Log in with username `admin` and password `admin`. +- Select '☰ > Dashboards > Heap Profiles' + + 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) + +- 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) + + 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) + +Let's briefly discuss what this script does: + +- **The OpenTelemetry Configuration.** + + The Eventlog Live exporter is configured using the [OpenTelemetry environment variables](https://opentelemetry.io/docs/specs/otel/configuration/sdk-environment-variables). + - `OTEL_LOG_LEVEL` sets Eventlog Live's log level. + - `OTEL_SERVICE_NAME` sets the service name under which your application's telemetry shows up on your dashboard. + - `OTEL_EXPORTER_OTLP_PROTOCOL` selects the exporter's protocol. The default is `http/protobuf`, but the docker setup uses gRPC. If the protocol is gRPC, the default endpoint is `http://localhost:4317`, which is what our docker setup uses. + +- **The Eventlog.** + + In this example, the eventlog is sent from your application's RTS to Eventlog Live via a named pipe. + The [`mkfifo`](https://www.man7.org/linux/man-pages/man1/mkfifo.1.html) command creates a named pipe. + The [`-l`](https://downloads.haskell.org/ghc/latest/docs/users_guide/runtime_control.html#rts-flag-l-flags) flag passed to your application's RTS tells it to write the eventlog in binary form and the [`-ol`](https://downloads.haskell.org/ghc/latest/docs/users_guide/runtime_control.html#rts-flag-olfilename) flag tells it to write it to the named pipe. + The `--eventlog-file` flag passed to Eventlog Live tells it to read the eventlog from the named pipe. + +- **Eventlog flushing**. + + The [`--eventlog-flush-interval=1`](https://downloads.haskell.org/ghc/latest/docs/users_guide/runtime_control.html#rts-flag-eventlog-flush-interval-seconds) flag passed to your application's RTS tells it to flush the eventlog every second. + + The `--eventlog-flush-interval=1` flag passed to Eventlog Live tells it your application's flush interval. + + The eventlog must be sorted for various analyses. In the RTS, events accumulate in per-capability buffers, which are usually only flushed when they fill up. This makes it impossible to sort the incoming eventlog, as events could be arbitrarily delayed. + + Flushing the eventlog may have a significant performance impact, as each flush requires all threads in your application to synchronise. To mitigate this, you may want to increase the flush interval in production. + As a rule of thumb: + - If you pass `--eventlog-flush-interval=N` to your application, it synchronises all threads every `N` seconds. + + - If you pass `--eventlog-flush-interval=N` to Eventlog Live, your telemetry data is delayed by at least `2N` seconds, more if you configure longer aggregation or export intervals. + + Usually, you want to pass the same value to both your application and Eventlog Live. However, there is no harm in passing Eventlog Live a higher value and, if you are seeing many out-of-order event warnings, doing so may solve that. + + > ⚠️ **Warning:** + > Passing `--eventlog-flush-interval=N` to an executable that was built without `-threaded` throws an error in GHC 9.14 and later, and causes eventlog corruption in GHC version 9.12 an earlier. + > See GHC issue [#26222](https://gitlab.haskell.org/ghc/ghc/-/issues/26222) for details. + +- **Heap profiles.** + + The [`-h`](https://downloads.haskell.org/ghc/latest/docs/users_guide/profiling.html#rts-options-for-heap-profiling) flag passed to your application's RTS tells it to enable Heap Profiling, which provides a detailed breakdown of memory usage. + The `T` argument selects the "closure type" breakdown, which is the most well-supported breakdown and should work for every application without any further configuration. This will tell you which symbol is responsible for each heap segment, e.g., `ghc-prim:GHC.Tuple.(,)`. + (Heap Profiling by Info Table is discussed under [Eventlog Live with Heap Profiling by Info Table](#eventlog-live-with-heap-profiling-by-info-table).) + + The `-hT` flag passed to Eventlog Live tells it your application's heap profile breakdown. + This is only needed if your application was built wih GHC 9.12 or older, as those versions did not send the heap profile breakdown over the eventlog, but there's no harm in passing it even if your application was built with a more recent version of GHC. + + > ⚠️ **Warning:** + > Heap profiling has a significant performance impact, as each sample requires a major garbage collection. The default sampling interval is 0.1, but this can be adjusted with the [`-i`](https://downloads.haskell.org/ghc/latest/docs/users_guide/profiling.html#rts-flag-i-secs) flag. + > + > Heap profiling can be enabled/disabled at runtime from within your application using the functions in [`GHC.Profiling`](https://hackage.haskell.org/package/base/docs/GHC-Profiling.html). If you plan to use these functions, you can pass [`--no-automatic-heap-samples`](https://downloads.haskell.org/ghc/latest/docs/users_guide/profiling.html#rts-flag-no-automatic-heap-samples) to disable heap samples until you first call [`startHeapProfTimer`](https://hackage.haskell.org/package/base-4.21.0.0/docs/GHC-Profiling.html#v:startHeapProfTimer). + > + > Alternatively, heap profiling can be enabled/disabled by Eventlog Live, e.g., using the Start/Stop buttons on the Heap Profiles dashboard. This requires that your application was instrumented with `eventlog-socket` using the `+control` flag. This is discussed under [Eventlog Live with Eventlog Socket](#eventlog-live-with-eventlog-socket). + +### Eventlog Live with Eventlog Socket + +Eventlog Socket gives us two things: + +- If instrumented with Eventlog Socket, your application can write the eventlog to a Unix domain socket or a TCP/IP socket. + +- If `eventlog-socket` is compiled with the `+control` feature flag, your application can read control messages from the eventlog socket. The builtin control messages can be used, e.g., to enable/disable heap or stack profiling at runtime. However, Eventlog Socket's control protocol is extensible. You can register new command messages from within your application using any Haskell function as their callbacks. + + > ⚠️ **Warning:** + > For security reasons, the Eventlog Socket control protocol is hidden behind a feature flag. If you do not enable the `+control` feature flag at compile time, none of the code that handles the the control protocol will be present in the library. + +To instrument your application with Eventlog Socket, you need to make four small changes: + +1. Add `eventlog-socket` to the `build-depends` for your application: + + ```diff + executable your-application + ... + + build-depends: + ... + + , eventlog-socket >=0.1.2 && <0.2 + ``` + +2. Instrument your main function: + + ```diff + module Main where + ... + + + import qualified GHC.Eventlog.Socket + + main :: IO () + main = do + + GHC.Eventlog.Socket.startFromEnv + ... + ``` + + There are various ways to start Eventlog Socket. For more details, see [the Haddock documentation](https://hackage-content.haskell.org/package/eventlog-socket-0.1.3.0/docs/GHC-Eventlog-Socket.html). + The [`startFromEnv`](https://hackage-content.haskell.org/package/eventlog-socket-0.1.3.0/docs/GHC-Eventlog-Socket.html#v:startFromEnv) function reads the Eventlog Socket configuration from environment variables: + - If `GHC_EVENTLOG_UNIX_PATH` is set, + it opens a Unix domain socket at the given path. + - If `GHC_EVENTLOG_INET_HOST` and `GHC_EVENTLOG_INET_PORT` are set, + it opens a TCP/IP socket at the given address. + - If `GHC_EVENTLOG_WAIT` is set, + it pauses the program until some other process connects to the socket. + +3. Build your application with support for the control protocol. + + You must ensure that its `eventlog-socket` dependency is built with the `+control` feature flag. + - During development, the easiest way to do this is to add the following to your `cabal.project` file: + + ``` + package eventlog-socket + flags: + +control + ``` + + - During installation, the easiest way to do this is to pass the `--constraint` flag: + + ```sh + cabal install your-application \ + --constraint='eventlog-socket +control' + ``` + +4. Build Eventlog Live with support for the control server. + + You must ensure that `eventlog-live-otlp` is built with the `+control` feature flag. + + ```sh + cabal install eventlog-live:eventlog-live-otlp \ + -f+control \ + --constraint='blockio +serialblockio' \ + --constraint='grpc-spec -snappy' + ``` + + When built with the `+control` feature flag, Eventlog Live supports starting the control server, an HTTP server that offers a REST interface to the control protocol, which you can call from, e.g., the buttons on your Grafana dashboard. + +To start monitoring your application, pass the same socket to it and Eventlog Live: + +```sh +# Eventlog Socket Configuration +export GHC_EVENTLOG_UNIX_PATH="/tmp/eventlog.sock" +export GHC_EVENTLOG_WAIT="true" + +# OpenTelemetry Configuration +export OTEL_LOG_LEVEL="debug" +export OTEL_SERVICE_NAME="your-application" +export OTEL_EXPORTER_OTLP_PROTOCOL="grpc" + +# Start your application +your-application \ + +RTS \ + -l \ + -hT \ + --eventlog-flush-interval=1 \ + -RTS & + +# Start eventlog-live-otlp +eventlog-live-otlp \ + --eventlog-socket="${GHC_EVENTLOG_UNIX_PATH}" \ + -hT \ + --eventlog-flush-interval=1 \ + --control \ + --control-port=30719 \ + --control-cors-ignore-failure + +# See: examples/oddball/oddball-with-hT.sh +``` + +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) + +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. + +Let's briefly discuss what the new parts of this script do: + +- The `GHC_EVENTLOG_UNIX_PATH` and `GHC_EVENTLOG_WAIT` environment variables configure Eventlog Socket, see above. + +- The `--control` and `--control-port=30719` flags passed to Eventlog Live tells it to start the control server on port 30719, which is the port used in the Grafana dashboards included in the demo. + +- The `--control-cors-ignore-failure` flag passed to Eventlog Live tells it to ignore and accept malformed [CORS preflight requests](https://en.wikipedia.org/wiki/Cross-origin_resource_sharing). + This is a workaround for Safari's broken CORS preflight requests for localhost. + You should not pass this flag in production. + +### Eventlog Live with Cost-Centre Stack Profiling + +Cost-Centre Stack Profiling is [GHC's builtin time profiler](https://downloads.haskell.org/ghc/latest/docs/users_guide/profiling.html#time-and-allocation-profiling). When enabled, cost-centre profiling maintains virtual cost-centre stacks that contain entries for all symbols marked as cost centres. + +To use Cost-Centre Stack Profiling, you must make two changes: + +1. Build your application and its dependencies must be built with profiling. + - During development, the easiest way to do this is to add the following to your `cabal.project` file: + + ``` + profiling: True + ``` + + - During installation, the easiest way to do this is to pass the `--enable-profiling` flag: + + ```sh + cabal install your-application --enable-profiling + ``` + +2. Add cost centres to your application. + + If you are only interested in specific symbols, you can manually add cost centres using the `SCC` pragma, e.g., + + ```diff + + {-# SCC myGreeter #-} + myGreeter :: String -> String + myGreeter name = "Hello, " <> name + ``` + + If you would like to automatically add cost centres for all symbols, you can use the Cabal [`profiling-detail`](https://cabal.readthedocs.io/en/3.18/cabal-project-description-file.html#cfg-flag---profiling-detail) option. + The easiest way to add cost centres for all packages is to add the following to your `cabal.project` file: + + ``` + package * + profiling-detail: late + ``` + + There are several different strategies, e.g., `all-functions` and `late`. + Our recommendation is to use `late`. + See [Late Cost Centre Profiling](https://well-typed.com/blog/2023/03/prof-late/). + +To start monitoring your application, run your application and Evenlog Live. The following script builds on the example from [Eventlog Live with Eventlog Socket](#eventlog-live-with-eventlog-socket), but using Cost-Centre Stack Profiling is independent from Eventlog Socket. + +```sh +# Eventlog Socket Configuration +export GHC_EVENTLOG_UNIX_PATH="/tmp/eventlog.sock" +export GHC_EVENTLOG_WAIT="true" + +# OpenTelemetry Configuration +export OTEL_LOG_LEVEL="debug" +export OTEL_SERVICE_NAME="your-application" +export OTEL_EXPORTER_OTLP_PROTOCOL="grpc" + +# Start your application +your-application \ + +RTS \ + -l \ + -p \ + --eventlog-flush-interval=1 \ + -RTS & + +# Start eventlog-live-otlp +eventlog-live-otlp \ + --eventlog-socket="${GHC_EVENTLOG_UNIX_PATH}" \ + --eventlog-flush-interval=1 \ + --control \ + --control-port=30719 \ + --control-cors-ignore-failure + +# See: examples/jumpy-jump/jumpy-jump-with-cost-centre-profiler.sh +# examples/jumpy-jump/jumpy-jump-with-cost-centre-profiler-with-pipe.sh +``` + +If you run these commands, you should start seeing profiles show up on your dashboard. + +- Navigate to Grafana at . +- Log in with username `admin` and password `admin`. +- Select '☰ > Dashboards > Cost-Centre Stack Profiles' + + 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) + +If your application is instrumented with Eventlog Socket, the Start and Stop buttons should enable/disable cost-centre stack profiling. + +Let's briefly discuss what the new parts of this script do: + +- The [`-p`](https://downloads.haskell.org/ghc/latest/docs/users_guide/profiling.html#time-and-allocation-profiling) flag passed to your application's RTS tells it to enable Cost-Centre Stack Profiling. + +> ℹ️ **Tip:** +> When compared to call-stack profiling, a cost-centre stack profile more closely models user expectation. +> For example, in a recursive loop without allocations, the recursive function is not pushed onto the call-stack, and won't show up in a call-stack profile. However, its cost centres _will_ be pushed to the virtual cost-centre stack. + +> ⚠️ **Warning:** +> Cost-centre profiling has a huge runtime overhead. When compiled with profiling, the in-memory representation of all datatypes grows by one word and this alone results in a 50% runtime overhead even without any cost centres and even while running without `-p`, e.g., without maintaining the virtual cost-centre stacks. For production environments, we recommend running GHC Stack Profiler. See [Eventlog Live with GHC Stack Profiler](#eventlog-live-with-ghc-stack-profiler). + +### Eventlog Live with Heap Profiling by Info Table + +In [Eventlog Live – The Basic Version](#eventlog-live-the-basic-version), we told your application's RTS to enable heap profiling, using a breakdown by closure type (`-hT`). While this is incredibly useful, there's a good chance one of the largest categories will be something like `STACK` or `THUNK`. +We can use Heap Profiling by Info Table to get a much more detailed breakdown. + +To use Heap Profiling by Info Table, your application and all its dependencies must be built with the GHC options [`-finfo-table-map`](https://downloads.haskell.org/ghc/latest/docs/users_guide/debug-info.html#ghc-flag-finfo-table-map) and [`-fdistinct-constructor-tables`](https://downloads.haskell.org/ghc/latest/docs/users_guide/debug-info.html#ghc-flag-fdistinct-constructor-tables) GHC options. + +Let's do this in two steps: + +1. To build your application and its dependencies with info table maps, you must ensure that they are built with the `-finfo-table-map` and `-fdistinct-constructor-tables` GHC options. + + The easiest way to do this is to add the following to your `cabal.project` file: + + ``` + package * + ghc-options: + -finfo-table-map + -fdistinct-constructor-tables + ``` + + There is currently no easy way to pass GHC options to all packages when using `cabal install`. + As a workaround, you can add a `cabal.project` file to a source distribution and install from there. + +If you run Heap Profiling by Info Table with your application built this way, you will get detailed information for all the symbols defined in your application and most symbols defined in your dependencies. +However, you will see some unresolved info tables, which will show as numbers, e.g., `0x100000000`. +These are symbols that are either built into GHC or defined in the [_boot libraries_](https://gitlab.haskell.org/ghc/ghc/-/wikis/working-conventions/boot-libraries) that came with GHC, such as `base`. +The boot packages are _never_ rebuilt by Cabal and are unaffected by the `package *` stanza. + +2. To build the GHC and the boot libaries with info table maps, you must build GHC with the `+ipe` flavour. + + The easiest way to do this is using `ghcup`. Some variant of the following command may work for you: + + ```sh + ghcup compile ghc -j0 -b 9.10.3 -v 9.10.3 -f perf+ipe -o '%v-ipe' -- + ``` + + You may need to pass the appropriate configure flags for your platform. + See [Building and Porting GHC](https://gitlab.haskell.org/ghc/ghc/-/wikis/building#building-and-porting-ghc). + +Once you have a version of GHC built with the `+ipe` flavour, you can rebuild your application, and start using Heap Profiling by Info Table. The following script builds on the example from [Eventlog Live with Eventlog Socket](#eventlog-live-with-eventlog-socket), but Heap Profiling by Info Table is independent from Eventlog Socket. + +```sh +# Eventlog Socket Configuration +export GHC_EVENTLOG_UNIX_PATH="/tmp/eventlog.sock" +export GHC_EVENTLOG_WAIT="true" + +# OpenTelemetry Configuration +export OTEL_LOG_LEVEL="debug" +export OTEL_SERVICE_NAME="your-application" +export OTEL_EXPORTER_OTLP_PROTOCOL="grpc" + +# Start your application +your-application \ + +RTS \ + -l \ + -hi \ + --eventlog-flush-interval=1 \ + -RTS & + +# Start eventlog-live-otlp +eventlog-live-otlp \ + --eventlog-socket="${GHC_EVENTLOG_UNIX_PATH}" \ + -hi \ + --eventlog-flush-interval=1 \ + --control \ + --control-port=30719 \ + --control-cors-ignore-failure + +# See: examples/oddball/oddball-with-hi.sh +``` + +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) + +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. + +Let's briefly discuss what the new parts of this script do: + +- The [`-hi`](https://downloads.haskell.org/ghc/latest/docs/users_guide/profiling.html#rts-options-for-heap-profiling) flag passed to your application's RTS tells it to enable Heap Profiling by Info Table. + + As before, the `-hi` flag passed to Eventlog Live tells it your application's heap profile breakdown. + +### Eventlog Live with GHC Stack Profiler + +[GHC Stack Profiler](https://github.com/well-typed/ghc-stack-profiler) is a lightweight profiler that samples the runtime call-stack and writes these to the eventlog. It only has an 5-10% overhead while running. When compiled with the `+control` feature flag, it supports Eventlog Socket's command protocol, which lets you enable/disable samples at runtime. + +To instrument your application with GHC Stack Profiler, you need to make three changes: + +1. Add `ghc-stack-profiler` to the `build-depends` for your application: + + ```diff + executable your-application + ... + + build-depends: + ... + + , ghc-stack-profiler >=0.4 && <0.5 + ``` + +2. Instrument your main function: + + ```diff + module Main where + ... + + + import qualified GHC.Stack.Profiler as GSP + + main :: IO () + main = do + + GSP.withRootStackProfiler True $ \manager -> + + GSP.withStackProfiler manager (GSP.SampleIntervalMs 100) $ + ... + ``` + + The current version of GHC Stack Profiler requires you to set the sampling interval at compile-time. + +3. Build your application and its dependencies with info table maps. + + For detailed instructions, see [Eventlog Live with Heap Profiling by Info Table](#eventlog-live-with-heap-profiling-by-info-table). + +To start monitoring your application, run your application and Evenlog Live. The following script builds on the example from [Eventlog Live with Heap Profiling by Info Table](#eventlog-live-with-heap-profiling-by-info-table), but using GHC Stack Profiler is independent from Eventlog Socket and while it needs info table maps, it does not require _running_ an Info Table Profile (`-hi`). + +```sh +# Eventlog Socket Configuration +export GHC_EVENTLOG_UNIX_PATH="/tmp/eventlog.sock" +export GHC_EVENTLOG_WAIT="true" + +# OpenTelemetry Configuration +export OTEL_LOG_LEVEL="debug" +export OTEL_SERVICE_NAME="your-application" +export OTEL_EXPORTER_OTLP_PROTOCOL="grpc" + +# Start your application +your-application \ + +RTS \ + -l \ + -hi \ + --eventlog-flush-interval=1 \ + -RTS & + +# Start eventlog-live-otlp +eventlog-live-otlp \ + --eventlog-socket="${GHC_EVENTLOG_UNIX_PATH}" \ + -hi \ + --eventlog-flush-interval=1 \ + --control \ + --control-port=30719 \ + --control-cors-ignore-failure + +# See: examples/jumpy-jump/jumpy-jump-with-ghc-stack-profiler.sh +``` + +If you run these commands, you should start seeing profiles show up on your dashboard. + +- Navigate to Grafana at . +- Log in with username `admin` and password `admin`. +- Select '☰ > Dashboards > Call-Stack Profiles' + + 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) + +If your application is instrumented with Eventlog Socket, the Start and Stop buttons should enable/disable call-stack profiling. + +> ℹ️ **Tip:** +> You can use the [`annotateStackIO`](https://hackage-content.haskell.org/package/ghc-experimental-9.1401.0/docs/GHC-Stack-Annotation-Experimental.html#v:annotateStackIO) functions from `ghc-experimental` to push annotation frames onto the call-stack at runtime. +> These annotation frames are visible in call-stack profiles captured by GHC Stack Profiler. +> See [Better Haskell stack traces via user annotations](https://www.well-typed.com/blog/2025/09/better-haskell-stack-traces/). + +> ⚠️ **Warning:** +> Due to a bug in GHC, copying the call-stack may cause a segfault at runtime in applications built with GHC 9.14 and older. +> If you use GHC Stack Profiler in production, you should build your application with GHC 10 or later. + +## Fine-Tuning Eventlog Live + +### Configuration Files + +The telemetry data produced by Eventlog Live can be configured in great detail via configuration files. +These let you enable/disable each individual telemetry stream and control their aggregation and export intervals. +The [default configuration](eventlog-live-otlp/data/default.yaml) file contains comments that explain what each option means. +To get started, you can write the default configuration to a file using the following command: + +```sh +eventlog-live-otlp --print-defaults > eventlog-live.yaml +``` + +To pass a configuration file to Eventlog Lie, use the `--config` flag: + +```sh +eventlog-live-otlp --config=eventlog-live.yaml ... +``` + +For validation and editor support, Eventlog Live ships with a JSON Schema for the configuration file format. +To print the [JSON Schema](eventlog-live-otlp/data/config.schema.json), run the following command: + +```sh +eventlog-live-otlp --print-config-json-schema +``` + +> ℹ️ **Tip:** +> If you use the RedHat YAML language server, you can instruct your editor to load this schema. +> See [Associating schemas](https://github.com/redhat-developer/yaml-language-server/blob/538c8abb924acf727a136351a42a0c34a8b35bae/README.md#associating-schemas). + +> ℹ️ **Tip:** +> The configuration files are parsed using [`HsYAML`](https://hackage.haskell.org/package/HsYAML) which is a [YAML 1.2](https://yaml.org/spec/1.2/spec.html) compliant parser. + +### Restricted Event Classes + +If you're only interested in particular kinds of telemetry signals, you may be able to configure your application to only write out certain classes of events. This can help save memory usage and bandwidth on the eventlog pipe or socket. + +For example, if you're not interested in productivity and the thread state and capability usage spans (which are disabled by default), you can disable the class of scheduler events. Replace the `-l` flag passed to your application's RTS with `-la-s` (which means "all minus scheduler"). + +```diff + your-application \ + +RTS \ +- -l \ ++ -la-s \ + ... +``` + +For a detailed overview of event classes, see [GHC's users guide](https://downloads.haskell.org/ghc/latest/docs/users_guide/runtime_control.html#rts-flag-l-flags). + +### Info Table and Cost-Centre Databases + +If your application is particularly large, you might want to strip its info table or cost centre maps. +You can use [IpeDB](https://github.com/well-typed/ipedb) to build an info table database or cost centre database for your executable. +These databases can be passed to Eventlog Live via the `--ipedb` and `--ccdb` flags. +Once you have built an info table database for your application, you can safely make the following changes: + +- If you application was built with GHC 10 or later, you can also restrict the IPE event class using `I`, e.g., `-la-I`. + For more details, see [Restricted Event Classes](#restricted-event-classes). +- If your application was built with GHC 9.14 or later, the info table maps are stored in named `.ipe` sections. + These sections can be safely stripped from the executable. + +There is currently no method for safely stripping cost-centre information. diff --git a/app/eventlog-live-otlp.hs b/app/eventlog-live-otlp.hs new file mode 100644 --- /dev/null +++ b/app/eventlog-live-otlp.hs @@ -0,0 +1,8 @@ +{-# LANGUAGE NoImplicitPrelude #-} +{-# OPTIONS_GHC -Wno-missing-signatures #-} + +module Main where + +import GHC.Eventlog.Live.Otlp qualified (main) + +main = GHC.Eventlog.Live.Otlp.main diff --git a/data/config.schema.json b/data/config.schema.json new file mode 100644 --- /dev/null +++ b/data/config.schema.json @@ -0,0 +1,169 @@ +{ + "$schema": "https://json-schema.org/draft-07/schema", + "title": "Config", + "description": "Configuration for the eventlog-live-otlp program", + "type": "object", + "properties": { + "processors": { + "type": "object", + "properties": { + "defaults": { "#ref": "#/definitions/processor_defaults" }, + "logs": { + "type": "object", + "defaults": { "#ref": "#/definitions/log_defaults" }, + "thread_label": { "#ref": "#/definitions/log" }, + "user_marker": { "#ref": "#/definitions/log" }, + "user_message": { "#ref": "#/definitions/log" }, + "internal_log_message": { "#ref": "#/definitions/log" } + }, + "metrics": { + "type": "object", + "properties": { + "defaults": { "#ref": "#/definitions/metric_defaults" }, + "blocks_size": { "$ref": "#/definitions/metric" }, + "capability_usage": { "$ref": "#/definitions/metric" }, + "heap_allocated": { "$ref": "#/definitions/metric" }, + "heap_live": { "$ref": "#/definitions/metric" }, + "heap_prof_sample": { "$ref": "#/definitions/metric" }, + "heap_size": { "$ref": "#/definitions/metric" }, + "mem_current": { "$ref": "#/definitions/metric" }, + "mem_needed": { "$ref": "#/definitions/metric" }, + "mem_returned": { "$ref": "#/definitions/metric" } + }, + "additionalProperties": false + }, + "traces": { + "type": "object", + "properties": { + "defaults": { "#ref": "#/definitions/trace_defaults" }, + "capability_usage": { "$ref": "#/definitions/trace" }, + "thread_state": { "$ref": "#/definitions/trace" } + }, + "additionalProperties": false + }, + "profiles": { + "type": "object", + "properties": { + "defaults": { "#ref": "#/definitions/profile_defaults" }, + "call_stack_profile": { "$ref": "#/definitions/profile" }, + "cost_centre_stack_profile": { "$ref": "#/definitions/profile" } + }, + "additionalProperties": false + } + } + } + }, + "definitions": { + "duration": {}, + "duration_by_batches": { + "type": "string", + "pattern": "^([0-9]+)(x)$" + }, + "duration_by_seconds": { + "type": "string", + "pattern": "^([0-9]+(\\.[0-9]+)?)(s)$" + }, + "aggregation_strategy": { + "oneOf": [ + { "type": "null" }, + { "$ref": "#/definitions/aggregation_strategy_bool" }, + { "$ref": "#/definitions/aggregation_strategy_duration" } + ] + }, + "aggregation_strategy_bool": { + "type": "boolean" + }, + "aggregation_strategy_duration": { + "oneOf": [ + { "$ref": "#/definitions/duration_by_batches" }, + { "$ref": "#/definitions/duration_by_seconds" } + ] + }, + "export_strategy": { + "oneOf": [ + { "type": "null" }, + { "$ref": "#/definitions/export_strategy_bool" }, + { "$ref": "#/definitions/export_strategy_duration" } + ] + }, + "export_strategy_bool": { + "type": "boolean" + }, + "export_strategy_duration": { + "oneOf": [ + { "$ref": "#/definitions/duration_by_batches" }, + { "$ref": "#/definitions/duration_by_seconds" } + ] + }, + "processor_defaults": { + "description": "An optional 'defaults' block for defining YAML anchors.", + "properties": { + "export": { "$ref": "#/definitions/export_strategy" }, + "aggregate": { "$ref": "#/definitions/aggregation_strategy" } + }, + "additionalProperties": false + }, + "log": { + "properties": { + "name": { "type": "string" }, + "description": { "type": "string" }, + "export": { "$ref": "#/definitions/export_strategy" } + }, + "additionalProperties": false + }, + "log_defaults": { + "description": "An optional 'defaults' block for defining YAML anchors.", + "properties": { + "export": { "$ref": "#/definitions/export_strategy" } + }, + "additionalProperties": false + }, + "metric": { + "properties": { + "name": { "type": "string" }, + "description": { "type": "string" }, + "export": { "$ref": "#/definitions/export_strategy" }, + "aggregate": { "$ref": "#/definitions/aggregation_strategy" } + }, + "additionalProperties": false + }, + "metric_defaults": { + "description": "An optional 'defaults' block for defining YAML anchors.", + "properties": { + "export": { "$ref": "#/definitions/export_strategy" }, + "aggregate": { "$ref": "#/definitions/aggregation_strategy" } + }, + "additionalProperties": false + }, + "trace": { + "properties": { + "name": { "type": "string" }, + "description": { "type": "string" }, + "export": { "$ref": "#/definitions/export_strategy" } + }, + "additionalProperties": false + }, + "trace_defaults": { + "description": "An optional 'defaults' block for defining YAML anchors.", + "properties": { + "export": { "$ref": "#/definitions/export_strategy" } + }, + "additionalProperties": false + }, + "profile": { + "properties": { + "name": { "type": "string" }, + "description": { "type": "string" }, + "export": { "$ref": "#/definitions/export_strategy" } + }, + "additionalProperties": false + }, + "profile_defaults": { + "description": "An optional 'defaults' block for defining YAML anchors.", + "properties": { + "export": { "$ref": "#/definitions/export_strategy" } + }, + "additionalProperties": false + } + } +} diff --git a/data/default.yaml b/data/default.yaml new file mode 100644 --- /dev/null +++ b/data/default.yaml @@ -0,0 +1,147 @@ +# Configuration for the eventlog processors, organised by the type of telemetry +# data they produce. Every processor shares certain properties. Let's look at +# the default configuration for the `blocks_size` metrics processor: +# +# blocks_size: +# name: ghc_eventlog_BlocksSize +# description: The current heap size, calculated by the allocated number of blocks. +# aggregate: 1s +# export: 60s +# +# - The `name` property is added to each piece of telemetry data, +# and determines the name under which the data becomes available in your +# data source, such as Prometheus. +# +# The data produced by our example `blocks_size` processor will be available +# in Prometheus as `ghc_eventlog_BlocksSize`. +# +# - The `description` property is added to each piece of telemetry data, +# and may be used to describe it. In most cases, this can be safely set +# to `null` to save bandwidth. +# +# The data produced by our example `blocks_size` processor will be given the +# above description. +# +# - The `export` property determines whether or not the telemetry data is +# exported to the OpenTelemetry Collector and, if so, with what frequency. +# +# There are three ways to configure the `export` property: +# +# - A duration in seconds, given as "Ns". For instance, if `export` is "30s" +# then the processor exports a batch of telemetry data every 30 seconds. +# +# - A duration in batches, given as "Nx". The length of one batch interval +# is determined by the `--eventlog-flush-interval=SECONDS` flag, as passed +# to the RTS of the monitored process and to this program. For instance, +# if `export` is "2x" and the eventlog flush interval is 30 seconds, then +# the processor exports a batch of telemetery data every minute. +# +# - A boolean flag, i.e., `true` or `false`. If `export` is `false`, then the +# processor will not export data and, if its output is not needed by some +# other processor, it will not run either. If `export` is `true`, then the +# processor exports telemetry data as if configured with "1x" (see above). +# +# The example `blocks_size` processor exports a batch of telemetry data every +# 60 seconds. +# +# - The `aggregate` property determines whether or not the telemetry data is +# aggregated over time, and, if so, over what interval. Only metrics support +# aggregation. +# +# The aggregation interval uses the same format as the export interval (see +# above). For instance, if `aggregate` is 5s, the processor aggregates data +# over 5 second intervals. +# +# Aggregation follows the OpenTelemetry specification. Sums are aggregated by +# summation. Gauges are aggregated by taking the most recent data point. +# The `heap_allocated` and `capability_usage` metrics are aggregated as sums. +# All other metrics are aggregated as gauges. +# +# The data produced by our example `blocks_size` processor aggregates data +# over 1 second intervals and only keeps the last metric in each interval. +# +# If the key for any specific processor is present in the file, even if it sets +# none of the properties, the processor is _enabled_, and any missing keys will +# default to the values in this file. Otherwise, the processor is _disabled_. +processors: + logs: + thread_label: + name: ghc_eventlog_ThreadLabel + description: A thread label. + export: 30s + user_marker: + name: ghc_eventlog_UserMarker + description: A user marker. + export: 30s + user_message: + name: ghc_eventlog_UserMessage + description: A user log message. + export: 30s + internal_log_message: + name: eventlog_live_InternalLogMessage + description: An internal eventlog-live log message. + export: 30s + metrics: + blocks_size: + name: ghc_eventlog_BlocksSize + description: The current heap size, calculated by the allocated number of blocks. + aggregate: 1s + export: 30s + capability_usage: + name: ghc_eventlog_CapabilityUsageDuration + description: The duration of each capability usage span. + aggregate: 1s + export: false # The current format of this metric breaks various OTLP receivers + heap_allocated: + name: ghc_eventlog_HeapAllocated + description: The size of a newly allocated chunk of heap. + aggregate: 1s + export: false # The current format of this metric breaks various OTLP receivers + heap_live: + name: ghc_eventlog_HeapLive + description: The current heap size, calculated by the allocated number of megablocks. + aggregate: 1s + export: 30s + heap_prof_sample: + name: ghc_eventlog_HeapProfSample + description: A heap profile sample. + aggregate: 1s + export: 30s + heap_size: + name: ghc_eventlog_HeapSize + description: The current heap size, calculated by the allocated number of megablocks. + aggregate: 1s + export: 30s + mem_current: + name: ghc_eventlog_MemCurrent + description: The number of megablocks currently allocated. + aggregate: 1s + export: 30s + mem_needed: + name: ghc_eventlog_MemNeeded + description: The number of megablocks currently needed. + aggregate: 1s + export: 30s + mem_returned: + name: ghc_eventlog_MemReturned + description: The number of megablocks currently being returned to the OS. + aggregate: 1s + export: 30s + traces: + capability_usage: + name: ghc_eventlog_CapabilityUsage + description: A trace of capability usage (either mutator thread or garbage collection). + export: false # These spans easily overwhelm most OTLP receivers + thread_state: + name: ghc_eventlog_ThreadState + description: A trace of thread state changes (either running or stopped). + export: false # These spans easily overwhelm most OTLP receivers + profiles: + call_stack_profile: + name: ghc_eventlog_CallStackProfile + description: A GHC call-stack profile. + export: 30s + cost_centre_stack_profile: + name: ghc_eventlog_CostCentreStackProfile + description: A GHC cost-centre stack profile. + export: 30s diff --git a/eventlog-live.cabal b/eventlog-live.cabal --- a/eventlog-live.cabal +++ b/eventlog-live.cabal @@ -1,72 +1,110 @@ -cabal-version: 3.0 -name: eventlog-live -version: 0.4.0.0 -synopsis: Live processing of eventlog data. -description: - This package supports live processing of eventlog data. - It consists of three libraries: - - * The @eventlog-live@ library defines - [machines](https://hackage.haskell.org/package/machines) - for processing eventlog data. - * The @eventlog-live:options@ sub-library defines - [optparse-applicative](https://hackage.haskell.org/package/optparse-applicative) - parsers for common command-line arguments. - * The @eventlog-live:socket@ sub-library defines functions to read the - eventlog from a Unix socket, which depend on the - [network](https://hackage.haskell.org/package/network) package. - - This package is primarily intended for use via the - [eventlog-live-influxdb](https://hackage.haskell.org/package/eventlog-live-influxdb) - and - [eventlog-live-otelcol](https://hackage.haskell.org/package/eventlog-live-otelcol) - packages. - - [⚠️ Warning]: - This package is experimental. - It is versioned according to the [PVP](https://pvp.haskell.org). - However, breaking changes should be expected and no effort will be - made to avoid major version bumps until at least version @1.0.0.0@. +cabal-version: 3.0 +name: eventlog-live +version: 0.8.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 +license-file: LICENSE +author: Wen Kokke +maintainer: wen@well-typed.com +copyright: (c) 2021-2026 Well-Typed +build-type: Simple +category: Debug, Monitoring, System +extra-doc-files: + CHANGELOG.md + README.md - For more information, see [the README](https://github.com/well-typed/eventlog-live#readme). +extra-source-files: + data/config.schema.json + data/default.yaml -license: BSD-3-Clause -license-file: LICENSE -author: Wen Kokke -maintainer: wen@well-typed.com -copyright: (c) 2021-2025 Well-Typed -build-type: Simple -category: Debug, Monitoring, System -extra-doc-files: CHANGELOG.md tested-with: - GHC ==9.2.8 - || ==9.4.8 - || ==9.6.7 - || ==9.8.4 - || ==9.10.2 - || ==9.12.2 + ghc ==9.2.8 || ==9.4.8 || ==9.6.7 || ==9.8.4 || ==9.10.3 || ==9.12.4 source-repository head - type: git + type: git location: https://github.com/well-typed/eventlog-live.git - subdir: eventlog-live + subdir: eventlog-live +source-repository this + type: git + location: https://github.com/well-typed/eventlog-live.git + tag: eventlog-live-v0.8.0.0 + subdir: eventlog-live + +-- This flag enables the control command server, which is an HTTP endpoint +-- that gets started by eventlog-live-otlp. If +control is set, then +-- eventlog-socket SHOULD also be compiled with +control. If this flag is +-- set at compile-time, the control server can be enabled at runtime. +flag control + description: Enable control command server. + default: False + manual: True + +-- 2025-12-09: +-- This flag should enable switching between concurrent-machines and the +-- vendored copy of the packages, as it currently does not easily build. +flag use-concurrent-machines + description: Use concurrent-machines in place of the vendored copy + default: False + manual: True + +-- 2026-07-29: +-- This flag should enable switching between hs-opentelemetry-api and the +-- vendored copy of the packages, as only a small subset is needed. +flag use-hs-opentelemetry-api + description: Use hs-opentelemetry-api in place of the vendored copy + default: False + manual: True + +-- 2026-04-02: +-- This flag should enable switching the use of eventlog-socket on +-- and off, since it may cause issues with certain versions of GHC. +flag use-eventlog-socket + description: Use eventlog-socket + default: False + manual: True + +-- 2025-11-10: +-- This flag should enable switching the use of ghc-debug-stub on +-- and off, since it may cause issues with certain versions of GHC. +-- See https://github.com/well-typed/eventlog-live/issues/88 +flag use-ghc-debug-stub + description: Use ghc-debug-stub + default: False + manual: True + +-- 2025-11-06: +-- This flag should enable switching between template-haskell and +-- template-haskell-lift, because the latter is not on nixpkgs. +flag use-template-haskell-lift + description: Use template-haskell-lift in place of template-haskell + default: False + manual: False + common language ghc-options: - -Wall -Wcompat -Widentities -Wprepositive-qualified-module - -Wredundant-constraints -Wunticked-promoted-constructors + -Wall + -Wcompat + -Widentities + -Wprepositive-qualified-module + -Wredundant-constraints + -Wunticked-promoted-constructors -Wunused-packages - default-language: Haskell2010 + default-language: Haskell2010 default-extensions: BangPatterns ConstraintKinds DataKinds + DefaultSignatures DeriveFoldable DeriveFunctor DeriveGeneric + DeriveLift DeriveTraversable DerivingStrategies + DerivingVia DuplicateRecordFields FlexibleContexts FlexibleInstances @@ -82,25 +120,38 @@ NoFieldSelectors NumericUnderscores OverloadedRecordDot + PatternSynonyms RankNTypes RecordWildCards ScopedTypeVariables StandaloneDeriving + StandaloneKindSignatures TupleSections TypeApplications TypeFamilies + TypeOperators + ViewPatterns library - import: language - hs-source-dirs: src + import: language + hs-source-dirs: + src-lib + exposed-modules: GHC.Eventlog.Live.Data.Attribute + GHC.Eventlog.Live.Data.Capability GHC.Eventlog.Live.Data.Group + GHC.Eventlog.Live.Data.HeapProfBreakdown + GHC.Eventlog.Live.Data.LogRecord GHC.Eventlog.Live.Data.Metric + GHC.Eventlog.Live.Data.Severity GHC.Eventlog.Live.Data.Span + GHC.Eventlog.Live.Data.Thread GHC.Eventlog.Live.Logger GHC.Eventlog.Live.Machine.Analysis.Capability GHC.Eventlog.Live.Machine.Analysis.Heap + GHC.Eventlog.Live.Machine.Analysis.Log + GHC.Eventlog.Live.Machine.Analysis.Profile GHC.Eventlog.Live.Machine.Analysis.Thread GHC.Eventlog.Live.Machine.Core GHC.Eventlog.Live.Machine.Decoder @@ -108,19 +159,190 @@ GHC.Eventlog.Live.Machine.Source GHC.Eventlog.Live.Machine.WithStartTime GHC.Eventlog.Live.Options - GHC.Eventlog.Live.Socket - GHC.Eventlog.Live.Verbosity + GHC.Eventlog.Live.Source + GHC.Eventlog.Live.Source.Core build-depends: - , ansi-terminal >=1.1 && <1.2 - , base >=4.16 && <4.22 - , bytestring >=0.11 && <0.13 - , dlist >=1.0 && <1.1 - , ghc-events >=0.20 && <0.21 - , hashable >=1.4 && <1.6 - , machines >=0.7.4 && <0.8 - , network >=3.2.7 && <3.3 - , optparse-applicative >=0.17 && <0.20 - , text >=1.2 && <2.2 - , unliftio-core >=0.2.1 && <0.3 - , unordered-containers >=0.2.20 && <0.3 + ansi-terminal >=1.1 && <1.2, + base >=4.16 && <5, + bytestring >=0.11 && <0.13, + clock >=0.8 && <0.9, + co-log-core >=0.3 && <0.4, + containers >=0.6 && <0.9, + dlist >=1.0 && <1.1, + ghc-events >=0.20 && <0.21, + ghc-stack-profiler-core >=0.3 && <0.4, + hashable >=1.4 && <1.6, + ipedb >=0.2 && <0.3, + machines >=0.7.4 && <0.8, + monad-control >=1.0 && <1.1, + network >=3.2.7 && <3.3, + optparse-applicative >=0.17 && <0.20, + stm >=2.5 && <2.6, + text >=1.2 && <2.2, + transformers >=0.2 && <0.7, + unordered-containers >=0.2.20 && <0.3, + vector >=0.12.2 && <0.14, + + -- 2026-07-17: + -- This includes a vendored copy of mapAccumM from the base-compat + -- package version 0.15.0. + hs-source-dirs: + vendor/base-compat-0.15.0 + + other-modules: + Data.Traversable.Compat + + -- 2025-12-09: + -- This configures the build requirements for the vendored copy of + -- the concurrent-machines package version 0.3.1.5. + if flag(use-concurrent-machines) + build-depends: concurrent-machines >=0.1 && <0.4 + else + ghc-options: -Wno-prepositive-qualified-module + hs-source-dirs: vendor/concurrent-machines-0.3.1.5/src + other-modules: + Data.Machine.Concurrent + Data.Machine.Concurrent.AsyncStep + Data.Machine.Concurrent.Buffer + Data.Machine.Concurrent.Fanout + Data.Machine.Concurrent.Scatter + Data.Machine.Concurrent.Tee + Data.Machine.Concurrent.Wye + Data.Machine.Regulated + + build-depends: + async >=2.0.1 && <2.3, + containers >=0.5 && <0.8, + lifted-async >=0.10 && <0.12, + time >=1.4 && <1.16, + transformers-base >=0.4 && <0.5, + +executable eventlog-live-otlp + import: language + main-is: eventlog-live-otlp.hs + hs-source-dirs: + app + + ghc-options: + -threaded + -rtsopts + -finfo-table-map + + hs-source-dirs: + src-app + + other-modules: + GHC.Eventlog.Live.Otlp + GHC.Eventlog.Live.Otlp.Config + GHC.Eventlog.Live.Otlp.Config.Default + GHC.Eventlog.Live.Otlp.Config.Default.Raw + GHC.Eventlog.Live.Otlp.Config.Types + GHC.Eventlog.Live.Otlp.Control + GHC.Eventlog.Live.Otlp.Environment + GHC.Eventlog.Live.Otlp.Exporter.Core + GHC.Eventlog.Live.Otlp.Exporter.Logs + GHC.Eventlog.Live.Otlp.Exporter.Metrics + GHC.Eventlog.Live.Otlp.Exporter.Profiles + GHC.Eventlog.Live.Otlp.Exporter.Traces + GHC.Eventlog.Live.Otlp.Options + GHC.Eventlog.Live.Otlp.Processor.Common.Core + GHC.Eventlog.Live.Otlp.Processor.Common.Logs + GHC.Eventlog.Live.Otlp.Processor.Common.Metrics + GHC.Eventlog.Live.Otlp.Processor.Common.ProfilesDictionary + GHC.Eventlog.Live.Otlp.Processor.Common.SymbolTable + GHC.Eventlog.Live.Otlp.Processor.Common.Traces + GHC.Eventlog.Live.Otlp.Processor.Heap + GHC.Eventlog.Live.Otlp.Processor.Logs + GHC.Eventlog.Live.Otlp.Processor.Profiles + GHC.Eventlog.Live.Otlp.Processor.Threads + GHC.Eventlog.Live.Otlp.Stats + + hs-source-dirs: + src-app-internal + + other-modules: + GHC.Debug.Stub.Compat + GHC.Eventlog.Socket.Compat + Language.Haskell.TH.Lift.Compat + Options.Applicative.Compat + Options.Applicative.Extra.Feature + Paths_eventlog_live + System.Random.Compat + + autogen-modules: Paths_eventlog_live + build-depends: + ansi-terminal >=1.1 && <1.2, + base >=4.16 && <5, + bytestring >=0.11 && <0.13, + case-insensitive >=1.2 && <1.3, + containers >=0.6 && <0.8, + data-default >=0.2 && <0.9, + dlist >=1.0 && <1.1, + eventlog-live, + file-embed >=0.0.16 && <0.1, + ghc-events >=0.20 && <0.21, + grapesy >=1.0.0 && <1.2, + hashable >=1.4 && <1.6, + 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-types >=0.12 && <0.13, + ipedb >=0.2.0.1 && <0.3, + lens-family >=2.1.3 && <2.2, + machines >=0.7.4 && <0.8, + network-uri >=2.6 && <2.8, + optparse-applicative >=0.17 && <0.20, + proto-lens >=0.7.1 && <0.8, + random >=1.2 && <1.4, + stm >=2.5 && <2.6, + strict-list >=0.1 && <0.2, + table-layout >=1.0 && <1.1, + text >=1.2 && <2.2, + transformers >=0.2 && <0.7, + unordered-containers >=0.2.20 && <0.3, + vector >=0.11 && <0.14, + + if flag(control) + build-depends: + aeson >=2.2 && <2.3, + binary >=0.8 && <0.9, + eventlog-socket-control >=0.1.1 && <0.2, + fast-logger >=3.0 && <3.3, + http-api-data >=0.6 && <0.7, + network >=3.2.7 && <3.3, + servant >=0.20 && <0.21, + servant-server >=0.20 && <0.21, + wai >=3.2 && <3.3, + wai-cors >=0.2 && <0.3, + wai-extra >=3.1 && <3.2, + warp >=3.4 && <3.5, + + cpp-options: -DEVENTLOG_LIVE_OTELCOL_FEATURE_CONTROL + + if flag(use-eventlog-socket) + build-depends: eventlog-socket >=0.1.2 && <0.2 + cpp-options: -DEVENTLOG_LIVE_OTELCOL_USE_EVENTLOG_SOCKET + + if flag(use-ghc-debug-stub) + build-depends: ghc-debug-stub >=0.1 && <1 + cpp-options: -DEVENTLOG_LIVE_OTELCOL_USE_GHC_DEBUG_STUB + + -- 2026-07-29: + -- This configures the build requirements for the vendored copy of + -- the hs-opentelemetry-api package version 1.0.0.0. + if flag(use-hs-opentelemetry-api) + build-depends: hs-opentelemetry-api >=1.0.0.0 && <1.1 + else + hs-source-dirs: vendor/hs-opentelemetry-api-1.0.0.0/src + other-modules: OpenTelemetry.Baggage + + -- 2025-11-06: + -- This configures the build requirements for using either template-haskell + -- or template-haskell-lift. + if flag(use-template-haskell-lift) + build-depends: template-haskell-lift >=0.1 && <0.2 + cpp-options: -DEVENTLOG_LIVE_OTELCOL_USE_TEMPLATE_HASKELL_LIFT + else + build-depends: template-haskell >=2.2 && <3 diff --git a/src-app-internal/GHC/Debug/Stub/Compat.hs b/src-app-internal/GHC/Debug/Stub/Compat.hs new file mode 100644 --- /dev/null +++ b/src-app-internal/GHC/Debug/Stub/Compat.hs @@ -0,0 +1,121 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE OverloadedStrings #-} + +{- | +Module : GHC.Debug.Stub.Compat +Description : The implementation of @eventlog-live-otlp@. +Stability : experimental +Portability : portable +-} +module GHC.Debug.Stub.Compat ( + MyGhcDebugSocket (..), + withMyGhcDebug, + maybeMyGhcDebugSocketParser, +) where + +import Control.Applicative (asum) +import GHC.Eventlog.Live.Logger (Logger) +import Options.Applicative qualified as O +import Options.Applicative.Extra.Feature (Feature (..)) +import Options.Applicative.Extra.Feature qualified as OF + +#ifdef EVENTLOG_LIVE_OTELCOL_USE_GHC_DEBUG_STUB +import Data.Text qualified as T +import GHC.Debug.Stub qualified as GHC.Debug (withGhcDebug, withGhcDebugTCP, withGhcDebugUnix) +import GHC.Eventlog.Live.Data.Severity (Severity (..)) +import GHC.Eventlog.Live.Logger (writeLog) +import System.Exit (exitFailure) +import Text.Read (readEither) +#else +import Data.Maybe (isJust) +import Control.Monad (when) +#endif + +-------------------------------------------------------------------------------- +-- Feature: use-ghc-debug-stub +-------------------------------------------------------------------------------- + +useGhcDebugStub :: Feature +useGhcDebugStub = Feature{flag = "use-ghc-debug-stub", isOn = isOn, info = "Cannot open ghc-debug socket."} + where + isOn :: Bool +#ifdef EVENTLOG_LIVE_OTELCOL_USE_GHC_DEBUG_STUB + isOn = True +#else + isOn = False +#endif + +-------------------------------------------------------------------------------- +-- My GHC Debug +-------------------------------------------------------------------------------- + +data MyGhcDebugSocket + = MyGhcDebugSocketDefault + | MyGhcDebugSocketUnix FilePath + | MyGhcDebugSocketTcp String + deriving (Show) + +{- | +Internal helper. +Start @ghc-debug@ on the given `MyGhcDebugSocket`. +-} +withMyGhcDebug :: Logger IO -> Maybe MyGhcDebugSocket -> IO a -> IO a +#ifdef EVENTLOG_LIVE_OTELCOL_USE_GHC_DEBUG_STUB +withMyGhcDebug logger maybeMyGhcDebugSocket action = + case maybeMyGhcDebugSocket of + Nothing -> action + Just MyGhcDebugSocketDefault -> do + writeLog logger INFO $ + "Start ghc-debug with default socket." + GHC.Debug.withGhcDebug action + Just (MyGhcDebugSocketUnix myGhcDebugSocketUnix) -> do + writeLog logger INFO $ + "Start ghc-debug with Unix domain socket at " <> T.pack myGhcDebugSocketUnix <> "." + GHC.Debug.withGhcDebugUnix myGhcDebugSocketUnix action + Just (MyGhcDebugSocketTcp myGhcDebugSocketTcp) -> do + let (host, port) = break (== ':') myGhcDebugSocketTcp + writeLog logger INFO $ + "Start ghc-debug with TCP/IP socket at " <> T.pack host <> ":" <> T.pack port <> "." + case readEither port of + Left _parseError -> do + writeLog logger FATAL $ + T.pack $ "Could not parse ghc-debug TCP address " <> myGhcDebugSocketTcp <> "." + exitFailure + Right portWord16 -> + GHC.Debug.withGhcDebugTCP host portWord16 action +#else +withMyGhcDebug logger maybeMyGhcDebugSocket action = do + when (isJust maybeMyGhcDebugSocket) $ + OF.exitIfUnsupported useGhcDebugStub logger + action +#endif + +-------------------------------------------------------------------------------- +-- My GHC Debug + +maybeMyGhcDebugSocketParser :: O.Parser (Maybe MyGhcDebugSocket) +maybeMyGhcDebugSocketParser = + asum $ + [ myGhcDebugSocketDefaultParser + , myGhcDebugSocketUnixParser + , myGhcDebugSocketTcpParser + , pure Nothing + ] + +myGhcDebugSocketDefaultParser :: O.Parser (Maybe MyGhcDebugSocket) +myGhcDebugSocketDefaultParser = + OF.onlyFor useGhcDebugStub (O.flag' $ Just MyGhcDebugSocketDefault) mempty $ + O.long "my-ghc-debug-socket" + <> OF.helpFor useGhcDebugStub "Open the default ghc-debug socket for this program." + +myGhcDebugSocketUnixParser :: O.Parser (Maybe MyGhcDebugSocket) +myGhcDebugSocketUnixParser = + OF.onlyFor useGhcDebugStub (O.option (Just . MyGhcDebugSocketUnix <$> O.str)) (O.metavar "FILE") $ + O.long "my-ghc-debug-socket-unix" + <> OF.helpFor useGhcDebugStub "Open a ghc-debug Unix domain socket with the given file path." + +myGhcDebugSocketTcpParser :: O.Parser (Maybe MyGhcDebugSocket) +myGhcDebugSocketTcpParser = + OF.onlyFor useGhcDebugStub (O.option (Just . MyGhcDebugSocketTcp <$> O.str)) (O.metavar "ADDRESS") $ + O.long "my-ghc-debug-socket-tcp" + <> OF.helpFor useGhcDebugStub "Open a ghc-debug TCP/IP socket with the given address as 'host:port'." diff --git a/src-app-internal/GHC/Eventlog/Socket/Compat.hs b/src-app-internal/GHC/Eventlog/Socket/Compat.hs new file mode 100644 --- /dev/null +++ b/src-app-internal/GHC/Eventlog/Socket/Compat.hs @@ -0,0 +1,82 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE OverloadedStrings #-} + +{- | +Module : GHC.Eventlog.Socket.Compat +Description : The implementation of @eventlog-live-otlp@. +Stability : experimental +Portability : portable +-} +module GHC.Eventlog.Socket.Compat ( + MyEventlogSocket (..), + maybeMyEventlogSocketParser, + startMyEventlogSocket, +) where + +import Control.Applicative (asum) +import GHC.Eventlog.Live.Logger (Logger) +import Options.Applicative qualified as O +import Options.Applicative.Extra.Feature (Feature (..)) +import Options.Applicative.Extra.Feature qualified as OF + +#ifdef EVENTLOG_LIVE_OTELCOL_USE_EVENTLOG_SOCKET +import Data.Foldable (for_) +import Data.Text qualified as T +import GHC.Eventlog.Live.Data.Severity (Severity (..)) +import GHC.Eventlog.Live.Logger (writeLog) +import GHC.Eventlog.Socket qualified as Eventlog.Socket +#else +import Control.Monad (when) +import Data.Maybe (isJust) +#endif + +-------------------------------------------------------------------------------- +-- Feature: use-eventlog-socket +-------------------------------------------------------------------------------- + +useEventlogSocket :: Feature +useEventlogSocket = Feature{flag = "use-eventlog-socket", isOn = isOn, info = "Cannot open eventlog socket."} + where + isOn :: Bool +#ifdef EVENTLOG_LIVE_OTELCOL_USE_EVENTLOG_SOCKET + isOn = True +#else + isOn = False +#endif + +-------------------------------------------------------------------------------- +-- My Eventlog Socket +-------------------------------------------------------------------------------- + +newtype MyEventlogSocket + = MyEventlogSocketUnix FilePath + +maybeMyEventlogSocketParser :: O.Parser (Maybe MyEventlogSocket) +maybeMyEventlogSocketParser = + asum $ + [ myEventlogSocketUnixParser + , pure Nothing + ] + +myEventlogSocketUnixParser :: O.Parser (Maybe MyEventlogSocket) +myEventlogSocketUnixParser = + OF.onlyFor useEventlogSocket (O.option (Just . MyEventlogSocketUnix <$> O.str)) (O.metavar "FILE") $ + O.long "my-eventlog-socket-unix" + <> OF.helpFor useEventlogSocket "Open an eventlog socket for this program on the given Unix socket." + +{- | +Set @eventlog-socket@ as the eventlog writer. +-} +startMyEventlogSocket :: Logger IO -> Maybe MyEventlogSocket -> IO () +#ifdef EVENTLOG_LIVE_OTELCOL_USE_EVENTLOG_SOCKET +startMyEventlogSocket logger maybeMyEventlogSocket = + for_ maybeMyEventlogSocket $ \case + MyEventlogSocketUnix myEventlogSocketUnix -> do + writeLog logger INFO $ + "Start eventlog-socket with Unix domain socket at " <> T.pack myEventlogSocketUnix <> "." + Eventlog.Socket.startWait myEventlogSocketUnix +#else +startMyEventlogSocket logger maybeMyEventlogSocket = + when (isJust maybeMyEventlogSocket) $ + OF.exitIfUnsupported useEventlogSocket logger +#endif diff --git a/src-app-internal/Language/Haskell/TH/Lift/Compat.hs b/src-app-internal/Language/Haskell/TH/Lift/Compat.hs new file mode 100644 --- /dev/null +++ b/src-app-internal/Language/Haskell/TH/Lift/Compat.hs @@ -0,0 +1,13 @@ +{-# LANGUAGE CPP #-} + +module Language.Haskell.TH.Lift.Compat ( + Exp, + Lift (..), + Q, +) where + +#if defined(EVENTLOG_LIVE_OTELCOL_USE_TEMPLATE_HASKELL_LIFT) +import Language.Haskell.TH.Lift (Exp, Lift (..), Q) +#else +import Language.Haskell.TH.Syntax (Exp, Lift (..), Q) +#endif diff --git a/src-app-internal/Options/Applicative/Compat.hs b/src-app-internal/Options/Applicative/Compat.hs new file mode 100644 --- /dev/null +++ b/src-app-internal/Options/Applicative/Compat.hs @@ -0,0 +1,34 @@ +{-# LANGUAGE CPP #-} + +module Options.Applicative.Compat ( + parserOptionGroup, + simpleVersioner, +) where + +#if MIN_VERSION_optparse_applicative(0,19,0) +import Options.Applicative (parserOptionGroup) +import Options.Applicative (simpleVersioner) +#else +#if MIN_VERSION_optparse_applicative(0,18,1) +import Options.Applicative (simpleVersioner) +#else +import Options.Applicative (infoOption, long, help, hidden) +#endif +import Options.Applicative (Parser) +#endif + +#if MIN_VERSION_optparse_applicative(0,19,0) +#else +-- Prior to optparse-applicative-0.19.0.0, option groups were not supported, +-- so this definition simply drops the group. +parserOptionGroup :: String -> Parser a -> Parser a +parserOptionGroup _ p = p +#if MIN_VERSION_optparse_applicative(0,18,1) +#else +-- Prior to optparse-applicative-0.18.1.0, simpleVersioner was not defined, +-- so this definition is taken verbatim from optparse-applicative-0.18.1.0. +simpleVersioner :: String -> Parser (a -> a) +simpleVersioner version = infoOption version $ + mconcat [long "version", help "Show version information", hidden] +#endif +#endif diff --git a/src-app-internal/Options/Applicative/Extra/Feature.hs b/src-app-internal/Options/Applicative/Extra/Feature.hs new file mode 100644 --- /dev/null +++ b/src-app-internal/Options/Applicative/Extra/Feature.hs @@ -0,0 +1,62 @@ +{-# LANGUAGE OverloadedStrings #-} + +module Options.Applicative.Extra.Feature ( + Feature (..), + helpFor, + onlyFor, + exitIfUnsupported, +) where + +import Control.Monad (unless) +import Data.Default (Default (..)) +import Data.Text (Text) +import Data.Text qualified as T +import GHC.Eventlog.Live.Data.Severity (Severity (..)) +import GHC.Eventlog.Live.Logger (Logger, writeLog) +import Options.Applicative qualified as O +import Options.Applicative.Help.Pretty qualified as OP +import System.Exit (exitFailure) + +data Feature = Feature + { flag :: !String + , isOn :: !Bool + , info :: !String + } + +{- | +Create a command-line help document for an option that depend on a feature flag. +-} +helpFor :: Feature -> String -> O.Mod f a +helpFor feature help + | feature.isOn = O.help help + | otherwise = O.helpDoc (Just $ OP.vcat [OP.pretty unsupported, OP.pretty help]) <> O.hidden + where + unsupported :: Text + unsupported = T.pack "Unsupported. Requires build with -f+" <> T.pack feature.flag <> "." + +{- | +Create a command-line option that depends on a feature flag. +-} +onlyFor :: + forall f a. + (O.HasName f, Default a) => + Feature -> + (O.Mod f a -> O.Parser a) -> + O.Mod f a -> + (forall g x. (O.HasName g) => O.Mod g x) -> + O.Parser a +onlyFor feature opt optIfSupported optAlways + | feature.isOn = opt (optAlways <> optIfSupported) + | otherwise = def <$ O.infoOption unsupportedInfo optAlways + where + unsupportedInfo :: String + unsupportedInfo = feature.info <> " Requires build with -f+" <> feature.flag <> "." + +{- | +Exit with the feature info. +-} +exitIfUnsupported :: Feature -> Logger IO -> IO () +exitIfUnsupported feature logger = + unless feature.isOn $ do + writeLog logger FATAL (T.pack feature.info) + exitFailure diff --git a/src-app-internal/System/Random/Compat.hs b/src-app-internal/System/Random/Compat.hs new file mode 100644 --- /dev/null +++ b/src-app-internal/System/Random/Compat.hs @@ -0,0 +1,17 @@ +{-# LANGUAGE CPP #-} + +module System.Random.Compat ( + uniformByteString, +) where + +#if MIN_VERSION_random(1,3,0) +import System.Random (uniformByteString) +#else +import Data.Bifunctor (Bifunctor (first)) +import Data.ByteString (ByteString) +import Data.ByteString.Short (fromShort) +import System.Random (RandomGen (genShortByteString)) + +uniformByteString :: RandomGen g => Int -> g -> (ByteString, g) +uniformByteString n g = first fromShort (genShortByteString n g) +#endif diff --git a/src-app/GHC/Eventlog/Live/Otlp.hs b/src-app/GHC/Eventlog/Live/Otlp.hs new file mode 100644 --- /dev/null +++ b/src-app/GHC/Eventlog/Live/Otlp.hs @@ -0,0 +1,438 @@ +{-# LANGUAGE OverloadedStrings #-} + +{- | +Module : GHC.Eventlog.Live.Otlp +Description : The implementation of @eventlog-live-otlp@. +Stability : experimental +Portability : portable +-} +module GHC.Eventlog.Live.Otlp ( + main, +) where + +import Control.Concurrent.STM.TChan (newTChanIO) +import Control.Exception (bracket_) +import Control.Monad.Trans.Except (runExceptT) +import Data.DList (DList) +import Data.DList qualified as D +import Data.Default (Default (..)) +import Data.Foldable qualified as F +import Data.Machine (Process, ProcessT, asParts, mapping, stopped, (~>)) +import Data.Maybe (catMaybes, fromMaybe, isJust, mapMaybe) +import Data.Text (Text) +import Data.Text qualified as T +import Data.Version (showVersion) +import Data.Void (absurd) +import GHC.Debug.Stub.Compat (withMyGhcDebug) +import GHC.Eventlog.Live.Data.Attribute (AttrValue (AttrText), (~=)) +import GHC.Eventlog.Live.Data.LogRecord (LogRecord (..)) +import GHC.Eventlog.Live.Data.Severity (Severity (..)) +import GHC.Eventlog.Live.Logger (Logger, MyTelemetryData, writeLog) +import GHC.Eventlog.Live.Logger qualified as M +import GHC.Eventlog.Live.Machine.Core (Tick) +import GHC.Eventlog.Live.Machine.Core qualified as M +import GHC.Eventlog.Live.Machine.WithStartTime qualified as M +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.Exporter.Core (Exporter, withExporters) +import GHC.Eventlog.Live.Otlp.Exporter.Logs (exportResourceLogs) +import GHC.Eventlog.Live.Otlp.Exporter.Metrics (exportResourceMetrics) +import GHC.Eventlog.Live.Otlp.Exporter.Profiles (exportResourceProfiles) +import GHC.Eventlog.Live.Otlp.Exporter.Traces (exportResourceSpans) +import GHC.Eventlog.Live.Otlp.Options +import GHC.Eventlog.Live.Otlp.Processor.Common.Core +import GHC.Eventlog.Live.Otlp.Processor.Common.Logs (ToLogRecord (..), toExportLogsServiceRequest, toResourceLogs, toScopeLogs) +import GHC.Eventlog.Live.Otlp.Processor.Common.Metrics (toExportMetricsServiceRequest, toResourceMetrics, toScopeMetrics) +import GHC.Eventlog.Live.Otlp.Processor.Common.Traces (toExportTracesServiceRequest, toResourceSpans, toScopeSpans) +import GHC.Eventlog.Live.Otlp.Processor.Heap (processHeapEvents) +import GHC.Eventlog.Live.Otlp.Processor.Logs (processLogEvents) +import GHC.Eventlog.Live.Otlp.Processor.Profiles (Sample, Stack, processProfileEvents, toExportProfileServiceRequest, toProfiles, toProfilesData, toResourceProfiles, toScopeProfiles) +import GHC.Eventlog.Live.Otlp.Processor.Threads (processThreadEvents) +import GHC.Eventlog.Live.Otlp.Stats (Stat (..), eventCountTick, processStats) +import GHC.Eventlog.Live.Source (runWithEventlogSourceHandle, withEventlogSourceHandle) +import GHC.Eventlog.Socket.Compat (startMyEventlogSocket) +import GHC.RTS.Events (Event (..)) +import IpeDB.Database qualified as DB +import IpeDB.Types.CostCentre qualified as CC +import IpeDB.Types.InfoProv qualified as IP +import Lens.Family2 ((.~)) +import Options.Applicative qualified as O +import Paths_eventlog_live qualified as EventlogLive +import Proto.Opentelemetry.Proto.Common.V1.Common qualified as OC +import Proto.Opentelemetry.Proto.Common.V1.Common_Fields qualified as OC +import Proto.Opentelemetry.Proto.Logs.V1.Logs qualified as OL +import Proto.Opentelemetry.Proto.Metrics.V1.Metrics qualified as OM +import Proto.Opentelemetry.Proto.Metrics.V1.Metrics_Fields qualified as OM +import Proto.Opentelemetry.Proto.Profiles.V1development.Profiles qualified as OP +import Proto.Opentelemetry.Proto.Resource.V1.Resource qualified as OR +import Proto.Opentelemetry.Proto.Trace.V1.Trace qualified as OT +import System.Exit (die) + +{- | +The main function for @eventlog-live-otlp@. +-} +main :: IO () +main = do + -- Parse the command-line options + Options{..} <- O.execParser options + + -- Lookup the OpenTelemetry log level + logLevel <- + either die pure =<< runExceptT lookupLogLevel + + -- Construct the logging action + myTelemetryDataChan <- newTChanIO + let logger = M.filterBySeverity logLevel (M.stderrLogger <> M.chanLogger myTelemetryDataChan) + + -- Lookup the OpenTelemetry Exporter Options + exporterOptions <- + either die pure =<< runExceptT (lookupExporterOptions logger) + + -- Lookup the OpenTelemetry Resource Attributes + maybeResourceAttributes <- + either die pure =<< runExceptT (lookupResourceAttributes logger) + + -- Instument THIS PROGRAM with eventlog-socket and/or ghc-debug. + let MyDebugOptions{..} = myDebugOptions + startMyEventlogSocket logger maybeMyEventlogSocket + withMyGhcDebug logger maybeMyGhcDebugSocket $ do + -- + -- Start the control server. + controlServerApi <- startControlServer logger controlOptions + + -- Read the configuration file. + let readConfigFile configFile = do + writeLog logger DEBUG $ + "Reading configuration file from " <> T.pack configFile + config <- C.readConfigFile logger configFile + writeLog logger DEBUG $ + "Configuration file:\n" <> C.prettyConfig config + pure config + + -- Read the configuration file and add derived settings. + fullConfig <- + C.toFullConfig eventlogFlushIntervalS + <$> maybe (pure def) readConfigFile maybeConfigFile + writeLog logger DEBUG $ + "Batch interval is " <> T.pack (show fullConfig.batchIntervalMs) <> "ms" + writeLog logger DEBUG $ + "Eventlog flush interval is " <> T.pack (show fullConfig.eventlogFlushIntervalX) <> "x" + + -- Determine the window size for statistics + let windowSizeX = + (10 *) . maximum $ + [ fullConfig.eventlogFlushIntervalX + , C.maximumAggregationBatches fullConfig + , C.maximumExportBatches fullConfig + ] + + -- Find the service name, if any: + let !serviceName = + fromMaybe (ServiceName "undefined") $ + (.serviceName) =<< maybeResourceAttributes + + -- Create a resource to represent the monitored process. + let eventlogResource :: OR.Resource + eventlogResource = + let attributes = + mapMaybe (toMaybeKeyValue . uncurry (~=)) $ + maybe [] (.attributes) maybeResourceAttributes + in messageWith [OM.attributes .~ attributes] + + -- Create machine that indexes CostCentre data. + let indexCostCentreEvents :: + DB.Table CC.CostCentreId CC.CostCentre -> + ProcessT IO (Tick (M.WithStartTime Event)) (Tick x) + indexCostCentreEvents ccdb + -- If a cost-centre database was provided, don't index any new entries. + | isJust maybeCCDBPath = stopped + | otherwise = M.liftTick (DB.indexer (CC.toCostCentre . (.value)) def ccdb ~> mapping absurd) + + -- Create machine that indexes InfoProv data. + let indexInfoProvEvents :: + DB.Table IP.InfoProvId IP.InfoProv -> + ProcessT IO (Tick (M.WithStartTime Event)) (Tick x) + indexInfoProvEvents ipedb + -- If an IPE database was provided, don't index any new entries. + | isJust maybeIpeDBPath = stopped + | otherwise = M.liftTick (DB.indexer (IP.toInfoProv . (.value)) def ipedb ~> mapping absurd) + + -- Create machine that processes eventlog data into telemetry data + let processEventlogTelemetry :: + DB.Table CC.CostCentreId CC.CostCentre -> + DB.Table IP.InfoProvId IP.InfoProv -> + ProcessT IO (Tick Event) (Tick ResourceTelemetryData) + processEventlogTelemetry ccdb ipedb = + M.liftTick M.withStartTime + ~> M.fanoutTick + [ -- Process CostCentre events. + indexCostCentreEvents ccdb + , -- Process InfoProv events. + indexInfoProvEvents ipedb + , -- Process the heap events. + processHeapEvents logger (Just ipedb) maybeHeapProfBreakdown fullConfig + ~> mapping (fmap (fmap TelemetryData'Metric)) + , -- Process the log events. + processLogEvents fullConfig + ~> mapping (fmap (fmap TelemetryData'Log)) + , -- Process the thread events. + processThreadEvents logger fullConfig + ~> mapping (fmap (fmap (either TelemetryData'Metric TelemetryData'Span))) + , -- Process the profile events. + processProfileEvents logger ccdb ipedb fullConfig + ~> mapping (fmap (fmap TelemetryData'Sample)) + ] + ~> M.liftTick (asResourceTelemetryData eventlogResource eventlogLiveScope) + + -- Create a resource to represent the eventlog-live process. + let internalResource :: OR.Resource + internalResource = + messageWith + [ OM.attributes + .~ mapMaybe + toMaybeKeyValue + [ "service.name" ~= AttrText (eventlogLiveName <> "-for-" <> serviceName.serviceName) + , "service.version" ~= eventlogLiveVersion + ] + ] + + -- Create the machine that processes internal telemetry data + -- + -- NOTE: This process only takes a stream of inputs to use their tick. + let processInternalTelemetry :: ProcessT IO (Tick x) (Tick ResourceTelemetryData) + processInternalTelemetry = + M.mergeWithTickCC (M.chanSource myTelemetryDataChan) + ~> processInternalTelemetryData fullConfig + ~> M.liftTick (asResourceTelemetryData internalResource eventlogLiveScope) + + -- Create the full machine to process eventlog data. + let processAndExportTelemetry ccdb ipedb exporters = + M.fanoutTick + [ -- Log a warning if no input has been received after 10 ticks. + M.validateInput logger 10 + , -- Count the number of input events between each tick. + eventCountTick + ~> mapping (fmap (D.singleton . EventCountStat)) + , -- Process eventlog and internal telemetry... + M.fanoutTickCC + [ processEventlogTelemetry ccdb ipedb ~> mapping (fmap D.singleton) + , processInternalTelemetry ~> mapping (fmap D.singleton) + ] + ~> M.liftTick asParts + -- ...and export it. + ~> exportResourceTelemetryData logger fullConfig exporters + ] + -- Process the statistics + -- TODO: windowSize should be the maximum of all aggregation and export intervals + ~> M.liftTick (asParts ~> processStats logger stats eventlogFlushIntervalS windowSizeX) + -- Validate the consistency of the tick + ~> M.validateTicks logger + ~> M.dropTick + + -- Open a connection to the OpenTelemetry Collector. + withExporters logger exporterOptions $ \exporters -> do + DB.withNewSession def $ \session -> do + let withCostCentreTable = + case maybeCCDBPath of + Nothing -> DB.withNewTable session def + Just ccDBPath -> DB.withTableFrom session ccDBPath def + let withInfoProvTable = + case maybeIpeDBPath of + Nothing -> DB.withNewTable session def + Just ipeDBPath -> DB.withTableFrom session ipeDBPath def + withCostCentreTable $ \ccdb -> + withInfoProvTable $ \ipedb -> + withEventlogSourceHandle + logger + eventlogSocketTimeoutS + eventlogSocketTimeoutExponent + eventlogSourceOptions + $ \eventlogSourceHandle -> do + -- Notify the control server of the connection status. + let newConnection = controlServerApi.notifyNewConnection serviceName eventlogSourceHandle + let endConnection = controlServerApi.notifyEndConnection serviceName + bracket_ newConnection endConnection $ + -- Run the eventlog processor. + runWithEventlogSourceHandle + logger + eventlogSourceHandle + fullConfig.batchIntervalMs + Nothing + maybeEventlogLogFile + (processAndExportTelemetry ccdb ipedb exporters) + +data TelemetryData + = TelemetryData'Log OL.LogRecord + | TelemetryData'Metric OM.Metric + | TelemetryData'Span OT.Span + | TelemetryData'Sample (Sample Stack) + +data ResourceTelemetryData + = ResourceTelemetryData'Log OL.ResourceLogs + | ResourceTelemetryData'Metric OM.ResourceMetrics + | ResourceTelemetryData'Span OT.ResourceSpans + | ResourceTelemetryData'Profile OP.ProfilesData + +{- | +Internal helper. +Export resource telemetry data and yield statistics. +-} +exportResourceTelemetryData :: + Logger IO -> + FullConfig -> + PerSignal (Maybe Exporter) -> + ProcessT IO (Tick ResourceTelemetryData) (Tick (DList Stat)) +exportResourceTelemetryData logger fullConfig exporters = + M.fanoutTick + [ -- Export logs. + runIf (C.shouldExportLogs fullConfig) $ + runWith (exporters `forSignal` LOGS) $ \logsExporter -> + M.liftTick (mapping getResourceLogs ~> asParts ~> mapping D.singleton) + -- NOTE: This is required to combine different resource telemetry + -- streams. However, it has the "unfortunate" side-effect of + -- making it impossible to not batch once per interval. + ~> M.batchByTick + ~> M.liftTick (mapping (toExportLogsServiceRequest . D.toList)) + ~> exportResourceLogs logger logsExporter + ~> M.liftTick (mapping (D.singleton . ExportLogsResultStat)) + , -- Export metrics. + runIf (C.shouldExportMetrics fullConfig) $ + runWith (exporters `forSignal` METRICS) $ \metricsExporter -> + M.liftTick (mapping getResourceMetrics ~> asParts ~> mapping D.singleton) + -- NOTE: See note above. + ~> M.batchByTick + ~> M.liftTick (mapping (toExportMetricsServiceRequest . D.toList)) + ~> exportResourceMetrics logger metricsExporter + ~> M.liftTick (mapping (D.singleton . ExportMetricsResultStat)) + , -- Export spans. + runIf (C.shouldExportTraces fullConfig) $ + runWith (exporters `forSignal` TRACES) $ \tracesExporter -> + M.liftTick (mapping getResourceSpans ~> asParts ~> mapping D.singleton) + -- NOTE: See note above. + ~> M.batchByTick + ~> M.liftTick (mapping (toExportTracesServiceRequest . D.toList)) + ~> exportResourceSpans logger tracesExporter + ~> M.liftTick (mapping (D.singleton . ExportTraceResultStat)) + , -- Export profiles. + runIf (C.shouldExportProfiles fullConfig) $ + runWith (exporters `forSignal` PROFILES) $ \profilesExporter -> + M.liftTick (mapping getResourceProfiles ~> asParts ~> mapping toExportProfileServiceRequest) + ~> exportResourceProfiles logger profilesExporter + ~> M.liftTick (mapping (D.singleton . ExportProfileResultStat)) + ] + +getResourceLogs :: ResourceTelemetryData -> Maybe OL.ResourceLogs +getResourceLogs = \case + (ResourceTelemetryData'Log resourceLogs) -> Just resourceLogs + _otherwise -> Nothing + +getResourceMetrics :: ResourceTelemetryData -> Maybe OM.ResourceMetrics +getResourceMetrics = \case + (ResourceTelemetryData'Metric resourceMetrics) -> Just resourceMetrics + _otherwise -> Nothing + +getResourceSpans :: ResourceTelemetryData -> Maybe OT.ResourceSpans +getResourceSpans = \case + (ResourceTelemetryData'Span resourceSpans) -> Just resourceSpans + _otherwise -> Nothing + +getResourceProfiles :: ResourceTelemetryData -> Maybe OP.ProfilesData +getResourceProfiles = \case + (ResourceTelemetryData'Profile profilesData) -> Just profilesData + _otherwise -> Nothing + +{- | +Internal helper. + +Repack a stream of `TelemetryData` to batched `ResourceTelemetryData`. +-} +asResourceTelemetryData :: + (Foldable f) => + OR.Resource -> + OC.InstrumentationScope -> + Process (f TelemetryData) ResourceTelemetryData +asResourceTelemetryData resource instrumentationScope = + mapping (toResourceTelemetryData . F.toList) ~> asParts + where + toResourceTelemetryData :: + [TelemetryData] -> + [ResourceTelemetryData] + toResourceTelemetryData telemetryData = + catMaybes [maybeResourceLogs, maybeResourceMetrics, maybeResourceSpans, maybeProfiles] + where + (logRecords, metrics, spans, samples) = partitionTelemetryData telemetryData + + maybeResourceLogs = do + scopeLogs <- toScopeLogs instrumentationScope logRecords + resourceLogs <- toResourceLogs resource [scopeLogs] + pure $ ResourceTelemetryData'Log resourceLogs + maybeResourceMetrics = do + scopeMetrics <- toScopeMetrics instrumentationScope metrics + resourceMetrics <- toResourceMetrics resource [scopeMetrics] + pure $ ResourceTelemetryData'Metric resourceMetrics + maybeResourceSpans = do + scopeSpans <- toScopeSpans instrumentationScope spans + resourceSpans <- toResourceSpans resource [scopeSpans] + pure $ ResourceTelemetryData'Span resourceSpans + maybeProfiles = do + (profiles, dictionary) <- toProfiles samples + scopeProfiles <- toScopeProfiles instrumentationScope profiles + resourceProfiles <- toResourceProfiles resource [scopeProfiles] + profilesData <- toProfilesData [resourceProfiles] dictionary + pure $ ResourceTelemetryData'Profile profilesData + +{- | +Partition a stream of `TelemetryData` batches to individual batches for each kind of telemetry data. +-} +partitionTelemetryData :: [TelemetryData] -> ([OL.LogRecord], [OM.Metric], [OT.Span], [Sample Stack]) +partitionTelemetryData = go ([], [], [], []) + where + go :: ([OL.LogRecord], [OM.Metric], [OT.Span], [Sample Stack]) -> [TelemetryData] -> ([OL.LogRecord], [OM.Metric], [OT.Span], [Sample Stack]) + go (logsRev, metricsRev, spansRev, samplesRev) = \case + [] -> (reverse logsRev, reverse metricsRev, reverse spansRev, reverse samplesRev) + (TelemetryData'Log log_ : rest) -> go (log_ : logsRev, metricsRev, spansRev, samplesRev) rest + (TelemetryData'Metric metric : rest) -> go (logsRev, metric : metricsRev, spansRev, samplesRev) rest + (TelemetryData'Span span_ : rest) -> go (logsRev, metricsRev, span_ : spansRev, samplesRev) rest + (TelemetryData'Sample sample : rest) -> go (logsRev, metricsRev, spansRev, sample : samplesRev) rest + +{- | +Internal helper. +Process internal telemetry data. +-} +processInternalTelemetryData :: + FullConfig -> + Process (Tick MyTelemetryData) (Tick (DList TelemetryData)) +processInternalTelemetryData fullConfig = + M.fanoutTick + [ -- Process internal log messages. + M.liftTick (mapping getMyLogRecord ~> asParts ~> mapping (D.singleton . TelemetryData'Log . toLogRecord)) + ~> M.batchByTicks (C.processorExportBatches (.logs) (.internalLogMessage) fullConfig) + -- TODO: Any internal metrics should be processed below. + ] + +getMyLogRecord :: MyTelemetryData -> Maybe LogRecord +getMyLogRecord = \case + M.MyTelemetryData'LogRecord{..} -> Just logRecord + M.MyTelemetryData'Metric{} -> Nothing + +-------------------------------------------------------------------------------- +-- Instrumentation Scope +-------------------------------------------------------------------------------- + +-- 2025-09-22: +-- Once `cabal2nix` supports Cabal 3.12, this can once again use the value from: +-- `PackageInfo_eventlog_live.name`. +eventlogLiveName :: Text +eventlogLiveName = "eventlog-live-otlp" + +eventlogLiveVersion :: Text +eventlogLiveVersion = T.pack (showVersion EventlogLive.version) + +eventlogLiveScope :: OC.InstrumentationScope +eventlogLiveScope = + messageWith + [ OC.name .~ eventlogLiveName + , OC.version .~ eventlogLiveVersion + ] diff --git a/src-app/GHC/Eventlog/Live/Otlp/Config.hs b/src-app/GHC/Eventlog/Live/Otlp/Config.hs new file mode 100644 --- /dev/null +++ b/src-app/GHC/Eventlog/Live/Otlp/Config.hs @@ -0,0 +1,672 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE TemplateHaskell #-} +{-# OPTIONS_GHC -Wno-orphans #-} + +{- | +Module : GHC.Eventlog.Live.Otlp.Config +Description : The implementation of @eventlog-live-otlp@. +Stability : experimental +Portability : portable +-} +module GHC.Eventlog.Live.Otlp.Config ( + -- * Configuration type + Config (..), + readConfigFile, + prettyConfig, + FullConfig (..), + toFullConfig, + + -- ** Processor configuration types + Processors (..), + IsProcessorConfig, + processorEnabled, + processorDescription, + processorName, + + -- *** Log processor configuration types + Logs (..), + IsLogProcessorConfig, + shouldExportLogs, + ThreadLabel (..), + UserMarker (..), + UserMessage (..), + InternalLogMessage (..), + + -- *** Metric processor configuration types + Metrics (..), + IsMetricProcessorConfig, + shouldExportMetrics, + HeapAllocatedMetric (..), + BlocksSizeMetric (..), + HeapSizeMetric (..), + HeapLiveMetric (..), + MemCurrentMetric (..), + MemNeededMetric (..), + MemReturnedMetric (..), + HeapProfSampleMetric (..), + CapabilityUsageMetric (..), + + -- *** Trace processor configuration types + Traces (..), + IsTraceProcessorConfig, + shouldExportTraces, + CapabilityUsageSpan (..), + ThreadStateSpan (..), + + -- *** Profiler processor configuration types + Profiles (..), + IsProfileProcessorConfig, + shouldExportProfiles, + CallStackProfile (..), + CostCentreStackProfile (..), + + -- ** Property types + + -- *** Aggregation strategy + AggregationStrategy (..), + toAggregationBatches, + processorAggregationStrategy, + processorAggregationBatches, + maximumAggregationBatches, + + -- *** Export strategy + ExportStrategy (..), + toExportBatches, + processorExportStrategy, + processorExportBatches, + maximumExportBatches, + + -- *** Batch interval + toBatchIntervalMs, + toBatches, +) where + +import Control.Exception (assert) +import Control.Monad ((<=<)) +import Control.Monad.IO.Class (MonadIO (..)) +import Data.ByteString.Lazy qualified as BSL +import Data.Default (Default (..)) +import Data.List.NonEmpty (NonEmpty (..)) +import Data.Maybe (catMaybes, fromMaybe, mapMaybe) +import Data.Monoid (Any (..)) +import Data.Semigroup (Semigroup (..)) +import Data.Text (Text) +import Data.Text qualified as T +import Data.Text.Encoding qualified as TE +import Data.YAML qualified as YAML +import GHC.Eventlog.Live.Data.Severity (Severity (..)) +import GHC.Eventlog.Live.Logger (Logger, writeLog) +import GHC.Eventlog.Live.Otlp.Config.Default (defaultConfig, getDefault) +import GHC.Eventlog.Live.Otlp.Config.Types +import GHC.Records (HasField) +import GHC.Stack.Types (HasCallStack) +import System.Exit (exitFailure) + +{- | +Read a `Config` from a configuration file. +-} +readConfigFile :: + Logger IO -> + FilePath -> + IO Config +readConfigFile logger filePath = + readConfig logger =<< liftIO (BSL.readFile filePath) + +{- | +Read a `Config` from a `BSL.ByteString`. +-} +readConfig :: + Logger IO -> + BSL.ByteString -> + IO Config +readConfig logger fileContents = do + case YAML.decode1 fileContents of + Left (pos, errorMessage) -> do + writeLog logger FATAL $ + T.pack $ + YAML.prettyPosWithSource pos fileContents " error" <> errorMessage + liftIO exitFailure + Right config -> pure config + +{- | +Pretty-print a `Config` to YAML. +-} +prettyConfig :: Config -> Text +prettyConfig = TE.decodeUtf8Lenient . BSL.toStrict . YAML.encode1 + +{- | +Create a full configuration. +-} +toFullConfig :: + -- | The @--eventlog-flush-interval@ in seconds. + Double -> + -- | The user configuration. + Config -> + FullConfig +toFullConfig eventlogFlushIntervalS config = + FullConfig{..} + where + batchIntervalMs = toBatchIntervalMs eventlogFlushIntervalS config + eventlogFlushIntervalX = toBatches batchIntervalMs eventlogFlushIntervalS + +------------------------------------------------------------------------------- +-- Default Instances +------------------------------------------------------------------------------- + +instance Default Config where + def :: Config + def = defaultConfig + +instance Default Processors where + def :: Processors + def = $(getDefault @'["processors"] defaultConfig) + +instance Default Logs where + def :: Logs + def = $(getDefault @'["processors", "logs"] defaultConfig) + +instance Default Metrics where + def :: Metrics + def = $(getDefault @'["processors", "metrics"] defaultConfig) + +instance Default Traces where + def :: Traces + def = $(getDefault @'["processors", "traces"] defaultConfig) + +instance Default Profiles where + def :: Profiles + def = $(getDefault @'["processors", "profiles"] defaultConfig) + +-- NOTE: This should be kept in sync with the list of logs. +-- Specifically, there should be a `Default` instance for every log. + +instance Default ThreadLabel where + def :: ThreadLabel + def = $(getDefault @'["processors", "logs", "threadLabel"] defaultConfig) + +instance Default UserMarker where + def :: UserMarker + def = $(getDefault @'["processors", "logs", "userMarker"] defaultConfig) + +instance Default UserMessage where + def :: UserMessage + def = $(getDefault @'["processors", "logs", "userMessage"] defaultConfig) + +instance Default InternalLogMessage where + def :: InternalLogMessage + def = $(getDefault @'["processors", "logs", "internalLogMessage"] defaultConfig) + +-- NOTE: This should be kept in sync with the list of metrics. +-- Specifically, there should be a `Default` instance for every metric. + +instance Default HeapAllocatedMetric where + def :: HeapAllocatedMetric + def = $(getDefault @'["processors", "metrics", "heapAllocated"] defaultConfig) + +instance Default BlocksSizeMetric where + def :: BlocksSizeMetric + def = $(getDefault @'["processors", "metrics", "blocksSize"] defaultConfig) + +instance Default HeapSizeMetric where + def :: HeapSizeMetric + def = $(getDefault @'["processors", "metrics", "heapSize"] defaultConfig) + +instance Default HeapLiveMetric where + def :: HeapLiveMetric + def = $(getDefault @'["processors", "metrics", "heapLive"] defaultConfig) + +instance Default MemCurrentMetric where + def :: MemCurrentMetric + def = $(getDefault @'["processors", "metrics", "memCurrent"] defaultConfig) + +instance Default MemNeededMetric where + def :: MemNeededMetric + def = $(getDefault @'["processors", "metrics", "memNeeded"] defaultConfig) + +instance Default MemReturnedMetric where + def :: MemReturnedMetric + def = $(getDefault @'["processors", "metrics", "memReturned"] defaultConfig) + +instance Default HeapProfSampleMetric where + def :: HeapProfSampleMetric + def = $(getDefault @'["processors", "metrics", "heapProfSample"] defaultConfig) + +instance Default CapabilityUsageMetric where + def :: CapabilityUsageMetric + def = $(getDefault @'["processors", "metrics", "capabilityUsage"] defaultConfig) + +-- NOTE: This should be kept in sync with the list of traces. +-- Specifically, there should be a `Default` instance for every trace. + +instance Default CapabilityUsageSpan where + def :: CapabilityUsageSpan + def = $(getDefault @'["processors", "traces", "capabilityUsage"] defaultConfig) + +instance Default ThreadStateSpan where + def :: ThreadStateSpan + def = $(getDefault @'["processors", "traces", "threadState"] defaultConfig) + +instance Default CallStackProfile where + def :: CallStackProfile + def = $(getDefault @'["processors", "profiles", "callStackProfile"] defaultConfig) + +instance Default CostCentreStackProfile where + def :: CostCentreStackProfile + def = $(getDefault @'["processors", "profiles", "costCentreStackProfile"] defaultConfig) + +------------------------------------------------------------------------------- +-- Accessors +------------------------------------------------------------------------------- + +{- | +Get the user-specified processor configuration. +-} +userProcessorConfig :: + (Processors -> Maybe processorGroup) -> + (processorGroup -> Maybe processorConfig) -> + FullConfig -> + Maybe processorConfig +userProcessorConfig group processor fullConfig = + processor =<< group =<< fullConfig.config.processors + +{- | +Get whether or not a processor is enabled. +-} +processorEnabled :: + (HasField "export" processorConfig (Maybe ExportStrategy)) => + (Processors -> Maybe processorGroup) -> + (processorGroup -> Maybe processorConfig) -> + FullConfig -> + Bool +processorEnabled group processor = + isEnabled . userProcessorConfig group processor + +{- | +Get the description corresponding to a processor. +-} +processorDescription :: + forall a b. + (Default b, HasField "description" b (Maybe Text)) => + (Processors -> Maybe a) -> + (a -> Maybe b) -> + FullConfig -> + Maybe Text +processorDescription group processor = + (.description) . fromMaybe (def :: b) . userProcessorConfig group processor + +{- | +Get the name corresponding to a processor. +-} +processorName :: + forall a b. + (HasCallStack, Show b, Default b, HasField "name" b (Maybe Text)) => + (Processors -> Maybe a) -> + (a -> Maybe b) -> + FullConfig -> + Text +processorName group processor = + fromMaybe defaultName . ((.name) <=< userProcessorConfig group processor) + where + defaultName = fromMaybe (error errMsg) config.name + where + config = def :: b + errMsg = "The default configuration has no name: " <> show config + +-------------------------------------------------------------------------------- +-- Aggregation Strategy + +{- | +Get the aggregation strategy corresponding to a metric processor. +-} +processorAggregationStrategy :: + (Default b, HasField "aggregate" b (Maybe AggregationStrategy)) => + (Processors -> Maybe a) -> + (a -> Maybe b) -> + FullConfig -> + Maybe AggregationStrategy +processorAggregationStrategy group field = + (.aggregate) . fromMaybe def . userProcessorConfig group field + +{- | +Convert an `AggregationStrategy` to a number of batches. + +__Precondition:__ +If the aggregation strategy is defined in seconds, +then the batch interval should divide this duration. +-} +toAggregationBatches :: + -- | The batch interval in milliseconds. + Int -> + -- | The @--eventlog-flush-interval@ in /batches/. + Int -> + -- | The aggregation strategy. + Maybe AggregationStrategy -> + Int +toAggregationBatches batchIntervalMs eventlogFlushIntervalX = \case + -- If the setting is '60s' this means 60 seconds. + Just (AggregationStrategyDuration DurationBySeconds{..}) -> toMilli seconds `div` batchIntervalMs + -- If the setting is '60x' this means 60 times the /eventlog flush interval/, + -- not the interal batch interval. + Just (AggregationStrategyDuration DurationByBatches{..}) -> batches * eventlogFlushIntervalX + -- If the setting is 'true' this means '1x', i.e., /eventlog flush interval/. + Just AggregationStrategyBool{..} | isOn -> eventlogFlushIntervalX + -- If the setting is absent or 'false' this means /do not aggregate/. + Nothing -> 0 + Just AggregationStrategyBool{..} -> assert (not isOn) 0 + +{- | +Get the aggregation strategy corresponding to a metric processor. +-} +processorAggregationBatches :: + (Default b, HasField "aggregate" b (Maybe AggregationStrategy)) => + -- | The accessor for the sub-group of processors. + (Processors -> Maybe a) -> + -- | The accessor for the individual processor. + (a -> Maybe b) -> + -- | The full configuration. + FullConfig -> + Int +processorAggregationBatches group field fullConfig = + toAggregationBatches fullConfig.batchIntervalMs fullConfig.eventlogFlushIntervalX $ + processorAggregationStrategy group field fullConfig + +{- | +Get all aggregation strategies. +-} +allAggregationStrategies :: + Config -> + [AggregationStrategy] +allAggregationStrategies = + catMaybes . with (.processors) (with (.metrics) (forEachMetricProcessor ((.aggregate) =<<))) + +{- | +Get the largest aggregation strategy in batches. +-} +maximumAggregationBatches :: + FullConfig -> + Int +maximumAggregationBatches fullConfig = + maximum . fmap (toAggregationBatches fullConfig.batchIntervalMs fullConfig.eventlogFlushIntervalX . Just) $ + allAggregationStrategies fullConfig.config + +-------------------------------------------------------------------------------- +-- Export Strategy + +{- | +Get the export strategy corresponding to a processor. +-} +processorExportStrategy :: + (Default b, HasField "export" b (Maybe ExportStrategy)) => + (Processors -> Maybe a) -> + (a -> Maybe b) -> + FullConfig -> + Maybe ExportStrategy +processorExportStrategy group field = + (.export) . fromMaybe def . userProcessorConfig group field + +{- | +Convert an `ExportStrategy` to a number of batches. + +__Precondition:__ +If the export strategy is defined in seconds, +then the batch interval should divide this duration. +-} +toExportBatches :: + -- | The batch interval in milliseconds. + Int -> + -- | The @--eventlog-flush-interval@ in /batches/. + Int -> + -- | The export strategy. + Maybe ExportStrategy -> + Int +toExportBatches batchIntervalMs eventlogFlushIntervalX = \case + -- If the setting is '60s' this means 60 seconds. + Just (ExportStrategyDuration DurationBySeconds{..}) -> toMilli seconds `div` batchIntervalMs + -- If the setting is '60x' this means 60 times the /eventlog flush interval/, + -- not the interal batch interval. + Just (ExportStrategyDuration DurationByBatches{..}) -> batches * eventlogFlushIntervalX + -- If the setting is 'true' this means '1x', i.e., /eventlog flush interval/. + Just ExportStrategyBool{..} | isOn -> eventlogFlushIntervalX + -- If the setting is absent or 'false' this means /do not aggregate/. + Nothing -> 0 + Just ExportStrategyBool{..} -> assert (not isOn) 0 + +{- | +Get the export strategy corresponding to processor in batches. +-} +processorExportBatches :: + (Default b, HasField "export" b (Maybe ExportStrategy)) => + (Processors -> Maybe a) -> + (a -> Maybe b) -> + FullConfig -> + Int +processorExportBatches group field fullConfig = + toExportBatches fullConfig.batchIntervalMs fullConfig.eventlogFlushIntervalX $ + processorExportStrategy group field fullConfig + +{- | +Get all export strategies. +-} +allExportStrategies :: + Config -> + [ExportStrategy] +allExportStrategies = + catMaybes . with (.processors) (forEachProcessor ((.export) =<<)) + +{- | +Get the largest export strategy in batches. +-} +maximumExportBatches :: + FullConfig -> + Int +maximumExportBatches fullConfig = + maximum . fmap (toExportBatches fullConfig.batchIntervalMs fullConfig.eventlogFlushIntervalX . Just) $ + allExportStrategies fullConfig.config + +------------------------------------------------------------------------------- +-- Batch Interval + +{- | +Get the batch interval such that all user-specified intervals can be respected. +-} +toBatchIntervalMs :: + -- | The @--eventlog-flush-interval@. + Double -> + -- | The configuration. + Config -> + Int +toBatchIntervalMs eventlogFlushIntervalS config = + (.getGCD) . sconcat . fmap GCD $ + eventlogFlushIntervalMs :| aggregationIntervalsMs <> exportIntervalsMs + where + -- TODO: Check if any intervals round to 0ms. + eventlogFlushIntervalMs = + toMilli eventlogFlushIntervalS + aggregationIntervalsMs = + mapMaybe (fmap toMilli . toAggregationSeconds) . allAggregationStrategies $ config + exportIntervalsMs = + mapMaybe (fmap toMilli . toExportSeconds) . allExportStrategies $ config + +{- | +Get the relevant interval in batches. + +__Precondition:__ The batch interval divides the relevant interval. +-} +toBatches :: + -- | The batch interval in milliseconds. + Int -> + -- | The relevant interval in seconds. + Double -> + Int +toBatches batchIntervalMs intervalS = + toMilli intervalS `div` batchIntervalMs + +------------------------------------------------------------------------------- +-- Exporters +------------------------------------------------------------------------------- + +shouldExportLogs :: FullConfig -> Bool +shouldExportLogs = + getAny + . with + (.processors) + ( with + (.logs) + (mconcat . forEachLogProcessor (Any . isEnabled)) + ) + . (.config) + +shouldExportMetrics :: FullConfig -> Bool +shouldExportMetrics = + getAny + . with + (.processors) + ( with + (.metrics) + (mconcat . forEachMetricProcessor (Any . isEnabled)) + ) + . (.config) + +shouldExportTraces :: FullConfig -> Bool +shouldExportTraces = + getAny + . with + (.processors) + ( with + (.traces) + (mconcat . forEachTraceProcessor (Any . isEnabled)) + ) + . (.config) + +shouldExportProfiles :: FullConfig -> Bool +shouldExportProfiles = + getAny + . with + (.processors) + ( with + (.profiles) + (mconcat . forEachProfileProcessor (Any . isEnabled)) + ) + . (.config) + +------------------------------------------------------------------------------- +-- Functors for processor configurations +------------------------------------------------------------------------------- + +{- | +Apply a function to each processor. +-} +forEachProcessor :: + ( forall processorConfig. + (IsProcessorConfig processorConfig) => + Maybe processorConfig -> a + ) -> + Processors -> + [a] +forEachProcessor f processors = + concatMap (fromMaybe []) $ + [ forEachLogProcessor f <$> processors.logs + , forEachMetricProcessor f <$> processors.metrics + , forEachTraceProcessor f <$> processors.traces + , forEachProfileProcessor f <$> processors.profiles + ] + +{- | +Apply a function to each metric processor. +-} +forEachLogProcessor :: + ( forall traceProcessorConfig. + (IsLogProcessorConfig traceProcessorConfig) => + Maybe traceProcessorConfig -> a + ) -> + Logs -> + [a] +forEachLogProcessor f logs = + [ -- NOTE: This should be kept in sync with the list of logs. + f logs.threadLabel + , f logs.userMarker + , f logs.userMessage + , f logs.internalLogMessage + ] + +{- | +Apply a function to each metric processor. +-} +forEachMetricProcessor :: + ( forall metricProcessorConfig. + (IsMetricProcessorConfig metricProcessorConfig) => + Maybe metricProcessorConfig -> a + ) -> + Metrics -> + [a] +forEachMetricProcessor f metrics = + [ -- NOTE: This should be kept in sync with the list of metrics. + f metrics.heapAllocated + , f metrics.blocksSize + , f metrics.heapSize + , f metrics.heapLive + , f metrics.memCurrent + , f metrics.memNeeded + , f metrics.memReturned + , f metrics.heapProfSample + , f metrics.capabilityUsage + ] + +{- | +Apply a function to each metric processor. +-} +forEachTraceProcessor :: + ( forall traceProcessorConfig. + (IsTraceProcessorConfig traceProcessorConfig) => + Maybe traceProcessorConfig -> a + ) -> + Traces -> + [a] +forEachTraceProcessor f traces = + [ -- NOTE: This should be kept in sync with the list of traces. + f traces.capabilityUsage + , f traces.threadState + ] + +{- | +Apply a function to each metric processor. +-} +forEachProfileProcessor :: + ( forall profileProcessorConfig. + (IsProfileProcessorConfig profileProcessorConfig) => + Maybe profileProcessorConfig -> a + ) -> + Profiles -> + [a] +forEachProfileProcessor f profiles = + [ -- NOTE: This should be kept in sync with the list of profiles. + f profiles.callStackProfile + , f profiles.costCentreStackProfile + ] + +------------------------------------------------------------------------------- +-- Internal Helpers +------------------------------------------------------------------------------- + +{- | +Internal helper. +-} +with :: (Foldable f, Monoid r) => (s -> f t) -> (t -> r) -> s -> r +with = flip ((.) . foldMap) + +{- | +Internal helper. +Convert seconds to milliseconds. +-} +toMilli :: Double -> Int +toMilli seconds = round (seconds * 1_000) + +{- | +Internal helper. +Wrapper that provides a `Semigroup` instance for `gcd`. +-} +newtype GCD a = GCD {getGCD :: a} + +instance (Integral a) => Semigroup (GCD a) where + (<>) :: GCD a -> GCD a -> GCD a + x <> y = GCD{getGCD = x.getGCD `gcd` y.getGCD} diff --git a/src-app/GHC/Eventlog/Live/Otlp/Config/Default.hs b/src-app/GHC/Eventlog/Live/Otlp/Config/Default.hs new file mode 100644 --- /dev/null +++ b/src-app/GHC/Eventlog/Live/Otlp/Config/Default.hs @@ -0,0 +1,105 @@ +{-# LANGUAGE AllowAmbiguousTypes #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE UndecidableInstances #-} +{-# OPTIONS_GHC -Wno-orphans #-} + +{- | +Module : GHC.Eventlog.Live.Otlp.Config +Description : The implementation of @eventlog-live-otlp@. +Stability : experimental +Portability : portable +-} +module GHC.Eventlog.Live.Otlp.Config.Default ( + defaultConfig, + + -- * Internal helpers for defining `Default` instances + MissingDefaultException (..), + getDefault, +) where + +import Control.Exception (Exception (..), throw) +import Data.Bifunctor (Bifunctor (..)) +import Data.Kind (Type) +import Data.List (intercalate) +import Data.Proxy (Proxy (..)) +import GHC.Eventlog.Live.Otlp.Config.Default.Raw (decodeThrow, defaultConfigByteString) +import GHC.Eventlog.Live.Otlp.Config.Types (Config) +import GHC.Records (HasField (..)) +import GHC.TypeLits (KnownSymbol, Symbol, symbolVal) +import Language.Haskell.TH.Lift.Compat (Exp, Lift (..), Q) + +{- | +Internal helper. +The default configuration. +-} +defaultConfig :: Config +defaultConfig = $(lift =<< decodeThrow @Q @Config defaultConfigByteString) + +{- | +__Warning:__ Compile-time only. + +Internal helper. +This exception is thrown when a property is missing from the default configuration file. +-} +newtype MissingDefaultException + = MissingDefaultException + { accessors :: [String] + } + +instance Show MissingDefaultException where + show :: MissingDefaultException -> String + show e = + "Missing property '" <> intercalate "." e.accessors <> "' in default configuration" + +instance Exception MissingDefaultException + +{- | +__Warning:__ Compile-time only. + +Internal helper. +Get the default value under the given path of accessors and `lift` it. +-} +getDefault :: + forall xs a b. + (GetDefault xs a b, Lift b) => + a -> + Q Exp +getDefault a = either throw lift (getDefaultEither @xs @a @b a) + +{- | +__Warning:__ Compile-time only. + +Internal helper. +Get the default value under the given accessor after calling a recursor. +This function is used to implement the `GetDefault` instances. +-} +getDefaultEither' :: + forall x a b c. + (KnownSymbol x, HasField x a (Maybe b)) => + (b -> Either MissingDefaultException c) -> + a -> + Either MissingDefaultException c +getDefaultEither' rec a = + first addAccessor . maybe (Left $ MissingDefaultException []) rec $ getField @x a + where + addAccessor :: MissingDefaultException -> MissingDefaultException + addAccessor e = MissingDefaultException{accessors = symbolVal (Proxy @x) : e.accessors} + +{- | +__Warning:__ Compile-time only. + +Internal helper. +This class guides the search for `getDefaultEither` functions from a list of accessors. +-} +class GetDefault (xs :: [Symbol]) (a :: Type) (b :: Type) where + getDefaultEither :: a -> Either MissingDefaultException b + +instance (KnownSymbol x, HasField x a (Maybe b)) => GetDefault (x ': '[]) a b where + getDefaultEither :: a -> Either MissingDefaultException b + getDefaultEither = getDefaultEither' @x Right + {-# INLINE getDefaultEither #-} + +instance (KnownSymbol x, HasField x a (Maybe b), GetDefault (y ': ys) b c) => GetDefault (x ': y ': ys) a c where + getDefaultEither :: a -> Either MissingDefaultException c + getDefaultEither = getDefaultEither' @x (getDefaultEither @(y ': ys)) + {-# INLINE getDefaultEither #-} diff --git a/src-app/GHC/Eventlog/Live/Otlp/Config/Default/Raw.hs b/src-app/GHC/Eventlog/Live/Otlp/Config/Default/Raw.hs new file mode 100644 --- /dev/null +++ b/src-app/GHC/Eventlog/Live/Otlp/Config/Default/Raw.hs @@ -0,0 +1,74 @@ +{-# LANGUAGE TemplateHaskell #-} + +{- | +Module : GHC.Eventlog.Live.Otlp.Config.Default.Raw +Description : The implementation of @eventlog-live-otlp@. +Stability : experimental +Portability : portable +-} +module GHC.Eventlog.Live.Otlp.Config.Default.Raw ( + defaultConfigByteString, + defaultConfigString, + defaultConfigJSONSchemaByteString, + defaultConfigJSONSchemaString, + + -- * Compile-time only helper functions + decodeThrow, +) where + +import Data.ByteString (ByteString) +import Data.ByteString.Lazy qualified as BSL +import Data.FileEmbed (embedFileRelative) +import Data.Text qualified as T +import Data.Text.Encoding qualified as TE +import Data.YAML (FromYAML) +import Data.YAML qualified as YAML + +{- | +Internal helper. +The default configuration as a `ByteString`. +-} +defaultConfigByteString :: ByteString +defaultConfigByteString = $(embedFileRelative "data/default.yaml") + +{- | +Internal helper. +The default configuration as a `String`. +-} +defaultConfigString :: String +defaultConfigString = fromByteString defaultConfigByteString + +{- | +Internal helper. +The default configuration as a `ByteString`. +-} +defaultConfigJSONSchemaByteString :: ByteString +defaultConfigJSONSchemaByteString = $(embedFileRelative "data/config.schema.json") + +{- | +Internal helper. +The default configuration as a `String`. +-} +defaultConfigJSONSchemaString :: String +defaultConfigJSONSchemaString = fromByteString defaultConfigJSONSchemaByteString + +{- | +__Warning:__ Compile-time only. + +Internal helper. +Decode a `ByteString` or throw an exception. +-} +decodeThrow :: (MonadFail m, FromYAML a) => ByteString -> m a +decodeThrow byteString = + either (fail . prettyErrorMessage) pure $ YAML.decode1Strict byteString + where + prettyErrorMessage :: (YAML.Pos, String) -> String + prettyErrorMessage (pos, errorMessage) = + YAML.prettyPosWithSource pos (BSL.fromStrict byteString) " error" <> errorMessage + +{- | +Internal helper. +Decode a `ByteString` to a `String`. +-} +fromByteString :: ByteString -> String +fromByteString = T.unpack . TE.decodeUtf8Lenient diff --git a/src-app/GHC/Eventlog/Live/Otlp/Config/Types.hs b/src-app/GHC/Eventlog/Live/Otlp/Config/Types.hs new file mode 100644 --- /dev/null +++ b/src-app/GHC/Eventlog/Live/Otlp/Config/Types.hs @@ -0,0 +1,941 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# OPTIONS_GHC -Wno-name-shadowing #-} + +{- | +Module : GHC.Eventlog.Live.Otlp.Config.Types +Description : The implementation of @eventlog-live-otlp@. +Stability : experimental +Portability : portable +-} +module GHC.Eventlog.Live.Otlp.Config.Types ( + -- * Configuration type + Config (..), + FullConfig (..), + + -- ** Processor configuration types + Processors (..), + IsProcessorConfig, + + -- *** Log processor configuration types + Logs (..), + IsLogProcessorConfig, + ThreadLabel (..), + UserMarker (..), + UserMessage (..), + InternalLogMessage (..), + + -- *** Metric processor configuration types + Metrics (..), + IsMetricProcessorConfig, + HeapAllocatedMetric (..), + BlocksSizeMetric (..), + HeapSizeMetric (..), + HeapLiveMetric (..), + MemCurrentMetric (..), + MemNeededMetric (..), + MemReturnedMetric (..), + HeapProfSampleMetric (..), + CapabilityUsageMetric (..), + + -- *** Trace processor configuration types + Traces (..), + IsTraceProcessorConfig, + CapabilityUsageSpan (..), + ThreadStateSpan (..), + + -- *** Profile processor configuration types + Profiles (..), + IsProfileProcessorConfig, + CallStackProfile (..), + CostCentreStackProfile (..), + + -- ** Property types + Duration (..), + AggregationStrategy (..), + toAggregationSeconds, + ExportStrategy (..), + toExportSeconds, + isEnabled, +) where + +import Control.Applicative (asum) +import Data.Char (isDigit) +import Data.Kind (Constraint, Type) +import Data.Text (Text) +import Data.Text qualified as T +import Data.YAML (FromYAML (..), ToYAML, (.:?), (.=)) +import Data.YAML qualified as YAML +import GHC.Records (HasField (..)) +import Language.Haskell.TH.Lift.Compat (Lift) +import Text.ParserCombinators.ReadP (ReadP) +import Text.ParserCombinators.ReadP qualified as P +import Text.Read (readEither) + +{- | +The extended configuration with derived fields. +-} +data FullConfig = FullConfig + { batchIntervalMs :: !Int + -- ^ The batch interval in milliseconds. + , eventlogFlushIntervalX :: !Int + -- ^ The @--eventlog-flush-interval@ in /batches/. + , config :: !Config + } + +{- | +The configuration for @eventlog-live-otlp@. +-} +newtype Config = Config + { processors :: Maybe Processors + } + deriving (Lift, Show) + +instance FromYAML Config where + parseYAML :: YAML.Node YAML.Pos -> YAML.Parser Config + parseYAML = YAML.withMap "Config" $ \m -> + Config + <$> m .:? "processors" + +instance ToYAML Config where + toYAML :: Config -> YAML.Node () + toYAML config = + YAML.mapping + [ "processors" .= config.processors + ] + +{- | +The configuration options for the processors. +-} +data Processors = Processors + { logs :: Maybe Logs + , metrics :: Maybe Metrics + , traces :: Maybe Traces + , profiles :: Maybe Profiles + } + deriving (Lift, Show) + +instance FromYAML Processors where + parseYAML :: YAML.Node YAML.Pos -> YAML.Parser Processors + parseYAML = YAML.withMap "Processors" $ \m -> + Processors + <$> m .:? "logs" + <*> m .:? "metrics" + <*> m .:? "traces" + <*> m .:? "profiles" + +instance ToYAML Processors where + toYAML :: Processors -> YAML.Node () + toYAML processors = + YAML.mapping + [ "logs" .= processors.logs + , "metrics" .= processors.metrics + , "traces" .= processors.traces + , "profiles" .= processors.profiles + ] + +{- | +The configuration options for the span processors. +-} + +-- NOTE: +-- If you add a new log, search for the string... +-- +-- This should be kept in sync with the list of logs. +-- +-- ...and update all the relevant locations. +data Logs = Logs + { threadLabel :: Maybe ThreadLabel + , userMarker :: Maybe UserMarker + , userMessage :: Maybe UserMessage + , internalLogMessage :: Maybe InternalLogMessage + } + deriving (Lift, Show) + +instance FromYAML Logs where + parseYAML :: YAML.Node YAML.Pos -> YAML.Parser Logs + parseYAML = + -- NOTE: This should be kept in sync with the list of logs. + YAML.withMap "Logs" $ \m -> + Logs + <$> m .:? "thread_label" + <*> m .:? "user_marker" + <*> m .:? "user_message" + <*> m .:? "internal_log_message" + +instance ToYAML Logs where + toYAML :: Logs -> YAML.Node () + toYAML logs = + -- NOTE: This should be kept in sync with the list of logs. + YAML.mapping + [ "thread_label" .= logs.threadLabel + , "user_marker" .= logs.userMarker + , "user_message" .= logs.userMessage + , "internal_log_message" .= logs.internalLogMessage + ] + +{- | +The configuration options for the metric processors. +-} + +-- NOTE: +-- If you add a new metric, search for the string... +-- +-- This should be kept in sync with the list of metrics. +-- +-- ...and update all the relevant locations. +data Metrics = Metrics + { heapAllocated :: Maybe HeapAllocatedMetric + , blocksSize :: Maybe BlocksSizeMetric + , heapSize :: Maybe HeapSizeMetric + , heapLive :: Maybe HeapLiveMetric + , memCurrent :: Maybe MemCurrentMetric + , memNeeded :: Maybe MemNeededMetric + , memReturned :: Maybe MemReturnedMetric + , heapProfSample :: Maybe HeapProfSampleMetric + , capabilityUsage :: Maybe CapabilityUsageMetric + } + deriving (Lift, Show) + +instance FromYAML Metrics where + parseYAML :: YAML.Node YAML.Pos -> YAML.Parser Metrics + parseYAML = + -- NOTE: This should be kept in sync with the list of metrics. + YAML.withMap "Metrics" $ \m -> + Metrics + <$> m .:? "heap_allocated" + <*> m .:? "blocks_size" + <*> m .:? "heap_size" + <*> m .:? "heap_live" + <*> m .:? "mem_current" + <*> m .:? "mem_needed" + <*> m .:? "mem_returned" + <*> m .:? "heap_prof_sample" + <*> m .:? "capability_usage" + +instance ToYAML Metrics where + toYAML :: Metrics -> YAML.Node () + toYAML metrics = + -- NOTE: This should be kept in sync with the list of metrics. + YAML.mapping + [ "heap_allocated" .= metrics.heapAllocated + , "blocks_size" .= metrics.blocksSize + , "heap_size" .= metrics.heapSize + , "heap_live" .= metrics.heapLive + , "mem_current" .= metrics.memCurrent + , "mem_needed" .= metrics.memNeeded + , "mem_returned" .= metrics.memReturned + , "heap_prof_sample" .= metrics.heapProfSample + , "capability_usage" .= metrics.capabilityUsage + ] + +{- | +The configuration options for the span processors. +-} + +-- NOTE: +-- If you add a new trace, search for the string... +-- +-- This should be kept in sync with the list of traces. +-- +-- ...and update all the relevant locations. +data Traces = Traces + { capabilityUsage :: Maybe CapabilityUsageSpan + , threadState :: Maybe ThreadStateSpan + } + deriving (Lift, Show) + +instance FromYAML Traces where + parseYAML :: YAML.Node YAML.Pos -> YAML.Parser Traces + parseYAML = + -- NOTE: This should be kept in sync with the list of traces. + YAML.withMap "Traces" $ \m -> + Traces + <$> m .:? "capability_usage" + <*> m .:? "thread_state" + +instance ToYAML Traces where + toYAML :: Traces -> YAML.Node () + toYAML traces = + -- NOTE: This should be kept in sync with the list of traces. + YAML.mapping + [ "capability_usage" .= traces.capabilityUsage + , "thread_state" .= traces.threadState + ] + +{- | +The configuration options for the profile processors. +-} +data Profiles = Profiles + { callStackProfile :: Maybe CallStackProfile + , costCentreStackProfile :: Maybe CostCentreStackProfile + } + deriving (Lift, Show) + +instance FromYAML Profiles where + parseYAML :: YAML.Node YAML.Pos -> YAML.Parser Profiles + parseYAML = + -- NOTE: This should be kept in sync with the list of profiles. + YAML.withMap "Profiles" $ \m -> + Profiles + <$> m .:? "call_stack_profile" + <*> m .:? "cost_centre_stack_profile" + +instance ToYAML Profiles where + toYAML :: Profiles -> YAML.Node () + toYAML profiles = + -- NOTE: This should be kept in sync with the list of profiles. + YAML.mapping + [ "call_stack_profile" .= profiles.callStackProfile + , "cost_centre_stack_profile" .= profiles.costCentreStackProfile + ] + +------------------------------------------------------------------------------- +-- Logs +------------------------------------------------------------------------------- + +{- | +The configuration options for `GHC.Eventlog.Live.Machine.Analysis.Thread.processThreadLabelData`. +-} +data ThreadLabel = ThreadLabel + { name :: Maybe Text + , description :: Maybe Text + , export :: Maybe ExportStrategy + } + deriving (Lift, Show) + +instance FromYAML ThreadLabel where + parseYAML :: YAML.Node YAML.Pos -> YAML.Parser ThreadLabel + parseYAML = genericParseYAMLLogProcessorConfig "ThreadLabel" ThreadLabel + +instance ToYAML ThreadLabel where + toYAML :: ThreadLabel -> YAML.Node () + toYAML = genericToYAMLLogProcessorConfig + +{- | +The configuration options for `GHC.Eventlog.Live.Machine.Analysis.Log.processStackFrame'Message`. +-} +data UserMessage = UserMessage + { name :: Maybe Text + , description :: Maybe Text + , export :: Maybe ExportStrategy + } + deriving (Lift, Show) + +instance FromYAML UserMessage where + parseYAML :: YAML.Node YAML.Pos -> YAML.Parser UserMessage + parseYAML = genericParseYAMLLogProcessorConfig "UserMessage" UserMessage + +instance ToYAML UserMessage where + toYAML :: UserMessage -> YAML.Node () + toYAML = genericToYAMLLogProcessorConfig + +{- | +The configuration options for `GHC.Eventlog.Live.Machine.Analysis.Log.processUserMarkerData`. +-} +data UserMarker = UserMarker + { name :: Maybe Text + , description :: Maybe Text + , export :: Maybe ExportStrategy + } + deriving (Lift, Show) + +instance FromYAML UserMarker where + parseYAML :: YAML.Node YAML.Pos -> YAML.Parser UserMarker + parseYAML = genericParseYAMLLogProcessorConfig "UserMarker" UserMarker + +instance ToYAML UserMarker where + toYAML :: UserMarker -> YAML.Node () + toYAML = genericToYAMLLogProcessorConfig + +{- | +The configuration options for internal log messages. +-} +data InternalLogMessage = InternalLogMessage + { name :: Maybe Text + , description :: Maybe Text + , export :: Maybe ExportStrategy + } + deriving (Lift, Show) + +instance FromYAML InternalLogMessage where + parseYAML :: YAML.Node YAML.Pos -> YAML.Parser InternalLogMessage + parseYAML = genericParseYAMLLogProcessorConfig "InternalLogMessage" InternalLogMessage + +instance ToYAML InternalLogMessage where + toYAML :: InternalLogMessage -> YAML.Node () + toYAML = genericToYAMLLogProcessorConfig + +------------------------------------------------------------------------------- +-- Metrics +------------------------------------------------------------------------------- + +{- | +The configuration options for `GHC.Eventlog.Live.Machine.Analysis.Heap.processHeapAllocatedData`. +-} +data HeapAllocatedMetric = HeapAllocatedMetric + { name :: Maybe Text + , description :: Maybe Text + , aggregate :: Maybe AggregationStrategy + , export :: Maybe ExportStrategy + } + deriving (Lift, Show) + +instance FromYAML HeapAllocatedMetric where + parseYAML :: YAML.Node YAML.Pos -> YAML.Parser HeapAllocatedMetric + parseYAML = genericParseYAMLMetricProcessorConfig "HeapAllocatedMetric" HeapAllocatedMetric + +instance ToYAML HeapAllocatedMetric where + toYAML :: HeapAllocatedMetric -> YAML.Node () + toYAML = genericToYAMLMetricProcessorConfig + +{- | +The configuration options for `GHC.Eventlog.Live.Machine.Analysis.Heap.processHeapSizeData`. +-} +data HeapSizeMetric = HeapSizeMetric + { name :: Maybe Text + , description :: Maybe Text + , aggregate :: Maybe AggregationStrategy + , export :: Maybe ExportStrategy + } + deriving (Lift, Show) + +instance FromYAML HeapSizeMetric where + parseYAML :: YAML.Node YAML.Pos -> YAML.Parser HeapSizeMetric + parseYAML = genericParseYAMLMetricProcessorConfig "HeapSizeMetric" HeapSizeMetric + +instance ToYAML HeapSizeMetric where + toYAML :: HeapSizeMetric -> YAML.Node () + toYAML = genericToYAMLMetricProcessorConfig + +{- | +The configuration options for `GHC.Eventlog.Live.Machine.Analysis.Heap.processBlocksSizeData`. +-} +data BlocksSizeMetric = BlocksSizeMetric + { name :: Maybe Text + , description :: Maybe Text + , aggregate :: Maybe AggregationStrategy + , export :: Maybe ExportStrategy + } + deriving (Lift, Show) + +instance FromYAML BlocksSizeMetric where + parseYAML :: YAML.Node YAML.Pos -> YAML.Parser BlocksSizeMetric + parseYAML = genericParseYAMLMetricProcessorConfig "BlocksSizeMetric" BlocksSizeMetric + +instance ToYAML BlocksSizeMetric where + toYAML :: BlocksSizeMetric -> YAML.Node () + toYAML = genericToYAMLMetricProcessorConfig + +{- | +The configuration options for `GHC.Eventlog.Live.Machine.Analysis.Heap.processHeapLiveData`. +-} +data HeapLiveMetric = HeapLiveMetric + { name :: Maybe Text + , description :: Maybe Text + , aggregate :: Maybe AggregationStrategy + , export :: Maybe ExportStrategy + } + deriving (Lift, Show) + +instance FromYAML HeapLiveMetric where + parseYAML :: YAML.Node YAML.Pos -> YAML.Parser HeapLiveMetric + parseYAML = genericParseYAMLMetricProcessorConfig "HeapLiveMetric" HeapLiveMetric + +instance ToYAML HeapLiveMetric where + toYAML :: HeapLiveMetric -> YAML.Node () + toYAML = genericToYAMLMetricProcessorConfig + +{- | +The configuration options for the @memCurrent@ field `GHC.Eventlog.Live.Machine.Analysis.Heap.processMemReturnData`. +-} +data MemCurrentMetric = MemCurrentMetric + { name :: Maybe Text + , description :: Maybe Text + , aggregate :: Maybe AggregationStrategy + , export :: Maybe ExportStrategy + } + deriving (Lift, Show) + +instance FromYAML MemCurrentMetric where + parseYAML :: YAML.Node YAML.Pos -> YAML.Parser MemCurrentMetric + parseYAML = genericParseYAMLMetricProcessorConfig "MemCurrentMetric" MemCurrentMetric + +instance ToYAML MemCurrentMetric where + toYAML :: MemCurrentMetric -> YAML.Node () + toYAML = genericToYAMLMetricProcessorConfig + +{- | +The configuration options for the @memNeeded@ field `GHC.Eventlog.Live.Machine.Analysis.Heap.processMemReturnData`. +-} +data MemNeededMetric = MemNeededMetric + { name :: Maybe Text + , description :: Maybe Text + , aggregate :: Maybe AggregationStrategy + , export :: Maybe ExportStrategy + } + deriving (Lift, Show) + +instance FromYAML MemNeededMetric where + parseYAML :: YAML.Node YAML.Pos -> YAML.Parser MemNeededMetric + parseYAML = genericParseYAMLMetricProcessorConfig "MemNeededMetric" MemNeededMetric + +instance ToYAML MemNeededMetric where + toYAML :: MemNeededMetric -> YAML.Node () + toYAML = genericToYAMLMetricProcessorConfig + +{- | +The configuration options for the @memReturned@ field `GHC.Eventlog.Live.Machine.Analysis.Heap.processMemReturnData`. +-} +data MemReturnedMetric = MemReturnedMetric + { name :: Maybe Text + , description :: Maybe Text + , aggregate :: Maybe AggregationStrategy + , export :: Maybe ExportStrategy + } + deriving (Lift, Show) + +instance FromYAML MemReturnedMetric where + parseYAML :: YAML.Node YAML.Pos -> YAML.Parser MemReturnedMetric + parseYAML = genericParseYAMLMetricProcessorConfig "MemReturnedMetric" MemReturnedMetric + +instance ToYAML MemReturnedMetric where + toYAML :: MemReturnedMetric -> YAML.Node () + toYAML = genericToYAMLMetricProcessorConfig + +{- | +The configuration options for `GHC.Eventlog.Live.Machine.Analysis.Heap.processHeapProfSampleData`. +-} +data HeapProfSampleMetric = HeapProfSampleMetric + { name :: Maybe Text + , description :: Maybe Text + , aggregate :: Maybe AggregationStrategy + , export :: Maybe ExportStrategy + } + deriving (Lift, Show) + +instance FromYAML HeapProfSampleMetric where + parseYAML :: YAML.Node YAML.Pos -> YAML.Parser HeapProfSampleMetric + parseYAML = genericParseYAMLMetricProcessorConfig "HeapProfSampleMetric" HeapProfSampleMetric + +instance ToYAML HeapProfSampleMetric where + toYAML :: HeapProfSampleMetric -> YAML.Node () + toYAML = genericToYAMLMetricProcessorConfig + +{- | +The configuration options for `GHC.Eventlog.Live.Machine.Analysis.Capability.processCapabilityUsageMetrics`. +-} +data CapabilityUsageMetric = CapabilityUsageMetric + { name :: Maybe Text + , description :: Maybe Text + , aggregate :: Maybe AggregationStrategy + , export :: Maybe ExportStrategy + } + deriving (Lift, Show) + +instance FromYAML CapabilityUsageMetric where + parseYAML :: YAML.Node YAML.Pos -> YAML.Parser CapabilityUsageMetric + parseYAML = genericParseYAMLMetricProcessorConfig "CapabilityUsageMetric" CapabilityUsageMetric + +instance ToYAML CapabilityUsageMetric where + toYAML :: CapabilityUsageMetric -> YAML.Node () + toYAML = genericToYAMLMetricProcessorConfig + +------------------------------------------------------------------------------- +-- Traces +------------------------------------------------------------------------------- + +{- | +The configuration options for `GHC.Eventlog.Live.Machine.Analysis.Capability.processCapabilityUsageTraces`. +-} +data CapabilityUsageSpan = CapabilityUsageSpan + { name :: Maybe Text + , description :: Maybe Text + , export :: Maybe ExportStrategy + } + deriving (Lift, Show) + +instance FromYAML CapabilityUsageSpan where + parseYAML :: YAML.Node YAML.Pos -> YAML.Parser CapabilityUsageSpan + parseYAML = genericParseYAMLTraceProcessorConfig "CapabilityUsageSpan" CapabilityUsageSpan + +instance ToYAML CapabilityUsageSpan where + toYAML :: CapabilityUsageSpan -> YAML.Node () + toYAML = genericToYAMLTraceProcessorConfig + +{- | +The configuration options for `GHC.Eventlog.Live.Machine.Analysis.Thread.processThreadStateSpan`. +-} +data ThreadStateSpan = ThreadStateSpan + { name :: Maybe Text + , description :: Maybe Text + , export :: Maybe ExportStrategy + } + deriving (Lift, Show) + +instance FromYAML ThreadStateSpan where + parseYAML :: YAML.Node YAML.Pos -> YAML.Parser ThreadStateSpan + parseYAML = genericParseYAMLTraceProcessorConfig "ThreadStateSpan" ThreadStateSpan + +instance ToYAML ThreadStateSpan where + toYAML :: ThreadStateSpan -> YAML.Node () + toYAML = genericToYAMLTraceProcessorConfig + +------------------------------------------------------------------------------- +-- Profiles +------------------------------------------------------------------------------- + +{- | +The configuration options for `GHC.Eventlog.Live.Machine.Analysis.Profile.processStackProfSampleData`. +-} +data CallStackProfile = CallStackProfile + { name :: Maybe Text + , description :: Maybe Text + , export :: Maybe ExportStrategy + } + deriving (Lift, Show) + +instance FromYAML CallStackProfile where + parseYAML :: YAML.Node YAML.Pos -> YAML.Parser CallStackProfile + parseYAML = genericParseYAMLProfilerProcessorConfig "CallStackProfile" CallStackProfile + +instance ToYAML CallStackProfile where + toYAML :: CallStackProfile -> YAML.Node () + toYAML = genericToYAMLProfilerProcessorConfig + +{- | +The configuration options for `GHC.Eventlog.Live.Machine.Analysis.Profile.processCostCentreProfSampleData`. +-} +data CostCentreStackProfile = CostCentreStackProfile + { name :: Maybe Text + , description :: Maybe Text + , export :: Maybe ExportStrategy + } + deriving (Lift, Show) + +instance FromYAML CostCentreStackProfile where + parseYAML :: YAML.Node YAML.Pos -> YAML.Parser CostCentreStackProfile + parseYAML = genericParseYAMLProfilerProcessorConfig "CostCentreStackProfile" CostCentreStackProfile + +instance ToYAML CostCentreStackProfile where + toYAML :: CostCentreStackProfile -> YAML.Node () + toYAML = genericToYAMLProfilerProcessorConfig + +------------------------------------------------------------------------------- +-- Configuration supertypes +------------------------------------------------------------------------------- + +{- | +The structural type of processor configurations. +-} +type IsProcessorConfig :: Type -> Constraint +type IsProcessorConfig config = + ( HasField "name" config (Maybe Text) + , HasField "description" config (Maybe Text) + , HasField "export" config (Maybe ExportStrategy) + ) + +{- | +The structural type of log processor configurations. +-} +type IsLogProcessorConfig :: Type -> Constraint +type IsLogProcessorConfig config = + (IsProcessorConfig config) + +{- | +The structural type of metric processor configurations. +-} +type IsMetricProcessorConfig :: Type -> Constraint +type IsMetricProcessorConfig config = + ( IsProcessorConfig config + , HasField "aggregate" config (Maybe AggregationStrategy) + ) + +{- | +The structural type of span processor configurations. +-} +type IsTraceProcessorConfig :: Type -> Constraint +type IsTraceProcessorConfig config = + (IsProcessorConfig config) + +{- | +The structural type of span processor configurations. +-} +type IsProfileProcessorConfig :: Type -> Constraint +type IsProfileProcessorConfig config = + (IsProcessorConfig config) + +-------------------------------------------------------------------------------- +-- Duration +-------------------------------------------------------------------------------- + +data Duration + = DurationByBatches {batches :: !Int} + | DurationBySeconds {seconds :: !Double} + deriving (Lift, Show) + +{- | +Internal helper. +A `ReadP` style parser for `AggregationStrategy`. +-} +readPDuration :: ReadP Duration +readPDuration = do + -- Parse the number + integerPart <- P.munch1 isDigit + maybeFractionPart <- P.option Nothing (Just <$ P.char '.' <*> P.munch1 isDigit) + + -- Make a duration by batches + let byBatches = + case maybeFractionPart of + Nothing -> + case readEither integerPart of + Left errorMsg -> fail $ "Could not parse duration: " <> errorMsg + Right batches -> pure DurationByBatches{..} + Just fractionPart -> fail $ "Fractional batches are unsupported; found " <> integerPart <> "." <> fractionPart <> "x" + + -- Make a duration by seconds + let bySeconds = + case readEither $ integerPart <> maybe "" ('.' :) maybeFractionPart of + Left errorMsg -> fail $ "Could not parse duration: " <> errorMsg + Right seconds -> pure DurationBySeconds{..} + + -- Parse the unit + asum + [ P.char 'x' >> byBatches + , P.char 's' >> bySeconds + ] + +{- | +Internal helper. +Pretty-print a duration. +-} +prettyDuration :: Duration -> String +prettyDuration = \case + DurationByBatches{..} -> show batches <> "x" + DurationBySeconds{..} -> show seconds <> "s" + +-------------------------------------------------------------------------------- +-- Aggregation Strategy +-------------------------------------------------------------------------------- + +{- | +The options for metric aggregation strategies. +-} +data AggregationStrategy + = AggregationStrategyBool {isOn :: !Bool} + | AggregationStrategyDuration {duration :: !Duration} + deriving (Lift, Show) + +{- | +Convert an `AggregationStrategy` to a number of seconds, if specified in seconds. +-} +toAggregationSeconds :: AggregationStrategy -> Maybe Double +toAggregationSeconds aggregationStrategy + | AggregationStrategyDuration DurationBySeconds{..} <- aggregationStrategy = Just seconds + | otherwise = Nothing + +instance FromYAML AggregationStrategy where + parseYAML :: YAML.Node YAML.Pos -> YAML.Parser AggregationStrategy + parseYAML node = YAML.withScalar "AggregationStrategy" parseYAMLScalar node + where + parseYAMLScalar = \case + YAML.SBool isOn -> pure AggregationStrategyBool{..} + YAML.SStr str + | [(duration, "")] <- P.readP_to_S readPDuration (T.unpack str) -> + pure AggregationStrategyDuration{..} + _otherwise -> YAML.typeMismatch "AggregationStrategy" node + +instance ToYAML AggregationStrategy where + toYAML :: AggregationStrategy -> YAML.Node () + toYAML = \case + AggregationStrategyBool{..} -> + YAML.Scalar () (YAML.SBool isOn) + AggregationStrategyDuration{..} -> + YAML.Scalar () (YAML.SStr . T.pack . prettyDuration $ duration) + +-------------------------------------------------------------------------------- +-- Export Strategy +-------------------------------------------------------------------------------- + +{- | +The options for export strategies. +-} +data ExportStrategy + = ExportStrategyBool {isOn :: !Bool} + | ExportStrategyDuration {duration :: !Duration} + deriving (Lift, Show) + +{- | +Check whether or not a processor is enabled based on its export strategy. +-} +isEnabled :: + forall processorConfig. + (HasField "export" processorConfig (Maybe ExportStrategy)) => + Maybe processorConfig -> Bool +isEnabled = + maybe False (isEnabledByExportStrategy . (.export)) + where + isEnabledByExportStrategy :: Maybe ExportStrategy -> Bool + isEnabledByExportStrategy = \case + Nothing -> True + Just ExportStrategyBool{..} -> isOn + Just ExportStrategyDuration{..} -> + case duration of + DurationByBatches{..} -> batches > 0 + DurationBySeconds{..} -> seconds > 0 + +{- | +Convert an `ExportStrategy` to a number of seconds, if specified in seconds. +-} +toExportSeconds :: ExportStrategy -> Maybe Double +toExportSeconds exportStrategy + | ExportStrategyDuration DurationBySeconds{..} <- exportStrategy = Just seconds + | otherwise = Nothing + +instance FromYAML ExportStrategy where + parseYAML :: YAML.Node YAML.Pos -> YAML.Parser ExportStrategy + parseYAML node = YAML.withScalar "ExportStrategy" parseYAMLScalar node + where + parseYAMLScalar = \case + YAML.SBool isOn -> pure ExportStrategyBool{..} + YAML.SStr str + | [(duration, "")] <- P.readP_to_S readPDuration (T.unpack str) -> + pure ExportStrategyDuration{..} + _otherwise -> YAML.typeMismatch "ExportStrategy" node + +instance ToYAML ExportStrategy where + toYAML :: ExportStrategy -> YAML.Node () + toYAML = \case + ExportStrategyBool{..} -> + YAML.Scalar () (YAML.SBool isOn) + ExportStrategyDuration{..} -> + YAML.Scalar () (YAML.SStr . T.pack . prettyDuration $ duration) + +------------------------------------------------------------------------------- +-- Internal Helpers +------------------------------------------------------------------------------- + +{- | +Internal helper. +Generic parser for log processor configuration. +-} +genericParseYAMLLogProcessorConfig :: + String -> + (Maybe Text -> Maybe Text -> Maybe ExportStrategy -> logProcessorConfig) -> + YAML.Node YAML.Pos -> + YAML.Parser logProcessorConfig +genericParseYAMLLogProcessorConfig log mkLogProcessorConfig = + YAML.withMap log $ \m -> + mkLogProcessorConfig + <$> m .:? "name" + <*> m .:? "description" + <*> m .:? "export" + +{- | +Internal helper. +Generic conversion from log processor configuration to YAML mappings. +-} +genericToYAMLLogProcessorConfig :: + (IsLogProcessorConfig logProcessorConfig) => + logProcessorConfig -> + YAML.Node () +genericToYAMLLogProcessorConfig logProcessorConfig = + YAML.mapping + [ "name" .= logProcessorConfig.name + , "description" .= logProcessorConfig.description + , "export" .= logProcessorConfig.export + ] + +{- | +Internal helper. +Generic parser for metric processor configuration. +-} +genericParseYAMLMetricProcessorConfig :: + String -> + (Maybe Text -> Maybe Text -> Maybe AggregationStrategy -> Maybe ExportStrategy -> metricProcessorConfig) -> + YAML.Node YAML.Pos -> + YAML.Parser metricProcessorConfig +genericParseYAMLMetricProcessorConfig metric mkMetricProcessorConfig = + YAML.withMap metric $ \m -> + mkMetricProcessorConfig + <$> m .:? "name" + <*> m .:? "description" + <*> m .:? "aggregate" + <*> m .:? "export" + +{- | +Internal helper. +Generic conversion from metric processor configuration to YAML mappings. +-} +genericToYAMLMetricProcessorConfig :: + (IsMetricProcessorConfig metricProcessorConfig) => + metricProcessorConfig -> + YAML.Node () +genericToYAMLMetricProcessorConfig metricProcessorConfig = + YAML.mapping + [ "name" .= metricProcessorConfig.name + , "description" .= metricProcessorConfig.description + , "aggregate" .= metricProcessorConfig.aggregate + , "export" .= metricProcessorConfig.export + ] + +{- | +Internal helper. +Generic parser for trace processor configuration. +-} +genericParseYAMLTraceProcessorConfig :: + String -> + (Maybe Text -> Maybe Text -> Maybe ExportStrategy -> traceProcessorConfig) -> + YAML.Node YAML.Pos -> + YAML.Parser traceProcessorConfig +genericParseYAMLTraceProcessorConfig trace mkTraceProcessorConfig = + YAML.withMap trace $ \m -> + mkTraceProcessorConfig + <$> m .:? "name" + <*> m .:? "description" + <*> m .:? "export" + +{- | +Internal helper. +Generic conversion from trace processor configuration to YAML mappings. +-} +genericToYAMLTraceProcessorConfig :: + (IsTraceProcessorConfig traceProcessorConfig) => + traceProcessorConfig -> + YAML.Node () +genericToYAMLTraceProcessorConfig traceProcessorConfig = + YAML.mapping + [ "name" .= traceProcessorConfig.name + , "description" .= traceProcessorConfig.description + , "export" .= traceProcessorConfig.export + ] + +{- | +Internal helper. +Generic parser for processor configuration. +-} +genericParseYAMLProfilerProcessorConfig :: + String -> + (Maybe Text -> Maybe Text -> Maybe ExportStrategy -> profilerConfig) -> + YAML.Node YAML.Pos -> + YAML.Parser profilerConfig +genericParseYAMLProfilerProcessorConfig trace mkProfilerConfig = + YAML.withMap trace $ \m -> + mkProfilerConfig + <$> m .:? "name" + <*> m .:? "description" + <*> m .:? "export" + +{- | +Internal helper. +Generic parser for metric configuration. +-} +genericToYAMLProfilerProcessorConfig :: + (IsTraceProcessorConfig profilerConfig) => + profilerConfig -> + YAML.Node () +genericToYAMLProfilerProcessorConfig profilerConfig = + YAML.mapping + [ "name" .= profilerConfig.name + , "description" .= profilerConfig.description + , "export" .= profilerConfig.export + ] diff --git a/src-app/GHC/Eventlog/Live/Otlp/Control.hs b/src-app/GHC/Eventlog/Live/Otlp/Control.hs new file mode 100644 --- /dev/null +++ b/src-app/GHC/Eventlog/Live/Otlp/Control.hs @@ -0,0 +1,712 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE OverloadedStrings #-} + +module GHC.Eventlog.Live.Otlp.Control ( + ControlOptions (..), + ControlPort (..), + ControlCors (..), + ControlCorsAllowOrigin (..), + ControlServerApi (..), + controlOptionsParser, + startControlServer, +) where + +import Control.Applicative (asum) +import Data.ByteString.Char8 qualified as BSC +import Data.Char (isSpace) +import Data.Maybe (isJust) +import GHC.Eventlog.Live.Logger (Logger) +import GHC.Eventlog.Live.Otlp.Environment (ServiceName (..)) +import GHC.Eventlog.Live.Source.Core (EventlogSourceHandle (..)) +import Options.Applicative qualified as O +import Options.Applicative.Compat qualified as OC +import Options.Applicative.Extra.Feature (Feature (..)) +import Options.Applicative.Extra.Feature qualified as OF +import Text.ParserCombinators.ReadP (ReadP) +import Text.ParserCombinators.ReadP qualified as P + +#ifdef EVENTLOG_LIVE_OTELCOL_FEATURE_CONTROL +import Control.Concurrent (forkIO, killThread) +import Control.Concurrent.STM (atomically) +import Control.Concurrent.STM.TVar (TVar, modifyTVar', newTVarIO, readTVarIO) +import Control.Exception (Exception (..), catches) +import Control.Exception qualified as E (Handler (..)) +import Control.Monad.IO.Class (MonadIO (..)) +import Data.Aeson qualified as JSON +import Data.Aeson.Types (FromJSON (..), ToJSON (..), Parser, Value, genericParseJSON, genericToJSON) +import Data.Binary qualified as B +import Data.ByteString.Lazy qualified as BSL +import Data.Char (isLower, isUpper, toLower) +import Data.HashMap.Strict (HashMap) +import Data.HashMap.Strict qualified as M +import Data.Proxy (Proxy (..)) +import Data.Text (Text) +import Data.Text qualified as T +import Data.Text.Encoding qualified as TE +import Data.Word (Word8) +import GHC.Eventlog.Live.Data.Severity (Severity (..)) +import GHC.Eventlog.Live.Logger (writeLog) +import GHC.Eventlog.Socket.Control qualified as C +import GHC.Generics (Generic) +import Network.Socket (Socket) +import Network.Socket.ByteString.Lazy qualified as SBSL +import Network.Wai (Middleware) +import Network.Wai.Handler.Warp qualified as Warp +import Network.Wai.Middleware.Cors (CorsResourcePolicy (..), Origin, cors) +import Network.Wai.Middleware.RequestLogger (Destination (..), DetailedSettings (..), OutputFormat (..), RequestLoggerSettings (..), defaultDetailedSettings, defaultRequestLoggerSettings, mkRequestLogger) +import Servant (PlainText, throwError) +import Servant.API (Capture, FormUrlEncoded, Get, Header, Headers, JSON, NoContent (..), PostAccepted, ReqBody, StdMethod (..), UVerb, Union, WithStatus (..), addHeader, (:>), type (:<|>) (..)) +import Servant.Server (Handler, Server, ServerError (..), serve, respond) +import System.Log.FastLogger (fromLogStr) +import Web.FormUrlEncoded (Form, FormOptions, FromForm (..), genericFromForm) +import Web.FormUrlEncoded qualified as Form (FormOptions (fieldLabelModifier), defaultFormOptions) +#else +import Control.Monad (when) +#endif + +-------------------------------------------------------------------------------- +-- Feature: control +-------------------------------------------------------------------------------- + +control :: Feature +control = Feature{flag = "control", isOn = isOn, info = "Cannot start control server."} + where + isOn :: Bool +#ifdef EVENTLOG_LIVE_OTELCOL_FEATURE_CONTROL + isOn = True +#else + isOn = False +#endif + +-------------------------------------------------------------------------------- +-- Control App +-------------------------------------------------------------------------------- + +data ControlServerApi = ControlServerApi + { notifyNewConnection :: ServiceName -> EventlogSourceHandle -> IO () + , notifyEndConnection :: ServiceName -> IO () + , stop :: IO () + } + +noopControlServerApi :: ControlServerApi +noopControlServerApi = + ControlServerApi + { notifyNewConnection = \_serviceName _eventlogSourceHandle -> pure () + , notifyEndConnection = \_serviceName -> pure () + , stop = pure () + } + +{- | +If the binary is built with -f+control and the control server is enabled from +the CLI, this starts the control server and returns the control server API. + +If the binary is NOT built with -f+control, but the control server is enabled +from the CLI, this prints an error and exits the process. + +If the control server is NOT enabled from the CLI, this returns a no-op API. +-} +startControlServer :: Logger IO -> ControlOptions -> IO ControlServerApi + +-------------------------------------------------------------------------------- +-- Control App - Disabled +-------------------------------------------------------------------------------- +#ifndef EVENTLOG_LIVE_OTELCOL_FEATURE_CONTROL + +startControlServer logger controlOptions = do + when (shouldStart controlOptions) $ + OF.exitIfUnsupported control logger + pure noopControlServerApi + +-------------------------------------------------------------------------------- +-- Control App - Enabled +-------------------------------------------------------------------------------- +#else + +startControlServer logger controlOptions + | shouldStart controlOptions = do + -- Determine the control port + let port = maybe 30179 (.port) controlOptions.controlPort + + writeLog logger INFO $ + "Starting control server on " <> T.pack (show port) + -- Create middleware that logs all incoming requests. + requestLogger <- mkLoggerMiddleware logger + + -- Create variable for storing sockets. + eventlogSourceHandleMap <- newTVarIO M.empty + + -- Create CORS resource policy. + -- + -- NOTE: The @wai-cors@ package lets the resource policy depend dynamically + -- on the received request. However, it is difficult to expose this freedom + -- via command-line arguments. + -- + -- TODO: We might have to manually find the origin in the request, check it + -- against the allow-list, and set the @corsOrigins@ field. + let !corsResourcePolicy = mkCorsResourcePolicy controlOptions.controlCors + + -- Start control server. + controlServerThreadId <- + forkIO $ + Warp.run port $ + requestLogger $ + cors (const $ Just corsResourcePolicy) $ + serve (Proxy @(HealthApi :<|> ControlApi)) $ + controlServer logger eventlogSourceHandleMap (corsIgnoreFailures corsResourcePolicy) + + -- When notified of a new connection, update the eventlogSourceHandleMap. + let notifyNewConnection serviceName eventlogSourceHandle = do + writeLog logger DEBUG $ + "New connection for service " <> serviceName.serviceName <> "." + atomically $ + modifyTVar' eventlogSourceHandleMap (M.insert serviceName eventlogSourceHandle) + + -- When notified of the end of a connection, update the eventlogSourceHandleMap. + let notifyEndConnection serviceName = do + writeLog logger DEBUG $ + "End connection for service " <> serviceName.serviceName <> "." + atomically $ + modifyTVar' eventlogSourceHandleMap (M.delete serviceName) + + -- When requested to stop, kill the control server thread. + let stop = killThread controlServerThreadId + + pure ControlServerApi{..} + | otherwise = + pure noopControlServerApi + +mkLoggerMiddleware :: Logger IO -> IO Middleware +mkLoggerMiddleware logger = + mkRequestLogger $ + defaultRequestLoggerSettings + { destination = Callback $ writeLog logger TRACE2 . TE.decodeUtf8Lenient . fromLogStr + , outputFormat = + DetailedWithSettings + defaultDetailedSettings + { useColors = False + } + } + +mkCorsResourcePolicy :: ControlCors -> CorsResourcePolicy +mkCorsResourcePolicy ControlCors{..} = + CorsResourcePolicy + { corsOrigins = corsOrigins + , corsMethods = ["GET", "POST"] + , corsRequestHeaders = ["Content-Type", "Origin"] + , corsExposedHeaders = Nothing + , corsMaxAge = controlCorsMaxAgeS + , corsVaryOrigin = corsVaryOrigin + , corsRequireOrigin = controlCorsRequireOrigin + , corsIgnoreFailures = controlCorsIgnoreFailures + } + where + -- TODO: If we add authentication, this flag needs to be set. + corsCredentials :: Bool + corsCredentials = False + + -- The @wai-cors@ package represents wildcard as @Nothing@ and otherwise + -- accepts a list of origins and a boolean that determines whether or not + -- credentials are used to access the resource. + corsOrigins :: Maybe ([Origin], Bool) + corsOrigins = + case controlCorsAllowOrigin of + Just (ControlCorsAllowOriginList origins) -> Just (origins, corsCredentials) + _otherwise -> Nothing + + -- The @Vary: Origin@ header must be added if @Access-Control-Allow-Origin@ + -- is not set to wildcard and there are multiple origins. + corsVaryOrigin :: Bool + corsVaryOrigin = + case controlCorsAllowOrigin of + Just (ControlCorsAllowOriginList origins) -> length origins >= 2 + _otherwise -> False + +-------------------------------------------------------------------------------- +-- Control Server + +controlServer :: Logger IO -> TVar (HashMap ServiceName EventlogSourceHandle) -> Bool -> Server (HealthApi :<|> ControlApi) +controlServer logger eventlogSourceHandleMapVar corsIgnoreFailures = + health :<|> controlApi + where + health :: Handler () + health = do + liftIO . writeLog logger DEBUG $ + "Received request on /health." + + controlApi :: Server ControlApi + controlApi = eventlogSocket :<|> customCommand + where + customCommand :: Server CustomCommandApi + customCommand namespaceText commandId = callCustomCommand :<|> badCORSPreflight + where + callCustomCommand :: CustomCommandReq -> Handler (Union '[CustomCommandAccept, CustomCommandReject]) + callCustomCommand req = do + liftIO . writeLog logger DEBUG $ + "Received request on /control/" <> namespaceText <> " with command ID " <> T.pack (show commandId) <> " for " <> req.serviceName <> "." + -- Construct the user namespace. + liftIO (eitherUserNamespace namespaceText) >>= \case + -- If userNamespace throws an exception, then... + Left customCommandError -> + -- ...respond with a custom command error. + respond . WithStatus @404 $ + customCommandError + -- Otherwise, ... + Right namespace -> do + -- ...construct the user command... + let command = C.userCommand namespace (C.CommandId commandId) + -- ...send the user command... + withSocketFor (ServiceName req.serviceName) $ \socket -> do + liftIO (SBSL.sendAll socket $ B.encode command) + -- ...respond with a success status. + respond . WithStatus @204 $ + NoContent + + eventlogSocket :: Server EventlogSocketApi + eventlogSocket = + (startProfiling :<|> badCORSPreflight) + :<|> (stopProfiling :<|> badCORSPreflight) + :<|> (startHeapProfiling :<|> badCORSPreflight) + :<|> (stopHeapProfiling :<|> badCORSPreflight) + :<|> (requestHeapCensus :<|> badCORSPreflight) + where + startProfiling :: StartProfilingReq -> Handler () + startProfiling req = do + liftIO . writeLog logger DEBUG $ + "Received request on /control/eventlog-socket/start-profiling for " <> req.serviceName <> "." + -- Send the control command over the socket. + withSocketFor (ServiceName req.serviceName) $ \socket -> do + liftIO (SBSL.sendAll socket $ B.encode C.startProfiling) + + stopProfiling :: StopProfilingReq -> Handler () + stopProfiling req = do + liftIO . writeLog logger DEBUG $ + "Received request on /control/eventlog-socket/stop-profiling for " <> req.serviceName <> "." + -- Send the control command over the socket. + withSocketFor (ServiceName req.serviceName) $ \socket -> do + liftIO (SBSL.sendAll socket $ B.encode C.stopProfiling) + + startHeapProfiling :: StartHeapProfilingReq -> Handler () + startHeapProfiling req = do + liftIO . writeLog logger DEBUG $ + "Received request on /control/eventlog-socket/start-heap-profiling for " <> req.serviceName <> "." + -- Send the control command over the socket. + withSocketFor (ServiceName req.serviceName) $ \socket -> do + liftIO (SBSL.sendAll socket $ B.encode C.startHeapProfiling) + + stopHeapProfiling :: StopHeapProfilingReq -> Handler () + stopHeapProfiling req = do + liftIO . writeLog logger DEBUG $ + "Received request on /control/eventlog-socket/stop-heap-profiling for " <> req.serviceName <> "." + -- Send the control command over the socket. + withSocketFor (ServiceName req.serviceName) $ \socket -> do + liftIO (SBSL.sendAll socket $ B.encode C.stopHeapProfiling) + + requestHeapCensus :: RequestHeapCensusReq -> Handler () + requestHeapCensus req = do + liftIO . writeLog logger DEBUG $ + "Received request on /control/eventlog-socket/request-heap-census for " <> req.serviceName <> "." + -- Send the control command over the socket. + withSocketFor (ServiceName req.serviceName) $ \socket -> do + liftIO (SBSL.sendAll socket $ B.encode C.requestHeapCensus) + + badCORSPreflight :: Handler (Union '[BadCORSPreflightAccept, BadCORSPreflightReject]) + badCORSPreflight + | corsIgnoreFailures = do + -- This accepts malformed CORS preflight requests. + liftIO . writeLog logger DEBUG $ "Accepted malformed CORS preflight request." + respond . WithStatus @204 $ + addHeader @"Access-Control-Allow-Origin" @String "*" $ + addHeader @"Access-Control-Allow-Methods" @String "GET, POST" $ + addHeader @"Access-Control-Allow-Headers" @String "*" $ + NoContent + | otherwise = do + liftIO . writeLog logger DEBUG $ "Accepted malformed CORS preflight request." + respond . WithStatus @400 $ + NoContent + + withSocketFor :: ServiceName -> (Socket -> Handler ()) -> Handler () + withSocketFor serviceName action = do + eventlogSourceHandleMap <- liftIO (readTVarIO eventlogSourceHandleMapVar) + case M.lookup serviceName eventlogSourceHandleMap of + -- If the service is not known, return a 404. + Nothing -> + throwError + ServerError + { errHTTPCode = 404 + , errReasonPhrase = "Not Found" + , errBody = BSL.fromStrict . TE.encodeUtf8 $ "Could not find eventlog socket for service " <> serviceName.serviceName <> "." + , errHeaders = [] + } + -- If the service telemetry is streamed from stdin or a file, return a 400. + Just EventlogSourceHandleStdin -> + throwError + ServerError + { errHTTPCode = 400 + , errReasonPhrase = "Bad Request" + , errBody = BSL.fromStrict . TE.encodeUtf8 $ "The telemetry for service " <> serviceName.serviceName <> " is streamed from stdin." + , errHeaders = [] + } + Just (EventlogSourceHandleFile _h) -> + throwError + ServerError + { errHTTPCode = 400 + , errReasonPhrase = "Bad Request" + , errBody = BSL.fromStrict . TE.encodeUtf8 $ "The telemetry for service " <> serviceName.serviceName <> " is streamed from a file." + , errHeaders = [] + } + -- If the service telemetry is streamed from a socket, continue. + Just (EventlogSourceHandleSocket s) -> action s + +-------------------------------------------------------------------------------- +-- Control API + +type ControlApi = + "control" :> (EventlogSocketApi :<|> CustomCommandApi) + +-------------------------------------------------------------------------------- +-- Health API + +type HealthApi = + "health" :> Get '[JSON] () + +-------------------------------------------------------------------------------- +-- Custom Command API + +type CustomCommandApi = + Capture "namespace" Text + :> Capture "commandId" Word8 + :> ((ReqBody '[FormUrlEncoded, JSON] CustomCommandReq + :> UVerb 'POST '[JSON] '[CustomCommandAccept, CustomCommandReject]) :<|> BadCORSPreflight) + +type CustomCommandAccept = WithStatus 204 NoContent + +type CustomCommandReject = WithStatus 404 CustomCommandError + +newtype CustomCommandError = CustomCommandError + { errorMessage :: String + } + deriving (Generic, Show) + +eitherUserNamespace :: Text -> IO (Either CustomCommandError C.Namespace) +eitherUserNamespace namespace = + (pure . Right . C.userNamespace $ namespace) `catches` handlers + where + handlers = + [ E.Handler $ pure . Left . toCustomCommandError @C.NamespaceReservedError + , E.Handler $ pure . Left . toCustomCommandError @C.NamespaceTooLongError + ] + +toCustomCommandError :: (Exception e) => e -> CustomCommandError +toCustomCommandError = CustomCommandError . displayException + +instance ToJSON CustomCommandError where + toJSON :: CustomCommandError -> Value + toJSON = genericToJSON myJSONOptions + +-------------------------------------------------------------------------------- +-- CustomCommandReq + +data CustomCommandReq = CustomCommandReq + { serviceName :: Text + } + deriving (Generic, Show) + +instance FromForm CustomCommandReq where + fromForm :: Form -> Either Text CustomCommandReq + fromForm = genericFromForm myFormOptions + +instance FromJSON CustomCommandReq where + parseJSON :: Value -> Parser CustomCommandReq + parseJSON = genericParseJSON myJSONOptions + +-------------------------------------------------------------------------------- +-- Eventlog Socket API + +-- 2025-12-11: +-- Ideally, the /heap-profiling API would attach the semantics of /start and +-- /stop to a PUT and DELETE request on /heap-profiling with 204 No Content +-- responses. This would give us exactly the right caching semantics. +-- However, I have not been able to find any Grafana plugins that support +-- sending PUT and DELETE requests, and servant appears to have trouble adding +-- headers to 204 No Content responses, so I'm using POST requests on separate +-- /start and /stop endpoints. + +type EventlogSocketApi = + "eventlog-socket" + :> ("start-profiling" :> (StartProfilingApi :<|> BadCORSPreflight) + :<|> "stop-profiling" :> (StopProfilingApi :<|> BadCORSPreflight) + :<|> "start-heap-profiling" :> (StartHeapProfilingApi :<|> BadCORSPreflight) + :<|> "stop-heap-profiling" :> (StopHeapProfilingApi :<|> BadCORSPreflight) + :<|> "request-heap-census" :> (RequestHeapCensusApi :<|> BadCORSPreflight) + ) + +type StartProfilingApi = + ReqBody '[FormUrlEncoded, JSON] StartProfilingReq + :> PostAccepted '[JSON] () + +type StopProfilingApi = + ReqBody '[FormUrlEncoded, JSON] StopProfilingReq + :> PostAccepted '[JSON] () + +type StartHeapProfilingApi = + ReqBody '[FormUrlEncoded, JSON] StartHeapProfilingReq + :> PostAccepted '[JSON] () + +type StopHeapProfilingApi = + ReqBody '[FormUrlEncoded, JSON] StopHeapProfilingReq + :> PostAccepted '[JSON] () + +type RequestHeapCensusApi = + ReqBody '[FormUrlEncoded, JSON] RequestHeapCensusReq + :> PostAccepted '[JSON] () + +type BadCORSPreflight = + UVerb 'OPTIONS '[PlainText] '[BadCORSPreflightAccept, BadCORSPreflightReject] + +type BadCORSPreflightAccept = WithStatus 204 (Headers + '[ Header "Access-Control-Allow-Origin" String + , Header "Access-Control-Allow-Methods" String + , Header "Access-Control-Allow-Headers" String + ] + NoContent) + +type BadCORSPreflightReject = WithStatus 400 NoContent + +-------------------------------------------------------------------------------- +-- StartProfilingReq + +newtype StartProfilingReq = StartProfilingReq + { serviceName :: Text + } + deriving (Generic, Show) + +instance FromForm StartProfilingReq where + fromForm :: Form -> Either Text StartProfilingReq + fromForm = genericFromForm myFormOptions + +instance FromJSON StartProfilingReq where + parseJSON :: Value -> Parser StartProfilingReq + parseJSON = genericParseJSON myJSONOptions + +-------------------------------------------------------------------------------- +-- StopProfilingReq + +newtype StopProfilingReq = StopProfilingReq + { serviceName :: Text + } + deriving (Generic, Show) + +instance FromForm StopProfilingReq where + fromForm :: Form -> Either Text StopProfilingReq + fromForm = genericFromForm myFormOptions + +instance FromJSON StopProfilingReq where + parseJSON :: Value -> Parser StopProfilingReq + parseJSON = genericParseJSON myJSONOptions + +-------------------------------------------------------------------------------- +-- StartHeapProfilingReq + +newtype StartHeapProfilingReq = StartHeapProfilingReq + { serviceName :: Text + } + deriving (Generic, Show) + +instance FromForm StartHeapProfilingReq where + fromForm :: Form -> Either Text StartHeapProfilingReq + fromForm = genericFromForm myFormOptions + +instance FromJSON StartHeapProfilingReq where + parseJSON :: Value -> Parser StartHeapProfilingReq + parseJSON = genericParseJSON myJSONOptions + +-------------------------------------------------------------------------------- +-- StopHeapProfilingReq + +newtype StopHeapProfilingReq = StopHeapProfilingReq + { serviceName :: Text + } + deriving (Generic, Show) + +instance FromForm StopHeapProfilingReq where + fromForm :: Form -> Either Text StopHeapProfilingReq + fromForm = genericFromForm myFormOptions + +instance FromJSON StopHeapProfilingReq where + parseJSON :: Value -> Parser StopHeapProfilingReq + parseJSON = genericParseJSON myJSONOptions + +-------------------------------------------------------------------------------- +-- RequestHeapCensusReq + +newtype RequestHeapCensusReq = RequestHeapCensusReq + { serviceName :: Text + } + deriving (Generic, Show) + +instance FromForm RequestHeapCensusReq where + fromForm :: Form -> Either Text RequestHeapCensusReq + fromForm = genericFromForm myFormOptions + +instance FromJSON RequestHeapCensusReq where + parseJSON :: Value -> Parser RequestHeapCensusReq + parseJSON = genericParseJSON myJSONOptions + +-------------------------------------------------------------------------------- +-- Internal helpers. + +-- | Generic options for `FromForm`. +myFormOptions :: FormOptions +myFormOptions = + Form.defaultFormOptions + { Form.fieldLabelModifier = camelTo2 '-' + } + +-- | Generic options for `FromJSON`. +myJSONOptions :: JSON.Options +myJSONOptions = + JSON.defaultOptions + { JSON.fieldLabelModifier = camelTo2 '-' + } + +-- | Taken from aeson. +camelTo2 :: Char -> String -> String +camelTo2 c = map toLower . go2 . go1 + where + go1 "" = "" + go1 (x : u : l : xs) | isUpper u && isLower l = x : c : u : l : go1 xs + go1 (x : xs) = x : go1 xs + go2 "" = "" + go2 (l : u : xs) | isLower l && isUpper u = l : c : u : go2 xs + go2 (x : xs) = x : go2 xs + +#endif + +-------------------------------------------------------------------------------- +-- Control Options +-------------------------------------------------------------------------------- + +data ControlOptions = ControlOptions + { controlEnabled :: !Bool + , controlPort :: !(Maybe ControlPort) + , controlCors :: !ControlCors + } + +{- | +Internal helper. + +If the user provides any of the control options, this implies @--control@. +-} +shouldStart :: ControlOptions -> Bool +shouldStart controlOptions = + controlOptions.controlEnabled + || isJust controlOptions.controlPort + || isJust controlOptions.controlCors.controlCorsAllowOrigin + || isJust controlOptions.controlCors.controlCorsMaxAgeS + || controlOptions.controlCors.controlCorsRequireOrigin + || controlOptions.controlCors.controlCorsIgnoreFailures + +controlOptionsParser :: O.Parser ControlOptions +controlOptionsParser = + OC.parserOptionGroup "Control Server Options" $ + ControlOptions + <$> controlEnabledParser + <*> controlPortParser + <*> controlCorsParser + +controlEnabledParser :: O.Parser Bool +controlEnabledParser = + OF.onlyFor control (O.flag False True) mempty $ + O.long "control" + <> OF.helpFor control "Start the control server." + +newtype ControlPort = ControlPort {port :: Int} + deriving (Eq, Show) + +controlPortParser :: O.Parser (Maybe ControlPort) +controlPortParser = + asum + [ OF.onlyFor control (O.option (Just . ControlPort <$> O.auto)) (O.metavar "PORT") $ + O.long "control-port" + <> OF.helpFor control "The port number for the control server." + , pure Nothing + ] + +data ControlCors = ControlCors + { controlCorsAllowOrigin :: !(Maybe ControlCorsAllowOrigin) + , controlCorsMaxAgeS :: !(Maybe Int) + , controlCorsRequireOrigin :: !Bool + , controlCorsIgnoreFailures :: !Bool + } + +controlCorsParser :: O.Parser ControlCors +controlCorsParser = + ControlCors + <$> controlCorsAllowOriginParser + <*> controlCorsMaxAgeSParser + <*> controlCorsRequireOriginParser + <*> controlCorsIgnoreFailuresParser + +controlCorsMaxAgeSParser :: O.Parser (Maybe Int) +controlCorsMaxAgeSParser = + asum + [ OF.onlyFor control (O.option (Just <$> O.auto)) (O.metavar "SECONDS") $ + O.long "control-cors-max-age" + <> OF.helpFor control "Set the maximum age of a cached CORS preflight request for the control server CORS policy." + , pure Nothing + ] + +controlCorsRequireOriginParser :: O.Parser Bool +controlCorsRequireOriginParser = + OF.onlyFor control (O.flag False True) mempty $ + O.long "control-cors-require-origin" + <> OF.helpFor control "If enabled, the control server will not accept requests without an Origin header." + +controlCorsIgnoreFailuresParser :: O.Parser Bool +controlCorsIgnoreFailuresParser = + OF.onlyFor control (O.flag False True) mempty $ + O.long "control-cors-ignore-failure" + <> OF.helpFor control "If enabled, the control server will accept malformed CORS preflight requests." + +type ControlCorsOrigin = BSC.ByteString + +data ControlCorsAllowOrigin + = ControlCorsAllowOriginWildcard + | ControlCorsAllowOriginList [ControlCorsOrigin] + +controlCorsAllowOriginParser :: O.Parser (Maybe ControlCorsAllowOrigin) +controlCorsAllowOriginParser = + asum + [ OF.onlyFor control (O.option (Just <$> readPReader pControlCorsAllowOrigin)) (O.metavar "ORIGIN") $ + O.long "control-cors-allow-origin" + <> OF.helpFor control "Set the allowed origins for the control server CORS policy." + , pure Nothing + ] + +readPReader :: ReadP a -> O.ReadM a +readPReader readP = readSReader (P.readP_to_S readP) + +readSReader :: ReadS a -> O.ReadM a +readSReader readS = O.maybeReader $ \str -> + case readS str of + [(a, "")] -> Just a + _otherwise -> Nothing + +pControlCorsAllowOrigin :: ReadP ControlCorsAllowOrigin +pControlCorsAllowOrigin = + P.skipSpaces + *> asum + [ -- Wildcard + ControlCorsAllowOriginWildcard <$ P.char '*' <* P.skipSpaces + , -- List of origins + ControlCorsAllowOriginList <$> P.sepBy1 pOrigin (P.char ',' <* P.skipSpaces) + ] + where + -- TODO: The parser for origin could parse the syntax for origins: + -- + -- Origin: null + -- Origin: :// + -- Origin: ://: + -- + pOrigin :: ReadP ControlCorsOrigin + pOrigin = BSC.pack <$> P.munch1 (\c -> not (c == ',' || isSpace c)) <* P.skipSpaces diff --git a/src-app/GHC/Eventlog/Live/Otlp/Environment.hs b/src-app/GHC/Eventlog/Live/Otlp/Environment.hs new file mode 100644 --- /dev/null +++ b/src-app/GHC/Eventlog/Live/Otlp/Environment.hs @@ -0,0 +1,598 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE QuasiQuotes #-} + +module GHC.Eventlog.Live.Otlp.Environment ( + -- * OpenTelemetry Exporter Options + lookupLogLevel, + ServiceName (..), + ResourceAttributes (..), + lookupResourceAttributes, + + -- ** OpenTelemetry Exporter Options + PerSignal (..), + Signal (..), + forSignal, + ExporterOptions (..), + lookupExporterOptions, + Protocol (..), + Endpoint (..), + defaultEndpointFor, + defaultPortFor, + Compression (..), + Timeout (..), + OtlpExporterOptions (..), +) where + +import Control.Monad (join, unless) +import Control.Monad.Trans.Class (MonadTrans (..)) +import Control.Monad.Trans.Except (ExceptT, throwE) +import Data.CaseInsensitive qualified as CI +import Data.Default (Default (..)) +import Data.Foldable (for_) +import Data.Hashable (Hashable) +import Data.List qualified as L +import Data.Maybe (catMaybes, fromMaybe) +import Data.Text (Text) +import Data.Text qualified as T +import Data.Text.Encoding qualified as TE +import Data.Traversable (for) +import Data.Word (Word16) +import GHC.Eventlog.Live.Data.Severity (Severity (..), fromSeverityString) +import GHC.Eventlog.Live.Logger (Logger, writeLog) +import GHC.IsList qualified as IsList +import GHC.Records (HasField (..)) +import Network.URI (URI (..), URIAuth (..)) +import Network.URI qualified as URI +import OpenTelemetry.Baggage (Baggage, decodeBaggageHeader) +import OpenTelemetry.Baggage qualified as Baggage +import System.Environment (lookupEnv) +import Text.Printf (printf) +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. + +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. +-} +newtype ExporterOptions = ExporterOptions'Otlp OtlpExporterOptions + deriving (Eq, Show) + +{- | +Lookup the OpenTelemetry OTLP 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 $ \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) + + let exporterOptions = + [tracesExporterOptions, metricsExporterOptions, logsExporterOptions, profilesExporterOptions] + pure $ + if allSame exporterOptions + then + Shared tracesExporterOptions + else + PerSignal + { forTRACES = tracesExporterOptions + , forMETRICS = metricsExporterOptions + , forLOGS = logsExporterOptions + , forPROFILES = profilesExporterOptions + } + +{- | +Lookup the OpenTelemetry Log Level from the environment. +-} +lookupLogLevel :: + ExceptT String IO Severity +lookupLogLevel = do + -- Lookup OTEL_LOG_LEVEL + let otelLogLevel = "OTEL_LOG_LEVEL" + fmap (fromMaybe INFO) + <$> traverse (readSeverity otelLogLevel) + =<< lift (lookupEnv otelLogLevel) + +{- | +OpenTelemetry Service Name. +-} +newtype ServiceName = ServiceName {serviceName :: Text} + deriving newtype (Eq, Hashable, Show) + +{- | +OpenTelemetry Resource Attributes. +-} +newtype ResourceAttributes = ResourceAttributes + { resourceAttributeBaggage :: Baggage + } + +{- | +Internal helper. + +The @service.name@ token. +-} +serviceNameToken :: Baggage.Token +serviceNameToken = [Baggage.token|service.name|] + +instance HasField "serviceName" ResourceAttributes (Maybe ServiceName) where + getField :: ResourceAttributes -> Maybe ServiceName + getField ResourceAttributes{..} = + ServiceName <$> Baggage.getValue serviceNameToken resourceAttributeBaggage + +instance HasField "attributes" ResourceAttributes [(Text, Text)] where + getField :: ResourceAttributes -> [(Text, Text)] + getField ResourceAttributes{..} = + [ (key, value) + | (token, Baggage.Element value _properties) <- + IsList.toList (Baggage.values resourceAttributeBaggage) + , let key = TE.decodeUtf8 (Baggage.tokenValue token) + ] + +{- | +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 -> + ExceptT String IO (Maybe ResourceAttributes) +lookupResourceAttributes logger = do + -- Lookup OTEL_SERVICE_NAME + let otelServiceName = "OTEL_SERVICE_NAME" + maybeServiceName <- + fmap (singletonBaggage serviceNameToken . T.pack) + <$> lift (lookupEnv otelServiceName) + + -- Lookup OTEL_RESOURCE_ATTRIBUTES + let otelResourceAttributes = "OTEL_RESOURCE_ATTRIBUTES" + maybeResourceAttributeBaggage <- + traverse (readBaggage logger otelResourceAttributes) + =<< lift (lookupEnv otelResourceAttributes) + + pure $ fmap ResourceAttributes (maybeServiceName <> maybeResourceAttributeBaggage) + +{- | +Internal helper. + +Convert a `Text` value to singleton `Baggage`. +-} +singletonBaggage :: Baggage.Token -> Text -> Baggage +singletonBaggage token value = Baggage.insert token (Baggage.element value) Baggage.empty + +-------------------------------------------------------------------------------- +-- OpenTelemetry Exporter Options +-------------------------------------------------------------------------------- + +{- | +OTLP protocol. +-} +data Protocol = Grpc | HttpProtobuf + deriving (Eq, Show) + +instance Default Protocol where + def :: Protocol + def = HttpProtobuf + +{- | +OTLP endpoint. +-} +data Endpoint = Endpoint + { host :: !String + , port :: !(Maybe Word16) + , path :: !String + , secure :: !Bool + } + deriving (Eq) + +toURI :: Endpoint -> URI +toURI endpoint = + URI.rectify $ + URI.nullURI + { uriScheme = if endpoint.secure then "https" else "http" + , uriAuthority = Just URI.nullURIAuth{uriRegName = endpoint.host, uriPort = maybe "" show endpoint.port} + , uriPath = endpoint.path + } + +instance Show Endpoint where + showsPrec :: Int -> Endpoint -> ShowS + showsPrec p = showsPrec p . toURI + +{- | +The default endpoint for each protocol. + +See: https://opentelemetry.io/docs/specs/otel/protocol/exporter/#configuration-options +-} +defaultEndpointFor :: Protocol -> Endpoint +defaultEndpointFor protocol = + Endpoint{host = "localhost", port = Just $ defaultPortFor protocol, path = "", secure = False} + +{- | +The default port for each protocol. +-} +defaultPortFor :: Protocol -> Word16 +defaultPortFor = \case Grpc -> 4317; HttpProtobuf -> 4318 + +{- | +OTLP compression. +-} +data Compression = GZip + deriving (Eq, Show) + +{- | +OTLP timeout. + +The value is specified in milliseconds. +The value @0@ should be interpreted as "no timeout". +-} +newtype Timeout = Timeout {timeoutMillis :: Word} + deriving (Eq, Show) + +instance Default Timeout where + def :: Timeout + def = Timeout 10_000 + +{- | +OpenTelemetry OTLP Exporter options. +-} +data OtlpExporterOptions = OtlpExporterOptions + { protocol :: !Protocol + , endpoint :: !Endpoint + , maybeCertificate :: !(Maybe String) + , maybeClientKey :: !(Maybe String) + , maybeClientCertificate :: !(Maybe String) + , maybeHeaders :: !(Maybe Baggage) + , maybeCompression :: !(Maybe Compression) + , timeout :: !Timeout + } + deriving (Eq, Show) + +{- | +Lookup the OpenTelemetry OTLP Exporter options from the environment. + +See: https://opentelemetry.io/docs/specs/otel/protocol/exporter +-} +lookupOtlpExporterOptions :: + Logger IO -> + Maybe Signal -> + ExceptT String IO OtlpExporterOptions +lookupOtlpExporterOptions logger signal = do + maybeProtocol <- lookupOtlpExporterOption logger signal PROTOCOL readProtocol + let !protocol = fromMaybe HttpProtobuf maybeProtocol + -- 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) + 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 + let timeout = fromMaybe def maybeTimeout + pure OtlpExporterOptions{..} + +{- | +Internal helper. + +The exporter options supported by OTLP. +-} +data OtlpExporterOption + = PROTOCOL + | ENDPOINT + | INSECURE + | CERTIFICATE + | CLIENT_KEY + | CLIENT_CERTIFICATE + | HEADERS + | COMPRESSION + | TIMEOUT + deriving (Show) + +{- | +Internal helper. + +Render an exporter option name as a string. + +>>> exporterOptionName Nothing ENDPOINT == "OTEL_EXPORTER_OTLP_ENDPOINT" +>>> exporterOptionName (Just TRACES) ENDPOINT == "OTEL_EXPORTER_OTLP_TRACES_ENDPOINT" +>>> exporterOptionName (Just METRICS) ENDPOINT == "OTEL_EXPORTER_OTLP_METRICS_ENDPOINT" +>>> exporterOptionName (Just LOGS) ENDPOINT == "OTEL_EXPORTER_OTLP_LOGS_ENDPOINT" +-} +exporterOptionName :: Maybe Signal -> OtlpExporterOption -> String +exporterOptionName signal option = + L.intercalate "_" . catMaybes $ + [Just "OTEL_EXPORTER_OTLP", show <$> signal, Just (show option)] + +{- | +Internal helper. + +Look up an exporter option, cascading from signal-specific for generic options. +-} +lookupOtlpExporterOption :: + Logger IO -> + Maybe Signal -> + OtlpExporterOption -> + (Logger IO -> String -> String -> ExceptT e IO a) -> + ExceptT e IO (Maybe a) +lookupOtlpExporterOption logger maybeSignal option parser = + -- Look up the exporter option for the specified signal, if any. + case maybeSignal of + Nothing -> + lookupOtlpExporterOptionOnlyFor Nothing + Just signal -> + lookupOtlpExporterOptionOnlyFor (Just signal) + >>= maybe (lookupOtlpExporterOptionOnlyFor Nothing) (pure . Just) + where + -- Look up the exporter option /only/ for the specified signal. + lookupOtlpExporterOptionOnlyFor maybeSignal' = + let optionName = exporterOptionName maybeSignal' option + in lift (lookupEnv optionName) >>= traverse (parser logger optionName) + +{- | +Internal helper. + +Parse a protocol. +-} +readProtocol :: (Monad m) => Logger m -> String -> String -> ExceptT String m Protocol +readProtocol _logger optionName protocol + | CI.mk protocol == "grpc" = pure Grpc + | CI.mk protocol == "http/protobuf" = pure HttpProtobuf + | CI.mk protocol == "http/json" = + throwE $ + "Environment variable " <> optionName <> " specifies unsupported protocol 'http/json'." + | otherwise = + throwE $ + "Environment variable " <> optionName <> " specifies unknown protocol '" <> protocol <> "'." + +{- | +Internal helper. + +Parse a boolean. + +See: https://opentelemetry.io/docs/specs/otel/configuration/sdk-environment-variables/#boolean +-} +readBoolean :: (Monad m) => Logger m -> String -> String -> ExceptT String m Bool +readBoolean logger optionName boolean + | CI.mk boolean == "true" = pure True + | CI.mk boolean == "false" = pure False + | otherwise = do + lift . writeLog logger WARN . T.pack $ + "Environment variable " <> optionName <> " has non-boolean value '" <> boolean <> "'. Use 'true' or 'false'." + pure False + +{- | +Internal helper. + +Parse a string. +-} +readString :: (Monad m) => Logger m -> String -> String -> ExceptT String m String +readString _logger _optionName = pure + +{- | +Internal helper. + +Show an URI. +-} +showURI :: URI -> String +showURI URI{..} = + printf + "URI {uriScheme = \"%s\", uriAuthority = %s, uriPath = \"%s\", uriQuery = \"%s\", uriFragment = \"%s\"}" + uriScheme + (show uriAuthority) + uriPath + uriQuery + uriFragment + +{- | +Internal helper. + +Parse an endpoint. + +@`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 + where + go retry endpoint = do + let maybeURI = URI.parseAbsoluteURI endpoint + for_ maybeURI $ \uri -> + lift . writeLog logger TRACE . T.pack $ + "Environment variable " <> optionName <> " specifies URI: " <> showURI uri + case maybeURI of + Nothing + | retry -> do + if maybeInsecure == Just False + then go False ("https://" <> endpoint) + else go False ("http://" <> endpoint) + | otherwise -> + throwE $ "Environment variable " <> optionName <> " specifies malformed URI '" <> endpoint <> "'." + Just URI{uriAuthority = Nothing} -> do + throwE $ "Environment variable " <> optionName <> " specifies URI without autority '" <> endpoint <> "'." + Just URI{uriScheme} + | uriScheme `notElem` ["http:", "https:"] -> + throwE $ "Environment variable " <> optionName <> " specifies URI with unsupported scheme '" <> endpoint <> "'. Use 'http' or 'https'." + Just URI{uriAuthority = Just URIAuth{..}, ..} -> do + unless (null uriUserInfo) $ + lift . writeLog logger WARN . T.pack $ + "Environment variable " <> optionName <> " specifies URI with user info '" <> uriUserInfo <> "'." + unless (null uriQuery) $ + lift . writeLog logger WARN . T.pack $ + "Environment variable " <> optionName <> " specifies URI with query '" <> uriQuery <> "'." + unless (null uriFragment) $ + lift . writeLog logger WARN . T.pack $ + "Environment variable " <> optionName <> " specifies URI with fragment '" <> uriFragment <> "'." + pure + Endpoint + { host = uriRegName + , port = readMaybe @Word16 (dropColon uriPort) + , path = uriPath + , secure = uriScheme == "https:" + } + + dropColon :: String -> String + dropColon = \case (':' : str) -> str; str -> str + +{- | +Internal helper. + +Parse headers in the baggage format. +-} +readBaggage :: (Monad m) => Logger m -> String -> String -> ExceptT String m Baggage +readBaggage _logger optionName baggage = + either onErr pure . decodeBaggageHeader . TE.encodeUtf8 . T.pack $ baggage + where + onErr e = + throwE $ printf "Environment variable %s specifies malformed baggage '%s': %s" optionName baggage e + +{- | +Internal helper. + +Parse compression. +-} +readCompression :: (Monad m) => Logger m -> String -> String -> ExceptT String m (Maybe Compression) +readCompression _logger optionName compression + | CI.mk compression == "none" = pure Nothing + | CI.mk compression == "gzip" = pure (Just GZip) + | otherwise = + throwE $ + "Environment variable " <> optionName <> " specifies unknown compression '" <> compression <> "'. Use 'none' or 'gzip'." + +{- | +Internal helper. + +Parse a timeout. +-} +readTimeout :: (Monad m) => Logger m -> String -> String -> ExceptT String m Timeout +readTimeout logger optionName timeout + | Just timeoutMillis <- readMaybe @Word timeout = + pure (Timeout timeoutMillis) + | otherwise = do + lift . writeLog logger WARN . T.pack $ + "Environment variable " <> optionName <> " specifies malformed timeout '" <> timeout <> "'." + pure def + +{- | +Internal helper. + +Parse a log level. + +See: https://opentelemetry.io/docs/specs/otel/logs/data-model/#field-severitytext +-} +readSeverity :: (Monad m) => String -> String -> ExceptT String m Severity +readSeverity optionName logLevel + | Just severity <- fromSeverityString logLevel = pure severity + | otherwise = + throwE $ + "Environment variable " <> optionName <> " specifies malformed log level '" <> logLevel <> "'." + +{- | +Internal helper. + +Parse an exporter type. +-} +readExporterType :: (Monad m) => Logger m -> String -> String -> ExceptT String m (Maybe ExporterType) +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"] = + throwE $ + "Environment variable " <> optionName <> " specifies unsupported exporter '" <> exporterType <> "'." + | otherwise = + throwE $ + "Environment variable " <> optionName <> " specifies unknown exporter '" <> exporterType <> "'." + +{- | +Internal helper. + +Check if all elements are the same. +-} +allSame :: (Eq a) => [a] -> Bool +allSame [] = True +allSame (x : xs) = all (== x) xs diff --git a/src-app/GHC/Eventlog/Live/Otlp/Exporter/Core.hs b/src-app/GHC/Eventlog/Live/Otlp/Exporter/Core.hs new file mode 100644 --- /dev/null +++ b/src-app/GHC/Eventlog/Live/Otlp/Exporter/Core.hs @@ -0,0 +1,295 @@ +{-# LANGUAGE AllowAmbiguousTypes #-} +{-# LANGUAGE OverloadedStrings #-} + +module GHC.Eventlog.Live.Otlp.Exporter.Core ( + Exporter (..), + withExporter, + withExporters, + export, + + -- * Export via gRPC + CanExportViaGrpc, + + -- * Export via HTTP/Protobuf + CanExportViaHttpProtobuf (..), + HttpError (..), +) where + +import Control.Exception (Exception (..), throwIO) +import Data.ByteString (ByteString) +import Data.ByteString qualified as BS +import Data.ByteString.Char8 qualified as BSC +import Data.ByteString.Lazy qualified as BSL +import Data.CaseInsensitive qualified as CI +import Data.Maybe (fromMaybe) +import Data.ProtoLens.Encoding qualified as Proto +import Data.ProtoLens.Message (Message (defMessage)) +import Data.ProtoLens.Service.Types (HasMethodImpl (..)) +import Data.Text qualified as T +import Data.Text.Encoding qualified as TE +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.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.Protobuf (Protobuf, StreamingType (..)) +import Network.GRPC.Common.Protobuf qualified as G +import Network.GRPC.Common.StreamType qualified as G +import Network.HTTP.Client qualified as H +import Network.HTTP.Client.TLS qualified as H +import Network.HTTP.Types.Header qualified as HTTP +import Network.HTTP.Types.Status qualified as HTTP +import OpenTelemetry.Baggage qualified as Baggage + +-------------------------------------------------------------------------------- +-- OTLP Exporter +-------------------------------------------------------------------------------- + +data Exporter + = Exporter'OtlpGrpc !OtlpGrpcExporter + | Exporter'OtlpHttpProtobuf !OtlpHttpProtobufExporter + +{- | +Construct one shared t`OtlpExporter` or one t`OtlpExporter` per signal. +-} +withExporters :: + Logger IO -> + PerSignal (Maybe ExporterOptions) -> + (PerSignal (Maybe Exporter) -> IO a) -> + IO a +withExporters logger (Shared maybeOptions) action = + withMaybeExporter logger maybeOptions $ action . Shared +withExporters logger PerSignal{..} action = + withMaybeExporter logger forTRACES $ \exporterForTRACES -> + withMaybeExporter logger forMETRICS $ \exporterForMETRICS -> + withMaybeExporter logger forLOGS $ \exporterForLOGS -> + withMaybeExporter logger forPROFILES $ \exporterForPROFILES -> + action $ PerSignal exporterForTRACES exporterForMETRICS exporterForLOGS exporterForPROFILES + +{- | +Construct a @Maybe t`Exporter`@ from @Maybe t`OtlpExporterOptions`@. +-} +withMaybeExporter :: + Logger IO -> + Maybe ExporterOptions -> + (Maybe Exporter -> IO a) -> + IO a +withMaybeExporter logger maybeOptions action = + case maybeOptions of + Nothing -> + action Nothing + Just options -> + withExporter logger options $ action . Just + +{- | +Construct an t`Exporter` from t`ExporterOptions`. +-} +withExporter :: + Logger IO -> + 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 + +{- | +Export telemetry data to the t`OtlpExporter`. +-} +export :: + forall serv meth. + ( CanExportViaGrpc serv meth + , CanExportViaHttpProtobuf serv meth + ) => + Logger IO -> + -- | The HTTP/Protobuf exporter. + Exporter -> + -- | The request message. + MethodInput serv meth -> + IO (MethodOutput serv meth) +export logger = \case + Exporter'OtlpGrpc exporter -> + exportGrpc @serv @meth logger exporter + Exporter'OtlpHttpProtobuf exporter -> + exportHttpProtobuf @serv @meth logger exporter + +-------------------------------------------------------------------------------- +-- OTLP gRPC Exporter +-------------------------------------------------------------------------------- + +{- | +An opaque OTLP gRPC exporter. +-} +newtype OtlpGrpcExporter = OtlpGrpcExporter + { connection :: G.Connection + } + +type CanExportViaGrpc serv meth = + ( G.SupportsClientRpc (Protobuf serv meth) + , G.SupportsStreamingType (Protobuf serv meth) 'NonStreaming + , G.RequestMetadata (Protobuf serv meth) ~ G.NoMetadata + ) + +withOtlpGrpcExporter :: + Logger IO -> + 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{..} + 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 + 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) => + 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) + +-------------------------------------------------------------------------------- +-- OTLP HTTP/Protobuf Exporter +-------------------------------------------------------------------------------- + +{- | +The options for an OTLP HTTP/Protobuf endpoint. +-} +newtype OtlpHttpEndpoint = OtlpHttpEndpoint + { baseUrl :: String + } + deriving (Show) + +data OtlpHttpProtobufExporter = OtlpHttpProtobufExporter + { manager :: H.Manager + , baseUrl :: String + , headers :: HTTP.RequestHeaders + } + +data HttpError + = HttpStatusError + { statusCode :: Int + , statusMessage :: ByteString + , responseBody :: ByteString + } + | HttpDecodeError + { errorMessage :: String + } + deriving (Show) + +instance Exception HttpError where + displayException :: HttpError -> String + displayException = \case + HttpStatusError{..} -> + "OTLP HTTP/Protobuf Exporter - HTTP Response: " + <> show statusCode + <> " " + <> BSC.unpack statusMessage + <> " with body: " + <> BSC.unpack responseBody + HttpDecodeError{..} -> + "OTLP HTTP/Protobuf Exporter - Malformed HTTP Response: " + <> errorMessage + +{- | +Internal helper. + +Run an action with an t`OtlpHttpProtobufExporter`. +-} +withOtlpHttpProtobufExporter :: + Logger IO -> + 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 an HTTP manager. + manager <- H.newManager H.tlsManagerSettings + -- Create the HTTP headers. + writeLog logger TRACE . T.pack $ + "OTLP HTTP/Protobuf Exporter - Headers: " <> show options.maybeHeaders + let headers = + [ (CI.mk (Baggage.tokenValue token), TE.encodeUtf8 value) + | (token, Baggage.Element value _properties) <- + IsList.toList (maybe mempty Baggage.values options.maybeHeaders) + ] + -- Run the action. + action OtlpHttpProtobufExporter{baseUrl = show options.endpoint, ..} + +class + ( Message (MethodInput serv meth) + , Message (MethodOutput serv meth) + ) => + CanExportViaHttpProtobuf serv meth + where + apiPath :: String + +{- | +Send a Protobuf message over an HTTP connection. +-} +exportHttpProtobuf :: + forall serv meth. + (CanExportViaHttpProtobuf serv meth) => + Logger IO -> + -- | The HTTP/Protobuf exporter. + OtlpHttpProtobufExporter -> + -- | The request message. + MethodInput serv meth -> + IO (MethodOutput serv meth) +exportHttpProtobuf logger OtlpHttpProtobufExporter{..} req = do + baseRequest <- H.parseRequest (baseUrl <> apiPath @serv @meth) + let request = + baseRequest + { H.method = "POST" + , H.requestBody = H.RequestBodyBS (Proto.encodeMessage req) + , H.checkResponse = \_ _ -> pure () + , H.requestHeaders = + [ (HTTP.hContentType, "application/x-protobuf") + , (HTTP.hAccept, "application/x-protobuf") + ] + <> headers + } + writeLog logger TRACE . T.pack $ "HTTP/Protobuf Exporter - HTTP Request: " <> show request + response <- H.httpLbs request manager + writeLog logger TRACE . T.pack $ "HTTP/Protobuf Exporter - HTTP Response: " <> show response + let status = H.responseStatus response + let body = BSL.toStrict (H.responseBody response) + if HTTP.statusIsSuccessful status + then decodeResponseBody body + else + throwIO + HttpStatusError + { statusCode = HTTP.statusCode status + , statusMessage = HTTP.statusMessage status + , responseBody = body + } + +{- | +Internal helper. + +Decode the HTTP response body into a Protobuf message. +-} +decodeResponseBody :: (Message msg) => ByteString -> IO msg +decodeResponseBody body + | BS.null body = pure defMessage + | otherwise = + case Proto.decodeMessage body of + Left errorMessage -> throwIO HttpDecodeError{..} + Right msg -> pure msg diff --git a/src-app/GHC/Eventlog/Live/Otlp/Exporter/Logs.hs b/src-app/GHC/Eventlog/Live/Otlp/Exporter/Logs.hs new file mode 100644 --- /dev/null +++ b/src-app/GHC/Eventlog/Live/Otlp/Exporter/Logs.hs @@ -0,0 +1,147 @@ +{-# OPTIONS_GHC -Wno-orphans #-} + +module GHC.Eventlog.Live.Otlp.Exporter.Logs ( + -- * Logs + ExportLogsResult (..), + RejectedLogsError (..), + exportResourceLogs, +) where + +import Control.Exception (Exception (..), SomeException (..), catch) +import Control.Monad (unless) +import Control.Monad.IO.Class (MonadIO (..)) +import Data.Int (Int64) +import Data.Machine (ProcessT, await, construct, yield) +import Data.Semigroup (Sum (..)) +import Data.Text (Text) +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 Lens.Family2 ((^.)) +import Network.GRPC.Common qualified as G +import Network.GRPC.Common.Protobuf (Protobuf) +import Proto.Opentelemetry.Proto.Collector.Logs.V1.LogsService qualified as OLS +import Proto.Opentelemetry.Proto.Collector.Logs.V1.LogsService_Fields qualified as OLS +import Proto.Opentelemetry.Proto.Logs.V1.Logs qualified as OL +import Proto.Opentelemetry.Proto.Logs.V1.Logs_Fields qualified as OL +import Text.Printf (printf) + +-------------------------------------------------------------------------------- +-- OpenTelemetry gRPC Exporters +-------------------------------------------------------------------------------- + +-------------------------------------------------------------------------------- +-- OpenTelemetry Exporter Result for Logs + +data ExportLogsResult + = ExportLogsResult + { exportedLogRecords :: !Int64 + , rejectedLogRecords :: !Int64 + , maybeSomeException :: Maybe SomeException + } + deriving (Show) + +pattern ExportLogsSuccess :: Int64 -> ExportLogsResult +pattern ExportLogsSuccess exportedLogRecords = + ExportLogsResult exportedLogRecords 0 Nothing + +pattern ExportLogsError :: Int64 -> Int64 -> SomeException -> ExportLogsResult +pattern ExportLogsError exportedLogRecords rejectedLogRecords someException = + ExportLogsResult exportedLogRecords rejectedLogRecords (Just someException) + +data RejectedLogsError + = RejectedLogsError + { rejectedLogRecords :: !Int64 + , errorMessage :: !Text + } + deriving (Show) + +instance Exception RejectedLogsError where + displayException :: RejectedLogsError -> String + displayException RejectedLogsError{..} = + printf "Error: OpenTelemetry Collector rejected %d log records with message: %s" rejectedLogRecords errorMessage + +-------------------------------------------------------------------------------- +-- OpenTelemetry gRPC Exporter for Logs + +exportResourceLogs :: + Logger IO -> + Exporter -> + ProcessT IO (Tick OLS.ExportLogsServiceRequest) (Tick ExportLogsResult) +exportResourceLogs logger exporter = construct $ go False + where + go exportedResourceLogs = + await >>= \case + Tick -> do + unless exportedResourceLogs $ + yield (Item $ ExportLogsSuccess 0) + yield Tick + go False + Item exportLogsServiceRequest -> do + exportLogsResult <- liftIO (sendResourceLogs exportLogsServiceRequest) + yield (Item exportLogsResult) + go True + + sendResourceLogs :: OLS.ExportLogsServiceRequest -> IO ExportLogsResult + sendResourceLogs exportLogsServiceRequest = + doExport `catch` handleSomeException + where + !exportedLogRecords = countLogRecordsInExportLogsServiceRequest exportLogsServiceRequest + + doExport :: IO ExportLogsResult + doExport = do + resp <- export @OLS.LogsService @"export" logger exporter exportLogsServiceRequest + if resp ^. OLS.partialSuccess . OLS.rejectedLogRecords == 0 + then + pure $ ExportLogsSuccess exportedLogRecords + else do + let !rejectedLogRecords = resp ^. OLS.partialSuccess . OLS.rejectedLogRecords + let !rejectedLogsError = RejectedLogsError{errorMessage = resp ^. OLS.partialSuccess . OLS.errorMessage, ..} + pure $ ExportLogsError exportedLogRecords rejectedLogRecords (SomeException rejectedLogsError) + + handleSomeException :: SomeException -> IO ExportLogsResult + handleSomeException someException = pure $ ExportLogsError 0 exportedLogRecords someException + +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 + apiPath :: String + apiPath = "/v1/logs" + +-------------------------------------------------------------------------------- +-- Internal Helpers +-------------------------------------------------------------------------------- + +{- | +Internal helper. +Count the number of `OL.NumberDataPoint` values in an `OLS.ExportLogsServiceRequest`. +-} +{-# SPECIALIZE countLogRecordsInExportLogsServiceRequest :: OLS.ExportLogsServiceRequest -> Int64 #-} +{-# SPECIALIZE countLogRecordsInExportLogsServiceRequest :: OLS.ExportLogsServiceRequest -> Word #-} +countLogRecordsInExportLogsServiceRequest :: (Integral i) => OLS.ExportLogsServiceRequest -> i +countLogRecordsInExportLogsServiceRequest exportLogsServiceRequest = + getSum $ foldMap (Sum . countLogRecordsInResourceLogs) (exportLogsServiceRequest ^. OLS.vec'resourceLogs) + +{- | +Internal helper. +Count the number of `OL.NumberDataPoint` values in an `OL.ResourceLogs`. +-} +{-# SPECIALIZE countLogRecordsInResourceLogs :: OL.ResourceLogs -> Int64 #-} +{-# SPECIALIZE countLogRecordsInResourceLogs :: OL.ResourceLogs -> Word #-} +countLogRecordsInResourceLogs :: (Integral i) => OL.ResourceLogs -> i +countLogRecordsInResourceLogs resourceLogs = + getSum $ foldMap (Sum . countLogRecordsInScopeLogs) (resourceLogs ^. OL.vec'scopeLogs) + +{- | +Internal helper. +Count the number of `OL.NumberDataPoint` values in an `OL.ScopeLogs`. +-} +{-# SPECIALIZE countLogRecordsInScopeLogs :: OL.ScopeLogs -> Int64 #-} +{-# SPECIALIZE countLogRecordsInScopeLogs :: OL.ScopeLogs -> Word #-} +countLogRecordsInScopeLogs :: (Integral i) => OL.ScopeLogs -> i +countLogRecordsInScopeLogs scopeLogs = + fromIntegral $ + V.length (scopeLogs ^. OL.vec'logRecords) diff --git a/src-app/GHC/Eventlog/Live/Otlp/Exporter/Metrics.hs b/src-app/GHC/Eventlog/Live/Otlp/Exporter/Metrics.hs new file mode 100644 --- /dev/null +++ b/src-app/GHC/Eventlog/Live/Otlp/Exporter/Metrics.hs @@ -0,0 +1,168 @@ +{-# OPTIONS_GHC -Wno-orphans #-} + +module GHC.Eventlog.Live.Otlp.Exporter.Metrics ( + -- * Metrics + ExportMetricsResult (..), + RejectedMetricsError (..), + exportResourceMetrics, +) where + +import Control.Exception (Exception (..), SomeException (..), catch) +import Control.Monad (unless) +import Control.Monad.IO.Class (MonadIO (..)) +import Data.Int (Int64) +import Data.Machine (ProcessT, await, construct, yield) +import Data.Semigroup (Sum (..)) +import Data.Text (Text) +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 Lens.Family2 ((^.)) +import Network.GRPC.Common qualified as G +import Network.GRPC.Common.Protobuf (Protobuf) +import Proto.Opentelemetry.Proto.Collector.Metrics.V1.MetricsService qualified as OMS +import Proto.Opentelemetry.Proto.Collector.Metrics.V1.MetricsService_Fields qualified as OMS +import Proto.Opentelemetry.Proto.Metrics.V1.Metrics qualified as OM +import Proto.Opentelemetry.Proto.Metrics.V1.Metrics_Fields qualified as OM +import Text.Printf (printf) + +-------------------------------------------------------------------------------- +-- OpenTelemetry gRPC Exporters +-------------------------------------------------------------------------------- + +-------------------------------------------------------------------------------- +-- OpenTelemetry Exporter Result for Metrics + +data ExportMetricsResult + = ExportMetricsResult + { exportedDataPoints :: !Int64 + , rejectedDataPoints :: !Int64 + , maybeSomeException :: Maybe SomeException + } + deriving (Show) + +pattern ExportMetricsSuccess :: Int64 -> ExportMetricsResult +pattern ExportMetricsSuccess exportedDataPoints = + ExportMetricsResult exportedDataPoints 0 Nothing + +pattern ExportMetricsError :: Int64 -> Int64 -> SomeException -> ExportMetricsResult +pattern ExportMetricsError exportedDataPoints rejectedDataPoints someException = + ExportMetricsResult exportedDataPoints rejectedDataPoints (Just someException) + +data RejectedMetricsError + = RejectedMetricsError + { rejectedDataPoints :: !Int64 + , errorMessage :: !Text + } + deriving (Show) + +instance Exception RejectedMetricsError where + displayException :: RejectedMetricsError -> String + displayException RejectedMetricsError{..} = + printf "Error: OpenTelemetry Collector rejected %d data points with message: %s" rejectedDataPoints errorMessage + +-------------------------------------------------------------------------------- +-- OpenTelemetry gRPC Exporter for Metrics + +exportResourceMetrics :: + Logger IO -> + Exporter -> + ProcessT IO (Tick OMS.ExportMetricsServiceRequest) (Tick ExportMetricsResult) +exportResourceMetrics logger exporter = construct $ go False + where + go exportedResourceMetrics = + await >>= \case + Tick -> do + unless exportedResourceMetrics $ + yield (Item $ ExportMetricsSuccess 0) + yield Tick + go False + Item exportMetricsServiceRequest -> do + exportMetricsResult <- liftIO (sendResourceMetrics exportMetricsServiceRequest) + yield (Item exportMetricsResult) + go True + + sendResourceMetrics :: OMS.ExportMetricsServiceRequest -> IO ExportMetricsResult + sendResourceMetrics exportMetricsServiceRequest = + doExport `catch` handleSomeException + where + !exportedDataPoints = countDataPointsInExportMetricsServiceRequest exportMetricsServiceRequest + + doExport :: IO ExportMetricsResult + doExport = do + resp <- export @OMS.MetricsService @"export" logger exporter exportMetricsServiceRequest + if resp ^. OMS.partialSuccess . OMS.rejectedDataPoints == 0 + then + pure $ ExportMetricsSuccess exportedDataPoints + else do + let !rejectedDataPoints = resp ^. OMS.partialSuccess . OMS.rejectedDataPoints + let !rejectedMetricsError = RejectedMetricsError{errorMessage = resp ^. OMS.partialSuccess . OMS.errorMessage, ..} + pure $ ExportMetricsError exportedDataPoints rejectedDataPoints (SomeException rejectedMetricsError) + + handleSomeException :: SomeException -> IO ExportMetricsResult + handleSomeException someException = pure $ ExportMetricsError 0 exportedDataPoints someException + +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 + apiPath :: String + apiPath = "/v1/metrics" + +-------------------------------------------------------------------------------- +-- Internal Helpers +-------------------------------------------------------------------------------- + +{- | +Internal helper. +Count the number of `OM.NumberDataPoint` values in an `OMS.ExportMetricsServiceRequest`. +-} +{-# SPECIALIZE countDataPointsInExportMetricsServiceRequest :: OMS.ExportMetricsServiceRequest -> Int64 #-} +{-# SPECIALIZE countDataPointsInExportMetricsServiceRequest :: OMS.ExportMetricsServiceRequest -> Word #-} +countDataPointsInExportMetricsServiceRequest :: (Integral i) => OMS.ExportMetricsServiceRequest -> i +countDataPointsInExportMetricsServiceRequest exportMetricsServiceRequest = + getSum $ foldMap (Sum . countDataPointsInResourceMetrics) (exportMetricsServiceRequest ^. OMS.vec'resourceMetrics) + +{- | +Internal helper. +Count the number of `OM.NumberDataPoint` values in an `OM.ResourceMetrics`. +-} +{-# SPECIALIZE countDataPointsInResourceMetrics :: OM.ResourceMetrics -> Int64 #-} +{-# SPECIALIZE countDataPointsInResourceMetrics :: OM.ResourceMetrics -> Word #-} +countDataPointsInResourceMetrics :: (Integral i) => OM.ResourceMetrics -> i +countDataPointsInResourceMetrics resourceMetrics = + getSum $ foldMap (Sum . countDataPointsInScopeMetrics) (resourceMetrics ^. OM.vec'scopeMetrics) + +{- | +Internal helper. +Count the number of `OM.NumberDataPoint` values in an `OM.ScopeMetrics`. +-} +{-# SPECIALIZE countDataPointsInScopeMetrics :: OM.ScopeMetrics -> Int64 #-} +{-# SPECIALIZE countDataPointsInScopeMetrics :: OM.ScopeMetrics -> Word #-} +countDataPointsInScopeMetrics :: (Integral i) => OM.ScopeMetrics -> i +countDataPointsInScopeMetrics scopeMetrics = + getSum $ foldMap (Sum . countDataPointsInMetric) (scopeMetrics ^. OM.vec'metrics) + +{- | +Internal helper. +Count the number of `OM.NumberDataPoint` values in an `OM.Metric`. +-} +{-# SPECIALIZE countDataPointsInMetric :: OM.Metric -> Int64 #-} +{-# SPECIALIZE countDataPointsInMetric :: OM.Metric -> Word #-} +countDataPointsInMetric :: (Integral i) => OM.Metric -> i +countDataPointsInMetric metric = + fromIntegral $ + case metric ^. OM.maybe'data' of + Nothing -> 0 + Just (OM.Metric'Gauge gauge) -> + V.length (gauge ^. OM.vec'dataPoints) + Just (OM.Metric'Sum sum_) -> + V.length (sum_ ^. OM.vec'dataPoints) + Just (OM.Metric'Histogram histogram) -> + V.length (histogram ^. OM.vec'dataPoints) + Just (OM.Metric'ExponentialHistogram exponentialHistogram) -> + V.length (exponentialHistogram ^. OM.vec'dataPoints) + Just (OM.Metric'Summary summary) -> + V.length (summary ^. OM.vec'dataPoints) diff --git a/src-app/GHC/Eventlog/Live/Otlp/Exporter/Profiles.hs b/src-app/GHC/Eventlog/Live/Otlp/Exporter/Profiles.hs new file mode 100644 --- /dev/null +++ b/src-app/GHC/Eventlog/Live/Otlp/Exporter/Profiles.hs @@ -0,0 +1,130 @@ +{-# OPTIONS_GHC -Wno-orphans #-} + +module GHC.Eventlog.Live.Otlp.Exporter.Profiles ( + -- * Profiles + ExportProfileResult (..), + RejectedProfilesError (..), + exportResourceProfiles, +) +where + +import Control.Exception (Exception (..), SomeException (..), catch) +import Control.Monad (unless) +import Control.Monad.IO.Class (MonadIO (..)) +import Data.Int (Int64) +import Data.Machine (ProcessT, await, construct, yield) +import Data.Semigroup (Sum (..)) +import Data.Text (Text) +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 Lens.Family2 ((^.)) +import Network.GRPC.Common qualified as G +import Network.GRPC.Common.Protobuf (Protobuf) +import Proto.Opentelemetry.Proto.Collector.Profiles.V1development.ProfilesService qualified as OPS +import Proto.Opentelemetry.Proto.Collector.Profiles.V1development.ProfilesService_Fields qualified as OPS +import Proto.Opentelemetry.Proto.Profiles.V1development.Profiles qualified as OP +import Proto.Opentelemetry.Proto.Profiles.V1development.Profiles_Fields qualified as OP +import Text.Printf (printf) + +data ExportProfileResult + = ExportProfileResult + { exportedProfiles :: !Int64 + , rejectedProfiles :: !Int64 + , maybeSomeException :: Maybe SomeException + } + deriving (Show) + +pattern ExportProfileSuccess :: Int64 -> ExportProfileResult +pattern ExportProfileSuccess exportedProfiles = + ExportProfileResult exportedProfiles 0 Nothing + +pattern ExportProfileError :: Int64 -> Int64 -> SomeException -> ExportProfileResult +pattern ExportProfileError exportedProfiles rejectedProfiles someException = + ExportProfileResult exportedProfiles rejectedProfiles (Just someException) + +data RejectedProfilesError + = RejectedProfilesError + { rejectedProfiles :: !Int64 + , errorMessage :: !Text + } + deriving (Show) + +instance Exception RejectedProfilesError where + displayException :: RejectedProfilesError -> String + displayException RejectedProfilesError{..} = + printf "Error: OpenTelemetry Collector rejectedProfiles %d data points with message: %s" rejectedProfiles errorMessage + +-------------------------------------------------------------------------------- +-- OpenTelemetry gRPC Exporter for Profiles + +exportResourceProfiles :: + Logger IO -> + Exporter -> + ProcessT IO (Tick OPS.ExportProfilesServiceRequest) (Tick ExportProfileResult) +exportResourceProfiles logger exporter = + construct $ go False + where + go exportedProfiles = + await >>= \case + Tick -> do + unless exportedProfiles $ + yield (Item $ ExportProfileSuccess 0) + yield Tick + go False + Item exportProfilesServiceRequest -> do + exportTraceResult <- liftIO (sendResourceProfiles exportProfilesServiceRequest) + yield (Item exportTraceResult) + go True + + sendResourceProfiles :: OPS.ExportProfilesServiceRequest -> IO ExportProfileResult + sendResourceProfiles exportProfilesServiceRequest = + doExport `catch` handleSomeException + where + !exportedProfiles = countSamplesInExportProfileServiceRequest exportProfilesServiceRequest + + doExport :: IO ExportProfileResult + doExport = do + resp <- export @OPS.ProfilesService @"export" logger exporter exportProfilesServiceRequest + if resp ^. OPS.partialSuccess . OPS.rejectedProfiles == 0 + then + pure $ ExportProfileSuccess exportedProfiles + else do + let !rejectedProfiles = resp ^. OPS.partialSuccess . OPS.rejectedProfiles + let !rejectedMetricsError = RejectedProfilesError{errorMessage = resp ^. OPS.partialSuccess . OPS.errorMessage, ..} + pure $ ExportProfileError exportedProfiles rejectedProfiles (SomeException rejectedMetricsError) + + handleSomeException :: SomeException -> IO ExportProfileResult + handleSomeException someException = pure $ ExportProfileError 0 exportedProfiles someException + +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 + apiPath :: String + apiPath = "/v1development/profiles" + +{- | +Internal helper. +Count the number of 'OP.Sample' values in an 'OPS.ExportProfilesServiceRequest'. +-} +{-# SPECIALIZE countSamplesInExportProfileServiceRequest :: OPS.ExportProfilesServiceRequest -> Int64 #-} +{-# SPECIALIZE countSamplesInExportProfileServiceRequest :: OPS.ExportProfilesServiceRequest -> Word #-} +countSamplesInExportProfileServiceRequest :: (Integral i) => OPS.ExportProfilesServiceRequest -> i +countSamplesInExportProfileServiceRequest exportProfileServiceRequest = + getSum $ foldMap (Sum . countSamplesInResourceProfiles) (exportProfileServiceRequest ^. OPS.vec'resourceProfiles) + +countSamplesInResourceProfiles :: (Integral i) => OP.ResourceProfiles -> i +countSamplesInResourceProfiles resourceProfiles = + getSum $ foldMap (Sum . countSamplesInScopeProfiles) (resourceProfiles ^. OP.vec'scopeProfiles) + +countSamplesInScopeProfiles :: (Integral i) => OP.ScopeProfiles -> i +countSamplesInScopeProfiles scopeProfiles = + getSum $ foldMap (Sum . countSamplesInProfile) (scopeProfiles ^. OP.vec'profiles) + +countSamplesInProfile :: (Integral i) => OP.Profile -> i +countSamplesInProfile profile = + fromIntegral $ + V.length (profile ^. OP.vec'samples) diff --git a/src-app/GHC/Eventlog/Live/Otlp/Exporter/Traces.hs b/src-app/GHC/Eventlog/Live/Otlp/Exporter/Traces.hs new file mode 100644 --- /dev/null +++ b/src-app/GHC/Eventlog/Live/Otlp/Exporter/Traces.hs @@ -0,0 +1,144 @@ +{-# OPTIONS_GHC -Wno-orphans #-} + +module GHC.Eventlog.Live.Otlp.Exporter.Traces ( + -- * Traces + ExportTraceResult (..), + RejectedSpansError (..), + exportResourceSpans, +) where + +import Control.Exception (Exception (..), SomeException (..), catch) +import Control.Monad (unless) +import Control.Monad.IO.Class (MonadIO (..)) +import Data.Int (Int64) +import Data.Machine (ProcessT, await, construct, yield) +import Data.Semigroup (Sum (..)) +import Data.Text (Text) +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 Lens.Family2 ((^.)) +import Network.GRPC.Common qualified as G +import Network.GRPC.Common.Protobuf (Protobuf) +import Proto.Opentelemetry.Proto.Collector.Trace.V1.TraceService qualified as OTS +import Proto.Opentelemetry.Proto.Collector.Trace.V1.TraceService_Fields qualified as OTS +import Proto.Opentelemetry.Proto.Trace.V1.Trace qualified as OT +import Proto.Opentelemetry.Proto.Trace.V1.Trace_Fields qualified as OT +import Text.Printf (printf) + +-------------------------------------------------------------------------------- +-- OpenTelemetry Exporter Result for Traces + +data ExportTraceResult + = ExportTraceResult + { exportedSpans :: !Int64 + , rejectedSpans :: !Int64 + , maybeSomeException :: Maybe SomeException + } + deriving (Show) + +pattern ExportTraceSuccess :: Int64 -> ExportTraceResult +pattern ExportTraceSuccess exportedSpans = + ExportTraceResult exportedSpans 0 Nothing + +pattern ExportTraceError :: Int64 -> Int64 -> SomeException -> ExportTraceResult +pattern ExportTraceError exportedSpans rejectedSpans someException = + ExportTraceResult exportedSpans rejectedSpans (Just someException) + +data RejectedSpansError + = RejectedSpansError + { rejectedSpans :: !Int64 + , errorMessage :: !Text + } + deriving (Show) + +instance Exception RejectedSpansError where + displayException :: RejectedSpansError -> String + displayException RejectedSpansError{..} = + printf "Error: OpenTelemetry Collector rejectedSpans %d spans with message: %s" rejectedSpans errorMessage + +-------------------------------------------------------------------------------- +-- OpenTelemetry gRPC Exporter for Traces + +exportResourceSpans :: + Logger IO -> + Exporter -> + ProcessT IO (Tick OTS.ExportTraceServiceRequest) (Tick ExportTraceResult) +exportResourceSpans logger exporter = + construct $ go False + where + go exportedResourceSpans = + await >>= \case + Tick -> do + unless exportedResourceSpans $ + yield (Item $ ExportTraceSuccess 0) + yield Tick + go False + Item exportTraceServiceRequest -> do + exportTraceResult <- liftIO (sendResourceSpans exportTraceServiceRequest) + yield (Item exportTraceResult) + go True + + sendResourceSpans :: OTS.ExportTraceServiceRequest -> IO ExportTraceResult + sendResourceSpans exportTraceServiceRequest = + doGrpc `catch` handleSomeException + where + !exportedSpans = countSpansInExportTraceServiceRequest exportTraceServiceRequest + + doGrpc :: IO ExportTraceResult + doGrpc = do + resp <- export @OTS.TraceService @"export" logger exporter exportTraceServiceRequest + if resp ^. OTS.partialSuccess . OTS.rejectedSpans == 0 + then + pure $ ExportTraceSuccess exportedSpans + else do + let !rejectedSpans = resp ^. OTS.partialSuccess . OTS.rejectedSpans + let !rejectedMetricsError = RejectedSpansError{errorMessage = resp ^. OTS.partialSuccess . OTS.errorMessage, ..} + pure $ ExportTraceError exportedSpans rejectedSpans (SomeException rejectedMetricsError) + + handleSomeException :: SomeException -> IO ExportTraceResult + handleSomeException someException = pure $ ExportTraceError 0 exportedSpans someException + +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 + apiPath :: String + apiPath = "/v1/traces" + +-------------------------------------------------------------------------------- +-- Internal Helpers +-------------------------------------------------------------------------------- + +{- | +Internal helper. +Count the number of `OT.Span` values in an `OTS.ExportTraceServiceRequest`. +-} +{-# SPECIALIZE countSpansInExportTraceServiceRequest :: OTS.ExportTraceServiceRequest -> Int64 #-} +{-# SPECIALIZE countSpansInExportTraceServiceRequest :: OTS.ExportTraceServiceRequest -> Word #-} +countSpansInExportTraceServiceRequest :: (Integral i) => OTS.ExportTraceServiceRequest -> i +countSpansInExportTraceServiceRequest exportTraceServiceRequest = + getSum $ foldMap (Sum . countSpansInResourceSpans) (exportTraceServiceRequest ^. OTS.vec'resourceSpans) + +{- | +Internal helper. +Count the number of `OT.Span` values in an `OT.ResourceSpans`. +-} +{-# SPECIALIZE countSpansInResourceSpans :: OT.ResourceSpans -> Int64 #-} +{-# SPECIALIZE countSpansInResourceSpans :: OT.ResourceSpans -> Word #-} +countSpansInResourceSpans :: (Integral i) => OT.ResourceSpans -> i +countSpansInResourceSpans resourceSpans = + getSum $ foldMap (Sum . countSpansInScopeSpans) (resourceSpans ^. OT.vec'scopeSpans) + +{- | +Internal helper. +Count the number of `OT.Span` values in an `OT.ScopeSpans`. +-} +{-# SPECIALIZE countSpansInScopeSpans :: OT.ScopeSpans -> Int64 #-} +{-# SPECIALIZE countSpansInScopeSpans :: OT.ScopeSpans -> Word #-} +countSpansInScopeSpans :: (Integral i) => OT.ScopeSpans -> i +countSpansInScopeSpans scopeSpans = + fromIntegral $ + V.length (scopeSpans ^. OT.vec'spans) diff --git a/src-app/GHC/Eventlog/Live/Otlp/Options.hs b/src-app/GHC/Eventlog/Live/Otlp/Options.hs new file mode 100644 --- /dev/null +++ b/src-app/GHC/Eventlog/Live/Otlp/Options.hs @@ -0,0 +1,138 @@ +module GHC.Eventlog.Live.Otlp.Options ( + Options (..), + MyDebugOptions (..), + options, +) where + +import Data.Default (Default (..)) +import Data.Text qualified as T +import Data.Version (showVersion) +import GHC.Debug.Stub.Compat (MyGhcDebugSocket, maybeMyGhcDebugSocketParser) +import GHC.Eventlog.Live.Options +import GHC.Eventlog.Live.Otlp.Config qualified as C +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.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 Paths_eventlog_live qualified as EventlogLive + +options :: O.ParserInfo Options +options = + O.info + ( optionsParser + O.<**> defaultsPrinter + O.<**> debugDefaultsPrinter + O.<**> configJSONSchemaPrinter + O.<**> OE.helperWith (O.long "help" <> O.help "Show this help text.") + O.<**> OC.simpleVersioner (showVersion EventlogLive.version) + ) + O.idm + +data Options = Options + { eventlogSourceOptions :: EventlogSourceOptions + , eventlogSocketTimeoutS :: Double + , eventlogSocketTimeoutExponent :: Double + , eventlogFlushIntervalS :: Double + , maybeEventlogLogFile :: Maybe FilePath + , maybeHeapProfBreakdown :: Maybe HeapProfBreakdown + , maybeIpeDBPath :: Maybe FilePath + , maybeCCDBPath :: Maybe FilePath + , stats :: Bool + , maybeConfigFile :: Maybe FilePath + , controlOptions :: ControlOptions + , myDebugOptions :: MyDebugOptions + } + +optionsParser :: O.Parser Options +optionsParser = + Options + <$> eventlogSourceOptionsParser + <*> eventlogSocketTimeoutSParser + <*> eventlogSocketTimeoutExponentParser + <*> eventlogFlushIntervalSParser + <*> O.optional eventlogLogFileParser + <*> O.optional heapProfBreakdownParser + <*> O.optional ipeDBPathParser + <*> O.optional ccDBPathParser + <*> statsParser + <*> O.optional configFileParser + <*> controlOptionsParser + <*> myDebugOptionsParser + +-------------------------------------------------------------------------------- +-- Configuration + +configFileParser :: O.Parser FilePath +configFileParser = + O.strOption + ( O.long "config" + <> O.metavar "FILE" + <> O.help "The path to a detailed configuration file." + ) + +defaultsPrinter :: O.Parser (a -> a) +defaultsPrinter = + O.infoOption defaultConfigString . mconcat $ + [ O.long "print-defaults" + , O.help "Print default configuration options." + ] + +configJSONSchemaPrinter :: O.Parser (a -> a) +configJSONSchemaPrinter = + O.infoOption defaultConfigJSONSchemaString . mconcat $ + [ O.long "print-config-json-schema" + , O.help "Print JSON Schema for configuration format." + ] + +debugDefaultsPrinter :: O.Parser (a -> a) +debugDefaultsPrinter = + O.infoOption defaultConfigDebugString . mconcat $ + [ O.long "print-defaults-debug" + , O.help "Print default configuration options using the parsed representation." + , O.internal + ] + where + defaultConfigDebugString = + T.unpack . C.prettyConfig $ (def :: Config) + +-------------------------------------------------------------------------------- +-- InfoProv Tables + +ipeDBPathParser :: O.Parser FilePath +ipeDBPathParser = + O.strOption + ( O.long "ipedb" + <> O.metavar "FILE" + <> O.help "The path to an IPE database." + ) + +-------------------------------------------------------------------------------- +-- CostCentre Tables + +ccDBPathParser :: O.Parser FilePath +ccDBPathParser = + O.strOption + ( O.long "ccdb" + <> O.metavar "FILE" + <> O.help "The path a cost-centre database." + ) + +-------------------------------------------------------------------------------- +-- Debug Options + +data MyDebugOptions = MyDebugOptions + { maybeMyEventlogSocket :: Maybe MyEventlogSocket + , maybeMyGhcDebugSocket :: Maybe MyGhcDebugSocket + } + +myDebugOptionsParser :: O.Parser MyDebugOptions +myDebugOptionsParser = + OC.parserOptionGroup "Debug Options" $ + MyDebugOptions + <$> maybeMyEventlogSocketParser + <*> maybeMyGhcDebugSocketParser diff --git a/src-app/GHC/Eventlog/Live/Otlp/Processor/Common/Core.hs b/src-app/GHC/Eventlog/Live/Otlp/Processor/Common/Core.hs new file mode 100644 --- /dev/null +++ b/src-app/GHC/Eventlog/Live/Otlp/Processor/Common/Core.hs @@ -0,0 +1,79 @@ +{- | +Module : GHC.Eventlog.Live.Otlp.Processor.Common.Core +Description : Common utilities shared across telemetry data types. +Stability : experimental +Portability : portable +-} +module GHC.Eventlog.Live.Otlp.Processor.Common.Core ( + messageWith, + (.~?), + runIf, + runWith, + ifNonEmpty, + toMaybeKeyValue, + toMaybeAnyValue, +) +where + +import Data.Functor ((<&>)) +import Data.Machine (MachineT, stopped) +import Data.ProtoLens (Message (..)) +import GHC.Eventlog.Live.Data.Attribute (Attr, AttrValue (..)) +import Lens.Family2 (Setter, (.~)) +import Proto.Opentelemetry.Proto.Common.V1.Common qualified as OC +import Proto.Opentelemetry.Proto.Common.V1.Common_Fields qualified as OC + +-- | Construct a message with a list of modifications applied. +messageWith :: (Message msg) => [msg -> msg] -> msg +messageWith = foldr ($) defMessage + +-- | Set a value if it is `Just`. +(.~?) :: Setter s s a a -> Maybe a -> s -> s +setter .~? maybeValue = maybe id (setter .~) maybeValue + +-- | Run a machine if a boolean is @True@, otherwise stop. +runIf :: (Monad m) => Bool -> MachineT m k o -> MachineT m k o +runIf b m = if b then m else stopped + +-- | Run a machine with the value from a @Maybe a@, otherwise stop. +runWith :: (Monad m) => Maybe a -> (a -> MachineT m k o) -> MachineT m k o +runWith ma mf = maybe stopped mf ma + +-- | Return the second argument if the first argument is non-empty. +ifNonEmpty :: [a] -> b -> Maybe b +ifNonEmpty xs r = if null xs then Nothing else Just r + +-------------------------------------------------------------------------------- +-- Interpret attributes + +{- | +Convert an `Attr` to an OTLP `OC.KeyValue`. +-} +toMaybeKeyValue :: Attr -> Maybe OC.KeyValue +toMaybeKeyValue (k, v) = + toMaybeAnyValue v <&> \v' -> + messageWith + [ OC.key .~ k + , OC.value .~ v' + ] + +{- | +Internal helper. +Convert an `AttrValue` to an OTLP `OC.AnyValue`. +-} +toMaybeAnyValue :: AttrValue -> Maybe OC.AnyValue +toMaybeAnyValue = \case + AttrBool v -> Just $ messageWith [OC.boolValue .~ v] + AttrInt v -> Just $ messageWith [OC.intValue .~ fromIntegral v] + AttrInt8 v -> Just $ messageWith [OC.intValue .~ fromIntegral v] + AttrInt16 v -> Just $ messageWith [OC.intValue .~ fromIntegral v] + AttrInt32 v -> Just $ messageWith [OC.intValue .~ fromIntegral v] + AttrInt64 v -> Just $ messageWith [OC.intValue .~ v] + AttrWord v -> Just $ messageWith [OC.intValue .~ fromIntegral v] + AttrWord8 v -> Just $ messageWith [OC.intValue .~ fromIntegral v] + AttrWord16 v -> Just $ messageWith [OC.intValue .~ fromIntegral v] + AttrWord32 v -> Just $ messageWith [OC.intValue .~ fromIntegral v] + AttrWord64 v -> Just $ messageWith [OC.intValue .~ fromIntegral v] + AttrDouble v -> Just $ messageWith [OC.doubleValue .~ v] + AttrText v -> Just $ messageWith [OC.stringValue .~ v] + AttrNull -> Nothing diff --git a/src-app/GHC/Eventlog/Live/Otlp/Processor/Common/Logs.hs b/src-app/GHC/Eventlog/Live/Otlp/Processor/Common/Logs.hs new file mode 100644 --- /dev/null +++ b/src-app/GHC/Eventlog/Live/Otlp/Processor/Common/Logs.hs @@ -0,0 +1,84 @@ +{-# LANGUAGE OverloadedStrings #-} + +{- | +Module : GHC.Eventlog.Live.Otlp.Processor.Common.Logs +Description : Profile Processors for OTLP. +Stability : experimental +Portability : portable +-} +module GHC.Eventlog.Live.Otlp.Processor.Common.Logs ( + ToLogRecord (..), + toExportLogsServiceRequest, + toResourceLogs, + toScopeLogs, +) +where + +import Data.Function ((&)) +import Data.Maybe (fromMaybe, mapMaybe) +import Data.ProtoLens (Message (..)) +import Data.Text (Text) +import GHC.Eventlog.Live.Data.Attribute ((~=)) +import GHC.Eventlog.Live.Data.LogRecord (LogRecord (..)) +import GHC.Eventlog.Live.Data.Severity (Severity) +import GHC.Eventlog.Live.Data.Severity qualified as DS +import GHC.Eventlog.Live.Machine.Analysis.Thread qualified as M +import GHC.Eventlog.Live.Otlp.Processor.Common.Core (ifNonEmpty, messageWith, toMaybeKeyValue) +import GHC.IsList (IsList (..)) +import Lens.Family2 ((.~)) +import Proto.Opentelemetry.Proto.Collector.Logs.V1.LogsService qualified as OLS +import Proto.Opentelemetry.Proto.Common.V1.Common qualified as OC +import Proto.Opentelemetry.Proto.Common.V1.Common_Fields qualified as OC +import Proto.Opentelemetry.Proto.Logs.V1.Logs qualified as OL +import Proto.Opentelemetry.Proto.Logs.V1.Logs_Fields qualified as OL +import Proto.Opentelemetry.Proto.Resource.V1.Resource qualified as OR + +toExportLogsServiceRequest :: [OL.ResourceLogs] -> OLS.ExportLogsServiceRequest +toExportLogsServiceRequest = (defMessage &) . (OL.resourceLogs .~) + +toResourceLogs :: OR.Resource -> [OL.ScopeLogs] -> Maybe OL.ResourceLogs +toResourceLogs resource scopeLogs = + ifNonEmpty scopeLogs $ + messageWith [OL.resource .~ resource, OL.scopeLogs .~ scopeLogs] + +toScopeLogs :: OC.InstrumentationScope -> [OL.LogRecord] -> Maybe OL.ScopeLogs +toScopeLogs instrumentationScope logRecords = + ifNonEmpty logRecords $ + messageWith [OL.scope .~ instrumentationScope, OL.logRecords .~ logRecords] + +-------------------------------------------------------------------------------- +-- Interpret logs + +class ToLogRecord v where + toLogRecord :: v -> OL.LogRecord + +instance ToLogRecord LogRecord where + toLogRecord :: LogRecord -> OL.LogRecord + toLogRecord i = + messageWith + [ OL.body .~ messageWith [OC.stringValue .~ i.body] + , OL.timeUnixNano .~ fromMaybe 0 i.maybeTimeUnixNano + , -- TODO: this could be set to the actual observed time in the processor. + OL.observedTimeUnixNano .~ fromMaybe 0 i.maybeTimeUnixNano + , OL.attributes .~ mapMaybe toMaybeKeyValue (toList i.attrs) + , OL.severityNumber .~ toSeverityNumber i.maybeSeverity + ] + where + toSeverityNumber :: Maybe Severity -> OL.SeverityNumber + toSeverityNumber = maybe OL.SEVERITY_NUMBER_UNSPECIFIED (toEnum . (.value) . DS.toSeverityNumber) + +instance ToLogRecord M.ThreadLabel where + toLogRecord :: M.ThreadLabel -> OL.LogRecord + toLogRecord i = + messageWith + [ OL.body .~ messageWith [OC.stringValue .~ i.threadlabel] + , OL.timeUnixNano .~ i.startTimeUnixNano + , -- TODO: this could be set to the actual observed time in the processor. + OL.observedTimeUnixNano .~ i.startTimeUnixNano + , OL.attributes + .~ mapMaybe + toMaybeKeyValue + [ "kind" ~= ("ThreadLabel" :: Text) + , "thread" ~= i.thread + ] + ] diff --git a/src-app/GHC/Eventlog/Live/Otlp/Processor/Common/Metrics.hs b/src-app/GHC/Eventlog/Live/Otlp/Processor/Common/Metrics.hs new file mode 100644 --- /dev/null +++ b/src-app/GHC/Eventlog/Live/Otlp/Processor/Common/Metrics.hs @@ -0,0 +1,292 @@ +{- | +Module : GHC.Eventlog.Live.Otlp.Processor.Common.Metrics +Description : Common utilities for metric processors. +Stability : experimental +Portability : portable +-} +module GHC.Eventlog.Live.Otlp.Processor.Common.Metrics ( + MetricProcessor (..), + runMetricProcessor, + MetricAggregators (..), + viaSum, + viaLast, + asGauge, + asSum, + toScopeMetrics, + toResourceMetrics, + toExportMetricsServiceRequest, +) +where + +import Control.Monad (unless) +import Data.Coerce (Coercible, coerce) +import Data.DList (DList) +import Data.DList qualified as D +import Data.Default (Default) +import Data.Function ((&)) +import Data.Int (Int16, Int32, Int64, Int8) +import Data.Kind (Type) +import Data.Machine (Process, ProcessT, asParts, await, echo, mapping, repeatedly, yield, (~>)) +import Data.Maybe (fromMaybe, mapMaybe) +import Data.ProtoLens (Message (..)) +import Data.Proxy (Proxy (..)) +import Data.Semigroup (Last (..), Sum (..)) +import Data.Text (Text) +import Data.Word (Word16, Word32, Word64, Word8) +import GHC.Eventlog.Live.Data.Group (Group, GroupBy, GroupedBy) +import GHC.Eventlog.Live.Data.Group qualified as DG +import GHC.Eventlog.Live.Data.Metric (Metric (..)) +import GHC.Eventlog.Live.Machine.Core (Tick) +import GHC.Eventlog.Live.Machine.Core qualified as M +import GHC.Eventlog.Live.Otlp.Config qualified as C +import GHC.Eventlog.Live.Otlp.Config.Types (FullConfig) +import GHC.Eventlog.Live.Otlp.Processor.Common.Core (ifNonEmpty, messageWith, runIf, toMaybeKeyValue) +import GHC.IsList (IsList (..)) +import GHC.Records (HasField (..)) +import GHC.TypeLits (Symbol) +import Lens.Family2 ((.~)) +import Proto.Opentelemetry.Proto.Collector.Metrics.V1.MetricsService qualified as OMS +import Proto.Opentelemetry.Proto.Common.V1.Common qualified as OC +import Proto.Opentelemetry.Proto.Metrics.V1.Metrics qualified as OM +import Proto.Opentelemetry.Proto.Metrics.V1.Metrics_Fields qualified as OM +import Proto.Opentelemetry.Proto.Resource.V1.Resource qualified as OR + +-------------------------------------------------------------------------------- +-- Generic Metric Processor + +type MetricProcessor :: Symbol -> Type -> (Type -> Type) -> Type -> Type -> Type -> Type -> Type +data MetricProcessor metricProcessor metricProcessorConfig m a b c d + = ( Monad m + , HasField metricProcessor C.Metrics (Maybe metricProcessorConfig) + , C.IsMetricProcessorConfig metricProcessorConfig + , IsNumberDataPoint'Value d + ) => + MetricProcessor + { metricProcessorProxy :: !(Proxy metricProcessor) + -- ^ The metric's field name in `C.Metrics`. + , dataProcessor :: !(ProcessT m a b) + -- ^ The metric's data processor + , aggregators :: !(MetricAggregators b c) + -- ^ The metric's aggregator + , postProcessor :: !(ProcessT m c (Metric d)) + -- ^ The metric's post processor + , unit :: !Text + -- ^ The metric's unit (in UCUM format). + , asMetric'Data :: !(ProcessT m [OM.NumberDataPoint] OM.Metric'Data) + -- ^ A process to wrap data points as `OM.Metric'Data`. + } + +{- | +Internal helper. +Run a `MetricProcessor`. +-} +runMetricProcessor :: + forall metricProcessor metricProcessorConfig m a b c d. + (Default metricProcessorConfig, Show metricProcessorConfig) => + MetricProcessor metricProcessor metricProcessorConfig m a b c d -> + -- | The full configuration. + FullConfig -> + ProcessT m (Tick a) (Tick (DList OM.Metric)) +runMetricProcessor MetricProcessor{..} fullConfig = + let metricProcessorConfig :: C.Metrics -> Maybe metricProcessorConfig + metricProcessorConfig = getField @metricProcessor + in runIf (C.processorEnabled (.metrics) metricProcessorConfig fullConfig) $ + M.liftTick dataProcessor + ~> aggregate aggregators (C.processorAggregationBatches (.metrics) metricProcessorConfig fullConfig) + ~> M.liftTick postProcessor + ~> mapping (fmap (D.singleton . toNumberDataPoint)) + ~> M.batchByTicks (C.processorExportBatches (.metrics) metricProcessorConfig fullConfig) + ~> M.liftTick + ( mapping D.toList + ~> asMetric'Data + ~> asMetricWith fullConfig metricProcessorConfig [OM.unit .~ unit] + ~> mapping D.singleton + ) +{-# INLINE runMetricProcessor #-} + +asMetricWith :: + ( Show metricProcessorConfig + , Default metricProcessorConfig + , HasField "description" metricProcessorConfig (Maybe Text) + , HasField "name" metricProcessorConfig (Maybe Text) + ) => + FullConfig -> + (C.Metrics -> Maybe metricProcessorConfig) -> + [OM.Metric -> OM.Metric] -> + Process OM.Metric'Data OM.Metric +asMetricWith fullConfig field f = + asMetric $ + [ OM.name .~ C.processorName (.metrics) field fullConfig + , maybe id (OM.description .~) $ C.processorDescription (.metrics) field fullConfig + ] + <> f + +asMetric :: [OM.Metric -> OM.Metric] -> Process OM.Metric'Data OM.Metric +asMetric f = mapping $ toMetric f + +toMetric :: [OM.Metric -> OM.Metric] -> OM.Metric'Data -> OM.Metric +toMetric f metric'data = messageWith ((OM.maybe'data' .~ Just metric'data) : f) + +toExportMetricsServiceRequest :: [OM.ResourceMetrics] -> OMS.ExportMetricsServiceRequest +toExportMetricsServiceRequest = (defMessage &) . (OM.resourceMetrics .~) + +toResourceMetrics :: OR.Resource -> [OM.ScopeMetrics] -> Maybe OM.ResourceMetrics +toResourceMetrics resource scopeMetrics = + ifNonEmpty scopeMetrics $ + messageWith [OM.resource .~ resource, OM.scopeMetrics .~ scopeMetrics] + +toScopeMetrics :: OC.InstrumentationScope -> [OM.Metric] -> Maybe OM.ScopeMetrics +toScopeMetrics instrumentationScope metrics = + ifNonEmpty metrics $ + messageWith [OM.scope .~ instrumentationScope, OM.metrics .~ metrics] + +asGauge :: Process [OM.NumberDataPoint] OM.Metric'Data +asGauge = + repeatedly $ do + await >>= \dataPoints -> + unless (null dataPoints) $ + yield (toGauge dataPoints) + +toGauge :: [OM.NumberDataPoint] -> OM.Metric'Data +toGauge dataPoints = OM.Metric'Gauge . messageWith $ [OM.dataPoints .~ dataPoints] + +asSum :: [OM.Sum -> OM.Sum] -> Process [OM.NumberDataPoint] OM.Metric'Data +asSum f = + repeatedly $ + await >>= \dataPoints -> + unless (null dataPoints) $ + yield (toSum f dataPoints) + +toSum :: [OM.Sum -> OM.Sum] -> [OM.NumberDataPoint] -> OM.Metric'Data +toSum f dataPoints = OM.Metric'Sum . messageWith $ (OM.dataPoints .~ dataPoints) : f + +-------------------------------------------------------------------------------- +-- Metric Aggregation + +data MetricAggregators a b = MetricAggregators + { nothing :: Process (Tick a) (Tick b) + , byBatches :: Int -> Process (Tick a) (Tick b) + } + +{- | +Internal helper. +Aggregate items based on the provided aggregators and aggregation strategy. +-} +aggregate :: MetricAggregators a b -> Int -> Process (Tick a) (Tick b) +aggregate MetricAggregators{..} aggregationBatches + | aggregationBatches >= 1 = byBatches aggregationBatches + | otherwise = nothing + +{- | +Internal helper. +Metric aggregators via the `Semigroup` instance for `Sum`. +-} +viaSum :: forall a. (Num a) => MetricAggregators (Metric a) (Metric a) +viaSum = + MetricAggregators + { nothing = echo + , byBatches = \ticks -> + -- TODO: Yield group sample counts as separate metric. + batchByTicksVia ticks (Proxy @(Metric (Sum a))) + ~> M.liftTick (mapping (fmap (.representative)) ~> asParts) + } + +{- | +Internal helper. +Metric aggregators via the `Semigroup` instance for `Last`. +-} +viaLast :: forall a. (GroupBy a) => MetricAggregators a a +viaLast = + MetricAggregators + { nothing = echo + , byBatches = \ticks -> + -- TODO: Yield group sample counts as separate metric. + batchByTicksVia ticks (Proxy @(Last a)) + ~> M.liftTick (mapping (fmap (.representative)) ~> asParts) + } + +{- | +Internal helper. +This function aggregates items via a `Semigroup` instance and grouped by the `GroupBy` instance. +-} +batchByTicksVia :: + forall a b. + (Coercible a b, GroupBy b, Semigroup b) => + -- | The number of ticks per batch. + Int -> + Proxy b -> + Process (Tick a) (Tick [Group a]) +batchByTicksVia ticks (Proxy :: Proxy b) = + mapping (fmap DG.singleton . coerce @(Tick a) @(Tick b)) + ~> M.batchByTicks @(GroupedBy b) ticks + ~> M.liftTick (mapping (coerce @[Group b] @[Group a] . DG.groups)) + +{- | +Internal helper. +Convert a metric datapoint to an `OM.NumberDataPoint`. +-} +toNumberDataPoint :: (IsNumberDataPoint'Value v) => Metric v -> OM.NumberDataPoint +toNumberDataPoint i = + messageWith + [ OM.maybe'value .~ Just (toNumberDataPoint'Value i.value) + , OM.timeUnixNano .~ fromMaybe 0 i.maybeTimeUnixNano + , OM.startTimeUnixNano .~ fromMaybe 0 i.maybeStartTimeUnixNano + , OM.attributes .~ mapMaybe toMaybeKeyValue (toList i.attrs) + ] + +{- | +Internal helper. +Class of types that can be converted to `OM.NumberDataPoint'Value` values. +-} +class IsNumberDataPoint'Value v where + toNumberDataPoint'Value :: v -> OM.NumberDataPoint'Value + +instance IsNumberDataPoint'Value Float where + toNumberDataPoint'Value :: Float -> OM.NumberDataPoint'Value + toNumberDataPoint'Value = OM.NumberDataPoint'AsDouble . realToFrac + +instance IsNumberDataPoint'Value Double where + toNumberDataPoint'Value :: Double -> OM.NumberDataPoint'Value + toNumberDataPoint'Value = OM.NumberDataPoint'AsDouble + +instance IsNumberDataPoint'Value Word8 where + toNumberDataPoint'Value :: Word8 -> OM.NumberDataPoint'Value + toNumberDataPoint'Value = OM.NumberDataPoint'AsInt . fromIntegral + +instance IsNumberDataPoint'Value Word16 where + toNumberDataPoint'Value :: Word16 -> OM.NumberDataPoint'Value + toNumberDataPoint'Value = OM.NumberDataPoint'AsInt . fromIntegral + +instance IsNumberDataPoint'Value Word32 where + toNumberDataPoint'Value :: Word32 -> OM.NumberDataPoint'Value + toNumberDataPoint'Value = OM.NumberDataPoint'AsInt . fromIntegral + +-- | __Warning__: This instance may cause overflow. +instance IsNumberDataPoint'Value Word64 where + toNumberDataPoint'Value :: Word64 -> OM.NumberDataPoint'Value + toNumberDataPoint'Value = OM.NumberDataPoint'AsInt . fromIntegral + +-- | __Warning__: This instance may cause overflow. +instance IsNumberDataPoint'Value Word where + toNumberDataPoint'Value :: Word -> OM.NumberDataPoint'Value + toNumberDataPoint'Value = OM.NumberDataPoint'AsInt . fromIntegral + +instance IsNumberDataPoint'Value Int8 where + toNumberDataPoint'Value :: Int8 -> OM.NumberDataPoint'Value + toNumberDataPoint'Value = OM.NumberDataPoint'AsInt . fromIntegral + +instance IsNumberDataPoint'Value Int16 where + toNumberDataPoint'Value :: Int16 -> OM.NumberDataPoint'Value + toNumberDataPoint'Value = OM.NumberDataPoint'AsInt . fromIntegral + +instance IsNumberDataPoint'Value Int32 where + toNumberDataPoint'Value :: Int32 -> OM.NumberDataPoint'Value + toNumberDataPoint'Value = OM.NumberDataPoint'AsInt . fromIntegral + +instance IsNumberDataPoint'Value Int64 where + toNumberDataPoint'Value :: Int64 -> OM.NumberDataPoint'Value + toNumberDataPoint'Value = OM.NumberDataPoint'AsInt + +instance IsNumberDataPoint'Value Int where + toNumberDataPoint'Value :: Int -> OM.NumberDataPoint'Value + toNumberDataPoint'Value = OM.NumberDataPoint'AsInt . fromIntegral diff --git a/src-app/GHC/Eventlog/Live/Otlp/Processor/Common/ProfilesDictionary.hs b/src-app/GHC/Eventlog/Live/Otlp/Processor/Common/ProfilesDictionary.hs new file mode 100644 --- /dev/null +++ b/src-app/GHC/Eventlog/Live/Otlp/Processor/Common/ProfilesDictionary.hs @@ -0,0 +1,173 @@ +{-# LANGUAGE OverloadedStrings #-} + +{- | +Module : GHC.Eventlog.Live.Otlp.Processor.Common.Profiles +Description : Abstraction over ProfilesDictionary for the OTLP protocol. +Stability : experimental +Portability : portable +-} +module GHC.Eventlog.Live.Otlp.Processor.Common.ProfilesDictionary ( + -- * Dictionary for deduplication logic of common values + ProfilesDictionary, + empty, + + -- * Retrieve the 'SymbolIndex' for various 'OP.ProfilesData' fields + SymbolIndex, + getLocation, + getFunction, + getText, + getString, + getMapping, + getLink, + getAttribute, + getAttr, + getStack, + + -- * Convert data to the formats used by @hs-opentelemetry-otlp@. + toProfilesDictionary, +) +where + +import Control.Monad.Trans.State.Strict (StateT) +import Control.Monad.Trans.State.Strict qualified as State +import Data.ProtoLens (Message (..)) +import Data.Text (Text) +import Data.Text qualified as T +import GHC.Eventlog.Live.Data.Attribute (Attr) +import GHC.Eventlog.Live.Otlp.Processor.Common.Core (messageWith, toMaybeAnyValue) +import GHC.Eventlog.Live.Otlp.Processor.Common.SymbolTable (SymbolIndex, SymbolTable) +import GHC.Eventlog.Live.Otlp.Processor.Common.SymbolTable qualified as ST +import GHC.Generics (Generic) +import Lens.Family2 (Lens', (.~), (^.)) +import Lens.Family2.Unchecked (lens) +import Proto.Opentelemetry.Proto.Profiles.V1development.Profiles qualified as OP +import Proto.Opentelemetry.Proto.Profiles.V1development.Profiles_Fields qualified as OP + +data ProfilesDictionary = ProfilesDictionary + { locationTable :: SymbolTable OP.Location + {- ^ Common 'OP.Location' table, first entry is the 'defMessage'. + This holds for OTLP 1.9.0. + -} + , functionTable :: SymbolTable OP.Function + {- ^ Common 'OP.Function' table, first entry is the 'defMessage'. + This holds for OTLP 1.9.0. + -} + , stringTable :: SymbolTable Text + {- ^ Common string table, the first entry must be "" per the protobuf + documentation. + + @ + // A common table for strings referenced by various messages. + // string_table[0] must always be "". + repeated string string_table = 5; + @ + -} + , mappingTable :: SymbolTable OP.Mapping + {- ^ Common 'OP.Mapping' table, first entry is the 'defMessage'. + This holds for OTLP 1.9.0. + -} + , linkTable :: SymbolTable OP.Link + {- ^ Common 'OP.Link' table, first entry is the 'defMessage'. + This holds for OTLP 1.9.0. + -} + , attributeTable :: SymbolTable OP.KeyValueAndUnit + {- ^ Common 'OP.KeyValueAndUnit' table, first entry is the 'defMessage'. + This holds for OTLP 1.9.0. + -} + , stackTable :: SymbolTable OP.Stack + {- ^ Common 'OP.Stack' table, first entry is the 'defMessage'. + This holds for OTLP 1.9.0. + -} + } + deriving (Show, Ord, Eq, Generic) + +toProfilesDictionary :: ProfilesDictionary -> OP.ProfilesDictionary +toProfilesDictionary st = + messageWith + [ OP.locationTable .~ locations st + , OP.functionTable .~ functions st + , OP.stringTable .~ strings st + , OP.mappingTable .~ mappings st + , OP.linkTable .~ links st + , OP.attributeTable .~ attributes st + , OP.stackTable .~ stacks st + ] + +empty :: ProfilesDictionary +empty = + ProfilesDictionary + { locationTable = ST.fromList [defMessage] + , functionTable = ST.fromList [defMessage] + , stringTable = ST.fromList [""] + , mappingTable = ST.fromList [defMessage] + , linkTable = ST.fromList [defMessage] + , attributeTable = ST.fromList [defMessage] + , stackTable = ST.fromList [defMessage] + } + +locations :: ProfilesDictionary -> [OP.Location] +locations pd = ST.toList pd.locationTable + +functions :: ProfilesDictionary -> [OP.Function] +functions pd = ST.toList pd.functionTable + +strings :: ProfilesDictionary -> [Text] +strings pd = ST.toList pd.stringTable + +mappings :: ProfilesDictionary -> [OP.Mapping] +mappings pd = ST.toList pd.mappingTable + +links :: ProfilesDictionary -> [OP.Link] +links pd = ST.toList pd.linkTable + +attributes :: ProfilesDictionary -> [OP.KeyValueAndUnit] +attributes pd = ST.toList pd.attributeTable + +stacks :: ProfilesDictionary -> [OP.Stack] +stacks pd = ST.toList pd.stackTable + +getSymbolIndexFor :: (Ord a, Monad m) => Lens' ProfilesDictionary (SymbolTable a) -> a -> StateT ProfilesDictionary m SymbolIndex +getSymbolIndexFor accessor a = do + st <- State.gets (^. accessor) + let (si, pd') = ST.insert a st + State.modify' (accessor .~ pd') + pure si + +getLocation :: (Monad m) => OP.Location -> StateT ProfilesDictionary m SymbolIndex +getLocation = getSymbolIndexFor (lens (.locationTable) (\pd st -> pd{locationTable = st})) + +getFunction :: (Monad m) => OP.Function -> StateT ProfilesDictionary m SymbolIndex +getFunction = getSymbolIndexFor (lens (.functionTable) (\pd st -> pd{functionTable = st})) + +getText :: (Monad m) => Text -> StateT ProfilesDictionary m SymbolIndex +getText = getSymbolIndexFor (lens (.stringTable) (\pd st -> pd{stringTable = st})) + +getString :: (Monad m) => String -> StateT ProfilesDictionary m SymbolIndex +getString = getText . T.pack + +getMapping :: (Monad m) => OP.Mapping -> StateT ProfilesDictionary m SymbolIndex +getMapping = getSymbolIndexFor (lens (.mappingTable) (\pd st -> pd{mappingTable = st})) + +getLink :: (Monad m) => OP.Link -> StateT ProfilesDictionary m SymbolIndex +getLink = getSymbolIndexFor (lens (.linkTable) (\pd st -> pd{linkTable = st})) + +getAttribute :: (Monad m) => OP.KeyValueAndUnit -> StateT ProfilesDictionary m SymbolIndex +getAttribute = getSymbolIndexFor (lens (.attributeTable) (\pd st -> pd{attributeTable = st})) + +getAttr :: (Monad m) => Attr -> StateT ProfilesDictionary m (Maybe SymbolIndex) +getAttr (key, value) = + case toMaybeAnyValue value of + Nothing -> + pure Nothing + Just anyValue -> do + keyStrindex <- getText key + let keyValueAndUnit :: OP.KeyValueAndUnit + keyValueAndUnit = + messageWith + [ OP.keyStrindex .~ keyStrindex + , OP.value .~ anyValue + ] + Just <$> getAttribute keyValueAndUnit + +getStack :: (Monad m) => OP.Stack -> StateT ProfilesDictionary m SymbolIndex +getStack = getSymbolIndexFor (lens (.stackTable) (\pd st -> pd{stackTable = st})) diff --git a/src-app/GHC/Eventlog/Live/Otlp/Processor/Common/SymbolTable.hs b/src-app/GHC/Eventlog/Live/Otlp/Processor/Common/SymbolTable.hs new file mode 100644 --- /dev/null +++ b/src-app/GHC/Eventlog/Live/Otlp/Processor/Common/SymbolTable.hs @@ -0,0 +1,76 @@ +{- | +Module : GHC.Eventlog.Live.Otlp.Processor.Common.SymbolTable +Description : Abstract symbol table datatype. +Stability : experimental +Portability : portable +-} +module GHC.Eventlog.Live.Otlp.Processor.Common.SymbolTable ( + SymbolIndex, + SymbolTable, + empty, + elemIndex, + toList, + fromList, + insert, +) +where + +import Data.Int (Int32) +import Data.Map.Strict (Map) +import Data.Map.Strict qualified as Map +import GHC.Generics (Generic) + +type SymbolIndex = Int32 + +data SymbolTable a + = SymbolTable + { nextSymbolIndex :: !SymbolIndex + {- ^ + The next unused `SymbolIndex`. + + > st.nextSymbolIndex == length st.entriesRev + -} + , entryToSymbolIndex :: !(Map a SymbolIndex) + {- ^ + A map from entries to their `SymbolIndex`. + + > toList st !! (st.entryToSymbolIndex Map.! a) == a + -} + , entriesRev :: ![a] -- reverse order of insertion into entryToSymbolIndex + + {- ^ + A list of entries in the `SymbolTable` in reverse order. + -} + } + deriving (Show, Ord, Eq, Generic) + +empty :: SymbolTable a +empty = + SymbolTable + { nextSymbolIndex = 0 + , entryToSymbolIndex = Map.empty + , entriesRev = [] + } + +elemIndex :: (Ord a) => a -> SymbolTable a -> Maybe SymbolIndex +elemIndex a st = Map.lookup a st.entryToSymbolIndex + +toList :: SymbolTable a -> [a] +toList st = reverse st.entriesRev + +fromList :: (Ord a) => [a] -> SymbolTable a +fromList = foldr (\val st -> snd (insert val st)) empty + +insert :: (Ord a) => a -> SymbolTable a -> (SymbolIndex, SymbolTable a) +insert a st = (si, st'') + where + ((si, isNew, st'), entryToSymbolIndex') = Map.alterF (updateEntry st) a st.entryToSymbolIndex + entriesRev' = if isNew then a : st'.entriesRev else st'.entriesRev + st'' = st'{entryToSymbolIndex = entryToSymbolIndex', entriesRev = entriesRev'} + +updateEntry :: SymbolTable a -> Maybe SymbolIndex -> ((SymbolIndex, Bool, SymbolTable a), Maybe SymbolIndex) +updateEntry st Nothing = let (si, st') = freshSymbolIndex st in ((si, True, st'), Just si) +updateEntry st (Just si) = ((si, False, st), Just si) + +freshSymbolIndex :: SymbolTable a -> (SymbolIndex, SymbolTable a) +freshSymbolIndex st = (st.nextSymbolIndex, st{nextSymbolIndex = st.nextSymbolIndex + 1}) diff --git a/src-app/GHC/Eventlog/Live/Otlp/Processor/Common/Traces.hs b/src-app/GHC/Eventlog/Live/Otlp/Processor/Common/Traces.hs new file mode 100644 --- /dev/null +++ b/src-app/GHC/Eventlog/Live/Otlp/Processor/Common/Traces.hs @@ -0,0 +1,166 @@ +{-# LANGUAGE OverloadedStrings #-} + +{- | +Module : GHC.Eventlog.Live.Otlp.Processor.Common.Traces +Description : Profile Processors for OTLP. +Stability : experimental +Portability : portable +-} +module GHC.Eventlog.Live.Otlp.Processor.Common.Traces ( + asSpan, + ToSpan (..), + toExportTracesServiceRequest, + toResourceSpans, + toScopeSpans, +) +where + +import Control.Monad.IO.Class (MonadIO (..)) +import Data.ByteString (ByteString) +import Data.Function ((&)) +import Data.HashMap.Strict qualified as HM +import Data.Hashable (Hashable) +import Data.Machine (ProcessT, await, construct, yield) +import Data.Maybe (mapMaybe) +import Data.ProtoLens (Message (..)) +import GHC.Eventlog.Live.Data.Attribute ((~=)) +import GHC.Eventlog.Live.Machine.Analysis.Capability (CapabilityUsageSpan) +import GHC.Eventlog.Live.Machine.Analysis.Capability qualified as M +import GHC.Eventlog.Live.Machine.Analysis.Thread (ThreadStateSpan (..)) +import GHC.Eventlog.Live.Machine.Analysis.Thread qualified as M +import GHC.Eventlog.Live.Otlp.Config qualified as C +import GHC.Eventlog.Live.Otlp.Config.Types (FullConfig) +import GHC.Eventlog.Live.Otlp.Processor.Common.Core (ifNonEmpty, messageWith, toMaybeKeyValue) +import GHC.RTS.Events (ThreadId) +import Lens.Family2 ((.~)) +import Proto.Opentelemetry.Proto.Collector.Trace.V1.TraceService qualified as OTS +import Proto.Opentelemetry.Proto.Common.V1.Common qualified as OC +import Proto.Opentelemetry.Proto.Resource.V1.Resource qualified as OR +import Proto.Opentelemetry.Proto.Trace.V1.Trace qualified as OT +import Proto.Opentelemetry.Proto.Trace.V1.Trace_Fields qualified as OT +import Proto.Opentelemetry.Proto.Trace.V1.Trace_Fields qualified as OTS +import System.Random (StdGen, initStdGen) +import System.Random.Compat (uniformByteString) + +toExportTracesServiceRequest :: [OT.ResourceSpans] -> OTS.ExportTraceServiceRequest +toExportTracesServiceRequest = (defMessage &) . (OTS.resourceSpans .~) + +toResourceSpans :: OR.Resource -> [OT.ScopeSpans] -> Maybe OT.ResourceSpans +toResourceSpans resource scopeSpans = + ifNonEmpty scopeSpans $ + messageWith [OT.resource .~ resource, OT.scopeSpans .~ scopeSpans] + +toScopeSpans :: OC.InstrumentationScope -> [OT.Span] -> Maybe OT.ScopeSpans +toScopeSpans instrumentationScope spans = + ifNonEmpty spans $ + messageWith [OT.scope .~ instrumentationScope, OT.spans .~ spans] + +-------------------------------------------------------------------------------- +-- Interpret spans + +-- | The `asSpan` machine processes values @v@ into OpenTelemetry spans `OT.Span`. +asSpan :: (ToSpan v, MonadIO m, Hashable (Key v)) => FullConfig -> ProcessT m v OT.Span +asSpan fullConfig = construct $ go (mempty, Nothing) + where + -- go :: (HashMap (Key v) ByteString, Maybe StdGen) -> PlanT (Is v) OT.Span m Void + go (traceIds, maybeGen) = do + -- Ensure the StdGen is initialised + gen0 <- maybe (liftIO initStdGen) pure maybeGen + -- Receive the next value + i <- await + -- Ensure the next value has a trace ID + let ensureTraceId :: Maybe ByteString -> ((ByteString, StdGen), Maybe ByteString) + ensureTraceId = wrap . maybe (uniformByteString 16 gen0) (,gen0) + where + wrap out@(traceId, _gen) = (out, Just traceId) + let ((traceId, gen1), traceIds') = HM.alterF ensureTraceId (toKey i) traceIds + -- Ensure the next value has a span ID + let (spanId, gen2) = uniformByteString 8 gen1 + -- Yield a span + yield $ toSpan fullConfig i traceId spanId + -- Continue + go (traceIds', Just gen2) + +class ToSpan v where + -- | The `Key` type is used to index a `HashMap` in the default definition of `asSpan`. + type Key v + + -- | The `toKey` function extracts a `Key` from the input value. + toKey :: + -- | The input value. + v -> + Key v + + toSpan :: + -- | The configuration. + FullConfig -> + -- | The input value. + v -> + -- | The trace ID. + ByteString -> + -- | The span ID. + ByteString -> + OT.Span + +-------------------------------------------------------------------------------- +-- Interpret capability usage spans + +instance ToSpan CapabilityUsageSpan where + type Key CapabilityUsageSpan = Int + + toKey :: CapabilityUsageSpan -> Int + toKey = (.cap) + + toSpan :: FullConfig -> CapabilityUsageSpan -> ByteString -> ByteString -> OT.Span + toSpan fullConfig i traceId spanId = + messageWith + [ OT.traceId .~ traceId + , OT.spanId .~ spanId + , OT.name .~ C.processorName (.traces) (.capabilityUsage) fullConfig <> " " <> M.showCapabilityUserCategory user + , OT.kind .~ OT.Span'SPAN_KIND_INTERNAL + , OT.startTimeUnixNano .~ i.startTimeUnixNano + , OT.endTimeUnixNano .~ i.endTimeUnixNano + , OT.attributes + .~ mapMaybe + toMaybeKeyValue + [ "capability" ~= i.cap + , "user" ~= user + ] + , OT.status + .~ messageWith + [ OT.code .~ OT.Status'STATUS_CODE_OK + ] + ] + where + user = M.capabilityUser i + +-------------------------------------------------------------------------------- +-- Interpret thread state spans + +instance ToSpan ThreadStateSpan where + type Key ThreadStateSpan = ThreadId + + toKey :: ThreadStateSpan -> ThreadId + toKey = (.thread) + + toSpan :: FullConfig -> ThreadStateSpan -> ByteString -> ByteString -> OT.Span + toSpan fullConfig i traceId spanId = + messageWith + [ OT.traceId .~ traceId + , OT.spanId .~ spanId + , OT.name .~ C.processorName (.traces) (.threadState) fullConfig <> " " <> M.showThreadStateCategory i.threadState + , OT.kind .~ OT.Span'SPAN_KIND_INTERNAL + , OT.startTimeUnixNano .~ i.startTimeUnixNano + , OT.endTimeUnixNano .~ i.endTimeUnixNano + , OT.attributes + .~ mapMaybe + toMaybeKeyValue + [ "capability" ~= M.threadStateCap i.threadState + , "thread" ~= show i.thread + , "status" ~= (show <$> M.threadStateStatus i.threadState) + ] + , OT.status + .~ messageWith + [ OT.code .~ OT.Status'STATUS_CODE_OK + ] + ] diff --git a/src-app/GHC/Eventlog/Live/Otlp/Processor/Heap.hs b/src-app/GHC/Eventlog/Live/Otlp/Processor/Heap.hs new file mode 100644 --- /dev/null +++ b/src-app/GHC/Eventlog/Live/Otlp/Processor/Heap.hs @@ -0,0 +1,189 @@ +{-# LANGUAGE OverloadedStrings #-} + +{- | +Module : GHC.Eventlog.Live.Otlp.Processor.Heap +Description : Heap Event Processors for OTLP. +Stability : experimental +Portability : portable +-} +module GHC.Eventlog.Live.Otlp.Processor.Heap ( + processHeapEvents, +) +where + +import Control.Monad.IO.Class (MonadIO (..)) +import Data.DList (DList) +import Data.Machine (Process, ProcessT, asParts, echo, mapping, (~>)) +import Data.Proxy (Proxy (..)) +import GHC.Eventlog.Live.Logger (Logger) +import GHC.Eventlog.Live.Machine.Analysis.Heap (MemReturnData (..)) +import GHC.Eventlog.Live.Machine.Analysis.Heap qualified as M +import GHC.Eventlog.Live.Machine.Core (Tick) +import GHC.Eventlog.Live.Machine.Core qualified as M +import GHC.Eventlog.Live.Machine.WithStartTime (WithStartTime (..)) +import GHC.Eventlog.Live.Otlp.Config qualified as C +import GHC.Eventlog.Live.Otlp.Config.Types (FullConfig (..)) +import GHC.Eventlog.Live.Otlp.Processor.Common.Core (runIf) +import GHC.Eventlog.Live.Otlp.Processor.Common.Metrics (MetricProcessor (..), asGauge, asSum, runMetricProcessor, viaLast, viaSum) +import GHC.RTS.Events (Event (..), HeapProfBreakdown (..)) +import IpeDB.Database qualified as DB +import IpeDB.Types.InfoProv qualified as IP +import Lens.Family2 ((.~)) +import Proto.Opentelemetry.Proto.Metrics.V1.Metrics qualified as OM +import Proto.Opentelemetry.Proto.Metrics.V1.Metrics_Fields qualified as OM + +-------------------------------------------------------------------------------- +-- processHeapEvents +-------------------------------------------------------------------------------- + +processHeapEvents :: + (MonadIO m) => + Logger m -> + Maybe (DB.Table IP.InfoProvId IP.InfoProv) -> + Maybe HeapProfBreakdown -> + FullConfig -> + ProcessT m (Tick (WithStartTime Event)) (Tick (DList OM.Metric)) +processHeapEvents verbosity maybeInfoProvTable maybeHeapProfBreakdown fullConfig = + M.fanoutTick + [ processHeapAllocated fullConfig + , processBlocksSize fullConfig + , processHeapSize fullConfig + , processHeapLive fullConfig + , processMemReturn fullConfig + , processHeapProfSample verbosity maybeInfoProvTable maybeHeapProfBreakdown fullConfig + ] + +-------------------------------------------------------------------------------- +-- HeapAllocated + +processHeapAllocated :: FullConfig -> Process (Tick (WithStartTime Event)) (Tick (DList OM.Metric)) +processHeapAllocated = + runMetricProcessor + MetricProcessor + { metricProcessorProxy = Proxy @"heapAllocated" + , dataProcessor = M.processHeapAllocatedData + , aggregators = viaSum + , postProcessor = echo + , unit = "By" + , asMetric'Data = + asSum + [ OM.aggregationTemporality .~ OM.AGGREGATION_TEMPORALITY_DELTA + , OM.isMonotonic .~ True + ] + } + +-------------------------------------------------------------------------------- +-- HeapSize + +processHeapSize :: FullConfig -> Process (Tick (WithStartTime Event)) (Tick (DList OM.Metric)) +processHeapSize = + runMetricProcessor + MetricProcessor + { metricProcessorProxy = Proxy @"heapSize" + , dataProcessor = M.processHeapSizeData + , aggregators = viaLast + , postProcessor = echo + , unit = "By" + , asMetric'Data = asGauge + } + +-------------------------------------------------------------------------------- +-- BlocksSize + +processBlocksSize :: FullConfig -> Process (Tick (WithStartTime Event)) (Tick (DList OM.Metric)) +processBlocksSize = + runMetricProcessor + MetricProcessor + { metricProcessorProxy = Proxy @"blocksSize" + , dataProcessor = M.processBlocksSizeData + , aggregators = viaLast + , postProcessor = echo + , unit = "By" + , asMetric'Data = asGauge + } + +-------------------------------------------------------------------------------- +-- HeapLive + +processHeapLive :: FullConfig -> Process (Tick (WithStartTime Event)) (Tick (DList OM.Metric)) +processHeapLive = + runMetricProcessor + MetricProcessor + { metricProcessorProxy = Proxy @"heapLive" + , dataProcessor = M.processHeapLiveData + , aggregators = viaLast + , postProcessor = echo + , unit = "By" + , asMetric'Data = asGauge + } + +-------------------------------------------------------------------------------- +-- MemReturn + +processMemReturn :: FullConfig -> Process (Tick (WithStartTime Event)) (Tick (DList OM.Metric)) +processMemReturn fullConfig = + runIf (shouldComputeMemReturn fullConfig) $ + M.liftTick M.processMemReturnData + ~> M.fanoutTick + [ runMetricProcessor + MetricProcessor + { metricProcessorProxy = Proxy @"memCurrent" + , dataProcessor = mapping (fmap (.current)) + , aggregators = viaLast + , postProcessor = echo + , unit = "{mblock}" + , asMetric'Data = asGauge + } + fullConfig + , runMetricProcessor + MetricProcessor + { metricProcessorProxy = Proxy @"memNeeded" + , dataProcessor = mapping (fmap (.needed)) + , aggregators = viaLast + , postProcessor = echo + , unit = "{mblock}" + , asMetric'Data = asGauge + } + fullConfig + , runMetricProcessor + MetricProcessor + { metricProcessorProxy = Proxy @"memReturned" + , dataProcessor = mapping (fmap (.returned)) + , aggregators = viaLast + , postProcessor = echo + , unit = "{mblock}" + , asMetric'Data = asGauge + } + fullConfig + ] + +{- | +Internal helper. +Determine whether the MemReturn data should be computed. +-} +shouldComputeMemReturn :: FullConfig -> Bool +shouldComputeMemReturn fullConfig = + C.processorEnabled (.metrics) (.memCurrent) fullConfig + || C.processorEnabled (.metrics) (.memNeeded) fullConfig + || C.processorEnabled (.metrics) (.memReturned) fullConfig + +-------------------------------------------------------------------------------- +-- HeapProfSample + +processHeapProfSample :: + (MonadIO m) => + Logger m -> + Maybe (DB.Table IP.InfoProvId IP.InfoProv) -> + Maybe HeapProfBreakdown -> + FullConfig -> + ProcessT m (Tick (WithStartTime Event)) (Tick (DList OM.Metric)) +processHeapProfSample logger maybeInfoProvTable maybeHeapProfBreakdown = + runMetricProcessor + MetricProcessor + { metricProcessorProxy = Proxy @"heapProfSample" + , dataProcessor = M.processHeapProfSampleData logger maybeInfoProvTable maybeHeapProfBreakdown + , aggregators = viaLast + , postProcessor = mapping M.heapProfSamples ~> asParts + , unit = "By" + , asMetric'Data = asGauge + } diff --git a/src-app/GHC/Eventlog/Live/Otlp/Processor/Logs.hs b/src-app/GHC/Eventlog/Live/Otlp/Processor/Logs.hs new file mode 100644 --- /dev/null +++ b/src-app/GHC/Eventlog/Live/Otlp/Processor/Logs.hs @@ -0,0 +1,71 @@ +{- | +Module : GHC.Eventlog.Live.Otlp.Processor.Logs +Description : Log Processors for OTLP. +Stability : experimental +Portability : portable +-} +module GHC.Eventlog.Live.Otlp.Processor.Logs ( + processLogEvents, +) +where + +import Control.Monad.IO.Class (MonadIO (..)) +import Data.DList (DList) +import Data.DList qualified as D +import Data.Machine (Process, ProcessT, mapping, (~>)) +import GHC.Eventlog.Live.Machine.Analysis.Log qualified as M +import GHC.Eventlog.Live.Machine.Analysis.Thread qualified as M +import GHC.Eventlog.Live.Machine.Core (Tick) +import GHC.Eventlog.Live.Machine.Core qualified as M +import GHC.Eventlog.Live.Machine.WithStartTime (WithStartTime (..)) +import GHC.Eventlog.Live.Otlp.Config qualified as C +import GHC.Eventlog.Live.Otlp.Config.Types (FullConfig (..)) +import GHC.Eventlog.Live.Otlp.Processor.Common.Core (runIf) +import GHC.Eventlog.Live.Otlp.Processor.Common.Logs (ToLogRecord (..)) +import GHC.RTS.Events (Event (..)) +import Proto.Opentelemetry.Proto.Logs.V1.Logs qualified as OL + +-------------------------------------------------------------------------------- +-- processLogEvents +-------------------------------------------------------------------------------- + +processLogEvents :: + (MonadIO m) => + FullConfig -> + ProcessT m (Tick (WithStartTime Event)) (Tick (DList OL.LogRecord)) +processLogEvents fullConfig = + M.fanoutTick + [ processThreadLabel fullConfig + , processUserMarker fullConfig + , processUserMessage fullConfig + ] + +-------------------------------------------------------------------------------- +-- UserMessage + +processUserMessage :: FullConfig -> Process (Tick (WithStartTime Event)) (Tick (DList OL.LogRecord)) +processUserMessage fullConfig = + runIf (C.processorEnabled (.logs) (.userMessage) fullConfig) $ + M.liftTick M.processStackFrame'Message + ~> M.liftTick (mapping (D.singleton . toLogRecord)) + ~> M.batchByTicks (C.processorExportBatches (.logs) (.userMessage) fullConfig) + +-------------------------------------------------------------------------------- +-- UserMarker + +processUserMarker :: FullConfig -> Process (Tick (WithStartTime Event)) (Tick (DList OL.LogRecord)) +processUserMarker fullConfig = + runIf (C.processorEnabled (.logs) (.userMarker) fullConfig) $ + M.liftTick M.processUserMarkerData + ~> M.liftTick (mapping (D.singleton . toLogRecord)) + ~> M.batchByTicks (C.processorExportBatches (.logs) (.userMarker) fullConfig) + +-------------------------------------------------------------------------------- +-- ThreadLabel + +processThreadLabel :: FullConfig -> Process (Tick (WithStartTime Event)) (Tick (DList OL.LogRecord)) +processThreadLabel fullConfig = + runIf (C.processorEnabled (.logs) (.threadLabel) fullConfig) $ + M.liftTick M.processThreadLabelData + ~> M.liftTick (mapping (D.singleton . toLogRecord)) + ~> M.batchByTicks (C.processorExportBatches (.logs) (.threadLabel) fullConfig) diff --git a/src-app/GHC/Eventlog/Live/Otlp/Processor/Profiles.hs b/src-app/GHC/Eventlog/Live/Otlp/Processor/Profiles.hs new file mode 100644 --- /dev/null +++ b/src-app/GHC/Eventlog/Live/Otlp/Processor/Profiles.hs @@ -0,0 +1,400 @@ +{-# LANGUAGE OverloadedStrings #-} + +{- | +Module : GHC.Eventlog.Live.Otlp.Processor.Profiles +Description : Profile Processors for OTLP. +Stability : experimental +Portability : portable +-} +module GHC.Eventlog.Live.Otlp.Processor.Profiles ( + -- * Profile processing + Sample (..), + Stack (..), + processProfileEvents, + toProfiles, + + -- * Conversion to OTLP profiles + toExportProfileServiceRequest, + toProfilesData, + toResourceProfiles, + toScopeProfiles, +) +where + +import Control.Monad.IO.Class (MonadIO (..)) +import Control.Monad.Trans.State.Strict (State, StateT (..)) +import Data.Bifunctor (Bifunctor (..)) +import Data.DList (DList) +import Data.DList qualified as D +import Data.Functor.Identity (Identity (..)) +import Data.Int (Int64) +import Data.Machine (ProcessT, mapping, (~>)) +import Data.Maybe (catMaybes) +import Data.Proxy (Proxy (..)) +import Data.Text (Text) +import Data.Text qualified as T +import Data.Vector (Vector) +import Data.Vector qualified as V +import Data.Word (Word32) +import GHC.Eventlog.Live.Data.Attribute (HasAttrs (..), (~=)) +import GHC.Eventlog.Live.Logger (Logger) +import GHC.Eventlog.Live.Machine.Analysis.Profile qualified as M +import GHC.Eventlog.Live.Machine.Core (Tick) +import GHC.Eventlog.Live.Machine.Core qualified as M +import GHC.Eventlog.Live.Machine.WithStartTime (WithStartTime (..)) +import GHC.Eventlog.Live.Otlp.Config qualified as C +import GHC.Eventlog.Live.Otlp.Config.Types (FullConfig (..)) +import GHC.Eventlog.Live.Otlp.Processor.Common.Core +import GHC.Eventlog.Live.Otlp.Processor.Common.ProfilesDictionary (ProfilesDictionary, SymbolIndex) +import GHC.Eventlog.Live.Otlp.Processor.Common.ProfilesDictionary qualified as PD +import GHC.IsList (IsList (..)) +import GHC.RTS.Events (Event (..), Timestamp) +import GHC.Records (HasField) +import IpeDB.Database qualified as DB +import IpeDB.Types.CostCentre qualified as CC +import IpeDB.Types.InfoProv qualified as IP +import IpeDB.Types.SrcLoc (Point (..), SrcLoc (..)) +import Lens.Family2 ((.~), (^.)) +import Proto.Opentelemetry.Proto.Collector.Profiles.V1development.ProfilesService qualified as OPS +import Proto.Opentelemetry.Proto.Common.V1.Common qualified as OC +import Proto.Opentelemetry.Proto.Profiles.V1development.Profiles qualified as OP +import Proto.Opentelemetry.Proto.Profiles.V1development.Profiles_Fields qualified as OP +import Proto.Opentelemetry.Proto.Profiles.V1development.Profiles_Fields qualified as OPS +import Proto.Opentelemetry.Proto.Resource.V1.Resource qualified as OR + +-------------------------------------------------------------------------------- +-- Samples +-------------------------------------------------------------------------------- + +data Sample a = Sample + { name :: !Text + , stack :: !a + } + deriving stock (Show, Functor) + +data Stack + = CostCentreStack !M.CostCentreStack + | CallStack !M.CallStack + deriving (Show) + +processProfileEvents :: + forall m. + (MonadIO m) => + Logger m -> + DB.Table CC.CostCentreId CC.CostCentre -> + DB.Table IP.InfoProvId IP.InfoProv -> + FullConfig -> + ProcessT m (Tick (WithStartTime Event)) (Tick (DList (Sample Stack))) +processProfileEvents logger ccdb ipedb config = + M.fanoutTick + [ processProfSampleCostCentre logger ccdb config + ~> mapping (fmap (fmap (fmap CostCentreStack))) + , processGhcStackProfiler logger ipedb config + ~> mapping (fmap (fmap (fmap CallStack))) + ] + +-------------------------------------------------------------------------------- +-- Processor for `ghc-stack-profiler` call-stack samples +-------------------------------------------------------------------------------- + +processGhcStackProfiler :: + forall m. + (MonadIO m) => + Logger m -> + DB.Table IP.InfoProvId IP.InfoProv -> + FullConfig -> + ProcessT m (Tick (WithStartTime Event)) (Tick (DList (Sample M.CallStack))) +processGhcStackProfiler logger ipedb config = + runIf (C.processorEnabled (.profiles) (.callStackProfile) config) $ + M.liftTick + ( M.processGhcStackProfilerData logger ipedb + ~> mapping (\stack -> D.singleton Sample{..}) + ) + ~> M.batchByTicks (C.processorExportBatches (.profiles) (.callStackProfile) config) + where + !name = C.processorName (.profiles) (.callStackProfile) config + +-------------------------------------------------------------------------------- +-- Processor for cost-centre stack samples +-------------------------------------------------------------------------------- + +processProfSampleCostCentre :: + forall m. + (MonadIO m) => + Logger m -> + DB.Table CC.CostCentreId CC.CostCentre -> + FullConfig -> + ProcessT m (Tick (WithStartTime Event)) (Tick (DList (Sample M.CostCentreStack))) +processProfSampleCostCentre logger ccdb config = + runIf (C.processorEnabled (.profiles) (.costCentreStackProfile) config) $ + M.liftTick + ( M.processProfSampleCostCentreData logger ccdb + ~> mapping (\stack -> D.singleton Sample{..}) + ) + ~> M.batchByTicks (C.processorExportBatches (.profiles) (.costCentreStackProfile) config) + where + !name = C.processorName (.profiles) (.costCentreStackProfile) config + +-------------------------------------------------------------------------------- +-- Translation to OTLP profiles +-------------------------------------------------------------------------------- + +toExportProfileServiceRequest :: OP.ProfilesData -> OPS.ExportProfilesServiceRequest +toExportProfileServiceRequest profilesData = + messageWith + [ OPS.resourceProfiles .~ profilesData ^. OPS.resourceProfiles + , OPS.dictionary .~ profilesData ^. OPS.dictionary + ] + +toProfilesData :: [OP.ResourceProfiles] -> OP.ProfilesDictionary -> Maybe OP.ProfilesData +toProfilesData resourceProfiles dictionary = + ifNonEmpty resourceProfiles $ + messageWith [OP.resourceProfiles .~ resourceProfiles, OP.dictionary .~ dictionary] + +toResourceProfiles :: OR.Resource -> [OP.ScopeProfiles] -> Maybe OP.ResourceProfiles +toResourceProfiles resource scopeProfiles = + ifNonEmpty scopeProfiles $ + messageWith [OP.resource .~ resource, OP.scopeProfiles .~ scopeProfiles] + +toScopeProfiles :: OC.InstrumentationScope -> [OP.Profile] -> Maybe OP.ScopeProfiles +toScopeProfiles instrumentationScope profiles = + ifNonEmpty profiles $ + messageWith [OP.scope .~ instrumentationScope, OP.profiles .~ profiles] + +toProfiles :: [Sample Stack] -> Maybe ([OP.Profile], OP.ProfilesDictionary) +toProfiles samples = ifNonEmpty profiles profilesData + where + (costCentreStacks, callStacks) = partitionSamples samples + + profilesData@(profiles, _) = + second PD.toProfilesDictionary . runIdentity . flip runStateT PD.empty $ do + -- Convert any cost-centre profiles. + maybeCostCentreProfile <- + sequence . ifNonEmpty costCentreStacks $ + getProfile costCentreStacks + -- Convert any call-stack profiles. + maybeCallStackProfiles <- + sequence . ifNonEmpty callStacks $ + getProfile callStacks + pure $ catMaybes [maybeCostCentreProfile, maybeCallStackProfiles] + +partitionSamples :: [Sample Stack] -> ([Sample M.CostCentreStack], [Sample M.CallStack]) +partitionSamples = go ([], []) + where + go :: ([Sample M.CostCentreStack], [Sample M.CallStack]) -> [Sample Stack] -> ([Sample M.CostCentreStack], [Sample M.CallStack]) + go (costCentreStackSamplesRev, callStackSamplesRev) = \case + [] -> (reverse costCentreStackSamplesRev, reverse callStackSamplesRev) + (Sample{stack = CostCentreStack costCentreStack, ..} : rest) -> go (Sample{stack = costCentreStack, ..} : costCentreStackSamplesRev, callStackSamplesRev) rest + (Sample{stack = CallStack callStack, ..} : rest) -> go (costCentreStackSamplesRev, Sample{stack = callStack, ..} : callStackSamplesRev) rest + +-------------------------------------------------------------------------------- +-- Translating profiles to OTLP profiles + +{-# SPECIALIZE getProfile :: + [Sample M.CallStack] -> State ProfilesDictionary OP.Profile + #-} +{-# SPECIALIZE getProfile :: + [Sample M.CostCentreStack] -> State ProfilesDictionary OP.Profile + #-} +getProfile :: + forall m a. + (Monad m, ToSample a) => + [Sample a] -> StateT ProfilesDictionary m OP.Profile +getProfile xs = do + samples <- traverse toSample xs + typeStrindex <- PD.getText (getSampleType (Proxy @a)) + unitStrindex <- PD.getText (getSampleUnit (Proxy @a)) + let sampleType :: OP.ValueType + sampleType = + messageWith + [ OP.typeStrindex .~ typeStrindex + , OP.unitStrindex .~ unitStrindex + ] + let profile :: OP.Profile + profile = + messageWith + [ OP.samples .~ samples + , OP.sampleType .~ sampleType + ] + pure profile + +-------------------------------------------------------------------------------- +-- Translating samples to OTLP samples + +type IsSample a = (IsStack a, HasAttrs a, HasField "maybeTimeUnixNano" a (Maybe Timestamp)) + +class (IsSample a, ToLocation (StackFrame a)) => ToSample a where + getSampleType :: Proxy a -> Text + getSampleUnit :: Proxy a -> Text + + getSampleValue :: a -> Int64 + getSampleValue _x = 1 + {-# INLINE getSampleValue #-} + +{-# SPECIALIZE toSample :: + Sample M.CallStack -> State ProfilesDictionary OP.Sample + #-} +{-# SPECIALIZE toSample :: + Sample M.CostCentreStack -> State ProfilesDictionary OP.Sample + #-} +toSample :: + forall m a. + (Monad m, ToSample a) => + Sample a -> StateT ProfilesDictionary m OP.Sample +toSample x = do + stackIndex <- PD.getStack =<< toStack x.stack + let attrs = "__name__" ~= x.name : toList (getAttrs x.stack) + attributeIndices <- catMaybes <$> traverse PD.getAttr attrs + let sample :: OP.Sample + sample = + messageWith + [ OP.values .~ [getSampleValue x.stack] + , OP.stackIndex .~ stackIndex + , OP.attributeIndices .~ attributeIndices + , OP.timestampsUnixNano .~? sequence [x.stack.maybeTimeUnixNano] + ] + pure sample + +instance ToSample M.CallStack where + getSampleType :: Proxy M.CallStack -> Text + getSampleType _proxy = "cpu" + {-# INLINE getSampleType #-} + + getSampleUnit :: Proxy M.CallStack -> Text + getSampleUnit _proxy = "samples" + {-# INLINE getSampleUnit #-} + +instance ToSample M.CostCentreStack where + getSampleType :: Proxy a -> Text + getSampleType _proxy = "cpu" + {-# INLINE getSampleType #-} + + getSampleUnit :: Proxy a -> Text + getSampleUnit _proxy = "samples" + {-# INLINE getSampleUnit #-} + +-------------------------------------------------------------------------------- +-- Translating stacks to OTLP stacks + +class IsStack a where + type StackFrame a + getStackFrames :: a -> Vector (StackFrame a) + +instance IsStack M.CallStack where + type StackFrame M.CallStack = M.CallStackFrame + getStackFrames :: M.CallStack -> Vector (StackFrame M.CallStack) + getStackFrames = (.callStack) + {-# INLINE getStackFrames #-} + +instance IsStack M.CostCentreStack where + type StackFrame M.CostCentreStack = M.CostCentreStackFrame + getStackFrames :: M.CostCentreStack -> Vector (StackFrame M.CostCentreStack) + getStackFrames = (.costCentreStack) + {-# INLINE getStackFrames #-} + +{-# SPECIALIZE toStack :: + M.CallStack -> State ProfilesDictionary OP.Stack + #-} +{-# SPECIALIZE toStack :: + M.CostCentreStack -> State ProfilesDictionary OP.Stack + #-} +toStack :: + forall m a. + (Monad m, IsStack a, ToLocation (StackFrame a)) => + a -> StateT ProfilesDictionary m OP.Stack +toStack x = do + locationIndices <- traverse toLocation (getStackFrames x) + let stack :: OP.Stack + stack = + messageWith + [ OP.vec'locationIndices .~ V.convert locationIndices + ] + pure stack + +-------------------------------------------------------------------------------- +-- Translating stack frames to OTLP Locations + +class ToLocation a where + toLocation :: + (Monad m) => + a -> StateT ProfilesDictionary m SymbolIndex + +instance ToLocation M.CallStackFrame where + toLocation :: + (Monad m) => + M.CallStackFrame -> StateT ProfilesDictionary m SymbolIndex + toLocation = \case + M.CallStackFrame _infoProvId (Just infoProv) + -- If there's a non-empty ipLabel, use it. + | not (T.null infoProv.ipLabel) -> + toLocation (infoProv.ipModule <> ":" <> infoProv.ipLabel, infoProv.ipSrcLoc) + -- If there's a non-empty ipName, use it. + | not (T.null infoProv.ipName) -> + toLocation (infoProv.ipModule <> ":" <> infoProv.ipName, infoProv.ipSrcLoc) + -- Otherwise, there's no helpful location information. + M.CallStackFrame infoProvId maybeInfoProv -> + let name = T.pack (show infoProvId) + srcLoc = maybe UnhelpfulSrcLoc (.ipSrcLoc) maybeInfoProv + in toLocation (name, srcLoc) + M.CallStackMessage name srcLoc -> toLocation (name, srcLoc) + {-# INLINE toLocation #-} + +instance ToLocation M.CostCentreStackFrame where + toLocation :: + (Monad m) => + M.CostCentreStackFrame -> StateT ProfilesDictionary m SymbolIndex + toLocation = \case + M.CostCentreStackFrame _costCentreId (Just costCentre) + -- If there's a non-empty ccLabel, use it. + | not (T.null costCentre.ccLabel) -> + toLocation (costCentre.ccModule <> ":" <> costCentre.ccLabel, costCentre.ccSrcLoc) + -- Otherwise, there's no helpful location information. + M.CostCentreStackFrame costCentreId maybeCostCentre -> + let name = T.pack (show costCentreId) + srcLoc = maybe UnhelpfulSrcLoc (.ccSrcLoc) maybeCostCentre + in toLocation (name, srcLoc) + {-# INLINE toLocation #-} + +instance ToLocation (Text, SrcLoc) where + toLocation :: + (Monad m) => + (Text, SrcLoc) -> StateT ProfilesDictionary m SymbolIndex + toLocation (name, srcLoc) = do + -- Encode the filename. + filenameStrindex <- + if null srcLoc.srcFilePath + then pure 0 + else PD.getString srcLoc.srcFilePath + + -- Encode the function name. + nameStrindex <- PD.getText name + + -- Encode the start point. + let !maybeStart = (.start) <$> srcLoc.srcRange + let !maybeStartLine = fromIntegral @Word32 @Int64 . (.line) <$> maybeStart + let !maybeStartColumn = fromIntegral @Word32 @Int64 . (.column) <$> maybeStart + + -- Encode the function metadata. + let function :: OP.Function + function = + messageWith + [ OP.nameStrindex .~ nameStrindex + , OP.filenameStrindex .~ filenameStrindex + , OP.startLine .~? maybeStartLine + ] + functionIndex <- PD.getFunction function + + -- Encode the location metadata. + let line :: OP.Line + line = + messageWith + [ OP.functionIndex .~ functionIndex + , OP.line .~? maybeStartLine + , OP.column .~? maybeStartColumn + ] + let location :: OP.Location + location = + messageWith + [ OP.lines .~ [line] + ] + PD.getLocation location diff --git a/src-app/GHC/Eventlog/Live/Otlp/Processor/Threads.hs b/src-app/GHC/Eventlog/Live/Otlp/Processor/Threads.hs new file mode 100644 --- /dev/null +++ b/src-app/GHC/Eventlog/Live/Otlp/Processor/Threads.hs @@ -0,0 +1,151 @@ +{-# LANGUAGE OverloadedStrings #-} + +{- | +Module : GHC.Eventlog.Live.Otlp.Processor.Threads +Description : Thread Event Processors for OTLP. +Stability : experimental +Portability : portable +-} +module GHC.Eventlog.Live.Otlp.Processor.Threads ( + processThreadEvents, +) +where + +import Control.Monad.IO.Class (MonadIO (..)) +import Data.DList (DList) +import Data.DList qualified as D +import Data.Machine (ProcessT, asParts, echo, mapping, (~>)) +import Data.Machine.Fanout (fanout) +import Data.Proxy (Proxy (..)) +import GHC.Eventlog.Live.Logger (Logger) +import GHC.Eventlog.Live.Machine.Analysis.Capability qualified as M +import GHC.Eventlog.Live.Machine.Analysis.Thread qualified as M +import GHC.Eventlog.Live.Machine.Core (Tick) +import GHC.Eventlog.Live.Machine.Core qualified as M +import GHC.Eventlog.Live.Machine.WithStartTime (WithStartTime (..)) +import GHC.Eventlog.Live.Machine.WithStartTime qualified as M +import GHC.Eventlog.Live.Otlp.Config qualified as C +import GHC.Eventlog.Live.Otlp.Config.Types (FullConfig (..)) +import GHC.Eventlog.Live.Otlp.Processor.Common.Core (runIf) +import GHC.Eventlog.Live.Otlp.Processor.Common.Metrics (MetricProcessor (..), asSum, runMetricProcessor, viaSum) +import GHC.Eventlog.Live.Otlp.Processor.Common.Traces (asSpan) +import GHC.RTS.Events (Event (..)) +import Lens.Family2 ((.~)) +import Proto.Opentelemetry.Proto.Metrics.V1.Metrics qualified as OM +import Proto.Opentelemetry.Proto.Metrics.V1.Metrics_Fields qualified as OM +import Proto.Opentelemetry.Proto.Trace.V1.Trace qualified as OT + +data OneOf a b c = A !a | B !b | C !c + +processThreadEvents :: + (MonadIO m) => + Logger m -> + FullConfig -> + ProcessT m (Tick (WithStartTime Event)) (Tick (DList (Either OM.Metric OT.Span))) +processThreadEvents verbosity fullConfig = + runIf (shouldProcessThreadEvents fullConfig) $ + M.sortByTicks (.value.evTime) fullConfig.eventlogFlushIntervalX + ~> M.liftTick + ( fanout + [ M.validateOrder verbosity (.value.evTime) + , runIf (shouldComputeCapabilityUsageSpan fullConfig) $ + M.processGCSpans verbosity + ~> mapping (D.singleton . A) + , runIf (shouldComputeThreadStateSpan fullConfig) $ + M.processThreadStateSpans' M.tryGetTimeUnixNano (.value) M.setWithStartTime'value verbosity + ~> fanout + [ M.asMutatorSpans' (.value) M.setWithStartTime'value + ~> mapping (D.singleton . B) + , mapping (D.singleton . C) + ] + ] + ) + ~> M.liftTick + ( asParts + ~> mapping repackCapabilityUsageSpanOrThreadStateSpan + ) + ~> fanout + [ M.liftTick + ( mapping leftToMaybe + ~> asParts + ) + ~> M.fanoutTick + [ runMetricProcessor + MetricProcessor + { metricProcessorProxy = Proxy @"capabilityUsage" + , dataProcessor = M.processCapabilityUsageMetrics + , aggregators = viaSum + , postProcessor = echo + , unit = "ns" + , asMetric'Data = + asSum + [ OM.aggregationTemporality .~ OM.AGGREGATION_TEMPORALITY_DELTA + , OM.isMonotonic .~ True + ] + } + fullConfig + ~> mapping (fmap (fmap Left)) + , runIf (C.processorEnabled (.traces) (.capabilityUsage) fullConfig) $ + M.liftTick + ( M.dropStartTime + ~> asSpan fullConfig + ~> mapping (D.singleton . Right) + ) + ~> M.batchByTick + ] + , runIf (C.processorEnabled (.traces) (.threadState) fullConfig) $ + M.liftTick + ( mapping rightToMaybe + ~> asParts + ~> asSpan fullConfig + ~> mapping (D.singleton . Right) + ) + ~> M.batchByTick + ] + where + repackCapabilityUsageSpanOrThreadStateSpan = \case + A i -> Left $ fmap Left i + B i -> Left $ fmap Right i + C i -> Right i.value + +{- | +Internal helper. +Get the `Left` value, if any. +-} +leftToMaybe :: Either a b -> Maybe a +leftToMaybe = either Just (const Nothing) + +{- | +Internal helper. +Get the `Right` value, if any. +-} +rightToMaybe :: Either a b -> Maybe b +rightToMaybe = either (const Nothing) Just + +{- | +Internal helper. +Determine whether or not any thread events should be processed at all. +-} +shouldProcessThreadEvents :: FullConfig -> Bool +shouldProcessThreadEvents fullConfig = + C.processorEnabled (.metrics) (.capabilityUsage) fullConfig + || C.processorEnabled (.traces) (.capabilityUsage) fullConfig + || C.processorEnabled (.traces) (.threadState) fullConfig + +{- | +Internal helper. +Determine whether or not the capability usage spans should be computed. +-} +shouldComputeCapabilityUsageSpan :: FullConfig -> Bool +shouldComputeCapabilityUsageSpan fullConfig = + C.processorEnabled (.traces) (.capabilityUsage) fullConfig + || C.processorEnabled (.metrics) (.capabilityUsage) fullConfig + +{- | +Internal helper. +Determine whether or not the thread state spans should be computed. +-} +shouldComputeThreadStateSpan :: FullConfig -> Bool +shouldComputeThreadStateSpan fullConfig = + C.processorEnabled (.traces) (.threadState) fullConfig + || shouldComputeCapabilityUsageSpan fullConfig diff --git a/src-app/GHC/Eventlog/Live/Otlp/Stats.hs b/src-app/GHC/Eventlog/Live/Otlp/Stats.hs new file mode 100644 --- /dev/null +++ b/src-app/GHC/Eventlog/Live/Otlp/Stats.hs @@ -0,0 +1,447 @@ +{-# LANGUAGE OverloadedStrings #-} + +{- | +Module : GHC.Eventlog.Live.Otlp.Stats +Description : The implementation of @eventlog-live-otlp@. +Stability : experimental +Portability : portable +-} +module GHC.Eventlog.Live.Otlp.Stats ( + EventCount, + eventCountTick, + Stat (..), + processStats, +) +where + +import Control.Exception (Exception (..)) +import Control.Monad (when) +import Control.Monad.IO.Class (MonadIO (..)) +import Data.Default (Default (..)) +import Data.Foldable (for_) +import Data.Int (Int64) +import Data.Machine (ProcessT, await, construct, repeatedly, yield) +import Data.Monoid (First (..)) +import Data.Text (Text) +import Data.Text qualified as T +import Data.Text.IO qualified as TIO +import Data.Void (Void) +import GHC.Eventlog.Live.Data.Severity (Severity (..)) +import GHC.Eventlog.Live.Logger (Logger, writeLog) +import GHC.Eventlog.Live.Machine.Core (Tick) +import GHC.Eventlog.Live.Machine.Core qualified as M +import GHC.Eventlog.Live.Otlp.Exporter.Logs (ExportLogsResult (..)) +import GHC.Eventlog.Live.Otlp.Exporter.Metrics (ExportMetricsResult (..)) +import GHC.Eventlog.Live.Otlp.Exporter.Profiles (ExportProfileResult (..)) +import GHC.Eventlog.Live.Otlp.Exporter.Traces (ExportTraceResult (..)) +import GHC.Records (HasField (..)) +import StrictList qualified as Strict +import System.Console.ANSI (hNowSupportsANSI) +import System.Console.ANSI qualified as ANSI +import System.IO qualified as IO +import Text.Layout.Table qualified as TBL +import Text.Printf (printf) + +{- | +This type represents a count of input events. +-} +newtype EventCount + = EventCount {value :: Int64} + deriving (Show) + +{- | +Count the number of events seen between each tick. +-} +eventCountTick :: (Monad m) => ProcessT m (Tick a) (Tick EventCount) +eventCountTick = construct $ go 0 + where + go acc = + await >>= \case + M.Tick -> yield (M.Item $ EventCount acc) >> yield M.Tick >> go 0 + M.Item{} -> go (acc + 1) + +{- | +This type represents the various stats produced by the pipeline. +-} +data Stat + = EventCountStat !EventCount + | ExportLogsResultStat !ExportLogsResult + | ExportMetricsResultStat !ExportMetricsResult + | ExportTraceResultStat !ExportTraceResult + | ExportProfileResultStat !ExportProfileResult + deriving (Show) + +{- | +Internal helper. +This type represents the aggregate stats kept by the stats processor. +-} +data Stats = Stats + { eventCounts :: Row + , exportedLogRecords :: Row + , rejectedLogRecords :: Row + , exportedDataPoints :: Row + , rejectedDataPoints :: Row + , exportedSpans :: Row + , rejectedSpans :: Row + , exportedProfiles :: Row + , rejectedProfiles :: Row + , errors :: !(Strict.List Text) + , displayedLines :: !(First Int) + } + deriving (Show) + +{- | +Internal helper. +This type represents a single row of statistics. +-} +data Row = Row + { total :: !Int64 + , peakRatePerBatch :: !Double + , window :: !(Strict.List Int64) + } + deriving (Show) + +instance HasField "ratePerBatch" Row Double where + getField :: Row -> Double + getField row = ratePerBatch row.window + +{- | +Internal helper. +Computes the rate per batch from a window. +-} +ratePerBatch :: Strict.List Int64 -> Double +ratePerBatch window = + let !n = length window + in if n <= 0 then 0 else sum (realToFrac <$> window) / fromIntegral n + +{- | +Internal helper. +Create a singleton `Row`. +-} +singletonRow :: Int64 -> Row +singletonRow total = Row{..} + where + peakRatePerBatch = realToFrac total + window = singletonStrictList total + +{- | +Internal helper. +This implements the left-biased union of rows. +In @unionRow new old@, the @new@ argument should contain the latest data. +-} +unionRow :: Int -> Row -> Row -> Row +unionRow windowSize new old = Row{..} + where + total = new.total + old.total + window = Strict.take windowSize (new.window <> old.window) + peakRatePerBatch = maximum [new.peakRatePerBatch, old.peakRatePerBatch, ratePerBatch window] + +{- | +Internal helper. +This instance implements the left-biased union of stats. +In @new <> old@, the @new@ argument should contain the latest data. +-} +unionStats :: Int -> Stats -> Stats -> Stats +unionStats windowSize new old = Stats{..} + where + eventCounts = unionRow windowSize new.eventCounts old.eventCounts + exportedLogRecords = unionRow windowSize new.exportedLogRecords old.exportedLogRecords + rejectedLogRecords = unionRow windowSize new.rejectedLogRecords old.rejectedLogRecords + exportedDataPoints = unionRow windowSize new.exportedDataPoints old.exportedDataPoints + rejectedDataPoints = unionRow windowSize new.rejectedDataPoints old.rejectedDataPoints + exportedSpans = unionRow windowSize new.exportedSpans old.exportedSpans + rejectedSpans = unionRow windowSize new.rejectedSpans old.rejectedSpans + exportedProfiles = unionRow windowSize new.exportedProfiles old.exportedProfiles + rejectedProfiles = unionRow windowSize new.rejectedProfiles old.rejectedProfiles + errors = Strict.take windowSize (new.errors <> old.errors) + displayedLines = new.displayedLines <> old.displayedLines + +{- | +Internal helper. +Construct a `Stats` object from an `EventCount`. +-} +fromEventCount :: EventCount -> Stats +fromEventCount eventCount = def{eventCounts = singletonRow eventCount.value} + +{- | +Internal helper. +Construct a `Stats` object from an `ExportLogsResult`. +-} +fromExportLogsResult :: ExportLogsResult -> Stats +fromExportLogsResult exportLogsResult = + def + { exportedLogRecords = singletonRow exportLogsResult.exportedLogRecords + , rejectedLogRecords = singletonRow exportLogsResult.rejectedLogRecords + , errors = maybeToStrictList $ T.pack . displayException <$> exportLogsResult.maybeSomeException + } + +{- | +Internal helper. +Construct a `Stats` object from an `ExportMetricsResult`. +-} +fromExportMetricsResult :: ExportMetricsResult -> Stats +fromExportMetricsResult exportMetricResult = + def + { exportedDataPoints = singletonRow exportMetricResult.exportedDataPoints + , rejectedDataPoints = singletonRow exportMetricResult.rejectedDataPoints + , errors = maybeToStrictList $ T.pack . displayException <$> exportMetricResult.maybeSomeException + } + +{- | +Internal helper. +Construct a `Stats` object from an `ExportTraceResult`. +-} +fromExportTraceResult :: ExportTraceResult -> Stats +fromExportTraceResult exportTracesResult = + def + { exportedSpans = singletonRow exportTracesResult.exportedSpans + , rejectedSpans = singletonRow exportTracesResult.rejectedSpans + , errors = maybeToStrictList $ T.pack . displayException <$> exportTracesResult.maybeSomeException + } + +{- | +Internal helper. +Construct a `Stats` object from an `ExportProfileResult`. +-} +fromExportProfileResult :: ExportProfileResult -> Stats +fromExportProfileResult exportProfileResult = + def + { exportedProfiles = singletonRow exportProfileResult.exportedProfiles + , rejectedProfiles = singletonRow exportProfileResult.rejectedProfiles + , errors = maybeToStrictList $ T.pack . displayException <$> exportProfileResult.maybeSomeException + } + +{- | +Internal helper. +Construct a singleton `Strict.List`. +-} +singletonStrictList :: a -> Strict.List a +singletonStrictList = (`Strict.Cons` Strict.Nil) + +{- | +Internal helper. +Variant of `Data.Maybe.maybeToList` for `Strict.List`. +-} +maybeToStrictList :: Maybe a -> Strict.List a +maybeToStrictList = maybe Strict.Nil singletonStrictList + +{- | +Internal helper. +This instance implements the empty row. +-} +instance Default Row where + def :: Row + def = Row{..} + where + total = 0 + peakRatePerBatch = 0 + window = Strict.Nil + +{- | +Internal helper. +This implements the empty stats. +-} +instance Default Stats where + def :: Stats + def = Stats{..} + where + eventCounts = def + exportedLogRecords = def + rejectedLogRecords = def + exportedDataPoints = def + rejectedDataPoints = def + exportedSpans = def + rejectedSpans = def + exportedProfiles = def + rejectedProfiles = def + errors = mempty + displayedLines = First Nothing + +{- | +Process and display stats. + +__Warning:__ This machine prints to stdout and is intended to be the /only/ function printing to stdout. +-} +processStats :: + Logger IO -> + Bool -> + Double -> + Int -> + ProcessT IO Stat Void +processStats logger stats eventlogFlushIntervalS windowSize + | stats = + -- If --stats is ENABLED, maintain and display `Stats`. + let go stats0 = + await >>= \stat -> do + -- Log the incoming `Stat` value. + liftIO $ logStat logger stat + -- Maintain and display the `Stats`. + let stats1 = updateStats windowSize stats0 stat + stats2 <- liftIO $ displayStats logger eventlogFlushIntervalS stats1 + go stats2 + in construct $ go def + | otherwise = + -- If --stats is DISABLED, log all incoming `Stat` values. + repeatedly $ + await >>= \stat -> + liftIO $ logStat logger stat + +{- | +Internal helper. +Update the current stats based on new input. +-} +updateStats :: Int -> Stats -> Stat -> Stats +updateStats windowSize old = \case + EventCountStat eventCount -> unionStats windowSize (fromEventCount eventCount) old + ExportLogsResultStat exportLogsResults -> unionStats windowSize (fromExportLogsResult exportLogsResults) old + ExportMetricsResultStat exportMetricsResult -> unionStats windowSize (fromExportMetricsResult exportMetricsResult) old + ExportTraceResultStat exportTracesResult -> unionStats windowSize (fromExportTraceResult exportTracesResult) old + ExportProfileResultStat exportProfilesResult -> unionStats windowSize (fromExportProfileResult exportProfilesResult) old + +{- | +Internal helper. +Log a statistic. +-} +logStat :: + Logger IO -> + Stat -> + IO () +logStat logger = \case + EventCountStat eventCount -> + -- Log received events. + when (eventCount.value > 0) $ do + writeLog logger DEBUG $ + "Received " <> showText eventCount.value <> " events." + ExportLogsResultStat exportLogsResult -> do + -- Log exported events. + when (exportLogsResult.exportedLogRecords > 0) $ do + writeLog logger DEBUG $ + "Exported " <> showText exportLogsResult.exportedLogRecords <> " logs." + -- Log rejected events. + when (exportLogsResult.rejectedLogRecords > 0) $ do + writeLog logger ERROR $ + "Rejected " <> showText exportLogsResult.rejectedLogRecords <> " logs." + -- Log exception. + for_ exportLogsResult.maybeSomeException $ \someException -> do + writeLog logger ERROR $ + T.pack $ + displayException someException + ExportMetricsResultStat exportMetricsResult -> do + -- Log exported events. + when (exportMetricsResult.exportedDataPoints > 0) $ do + writeLog logger DEBUG $ + "Exported " <> showText exportMetricsResult.exportedDataPoints <> " metrics." + -- Log rejected events. + when (exportMetricsResult.rejectedDataPoints > 0) $ do + writeLog logger ERROR $ + "Rejected " <> showText exportMetricsResult.rejectedDataPoints <> " metrics." + -- Log exception. + for_ exportMetricsResult.maybeSomeException $ \someException -> do + writeLog logger ERROR $ + T.pack $ + displayException someException + ExportTraceResultStat exportTracesResult -> do + -- Log exported events. + when (exportTracesResult.exportedSpans > 0) $ do + writeLog logger DEBUG $ + "Exported " <> showText exportTracesResult.exportedSpans <> " spans." + -- Log rejected events. + when (exportTracesResult.rejectedSpans > 0) $ do + writeLog logger ERROR $ + "Rejected " <> showText exportTracesResult.rejectedSpans <> " spans." + -- Log exception. + for_ exportTracesResult.maybeSomeException $ \someException -> do + writeLog logger ERROR $ + T.pack $ + displayException someException + ExportProfileResultStat exportProfilesResult -> do + -- Log exported events. + when (exportProfilesResult.exportedProfiles > 0) $ + writeLog logger DEBUG $ + "Exported " <> showText exportProfilesResult.exportedProfiles <> " profiles." + -- Log rejected events. + when (exportProfilesResult.rejectedProfiles > 0) $ + writeLog logger ERROR $ + "Rejected " <> showText exportProfilesResult.rejectedProfiles <> " profiles." + -- Log exception. + for_ exportProfilesResult.maybeSomeException $ \someException -> do + writeLog logger ERROR . T.pack $ displayException someException + +{- | +Internal helper. +Display the current stats. +This is intented to be the *only* function printing to the terminal. + +TODO: The stats printer should only overwrite the numbers. +-} +displayStats :: + Logger IO -> + Double -> + Stats -> + IO Stats +displayStats logger eventlogFlushIntervalS stats = do + -- Check if `displayedLines` is empty... + case stats.displayedLines of + First Nothing -> + -- ...if so, this is the first time this function has been evaluated... + -- ...so we should perform the `warnIfStderrSupportsANSI` check... + warnIfStderrSupportsANSI logger + First (Just numberOfLines) -> do + -- ...if not, we should clear the previous lines of output... + liftIO $ ANSI.cursorUp numberOfLines + liftIO $ ANSI.clearFromCursorToScreenEnd + + -- Compute the moving average count of items _per second_, + -- by computing the adjusted average of counts over n batches. + let rate :: Row -> Text + rate row = T.pack . printf "%0.2f" $ row.ratePerBatch / eventlogFlushIntervalS + let peak :: Row -> Text + peak row = T.pack . printf "%0.0f" $ row.peakRatePerBatch + + let cSpec :: [TBL.ColSpec] + cSpec = [TBL.defColSpec, TBL.defColSpec, TBL.numCol, TBL.numCol, TBL.numCol] + let hSpec :: TBL.HeaderSpec TBL.LineStyle (Maybe Text) + hSpec = TBL.titlesH [Just "Item", Just "Action", Just "Total (item)", Just "Rate (item/s)", Just "Peak (item/x)"] + let mkRow :: Maybe Text -> Maybe Text -> Row -> TBL.RowGroup (Maybe Text) + mkRow item result row = TBL.rowG [item, result, Just (showText row.total), Just (rate row), Just (peak row)] + let rSpec :: [TBL.RowGroup (Maybe Text)] + rSpec = + [ mkRow (Just "Events") (Just "Received") stats.eventCounts + , mkRow (Just "Logs") (Just "Exported") stats.exportedLogRecords + , mkRow Nothing (Just "Rejected") stats.rejectedLogRecords + , mkRow (Just "Metrics") (Just "Exported") stats.exportedDataPoints + , mkRow Nothing (Just "Rejected") stats.rejectedDataPoints + , mkRow (Just "Traces") (Just "Exported") stats.exportedSpans + , mkRow Nothing (Just "Rejected") stats.rejectedSpans + , mkRow (Just "Profiles") (Just "Exported") stats.exportedProfiles + , mkRow Nothing (Just "Rejected") stats.rejectedProfiles + ] + let tSpec :: TBL.TableSpec TBL.LineStyle TBL.LineStyle String (Maybe Text) (Maybe Text) + tSpec = TBL.columnHeaderTableS cSpec TBL.unicodeS hSpec rSpec + let table = TBL.tableLinesB tSpec :: [Text] + for_ table $ \row -> liftIO $ TIO.putStrLn row + pure stats{displayedLines = First (Just $ length table)} + +{- | +Check if `IO.stderr` supports ANSI codes. If it does, it is likely printed to +the same terminal as `IO.stdout`, which causes issues if @--stats@ is enabled. +-} +warnIfStderrSupportsANSI :: + Logger IO -> + IO () +warnIfStderrSupportsANSI logger = do + supportsANSI <- hNowSupportsANSI IO.stderr + when supportsANSI $ do + writeLog logger WARN $ + "When statistics are enabled, stderr should be redirected to a file." + +------------------------------------------------------------------------------- +-- Internal Helpers +------------------------------------------------------------------------------- + +{- | +Internal helper. +Show a value as `Text`. +-} +showText :: (Show a) => a -> Text +showText = T.pack . show diff --git a/src-lib/GHC/Eventlog/Live/Data/Attribute.hs b/src-lib/GHC/Eventlog/Live/Data/Attribute.hs new file mode 100644 --- /dev/null +++ b/src-lib/GHC/Eventlog/Live/Data/Attribute.hs @@ -0,0 +1,193 @@ +{- | +Module : GHC.Eventlog.Live.Attribute +Description : Representation for OTLP attributes. +Stability : experimental +Portability : portable +-} +module GHC.Eventlog.Live.Data.Attribute ( + HasAttrs (..), + Attrs, + lookup, + toList, + Attr, + AttrKey, + AttrValue (..), + IsAttrValue (..), + (~=), +) where + +import Data.HashMap.Strict (HashMap) +import Data.HashMap.Strict qualified as M +import Data.Hashable (Hashable) +import Data.Int (Int16, Int32, Int64, Int8) +import Data.Text (Text) +import Data.Text qualified as T +import Data.Word (Word16, Word32, Word64, Word8) +import GHC.Generics (Generic) +import GHC.IsList (IsList (..)) +import Prelude hiding (lookup) + +{- | +A class for types that have attributes. +-} +class HasAttrs a where + getAttrs :: a -> Attrs + +{- | +A set of attributes is a t`HashMap` +-} +newtype Attrs = Attrs {attrMap :: HashMap AttrKey AttrValue} + deriving (Eq, Generic, Show) + +lookup :: AttrKey -> Attrs -> Maybe AttrValue +lookup attrKey attrs = M.lookup attrKey attrs.attrMap + +instance Hashable Attrs + +instance Semigroup Attrs where + (<>) :: Attrs -> Attrs -> Attrs + x <> y = Attrs{attrMap = x.attrMap <> y.attrMap} + +instance Monoid Attrs where + mempty = Attrs mempty + +instance IsList Attrs where + type Item Attrs = Attr + + fromList :: [Item Attrs] -> Attrs + fromList = Attrs . M.fromList + + toList :: Attrs -> [Item Attrs] + toList = M.toList . (.attrMap) + +{- | +An attribute is a key-value pair where the key is any string and the value is +some numeric type, string, or null. Attributes should be constructed using the +`(~=)` operator, which automatically converts Haskell types to t`AttrValue`. +-} +type Attr = (AttrKey, AttrValue) + +{- | +Construct an t`Attr` as a pair of an t`AttrKey` and an t`AttrValue`, +constructed via the t`IsAttrValue` class. +-} +(~=) :: (IsAttrValue v) => AttrKey -> v -> Attr +k ~= v = (ak, av) + where + !ak = k + !av = toAttrValue v +{-# INLINE (~=) #-} + +{- | +The type of attribute keys. +-} +type AttrKey = + Text + +{- | +The type of attribute values. +-} +data AttrValue + = AttrBool !Bool + | AttrInt !Int + | AttrInt8 !Int8 + | AttrInt16 !Int16 + | AttrInt32 !Int32 + | AttrInt64 !Int64 + | AttrWord !Word + | AttrWord8 !Word8 + | AttrWord16 !Word16 + | AttrWord32 !Word32 + | AttrWord64 !Word64 + | AttrDouble !Double + | AttrText !Text + | AttrNull + deriving (Eq, Generic, Show) + +instance Hashable AttrValue + +{- | +Utility class to help construct values of the t`AttrValue` type. +-} +class IsAttrValue v where + toAttrValue :: v -> AttrValue + +instance IsAttrValue AttrValue where + toAttrValue :: AttrValue -> AttrValue + toAttrValue = id + {-# INLINE toAttrValue #-} + +instance IsAttrValue Bool where + toAttrValue :: Bool -> AttrValue + toAttrValue = AttrBool + {-# INLINE toAttrValue #-} + +instance IsAttrValue Int where + toAttrValue :: Int -> AttrValue + toAttrValue = AttrInt + {-# INLINE toAttrValue #-} + +instance IsAttrValue Int8 where + toAttrValue :: Int8 -> AttrValue + toAttrValue = AttrInt8 + {-# INLINE toAttrValue #-} + +instance IsAttrValue Int16 where + toAttrValue :: Int16 -> AttrValue + toAttrValue = AttrInt16 + {-# INLINE toAttrValue #-} + +instance IsAttrValue Int32 where + toAttrValue :: Int32 -> AttrValue + toAttrValue = AttrInt32 + {-# INLINE toAttrValue #-} + +instance IsAttrValue Int64 where + toAttrValue :: Int64 -> AttrValue + toAttrValue = AttrInt64 + {-# INLINE toAttrValue #-} + +instance IsAttrValue Word where + toAttrValue :: Word -> AttrValue + toAttrValue = AttrWord + {-# INLINE toAttrValue #-} + +instance IsAttrValue Word8 where + toAttrValue :: Word8 -> AttrValue + toAttrValue = AttrWord8 + {-# INLINE toAttrValue #-} + +instance IsAttrValue Word16 where + toAttrValue :: Word16 -> AttrValue + toAttrValue = AttrWord16 + {-# INLINE toAttrValue #-} + +instance IsAttrValue Word32 where + toAttrValue :: Word32 -> AttrValue + toAttrValue = AttrWord32 + {-# INLINE toAttrValue #-} + +instance IsAttrValue Word64 where + toAttrValue :: Word64 -> AttrValue + toAttrValue = AttrWord64 + {-# INLINE toAttrValue #-} + +instance IsAttrValue Double where + toAttrValue :: Double -> AttrValue + toAttrValue = AttrDouble + {-# INLINE toAttrValue #-} + +instance IsAttrValue String where + toAttrValue :: String -> AttrValue + toAttrValue = AttrText . T.pack + {-# INLINE toAttrValue #-} + +instance IsAttrValue Text where + toAttrValue :: Text -> AttrValue + toAttrValue = AttrText + {-# INLINE toAttrValue #-} + +instance (IsAttrValue v) => IsAttrValue (Maybe v) where + toAttrValue :: Maybe v -> AttrValue + toAttrValue = maybe AttrNull toAttrValue + {-# INLINE toAttrValue #-} diff --git a/src-lib/GHC/Eventlog/Live/Data/Capability.hs b/src-lib/GHC/Eventlog/Live/Data/Capability.hs new file mode 100644 --- /dev/null +++ b/src-lib/GHC/Eventlog/Live/Data/Capability.hs @@ -0,0 +1,49 @@ +{- | +Module : GHC.Eventlog.Live.Data.Capability +Description : Reprsentation for capability data. +Stability : experimental +Portability : portable +-} +module GHC.Eventlog.Live.Data.Capability ( + CapNo (..), + evCapNo, + fromCapabilityId, +) where + +import Data.Word (Word16) +import GHC.Eventlog.Live.Data.Attribute (IsAttrValue) +import GHC.RTS.Events (Event (..)) +import GHC.Stack.Profiler.Core.Eventlog (CapabilityId (..)) + +{- | +A capability number. + +In the GHC RTS, all capabilities are assigned a `Word16` identifier. + +In @ghc-events@, the event capability number is received as a `Word16`, +if present, and converted to an `Int`, using @-1@ for global events. + +In @ghc-stack-profiler@, the capability number is added to the event, +and upcast to `Word64`. +-} +newtype CapNo = CapNo + { value :: Word16 + } + deriving (Show, Eq, Ord) + deriving newtype (IsAttrValue) + +{- | +Get the capability number from a @ghc-events@ `Event`. +-} +evCapNo :: Event -> Maybe CapNo +evCapNo ev + | Just cap <- ev.evCap + , 0 <= cap && cap <= fromIntegral @Word16 maxBound = + Just (CapNo $ fromIntegral cap) + | otherwise = Nothing + +{- | +Get the capability number from a @ghc-stack-profiler@ `CapabilityId`. +-} +fromCapabilityId :: CapabilityId -> CapNo +fromCapabilityId (MkCapabilityId cap) = CapNo $ fromIntegral cap diff --git a/src-lib/GHC/Eventlog/Live/Data/Group.hs b/src-lib/GHC/Eventlog/Live/Data/Group.hs new file mode 100644 --- /dev/null +++ b/src-lib/GHC/Eventlog/Live/Data/Group.hs @@ -0,0 +1,82 @@ +{- | +Module : GHC.Eventlog.Live.Data.Group +Description : Reprsentation for grouped data. +Stability : experimental +Portability : portable +-} +module GHC.Eventlog.Live.Data.Group ( + -- * GroupBy + GroupBy (..), + Group (..), + GroupedBy, + singleton, + elems, + groups, +) where + +import Data.HashMap.Strict (HashMap) +import Data.HashMap.Strict qualified as M +import Data.Hashable (Hashable (..)) +import Data.Kind (Type) +import Data.Semigroup (First (..), Last (..), Max (..), Min (..), Product (..), Sum (..)) + +{- | +This class defines the key to group by when aggregating. +-} +class (Hashable (Key a)) => GroupBy a where + type Key a :: Type + toKey :: a -> Key a + +deriving newtype instance (GroupBy a) => GroupBy (First a) +deriving newtype instance (GroupBy a) => GroupBy (Last a) +deriving newtype instance (GroupBy a) => GroupBy (Max a) +deriving newtype instance (GroupBy a) => GroupBy (Min a) +deriving newtype instance (GroupBy a) => GroupBy (Product a) +deriving newtype instance (GroupBy a) => GroupBy (Sum a) + +{- | +This type defines a set of groups, grouped by the key given by `GroupBy`. +-} +data GroupedBy a = (GroupBy a) => GroupedBy + { groups :: HashMap (Key a) (Group a) + } + +{- | +Internal helper. +This type defines a group representative and the group size. +-} +data Group a = Group + { representative :: !a + , size :: !Word + } + deriving (Show, Functor, Foldable, Traversable) + +{- | +Construct the singleton `GroupedBy`. +-} +singleton :: (GroupBy a) => a -> GroupedBy a +singleton a = GroupedBy{groups = M.singleton (toKey a) Group{representative = a, size = 1}} + +{- | +Get all group representatives from a `GroupedBy`. +-} +elems :: GroupedBy a -> [a] +elems = fmap (.representative) . groups + +{- | +Get all group representatives and sizes from a `GroupedBy`. +-} +groups :: GroupedBy a -> [Group a] +groups = M.elems . (.groups) + +instance (Semigroup a) => Semigroup (Group a) where + (<>) :: Group a -> Group a -> Group a + x <> y = + Group + { representative = x.representative <> y.representative + , size = x.size + y.size + } + +instance (Semigroup a, GroupBy a) => Semigroup (GroupedBy a) where + (<>) :: GroupedBy a -> GroupedBy a -> GroupedBy a + x <> y = GroupedBy{groups = M.unionWith (<>) x.groups y.groups} diff --git a/src-lib/GHC/Eventlog/Live/Data/HeapProfBreakdown.hs b/src-lib/GHC/Eventlog/Live/Data/HeapProfBreakdown.hs new file mode 100644 --- /dev/null +++ b/src-lib/GHC/Eventlog/Live/Data/HeapProfBreakdown.hs @@ -0,0 +1,93 @@ +{-# LANGUAGE OverloadedStrings #-} + +{- | +Module : GHC.Eventlog.Live.Data.HeapProfBreakdown +Description : Utilities for GHC heap profiling breakdowns. +Stability : experimental +Portability : portable +-} +module GHC.Eventlog.Live.Data.HeapProfBreakdown ( + HeapProfBreakdown (..), + heapProfBreakdownEitherReader, + heapProfBreakdownShow, + findHeapProfBreakdown, +) where + +import Data.Maybe (listToMaybe, mapMaybe) +import Data.Text (Text) +import Data.Text qualified as T +import GHC.RTS.Events (HeapProfBreakdown (..)) + +{- | +Parses the `HeapProfBreakdown` command-line arguments: + +> heapProfBreakdownEitherReader "T" == Left HeapProfBreakdownClosureType +> heapProfBreakdownEitherReader "c" == Left HeapProfBreakdownCostCentre +> heapProfBreakdownEitherReader "m" == Left HeapProfBreakdownModule +> heapProfBreakdownEitherReader "d" == Left HeapProfBreakdownClosureDescr +> heapProfBreakdownEitherReader "y" == Left HeapProfBreakdownTypeDescr +> heapProfBreakdownEitherReader "e" == Left HeapProfBreakdownEra +> heapProfBreakdownEitherReader "r" == Left HeapProfBreakdownRetainer +> heapProfBreakdownEitherReader "b" == Left HeapProfBreakdownBiography +> heapProfBreakdownEitherReader "i" == Left HeapProfBreakdownInfoTable +-} +heapProfBreakdownEitherReader :: String -> Either String HeapProfBreakdown +heapProfBreakdownEitherReader = + \case + "T" -> Right HeapProfBreakdownClosureType + "c" -> Right HeapProfBreakdownCostCentre + "m" -> Right HeapProfBreakdownModule + "d" -> Right HeapProfBreakdownClosureDescr + "y" -> Right HeapProfBreakdownTypeDescr + "e" -> Right HeapProfBreakdownEra + "r" -> Right HeapProfBreakdownRetainer + "b" -> Right HeapProfBreakdownBiography + "i" -> Right HeapProfBreakdownInfoTable + str -> Left $ "Unsupported heap profile breakdown -h" <> str + +{- | +Shows a `HeapProfBreakdown` as its corresponding command-line flag: + +> heapProfBreakdownShow HeapProfBreakdownClosureType == "-hT" +> heapProfBreakdownShow HeapProfBreakdownCostCentre == "-hc" +> heapProfBreakdownShow HeapProfBreakdownModule == "-hm" +> heapProfBreakdownShow HeapProfBreakdownClosureDescr == "-hd" +> heapProfBreakdownShow HeapProfBreakdownTypeDescr == "-hy" +> heapProfBreakdownShow HeapProfBreakdownEra == "-he" +> heapProfBreakdownShow HeapProfBreakdownRetainer == "-hr" +> heapProfBreakdownShow HeapProfBreakdownBiography == "-hb" +> heapProfBreakdownShow HeapProfBreakdownInfoTable == "-hi" +-} +heapProfBreakdownShow :: HeapProfBreakdown -> String +heapProfBreakdownShow = + ("-h" <>) . \case + HeapProfBreakdownClosureType -> "T" + HeapProfBreakdownCostCentre -> "c" + HeapProfBreakdownModule -> "m" + HeapProfBreakdownClosureDescr -> "d" + HeapProfBreakdownTypeDescr -> "y" + HeapProfBreakdownEra -> "e" + HeapProfBreakdownRetainer -> "r" + HeapProfBreakdownBiography -> "b" + HeapProfBreakdownInfoTable -> "i" + +{- | +Determine the `HeapProfBreakdown` from the list of program arguments. + +__Warning__: This scan is not fully correct. It merely scans for the presence +of arguments that, as a whole, parse with `heapProfBreakdownEitherReader`. +It does not handle @-with-rtsopts@ and does not restrict its search to those +arguments between @+RTS@ and @-RTS@ tags. +-} +findHeapProfBreakdown :: [Text] -> Maybe HeapProfBreakdown +findHeapProfBreakdown = listToMaybe . mapMaybe parseHeapProfBreakdown + where + parseHeapProfBreakdown :: Text -> Maybe HeapProfBreakdown + parseHeapProfBreakdown arg + | "-h" `T.isPrefixOf` arg = + either (const Nothing) Just + . heapProfBreakdownEitherReader + . T.unpack + . T.drop 2 + $ arg + | otherwise = Nothing diff --git a/src-lib/GHC/Eventlog/Live/Data/LogRecord.hs b/src-lib/GHC/Eventlog/Live/Data/LogRecord.hs new file mode 100644 --- /dev/null +++ b/src-lib/GHC/Eventlog/Live/Data/LogRecord.hs @@ -0,0 +1,29 @@ +{- | +Module : GHC.Eventlog.Live.LogRecord +Description : Representation for OTLP log records. +Stability : experimental +Portability : portable +-} +module GHC.Eventlog.Live.Data.LogRecord ( + LogRecord (..), +) where + +import Data.Text (Text) +import GHC.Eventlog.Live.Data.Attribute (Attrs) +import GHC.Eventlog.Live.Data.Severity (Severity) +import GHC.RTS.Events (Timestamp) + +{- | +LogRecords combine a timestamp, message and a severity. +-} +data LogRecord = LogRecord + { body :: !Text + -- ^ The log message. + , maybeTimeUnixNano :: !(Maybe Timestamp) + -- ^ The time at which the log was created. + , maybeSeverity :: !(Maybe Severity) + -- ^ The severity of the log. + , attrs :: Attrs + -- ^ A set of attributes. + } + deriving (Show) diff --git a/src-lib/GHC/Eventlog/Live/Data/Metric.hs b/src-lib/GHC/Eventlog/Live/Data/Metric.hs new file mode 100644 --- /dev/null +++ b/src-lib/GHC/Eventlog/Live/Data/Metric.hs @@ -0,0 +1,135 @@ +{- | +Module : GHC.Eventlog.Live.Metric +Description : Representation for OTLP metrics. +Stability : experimental +Portability : portable +-} +module GHC.Eventlog.Live.Data.Metric ( + Metric (..), + + -- * Existential wrapper + SomeMetric (..), + SMetricType (..), + KnownMetricType (..), +) where + +import Control.Exception (assert) +import Data.Int (Int16, Int32, Int64, Int8) +import Data.Kind (Type) +import Data.Proxy (Proxy) +import Data.Word (Word16, Word32, Word64, Word8) +import GHC.Eventlog.Live.Data.Attribute (Attrs) +import GHC.Eventlog.Live.Data.Group (GroupBy (..)) +import GHC.RTS.Events (Timestamp) + +{- | +Metrics combine a measurement with a timestamp representing the time of the +measurement, a timestamp representing the earliest possible measurement, and +a list of attributes. +-} +data Metric a = Metric + { value :: !a + -- ^ The measurement. + , maybeTimeUnixNano :: !(Maybe Timestamp) + -- ^ The time at which the measurement was taken. + , maybeStartTimeUnixNano :: !(Maybe Timestamp) + {- ^ The earliest time at which any measurement could have been taken. + Usually, this represents the start time of a process. + -} + , attrs :: Attrs + -- ^ A set of attributes. + } + deriving (Functor, Show) + +instance GroupBy (Metric a) where + type Key (Metric a) = Attrs + toKey :: Metric a -> Attrs + toKey = (.attrs) + +instance (Semigroup a) => Semigroup (Metric a) where + (<>) :: Metric a -> Metric a -> Metric a + x <> y = + assert (x.attrs == y.attrs) $ + Metric + { value = x.value <> y.value + , maybeTimeUnixNano = x.maybeTimeUnixNano `max` y.maybeTimeUnixNano + , maybeStartTimeUnixNano = x.maybeStartTimeUnixNano `min` y.maybeStartTimeUnixNano + , attrs = x.attrs + } + +-------------------------------------------------------------------------------- +-- Existential wrapper for Metrics +-------------------------------------------------------------------------------- + +data SomeMetric + = forall metricType. + (KnownMetricType metricType) => + SomeMetric + { metricName :: String + , metric :: Metric metricType + } + +data SMetricType (a :: Type) where + SMetricTypeFloat :: SMetricType Float + SMetricTypeDouble :: SMetricType Double + SMetricTypeWord :: SMetricType Word + SMetricTypeWord8 :: SMetricType Word8 + SMetricTypeWord16 :: SMetricType Word16 + SMetricTypeWord32 :: SMetricType Word32 + SMetricTypeWord64 :: SMetricType Word64 + SMetricTypeInt :: SMetricType Int + SMetricTypeInt8 :: SMetricType Int8 + SMetricTypeInt16 :: SMetricType Int16 + SMetricTypeInt32 :: SMetricType Int32 + SMetricTypeInt64 :: SMetricType Int64 + +class (Num a) => KnownMetricType a where + metricTypeSing :: Proxy a -> SMetricType a + +instance KnownMetricType Float where + metricTypeSing :: Proxy Float -> SMetricType Float + metricTypeSing _proxy = SMetricTypeFloat + +instance KnownMetricType Double where + metricTypeSing :: Proxy Double -> SMetricType Double + metricTypeSing _proxy = SMetricTypeDouble + +instance KnownMetricType Word where + metricTypeSing :: Proxy Word -> SMetricType Word + metricTypeSing _proxy = SMetricTypeWord + +instance KnownMetricType Word8 where + metricTypeSing :: Proxy Word8 -> SMetricType Word8 + metricTypeSing _proxy = SMetricTypeWord8 + +instance KnownMetricType Word16 where + metricTypeSing :: Proxy Word16 -> SMetricType Word16 + metricTypeSing _proxy = SMetricTypeWord16 + +instance KnownMetricType Word32 where + metricTypeSing :: Proxy Word32 -> SMetricType Word32 + metricTypeSing _proxy = SMetricTypeWord32 + +instance KnownMetricType Word64 where + metricTypeSing :: Proxy Word64 -> SMetricType Word64 + metricTypeSing _proxy = SMetricTypeWord64 + +instance KnownMetricType Int where + metricTypeSing :: Proxy Int -> SMetricType Int + metricTypeSing _proxy = SMetricTypeInt + +instance KnownMetricType Int8 where + metricTypeSing :: Proxy Int8 -> SMetricType Int8 + metricTypeSing _proxy = SMetricTypeInt8 + +instance KnownMetricType Int16 where + metricTypeSing :: Proxy Int16 -> SMetricType Int16 + metricTypeSing _proxy = SMetricTypeInt16 + +instance KnownMetricType Int32 where + metricTypeSing :: Proxy Int32 -> SMetricType Int32 + metricTypeSing _proxy = SMetricTypeInt32 + +instance KnownMetricType Int64 where + metricTypeSing :: Proxy Int64 -> SMetricType Int64 + metricTypeSing _proxy = SMetricTypeInt64 diff --git a/src-lib/GHC/Eventlog/Live/Data/Severity.hs b/src-lib/GHC/Eventlog/Live/Data/Severity.hs new file mode 100644 --- /dev/null +++ b/src-lib/GHC/Eventlog/Live/Data/Severity.hs @@ -0,0 +1,84 @@ +{- | +Module : GHC.Eventlog.Live.Severity +Description : Representation for OTLP log record severities. +Stability : experimental +Portability : portable +-} +module GHC.Eventlog.Live.Data.Severity ( + Severity (..), + SeverityNumber (..), + toSeverityNumber, + fromSeverityNumber, + toSeverityString, + fromSeverityString, +) where + +import Data.Char (toUpper) +import Data.Ix (Ix) +import Text.Read (readMaybe) + +{- | +The severity number as specified by the OpenTelemetry specification. + +See: https://opentelemetry.io/docs/specs/otel/logs/data-model/#field-severitynumber +-} +newtype SeverityNumber = SeverityNumber {value :: Int} + +{- | +The severity as specified by the OpenTelemetry specification. + +See: https://opentelemetry.io/docs/specs/otel/logs/data-model/#displaying-severity +-} +data Severity + = TRACE + | TRACE2 + | TRACE3 + | TRACE4 + | DEBUG + | DEBUG2 + | DEBUG3 + | DEBUG4 + | INFO + | INFO2 + | INFO3 + | INFO4 + | WARN + | WARN2 + | WARN3 + | WARN4 + | ERROR + | ERROR2 + | ERROR3 + | ERROR4 + | FATAL + | FATAL2 + | FATAL3 + | FATAL4 + deriving (Bounded, Enum, Eq, Ord, Read, Show, Ix) + +{- | +Convert from a `Severity` to a `SeverityNumber`. +-} +toSeverityNumber :: Severity -> SeverityNumber +toSeverityNumber = SeverityNumber . (+ 1) . fromEnum + +{- | +Convert from a `SeverityNumber` to a `Severity`. +-} +fromSeverityNumber :: SeverityNumber -> Maybe Severity +fromSeverityNumber severityNumber + | 1 <= severityNumber.value && severityNumber.value <= 24 = + Just (toEnum $ severityNumber.value - 1) + | otherwise = Nothing + +{- | +Convert from a `Severity` to a `String`. +-} +toSeverityString :: Severity -> String +toSeverityString = show + +{- | +Convert from a `String` to a `Severity`. +-} +fromSeverityString :: String -> Maybe Severity +fromSeverityString = readMaybe . fmap toUpper diff --git a/src-lib/GHC/Eventlog/Live/Data/Span.hs b/src-lib/GHC/Eventlog/Live/Data/Span.hs new file mode 100644 --- /dev/null +++ b/src-lib/GHC/Eventlog/Live/Data/Span.hs @@ -0,0 +1,25 @@ +{- | +Module : GHC.Eventlog.Live.Span +Description : Representation for OTLP spans. +Stability : experimental +Portability : portable +-} +module GHC.Eventlog.Live.Data.Span ( + IsSpan, + duration, +) where + +import GHC.RTS.Events (Timestamp) +import GHC.Records (HasField) + +{- | +A span is any type with a start and end time. +-} +type IsSpan s = (HasField "startTimeUnixNano" s Timestamp, HasField "endTimeUnixNano" s Timestamp) + +{- | +Determine the duration of a span. +-} +duration :: (IsSpan s) => s -> Timestamp +duration s = if s.startTimeUnixNano < s.endTimeUnixNano then s.endTimeUnixNano - s.startTimeUnixNano else 0 +{-# INLINEABLE duration #-} diff --git a/src-lib/GHC/Eventlog/Live/Data/Thread.hs b/src-lib/GHC/Eventlog/Live/Data/Thread.hs new file mode 100644 --- /dev/null +++ b/src-lib/GHC/Eventlog/Live/Data/Thread.hs @@ -0,0 +1,28 @@ +{- | +Module : GHC.Eventlog.Live.Data.Thread +Description : Reprsentation for thread data. +Stability : experimental +Portability : portable +-} +module GHC.Eventlog.Live.Data.Thread ( + ThreadId (..), +) where + +import Data.Word (Word64) +import GHC.Eventlog.Live.Data.Attribute (IsAttrValue) + +{- | +A thread ID. + +In the GHC RTS, all threads are assigned a `Word64` identifier. +However, thread IDs are posted to the eventlog as `Word32` values. + +In @ghc-events@, the thread ID is received and represented as a `Word32` value. + +In @ghc-stack-profiler@, the thread ID is retrieved and posted as a `Word64` value. +-} +newtype ThreadId = ThreadId + { value :: Word64 + } + deriving stock (Show, Eq, Ord) + deriving newtype (IsAttrValue) diff --git a/src-lib/GHC/Eventlog/Live/Logger.hs b/src-lib/GHC/Eventlog/Live/Logger.hs new file mode 100644 --- /dev/null +++ b/src-lib/GHC/Eventlog/Live/Logger.hs @@ -0,0 +1,250 @@ +{-# LANGUAGE OverloadedLists #-} +{-# LANGUAGE OverloadedStrings #-} + +{- | +Module : GHC.Eventlog.Live..Logger +Description : Logging functions. +Stability : experimental +Portability : portable +-} +module GHC.Eventlog.Live.Logger ( + Logger, + MyTelemetryData (..), + writeLog, + writeException, + writeMetric, + filterBySeverity, + stderrLogger, + handleLogger, + chanLogger, + chanSource, +) where + +import Colog.Core.Action (cfilter, (<&)) +import Colog.Core.Action qualified as CCA (LogAction (..)) +import Control.Concurrent.STM (atomically) +import Control.Concurrent.STM.TChan (TChan, readTChan, writeTChan) +import Control.Exception (Exception (..), bracket_) +import Control.Monad ((<=<)) +import Control.Monad.IO.Class (MonadIO (..)) +import Data.Ix (Ix (..)) +import Data.Machine (SourceT, repeatedly, yield) +import Data.Maybe (isNothing) +import Data.Text (Text) +import Data.Text qualified as T +import Data.Text.IO qualified as TIO +import Data.Text.Lazy qualified as TL +import Data.Text.Lazy.Builder qualified as TLB +import GHC.Eventlog.Live.Data.Attribute (AttrValue (..), (~=)) +import GHC.Eventlog.Live.Data.Attribute qualified as A +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.RTS.Events (Timestamp) +import GHC.Stack (callStack, prettyCallStack, withFrozenCallStack) +import GHC.Stack.Types (HasCallStack) +import System.Clock (Clock (..), TimeSpec (..), getTime) +import System.Console.ANSI (Color (..), ColorIntensity (..), ConsoleLayer (..), SGR (..), hNowSupportsANSI, hSetSGR) +import System.IO qualified as IO +import Prelude hiding (log) + +type Logger m = CCA.LogAction m MyTelemetryData + +{- | +The type of internal telemetry data. +-} +data MyTelemetryData + = MyTelemetryData'LogRecord {logRecord :: !LogRecord} + | MyTelemetryData'Metric {metric :: !SomeMetric} + +{- | +Use a `Logger` to log a message with a severity. +-} +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] + } + } + +{- | +Use a `Logger` to log an exception. +-} +writeException :: (Exception e) => Logger m -> e -> m () +writeException logger e = + writeLog logger ERROR (T.pack $ displayException e) + +{- | +Use a `Logger` to log an internal metric. +-} +writeMetric :: + forall m metricType. + (KnownMetricType metricType) => + Logger m -> + -- | The metric name. + String -> + metricType -> + m () +writeMetric logger metricName value = + logger + <& MyTelemetryData'Metric + SomeMetric + { metricName + , metric = + Metric + { value + , maybeTimeUnixNano = Nothing + , maybeStartTimeUnixNano = Nothing + , attrs = [] + } + } + +{- | +A `Logger` that writes each `LogRecord` to a `IO.stderr` and ignores all other telemetry data. + +__TODO:__ Support the remaining telemetry data. +-} +stderrLogger :: Logger IO +stderrLogger = handleLogger IO.stderr + +{- | +A `Logger` that writes each `LogRecord` to a `IO.Handle` and ignores all other telemetry data. + +__TODO:__ Support the remaining telemetry data. +-} +handleLogger :: + IO.Handle -> + Logger IO +handleLogger handle = CCA.LogAction $ \case + MyTelemetryData'LogRecord logRecord -> liftIO $ do + withSeverityColor logRecord.maybeSeverity handle $ \handleWithColor -> + TIO.hPutStrLn handleWithColor $ formatLogRecord logRecord + IO.hFlush handle + MyTelemetryData'Metric{} -> pure () + +{- | +Filter a @`Logger` m@ by a `Severity`. +-} +filterBySeverity :: + (Applicative m) => + Severity -> + Logger m -> + Logger m +filterBySeverity severityThreshold = + cfilter severityFilter + where + severityFilter = \case + MyTelemetryData'LogRecord{..} -> + maybe False (>= severityThreshold) logRecord.maybeSeverity + _otherwise -> True + +{- | +Internal helper. +Format the message appropriately for the given verbosity level and threshold. +-} +formatLogRecord :: LogRecord -> Text +formatLogRecord logRecord = + TL.toStrict . TLB.toLazyText . mconcat $ + [ -- format the severity + maybe "" (\severity -> "[" <> TLB.fromString (toSeverityString severity) <> "] ") logRecord.maybeSeverity + , -- format the body + TLB.fromText logRecord.body + , -- format the call-stack, if any + case A.lookup "call-stack" logRecord.attrs of + Just (AttrText theCallStack) + | maybe False (>= ERROR) logRecord.maybeSeverity -> + "\n" <> TLB.fromText theCallStack + _otherwise -> "" + ] + +{- | +Internal helper. +Determine the ANSI color and intensity associated with a particular `Severity`. +-} +severityColor :: Severity -> Maybe (Color, ColorIntensity) +severityColor severity + | inRange (TRACE, TRACE4) severity = Just (Blue, Dull) + | inRange (DEBUG, DEBUG4) severity = Just (Blue, Vivid) + | inRange (WARN, WARN4) severity = Just (Yellow, Vivid) + | inRange (ERROR, ERROR4) severity = Just (Red, Dull) + | inRange (FATAL, FATAL4) severity = Just (Red, Vivid) + | otherwise = Nothing + +{- | +Internal helper. +Use a handle with the color set appropriately for the given `Severity`. +-} +withSeverityColor :: Maybe Severity -> IO.Handle -> (IO.Handle -> IO a) -> IO a +withSeverityColor maybeSeverity handle action = do + supportsANSI <- hNowSupportsANSI handle + if not supportsANSI + then + action handle + else case severityColor =<< maybeSeverity of + Nothing -> + action handle + Just (color, intensity) -> do + let setVerbosityColor = hSetSGR handle [SetColor Foreground intensity color] + let setDefaultColor = hSetSGR handle [SetDefaultColor Foreground] + bracket_ setVerbosityColor setDefaultColor $ action handle + +{- | +A `Logger` that writes the internal telemetry data to a channel. +-} +chanLogger :: TChan MyTelemetryData -> Logger IO +chanLogger chan = + CCA.LogAction $ + atomically . writeTChan chan <=< addTimeUnixNano + +{- | +A `Souce` that reads the data from a channel. +-} +chanSource :: (MonadIO m) => TChan a -> SourceT m a +chanSource chan = repeatedly $ do + a <- liftIO $ atomically $ readTChan chan + yield a + +{- | +Add the current Unix timestamp in nanoseconds to telemetry data. +-} +addTimeUnixNano :: MyTelemetryData -> IO MyTelemetryData +addTimeUnixNano myTelemetryData = + case myTelemetryData of + MyTelemetryData'LogRecord{logRecord = LogRecord{..}} + | isNothing maybeTimeUnixNano -> do + timeUnixNano <- getTimeUnixNano + pure $ + MyTelemetryData'LogRecord + LogRecord{maybeTimeUnixNano = Just timeUnixNano, ..} + | otherwise -> pure myTelemetryData + MyTelemetryData'Metric{metric = SomeMetric{metricName, metric = Metric{..}}} + | isNothing maybeTimeUnixNano -> do + timeUnixNano <- getTimeUnixNano + pure $ + MyTelemetryData'Metric + SomeMetric + { metricName + , metric = Metric{maybeTimeUnixNano = Just timeUnixNano, ..} + } + | otherwise -> pure myTelemetryData + +{- | +Get the current Unix time in nanoseconds. + +__Warning:__ This will start overflowing in the year 2554. +-} +getTimeUnixNano :: IO Timestamp +getTimeUnixNano = toNanos <$> getTime Realtime + where + -- NOTE: This will overflow if @t.sec > (2^64 - 1) `div` 10^9@, + -- which means you're running this code in the year 2554. + -- What's that like? + toNanos :: TimeSpec -> Timestamp + toNanos t = 1_000_000_000 * fromIntegral t.sec + fromIntegral t.nsec diff --git a/src-lib/GHC/Eventlog/Live/Machine/Analysis/Capability.hs b/src-lib/GHC/Eventlog/Live/Machine/Analysis/Capability.hs new file mode 100644 --- /dev/null +++ b/src-lib/GHC/Eventlog/Live/Machine/Analysis/Capability.hs @@ -0,0 +1,482 @@ +{-# LANGUAGE OverloadedLists #-} +{-# LANGUAGE OverloadedStrings #-} +{-# OPTIONS_GHC -Wno-name-shadowing #-} + +{- | +Module : GHC.Eventlog.Live.Machine +Description : Machines for processing eventlog data. +Stability : experimental +Portability : portable +-} +module GHC.Eventlog.Live.Machine.Analysis.Capability ( + -- * Capability Usage + + -- ** Capability Usage Metrics + processCapabilityUsageMetrics, + + -- ** Capability Usage Spans + CapabilityUsageSpan, + CapabilityUser (..), + capabilityUser, + showCapabilityUserCategory, + processCapabilityUsageSpans, + processCapabilityUsageSpans', + + -- ** GC Spans + GCSpan (..), + processGCSpans, + processGCSpans', + + -- ** Mutator Spans + MutatorSpan (..), + asMutatorSpans, + asMutatorSpans', + processMutatorSpans, + processMutatorSpans', +) where + +import Control.Monad (when) +import Control.Monad.Trans.Class (MonadTrans (..)) +import Data.Char (isSpace) +import Data.Foldable (for_) +import Data.Machine (Is (..), PlanT, ProcessT, asParts, await, construct, mapping, repeatedly, yield, (~>)) +import Data.Machine.Fanout (fanout) +import Data.Text (Text) +import Data.Text qualified as T +import Data.Void (Void) +import GHC.Eventlog.Live.Data.Attribute (AttrValue, IsAttrValue (..), (~=)) +import GHC.Eventlog.Live.Data.Metric (Metric (..)) +import GHC.Eventlog.Live.Data.Severity (Severity (..)) +import GHC.Eventlog.Live.Data.Span (duration) +import GHC.Eventlog.Live.Logger (Logger, writeLog) +import GHC.Eventlog.Live.Machine.Analysis.Thread (ThreadState (..), ThreadStateSpan (..), processThreadStateSpans') +import GHC.Eventlog.Live.Machine.Core (liftRouter) +import GHC.Eventlog.Live.Machine.WithStartTime (WithStartTime (..), setWithStartTime'value, tryGetTimeUnixNano) +import GHC.RTS.Events (Event (..), EventInfo, ThreadId, Timestamp) +import GHC.RTS.Events qualified as E +import GHC.Records (HasField (..)) +import Text.Printf (printf) + +------------------------------------------------------------------------------- +-- Capability Usage Metrics + +{- | +This machine processes t`CapabilityUsageSpan` spans and produces metrics that +contain the duration and category of each such span and each idle period in +between. +-} +processCapabilityUsageMetrics :: + forall m. + (Monad m) => + ProcessT m (WithStartTime CapabilityUsageSpan) (Metric Timestamp) +processCapabilityUsageMetrics = + liftRouter measure spawn + where + measure :: WithStartTime CapabilityUsageSpan -> Maybe Int + measure = Just . (.value.cap) + + spawn :: Int -> ProcessT m (WithStartTime CapabilityUsageSpan) (Metric Timestamp) + spawn cap = construct $ go Nothing + where + go :: + Maybe CapabilityUsageSpan -> + PlanT (Is (WithStartTime CapabilityUsageSpan)) (Metric Timestamp) m Void + go mi = + await >>= \j -> do + -- If there is a previous span, and... + for_ mi $ \i -> + -- ...the end time of the previous span precedes the start time of the current span, then... + when (i.endTimeUnixNano < j.value.startTimeUnixNano) $ + -- ...yield an idle duration metric. + yield + Metric + { value = j.value.startTimeUnixNano - i.endTimeUnixNano + , maybeTimeUnixNano = Just i.endTimeUnixNano + , maybeStartTimeUnixNano = j.maybeStartTimeUnixNano + , attrs = ["cap" ~= cap, "category" ~= ("Idle" :: Text)] + } + -- Yield a duration metric for the current span. + let user = capabilityUser j.value + yield + Metric + { value = duration j.value + , maybeTimeUnixNano = Just j.value.startTimeUnixNano + , maybeStartTimeUnixNano = j.maybeStartTimeUnixNano + , attrs = ["cap" ~= cap, "category" ~= showCapabilityUserCategory user, "user" ~= user] + } + go (Just j.value) + +{- | +The type of process using a capability, +which is either a mutator thread or garbage collection. +-} +data CapabilityUser + = GC + | Mutator {thread :: !ThreadId} + +instance Show CapabilityUser where + show :: CapabilityUser -> String + show = \case + GC -> "GC" + Mutator{thread} -> show thread + +instance IsAttrValue CapabilityUser where + toAttrValue :: CapabilityUser -> AttrValue + toAttrValue = toAttrValue . show + {-# INLINE toAttrValue #-} + +{- | +Get the t`CapabilityUser` associated with a t`CapabilityUsageSpan`. +-} +capabilityUser :: CapabilityUsageSpan -> CapabilityUser +capabilityUser = either (const GC) (Mutator . (.thread)) + +{- | +Show the category of a `CapabilityUser` as either @"GC"@ or @"Mutator"@. +-} +showCapabilityUserCategory :: CapabilityUser -> Text +showCapabilityUserCategory = \case + GC{} -> "GC" + Mutator{} -> "Mutator" + +------------------------------------------------------------------------------- +-- Capability Usage Spans + +{- | +A t`CapabilityUsageSpan` is either a t`GCSpan` or a t`MutatorSpan`. +-} +type CapabilityUsageSpan = Either GCSpan MutatorSpan + +instance HasField "startTimeUnixNano" CapabilityUsageSpan Timestamp where + getField :: CapabilityUsageSpan -> Timestamp + getField = either (.startTimeUnixNano) (.startTimeUnixNano) + +instance HasField "endTimeUnixNano" CapabilityUsageSpan Timestamp where + getField :: CapabilityUsageSpan -> Timestamp + getField = either (.endTimeUnixNano) (.endTimeUnixNano) + +instance HasField "cap" CapabilityUsageSpan Int where + getField :: CapabilityUsageSpan -> Int + getField = either (.cap) (.cap) + +{-# SPECIALIZE duration :: CapabilityUsageSpan -> Timestamp #-} + +{- | +This machine runs `processGCSpans` and `processMutatorSpans` in parallel and +combines their output. + +This is effectively a fanout of `processGCSpans` and `processMutatorSpans`, the +latter of which runs `processThreadStateSpans` internally. If you are running +`processThreadStateSpans` as well, then using `asMutatorSpans` and constructing +the fanout yourself is more efficient. +-} +processCapabilityUsageSpans :: + forall m. + (Monad m) => + Logger m -> + ProcessT m (WithStartTime Event) (WithStartTime CapabilityUsageSpan) +processCapabilityUsageSpans logger = + processCapabilityUsageSpans' tryGetTimeUnixNano (.value) setWithStartTime'value setWithStartTime'value logger + ~> mapping (either (fmap Left) (fmap Right)) + +{- | +Generalised version of `processCapabilityUsageSpans` that can be adapted to +work on arbitrary types using a getter and a pair of lenses. +-} +processCapabilityUsageSpans' :: + forall m s t1 t2. + (Monad m) => + (s -> Maybe Timestamp) -> + (s -> Event) -> + (s -> GCSpan -> t1) -> + (s -> MutatorSpan -> t2) -> + Logger m -> + ProcessT m s (Either t1 t2) +processCapabilityUsageSpans' timeUnixNano getEvent setGCSpan setMutatorSpan logger = + -- NOTE: + -- Combining this fanout with an `Either` is risky, because it + -- has the potential to lose information if both `processGCSpans` + -- and `processMutatorSpans` yield a value for the same input. + -- However, this shouldn't ever happen, since the two processors + -- process disjoint sets of events. + fanout + [ processGCSpans' timeUnixNano getEvent setGCSpan logger + ~> mapping Left + , processMutatorSpans' timeUnixNano getEvent setMutatorSpan logger + ~> mapping Right + ] + +------------------------------------------------------------------------------- +-- GC spans + +{- | +A t`GCSpan` represents a segment of time during which the specified capability +ran GC. +-} +data GCSpan = GCSpan + { cap :: !Int + , startTimeUnixNano :: !Timestamp + , endTimeUnixNano :: !Timestamp + } + deriving (Show) + +{-# SPECIALIZE duration :: GCSpan -> Timestamp #-} + +{- | +This machine processes `E.StartGC` and `E.EndGC` events to produce t`GCSpan` +values that represent the segments of time a capability spent in GC. + +This processor uses the following finite-state automaton: + +@ + ┌─(EndGC)───┐ + │ ↓ + ┌→[ Idle ]─┐ + │ │ +(EndGC) (StartGC) + │ │ + └─[ GC ]←┘ + ↑ │ + └─(StartGC)─┘ +@ + +The transition from @GC@ to @Idle@ yields a GC span. +-} +processGCSpans :: + forall m. + (Monad m) => + Logger m -> + ProcessT m (WithStartTime Event) (WithStartTime GCSpan) +processGCSpans = + processGCSpans' tryGetTimeUnixNano (.value) setWithStartTime'value + +{- | +Generalised version of `processGCSpans` that can be adapted to work on +arbitrary types using a getter and a lens. +-} +processGCSpans' :: + forall m s t. + (Monad m) => + (s -> Maybe Timestamp) -> + (s -> Event) -> + (s -> GCSpan -> t) -> + Logger m -> + ProcessT m s t +processGCSpans' timeUnixNano getEvent setGCSpan logger = + liftRouter measure spawn + where + getEventTime = (.evTime) . getEvent + getEventInfo = (.evSpec) . getEvent + getEventCap = (.evCap) . getEvent + + measure :: s -> Maybe Int + measure i + | accept (getEventInfo i) = getEventCap i + | otherwise = Nothing + where + accept E.StartGC{} = True + accept E.EndGC{} = True + accept _ = False + + -- TODO: Rewrite using `MealyT` + spawn :: Int -> ProcessT m s t + spawn cap = construct $ go Nothing + where + -- The "mi" variable tracks the previous event for this capability, which + -- is either `Nothing` or `Just` a `StartGC` or a `EndGC` event. + go :: Maybe s -> PlanT (Is s) t m Void + go mi = + -- We start by awaiting the next event "j"... + await >>= \j -> case getEventInfo j of + -- If the next event is a `RunThread` event, and... + E.StartGC{} -> case mi of + Just i + -- If the previous event was a `StartGC` event, then... + | E.StartGC{} <- getEventInfo i -> + -- ...continue with the oldest event. + go (Just $ minBy getEventTime i j) + -- If the previous event was a `EndGC` event, then... + | E.EndGC{} <- getEventInfo i -> + -- ...continue with the current event. + go (Just j) + -- If the previous event was any other event, then... + | otherwise -> do + -- ...emit a warning, and... + let msg = + T.pack $ + printf + "Capability %d: Unsupported trace %s --> %s" + cap + (showEventInfo (getEventInfo i)) + (showEventInfo (getEventInfo j)) + lift $ writeLog logger WARN $ msg + -- ...continue with the previous event. + go (Just i) + -- If there was no previous event, then... + Nothing -> + -- ...continue with the current event. + go (Just j) + -- If the next event is a `StopThread` event... + E.EndGC{} -> case mi of + Just i + -- If the previous event was a `StartGC` event, then... + | E.StartGC{} <- getEventInfo i + , Just startTimeUnixNano <- timeUnixNano i + , Just endTimeUnixNano <- timeUnixNano j -> do + -- ...yield a GC span, and... + yield . setGCSpan j $ GCSpan{..} + -- ...continue with the current event. + go (Just j) + -- If the previous event was a `EndGC` event, then... + | E.EndGC{} <- getEventInfo i -> + -- ...continue with the oldest event. + go (Just $ minBy getEventTime i j) + -- If there was no previous event or it was any other event, then... + _otherwise -> do + -- ...emit a warning, and... + let msg = + T.pack $ + printf + "Capability %d: Unsupported trace %s --> %s" + cap + (maybe "?" (showEventInfo . getEventInfo) mi) + (showEventInfo (getEventInfo j)) + lift $ writeLog logger WARN $ msg + -- ...continue with the previous event. + go mi + -- If the next event is any other event, ignore it. + _otherwise -> go mi + +------------------------------------------------------------------------------- +-- Mutator spans + +{- | +A t`MutatorSpan` represents a segment of time during which the specified +capability ran the specified mutator thread. +-} +data MutatorSpan = MutatorSpan + { cap :: !Int + , thread :: !ThreadId + , startTimeUnixNano :: !Timestamp + , endTimeUnixNano :: !Timestamp + } + deriving (Show) + +{-# SPECIALIZE duration :: MutatorSpan -> Timestamp #-} + +{- | +This machine processes `E.RunThread` and `E.StopThread` events to produce +t`MutatorSpan` values that represent the segments of time a capability spent +executating a mutator. + +This processor uses the following finite-state automaton: + +@ + ┌─(StopThread[X])─┐ + │ ↓ + ┌→[ Idle ]─┐ + │ │ +(StopThread[X]) (RunThread[X]) + │ │ + └─[ Mutator[X] ]←┘ + ↑ │ + └─(RunThread[X])──┘ +@ + +The transition from @Mutator[X]@ to @Idle@ yields a t`MutatorSpan`. +While in the @Mutator[X]@ state, any @RunThread[Y]@ or @StopThread[Y]@ events result in an error. +Furthermore, when a @StopThread[X]@ event with the @ThreadFinished@ status is processed, +the thread @X@ is added to a set of finished threads, +and any further @RunThread[X]@ events for that thread are ignored. +This is done because the GHC RTS frequently emits a @RunThread[X]@ event +immediately after a @StopThread[X]@ event with the @ThreadFinished@ status. + +This runs `processThreadStateSpans` internally. If you are also running +`processThreadStateSpans`, then post-composing it with `asMutatorSpans` +is more efficient. +-} +processMutatorSpans :: + forall m. + (Monad m) => + Logger m -> + ProcessT m (WithStartTime Event) (WithStartTime MutatorSpan) +processMutatorSpans = + processMutatorSpans' tryGetTimeUnixNano (.value) setWithStartTime'value + +{- | +Generalised version of `processMutatorSpans` that can be adapted to work on +arbitrary types using a getter and a lens. +-} +processMutatorSpans' :: + forall m s t. + (Monad m) => + (s -> Maybe Timestamp) -> + (s -> Event) -> + (s -> MutatorSpan -> t) -> + Logger m -> + ProcessT m s t +processMutatorSpans' timeUnixNano getEvent setMutatorSpan logger = + processThreadStateSpans' timeUnixNano getEvent setThreadStateSpan logger ~> asParts + where + setThreadStateSpan :: s -> ThreadStateSpan -> Maybe t + setThreadStateSpan s threadStateSpan = + setMutatorSpan s <$> threadStateSpanToMutatorSpan threadStateSpan + +{- | +This machine converts any `Running` t`ThreadStateSpan` to a t`MutatorSpan`. +-} +asMutatorSpans :: + forall m. + (Monad m) => + ProcessT m ThreadStateSpan MutatorSpan +asMutatorSpans = asMutatorSpans' id (const id) + +{- | +Generalised version of `asMutatorSpans` that can be adapted to work on +arbitrary types using a getter and a lens. +-} +asMutatorSpans' :: + forall m s t. + (Monad m) => + (s -> ThreadStateSpan) -> + (s -> MutatorSpan -> t) -> + ProcessT m s t +asMutatorSpans' getThreadStateSpan setMutatorSpan = repeatedly go + where + go = + await >>= \s -> do + let threadStateSpan = getThreadStateSpan s + let maybeMutatorSpan = threadStateSpanToMutatorSpan threadStateSpan + for_ maybeMutatorSpan $ yield . setMutatorSpan s + +{- | +Convert the `Running` t`ThreadStateSpan` to `Just` a t`MutatorSpan`. +-} +threadStateSpanToMutatorSpan :: ThreadStateSpan -> Maybe MutatorSpan +threadStateSpanToMutatorSpan ThreadStateSpan{..} = + case threadState of + Running{..} -> Just MutatorSpan{..} + _otherwise -> Nothing + +------------------------------------------------------------------------------- +-- Internal Helpers +------------------------------------------------------------------------------- + +{- | +Internal helper. +Show `EventInfo` in a condensed format suitable for logging. +-} +showEventInfo :: EventInfo -> String +showEventInfo = \case + E.RunThread{thread} -> printf "RunThread{%d}" thread + E.StopThread{thread, status} -> printf "StopThread{%d,%s}" thread (E.showThreadStopStatus status) + E.MigrateThread{thread} -> printf "MigrateThread{%d}" thread + E.StartGC{} -> "StartGC" + E.EndGC{} -> "EndGC" + evSpec -> takeWhile (not . isSpace) . show $ evSpec + +{- | +Internal helper. Return the minimal value by some projection. +-} +minBy :: (Ord b) => (a -> b) -> a -> a -> a +minBy f x y = if f x < f y then x else y diff --git a/src-lib/GHC/Eventlog/Live/Machine/Analysis/Heap.hs b/src-lib/GHC/Eventlog/Live/Machine/Analysis/Heap.hs new file mode 100644 --- /dev/null +++ b/src-lib/GHC/Eventlog/Live/Machine/Analysis/Heap.hs @@ -0,0 +1,418 @@ +{-# LANGUAGE OverloadedLists #-} +{-# LANGUAGE OverloadedStrings #-} + +{- | +Module : GHC.Eventlog.Live.Machine.Analysis.Heap +Description : Machines for processing eventlog data. +Stability : experimental +Portability : portable +-} +module GHC.Eventlog.Live.Machine.Analysis.Heap ( + -- * Heap Usage + processHeapAllocatedData, + processHeapSizeData, + processBlocksSizeData, + processHeapLiveData, + MemReturnData (..), + processMemReturnData, + HeapProfSampleData, + heapProfSamples, + processHeapProfSampleData, +) where + +import Control.Monad (unless, when) +import Control.Monad.IO.Class (MonadIO (..)) +import Control.Monad.Trans.Class (MonadTrans (..)) +import Data.Either (isLeft) +import Data.Foldable (for_) +import Data.HashMap.Strict (HashMap) +import Data.HashMap.Strict qualified as M +import Data.List qualified as L +import Data.Machine (Process, ProcessT, await, construct, repeatedly, yield) +import Data.Text (Text) +import Data.Text qualified as T +import Data.Word (Word32, Word64) +import GHC.Eventlog.Live.Data.Attribute (Attrs, (~=)) +import GHC.Eventlog.Live.Data.Group (GroupBy (..)) +import GHC.Eventlog.Live.Data.HeapProfBreakdown (findHeapProfBreakdown, heapProfBreakdownShow) +import GHC.Eventlog.Live.Data.Metric (Metric (..)) +import GHC.Eventlog.Live.Data.Severity (Severity (..)) +import GHC.Eventlog.Live.Logger (Logger, writeLog) +import GHC.Eventlog.Live.Machine.WithStartTime (WithStartTime (..), tryGetTimeUnixNano) +import GHC.RTS.Events (Event (..), HeapProfBreakdown (..)) +import GHC.RTS.Events qualified as E +import IpeDB.Database (Table) +import IpeDB.Database qualified as DB +import IpeDB.Types.InfoProv (InfoProv (..), InfoProvId (..)) +import Text.Printf (printf) +import Text.Read (readMaybe) + +------------------------------------------------------------------------------- +-- Heap events +------------------------------------------------------------------------------- + +-------------------------------------------------------------------------------- +-- HeapAllocated + +{- | +This machine processes `E.HeapAllocated` events into metrics. +-} +processHeapAllocatedData :: Process (WithStartTime Event) (Metric Word64) +processHeapAllocatedData = + repeatedly $ + await >>= \case + i + | E.HeapAllocated{..} <- i.value.evSpec -> + yield $ + metric i allocBytes $ + [ "evCap" ~= i.value.evCap + , "heapCapset" ~= heapCapset + ] + | otherwise -> pure () + +------------------------------------------------------------------------------- +-- HeapSize + +{- | +This machine processes `E.HeapSize` events into metrics. +-} +processHeapSizeData :: Process (WithStartTime Event) (Metric Word64) +processHeapSizeData = repeatedly go + where + go = + await >>= \case + i + | E.HeapSize{..} <- i.value.evSpec -> do + yield $ + metric i sizeBytes $ + [ "evCap" ~= i.value.evCap + , "heapCapset" ~= heapCapset + ] + | otherwise -> pure () + +------------------------------------------------------------------------------- +-- BlocksSize + +{- | +This machine processes `E.BlocksSize` events into metrics. +-} +processBlocksSizeData :: Process (WithStartTime Event) (Metric Word64) +processBlocksSizeData = + repeatedly $ + await >>= \case + i + | E.BlocksSize{..} <- i.value.evSpec -> do + yield $ + metric i blocksSize $ + [ "evCap" ~= i.value.evCap + , "heapCapset" ~= heapCapset + ] + | otherwise -> pure () + +------------------------------------------------------------------------------- +-- HeapLive + +{- | +This machine processes `E.HeapLive` events into metrics. +-} +processHeapLiveData :: Process (WithStartTime Event) (Metric Word64) +processHeapLiveData = + repeatedly $ + await >>= \case + i + | E.HeapLive{..} <- i.value.evSpec -> do + yield $ + metric i liveBytes $ + [ "evCap" ~= i.value.evCap + , "heapCapset" ~= heapCapset + ] + | otherwise -> pure () + +------------------------------------------------------------------------------- +-- MemReturn + +{- | +The type of data associated with a `E.MemReturn` event. +-} +data MemReturnData = MemReturnData + { current :: !Word32 + -- ^ The number of megablocks currently allocated. + , needed :: !Word32 + -- ^ The number of megablocks currently needed. + , returned :: !Word32 + -- ^ The number of megablocks currently being returned to the OS. + } + +{- | +This machine processes `E.MemReturn` events into metrics. +-} +processMemReturnData :: Process (WithStartTime Event) (Metric MemReturnData) +processMemReturnData = + repeatedly $ + await >>= \case + i + | E.MemReturn{..} <- i.value.evSpec -> do + yield $ + metric i MemReturnData{..} $ + [ "evCap" ~= i.value.evCap + , "heapCapset" ~= heapCapset + ] + | otherwise -> pure () + +------------------------------------------------------------------------------- +-- HeapProfSample + +{- | +The type of all heap profile samples from a single garbage collection pass. +-} +newtype HeapProfSampleData = HeapProfSampleData + { heapProfSampleMap :: HashMap Text (Metric Word64) + } + deriving (Show) + deriving newtype (Semigroup, Monoid) + +instance GroupBy HeapProfSampleData where + type Key HeapProfSampleData = () + + toKey :: HeapProfSampleData -> () + toKey = const () + +{- | +Get the elements of a heap profile sample collection. +-} +heapProfSamples :: HeapProfSampleData -> [Metric Word64] +heapProfSamples = M.elems . (.heapProfSampleMap) + +{- | +Internal helper. +Insert a heap profiling sample into the collection. +-} +insertHeapProfSampleString :: + forall m. + (Monad m) => + Logger m -> + Text -> + Metric Word64 -> + HeapProfSampleData -> + m HeapProfSampleData +insertHeapProfSampleString logger heapProfLabel heapProfSample heapProfSampleData = do + let insert :: Maybe (Metric Word64) -> m (Maybe (Metric Word64)) + insert maybeHeapProfSample = do + -- When using -hT profiling, GHC appears to emit the same sample multiple times. + for_ maybeHeapProfSample $ \heapProfSample' -> + -- If the two samples are not the same, this assumption is wrong - warn. + when (heapProfSample'.value /= heapProfSample.value) $ + writeLog logger WARN . T.pack $ + printf + "Duplicate sample for %s within census (old: %d, new: %d)." + (T.unpack heapProfLabel) + heapProfSample'.value + heapProfSample.value + + pure (Just heapProfSample) + heapProfSampleMap' <- M.alterF insert heapProfLabel heapProfSampleData.heapProfSampleMap + pure HeapProfSampleData{heapProfSampleMap = heapProfSampleMap'} + +{- | +Internal helper. +The type of the state kept by `processHeapProfSampleData`. +-} +data HeapProfSampleState = HeapProfSampleState + { eitherShouldWarnOrHeapProfBreakdown :: !(Either Bool HeapProfBreakdown) + , heapProfSampleEraStack :: ![Word64] + , maybeHeapProfSampleData :: !(Maybe HeapProfSampleData) + } + deriving (Show) + +{- | +This machine processes `E.HeapProfSampleString` events into metrics. +Furthermore, it processes the `E.HeapProfBegin` and `E.ProgramArgs` events +to determine the heap profile breakdown, processes `E.InfoTableProv` events to +build an info table map, if necessary, and processes `E.HeapProfSampleBegin` +and `E.HeapProfSampleEnd` events to maintain an era stack. +-} +processHeapProfSampleData :: + (MonadIO m) => + Logger m -> + Maybe (Table InfoProvId InfoProv) -> + Maybe HeapProfBreakdown -> + ProcessT m (WithStartTime Event) HeapProfSampleData +processHeapProfSampleData logger maybeInfoProvTable maybeHeapProfBreakdown = + construct $ + go + HeapProfSampleState + { eitherShouldWarnOrHeapProfBreakdown = maybe (Left True) Right maybeHeapProfBreakdown + , heapProfSampleEraStack = mempty + , maybeHeapProfSampleData = mempty + } + where + -- go :: HeapProfSampleState -> PlanT (Is (WithStartTime Event)) HeapProfSampleData m Void + go st@HeapProfSampleState{..} = do + await >>= \i -> case i.value.evSpec of + -- Announces the heap profile breakdown, amongst other things. + -- This event is only emitted for code compiled with GHC >=9.14. + E.HeapProfBegin{..} + | isLeft eitherShouldWarnOrHeapProfBreakdown -> + go st{eitherShouldWarnOrHeapProfBreakdown = Right heapProfBreakdown} + -- Announces the arguments with which the program was called. + -- This *may* include RTS options, which can be used to determine the + -- heap profile breakdown for code compiled with GHC <9.14. + E.ProgramArgs{..} + | isLeft eitherShouldWarnOrHeapProfBreakdown + , Just heapProfBreakdown <- findHeapProfBreakdown args -> + go st{eitherShouldWarnOrHeapProfBreakdown = Right heapProfBreakdown} + -- Announces the beginning of a heap profile sample. + E.HeapProfSampleBegin{..} -> do + -- Check that maybeHeapProfSampleData is Nothing. + for_ st.maybeHeapProfSampleData $ \heapProfSampleData -> do + let msg = + "Unexpected event HeapProfSampleBegin while previous garbage collection pass was left open.\n\ + \This may indicate that the eventlog is not properly ordered or that its semantics have changed." + lift $ writeLog logger WARN $ msg + + -- Yield the previous sample data anyway. + yield heapProfSampleData + -- Start a new garbage collection pass. + go + st + { heapProfSampleEraStack = heapProfSampleEra : heapProfSampleEraStack + , maybeHeapProfSampleData = Just mempty + } + -- Announces the end of a heap profile sample. + E.HeapProfSampleEnd{..} -> do + -- Yield the previous heap profile sample data + for_ st.maybeHeapProfSampleData yield + -- Pop the heapProfSampleEraStack + heapProfSampleEraStack' <- + case L.uncons heapProfSampleEraStack of + Nothing -> do + let msg = + T.pack $ + printf + "Eventlog closed era %d, but there is no current era." + heapProfSampleEra + lift $ writeLog logger WARN $ msg + pure heapProfSampleEraStack + Just (currentEra, heapProfSampleEraStack') -> do + unless (currentEra == heapProfSampleEra) $ do + let msg = + T.pack $ + printf + "Eventlog closed era %d, but the current era is era %d." + heapProfSampleEra + currentEra + lift $ writeLog logger WARN $ msg + pure heapProfSampleEraStack' + go + st + { heapProfSampleEraStack = heapProfSampleEraStack' + , maybeHeapProfSampleData = Nothing + } + -- Announces a heap profile sample. + E.HeapProfSampleString{..} + -- If there is no heap profile breakdown, issue a warning, then disable warnings. + | Left True <- eitherShouldWarnOrHeapProfBreakdown -> do + let msg = + "Cannot infer heap profile breakdown.\n\ + \ If your binary was compiled with a GHC version prior to 9.14,\n\ + \ you must also pass the heap profile type to this executable.\n\ + \ See: https://gitlab.haskell.org/ghc/ghc/-/commit/76d392a" + lift $ writeLog logger WARN $ msg + go st{eitherShouldWarnOrHeapProfBreakdown = Left False} + -- If the heap profile breakdown is by info table, but the shared info + -- prov table was not provided, issue a warning, then disable warnings. + | Right HeapProfBreakdownInfoTable <- eitherShouldWarnOrHeapProfBreakdown + , Nothing <- maybeInfoProvTable -> do + let msg = + "Heap profile breakdown is " + <> heapProfBreakdownShow HeapProfBreakdownInfoTable + <> ", but no shared InfoProv table was provided." + lift $ writeLog logger WARN $ T.pack msg + go st{eitherShouldWarnOrHeapProfBreakdown = Left False} + -- If the heap profile breakdown is biographical, issue a warning, then disable warnings. + | Right HeapProfBreakdownBiography <- eitherShouldWarnOrHeapProfBreakdown -> do + let msg = + "Unsupported heap profile breakdown " + <> heapProfBreakdownShow HeapProfBreakdownBiography + lift $ writeLog logger WARN $ T.pack msg + go st{eitherShouldWarnOrHeapProfBreakdown = Left False} + -- If there is a heap profile breakdown, handle it appropriately. + | Right heapProfBreakdown <- eitherShouldWarnOrHeapProfBreakdown -> do + -- If the heap profile breakdown is by info table, add the info table. + maybeInfoProv <- + case heapProfBreakdown of + -- NOTE: The case where maybeInfoProvTable is Nothing is handled above. + HeapProfBreakdownInfoTable | Just infoProvTable <- maybeInfoProvTable -> + case readMaybe (T.unpack heapProfLabel) of + Nothing -> do + lift . writeLog logger WARN $ + "Expected InfoProv ID, found '" <> heapProfLabel <> "' for HeapProfSampleString." + pure Nothing + Just infoProvPtr -> do + maybeInfoProv <- liftIO $ DB.lookup infoProvTable infoProvPtr + case maybeInfoProv of + Nothing -> + when (infoProvPtr /= InfoProvId 0) . lift . writeLog logger WARN $ + "Could not resolve IPE for " <> T.pack (show infoProvPtr) <> "." + Just infoProv -> + lift . writeLog logger TRACE $ + "Resolved IPE for " <> T.pack (show infoProvPtr) <> " to " <> infoProv.ipName <> "." + pure maybeInfoProv + _otherwise -> pure Nothing + -- Get the HeapProfSampleData + heapProfSampleData <- + case st.maybeHeapProfSampleData of + Nothing -> do + let msg = + "Unexpected event HeapProfSampleString out of scope of HeapProfSampleBegin and HeapProfSampleEnd.\n\ + \This may indicate that the eventlog is not properly ordered or that its semantics have changed." + lift $ writeLog logger WARN $ msg + pure mempty + Just heapProfSampleData -> + pure heapProfSampleData + -- Update the HeapProfSampleData + let heapProfSample = + metric i heapProfResidency $ + [ "evCap" ~= i.value.evCap + , "heapProfBreakdown" ~= heapProfBreakdownShow heapProfBreakdown + , "heapProfId" ~= heapProfId + , "heapProfLabel" ~= heapProfLabel + , "heapProfSampleEra" ~= (fst <$> L.uncons heapProfSampleEraStack) + , "ipName" ~= fmap (.ipName) maybeInfoProv + , "ipClosureDesc" ~= fmap (.ipClosureDesc) maybeInfoProv + , "ipTyDesc" ~= fmap (.ipTyDesc) maybeInfoProv + , "ipLabel" ~= fmap (.ipLabel) maybeInfoProv + , "ipModule" ~= fmap (.ipModule) maybeInfoProv + , "ipSrcLoc" ~= fmap (show . (.ipSrcLoc)) maybeInfoProv + ] + heapProfSampleData' <- + lift $ insertHeapProfSampleString logger heapProfLabel heapProfSample heapProfSampleData + -- Continue with the updated HeapProfSampleState + go + st + { -- Add the update HeapProfSampleData + maybeHeapProfSampleData = Just heapProfSampleData' + } + _otherwise -> go st + +------------------------------------------------------------------------------- +-- Internal Helpers +------------------------------------------------------------------------------- + +{- | +Internal helper. Construct a t`Metric` from an event with a start time +(t`WithStartTime` t`Event`), together with the measurement and any attributes. +This is a smart constructor that pulls the various timestamps out of the event. +-} +metric :: + WithStartTime Event -> + v -> + Attrs -> + Metric v +metric i v attrs = + Metric + { value = v + , maybeTimeUnixNano = tryGetTimeUnixNano i + , maybeStartTimeUnixNano = i.maybeStartTimeUnixNano + , attrs = attrs + } diff --git a/src-lib/GHC/Eventlog/Live/Machine/Analysis/Log.hs b/src-lib/GHC/Eventlog/Live/Machine/Analysis/Log.hs new file mode 100644 --- /dev/null +++ b/src-lib/GHC/Eventlog/Live/Machine/Analysis/Log.hs @@ -0,0 +1,77 @@ +{-# LANGUAGE OverloadedLists #-} +{-# LANGUAGE OverloadedStrings #-} + +{- | +Module : GHC.Eventlog.Live.Machine.Analysis.Log +Description : Machines for processing eventlog data. +Stability : experimental +Portability : portable +-} +module GHC.Eventlog.Live.Machine.Analysis.Log where + +import Data.Machine (Process, await, repeatedly, yield) +import Data.Text (Text) +import GHC.Eventlog.Live.Data.Attribute (Attrs, (~=)) +import GHC.Eventlog.Live.Data.LogRecord (LogRecord (..)) +import GHC.Eventlog.Live.Data.Severity (Severity (..)) +import GHC.Eventlog.Live.Machine.WithStartTime (WithStartTime (..), tryGetTimeUnixNano) +import GHC.RTS.Events (Event) +import GHC.RTS.Events qualified as E + +-------------------------------------------------------------------------------- +-- UserMessage + +{- | +This machine processes `E.UserMessage` events into logs. +-} +processStackFrame'Message :: Process (WithStartTime Event) LogRecord +processStackFrame'Message = + repeatedly $ + await >>= \case + i + | E.UserMessage{..} <- i.value.evSpec -> + yield $ + logRecord i msg (Just DEBUG) $ + [ "evCap" ~= i.value.evCap + , "kind" ~= ("UserMessage" :: Text) + ] + | otherwise -> pure () + +-------------------------------------------------------------------------------- +-- UserMarker + +{- | +This machine processes `E.UserMarker` events into logs. +-} +processUserMarkerData :: Process (WithStartTime Event) LogRecord +processUserMarkerData = + repeatedly $ + await >>= \case + i + | E.UserMarker{..} <- i.value.evSpec -> + yield $ + logRecord i markername (Just TRACE) $ + [ "evCap" ~= i.value.evCap + , "kind" ~= ("UserMarker" :: Text) + ] + | otherwise -> pure () + +{- | +Internal helper. +Construct a t`LogRecord` from an event with a start time, a message, and any +set of attributes. This is a smart constructor that pulls the timestamps out +of the event. +-} +logRecord :: + WithStartTime Event -> + Text -> + Maybe Severity -> + Attrs -> + LogRecord +logRecord i body maybeSeverity attrs = + LogRecord + { body = body + , maybeTimeUnixNano = tryGetTimeUnixNano i + , maybeSeverity = maybeSeverity + , attrs = attrs + } diff --git a/src-lib/GHC/Eventlog/Live/Machine/Analysis/Profile.hs b/src-lib/GHC/Eventlog/Live/Machine/Analysis/Profile.hs new file mode 100644 --- /dev/null +++ b/src-lib/GHC/Eventlog/Live/Machine/Analysis/Profile.hs @@ -0,0 +1,315 @@ +{-# LANGUAGE OverloadedLists #-} +{-# LANGUAGE OverloadedStrings #-} + +module GHC.Eventlog.Live.Machine.Analysis.Profile ( + -- * Call-stack profiling + CallStack (..), + CallStackFrame (..), + processGhcStackProfilerData, + + -- * Cost-centre profiling + CostCentreStack (..), + CostCentreStackFrame (..), + processProfSampleCostCentreData, +) +where + +import Control.Applicative (Alternative (..)) +import Control.Exception (Exception (..)) +import Control.Monad (unless, when) +import Control.Monad.IO.Class (MonadIO (..)) +import Control.Monad.Trans.Class (MonadTrans (..)) +import Data.ByteString.Lazy qualified as BSL +import Data.List.NonEmpty (NonEmpty ((:|))) +import Data.List.NonEmpty qualified as NE +import Data.Machine (Is, PlanT, ProcessT, await, construct, repeatedly, yield) +import Data.Map.Strict qualified as M +import Data.Maybe (catMaybes, isNothing, mapMaybe) +import Data.Set qualified as S +import Data.Text (Text) +import Data.Text qualified as T +import Data.Text qualified as Text +import Data.Traversable.Compat (mapAccumM) +import Data.Vector (Vector) +import Data.Vector qualified as V +import GHC.Eventlog.Live.Data.Attribute (Attrs, HasAttrs (..), (~=)) +import GHC.Eventlog.Live.Data.Capability (CapNo (..), fromCapabilityId) +import GHC.Eventlog.Live.Data.Severity (Severity (..)) +import GHC.Eventlog.Live.Data.Thread (ThreadId (..)) +import GHC.Eventlog.Live.Logger (Logger, writeLog) +import GHC.Eventlog.Live.Machine.WithStartTime (WithStartTime (..), tryGetTimeUnixNano) +import GHC.RTS.Events (Event (..), Timestamp) +import GHC.RTS.Events qualified as E +import GHC.Stack.Profiler.Core.Eventlog qualified as GSP +import GHC.Stack.Profiler.Core.SymbolTable qualified as GSP +import GHC.Stack.Profiler.Core.ThreadSample qualified as GSP +import IpeDB.Database qualified as DB +import IpeDB.Types.CostCentre (CostCentre (..), CostCentreId (..)) +import IpeDB.Types.InfoProv (InfoProv (..), InfoProvId (..)) +import IpeDB.Types.SrcLoc (Range (..), SrcLoc (..)) + +-------------------------------------------------------------------------------- +-- Processor for `ghc-stack-profiler` call-stack samples +-------------------------------------------------------------------------------- + +{- | +A GHC call-stack as produced by @ghc-stack-profiler@. +-} +data CallStack = CallStack + { capNo :: !CapNo + , threadId :: !ThreadId + , callStack :: !(Vector CallStackFrame) + , maybeTimeUnixNano :: !(Maybe Timestamp) + } + deriving stock (Show) + +instance HasAttrs CallStack where + getAttrs :: CallStack -> Attrs + getAttrs callStack = + [ "capability" ~= callStack.capNo + , "thread" ~= callStack.threadId + ] + +{- | +A GHC call-stack frame as produced by @ghc-stack-profiler@. +-} +data CallStackFrame + = CallStackFrame !InfoProvId !(Maybe InfoProv) + | CallStackMessage !Text !SrcLoc + deriving stock (Show) + +{- | +Internal helper. + +The internal state for `processGhcStackProfilerData`. +-} +data GhcStackProfilerState = GhcStackProfilerState + { warnOnDeserializeError :: !Bool + , callStackChunksRev :: ![GSP.BinaryCallStackMessage] + , maybeTimeUnixNano :: !(Maybe Timestamp) + , symbolTable :: !GSP.IntMapTable + } + +{- | +Internal helper. + +The initial state for `processGhcStackProfilerData`. +-} +emptyGhcStackProfilerState :: GhcStackProfilerState +emptyGhcStackProfilerState = + GhcStackProfilerState + { warnOnDeserializeError = True + , callStackChunksRev = [] + , maybeTimeUnixNano = Nothing + , symbolTable = GSP.emptyIntMapTable + } + +{- | +This machine processes the `E.UserBinaryMessage` events produced by +@ghc-stack-profiler@ into `CallStack` samples. +-} +processGhcStackProfilerData :: + forall m. + (MonadIO m) => + Logger m -> + DB.Table InfoProvId InfoProv -> + ProcessT m (WithStartTime Event) CallStack +processGhcStackProfilerData logger infoProvTable = + construct $ go emptyGhcStackProfilerState + where + go :: GhcStackProfilerState -> PlanT (Is (WithStartTime Event)) CallStack m () + go st = + await >>= \i -> do + case i.value.evSpec of + E.UserBinaryMessage{..} -> do + case GSP.deserializeEventlogMessage (BSL.fromStrict payload) of + Left errMsg + | st.warnOnDeserializeError -> do + lift . writeLog logger WARN . T.unlines $ + [ "Could not parse UserBinaryMessage as ghc-stack-profiler message:" + , T.pack errMsg + , "If other plugins are communicating via binary eventlog messages, this is expected." + ] + go st{warnOnDeserializeError = False} + | otherwise -> go st + -- If we receive the final call-stack chunk, decode and yield the call-stack, the restart... + Right (GSP.CallStackFinal callStackChunk) -> do + let symbolTableReader = GSP.mkIntMapSymbolTableReader st.symbolTable + let callStackChunks = NE.reverse (callStackChunk :| st.callStackChunksRev) + let !maybeTimeUnixNano = st.maybeTimeUnixNano <|> tryGetTimeUnixNano i + callStack <- lift $ decodeCallStack maybeTimeUnixNano symbolTableReader callStackChunks + unless (V.null callStack.callStack) $ yield callStack + go + st + { callStackChunksRev = [] + , maybeTimeUnixNano = Nothing + } + -- If we receive a call-stack chunk, add it to the list of chunks and continue... + Right (GSP.CallStackChunk callStackChunk) -> + go + st + { callStackChunksRev = callStackChunk : st.callStackChunksRev + , maybeTimeUnixNano = st.maybeTimeUnixNano <|> tryGetTimeUnixNano i + } + -- If we receive a string definition, update the symbol table and continue... + Right (GSP.StringDef string) -> do + let !symbolTable' = GSP.insertTextMessage string st.symbolTable + go st{symbolTable = symbolTable'} + -- If we receive a source location definition, update the symbol table and continue... + Right (GSP.SourceLocationDef sourceLocation) -> + case GSP.insertSourceLocationMessage sourceLocation st.symbolTable of + Left errMsg -> do + lift . writeLog logger WARN . T.unlines $ + [ "Could not decode source location from ghc-stack-profiler message:" + , T.pack (displayException errMsg) + ] + go st + Right symbolTable' -> + go st{symbolTable = symbolTable'} + _otherwise -> go st + + decodeCallStack :: + Maybe Timestamp -> + GSP.SymbolTableReader -> + NonEmpty GSP.BinaryCallStackMessage -> + m CallStack + decodeCallStack maybeTimeUnixNano symbolTableReader callStackChunks = do + -- Concatenate the chunks into a full binary call-stack message. + let !gspBinaryCallStack = GSP.catCallStackMessage callStackChunks + + -- Decode the binary call-stack and log any decoding errors. + let !(gspCallStackMessage, decodeErrors) = + GSP.hydrateEventlogCallStackMessage symbolTableReader gspBinaryCallStack + let !gspCallStack = GSP.callStack gspCallStackMessage + unless (null decodeErrors) $ + writeLog logger WARN . T.unlines $ + ["Encountered errors while decoding binary call-stack from ghc-stack-profiler message:"] + <> [T.pack (displayException decodeError) | decodeError <- decodeErrors] + + -- Extract the IPE IDs and look them up in a single batched database query. + let getMaybeInfoProvId :: GSP.StackItem -> Maybe InfoProvId + getMaybeInfoProvId = \case GSP.IpeId iid -> Just (toInfoProvId iid); _otherwise -> Nothing + let infoProvIds = V.fromList . mapMaybe getMaybeInfoProvId $ gspCallStack + maybeInfoProvs <- liftIO $ lookups infoProvTable infoProvIds + + -- Convert each `GSP.StackItem` to a `CallStackFrame`. + let toCallStackFrame :: [Maybe InfoProv] -> GSP.StackItem -> m ([Maybe InfoProv], Maybe CallStackFrame) + toCallStackFrame (maybeInfoProv : acc) (GSP.IpeId iid) = do + when (isNothing maybeInfoProv) $ + writeLog logger WARN $ + "Could not resolve IPE ID " <> T.pack (show (toInfoProvId iid)) + pure (acc, Just $! CallStackFrame (toInfoProvId iid) maybeInfoProv) + toCallStackFrame acc (GSP.UserAnnotation msg maybeSourceLocation) = + pure (acc, Just $! CallStackMessage (T.pack msg) (toSrcLoc maybeSourceLocation)) + toCallStackFrame [] (GSP.IpeId _iid) = do + writeLog logger ERROR $ + "Did not receive enough IPEs to annotate each call-stack item. Please report this as a bug." + pure ([], Nothing) + callStack <- + V.fromList . catMaybes . snd + <$> mapAccumM toCallStackFrame (V.toList maybeInfoProvs) gspCallStack + + let !capNo = fromCapabilityId . GSP.callCapabilityId $ gspCallStackMessage + let !threadId = ThreadId . GSP.callThreadId $ gspCallStackMessage + pure CallStack{..} + +{- | +Internal helper. + +Convert a @ghc-stack-profiler@ `GSP.IpeID` to an `InfoProvId`. +-} +toInfoProvId :: GSP.IpeId -> InfoProvId +toInfoProvId (GSP.MkIpeId x) = InfoProvId x + +{- | +Internal helper. + +Convert a `GSP.SourceLocation` to a `SrcLoc`. +-} +toSrcLoc :: Maybe GSP.SourceLocation -> SrcLoc +toSrcLoc = \case + Nothing -> + UnhelpfulSrcLoc + Just GSP.MkSourceLocation{fileName, column, line} -> + SrcLoc (Text.unpack fileName) (Just $! Range'Point column line) + +-------------------------------------------------------------------------------- +-- Processor for cost-centre stack samples +-------------------------------------------------------------------------------- + +{- | +A GHC cost-centre stack. +-} +data CostCentreStack = CostCentreStack + { capNo :: !CapNo + , costCentreStack :: !(Vector CostCentreStackFrame) + , maybeTimeUnixNano :: !(Maybe Timestamp) + } + deriving stock (Show) + +instance HasAttrs CostCentreStack where + getAttrs :: CostCentreStack -> Attrs + getAttrs costCentreStack = + [ "capability" ~= costCentreStack.capNo + ] + +{- | +A GHC cost-centre stack frame. +-} +data CostCentreStackFrame + = CostCentreStackFrame !CostCentreId !(Maybe CostCentre) + deriving stock (Show) + +{- | +This machine processes `E.ProfSampleCostCentre` events into `CostCentreStack` samples. +-} +processProfSampleCostCentreData :: + forall m. + (MonadIO m) => + Logger m -> + DB.Table CostCentreId CostCentre -> + ProcessT m (WithStartTime Event) CostCentreStack +processProfSampleCostCentreData logger costCentreTable = + repeatedly $ + await >>= \i -> + case i.value.evSpec of + E.ProfSampleCostCentre{..} -> do + -- Look up all cost centre IDs in the cost centre stack. + let !costCentreIds = CostCentreId <$> V.convert profCcsStack + !maybeCostCentres <- liftIO $ lookups costCentreTable costCentreIds + -- NOTE: The following is equivalent to `CostCentreStackFrame`, but + -- logs a warning if the cost centre was not resolved. + let warnIfNotFound costCentreId maybeCostCentre = do + lift . when (isNothing maybeCostCentre) $ do + writeLog logger WARN . T.pack $ + "Could not resolve cost centre ID " <> show costCentreId + pure $ CostCentreStackFrame costCentreId maybeCostCentre + costCentreStack <- V.zipWithM warnIfNotFound costCentreIds maybeCostCentres + + -- Yield the cost centre stack. + let !capNo = CapNo profCap + let !maybeTimeUnixNano = tryGetTimeUnixNano i + yield CostCentreStack{..} + _otherwise -> pure () + +-------------------------------------------------------------------------------- +-- Internal helpers +-------------------------------------------------------------------------------- + +{- | +Variant of `DB.lookups` that deduplicates keys before performing the database lookup. +-} +lookups :: (Ord k, DB.Key k, DB.Value v) => DB.Table k v -> Vector k -> IO (Vector (Maybe v)) +lookups table keys = do + -- Build a set of keys: + let !keysSet = S.fromList (V.toList keys) + if S.size keysSet == V.length keys + then do + -- If all keys are unique, we can just perform the database lookup... + DB.lookups table keys + else do + -- Otherwise, we perform the database lookup with the unique keys and resolve them via a map... + let !keysUniq = V.fromList (S.toAscList keysSet) + maybeValues <- DB.lookups table keysUniq + let !keyValueMap = M.fromAscList . V.toList . V.mapMaybe sequence $ V.zip keysUniq maybeValues + pure $ V.map (`M.lookup` keyValueMap) keys diff --git a/src-lib/GHC/Eventlog/Live/Machine/Analysis/Thread.hs b/src-lib/GHC/Eventlog/Live/Machine/Analysis/Thread.hs new file mode 100644 --- /dev/null +++ b/src-lib/GHC/Eventlog/Live/Machine/Analysis/Thread.hs @@ -0,0 +1,312 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# OPTIONS_GHC -Wno-name-shadowing #-} + +{- | +Module : GHC.Eventlog.Live.Machine.Analysis.Thread +Description : Machines for processing eventlog data. +Stability : experimental +Portability : portable +-} +module GHC.Eventlog.Live.Machine.Analysis.Thread ( + -- * Thread Analysis + + -- ** Thread Labels + ThreadLabel (..), + processThreadLabelData, + + -- ** Thread State Spans + ThreadState (..), + showThreadStateCategory, + threadStateStatus, + threadStateCap, + ThreadStateSpan (..), + processThreadStateSpans, + processThreadStateSpans', +) where + +import Control.Monad.Trans.Class (MonadTrans (..)) +import Data.Char (isSpace) +import Data.Machine (Is (..), PlanT, Process, ProcessT, await, construct, repeatedly, yield) +import Data.Maybe (isNothing) +import Data.Text (Text) +import Data.Text qualified as T +import Data.Void (Void) +import GHC.Eventlog.Live.Data.Severity (Severity (..)) +import GHC.Eventlog.Live.Data.Span (duration) +import GHC.Eventlog.Live.Logger (Logger, writeLog) +import GHC.Eventlog.Live.Machine.Core (liftRouter) +import GHC.Eventlog.Live.Machine.WithStartTime (WithStartTime (..), tryGetTimeUnixNano) +import GHC.RTS.Events (Event (..), EventInfo, ThreadId, ThreadStopStatus (..), Timestamp) +import GHC.RTS.Events qualified as E +import Text.Printf (printf) + +------------------------------------------------------------------------------- +-- Thread Labels + +{- | +The t`ThreadLabel` type represents the association of a label with a thread +starting at a given time. +-} +data ThreadLabel + = ThreadLabel + { thread :: !ThreadId + , threadlabel :: !Text + , startTimeUnixNano :: !Timestamp + } + +{- | +This machine processes `E.ThreadLabel` events and yields t`ThreadLabel` values. +-} +processThreadLabelData :: Process (WithStartTime Event) ThreadLabel +processThreadLabelData = repeatedly go + where + go = + await >>= \i -> case i.value.evSpec of + E.ThreadLabel{..} + | Just startTimeUnixNano <- tryGetTimeUnixNano i -> + yield ThreadLabel{..} + _otherwise -> pure () + +------------------------------------------------------------------------------- +-- Thread State Spans + +{- | +The execution states of a mutator thread. +-} +data ThreadState + = Running {cap :: !Int} + | Blocked {status :: !ThreadStopStatus} + | Finished + deriving (Show) + +{- | +Pretty-print a thread state as "Running", "Blocked", or "Finished". +-} +showThreadStateCategory :: ThreadState -> Text +showThreadStateCategory = \case + Running{} -> "Running" + Blocked{} -> "Blocked" + Finished{} -> "Finished" + +{- | +Get the t`ThreadState` status, if the t`ThreadState` is `Blocked`. +-} +threadStateStatus :: ThreadState -> Maybe ThreadStopStatus +threadStateStatus = \case + Running{} -> Nothing + Blocked{status} -> Just status + Finished{} -> Nothing + +{- | +Get the t`ThreadState` capability, if the `ThreadState` is `Running`. +-} +threadStateCap :: ThreadState -> Maybe Int +threadStateCap = \case + Running{cap} -> Just cap + Blocked{} -> Nothing + Finished{} -> Nothing + +{- | +A span representing the state of a mutator thread. +-} +data ThreadStateSpan + = ThreadStateSpan + { thread :: !ThreadId + , threadState :: !ThreadState + , startTimeUnixNano :: !Timestamp + , endTimeUnixNano :: !Timestamp + } + deriving (Show) + +{-# SPECIALIZE duration :: ThreadStateSpan -> Timestamp #-} + +{- | +This machine processes `E.RunThread` and `E.StopThread` events to produce +t`ThreadStateSpan` values that represent segments of time where a thread is +running, blocked, or finished. + +This processor uses the following finite-state automaton: + +@ + ┌─(StopThread)─┐ + │ ↓ + ┌→[ Blocked ]─┐ + │ │ +(StopThread) (RunThread) + │ │ + └─[ Running ]←┘ + ↑ │ + └─(RunThread)──┘ +@ + +The transitions from @Blocked@ to @Blocked@, @Blocked@ to @Running@, and +@Running@ to @Running@ yield a t`ThreadStateSpan`. There are additional +transitions (not pictured) from either state to the final `Finished` state +with a `E.StopThread` event with the `ThreadFinished` status. +-} +processThreadStateSpans :: + (Monad m) => + Logger m -> + ProcessT m (WithStartTime Event) ThreadStateSpan +processThreadStateSpans = + processThreadStateSpans' tryGetTimeUnixNano (.value) (const id) + +{- | +Generalised version of `processThreadStateSpans` that can be adapted to work +on arbitrary types using a getter and a lens. +-} +processThreadStateSpans' :: + forall m s t. + (Monad m) => + (s -> Maybe Timestamp) -> + (s -> Event) -> + (s -> ThreadStateSpan -> t) -> + Logger m -> + ProcessT m s t +processThreadStateSpans' timeUnixNano getEvent setThreadStateSpan logger = + liftRouter measure spawn + where + getEventTime = (.evTime) . getEvent + getEventInfo = (.evSpec) . getEvent + getEventCap = (.evCap) . getEvent + + measure :: s -> Maybe ThreadId + measure i = case getEventInfo i of + E.RunThread{thread} -> Just thread + E.StopThread{thread} -> Just thread + _otherwise -> Nothing + + spawn :: ThreadId -> ProcessT m s t + spawn thread = construct $ go Nothing + where + go :: Maybe s -> PlanT (Is s) t m Void + go mi = + await >>= \case + j + -- If the previous event was a `E.StopThread` event, and... + | Just E.StopThread{status} <- getEventInfo <$> mi + , --- ...it has the `ThreadFinished` status, then... + isThreadFinished status -> + -- ...ignore the current event. + go mi + -- + -- If the current event is a `E.RunThread` event, and... + | E.RunThread{} <- getEventInfo j + , -- ...the previous event was a `E.StopThread` event, then... + Just E.StopThread{status} <- getEventInfo <$> mi + , -- ...gather the end time of the previous event, and... + Just startTimeUnixNano <- timeUnixNano =<< mi + , -- ...gather the start time of the current event, and... + Just endTimeUnixNano <- timeUnixNano j -> do + -- ...yield a thread state span, and... + yield . setThreadStateSpan j $ + ThreadStateSpan{threadState = Blocked status, ..} + go (Just j) + -- + -- If the current event is a `E.RunThread` event, and... + | E.RunThread{} <- getEventInfo j + , -- ...the previous event was a `E.RunThread` event, then... + Just E.RunThread{} <- getEventInfo <$> mi -> do + -- ...keep the oldest event. + go (Just $ maybe j (minBy getEventTime j) mi) + -- + -- If the current event is a `E.RunThread` event, and... + | E.RunThread{} <- getEventInfo j + , -- ...there is no previous event, then... + isNothing mi -> + -- ...keep the current event. + -- + -- The reason for the additional `isNothing` test is because, + -- otherwise, this case might silently swallow any `E.StopThread` + -- events for which `timeUnixNano` gives `Nothing`. + -- By excluding these, they are forwarded to the catch-all case. + go (Just j) + -- + -- If the current event is a `E.StopThread` event, and... + | E.StopThread{} <- getEventInfo j + , -- ...the previous event was a `E.StopThread` event, then... + Just E.StopThread{status} <- getEventInfo <$> mi + , -- ...gather the end time of the previous event, and... + Just startTimeUnixNano <- timeUnixNano =<< mi + , -- ...gather the start time of the current event, and... + Just endTimeUnixNano <- timeUnixNano j -> do + -- ...yield a thread state span, and... + yield . setThreadStateSpan j $ + ThreadStateSpan{threadState = Blocked status, ..} + -- ...keep the current event. + -- + -- This causes us to adopt every `E.StopThread` event, until + -- we hit a `E.StopThread` event with the `ThreadFinished`, at + -- which point the first clause will cause us to stick with it. + go (Just j) + -- + -- If the current event is a `E.StopThread` event, and... + | E.StopThread{} <- getEventInfo j + , -- ...the previous event was a `E.RunThread` event, then... + Just E.RunThread{} <- getEventInfo <$> mi + , -- ...gather the capability of the `E.RunThread` event, and... + Just cap <- getEventCap =<< mi + , -- ...gather the end time of the previous event, and... + Just startTimeUnixNano <- timeUnixNano =<< mi + , -- ...gather the start time of the current event, and... + Just endTimeUnixNano <- timeUnixNano j -> do + -- ...yield a thread state span, and... + yield . setThreadStateSpan j $ + ThreadStateSpan{threadState = Running cap, ..} + -- ...keep the current event. + go (Just j) + -- + -- If the current event is any other event, then... + | otherwise -> do + -- ...emit a warning, and... + let msg = + T.pack $ + printf + "Thread %d: Unexpected event %s\n\ + \This happens once per running thread when connecting to a running process,\n\ + \but should not happen multiple times per thread." + thread + (showEventInfo (getEventInfo j)) + lift $ writeLog logger WARN $ msg + + -- + -- This case may trigger for any event that isn't `E.RunThread` + -- or `E.StopThread` and for any `E.StopThread` event that comes + -- before the first `E.RunThread` event. It may also trigger for + -- any event for which `timeUnixNano` returns `Nothing`. + -- + -- ...ignore it. + go mi + +------------------------------------------------------------------------------- +-- Internal Helpers +------------------------------------------------------------------------------- + +{- | +Internal helper. +Check whether a t`ThreadStopStatus` is equal to `ThreadFinished`. +This is needed because t`ThreadStopStatus` does not define an `Eq` instance. +-} +isThreadFinished :: ThreadStopStatus -> Bool +isThreadFinished = \case + ThreadFinished -> True + _otherwise -> False + +{- | +Internal helper. +Show `EventInfo` in a condensed format suitable for logging. +-} +showEventInfo :: EventInfo -> String +showEventInfo = \case + E.RunThread{thread} -> printf "RunThread{%d}" thread + E.StopThread{thread, status} -> printf "StopThread{%d,%s}" thread (E.showThreadStopStatus status) + E.MigrateThread{thread} -> printf "MigrateThread{%d}" thread + E.StartGC{} -> "StartGC" + E.EndGC{} -> "EndGC" + evSpec -> takeWhile (not . isSpace) . show $ evSpec + +{- | +Internal helper. Return the minimal value by some projection. +-} +minBy :: (Ord b) => (a -> b) -> a -> a -> a +minBy f x y = if f x < f y then x else y diff --git a/src-lib/GHC/Eventlog/Live/Machine/Core.hs b/src-lib/GHC/Eventlog/Live/Machine/Core.hs new file mode 100644 --- /dev/null +++ b/src-lib/GHC/Eventlog/Live/Machine/Core.hs @@ -0,0 +1,836 @@ +{-# LANGUAGE ImplicitParams #-} +{-# LANGUAGE OverloadedStrings #-} + +{- | +Module : GHC.Eventlog.Live.Machine.Core +Description : Core machines for processing data in batches. +Stability : experimental +Portability : portable +-} +module GHC.Eventlog.Live.Machine.Core ( + -- * Ticks + TickInfo (..), + HasTickInfo, + Tick (Item, Tick, TickWithInfo, tickInfo), + fanoutTick, + fanoutTickCC, + mergeWithTickCC, + batchByTickList, + batchByTicksList, + batchByTick, + batchByTicks, + dropTick, + onlyTick, + liftTick, + + -- * Machine combinators + (&>), + embed, + + -- * Routers + liftRouter, + + -- * Event sorting + sortByBatch, + sortByTick, + sortByTicks, + + -- * Delimiting + delimit, + betweenEach, + betweenFirst, + + -- * Validation + validateInput, + validateOrder, + validateTicks, +) where + +import Control.Monad (when) +import Control.Monad.Trans.Class (MonadTrans (..)) +import Control.Monad.Trans.Control (MonadBaseControl) +import Data.DList qualified as D +import Data.Foldable (Foldable (..), for_) +import Data.Function (on) +import Data.Functor ((<&>)) +import Data.HashMap.Strict (HashMap) +import Data.HashMap.Strict qualified as M +import Data.Hashable (Hashable (..)) +import Data.Kind (Constraint) +import Data.List qualified as L +import Data.Machine (Is (..), MachineT (..), Moore (..), PlanT, Process, ProcessT, SourceT, Step (..), asParts, await, construct, encased, mapping, repeatedly, starve, stopped, yield, (~>)) +import Data.Machine.Concurrent qualified as CC +import Data.Machine.Fanout (fanout) +import Data.Maybe (fromMaybe) +import Data.Semigroup (Max (..)) +import Data.Text qualified as T +import Data.Void (Void) +import GHC.Eventlog.Live.Data.Severity (Severity (..)) +import GHC.Eventlog.Live.Logger (Logger, writeLog) +import Text.Printf (printf) + +{- $setup +>>> :set -XFlexibleContexts +>>> :set -XImplicitParams +>>> :set -XImportQualifiedPost +>>> :set -XLambdaCase +>>> :set -XRankNTypes +>>> :set -XTypeApplications +>>> import Data.Functor.Identity (Identity) +>>> import Data.Machine qualified as M +>>> import Data.Machine hiding (run, runT_) +>>> import Data.Machine.Fanout (fanout) +>>> import Data.Semigroup (Sum (..)) + +>>> :{ +run :: (HasTickInfo => M.MachineT Identity k b) -> [b] +run = let ?tickInfo = TickInfo { tick = 0 } in M.run +:} + +>>> :{ +runT_ :: Monad m => (HasTickInfo => MachineT m k b) -> m () +runT_ = let ?tickInfo = TickInfo { tick = 0 } in M.runT_ +:} +-} + +------------------------------------------------------------------------------- +-- Ticks +------------------------------------------------------------------------------- + +{- | +The type of v`Tick` information. +-} +newtype TickInfo = TickInfo + { tick :: Word + } + +{- | +The constraint that adds information to each v`Tick`. +This should be treated as opaque. +-} +type HasTickInfo :: Constraint +type HasTickInfo = (?tickInfo :: TickInfo) + +{- | +The type of data on a stream of items and ticks. + +The t`Tick` type is isomorphic to `Maybe` modulo strictness, +but with the caveat that v`Tick` does not represent failure. +-} +data Tick a + = Item !a + | (HasTickInfo) => Tick + +{- | +__Warning:__ +This instance loses ticks and should only be used with `fanout` to combine +streams which pass on ticks. +-} +instance (Semigroup a) => Semigroup (Tick a) where + (<>) :: Tick a -> Tick a -> Tick a + t@Tick <> Tick = t + i@Item{} <> Tick = i + Tick <> i@Item{} = i + Item a <> Item a' = Item (a <> a') + +deriving instance (Eq a) => Eq (Tick a) +deriving instance Functor Tick +deriving instance Foldable Tick +deriving instance Traversable Tick +deriving instance (Show a) => Show (Tick a) + +{- | +Internal helper. +Get `TickInfo` from a t`Tick`. +-} +toTickInfo :: Tick x -> Maybe TickInfo +toTickInfo Item{} = Nothing +toTickInfo Tick = Just ?tickInfo + +{- | +Internal helper. +Lift `TickInfo` to a constraint. +-} +withTickInfo :: TickInfo -> ((HasTickInfo) => a) -> a +withTickInfo tickInfo action = + let ?tickInfo = tickInfo in action + +pattern TickWithInfo :: TickInfo -> Tick a +pattern TickWithInfo{tickInfo} <- (toTickInfo -> Just tickInfo) + where + TickWithInfo tickInfo = withTickInfo tickInfo Tick + +{-# COMPLETE Item, TickWithInfo #-} + +{- | +Variant of `fanout` for processes that act on t`Tick` streams. + +==== __Examples__ + +>>> run $ fanoutTick [echo, echo] <~ source [Item [1], Tick, Item [2]] +[Item [1,1],Tick,Item [2,2]] +-} +fanoutTick :: + forall m a b. + (Monad m, Semigroup b) => + [ProcessT m (Tick a) (Tick b)] -> + ProcessT m (Tick a) (Tick b) +fanoutTick processes = + fanout + [ fanout + [ process ~> dropTick + | process <- processes + ] + ~> mapping (D.singleton . Item) + , onlyTick + ~> mapping D.singleton + ] + ~> asParts + +{- | +Variant of `fanoutTick` that runs processes concurrently. +-} +fanoutTickCC :: + forall m a b. + (MonadBaseControl IO m, Semigroup b) => + [ProcessT m (Tick a) (Tick b)] -> + ProcessT m (Tick a) (Tick b) +fanoutTickCC processes = + fanout + [ CC.fanout + [ process ~> dropTick + | process <- processes + ] + ~> mapping (D.singleton . Item) + , onlyTick + ~> mapping D.singleton + ] + ~> asParts + +{- | +Merges a stream of ticks into an existing source. +All items are discarded. +The source is run concurrently with its input. +-} +mergeWithTickCC :: + forall m x a. + (MonadBaseControl IO m) => + SourceT m a -> + ProcessT m (Tick x) (Tick a) +mergeWithTickCC source = + CC.scatter [onlyTick, source ~> mapping Item] + +{- | +Batches items to lists. + +The process @`batchByTickList`@ consumes a stream of items and ticks. +It preserves ticks but batches items between ticks to lists. + +__Warning:__ This process does not yield empty batches. + +==== __Examples__ + +>>> run $ batchByTickList <~ source [Item 1,Item 2,Tick,Item 3,Tick,Item 4,Item 5,Tick,Item 6,Tick] +[[1,2],[3],[4,5],[6]] + +>>> run $ batchByTickList <~ source [Item 1,Item 2,Tick,Tick] +[[1,2]] +-} +batchByTickList :: Process (Tick a) [a] +batchByTickList = + mapping (fmap D.singleton) + ~> batchByTick + ~> dropTick + ~> mapping D.toList + +{- | +Batches items for a given number of ticks to lists. + +The process @`batchByTicksList` n@ consumes a stream of items and ticks. +It preserves ticks but batches items for @n@ ticks to lists and yields the batch before the @n@'th tick. + +__Warning:__ This process does not yield empty batches. + +==== __Examples__ + +>>> run $ batchByTicksList 2 <~ source [Item 1,Item 2,Tick,Item 3,Tick,Item 4,Item 5,Tick,Item 6,Tick] +[[1,2,3],[4,5,6]] + +>>> run $ batchByTicksList 2 <~ source [Item 1,Item 2,Tick,Tick] +[[1,2]] +-} +batchByTicksList :: + -- | The number of ticks per batch. + Int -> + Process (Tick a) [a] +batchByTicksList ticks = + mapping (fmap D.singleton) + ~> batchByTicks ticks + ~> dropTick + ~> mapping D.toList + +{- | +Batches items via their `Semigroup` instance. + +The process @`batchByTick`@ consumes a stream of items and ticks. +It preserves ticks but batches items between ticks using `sconcat`. + +==== __Examples__ + +>>> run $ batchByTick <~ source [Item [1],Item [2],Tick,Item [3],Tick,Item [4],Item [5],Tick,Item [6],Tick] +[Item [1,2],Tick,Item [3],Tick,Item [4,5],Tick,Item [6],Tick] + +>>> run $ batchByTick <~ source [Item (Sum 1),Item (Sum 2),Tick,Item (Sum 3),Tick,Item (Sum 4),Item (Sum 5),Tick,Item (Sum 6),Tick] +[Item (Sum {getSum = 3}),Tick,Item (Sum {getSum = 3}),Tick,Item (Sum {getSum = 9}),Tick,Item (Sum {getSum = 6}),Tick] +-} +batchByTick :: + forall a. + (Monoid a) => Process (Tick a) (Tick a) +batchByTick = batchByTicks 1 + +{- | +Batches items for a given number of ticks via their `Semigroup` instance. + +The process @`batchByTicks` n@ consumes a stream of items and ticks. +It preserves ticks but batches items for @n@ ticks using `sconcat` and yields the batch before the @n@'th tick. + +==== __Examples__ + +>>> run $ batchByTicks 2 <~ source [Item [1],Item [2],Tick,Item [3],Tick,Item [4],Item [5],Tick,Item [6],Tick] +[Tick,Item [1,2,3],Tick,Tick,Item [4,5,6],Tick] + +>>> run $ batchByTicks 2 <~ source [Item (Sum 1),Item (Sum 2),Tick,Item (Sum 3),Tick,Item (Sum 4),Item (Sum 5),Tick,Item (Sum 6),Tick] +[Tick,Item (Sum {getSum = 6}),Tick,Tick,Item (Sum {getSum = 15}),Tick] +-} +batchByTicks :: + forall a. + (Semigroup a) => + -- | The number of ticks per batch. + Int -> + Process (Tick a) (Tick a) +batchByTicks ticks = batchByTicksWith ticks mempty + where + batchByTicksWith :: + forall m. + (Monad m) => + Int -> + Maybe a -> + MachineT m (Is (Tick a)) (Tick a) + batchByTicksWith ticksRemaining maybeAcc = + MachineT $ pure $ Await onNext Refl onStop + where + yieldItem :: a -> ProcessT m (Tick a) (Tick a) -> ProcessT m (Tick a) (Tick a) + yieldItem a = MachineT . pure . Yield (Item a) + + yieldTick :: (HasTickInfo) => ProcessT m (Tick a) (Tick a) -> ProcessT m (Tick a) (Tick a) + yieldTick = MachineT . pure . Yield Tick + + onNext :: Tick a -> MachineT m (Is (Tick a)) (Tick a) + onNext = \case + Item a -> batchByTicksWith ticksRemaining (maybeAcc <> Just a) + Tick + | ticksRemaining <= 1 -> + -- Yield an `Item` if any items were accumulated. + maybe id yieldItem maybeAcc $ + -- Yield the `Tick`. + yieldTick $ + -- Continue with the initial state. + batchByTicksWith ticks Nothing + | otherwise -> + -- Yield the `Tick`. + yieldTick $ + -- Continue with one fewer tick remaining. + batchByTicksWith (ticksRemaining - 1) maybeAcc + + onStop :: MachineT m (Is (Tick a)) (Tick a) + onStop = + -- Yield an `Item` if any items were accumulated. + maybe id yieldItem maybeAcc $ + -- Stop. + stopped + +{- | +This machine drops all ticks. +-} +dropTick :: Process (Tick a) a +dropTick = + repeatedly $ + await >>= \case + Item a -> yield a + Tick -> pure () + +{- | +This machine drops all items. +-} +onlyTick :: Process (Tick a) (Tick b) +onlyTick = + repeatedly $ + await >>= \case + Tick -> yield Tick + Item{} -> pure () + +------------------------------------------------------------------------------- +-- Machine combinators +------------------------------------------------------------------------------- + +infixl 7 &> + +{- | +Run two machines in sequence. +-} +(&>) :: (Monad m) => MachineT m k a -> MachineT m k a -> MachineT m k a +m &> n = + MachineT $ + runMachineT m >>= \case + Stop -> + runMachineT n + Yield o k -> + pure (Yield o (k &> n)) + Await onNext k onStop -> + pure (Await (\t -> onNext t &> n) k (onStop &> n)) + +{- | +Run a monadic action as a machine. +-} +embed :: (Monad m) => m () -> MachineT m k a +embed action = MachineT $! action >> pure Stop + +-------------------------------------------------------------------------------- +-- Lift a machine to a machine that passes on ticks unchanged + +{- | +Lift a machine to a machine that passes on ticks unchanged. + +Constructs the following machine: + +@ + ┌─(if Tick)────────────────────┐ + [ Tick a ] [ Tick b ] + └─(if Item)─( ProcessT m a b )─┘ +@ + +==== __Examples__ + +>>> run $ liftTick (mapping (+1)) <~ source [Item 1,Tick,Item 2,Item 3,Tick,Tick] +[Item 2,Tick,Item 3,Item 4,Tick,Tick] + +>>> run $ liftTick (scan (+) 0) <~ source [Item 1,Tick,Item 2,Item 3,Tick,Tick] +[Item 0,Item 1,Tick,Item 3,Item 6,Tick,Tick] +-} +liftTick :: + (Monad m) => + ProcessT m a b -> + ProcessT m (Tick a) (Tick b) +liftTick m = + MachineT $ + runMachineT m <&> \case + Stop -> + Stop + Yield o k -> + Yield (Item o) (liftTick k) + Await (onNext :: t -> ProcessT m a b) Refl onStop -> + await' + where + await' = Await onNext' Refl onStop' + where + onNext' :: Tick a -> ProcessT m (Tick a) (Tick b) + onNext' = \case + Tick -> + MachineT . pure . Yield Tick $ + MachineT . pure $ + await' + Item a -> liftTick (onNext a) + onStop' :: ProcessT m (Tick a) (Tick b) + onStop' = liftTick onStop + +-------------------------------------------------------------------------------- +-- Construct a processor that spawns a separate child processor for each measure + +{- | +Spawns a process for each measure. + +Constructs the following machine: + +@ + ┌─────(if measure == k0)─( spawn k0 :: ProcessT m a b )────┐ + [ a ] ──(if measure == ..)─( spawn .. :: ProcessT m a b )─ [ b ] + └─────(if measure == kN)─( spawn kN :: ProcessT m a b )────┘ +@ + +If the spawned process for some measure stops, +then all future inputs for that measure are ignored. + +__Warning:__ +The router process holds on to a reference to each measure @i@ for each child +process, even after that child process has stopped. + +==== __Examples__ + +>>> run $ liftRouter (Just . even) (\case {True -> mapping (+1); False -> echo}) <~ source [1,2,3,4,5] +[1,3,3,5,5] + +>>> run $ liftRouter (Just . even) (\case {True -> echo; False -> stopped}) <~ source [1,2,3,4,5] +[2,4] + +>>> run $ liftRouter (Just . even) (\case {True -> echo; False -> taking 1}) <~ source [1,2,3,4,5] +[1,2,4] +-} +liftRouter :: + forall m i a b. + (Monad m, Hashable i) => + -- | Function to measure. + (a -> Maybe i) -> + -- | Function to spawn child processors. + (i -> ProcessT m a b) -> + ProcessT m a b +liftRouter measure spawn = awaiting M.empty + where + awaiting :: HashMap i (Child (ProcessT m a b)) -> ProcessT m a b + awaiting st = MachineT . pure $ Await onNext Refl onStop + where + onNext :: a -> MachineT m (Is a) b + onNext a = case measure a of + Nothing -> awaiting st + Just i -> + case fromMaybe (ChildRunning $ spawn i) (M.lookup i st) of + ChildRunning p -> + provideThen a p $ \p' -> + let !st' = M.insert i p' st + in awaiting st' + ChildStopped -> + awaiting st + + onStop :: MachineT m (Is a) b + onStop = foldr starve stopped (concatMap toList . M.elems $ st) + + provideThen :: a -> ProcessT m a b -> (Child (ProcessT m a b) -> ProcessT m a b) -> ProcessT m a b + provideThen a p k = + MachineT $ + runMachineT p >>= \case + Stop -> runMachineT (k ChildStopped) + Yield o p' -> pure (Yield o (provideThen a p' k)) + Await onNext Refl _onStop -> runMachineT (exhaustThen (onNext a) k) + + exhaustThen :: ProcessT m a b -> (Child (ProcessT m a b) -> ProcessT m a b) -> ProcessT m a b + exhaustThen p k = + MachineT $ + runMachineT p >>= \case + Yield o p' -> pure (Yield o (k $ ChildRunning p')) + p' -> runMachineT (k (ChildRunning $ encased p')) + +{- | +Internal helper. +A wrapper for child processes spawned by `liftRouter`. +-} +data Child a + = ChildRunning !a + | ChildStopped + deriving (Functor, Foldable) + +------------------------------------------------------------------------------- +-- Event stream sorting +------------------------------------------------------------------------------- + +{- | +Sort items in @N@ successive batches. + +If the maximum key in batch @i@ is guaranteed to be smaller than the minimum +key in batch @i + 2N@, this process produces a totally ordered stream of items. + +The process @`sortByBatch` key@ caches @N@ batches of items, sorts them +together, and yields only those items whose key is less than or equal +to the maximum key in the first batch. + +==== __Examples__ + +>>> run $ sortByBatch @Int id <~ source [[1,4],[7,2,3,5],[6,8]] +[[1,2,3,4],[5,6,7],[8]] + +>>> run $ sortByBatch @Int id <~ source [[1,7],[4,2,3,5],[6,8]] +[[1,2,3,4,5,7],[6,8]] +-} +sortByBatch :: + forall a k. + (Bounded k, Ord k) => + (a -> k) -> + Process [a] [a] +sortByBatch key = sortByBatchWith Nothing + where + sortByBatchWith :: + forall m. + (Monad m) => + Maybe [a] -> + ProcessT m [a] [a] + sortByBatchWith = \case + Nothing -> MachineT $ pure $ Await onNext Refl onStop + where + onNext :: [a] -> ProcessT m [a] [a] + onNext new = sortByBatchWith (Just sortedNew) + where + sortedNew = sortByKey new + onStop :: ProcessT m [a] [a] + onStop = stopped + Just sortedOld -> MachineT $ pure $ Await onNext Refl onStop + where + onNext :: [a] -> ProcessT m [a] [a] + onNext new + | null sortedOld = sortByBatchWith $ Just sortedNew + | otherwise = MachineT $ pure $ Yield sortedBeforeCutoff $ sortByBatchWith $ Just sortedAfterCutoff + where + -- NOTE: use of partial @maximum@ is guarded by the check @null old@. + cutoff = getMax (foldMap (Max . key) sortedOld) + sortedNew = sortByKey new + sorted = joinByKey sortedOld sortedNew + (sortedBeforeCutoff, sortedAfterCutoff) = L.partition ((<= cutoff) . key) sorted + onStop :: ProcessT m [a] [a] + onStop = MachineT $ pure $ Yield sortedOld $ stopped + + compByKey :: a -> a -> Ordering + compByKey = compare `on` key + + sortByKey :: [a] -> [a] + sortByKey = L.sortBy compByKey + + joinByKey {- Sorted -} :: [a {- Sorted -}] -> [a {- Sorted -}] -> [a] + joinByKey [] ys = ys + joinByKey xs [] = xs + joinByKey (x : xs) (y : ys) + | compByKey x y == LT = x : joinByKey xs (y : ys) + | otherwise = y : joinByKey (x : xs) ys + +{- | +Sort items between successive ticks. + +If the maximum key in batch @i@ is guaranteed to be smaller than the minimum +key in batch @i + 2@, this process produces a totally ordered stream of items. + +==== __Examples__ + +>>> run $ sortByTick @Int id <~ source [Item 1,Item 4,Tick,Item 7,Item 2,Item 3,Item 5,Tick,Item 6,Item 8] +[Tick,Item 1,Item 2,Item 3,Item 4,Tick,Item 5,Item 6,Item 7,Item 8] + +>>> run $ sortByTick @Int id <~ source [Item 1,Item 7,Tick,Item 4,Item 2,Item 3,Item 5,Tick,Item 6,Item 8] +[Tick,Item 1,Item 2,Item 3,Item 4,Item 5,Item 7,Tick,Item 6,Item 8] +-} +sortByTick :: + forall a k. + (Bounded k, Ord k) => + (a -> k) -> + Process (Tick a) (Tick a) +sortByTick key = + mapping (fmap D.singleton) + ~> batchByTick + ~> mapping (fmap D.toList) + ~> liftTick (sortByBatch key ~> asParts) + +{- | +Sort items between @2*K@ successive ticks. + +If the maximum key in batch @i@ is guaranteed to be smaller than the minimum +key in batch @i + K@, this process produces a totally ordered stream of items. + +==== __Examples__ + +>>> run $ sortByTicks @Int id 2 <~ source [Item 2,Tick,Item 1,Tick,Item 4,Tick,Item 3,Tick] +[Tick,Tick,Tick,Item 1,Item 2,Tick,Item 3,Item 4] + +>>> run $ sortByTicks @Int id 2 <~ source [Item 1,Tick,Item 3,Tick,Item 2,Tick,Item 4,Tick] +[Tick,Tick,Tick,Item 1,Item 2,Item 3,Tick,Item 4] + +>>> run $ sortByTicks @Int id 2 <~ source [Item 1,Tick,Item 4,Tick,Item 2,Tick,Item 3,Tick] +[Tick,Tick,Tick,Item 1,Item 2,Item 3,Item 4,Tick] +-} +sortByTicks :: + forall a k. + (Bounded k, Ord k) => + (a -> k) -> + Int -> + Process (Tick a) (Tick a) +sortByTicks key ticks = + mapping (fmap D.singleton) + ~> batchByTicks ticks + ~> mapping (fmap D.toList) + ~> liftTick (sortByBatch key ~> asParts) + +------------------------------------------------------------------------------- +-- Filtering semaphores +------------------------------------------------------------------------------- + +{- | +A delimiting t`Moore` machine based on constant open/close markers. + +The machine @`between` o c@ consumes consumes a stream of items, and produces +a stream of `Bool` that is `False` up to and including the first occurrence of +@o@, then is `True` up to and including the first occurrence of @c@, and then +is `False` forever. + +==== __Examples__ + +>>> run $ auto (betweenEach (2, 4)) <~ source [1, 2, 3, 4, 5] +[False,False,True,True,False,False] + +>>> run $ auto (betweenEach (2, 4)) <~ source [2, 3, 4, 2, 3, 4] +[False,True,True,False,True,True,False] +-} +betweenEach :: (Eq a) => (a, a) -> Moore a Bool +betweenEach (open, close) = beforeOpen + where + beforeOpen = Moore False $ \a -> + if a == open then betweenOpenAndClose else beforeOpen + betweenOpenAndClose = Moore True $ \a -> + if a == close then beforeOpen else betweenOpenAndClose + +{- | +A delimiting t`Moore` machine based on constant open/close markers. + +The machine @`between` o c@ consumes consumes a stream of items, and produces +a stream of `Bool` that is `False` up to and including the first occurrence of +@o@, then is `True` up to and including the first occurrence of @c@, and then +is `False` forever. + +==== __Examples__ + +>>> run $ auto (betweenFirst (2, 4)) <~ source [1, 2, 3, 4, 5] +[False,False,True,True,False,False] + +>>> run $ auto (betweenFirst (2, 4)) <~ source [2, 3, 4, 2, 3, 4] +[False,True,True,False,False,False,False] +-} +betweenFirst :: (Eq a) => (a, a) -> Moore a Bool +betweenFirst (open, close) = beforeFirstOpen + where + beforeFirstOpen = Moore False $ \a -> + if a == open then betweenFirstOpenAndClose else beforeFirstOpen + betweenFirstOpenAndClose = Moore True $ \a -> + if a == close then afterFirstClose else betweenFirstOpenAndClose + afterFirstClose = Moore False (const afterFirstClose) + +{- | +Filter the items in a stream based on a t`Moore` machine. + +==== __Examples__ + +>>> run $ delimit (betweenEach (2, 4)) <~ source [1, 2, 3, 4, 5] +[2,3,4] + +>>> run $ delimit (betweenEach (2, 4)) <~ source [2, 3, 4, 2, 3, 4] +[2,3,4,2,3,4] + +>>> run $ delimit (betweenFirst (2, 4)) <~ source [1, 2, 3, 4, 5] +[2,3,4] + +>>> run $ delimit (betweenFirst (2, 4)) <~ source [2, 3, 4, 2, 3, 4] +[2,3,4] +-} +delimit :: + forall m a. + (Monad m) => + Moore a Bool -> + ProcessT m a a +delimit = construct . go + where + go :: + Moore a Bool -> + PlanT (Is a) a m Void + go _st@(Moore wasOpen onNext) = + await >>= \a -> do + -- Feed the item to the delimiting Moore machine. + let st'@(Moore willBeOpen _) = onNext a + -- If the state has changed, i.e., @wasOpen /= willBeOpen@, then + -- the current item is a marker. All markers should be yielded. + let isMarker = wasOpen /= willBeOpen + when (wasOpen || isMarker) $ yield a + go st' + +------------------------------------------------------------------------------- +-- Validation +-- +-- TODO: These machines, or at least the error messages that they print, are +-- specific to eventlog processing. Hence, they should be moved. +------------------------------------------------------------------------------- + +{- | +This machine validates that there is some input. + +If no input is encountered after the given number of ticks, the machine prints +a warning that directs the user to check that the @-l@ flag was set correctly. +-} +validateInput :: + (Monad m) => + Logger m -> + Int -> + ProcessT m (Tick a) x +validateInput logger ticks = construct $ start ticks + where + start remaining + | remaining <= 0 = do + let msg = printf "No input after %d ticks. Did you pass -l to the GHC RTS?" ticks + lift $ writeLog logger WARN $ T.pack msg + pure () + | otherwise = do + let msg = "Waiting for " <> T.pack (show remaining) <> " more ticks before showing input warning." + lift $ writeLog logger DEBUG $ msg + await >>= \case + Item{} -> + lift $ writeLog logger DEBUG $ "Received item. Cancelled input warning." + Tick -> + start (pred remaining) + +{- | +This machine validates that the inputs are received in order. + +If an out-of-order input is encountered, the machine prints an error message +that directs the user to check that the @--eventlog-flush-interval@ flag is +set correctly. +-} +validateOrder :: + (Monad m, Ord k, Show a) => + Logger m -> + (a -> k) -> + ProcessT m a x +validateOrder logger timestamp = construct $ go Nothing + where + go maybeOld = + await >>= \new -> + case maybeOld of + Just old + | timestamp new < timestamp old -> do + let msg1 = + "Encountered two out-of-order inputs.\n\ + \Did you pass --eventlog-flush-interval=SECONDS to the GHC RTS?\n\ + \Did you pass the same flag to this program?" + lift $ writeLog logger ERROR $ T.pack msg1 + let msg2 = + printf + "Out-of-order inputs:\n\ + \- %s\n\ + \- %s" + (show old) + (show new) + lift $ writeLog logger DEBUG $ T.pack msg2 + _otherwise -> do + go (Just new) + +{- | +This machine validates that ticks are unique and increasing. +-} +validateTicks :: + (Monad m) => + Logger m -> + ProcessT m (Tick a) (Tick a) +validateTicks logger = construct $ go Nothing + where + go maybeTick = + await >>= \case + Item _ -> + go maybeTick + TickWithInfo{tickInfo = TickInfo{tick = tick'}} -> do + for_ maybeTick $ \case + tick + | tick' == tick + 1 -> do + let msg = "Saw tick " <> T.pack (show tick) <> "." + lift $ writeLog logger TRACE $ msg + | otherwise -> do + let msg = "Encountered non-increasing ticks " <> T.pack (show tick) <> " and " <> T.pack (show tick') <> "." + lift $ writeLog logger ERROR $ msg + go (Just tick') diff --git a/src-lib/GHC/Eventlog/Live/Machine/Decoder.hs b/src-lib/GHC/Eventlog/Live/Machine/Decoder.hs new file mode 100644 --- /dev/null +++ b/src-lib/GHC/Eventlog/Live/Machine/Decoder.hs @@ -0,0 +1,53 @@ +{- | +Module : GHC.Eventlog.Live.Machine.Decoder +Description : Machines for processing eventlog data. +Stability : experimental +Portability : portable +-} +module GHC.Eventlog.Live.Machine.Decoder ( + -- * Event decoding + decodeEvent, + decodeEventBatch, +) where + +import Control.Monad.Trans.Class (MonadTrans (..)) +import Data.ByteString qualified as BS +import Data.Machine (Is, PlanT, ProcessT, await, construct, yield) +import Data.Text qualified as T +import GHC.Eventlog.Live.Data.Severity (Severity (..)) +import GHC.Eventlog.Live.Logger (Logger, writeLog) +import GHC.Eventlog.Live.Machine.Core (Tick (..), liftTick) +import GHC.RTS.Events (Event) +import GHC.RTS.Events.Incremental (Decoder (..), decodeEventLog) + +------------------------------------------------------------------------------- +-- Decoding events + +{- | +Parse t'Event's from a stream of 'BS.ByteString' chunks with ticks. + +Throws a t'DecodeError' on error. +-} +decodeEvent :: + forall m. + (Monad m) => + Logger m -> + ProcessT m BS.ByteString Event +decodeEvent logger = construct $ loop decodeEventLog + where + loop :: Decoder a -> PlanT (Is BS.ByteString) a m () + loop Done{} = pure () + loop (Consume k) = await >>= \chunk -> loop (k chunk) + loop (Produce a d') = yield a >> loop d' + loop (Error _ err) = lift $ writeLog logger ERROR $ T.pack err + +{- | +Parse 'Event's from a stream of 'BS.ByteString' chunks with ticks. + +Throws 'DecodeError' on error. +-} +decodeEventBatch :: + (Monad m) => + Logger m -> + ProcessT m (Tick BS.ByteString) (Tick Event) +decodeEventBatch logger = liftTick $ decodeEvent logger diff --git a/src-lib/GHC/Eventlog/Live/Machine/Sink.hs b/src-lib/GHC/Eventlog/Live/Machine/Sink.hs new file mode 100644 --- /dev/null +++ b/src-lib/GHC/Eventlog/Live/Machine/Sink.hs @@ -0,0 +1,42 @@ +{- | +Module : GHC.Eventlog.Live.Machine.Sink +Description : Machines for processing eventlog data. +Stability : experimental +Portability : portable +-} +module GHC.Eventlog.Live.Machine.Sink ( + -- * Eventlog file sink + fileSink, + fileSinkBatch, +) where + +import Control.Monad.IO.Class (MonadIO (..)) +import Data.ByteString qualified as BS +import Data.Machine (ProcessT, await, repeatedly, (~>)) +import Data.Void (Void) +import GHC.Eventlog.Live.Machine.Core (Tick (..), dropTick) +import System.IO (Handle) + +------------------------------------------------------------------------------- +-- Log file sink + +{- | +File sink for optional eventlog log file. +-} +fileSink :: + (MonadIO m) => + Handle -> + ProcessT m BS.ByteString Void +fileSink handle = repeatedly $ await >>= liftIO . BS.hPut handle + +------------------------------------------------------------------------------- +-- Log file sink with batches + +{- | +File sink for optional eventlog log file. +-} +fileSinkBatch :: + (MonadIO m) => + Handle -> + ProcessT m (Tick BS.ByteString) Void +fileSinkBatch handle = dropTick ~> fileSink handle diff --git a/src-lib/GHC/Eventlog/Live/Machine/Source.hs b/src-lib/GHC/Eventlog/Live/Machine/Source.hs new file mode 100644 --- /dev/null +++ b/src-lib/GHC/Eventlog/Live/Machine/Source.hs @@ -0,0 +1,90 @@ +{- | +Module : GHC.Eventlog.Live.Machine.Source +Description : Machines for processing eventlog data. +Stability : experimental +Portability : portable +-} +module GHC.Eventlog.Live.Machine.Source ( + -- * Eventlog source + eventlogSourceTick, + defaultChunkSizeBytes, +) where + +import Control.Monad.IO.Class (MonadIO (..)) +import Data.ByteString qualified as BS +import Data.Machine (MachineT (..), construct, yield) +import Data.Word (Word64) +import GHC.Clock (getMonotonicTimeNSec) +import GHC.Eventlog.Live.Machine.Core (Tick (..), TickInfo (..)) +import GHC.Eventlog.Live.Source.Core (EventlogSourceData (..), EventlogSourceHandle, recv) + +{- | +A source which reads chunks from a `Handle`. +When input is available, it yields an v`Item`. +It yields a v`Tick` at each increment of the batch interval. +-} +eventlogSourceTick :: + (MonadIO m) => + -- | The batch interval in milliseconds. + Int -> + -- | The number of bytes to read. + Int -> + -- | The eventlog source handle. + EventlogSourceHandle -> + MachineT m k (Tick BS.ByteString) +eventlogSourceTick batchIntervalMilli chunkSizeBytes h = + construct $ start 0 + where + batchIntervalMicro = milliToMicro batchIntervalMilli + + start tick = do + startTimeMicro <- liftIO getMonotonicTimeMicro + batch tick startTimeMicro + + batch tick startTimeMicro = batchLoop + where + getRemainingTimeMicro = do + currentTimeMicro <- liftIO getMonotonicTimeMicro + pure $ (startTimeMicro + batchIntervalMicro) - currentTimeMicro + + batchLoop = do + remainingTimeMicro <- getRemainingTimeMicro + if remainingTimeMicro <= 0 + then do + yield TickWithInfo{tickInfo = TickInfo{tick}} + start (tick + 1) + else do + liftIO (recv h remainingTimeMicro chunkSizeBytes) >>= \case + EventlogSourceData chunk -> yield (Item chunk) >> batchLoop + EventlogSourceTimeout -> batchLoop + EventlogSourceClosed -> pure () + +{- | +Eventlog chunk size in bytes. +This should be equal to the page size. +-} +defaultChunkSizeBytes :: Int +defaultChunkSizeBytes = 4096 + +{- | +Internal helper. +Return monotonic time in microseconds, since some unspecified starting point +-} +getMonotonicTimeMicro :: IO Int +getMonotonicTimeMicro = nanoToMicro <$> getMonotonicTimeNSec + +{- | +Internal helper. +Convert nanoseconds to microseconds. +If the size of @Int@ is at least as big as that of @Word64@, then +the conversion from 'Word64' to 'Int' is safe, due to the division by 1000. +-} +nanoToMicro :: Word64 -> Int +nanoToMicro = fromIntegral . (`div` 1_000) + +{- | +Internal helper. +Convert milliseconds to microseconds. +-} +milliToMicro :: Int -> Int +milliToMicro = (* 1_000) diff --git a/src-lib/GHC/Eventlog/Live/Machine/WithStartTime.hs b/src-lib/GHC/Eventlog/Live/Machine/WithStartTime.hs new file mode 100644 --- /dev/null +++ b/src-lib/GHC/Eventlog/Live/Machine/WithStartTime.hs @@ -0,0 +1,88 @@ +{- | +Module : GHC.Eventlog.Live.Machine.WithStartTime +Description : Machines for processing eventlog data. +Stability : experimental +Portability : portable +-} +module GHC.Eventlog.Live.Machine.WithStartTime ( + WithStartTime (..), + setWithStartTime'value, + tryGetTimeUnixNano, + withStartTime, + withStartTime', + dropStartTime, +) where + +import Control.Monad (forever) +import Data.Machine (Is (..), PlanT, Process, await, construct, mapping, yield) +import GHC.RTS.Events (Event (..), EventInfo, Timestamp) +import GHC.RTS.Events qualified as E + +------------------------------------------------------------------------------- +-- Start time + +{- | +Data decorated with a start time in nanoseconds since the Unix epoch. +-} +data WithStartTime a = WithStartTime + { value :: !a + , maybeStartTimeUnixNano :: !(Maybe Timestamp) + } + deriving (Functor, Show) + +{- | +Setter for the value of a t`WithStartTime` +-} +setWithStartTime'value :: WithStartTime a -> b -> WithStartTime b +setWithStartTime'value (WithStartTime _a t) b = WithStartTime b t + +{- | +If the event has a start time, return `Just` the time of the event in +nanoseconds since the Unix epoch. Otherwise, return `Nothing`. +-} +tryGetTimeUnixNano :: WithStartTime Event -> Maybe Timestamp +tryGetTimeUnixNano i = (i.value.evTime +) <$> i.maybeStartTimeUnixNano + +{- | +Wrap every event in t`WithStartTime`. Every event after `E.WallClockTime` will +have its start time field set to `Just` the process start time. + +This machine swallows the first and only `E.WallClockTime` event. +-} +withStartTime :: Process Event (WithStartTime Event) +withStartTime = withStartTime' E.evSpec WithStartTime + +{- | +Generalised version of `withStartTime` that can be adapted to work on arbitrary +types using a getter and a setter. +-} +withStartTime' :: (a -> EventInfo) -> (a -> Maybe Timestamp -> b) -> Process a b +withStartTime' getEventInfo setStartTime = construct start + where + start = + await >>= \case + value + -- The `WallClockTime` event announces the wall-clock time at which the + -- process was started. + | E.WallClockTime{..} <- getEventInfo value -> do + -- This will start overflowing on Sunday, 21 July 2554 23:34:33, UTC. + let !startTimeNs = sec * 1_000_000_000 + fromIntegral nsec + -- We do not re-emit the `WallClockTime` event. + continue startTimeNs + | otherwise -> + yield (value `setStartTime` Nothing) >> start + continue startTimeUnixNano = + mappingPlan $ \value -> + value `setStartTime` Just startTimeUnixNano + +{- | +Drop the t`WithStartTime` wrapper. +-} +dropStartTime :: Process (WithStartTime a) a +dropStartTime = mapping (.value) + +{- | +Internal helper. Variant of `mapping` for plans. +-} +mappingPlan :: (a -> b) -> PlanT (Is a) b m a +mappingPlan f = forever (await >>= \a -> yield (f a)) diff --git a/src-lib/GHC/Eventlog/Live/Options.hs b/src-lib/GHC/Eventlog/Live/Options.hs new file mode 100644 --- /dev/null +++ b/src-lib/GHC/Eventlog/Live/Options.hs @@ -0,0 +1,194 @@ +{- | +Module : GHC.Eventlog.Live.Options +Description : Command-line option parsers for eventlog machines. +Stability : experimental +Portability : portable +-} +module GHC.Eventlog.Live.Options ( + eventlogSourceOptionsParser, + eventlogSocketTimeoutSParser, + eventlogSocketTimeoutExponentParser, + heapProfBreakdownParser, + eventlogLogFileParser, + eventlogFlushIntervalSParser, + verbosityParser, + statsParser, +) where + +import Control.Applicative (asum) +import GHC.Eventlog.Live.Data.HeapProfBreakdown (heapProfBreakdownEitherReader) +import GHC.Eventlog.Live.Data.Severity (Severity (..), fromSeverityString) +import GHC.Eventlog.Live.Source.Core (EventlogSocketAddr (..), EventlogSourceOptions (..)) +import GHC.RTS.Events (HeapProfBreakdown (..)) +import Options.Applicative qualified as O +import Options.Applicative.Help.Pretty qualified as OP + +-------------------------------------------------------------------------------- +-- Eventlog Source + +{- | +Parser for the eventlog socket. +-} +eventlogSourceOptionsParser :: O.Parser EventlogSourceOptions +eventlogSourceOptionsParser = + asum + [ stdinParser + , fileParser + , socketParser + ] + where + stdinParser = + EventlogSourceOptionsStdin + <$ O.flag' + () + ( O.long "eventlog-stdin" + <> O.help "Read the eventlog from stdin." + ) + fileParser = + EventlogSourceOptionsFile + <$> O.strOption + ( O.long "eventlog-file" + <> O.metavar "FILE" + <> O.help "Read the eventlog from a file." + ) + socketParser = + EventlogSourceOptionsSocket + <$> asum + [ socketUnixParser + , socketInetParser + ] + socketUnixParser = + EventlogSocketUnixAddr + <$> O.strOption + ( O.long "eventlog-socket" + <> O.metavar "SOCKET" + <> O.help "Read the eventlog from a Unix socket." + ) + socketInetParser = + EventlogSocketInetAddr + <$> socketInetHostParser + <*> socketInetPortParser + + socketInetHostParser = + O.strOption + ( O.long "eventlog-socket-host" + <> O.metavar "HOST" + <> O.help "Read the eventlog from a TCP/IP socket." + ) + socketInetPortParser = + O.strOption + ( O.long "eventlog-socket-port" + <> O.metavar "PORT" + <> O.help "Read the eventlog from a TCP/IP socket." + ) + +{- | +Parser for the intial timeout for exponential backoff. +-} +eventlogSocketTimeoutSParser :: O.Parser Double +eventlogSocketTimeoutSParser = + O.option + O.auto + ( O.long "eventlog-socket-timeout" + <> O.metavar "SECONDS" + <> O.help "Eventlog socket connection retry timeout in seconds." + <> O.value 1 + ) + +{- | +Parser for the exponent for exponential backoff. +-} +eventlogSocketTimeoutExponentParser :: O.Parser Double +eventlogSocketTimeoutExponentParser = + O.option + O.auto + ( O.long "eventlog-socket-exponent" + <> O.metavar "NUMBER" + <> O.help "Eventlog socket connection retry timeout exponent." + <> O.value 1 + ) + +-------------------------------------------------------------------------------- +-- Heap Profile Breakdown + +{- | +Parser for the heap profile breakdown. +-} +heapProfBreakdownParser :: O.Parser HeapProfBreakdown +heapProfBreakdownParser = + O.option (O.eitherReader heapProfBreakdownEitherReader) . mconcat $ + [ O.short 'h' + , O.metavar "Tcmdyrbi" + , O.helpDoc . Just . OP.vcat . fmap OP.pretty $ + [ "Heap profile breakdown." + , "Should match the option passed to the application." + ] + ] + +-------------------------------------------------------------------------------- +-- Eventlog Log File + +{- | +Parser for the eventlog log file. +-} +eventlogLogFileParser :: O.Parser FilePath +eventlogLogFileParser = + O.strOption + ( O.long "eventlog-log-file" + <> O.metavar "FILE" + <> O.help "Use file to log binary eventlog data." + ) + +-------------------------------------------------------------------------------- +-- Batch Interval + +{- | +Parser for the eventlog flush interval. +-} +eventlogFlushIntervalSParser :: O.Parser Double +eventlogFlushIntervalSParser = + O.option O.auto . mconcat $ + [ O.long "eventlog-flush-interval" + , O.metavar "SECONDS" + , O.helpDoc . Just . OP.vcat . fmap OP.pretty $ + [ "Eventlog flush interval in seconds." + , "Should match the option passed to the application." + ] + , O.value defaultEventlogFlushIntervalS + ] + +{- | +Internal helper. +The default interval in which the eventlog is flushed in seconds. +-} +defaultEventlogFlushIntervalS :: Double +defaultEventlogFlushIntervalS = 1 + +-------------------------------------------------------------------------------- +-- Verbosity + +{- | +Parser for `Severity` +The default severity is `WARN`. +-} +verbosityParser :: O.Parser Severity +verbosityParser = + O.option + (O.maybeReader fromSeverityString) + ( O.short 'v' + <> O.long "verbosity" + <> O.metavar "fatal|error|warning|info|debug|trace" + <> O.help "The severity threshold for logging." + <> O.value WARN + ) + +-------------------------------------------------------------------------------- +-- Statistics + +statsParser :: O.Parser Bool +statsParser = + O.flag False True $ + ( O.short 's' + <> O.long "stats" + <> O.help "Display runtime statistics." + ) diff --git a/src-lib/GHC/Eventlog/Live/Source.hs b/src-lib/GHC/Eventlog/Live/Source.hs new file mode 100644 --- /dev/null +++ b/src-lib/GHC/Eventlog/Live/Source.hs @@ -0,0 +1,211 @@ +{-# LANGUAGE OverloadedStrings #-} + +{- | +Module : GHC.Eventlog.Live.Source +Description : Utilities for running eventlog machines with sockets. +Stability : experimental +Portability : portable +-} +module GHC.Eventlog.Live.Source ( + Tick (..), + withEventlogSourceHandle, + runWithEventlogSourceHandle, + runWithEventlogSourceOptions, +) where + +import Control.Concurrent (threadDelay) +import Control.Exception (Exception (..)) +import Control.Exception qualified as E +import Data.Foldable (traverse_) +import Data.List.NonEmpty qualified as NE +import Data.Machine (ProcessT, runT_, (~>)) +import Data.Machine.Fanout (fanout) +import Data.Maybe (fromMaybe) +import Data.Text (Text) +import Data.Text qualified as T +import Data.Void (Void) +import GHC.Eventlog.Live.Data.Severity (Severity (..)) +import GHC.Eventlog.Live.Logger (Logger, writeLog) +import GHC.Eventlog.Live.Machine.Core +import GHC.Eventlog.Live.Machine.Decoder +import GHC.Eventlog.Live.Machine.Sink +import GHC.Eventlog.Live.Machine.Source +import GHC.Eventlog.Live.Source.Core +import GHC.RTS.Events (Event) +import Network.Socket (Socket) +import Network.Socket qualified as S +import System.IO qualified as IO +import Text.Printf (printf) + +{- | +Run an event processor with `EventlogSourceOptions`. +-} +runWithEventlogSourceOptions :: + -- | The logging action. + Logger IO -> + -- | The eventlog socket handle. + EventlogSourceOptions -> + -- | The initial timeout in seconds for exponential backoff. + Double -> + -- | The timeout exponent for exponential backoff. + Double -> + -- | The batch interval in milliseconds. + Int -> + -- | The number of bytes to read (defaults to 4KiB). + Maybe Int -> + -- | An optional file to which to stream binary eventlog data. + Maybe FilePath -> + -- | The event processor. + ProcessT IO (Tick Event) Void -> + IO () +runWithEventlogSourceOptions logger eventlogSourceOptions timeoutExponent initialTimeoutS batchIntervalMs maybeChuckSizeBytes maybeOutputFile toEventSink = do + withEventlogSourceHandle logger timeoutExponent initialTimeoutS eventlogSourceOptions $ \eventlogSourceHandle -> + runWithEventlogSourceHandle logger eventlogSourceHandle batchIntervalMs maybeChuckSizeBytes maybeOutputFile toEventSink + +{- | +Run an event processor with an eventlog socket handle. +-} +runWithEventlogSourceHandle :: + -- | The logging action. + Logger IO -> + -- | The eventlog socket handle. + EventlogSourceHandle -> + -- | The batch interval in milliseconds. + Int -> + -- | The number of bytes to read (defaults to 4KiB). + Maybe Int -> + -- | An optional file to which to stream binary eventlog data. + Maybe FilePath -> + -- | The event processor. + ProcessT IO (Tick Event) Void -> + IO () +runWithEventlogSourceHandle logger eventlogSourceHandle batchIntervalMs maybeChuckSizeBytes maybeOutputFile toEventSink = do + let chuckSizeBytes = fromMaybe defaultChunkSizeBytes maybeChuckSizeBytes + let fromSocket = eventlogSourceTick batchIntervalMs chuckSizeBytes eventlogSourceHandle + case maybeOutputFile of + Nothing -> + runT_ $ + fromSocket ~> decodeEventBatch logger ~> toEventSink + Just outputFile -> + IO.withFile outputFile IO.WriteMode $ \outputHandle -> do + runT_ $ + fromSocket + ~> fanout + [ fileSinkBatch outputHandle + , decodeEventBatch logger ~> toEventSink + ] + +{- | +Run an action with a `Handle` to the eventlog described by `EventlogSourceOptions`. +-} +withEventlogSourceHandle :: + -- | The logging action. + Logger IO -> + -- | The initial timeout in seconds for exponential backoff. + Double -> + -- | The timeout exponent for exponential backoff. + Double -> + -- | The eventlog socket. + EventlogSourceOptions -> + (EventlogSourceHandle -> IO ()) -> + IO () +withEventlogSourceHandle logger initialTimeoutS timeoutExponent eventlogSource action = do + case eventlogSource of + EventlogSourceOptionsStdin -> do + writeLog logger INFO $ + "Reading eventlog from stdin" + let enter = do + maybeStdinTextEncoding <- IO.hGetEncoding IO.stdin + IO.hSetBinaryMode IO.stdin True + pure maybeStdinTextEncoding + let leave maybeStdinTextEncoding = do + traverse_ (IO.hSetEncoding IO.stdin) maybeStdinTextEncoding + IO.hSetNewlineMode IO.stdin IO.nativeNewlineMode + E.bracket enter leave . const . action $ EventlogSourceHandleStdin + EventlogSourceOptionsFile eventlogFile -> do + writeLog logger INFO $ + "Reading eventlog from " <> T.pack eventlogFile + IO.withBinaryFile eventlogFile IO.ReadMode $ \handle -> + action $ EventlogSourceHandleFile handle + EventlogSourceOptionsSocket eventlogSocketAddr -> do + writeLog logger INFO $ + "Waiting to connect on " <> prettyEventlogSocketAddr eventlogSocketAddr + E.bracket (connectRetry logger initialTimeoutS timeoutExponent eventlogSocketAddr) S.close $ \socket -> + action $ EventlogSourceHandleSocket socket + +{- | +Connect to the eventlog described by `EventlogSourceOptions` with retries and non-randomised exponential backoff. +-} +connectRetry :: + -- | The logging action. + Logger IO -> + -- | The initial timeout in seconds for exponential backoff. + Double -> + -- | The timeout exponent for exponential backoff. + Double -> + -- | The eventlog socket address. + EventlogSocketAddr -> + IO Socket +connectRetry logger initialTimeoutS timeoutExponent eventlogSocketAddr = + connectLoop initialTimeoutS + where + waitFor :: Double -> IO () + waitFor timeoutS = threadDelay $ round $ timeoutS * 1e6 + + connectLoop :: Double -> IO Socket + connectLoop timeoutS = do + let connect = do + writeLog logger DEBUG $ + "Trying to connect on " <> prettyEventlogSocketAddr eventlogSocketAddr + socket <- tryConnect eventlogSocketAddr + writeLog logger DEBUG $ + "Connected on " <> prettyEventlogSocketAddr eventlogSocketAddr + pure socket + let cleanup (e :: E.IOException) = do + writeLog logger DEBUG $ + "Failed to connect on " + <> prettyEventlogSocketAddr eventlogSocketAddr + <> ": " + <> T.pack (displayException e) + writeLog logger DEBUG $ + "Waiting " + <> prettyTimeoutMcs timeoutS + <> " to retry..." + waitFor timeoutS + connectLoop (timeoutS * timeoutExponent) + E.catch connect cleanup + +tryConnect :: EventlogSocketAddr -> IO Socket +tryConnect = \case + EventlogSocketUnixAddr{..} -> do + E.bracketOnError (S.socket S.AF_UNIX S.Stream S.defaultProtocol) S.close $ \socket -> do + S.connect socket (S.SockAddrUnix esaUnixPath) + pure socket + EventlogSocketInetAddr{..} -> do + let addrInfo = S.defaultHints{S.addrFamily = S.AF_UNSPEC, S.addrSocketType = S.Stream} + addr <- NE.head <$> S.getAddrInfo (Just addrInfo) (Just esaInetHost) (Just $ esaInetPort) + E.bracketOnError (S.socket (S.addrFamily addr) (S.addrSocketType addr) (S.addrProtocol addr)) S.close $ \socket -> do + S.connect socket (S.addrAddress addr) + pure socket + +{- | +Interal helper. Pretty-printer for timeout values in microseconds. +-} +prettyTimeoutMcs :: Double -> Text +prettyTimeoutMcs timeoutS + | timeoutS > 86400 = T.pack $ printf "%.2f days" (timeoutS / 86400) + | timeoutS > 3600 = T.pack $ printf "%.2f hours" (timeoutS / 3600) + | timeoutS > 60 = T.pack $ printf "%.2f minutes" (timeoutS / 60) + | timeoutS > 1 = T.pack $ printf "%.2f seconds" timeoutS + | timeoutS > 1e-3 = T.pack $ printf "%.2f milliseconds" (timeoutS / 1e-3) + | timeoutS > 1e-6 = T.pack $ printf "%.2f microseconds" (timeoutS / 1e-6) + | timeoutS > 1e-9 = T.pack $ printf "%.2f nanoseconds" (timeoutS / 1e-9) + | otherwise = T.pack $ printf "%.2f seconds" timeoutS + +{- | +Internal helper. Pretty-printer for eventlog socket addresses. +-} +prettyEventlogSocketAddr :: EventlogSocketAddr -> Text +prettyEventlogSocketAddr = \case + EventlogSocketUnixAddr{..} -> "Unix socket " <> T.pack esaUnixPath + EventlogSocketInetAddr{..} -> "Inet socket " <> T.pack (esaInetHost <> ":" <> esaInetPort) diff --git a/src-lib/GHC/Eventlog/Live/Source/Core.hs b/src-lib/GHC/Eventlog/Live/Source/Core.hs new file mode 100644 --- /dev/null +++ b/src-lib/GHC/Eventlog/Live/Source/Core.hs @@ -0,0 +1,134 @@ +module GHC.Eventlog.Live.Source.Core ( + EventlogSourceOptions (..), + EventlogSocketAddr (..), + EventlogSourceHandle (..), + EventlogSourceData (..), + recv, +) where + +import Control.Exception (handle, throwIO) +import Data.ByteString (ByteString) +import Data.ByteString qualified as BS +import Data.Maybe (fromMaybe) +import Network.Socket (Socket) +import Network.Socket.ByteString qualified as SB +import System.IO (Handle) +import System.IO qualified as IO (stdin) +import System.IO.Error (isEOFError) +import System.Timeout (timeout) + +{- | +The options for different kinds of eventlog sources. +-} +data EventlogSourceOptions + = EventlogSourceOptionsStdin + | EventlogSourceOptionsFile FilePath + | EventlogSourceOptionsSocket EventlogSocketAddr + +{- | +The options for different kinds of eventlog sockets. +-} +data EventlogSocketAddr + = EventlogSocketUnixAddr + { esaUnixPath :: FilePath + {- ^ Unix socket path, e.g., @"\/tmp\/ghc_eventlog.sock"@. + + __Warning:__ Unix domain socket paths are often limited to 107 characters or less. + -} + } + | EventlogSocketInetAddr + { esaInetHost :: String + -- ^ TCP host or interface, e.g. @"127.0.0.1"@. + , esaInetPort :: String + -- ^ TCP port, e.g., @"4242"@. + } + deriving (Eq, Show) + +{- | +The handles for different kinds of eventlog sources. +-} +data EventlogSourceHandle + = EventlogSourceHandleStdin + | EventlogSourceHandleFile Handle + | EventlogSourceHandleSocket Socket + +data EventlogSourceData + = EventlogSourceData ByteString + | EventlogSourceTimeout + | EventlogSourceClosed + +{- | +Receive data from an `EventlogSourceHandle`. + +__Warning__: The current implementation is blocking on Windows. See the documentation for `timeout`. +-} +recv :: + -- | The handle to the eventlog source. + EventlogSourceHandle -> + -- | The timeout in microseconds. + Int -> + -- | The number of bytes to read. + Int -> + IO EventlogSourceData +recv = \case + EventlogSourceHandleStdin -> recvFromHandle IO.stdin + EventlogSourceHandleFile h -> recvFromHandle h + EventlogSourceHandleSocket s -> recvFromSocket s + +-- Permit a timeout and wrap the result appropriately. + +{- | +Internal helper. +Receive data from a `Socket`. +-} +recvFromSocket :: + -- | The eventlog socket. + Socket -> + -- | The timeout in microseconds. + Int -> + -- | The number of bytes to read. + Int -> + IO EventlogSourceData +recvFromSocket s timeoutMicros chunkSizeBytes = + withTimeout timeoutMicros $ do + msg <- SB.recv s chunkSizeBytes + if BS.null msg + then pure EventlogSourceClosed + else pure $ EventlogSourceData msg + +{- | +Internal helper. +Receive data from a `Handle`. +-} +recvFromHandle :: + -- | The handle to the eventlog source. + Handle -> + -- | The timeout in microseconds. + Int -> + -- | The number of bytes to read. + Int -> + IO EventlogSourceData +recvFromHandle h timeoutMicros chunkSizeBytes = + withTimeout timeoutMicros $ + handleEOFError EventlogSourceClosed $ + EventlogSourceData <$> BS.hGetSome h chunkSizeBytes + +{- | +Internal helper. +Allow the IO operation to timeout. +-} +withTimeout :: + -- | The timeout in microseconds. + Int -> + -- | The IO action to read data from the eventlog source. + IO EventlogSourceData -> + IO EventlogSourceData +withTimeout timeoutMicros = + fmap (fromMaybe EventlogSourceTimeout) . timeout timeoutMicros + +{- | +Internal helper. +Recover from an EOF error with a default value. +-} +handleEOFError :: a -> IO a -> IO a +handleEOFError d = handle (\e -> if isEOFError e then pure d else throwIO e) diff --git a/src/GHC/Eventlog/Live/Data/Attribute.hs b/src/GHC/Eventlog/Live/Data/Attribute.hs deleted file mode 100644 --- a/src/GHC/Eventlog/Live/Data/Attribute.hs +++ /dev/null @@ -1,172 +0,0 @@ -{- | -Module : GHC.Eventlog.Live.Attribute -Description : Representation for attributes. -Stability : experimental -Portability : portable --} -module GHC.Eventlog.Live.Data.Attribute ( - Attrs, - toList, - Attr, - AttrKey, - AttrValue (..), - IsAttrValue (..), - (~=), -) where - -import Data.HashMap.Strict (HashMap) -import Data.HashMap.Strict qualified as M -import Data.Hashable (Hashable) -import Data.Int (Int16, Int32, Int64, Int8) -import Data.Text (Text) -import Data.Text qualified as T -import Data.Word (Word16, Word32, Word64, Word8) -import GHC.Generics (Generic) -import GHC.IsList (IsList (..)) - -{- | -A set of attributes is a t`HashMap` --} -newtype Attrs = Attrs {attrMap :: HashMap AttrKey AttrValue} - deriving (Eq, Generic, Show) - -instance Hashable Attrs - -instance Semigroup Attrs where - (<>) :: Attrs -> Attrs -> Attrs - x <> y = Attrs{attrMap = x.attrMap <> y.attrMap} - -instance IsList Attrs where - type Item Attrs = Attr - - fromList :: [Item Attrs] -> Attrs - fromList = Attrs . M.fromList - - toList :: Attrs -> [Item Attrs] - toList = M.toList . (.attrMap) - -{- | -An attribute is a key-value pair where the key is any string and the value is -some numeric type, string, or null. Attributes should be constructed using the -`(~=)` operator, which automatically converts Haskell types to t`AttrValue`. --} -type Attr = (AttrKey, AttrValue) - -{- | -Construct an t`Attr` as a pair of an t`AttrKey` and an t`AttrValue`, -constructed via the t`IsAttrValue` class. --} -(~=) :: (IsAttrValue v) => AttrKey -> v -> Attr -k ~= v = (ak, av) - where - !ak = k - !av = toAttrValue v -{-# INLINE (~=) #-} - -{- | -The type of attribute keys. --} -type AttrKey = - Text - -{- | -The type of attribute values. --} -data AttrValue - = AttrInt !Int - | AttrInt8 !Int8 - | AttrInt16 !Int16 - | AttrInt32 !Int32 - | AttrInt64 !Int64 - | AttrWord !Word - | AttrWord8 !Word8 - | AttrWord16 !Word16 - | AttrWord32 !Word32 - | AttrWord64 !Word64 - | AttrDouble !Double - | AttrText !Text - | AttrNull - deriving (Eq, Generic, Show) - -instance Hashable AttrValue - -{- | -Utility class to help construct values of the t`AttrValue` type. --} -class IsAttrValue v where - toAttrValue :: v -> AttrValue - -instance IsAttrValue AttrValue where - toAttrValue :: AttrValue -> AttrValue - toAttrValue = id - {-# INLINE toAttrValue #-} - -instance IsAttrValue Int where - toAttrValue :: Int -> AttrValue - toAttrValue = AttrInt - {-# INLINE toAttrValue #-} - -instance IsAttrValue Int8 where - toAttrValue :: Int8 -> AttrValue - toAttrValue = AttrInt8 - {-# INLINE toAttrValue #-} - -instance IsAttrValue Int16 where - toAttrValue :: Int16 -> AttrValue - toAttrValue = AttrInt16 - {-# INLINE toAttrValue #-} - -instance IsAttrValue Int32 where - toAttrValue :: Int32 -> AttrValue - toAttrValue = AttrInt32 - {-# INLINE toAttrValue #-} - -instance IsAttrValue Int64 where - toAttrValue :: Int64 -> AttrValue - toAttrValue = AttrInt64 - {-# INLINE toAttrValue #-} - -instance IsAttrValue Word where - toAttrValue :: Word -> AttrValue - toAttrValue = AttrWord - {-# INLINE toAttrValue #-} - -instance IsAttrValue Word8 where - toAttrValue :: Word8 -> AttrValue - toAttrValue = AttrWord8 - {-# INLINE toAttrValue #-} - -instance IsAttrValue Word16 where - toAttrValue :: Word16 -> AttrValue - toAttrValue = AttrWord16 - {-# INLINE toAttrValue #-} - -instance IsAttrValue Word32 where - toAttrValue :: Word32 -> AttrValue - toAttrValue = AttrWord32 - {-# INLINE toAttrValue #-} - -instance IsAttrValue Word64 where - toAttrValue :: Word64 -> AttrValue - toAttrValue = AttrWord64 - {-# INLINE toAttrValue #-} - -instance IsAttrValue Double where - toAttrValue :: Double -> AttrValue - toAttrValue = AttrDouble - {-# INLINE toAttrValue #-} - -instance IsAttrValue String where - toAttrValue :: String -> AttrValue - toAttrValue = AttrText . T.pack - {-# INLINE toAttrValue #-} - -instance IsAttrValue Text where - toAttrValue :: Text -> AttrValue - toAttrValue = AttrText - {-# INLINE toAttrValue #-} - -instance (IsAttrValue v) => IsAttrValue (Maybe v) where - toAttrValue :: Maybe v -> AttrValue - toAttrValue = maybe AttrNull toAttrValue - {-# INLINE toAttrValue #-} diff --git a/src/GHC/Eventlog/Live/Data/Group.hs b/src/GHC/Eventlog/Live/Data/Group.hs deleted file mode 100644 --- a/src/GHC/Eventlog/Live/Data/Group.hs +++ /dev/null @@ -1,82 +0,0 @@ -{- | -Module : GHC.Eventlog.Live.Data.Group -Description : Core machines for processing data in batches. -Stability : experimental -Portability : portable --} -module GHC.Eventlog.Live.Data.Group ( - -- * GroupBy - GroupBy (..), - Group (..), - GroupedBy, - singleton, - elems, - groups, -) where - -import Data.HashMap.Strict (HashMap) -import Data.HashMap.Strict qualified as M -import Data.Hashable (Hashable (..)) -import Data.Kind (Type) -import Data.Semigroup (First (..), Last (..), Max (..), Min (..), Product (..), Sum (..)) - -{- | -This class defines the key to group by when aggregating. --} -class (Hashable (Key a)) => GroupBy a where - type Key a :: Type - toKey :: a -> Key a - -deriving newtype instance (GroupBy a) => GroupBy (First a) -deriving newtype instance (GroupBy a) => GroupBy (Last a) -deriving newtype instance (GroupBy a) => GroupBy (Max a) -deriving newtype instance (GroupBy a) => GroupBy (Min a) -deriving newtype instance (GroupBy a) => GroupBy (Product a) -deriving newtype instance (GroupBy a) => GroupBy (Sum a) - -{- | -This type defines a set of groups, grouped by the key given by `GroupBy`. --} -data GroupedBy a = (GroupBy a) => GroupedBy - { groups :: HashMap (Key a) (Group a) - } - -{- | -Internal helper. -This type defines a group representative and the group size. --} -data Group a = Group - { representative :: !a - , size :: !Word - } - deriving (Show, Functor, Foldable, Traversable) - -{- | -Construct the singleton `GroupedBy`. --} -singleton :: (GroupBy a) => a -> GroupedBy a -singleton a = GroupedBy{groups = M.singleton (toKey a) Group{representative = a, size = 1}} - -{- | -Get all group representatives from a `GroupedBy`. --} -elems :: GroupedBy a -> [a] -elems = fmap (.representative) . groups - -{- | -Get all group representatives and sizes from a `GroupedBy`. --} -groups :: GroupedBy a -> [Group a] -groups = M.elems . (.groups) - -instance (Semigroup a) => Semigroup (Group a) where - (<>) :: Group a -> Group a -> Group a - x <> y = - Group - { representative = x.representative <> y.representative - , size = x.size + y.size - } - -instance (Semigroup a, GroupBy a) => Semigroup (GroupedBy a) where - (<>) :: GroupedBy a -> GroupedBy a -> GroupedBy a - x <> y = GroupedBy{groups = M.unionWith (<>) x.groups y.groups} diff --git a/src/GHC/Eventlog/Live/Data/Metric.hs b/src/GHC/Eventlog/Live/Data/Metric.hs deleted file mode 100644 --- a/src/GHC/Eventlog/Live/Data/Metric.hs +++ /dev/null @@ -1,48 +0,0 @@ -{- | -Module : GHC.Eventlog.Live.Metric -Description : Representation for metrics. -Stability : experimental -Portability : portable --} -module GHC.Eventlog.Live.Data.Metric ( - Metric (..), -) where - -import Control.Exception (assert) -import GHC.Eventlog.Live.Data.Attribute (Attrs) -import GHC.Eventlog.Live.Data.Group (GroupBy (..)) -import GHC.RTS.Events (Timestamp) - -{- | -Metrics combine a measurement with a timestamp representing the time of the -measurement, a timestamp representing the earliest possible measurment, and -a list of attributes. --} -data Metric a = Metric - { value :: !a - -- ^ The measurement. - , maybeTimeUnixNano :: !(Maybe Timestamp) - -- ^ The time at which the measurment was taken. - , maybeStartTimeUnixNano :: !(Maybe Timestamp) - -- ^ The earliest time at which any measurement could have been taken. - -- Usually, this represents the start time of a process. - , attrs :: Attrs - -- ^ A set of attributes. - } - deriving (Functor, Show) - -instance GroupBy (Metric a) where - type Key (Metric a) = Attrs - toKey :: Metric a -> Attrs - toKey = (.attrs) - -instance (Semigroup a) => Semigroup (Metric a) where - (<>) :: Metric a -> Metric a -> Metric a - x <> y = - assert (x.attrs == y.attrs) $ - Metric - { value = x.value <> y.value - , maybeTimeUnixNano = x.maybeTimeUnixNano `max` y.maybeTimeUnixNano - , maybeStartTimeUnixNano = x.maybeStartTimeUnixNano `min` y.maybeStartTimeUnixNano - , attrs = x.attrs - } diff --git a/src/GHC/Eventlog/Live/Data/Span.hs b/src/GHC/Eventlog/Live/Data/Span.hs deleted file mode 100644 --- a/src/GHC/Eventlog/Live/Data/Span.hs +++ /dev/null @@ -1,25 +0,0 @@ -{- | -Module : GHC.Eventlog.Live.Span -Description : Representation for spans. -Stability : experimental -Portability : portable --} -module GHC.Eventlog.Live.Data.Span ( - IsSpan, - duration, -) where - -import GHC.RTS.Events (Timestamp) -import GHC.Records (HasField) - -{- | -A span is any type with a start and end time. --} -type IsSpan s = (HasField "startTimeUnixNano" s Timestamp, HasField "endTimeUnixNano" s Timestamp) - -{- | -Determine the duration of a span. --} -duration :: (IsSpan s) => s -> Timestamp -duration s = if s.startTimeUnixNano < s.endTimeUnixNano then s.endTimeUnixNano - s.startTimeUnixNano else 0 -{-# INLINEABLE duration #-} diff --git a/src/GHC/Eventlog/Live/Logger.hs b/src/GHC/Eventlog/Live/Logger.hs deleted file mode 100644 --- a/src/GHC/Eventlog/Live/Logger.hs +++ /dev/null @@ -1,117 +0,0 @@ -{-# LANGUAGE OverloadedStrings #-} - -{- | -Module : GHC.Eventlog.Live..Logger -Description : Logging functions. -Stability : experimental -Portability : portable --} -module GHC.Eventlog.Live.Logger ( - logError, - logWarning, - logInfo, - logDebug, -) where - -import Control.Exception (bracket_) -import Control.Monad.IO.Class (MonadIO (..)) -import Data.List qualified as L -import Data.Text (Text) -import Data.Text qualified as T -import Data.Text.IO qualified as TIO -import GHC.Eventlog.Live.Verbosity (Verbosity, showVerbosity, verbosityDebug, verbosityError, verbosityInfo, verbosityWarning) -import GHC.Stack (CallStack, HasCallStack, SrcLoc (..), callStack, getCallStack) -import System.Console.ANSI (Color (..), ColorIntensity (..), ConsoleLayer (..), SGR (..), hNowSupportsANSI, hSetSGR) -import System.IO qualified as IO - -{- | -Log messages to given handle. -Only prints a message if its verbosity level is above the verbosity threshold. --} -logMessage :: (MonadIO m) => IO.Handle -> CallStack -> Verbosity -> Verbosity -> Text -> m () -logMessage handle theCallStack verbosityLevel verbosityThreshold msg - | verbosityLevel >= verbosityThreshold = liftIO $ do - withVerbosityColor verbosityLevel handle - . flip TIO.hPutStrLn - . formatMessage verbosityLevel verbosityThreshold theCallStack - $ msg - IO.hFlush handle - | otherwise = pure () - -{- | -Internal helper. -Format the `CallStack`. --} -formatCallStack :: CallStack -> Text -formatCallStack theCallStack = - maybe T.empty (formatSrcLoc . snd . fst) (L.uncons (getCallStack theCallStack)) - where - formatSrcLoc :: SrcLoc -> Text - formatSrcLoc srcLoc = - mconcat [T.pack srcLoc.srcLocFile, ":", T.pack (show srcLoc.srcLocStartLine), ":", T.pack (show srcLoc.srcLocStartCol)] - -{- | -Internal helper. -Format the message appropriately for the given verbosity level and threshold. --} -formatMessage :: Verbosity -> Verbosity -> CallStack -> Text -> Text -formatMessage verbosityLevel verbosityThreshold theCallStack msg - | verbosityLevel == verbosityInfo && verbosityThreshold /= verbosityDebug = msg - | otherwise = mconcat [showVerbosity verbosityLevel, " (", formatCallStack theCallStack, "): ", msg] - -{- | -Internal helper. -Use a handle with the color set appropriately for the given verbosity level. --} -withVerbosityColor :: Verbosity -> IO.Handle -> (IO.Handle -> IO a) -> IO a -withVerbosityColor verbosity handle action = do - supportsANSI <- hNowSupportsANSI handle - if not supportsANSI - then - action handle - else case verbosityColor verbosity of - Nothing -> - action handle - Just color -> do - let setVerbosityColor = hSetSGR handle [SetColor Foreground Vivid color] - let setDefaultColor = hSetSGR handle [SetDefaultColor Foreground] - bracket_ setVerbosityColor setDefaultColor $ action handle - -{- | -Internal helper. -Determine the ANSI color associated with a particular verbosity level. --} -verbosityColor :: Verbosity -> Maybe Color -verbosityColor verbosity - | verbosity == verbosityError = Just Red - | verbosity == verbosityWarning = Just Yellow - | verbosity == verbosityDebug = Just Blue - | otherwise = Nothing - -{- | -Log errors to `IO.stderr`. --} -logError :: (HasCallStack, MonadIO m) => Verbosity -> Text -> m () -logError = logMessage IO.stderr callStack verbosityError - -{- | -Log warnings to `IO.stderr`. --} -logWarning :: (HasCallStack, MonadIO m) => Verbosity -> Text -> m () -logWarning = logMessage IO.stderr callStack verbosityWarning - -{- | -Log info messages to `IO.stderr`. --} -logInfo :: (HasCallStack, MonadIO m) => Verbosity -> Text -> m () -logInfo verbosityThreshold = logMessage handle callStack verbosityInfo verbosityThreshold - where - handle - | verbosityThreshold <= verbosityDebug = IO.stderr - | otherwise = IO.stdout - -{- | -Log debug messages to `IO.stderr`. --} -logDebug :: (HasCallStack, MonadIO m) => Verbosity -> Text -> m () -logDebug = logMessage IO.stderr callStack verbosityDebug diff --git a/src/GHC/Eventlog/Live/Machine/Analysis/Capability.hs b/src/GHC/Eventlog/Live/Machine/Analysis/Capability.hs deleted file mode 100644 --- a/src/GHC/Eventlog/Live/Machine/Analysis/Capability.hs +++ /dev/null @@ -1,478 +0,0 @@ -{-# LANGUAGE OverloadedLists #-} -{-# LANGUAGE OverloadedStrings #-} -{-# OPTIONS_GHC -Wno-name-shadowing #-} - -{- | -Module : GHC.Eventlog.Live.Machine -Description : Machines for processing eventlog data. -Stability : experimental -Portability : portable --} -module GHC.Eventlog.Live.Machine.Analysis.Capability ( - -- * Capability Usage - - -- ** Capability Usage Metrics - processCapabilityUsageMetrics, - - -- ** Capability Usage Spans - CapabilityUsageSpan, - CapabilityUser (..), - capabilityUser, - showCapabilityUserCategory, - processCapabilityUsageSpans, - processCapabilityUsageSpans', - - -- ** GC Spans - GCSpan (..), - processGCSpans, - processGCSpans', - - -- ** Mutator Spans - MutatorSpan (..), - asMutatorSpans, - asMutatorSpans', - processMutatorSpans, - processMutatorSpans', -) where - -import Control.Monad (when) -import Control.Monad.IO.Class (MonadIO (..)) -import Data.Char (isSpace) -import Data.Foldable (for_) -import Data.Machine (Is (..), PlanT, ProcessT, asParts, await, construct, mapping, repeatedly, yield, (~>)) -import Data.Machine.Fanout (fanout) -import Data.Text (Text) -import Data.Text qualified as T -import Data.Void (Void) -import GHC.Eventlog.Live.Data.Attribute (AttrValue, IsAttrValue (..), (~=)) -import GHC.Eventlog.Live.Data.Metric (Metric (..)) -import GHC.Eventlog.Live.Data.Span (duration) -import GHC.Eventlog.Live.Logger (logWarning) -import GHC.Eventlog.Live.Machine.Analysis.Thread (ThreadState (..), ThreadStateSpan (..), processThreadStateSpans') -import GHC.Eventlog.Live.Machine.Core (liftRouter) -import GHC.Eventlog.Live.Machine.WithStartTime (WithStartTime (..), setWithStartTime'value, tryGetTimeUnixNano) -import GHC.Eventlog.Live.Verbosity (Verbosity) -import GHC.RTS.Events (Event (..), EventInfo, ThreadId, Timestamp) -import GHC.RTS.Events qualified as E -import GHC.Records (HasField (..)) -import Text.Printf (printf) - -------------------------------------------------------------------------------- --- Capability Usage Metrics - -{- | -This machine processes t`CapabilityUsageSpan` spans and produces metrics that -contain the duration and category of each such span and each idle period in -between. --} -processCapabilityUsageMetrics :: - forall m. - (MonadIO m) => - ProcessT m (WithStartTime CapabilityUsageSpan) (Metric Timestamp) -processCapabilityUsageMetrics = - liftRouter measure spawn - where - measure :: WithStartTime CapabilityUsageSpan -> Maybe Int - measure = Just . (.value.cap) - - spawn :: Int -> ProcessT m (WithStartTime CapabilityUsageSpan) (Metric Timestamp) - spawn cap = construct $ go Nothing - where - go :: - Maybe CapabilityUsageSpan -> - PlanT (Is (WithStartTime CapabilityUsageSpan)) (Metric Timestamp) m Void - go mi = - await >>= \j -> do - -- If there is a previous span, and... - for_ mi $ \i -> - -- ...the end time of the previous span precedes the start time of the current span, then... - when (i.endTimeUnixNano < j.value.startTimeUnixNano) $ - -- ...yield an idle duration metric. - yield - Metric - { value = j.value.startTimeUnixNano - i.endTimeUnixNano - , maybeTimeUnixNano = Just i.endTimeUnixNano - , maybeStartTimeUnixNano = j.maybeStartTimeUnixNano - , attrs = ["cap" ~= cap, "category" ~= ("Idle" :: Text)] - } - -- Yield a duration metric for the current span. - let user = capabilityUser j.value - yield - Metric - { value = duration j.value - , maybeTimeUnixNano = Just j.value.startTimeUnixNano - , maybeStartTimeUnixNano = j.maybeStartTimeUnixNano - , attrs = ["cap" ~= cap, "category" ~= showCapabilityUserCategory user, "user" ~= user] - } - go (Just j.value) - -{- | -The type of process using a capability, -which is either a mutator thread or garbage collection. --} -data CapabilityUser - = GC - | Mutator {thread :: !ThreadId} - -instance Show CapabilityUser where - show :: CapabilityUser -> String - show = \case - GC -> "GC" - Mutator{thread} -> show thread - -instance IsAttrValue CapabilityUser where - toAttrValue :: CapabilityUser -> AttrValue - toAttrValue = toAttrValue . show - {-# INLINE toAttrValue #-} - -{- | -Get the t`CapabilityUser` associated with a t`CapabilityUsageSpan`. --} -capabilityUser :: CapabilityUsageSpan -> CapabilityUser -capabilityUser = either (const GC) (Mutator . (.thread)) - -{- | -Show the category of a `CapabilityUser` as either @"GC"@ or @"Mutator"@. --} -showCapabilityUserCategory :: CapabilityUser -> Text -showCapabilityUserCategory = \case - GC{} -> "GC" - Mutator{} -> "Mutator" - -------------------------------------------------------------------------------- --- Capability Usage Spans - -{- | -A t`CapabilityUsageSpan` is either a t`GCSpan` or a t`MutatorSpan`. --} -type CapabilityUsageSpan = Either GCSpan MutatorSpan - -instance HasField "startTimeUnixNano" CapabilityUsageSpan Timestamp where - getField :: CapabilityUsageSpan -> Timestamp - getField = either (.startTimeUnixNano) (.startTimeUnixNano) - -instance HasField "endTimeUnixNano" CapabilityUsageSpan Timestamp where - getField :: CapabilityUsageSpan -> Timestamp - getField = either (.endTimeUnixNano) (.endTimeUnixNano) - -instance HasField "cap" CapabilityUsageSpan Int where - getField :: CapabilityUsageSpan -> Int - getField = either (.cap) (.cap) - -{-# SPECIALIZE duration :: CapabilityUsageSpan -> Timestamp #-} - -{- | -This machine runs `processGCSpans` and `processMutatorSpans` in parallel and -combines their output. - -This is effectively a fanout of `processGCSpans` and `processMutatorSpans`, the -latter of which runs `processThreadStateSpans` internally. If you are running -`processThreadStateSpans` as well, then using `asMutatorSpans` and constructing -the fanout yourself is more efficient. --} -processCapabilityUsageSpans :: - forall m. - (MonadIO m) => - Verbosity -> - ProcessT m (WithStartTime Event) (WithStartTime CapabilityUsageSpan) -processCapabilityUsageSpans verbosity = - processCapabilityUsageSpans' tryGetTimeUnixNano (.value) setWithStartTime'value setWithStartTime'value verbosity - ~> mapping (either (fmap Left) (fmap Right)) - -{- | -Generalised version of `processCapabilityUsageSpans` that can be adapted to -work on arbitrary types using a getter and a pair of lenses. --} -processCapabilityUsageSpans' :: - forall m s t1 t2. - (MonadIO m) => - (s -> Maybe Timestamp) -> - (s -> Event) -> - (s -> GCSpan -> t1) -> - (s -> MutatorSpan -> t2) -> - Verbosity -> - ProcessT m s (Either t1 t2) -processCapabilityUsageSpans' timeUnixNano getEvent setGCSpan setMutatorSpan verbosity = - -- NOTE: - -- Combining this fanout with an `Either` is risky, because it - -- has the potential to lose information if both `processGCSpans` - -- and `processMutatorSpans` yield a value for the same input. - -- However, this shouldn't ever happen, since the two processors - -- process disjoint sets of events. - fanout - [ processGCSpans' timeUnixNano getEvent setGCSpan verbosity - ~> mapping Left - , processMutatorSpans' timeUnixNano getEvent setMutatorSpan verbosity - ~> mapping Right - ] - -------------------------------------------------------------------------------- --- GC spans - -{- | -A t`GCSpan` represents a segment of time during which the specified capability -ran GC. --} -data GCSpan = GCSpan - { cap :: !Int - , startTimeUnixNano :: !Timestamp - , endTimeUnixNano :: !Timestamp - } - deriving (Show) - -{-# SPECIALIZE duration :: GCSpan -> Timestamp #-} - -{- | -This machine processes `E.StartGC` and `E.EndGC` events to produce t`GCSpan` -values that represent the segments of time a capability spent in GC. - -This processor uses the following finite-state automaton: - -@ - ┌─(EndGC)───┐ - │ ↓ - ┌→[ Idle ]─┐ - │ │ -(EndGC) (StartGC) - │ │ - └─[ GC ]←┘ - ↑ │ - └─(StartGC)─┘ -@ - -The transition from @GC@ to @Idle@ yields a GC span. --} -processGCSpans :: - forall m. - (MonadIO m) => - Verbosity -> - ProcessT m (WithStartTime Event) (WithStartTime GCSpan) -processGCSpans = - processGCSpans' tryGetTimeUnixNano (.value) setWithStartTime'value - -{- | -Generalised version of `processGCSpans` that can be adapted to work on -arbitrary types using a getter and a lens. --} -processGCSpans' :: - forall m s t. - (MonadIO m) => - (s -> Maybe Timestamp) -> - (s -> Event) -> - (s -> GCSpan -> t) -> - Verbosity -> - ProcessT m s t -processGCSpans' timeUnixNano getEvent setGCSpan verbosity = - liftRouter measure spawn - where - getEventTime = (.evTime) . getEvent - getEventInfo = (.evSpec) . getEvent - getEventCap = (.evCap) . getEvent - - measure :: s -> Maybe Int - measure i - | accept (getEventInfo i) = getEventCap i - | otherwise = Nothing - where - accept E.StartGC{} = True - accept E.EndGC{} = True - accept _ = False - - -- TODO: Rewrite using `MealyT` - spawn :: Int -> ProcessT m s t - spawn cap = construct $ go Nothing - where - -- The "mi" variable tracks the previous event for this capability, which - -- is either `Nothing` or `Just` a `StartGC` or a `EndGC` event. - go :: Maybe s -> PlanT (Is s) t m Void - go mi = - -- We start by awaiting the next event "j"... - await >>= \j -> case getEventInfo j of - -- If the next event is a `RunThread` event, and... - E.StartGC{} -> case mi of - Just i - -- If the previous event was a `StartGC` event, then... - | E.StartGC{} <- getEventInfo i -> - -- ...continue with the oldest event. - go (Just $ minBy getEventTime i j) - -- If the previous event was a `EndGC` event, then... - | E.EndGC{} <- getEventInfo i -> - -- ...continue with the current event. - go (Just j) - -- If the previous event was any other event, then... - | otherwise -> do - -- ...emit an error, and... - logWarning verbosity . T.pack $ - printf - "Capability %d: Unsupported trace %s --> %s" - cap - (showEventInfo (getEventInfo i)) - (showEventInfo (getEventInfo j)) - -- ...continue with the previous event. - go (Just i) - -- If there was no previous event, then... - Nothing -> - -- ...continue with the current event. - go (Just j) - -- If the next event is a `StopThread` event... - E.EndGC{} -> case mi of - Just i - -- If the previous event was a `StartGC` event, then... - | E.StartGC{} <- getEventInfo i - , Just startTimeUnixNano <- timeUnixNano i - , Just endTimeUnixNano <- timeUnixNano j -> do - -- ...yield a GC span, and... - yield . setGCSpan j $ GCSpan{..} - -- ...continue with the current event. - go (Just j) - -- If the previous event was a `EndGC` event, then... - | E.EndGC{} <- getEventInfo i -> - -- ...continue with the oldest event. - go (Just $ minBy getEventTime i j) - -- If there was no previous event or it was any other event, then... - _otherwise -> do - -- ...emit an error, and... - logWarning verbosity . T.pack $ - printf - "Capability %d: Unsupported trace %s --> %s" - cap - (maybe "?" (showEventInfo . getEventInfo) mi) - (showEventInfo (getEventInfo j)) - -- ...continue with the previous event. - go mi - -- If the next event is any other event, ignore it. - _otherwise -> go mi - -------------------------------------------------------------------------------- --- Mutator spans - -{- | -A t`MutatorSpan` represents a segment of time during which the specified -capability ran the specified mutator thread. --} -data MutatorSpan = MutatorSpan - { cap :: !Int - , thread :: !ThreadId - , startTimeUnixNano :: !Timestamp - , endTimeUnixNano :: !Timestamp - } - deriving (Show) - -{-# SPECIALIZE duration :: MutatorSpan -> Timestamp #-} - -{- | -This machine processes `E.RunThread` and `E.StopThread` events to produce -t`MutatorSpan` values that represent the segments of time a capability spent -executating a mutator. - -This processor uses the following finite-state automaton: - -@ - ┌─(StopThread[X])─┐ - │ ↓ - ┌→[ Idle ]─┐ - │ │ -(StopThread[X]) (RunThread[X]) - │ │ - └─[ Mutator[X] ]←┘ - ↑ │ - └─(RunThread[X])──┘ -@ - -The transition from @Mutator[X]@ to @Idle@ yields a t`MutatorSpan`. -While in the @Mutator[X]@ state, any @RunThread[Y]@ or @StopThread[Y]@ events result in an error. -Furthermore, when a @StopThread[X]@ event with the @ThreadFinished@ status is processed, -the thread @X@ is added to a set of finished threads, -and any further @RunThread[X]@ events for that thread are ignored. -This is done because the GHC RTS frequently emits a @RunThread[X]@ event -immediately after a @StopThread[X]@ event with the @ThreadFinished@ status. - -This runs `processThreadStateSpans` internally. If you are also running -`processThreadStateSpans`, then post-composing it with `asMutatorSpans` -is more efficient. --} -processMutatorSpans :: - forall m. - (MonadIO m) => - Verbosity -> - ProcessT m (WithStartTime Event) (WithStartTime MutatorSpan) -processMutatorSpans = - processMutatorSpans' tryGetTimeUnixNano (.value) setWithStartTime'value - -{- | -Generalised version of `processMutatorSpans` that can be adapted to work on -arbitrary types using a getter and a lens. --} -processMutatorSpans' :: - forall m s t. - (MonadIO m) => - (s -> Maybe Timestamp) -> - (s -> Event) -> - (s -> MutatorSpan -> t) -> - Verbosity -> - ProcessT m s t -processMutatorSpans' timeUnixNano getEvent setMutatorSpan verbosity = - processThreadStateSpans' timeUnixNano getEvent setThreadStateSpan verbosity ~> asParts - where - setThreadStateSpan :: s -> ThreadStateSpan -> Maybe t - setThreadStateSpan s threadStateSpan = - setMutatorSpan s <$> threadStateSpanToMutatorSpan threadStateSpan - -{- | -This machine converts any `Running` t`ThreadStateSpan` to a t`MutatorSpan`. --} -asMutatorSpans :: - forall m. - (MonadIO m) => - ProcessT m ThreadStateSpan MutatorSpan -asMutatorSpans = asMutatorSpans' id (const id) - -{- | -Generalised version of `asMutatorSpans` that can be adapted to work on -arbitrary types using a getter and a lens. --} -asMutatorSpans' :: - forall m s t. - (MonadIO m) => - (s -> ThreadStateSpan) -> - (s -> MutatorSpan -> t) -> - ProcessT m s t -asMutatorSpans' getThreadStateSpan setMutatorSpan = repeatedly go - where - go = - await >>= \s -> do - let threadStateSpan = getThreadStateSpan s - let maybeMutatorSpan = threadStateSpanToMutatorSpan threadStateSpan - for_ maybeMutatorSpan $ yield . setMutatorSpan s - -{- | -Convert the `Running` t`ThreadStateSpan` to `Just` a t`MutatorSpan`. --} -threadStateSpanToMutatorSpan :: ThreadStateSpan -> Maybe MutatorSpan -threadStateSpanToMutatorSpan ThreadStateSpan{..} = - case threadState of - Running{..} -> Just MutatorSpan{..} - _otherwise -> Nothing - -------------------------------------------------------------------------------- --- Internal Helpers -------------------------------------------------------------------------------- - -{- | -Internal helper. -Show `EventInfo` in a condensed format suitable for logging. --} -showEventInfo :: EventInfo -> String -showEventInfo = \case - E.RunThread{thread} -> printf "RunThread{%d}" thread - E.StopThread{thread, status} -> printf "StopThread{%d,%s}" thread (E.showThreadStopStatus status) - E.MigrateThread{thread} -> printf "MigrateThread{%d}" thread - E.StartGC{} -> "StartGC" - E.EndGC{} -> "EndGC" - evSpec -> takeWhile (not . isSpace) . show $ evSpec - -{- | -Internal helper. Return the minimal value by some projection. --} -minBy :: (Ord b) => (a -> b) -> a -> a -> a -minBy f x y = if f x < f y then x else y diff --git a/src/GHC/Eventlog/Live/Machine/Analysis/Heap.hs b/src/GHC/Eventlog/Live/Machine/Analysis/Heap.hs deleted file mode 100644 --- a/src/GHC/Eventlog/Live/Machine/Analysis/Heap.hs +++ /dev/null @@ -1,530 +0,0 @@ -{-# LANGUAGE OverloadedLists #-} -{-# LANGUAGE OverloadedStrings #-} -{-# OPTIONS_GHC -Wno-name-shadowing #-} - -{- | -Module : GHC.Eventlog.Live.Machine.Analysis.Heap -Description : Machines for processing eventlog data. -Stability : experimental -Portability : portable --} -module GHC.Eventlog.Live.Machine.Analysis.Heap ( - -- * Heap Usage - processHeapAllocatedData, - processHeapSizeData, - processBlocksSizeData, - processHeapLiveData, - MemReturnData (..), - processMemReturnData, - HeapProfSampleData, - heapProfSamples, - processHeapProfSampleData, - - -- ** Heap Profile Breakdown - heapProfBreakdownEitherReader, - heapProfBreakdownShow, -) where - -import Control.Monad (unless, when) -import Control.Monad.IO.Class (MonadIO (..)) -import Data.Either (isLeft) -import Data.Foldable (for_) -import Data.HashMap.Strict (HashMap) -import Data.HashMap.Strict qualified as M -import Data.Hashable (Hashable (..)) -import Data.List qualified as L -import Data.Machine (Process, ProcessT, await, construct, repeatedly, yield) -import Data.Maybe (isJust, listToMaybe, mapMaybe) -import Data.Text (Text) -import Data.Text qualified as T -import Data.Word (Word32, Word64) -import GHC.Eventlog.Live.Data.Attribute (Attrs, (~=)) -import GHC.Eventlog.Live.Data.Group (GroupBy (..)) -import GHC.Eventlog.Live.Data.Metric (Metric (..)) -import GHC.Eventlog.Live.Logger (logWarning) -import GHC.Eventlog.Live.Machine.WithStartTime (WithStartTime (..), tryGetTimeUnixNano) -import GHC.Eventlog.Live.Verbosity (Verbosity) -import GHC.RTS.Events (Event (..), HeapProfBreakdown (..)) -import GHC.RTS.Events qualified as E -import Numeric (showHex) -import Text.ParserCombinators.ReadP (readP_to_S) -import Text.ParserCombinators.ReadP qualified as P -import Text.Printf (printf) -import Text.Read (readMaybe) -import Text.Read.Lex (readHexP) - -------------------------------------------------------------------------------- --- Heap events -------------------------------------------------------------------------------- - --------------------------------------------------------------------------------- --- HeapAllocated - -{- | -This machine processes `E.HeapAllocated` events into metrics. --} -processHeapAllocatedData :: Process (WithStartTime Event) (Metric Word64) -processHeapAllocatedData = - repeatedly $ - await >>= \case - i - | E.HeapAllocated{..} <- i.value.evSpec -> - yield $ - metric i allocBytes $ - [ "evCap" ~= i.value.evCap - , "heapCapset" ~= heapCapset - ] - | otherwise -> pure () - -------------------------------------------------------------------------------- --- HeapSize - -{- | -This machine processes `E.HeapSize` events into metrics. --} -processHeapSizeData :: Process (WithStartTime Event) (Metric Word64) -processHeapSizeData = repeatedly go - where - go = - await >>= \case - i - | E.HeapSize{..} <- i.value.evSpec -> do - yield $ - metric i sizeBytes $ - [ "evCap" ~= i.value.evCap - , "heapCapset" ~= heapCapset - ] - | otherwise -> pure () - -------------------------------------------------------------------------------- --- BlocksSize - -{- | -This machine processes `E.BlocksSize` events into metrics. --} -processBlocksSizeData :: Process (WithStartTime Event) (Metric Word64) -processBlocksSizeData = - repeatedly $ - await >>= \case - i - | E.BlocksSize{..} <- i.value.evSpec -> do - yield $ - metric i blocksSize $ - [ "evCap" ~= i.value.evCap - , "heapCapset" ~= heapCapset - ] - | otherwise -> pure () - -------------------------------------------------------------------------------- --- HeapLive - -{- | -This machine processes `E.HeapLive` events into metrics. --} -processHeapLiveData :: Process (WithStartTime Event) (Metric Word64) -processHeapLiveData = - repeatedly $ - await >>= \case - i - | E.HeapLive{..} <- i.value.evSpec -> do - yield $ - metric i liveBytes $ - [ "evCap" ~= i.value.evCap - , "heapCapset" ~= heapCapset - ] - | otherwise -> pure () - -------------------------------------------------------------------------------- --- MemReturn - -{- | -The type of data associated with a `E.MemReturn` event. --} -data MemReturnData = MemReturnData - { current :: !Word32 - -- ^ The number of megablocks currently allocated. - , needed :: !Word32 - -- ^ The number of megablocks currently needed. - , returned :: !Word32 - -- ^ The number of megablocks currently being returned to the OS. - } - -{- | -This machine processes `E.MemReturn` events into metrics. --} -processMemReturnData :: Process (WithStartTime Event) (Metric MemReturnData) -processMemReturnData = - repeatedly $ - await >>= \case - i - | E.MemReturn{..} <- i.value.evSpec -> do - yield $ - metric i MemReturnData{..} $ - [ "evCap" ~= i.value.evCap - , "heapCapset" ~= heapCapset - ] - | otherwise -> pure () - -------------------------------------------------------------------------------- --- HeapProfSample - -{- | -The type of all heap profile samples from a single garbage collection pass. --} -newtype HeapProfSampleData = HeapProfSampleData - { heapProfSampleMap :: HashMap Text (Metric Word64) - } - deriving (Show) - deriving newtype (Semigroup, Monoid) - -instance GroupBy HeapProfSampleData where - type Key HeapProfSampleData = () - - toKey :: HeapProfSampleData -> () - toKey = const () - -{- | -Get the elements of a heap profile sample collection. --} -heapProfSamples :: HeapProfSampleData -> [Metric Word64] -heapProfSamples = M.elems . (.heapProfSampleMap) - -{- | -Internal helper. -Insert a heap profiling sample into the collection. --} -insertHeapProfSampleString :: - forall m. - (MonadIO m) => - Verbosity -> - Text -> - Metric Word64 -> - HeapProfSampleData -> - m HeapProfSampleData -insertHeapProfSampleString verbosityThreshold heapProfLabel heapProfSample heapProfSamples = do - let insert :: Maybe (Metric Word64) -> m (Maybe (Metric Word64)) - insert heapProfSample' = do - when (isJust heapProfSample') $ - logWarning verbosityThreshold $ - "Duplicate HeapProfSampleString for " <> heapProfLabel <> " within the same garbage collection pass." - pure (Just heapProfSample) - heapProfSampleMap' <- M.alterF insert heapProfLabel heapProfSamples.heapProfSampleMap - pure HeapProfSampleData{heapProfSampleMap = heapProfSampleMap'} - -{- | -Internal helper. -The type of info table pointers. --} -newtype InfoTablePtr = InfoTablePtr Word64 - deriving newtype (Eq, Hashable, Ord) - -instance Show InfoTablePtr where - showsPrec :: Int -> InfoTablePtr -> ShowS - showsPrec _ (InfoTablePtr ptr) = - showString "0x" . showHex ptr - -instance Read InfoTablePtr where - readsPrec :: Int -> ReadS InfoTablePtr - readsPrec _ = readP_to_S (InfoTablePtr <$> (P.string "0x" *> readHexP)) - -{- | -Internal helper. -The type of an info table entry, as produced by the `E.InfoTableProv` event. --} -data InfoTable = InfoTable - { infoTablePtr :: !InfoTablePtr - , infoTableName :: !Text - , infoTableClosureDesc :: !Int - , infoTableTyDesc :: !Text - , infoTableLabel :: !Text - , infoTableModule :: !Text - , infoTableSrcLoc :: !Text - } - deriving (Show) - -{- | -Internal helper. -The type of the state kept by `processHeapProfSampleData`. --} -data HeapProfSampleState = HeapProfSampleState - { eitherShouldWarnOrHeapProfBreakdown :: !(Either Bool HeapProfBreakdown) - , infoTableMap :: !(HashMap InfoTablePtr InfoTable) - , heapProfSampleEraStack :: ![Word64] - , maybeHeapProfSampleData :: !(Maybe HeapProfSampleData) - } - deriving (Show) - -{- | -Internal helper. -Decides whether or not `processHeapProfSampleData` should track info tables. -We track info tables until (1) we learn that the RTS is not run with @-hi@, -or (2) we see the first heap profiling sample and don't yet know for sure -that the RTS is run with @-hi@. --} -shouldTrackInfoTableMap :: Either Bool HeapProfBreakdown -> Bool -shouldTrackInfoTableMap (Left _shouldWarn) = True -shouldTrackInfoTableMap (Right HeapProfBreakdownInfoTable) = True -shouldTrackInfoTableMap _ = False - -{- | -Internal helper. -Checks whether a `HeapProfBreakdown` is `HeapProfBreakdownInfoTable`. -This is needed because the ghc-events package does not define an `Eq` -instance for the `HeapProfBreakdown` type. --} -isHeapProfBreakdownInfoTable :: HeapProfBreakdown -> Bool -isHeapProfBreakdownInfoTable HeapProfBreakdownInfoTable = True -isHeapProfBreakdownInfoTable _ = False - -{- | -This machine processes `E.HeapProfSampleString` events into metrics. -Furthermore, it processes the `E.HeapProfBegin` and `E.ProgramArgs` events -to determine the heap profile breakdown, processes `E.InfoTableProv` events to -build an info table map, if necessary, and processes `E.HeapProfSampleBegin` -and `E.HeapProfSampleEnd` events to maintain an era stack. --} -processHeapProfSampleData :: - (MonadIO m) => - Verbosity -> - Maybe HeapProfBreakdown -> - ProcessT m (WithStartTime Event) HeapProfSampleData -processHeapProfSampleData verbosityThreshold maybeHeapProfBreakdown = - construct $ - go - HeapProfSampleState - { eitherShouldWarnOrHeapProfBreakdown = maybe (Left True) Right maybeHeapProfBreakdown - , infoTableMap = mempty - , heapProfSampleEraStack = mempty - , maybeHeapProfSampleData = mempty - } - where - -- go :: HeapProfSampleState -> PlanT (Is (WithStartTime Event)) HeapProfSampleData m Void - go st@HeapProfSampleState{..} = do - await >>= \i -> case i.value.evSpec of - -- Announces the heap profile breakdown, amongst other things. - -- This event is only emitted for code compiled with GHC >=9.14. - E.HeapProfBegin{..} - | isLeft eitherShouldWarnOrHeapProfBreakdown -> - go st{eitherShouldWarnOrHeapProfBreakdown = Right heapProfBreakdown} - -- Announces the arguments with which the program was called. - -- This *may* include RTS options, which can be used to determine the - -- heap profile breakdown for code compiled with GHC <9.14. - E.ProgramArgs{..} - | isLeft eitherShouldWarnOrHeapProfBreakdown - , Just heapProfBreakdown <- findHeapProfBreakdown args -> - go st{eitherShouldWarnOrHeapProfBreakdown = Right heapProfBreakdown} - -- Announces an info table entry. - E.InfoTableProv{..} - | shouldTrackInfoTableMap eitherShouldWarnOrHeapProfBreakdown -> do - let infoTablePtr = InfoTablePtr itInfo - infoTable = - InfoTable - { infoTablePtr = infoTablePtr - , infoTableName = itTableName - , infoTableClosureDesc = itClosureDesc - , infoTableTyDesc = itTyDesc - , infoTableLabel = itLabel - , infoTableModule = itModule - , infoTableSrcLoc = itSrcLoc - } - go st{infoTableMap = M.insert infoTablePtr infoTable infoTableMap} - -- Announces the beginning of a heap profile sample. - E.HeapProfSampleBegin{..} -> do - -- Check that maybeHeapProfSampleData is Nothing. - for_ st.maybeHeapProfSampleData $ \heapProfSampleData -> do - logWarning - verbosityThreshold - "Unexpected event HeapProfSampleBegin while previous garbage collection pass was left open.\n\ - \This may indicate that the eventlog is not properly ordered or that its semantics have changed." - -- Yield the previous sample data anyway. - yield heapProfSampleData - -- Start a new garbage collection pass. - go - st - { heapProfSampleEraStack = heapProfSampleEra : heapProfSampleEraStack - , maybeHeapProfSampleData = Just mempty - } - -- Announces the end of a heap profile sample. - E.HeapProfSampleEnd{..} -> do - -- Yield the previous heap profile sample data - for_ st.maybeHeapProfSampleData yield - -- Pop the heapProfSampleEraStack - heapProfSampleEraStack' <- - case L.uncons heapProfSampleEraStack of - Nothing -> do - logWarning verbosityThreshold . T.pack $ - printf - "Eventlog closed era %d, but there is no current era." - heapProfSampleEra - pure heapProfSampleEraStack - Just (currentEra, heapProfSampleEraStack') -> do - unless (currentEra == heapProfSampleEra) $ - logWarning verbosityThreshold . T.pack $ - printf - "Eventlog closed era %d, but the current era is era %d." - heapProfSampleEra - currentEra - pure heapProfSampleEraStack' - go - st - { heapProfSampleEraStack = heapProfSampleEraStack' - , maybeHeapProfSampleData = Nothing - } - -- Announces a heap profile sample. - E.HeapProfSampleString{..} - -- If there is no heap profile breakdown, issue a warning, then disable warnings. - | Left True <- eitherShouldWarnOrHeapProfBreakdown -> do - logWarning verbosityThreshold $ - "Cannot infer heap profile breakdown.\n\ - \ If your binary was compiled with a GHC version prior to 9.14,\n\ - \ you must also pass the heap profile type to this executable.\n\ - \ See: https://gitlab.haskell.org/ghc/ghc/-/commit/76d392a" - go st{eitherShouldWarnOrHeapProfBreakdown = Left False, infoTableMap = mempty} - -- If the heap profile breakdown is biographical, issue a warning, then disable warnings. - | Right HeapProfBreakdownBiography <- eitherShouldWarnOrHeapProfBreakdown -> do - logWarning verbosityThreshold . T.pack $ - printf - "Unsupported heap profile breakdown %s" - (heapProfBreakdownShow HeapProfBreakdownBiography) - go st{eitherShouldWarnOrHeapProfBreakdown = Left False, infoTableMap = mempty} - -- If there is a heap profile breakdown, handle it appropriately. - | Right heapProfBreakdown <- eitherShouldWarnOrHeapProfBreakdown -> do - -- If the heap profile breakdown is by info table, add the info table. - let maybeInfoTable - | isHeapProfBreakdownInfoTable heapProfBreakdown = do - !infoTablePtr <- readMaybe (T.unpack heapProfLabel) - M.lookup infoTablePtr infoTableMap - | otherwise = Nothing - -- Get the HeapProfSampleData - heapProfSampleData <- - case st.maybeHeapProfSampleData of - Nothing -> do - logWarning verbosityThreshold $ - "Unexpected event HeapProfSampleString out of scope of HeapProfSampleBegin and HeapProfSampleEnd.\n\ - \This may indicate that the eventlog is not properly ordered or that its semantics have changed." - pure mempty - Just heapProfSampleData -> - pure heapProfSampleData - -- Update the HeapProfSampleData - let heapProfSample = - metric i heapProfResidency $ - [ "evCap" ~= i.value.evCap - , "heapProfBreakdown" ~= heapProfBreakdownShow heapProfBreakdown - , "heapProfId" ~= heapProfId - , "heapProfLabel" ~= heapProfLabel - , "heapProfSampleEra" ~= (fst <$> L.uncons heapProfSampleEraStack) - , "infoTableName" ~= fmap (.infoTableName) maybeInfoTable - , "infoTableClosureDesc" ~= fmap (.infoTableClosureDesc) maybeInfoTable - , "infoTableTyDesc" ~= fmap (.infoTableTyDesc) maybeInfoTable - , "infoTableLabel" ~= fmap (.infoTableLabel) maybeInfoTable - , "infoTableModule" ~= fmap (.infoTableModule) maybeInfoTable - , "infoTableSrcLoc" ~= fmap (.infoTableSrcLoc) maybeInfoTable - ] - heapProfSampleData' <- - insertHeapProfSampleString verbosityThreshold heapProfLabel heapProfSample heapProfSampleData - -- Continue with the updated HeapProfSampleState - go - st - { -- If we're not profiling with -hi, discard the info table map - infoTableMap = if isHeapProfBreakdownInfoTable heapProfBreakdown then st.infoTableMap else mempty - , -- Add the update HeapProfSampleData - maybeHeapProfSampleData = Just heapProfSampleData' - } - _otherwise -> go st - -{- | -Parses the `HeapProfBreakdown` command-line arguments: - -> heapProfBreakdownEitherReader "T" == Left HeapProfBreakdownClosureType -> heapProfBreakdownEitherReader "c" == Left HeapProfBreakdownCostCentre -> heapProfBreakdownEitherReader "m" == Left HeapProfBreakdownModule -> heapProfBreakdownEitherReader "d" == Left HeapProfBreakdownClosureDescr -> heapProfBreakdownEitherReader "y" == Left HeapProfBreakdownTypeDescr -> heapProfBreakdownEitherReader "e" == Left HeapProfBreakdownEra -> heapProfBreakdownEitherReader "r" == Left HeapProfBreakdownRetainer -> heapProfBreakdownEitherReader "b" == Left HeapProfBreakdownBiography -> heapProfBreakdownEitherReader "i" == Left HeapProfBreakdownInfoTable --} -heapProfBreakdownEitherReader :: String -> Either String HeapProfBreakdown -heapProfBreakdownEitherReader = - \case - "T" -> Right HeapProfBreakdownClosureType - "c" -> Right HeapProfBreakdownCostCentre - "m" -> Right HeapProfBreakdownModule - "d" -> Right HeapProfBreakdownClosureDescr - "y" -> Right HeapProfBreakdownTypeDescr - "e" -> Right HeapProfBreakdownEra - "r" -> Right HeapProfBreakdownRetainer - "b" -> Right HeapProfBreakdownBiography - "i" -> Right HeapProfBreakdownInfoTable - str -> Left $ "Unsupported heap profile breakdown -h" <> str - -{- | -Shows a `HeapProfBreakdown` as its corresponding command-line flag: - -> heapProfBreakdownShow HeapProfBreakdownClosureType == "-hT" -> heapProfBreakdownShow HeapProfBreakdownCostCentre == "-hc" -> heapProfBreakdownShow HeapProfBreakdownModule == "-hm" -> heapProfBreakdownShow HeapProfBreakdownClosureDescr == "-hd" -> heapProfBreakdownShow HeapProfBreakdownTypeDescr == "-hy" -> heapProfBreakdownShow HeapProfBreakdownEra == "-he" -> heapProfBreakdownShow HeapProfBreakdownRetainer == "-hr" -> heapProfBreakdownShow HeapProfBreakdownBiography == "-hb" -> heapProfBreakdownShow HeapProfBreakdownInfoTable == "-hi" --} -heapProfBreakdownShow :: HeapProfBreakdown -> String -heapProfBreakdownShow = - ("-h" <>) . \case - HeapProfBreakdownClosureType -> "T" - HeapProfBreakdownCostCentre -> "c" - HeapProfBreakdownModule -> "m" - HeapProfBreakdownClosureDescr -> "d" - HeapProfBreakdownTypeDescr -> "y" - HeapProfBreakdownEra -> "e" - HeapProfBreakdownRetainer -> "r" - HeapProfBreakdownBiography -> "b" - HeapProfBreakdownInfoTable -> "i" - -{- | -Internal helper. -Determine the `HeapProfBreakdown` from the list of program arguments. - -__Warning__: This scan is not fully correct. It merely scans for the presence -of arguments that, as a whole, parse with `heapProfBreakdownEitherReader`. -It does not handle @-with-rtsopts@ and does not restrict its search to those -arguments between @+RTS@ and @-RTS@ tags. --} -findHeapProfBreakdown :: [Text] -> Maybe HeapProfBreakdown -findHeapProfBreakdown = listToMaybe . mapMaybe parseHeapProfBreakdown - where - parseHeapProfBreakdown :: Text -> Maybe HeapProfBreakdown - parseHeapProfBreakdown arg - | "-h" `T.isPrefixOf` arg = - either (const Nothing) Just - . heapProfBreakdownEitherReader - . T.unpack - . T.drop 2 - $ arg - | otherwise = Nothing - -------------------------------------------------------------------------------- --- Internal Helpers -------------------------------------------------------------------------------- - -{- | -Internal helper. Construct a t`Metric` from an event with a start time -(t`WithStartTime` t`Event`), together with the measurement and any attributes. -This is a smart constructor that pulls the various timestamps out of the event. --} -metric :: - WithStartTime Event -> - v -> - Attrs -> - Metric v -metric i v attrs = - Metric - { value = v - , maybeTimeUnixNano = tryGetTimeUnixNano i - , maybeStartTimeUnixNano = i.maybeStartTimeUnixNano - , attrs = attrs - } diff --git a/src/GHC/Eventlog/Live/Machine/Analysis/Thread.hs b/src/GHC/Eventlog/Live/Machine/Analysis/Thread.hs deleted file mode 100644 --- a/src/GHC/Eventlog/Live/Machine/Analysis/Thread.hs +++ /dev/null @@ -1,307 +0,0 @@ -{-# LANGUAGE OverloadedStrings #-} -{-# OPTIONS_GHC -Wno-name-shadowing #-} - -{- | -Module : GHC.Eventlog.Live.Machine.Analysis.Thread -Description : Machines for processing eventlog data. -Stability : experimental -Portability : portable --} -module GHC.Eventlog.Live.Machine.Analysis.Thread ( - -- * Thread Analysis - - -- ** Thread Labels - ThreadLabel (..), - processThreadLabels, - - -- ** Thread State Spans - ThreadState (..), - showThreadStateCategory, - threadStateStatus, - threadStateCap, - ThreadStateSpan (..), - processThreadStateSpans, - processThreadStateSpans', -) where - -import Control.Monad.IO.Class (MonadIO (..)) -import Data.Char (isSpace) -import Data.Machine (Is (..), PlanT, Process, ProcessT, await, construct, repeatedly, yield) -import Data.Maybe (isNothing) -import Data.Text (Text) -import Data.Text qualified as T -import Data.Void (Void) -import GHC.Eventlog.Live.Data.Span (duration) -import GHC.Eventlog.Live.Logger (logWarning) -import GHC.Eventlog.Live.Machine.Core (liftRouter) -import GHC.Eventlog.Live.Machine.WithStartTime (WithStartTime (..), tryGetTimeUnixNano) -import GHC.Eventlog.Live.Verbosity (Verbosity) -import GHC.RTS.Events (Event (..), EventInfo, ThreadId, ThreadStopStatus (..), Timestamp) -import GHC.RTS.Events qualified as E -import Text.Printf (printf) - -------------------------------------------------------------------------------- --- Thread Labels - -{- | -The t`ThreadLabel` type represents the association of a label with a thread -starting at a given time. --} -data ThreadLabel - = ThreadLabel - { thread :: !ThreadId - , threadlabel :: !Text - , startTimeUnixNano :: !Timestamp - } - -{- | -This machine processes `E.ThreadLabel` events and yields t`ThreadLabel` values. --} -processThreadLabels :: Process (WithStartTime Event) ThreadLabel -processThreadLabels = repeatedly go - where - go = - await >>= \i -> case i.value.evSpec of - E.ThreadLabel{..} - | Just startTimeUnixNano <- tryGetTimeUnixNano i -> - yield ThreadLabel{..} - _otherwise -> pure () - -------------------------------------------------------------------------------- --- Thread State Spans - -{- | -The execution states of a mutator thread. --} -data ThreadState - = Running {cap :: !Int} - | Blocked {status :: !ThreadStopStatus} - | Finished - deriving (Show) - -{- | -Pretty-print a thread state as "Running", "Blocked", or "Finished". --} -showThreadStateCategory :: ThreadState -> Text -showThreadStateCategory = \case - Running{} -> "Running" - Blocked{} -> "Blocked" - Finished{} -> "Finished" - -{- | -Get the t`ThreadState` status, if the t`ThreadState` is `Blocked`. --} -threadStateStatus :: ThreadState -> Maybe ThreadStopStatus -threadStateStatus = \case - Running{} -> Nothing - Blocked{status} -> Just status - Finished{} -> Nothing - -{- | -Get the t`ThreadState` capability, if the `ThreadState` is `Running`. --} -threadStateCap :: ThreadState -> Maybe Int -threadStateCap = \case - Running{cap} -> Just cap - Blocked{} -> Nothing - Finished{} -> Nothing - -{- | -A span representing the state of a mutator thread. --} -data ThreadStateSpan - = ThreadStateSpan - { thread :: !ThreadId - , threadState :: !ThreadState - , startTimeUnixNano :: !Timestamp - , endTimeUnixNano :: !Timestamp - } - deriving (Show) - -{-# SPECIALIZE duration :: ThreadStateSpan -> Timestamp #-} - -{- | -This machine processes `E.RunThread` and `E.StopThread` events to produce -t`ThreadStateSpan` values that represent segments of time where a thread is -running, blocked, or finished. - -This processor uses the following finite-state automaton: - -@ - ┌─(StopThread)─┐ - │ ↓ - ┌→[ Blocked ]─┐ - │ │ -(StopThread) (RunThread) - │ │ - └─[ Running ]←┘ - ↑ │ - └─(RunThread)──┘ -@ - -The transitions from @Blocked@ to @Blocked@, @Blocked@ to @Running@, and -@Running@ to @Running@ yield a t`ThreadStateSpan`. There are additional -transitions (not pictured) from either state to the final `Finished` state -with a `E.StopThread` event with the `ThreadFinished` status. --} -processThreadStateSpans :: - (MonadIO m) => - Verbosity -> - ProcessT m (WithStartTime Event) ThreadStateSpan -processThreadStateSpans = - processThreadStateSpans' tryGetTimeUnixNano (.value) (const id) - -{- | -Generalised version of `processThreadStateSpans` that can be adapted to work -on arbitrary types using a getter and a lens. --} -processThreadStateSpans' :: - forall m s t. - (MonadIO m) => - (s -> Maybe Timestamp) -> - (s -> Event) -> - (s -> ThreadStateSpan -> t) -> - Verbosity -> - ProcessT m s t -processThreadStateSpans' timeUnixNano getEvent setThreadStateSpan verbosity = - liftRouter measure spawn - where - getEventTime = (.evTime) . getEvent - getEventInfo = (.evSpec) . getEvent - getEventCap = (.evCap) . getEvent - - measure :: s -> Maybe ThreadId - measure i = case getEventInfo i of - E.RunThread{thread} -> Just thread - E.StopThread{thread} -> Just thread - _otherwise -> Nothing - - spawn :: ThreadId -> ProcessT m s t - spawn thread = construct $ go Nothing - where - go :: Maybe s -> PlanT (Is s) t m Void - go mi = - await >>= \case - j - -- If the previous event was a `E.StopThread` event, and... - | Just E.StopThread{status} <- getEventInfo <$> mi - , --- ...it has the `ThreadFinished` status, then... - isThreadFinished status -> - -- ...ignore the current event. - go mi - -- - -- If the current event is a `E.RunThread` event, and... - | E.RunThread{} <- getEventInfo j - , -- ...the previous event was a `E.StopThread` event, then... - Just E.StopThread{status} <- getEventInfo <$> mi - , -- ...gather the end time of the previous event, and... - Just startTimeUnixNano <- timeUnixNano =<< mi - , -- ...gather the start time of the current event, and... - Just endTimeUnixNano <- timeUnixNano j -> do - -- ...yield a thread state span, and... - yield . setThreadStateSpan j $ - ThreadStateSpan{threadState = Blocked status, ..} - go (Just j) - -- - -- If the current event is a `E.RunThread` event, and... - | E.RunThread{} <- getEventInfo j - , -- ...the previous event was a `E.RunThread` event, then... - Just E.RunThread{} <- getEventInfo <$> mi -> do - -- ...keep the oldest event. - go (Just $ maybe j (minBy getEventTime j) mi) - -- - -- If the current event is a `E.RunThread` event, and... - | E.RunThread{} <- getEventInfo j - , -- ...there is no previous event, then... - isNothing mi -> - -- ...keep the current event. - -- - -- The reason for the additional `isNothing` test is because, - -- otherwise, this case might silently swallow any `E.StopThread` - -- events for which `timeUnixNano` gives `Nothing`. - -- By excluding these, they are forwarded to the catch-all case. - go (Just j) - -- - -- If the current event is a `E.StopThread` event, and... - | E.StopThread{} <- getEventInfo j - , -- ...the previous event was a `E.StopThread` event, then... - Just E.StopThread{status} <- getEventInfo <$> mi - , -- ...gather the end time of the previous event, and... - Just startTimeUnixNano <- timeUnixNano =<< mi - , -- ...gather the start time of the current event, and... - Just endTimeUnixNano <- timeUnixNano j -> do - -- ...yield a thread state span, and... - yield . setThreadStateSpan j $ - ThreadStateSpan{threadState = Blocked status, ..} - -- ...keep the current event. - -- - -- This causes us to adopt every `E.StopThread` event, until - -- we hit a `E.StopThread` event with the `ThreadFinished`, at - -- which point the first clause will cause us to stick with it. - go (Just j) - -- - -- If the current event is a `E.StopThread` event, and... - | E.StopThread{} <- getEventInfo j - , -- ...the previous event was a `E.RunThread` event, then... - Just E.RunThread{} <- getEventInfo <$> mi - , -- ...gather the capability of the `E.RunThread` event, and... - Just cap <- getEventCap =<< mi - , -- ...gather the end time of the previous event, and... - Just startTimeUnixNano <- timeUnixNano =<< mi - , -- ...gather the start time of the current event, and... - Just endTimeUnixNano <- timeUnixNano j -> do - -- ...yield a thread state span, and... - yield . setThreadStateSpan j $ - ThreadStateSpan{threadState = Running cap, ..} - -- ...keep the current event. - go (Just j) - -- - -- If the current event is any other event, then... - | otherwise -> do - -- ...emit an error, and... - logWarning verbosity . T.pack $ - printf - "Thread %d: Unexpected event %s" - thread - (showEventInfo (getEventInfo j)) - -- - -- This case may trigger for any event that isn't `E.RunThread` - -- or `E.StopThread` and for any `E.StopThread` event that comes - -- before the first `E.RunThread` event. It may also trigger for - -- any event for which `timeUnixNano` returns `Nothing`. - -- - -- ...ignore it. - go mi - -------------------------------------------------------------------------------- --- Internal Helpers -------------------------------------------------------------------------------- - -{- | -Internal helper. -Check whether a t`ThreadStopStatus` is equal to `ThreadFinished`. -This is needed because t`ThreadStopStatus` does not define an `Eq` instance. --} -isThreadFinished :: ThreadStopStatus -> Bool -isThreadFinished = \case - ThreadFinished -> True - _otherwise -> False - -{- | -Internal helper. -Show `EventInfo` in a condensed format suitable for logging. --} -showEventInfo :: EventInfo -> String -showEventInfo = \case - E.RunThread{thread} -> printf "RunThread{%d}" thread - E.StopThread{thread, status} -> printf "StopThread{%d,%s}" thread (E.showThreadStopStatus status) - E.MigrateThread{thread} -> printf "MigrateThread{%d}" thread - E.StartGC{} -> "StartGC" - E.EndGC{} -> "EndGC" - evSpec -> takeWhile (not . isSpace) . show $ evSpec - -{- | -Internal helper. Return the minimal value by some projection. --} -minBy :: (Ord b) => (a -> b) -> a -> a -> a -minBy f x y = if f x < f y then x else y diff --git a/src/GHC/Eventlog/Live/Machine/Core.hs b/src/GHC/Eventlog/Live/Machine/Core.hs deleted file mode 100644 --- a/src/GHC/Eventlog/Live/Machine/Core.hs +++ /dev/null @@ -1,510 +0,0 @@ -{-# LANGUAGE OverloadedStrings #-} - -{- | -Module : GHC.Eventlog.Live.Machine.Core -Description : Core machines for processing data in batches. -Stability : experimental -Portability : portable --} -module GHC.Eventlog.Live.Machine.Core ( - -- * Ticks - Tick (..), - batchByTick, - batchToTick, - batchListToTick, - batchByTickList, - dropTick, - onlyTick, - aggregateByTick, - liftTick, - liftBatch, - - -- * Debug - counterBy, - counterByTick, - - -- * Routers - liftRouter, - - -- * Event sorting - sortByBatch, - sortByBatchTick, - - -- * Delimiting - between, - delimit, - - -- * Validation - validateInput, - validateOrder, -) where - -import Control.Monad (when) -import Control.Monad.IO.Class (MonadIO (..)) -import Data.DList qualified as D -import Data.Foldable (for_) -import Data.Function (on) -import Data.Functor ((<&>)) -import Data.HashMap.Strict (HashMap) -import Data.HashMap.Strict qualified as M -import Data.Hashable (Hashable (..)) -import Data.List qualified as L -import Data.Machine (Is (..), MachineT (..), Moore (..), PlanT, Process, ProcessT, Step (..), asParts, await, construct, encased, mapping, repeatedly, starve, stopped, yield, (~>)) -import Data.Maybe (fromMaybe) -import Data.Semigroup (Max (..)) -import Data.Text (Text) -import Data.Text qualified as T -import GHC.Eventlog.Live.Logger (logDebug, logError, logWarning) -import GHC.Eventlog.Live.Verbosity (Verbosity, verbosityDebug, verbosityError, verbosityWarning) -import GHC.RTS.Events (Event (..), Timestamp) -import GHC.RTS.Events qualified as E -import Text.Printf (printf) - -------------------------------------------------------------------------------- --- Ticks -------------------------------------------------------------------------------- - -{- | -The type of data on a stream of items and ticks. - -The t`Tick` type is isomorphic to `Maybe` modulo strictness, -but with the caveat that v`Tick` does not represent failure. --} -data Tick a = Item !a | Tick - deriving (Eq, Functor, Foldable, Traversable, Show) - -{- | -This machine batches all items between two ticks into a list. --} -batchByTickList :: Process (Tick a) [a] -batchByTickList = - mapping (fmap D.singleton) - ~> batchByTick - ~> mapping D.toList - -{- | -Generalised version of `batchByTickList`. --} -batchByTick :: - forall a. - (Monoid a) => Process (Tick a) a -batchByTick = batchByTickWith mempty - where - batchByTickWith :: - forall m. - (Monad m) => - a -> MachineT m (Is (Tick a)) a - batchByTickWith acc = MachineT $ pure $ Await onNext Refl onStop - where - onNext :: Tick a -> MachineT m (Is (Tick a)) a - onNext = \case - Item a -> batchByTickWith (a <> acc) - Tick -> MachineT $ pure $ Yield acc batchByTick - onStop :: MachineT m (Is (Tick a)) a - onStop = MachineT $ pure $ Yield acc stopped - -{- | -This machine streams a list of items into a series of items -separated by ticks. --} -batchListToTick :: Process [a] (Tick a) -batchListToTick = batchToTick - -{- | -Generalised version of `batchListToTick`. --} -batchToTick :: (Foldable f) => Process (f a) (Tick a) -batchToTick = repeatedly go - where - go = await >>= \xs -> for_ xs (yield . Item) >> yield Tick - -{- | -This machine drops all ticks. --} -dropTick :: Process (Tick a) a -dropTick = - repeatedly $ - await >>= \case - Item a -> yield a - Tick -> pure () - -{- | -This machine drops all items. --} -onlyTick :: Process (Tick a) () -onlyTick = - repeatedly $ - await >>= \case - Tick -> yield () - Item{} -> pure () - -{- | -This machine aggregates a value by tick. - -The difference between `batchByTick` and `aggregateByTick` is that -`batchByTick` yields a batch on every tick whereas -`aggregateByTick` only yields a batch if there were any values. --} -aggregateByTick :: (Semigroup a) => Process (Tick a) a -aggregateByTick = - mapping (fmap Just) - ~> batchByTick - ~> asParts - -------------------------------------------------------------------------------- --- Machine combinators -------------------------------------------------------------------------------- - -{- | -This machine counts the number of inputs it received, -using the given function, and logs this value. --} -counterBy :: - forall m a x. - (MonadIO m) => - Verbosity -> - Text -> - (a -> Word) -> - ProcessT m a x -counterBy verbosity label counter - | verbosityDebug >= verbosity = repeatedly go - | otherwise = stopped - where - go :: PlanT (Is a) x m () - go = - await >>= \a -> - logDebug verbosity (T.pack (show (counter a)) <> " " <> label) - -{- | -This machine counts the number of inputs it received, -and logs this value on every tick. --} -counterByTick :: - forall m a x. - (MonadIO m) => - Verbosity -> - Text -> - ProcessT m (Tick a) x -counterByTick verbosity label - | verbosityDebug >= verbosity = construct $ go 0 - | otherwise = stopped - where - go :: Word -> PlanT (Is (Tick a)) x m () - go count = - await >>= \case - Item _ -> go (count + 1) - Tick -> logDebug verbosity (T.pack (show count) <> " " <> label) >> go 0 - -------------------------------------------------------------------------------- --- Machine combinators -------------------------------------------------------------------------------- - --------------------------------------------------------------------------------- --- Lift a machine to a machine that passes on ticks unchanged - -{- | -Lift a machine to a machine that passes on ticks unchanged. - -Constructs the following machine: - -@ - ┌─(if Tick)────────────────────┐ - [ Tick a ] [ Tick b ] - └─(if Item)─( ProcessT m a b )─┘ -@ --} -liftTick :: - (Monad m) => - ProcessT m a b -> - ProcessT m (Tick a) (Tick b) -liftTick m = - MachineT $ - runMachineT m <&> \case - Stop -> - Stop - Yield o k -> - Yield (Item o) (liftTick k) - Await (onNext :: t -> ProcessT m a b) Refl onStop -> - await' - where - await' = Await onNext' Refl onStop' - where - onNext' :: Tick a -> ProcessT m (Tick a) (Tick b) - onNext' = \case - Tick -> - MachineT . pure . Yield Tick $ - MachineT . pure $ - await' - Item a -> liftTick (onNext a) - onStop' :: ProcessT m (Tick a) (Tick b) - onStop' = liftTick onStop - --------------------------------------------------------------------------------- --- Lift a machine to a machine that operates on batches - -{- | -Lift a machine that processes @a@s into @b@s to a machine that processes -batches of @a@s into batches of @b@s. --} -liftBatch :: - forall m a b. - (Monad m) => - ProcessT m a b -> - ProcessT m [a] [b] -liftBatch = MachineT . running [] [] - where - -- The parent machine is running the child machine with the current batch. - running :: [a] -> [b] -> ProcessT m a b -> m (Step (Is [a]) [b] (ProcessT m [a] [b])) - running as bs m = - runMachineT m >>= \case - Stop -> - pure Stop - Yield b k -> - running as (b : bs) k - Await (onNext :: t -> ProcessT m a b) Refl onStop -> - pure $ Yield (reverse bs) $ MachineT $ awaiting as onNext onStop - - -- The parent machine is awaiting new input. - awaiting :: [a] -> (a -> ProcessT m a b) -> ProcessT m a b -> m (Step (Is [a]) [b] (ProcessT m [a] [b])) - awaiting (a : as) onNext _onStop = running as [] $ onNext a - awaiting [] onNext onStop = pure $ Await onNext' Refl onStop' - where - onNext' :: [a] -> ProcessT m [a] [b] - onNext' as = MachineT $ awaiting as onNext onStop - onStop' :: ProcessT m [a] [b] - onStop' = exhausting onStop - - -- The parent machine is exhausting the child machine to gather its output. - exhausting :: ProcessT m a b -> ProcessT m x [b] - exhausting = MachineT . go [] - where - go :: [b] -> ProcessT m a b -> m (Step (Is x) [b] (ProcessT m x [b])) - go bs m = - runMachineT m >>= \case - Stop -> - pure Stop - Yield b k -> - go (b : bs) k - Await _onNext _Refl onStop -> - pure $ Yield (reverse bs) $ MachineT $ go [] onStop - --------------------------------------------------------------------------------- --- Construct a processor that spawns a separate child processor for each measure - -{- | -Spawn a copy of a machine for each "measure". - -Constructs the following machine: - -@ - ┌─────(if measure == k0)─( ProcessT m a b )────┐ - [ a ] ──(if measure == ..)─( ProcessT m a b )─ [ b ] - └─────(if measure == kN)─( ProcessT m a b )────┘ -@ - -__Warning:__ The router does not currently garbage-collect terminated child processors. --} -liftRouter :: - forall m k a b. - (MonadIO m, Hashable k) => - -- | Function to measure. - (a -> Maybe k) -> - -- | Function to spawn child processors. - (k -> ProcessT m a b) -> - ProcessT m a b -liftRouter measure spawn = awaiting M.empty - where - awaiting :: HashMap k (ProcessT m a b) -> ProcessT m a b - awaiting st = MachineT . pure $ Await onNext Refl onStop - where - onNext :: a -> MachineT m (Is a) b - onNext a = case measure a of - Nothing -> awaiting st - Just k -> provideThen a m $ \m' -> awaiting (M.insert k m' st) - where - m = fromMaybe (spawn k) (M.lookup k st) - onStop :: MachineT m (Is a) b - onStop = foldr starve stopped (M.elems st) - - provideThen :: a -> ProcessT m a b -> (ProcessT m a b -> ProcessT m a b) -> ProcessT m a b - provideThen a m k = - MachineT $ - runMachineT m >>= \case - Stop -> runMachineT (k stopped) - Yield o m' -> pure (Yield o (provideThen a m' k)) - Await onNext Refl _onStop -> runMachineT (exhaustThen (onNext a) k) - - exhaustThen :: ProcessT m a b -> (ProcessT m a b -> ProcessT m a b) -> ProcessT m a b - exhaustThen m k = - MachineT $ - runMachineT m >>= \case - Yield o m' -> pure (Yield o (k m')) - m' -> runMachineT (k (encased m')) - -------------------------------------------------------------------------------- --- Event stream sorting -------------------------------------------------------------------------------- - -{- | -Reorder events respecting ticks. - -This machine caches two batches worth of events, sorts them together, -and then yields only those events whose timestamp is less than or equal -to the maximum of the first batch. --} -sortByBatch :: - forall m a. - (Monad m) => - (a -> Timestamp) -> - ProcessT m [a] [a] -sortByBatch timestamp = sortByBatchWith Nothing - where - sortByBatchWith :: Maybe [a] -> ProcessT m [a] [a] - sortByBatchWith = \case - Nothing -> MachineT $ pure $ Await onNext Refl onStop - where - onNext :: [a] -> ProcessT m [a] [a] - onNext new = sortByBatchWith (Just sortedNew) - where - sortedNew = sortByTime new - onStop :: ProcessT m [a] [a] - onStop = stopped - Just sortedOld -> MachineT $ pure $ Await onNext Refl onStop - where - onNext :: [a] -> ProcessT m [a] [a] - onNext new - | null sortedOld = sortByBatchWith $ Just sortedNew - | otherwise = MachineT $ pure $ Yield sortedBeforeCutoff $ sortByBatchWith $ Just sortedAfterCutoff - where - -- NOTE: use of partial @maximum@ is guarded by the check @null old@. - cutoff = getMax (foldMap (Max . timestamp) sortedOld) - sortedNew = sortByTime new - sorted = joinByTime sortedOld sortedNew - (sortedBeforeCutoff, sortedAfterCutoff) = L.partition ((<= cutoff) . timestamp) sorted - onStop :: ProcessT m [a] [a] - onStop = MachineT $ pure $ Yield sortedOld $ stopped - - -- compByTime :: a -> a -> Ordering - compByTime = compare `on` timestamp - - -- sortByTime :: [a] -> [a] - sortByTime = L.sortBy compByTime - - -- joinByTime :: [a] -> [a] -> [a] - joinByTime [] ys = ys - joinByTime xs [] = xs - joinByTime (x : xs) (y : ys) = case compByTime x y of - LT -> x : joinByTime xs (y : ys) - _ -> y : joinByTime (x : xs) ys - -{- | -Variant of `sortByBatch` that operates on streams of items and ticks. --} -sortByBatchTick :: (a -> Timestamp) -> Process (Tick a) (Tick a) -sortByBatchTick timestamp = - mapping (fmap (: [])) ~> batchByTick ~> sortByBatch timestamp ~> batchListToTick - -------------------------------------------------------------------------------- --- Filtering semaphores -------------------------------------------------------------------------------- - -{- | A simple delimiting t'Moore' machine, -which is opened by one constant marker and closed by the other one. --} -between :: Text -> Text -> Moore Text Bool -between x y = open - where - open = Moore False open' where open' x' = if x == x' then close else open - close = Moore True close' where close' y' = if y == y' then end else close - end = Moore False (const end) - --- | Delimit the event process. -delimit :: (Monad m) => Moore Text Bool -> ProcessT m Event Event -delimit = construct . go - where - go :: (Monad m) => Moore Text Bool -> PlanT (Is Event) Event m () - go mm@(Moore s next) = do - e <- await - case evSpec e of - -- on marker step the moore machine. - E.UserMarker m -> do - let mm'@(Moore s' _) = next m - -- if current or next state is open (== True), emit the marker. - when (s || s') $ yield e - go mm' - - -- for other events, emit if the state is open. - _ -> do - when s $ yield e - go mm - -------------------------------------------------------------------------------- --- Validation -------------------------------------------------------------------------------- - -{- | -This machine validates that there is some input. - -If no input is encountered after the given number of ticks, the machine prints -a warning that directs the user to check that the @-l@ flag was set correctly. --} -validateInput :: - (MonadIO m) => - Verbosity -> - Int -> - ProcessT m (Tick a) x -validateInput verbosity ticks - | verbosityWarning >= verbosity = construct $ start ticks - | otherwise = stopped - where - start remaining - | remaining <= 0 = liftIO $ do - logWarning verbosity . T.pack $ - printf - "No input after %d ticks. Did you pass -l to the GHC RTS?" - ticks - | otherwise = do - logDebug verbosity $ - T.pack (show remaining) <> " ticks remaining." - await >>= \case - Item{} -> do - logDebug verbosity "Received item." - Tick -> do - logDebug verbosity "Received tick." - start (pred remaining) - -{- | -This machine validates that the inputs are received in order. - -If an out-of-order input is encountered, the machine prints an error message -that directs the user to check that the @--eventlog-flush-interval@ and the -@--batch-interval@ flags are set correctly. --} -validateOrder :: - (MonadIO m, Show a) => - Verbosity -> - (a -> Timestamp) -> - ProcessT m a x -validateOrder verbosity timestamp - | verbosityError >= verbosity = construct $ start Nothing - | otherwise = stopped - where - start maybeOld = - await >>= \new -> - case maybeOld of - Just old - | timestamp new < timestamp old -> do - logError verbosity . T.pack $ - "Encountered two out-of-order inputs.\n\ - \Did you pass --eventlog-flush-interval to the GHC RTS?\n\ - \Did you set --batch-interval to be at least as big as the value of --eventlog-flush-interval?" - logDebug verbosity . T.pack $ - printf - "Out-of-order inputs:\n\ - \- %s\n\ - \- %s" - (show old) - (show new) - pure () - _otherwise -> do - start (Just new) diff --git a/src/GHC/Eventlog/Live/Machine/Decoder.hs b/src/GHC/Eventlog/Live/Machine/Decoder.hs deleted file mode 100644 --- a/src/GHC/Eventlog/Live/Machine/Decoder.hs +++ /dev/null @@ -1,49 +0,0 @@ -{- | -Module : GHC.Eventlog.Live.Machine.Decoder -Description : Machines for processing eventlog data. -Stability : experimental -Portability : portable --} -module GHC.Eventlog.Live.Machine.Decoder ( - -- * Event decoding - DecodeError (..), - decodeEvent, - decodeEventBatch, -) where - -import Control.Exception (Exception, throwIO) -import Control.Monad.IO.Class (MonadIO (..)) -import Data.ByteString qualified as BS -import Data.Machine (Is, PlanT, ProcessT, await, construct, yield) -import GHC.Eventlog.Live.Machine.Core (Tick (..), liftTick) -import GHC.RTS.Events (Event) -import GHC.RTS.Events.Incremental (Decoder (..), decodeEventLog) - -------------------------------------------------------------------------------- --- Decoding events - -{- | -Parse t'Event's from a stream of 'BS.ByteString' chunks with ticks. - -Throws a t'DecodeError' on error. --} -decodeEvent :: (MonadIO m) => ProcessT m BS.ByteString Event -decodeEvent = construct $ loop decodeEventLog - where - loop :: (MonadIO m) => Decoder a -> PlanT (Is BS.ByteString) a m () - loop Done{} = pure () - loop (Consume k) = await >>= \chunk -> loop (k chunk) - loop (Produce a d') = yield a >> loop d' - loop (Error _ err) = liftIO $ throwIO $ DecodeError err - -{- | -Parse 'Event's from a stream of 'BS.ByteString' chunks with ticks. - -Throws 'DecodeError' on error. --} -decodeEventBatch :: (MonadIO m) => ProcessT m (Tick BS.ByteString) (Tick Event) -decodeEventBatch = liftTick decodeEvent - -newtype DecodeError = DecodeError String deriving (Show) - -instance Exception DecodeError diff --git a/src/GHC/Eventlog/Live/Machine/Sink.hs b/src/GHC/Eventlog/Live/Machine/Sink.hs deleted file mode 100644 --- a/src/GHC/Eventlog/Live/Machine/Sink.hs +++ /dev/null @@ -1,42 +0,0 @@ -{- | -Module : GHC.Eventlog.Live.Machine.Sink -Description : Machines for processing eventlog data. -Stability : experimental -Portability : portable --} -module GHC.Eventlog.Live.Machine.Sink ( - -- * Eventlog file sink - fileSink, - fileSinkBatch, -) where - -import Control.Monad.IO.Class (MonadIO (..)) -import Data.ByteString qualified as BS -import Data.Machine (ProcessT, await, repeatedly, (~>)) -import Data.Void (Void) -import GHC.Eventlog.Live.Machine.Core (Tick (..), dropTick) -import System.IO (Handle) - -------------------------------------------------------------------------------- --- Log file sink - -{- | -File sink for optional eventlog log file. --} -fileSink :: - (MonadIO m) => - Handle -> - ProcessT m BS.ByteString Void -fileSink handle = repeatedly $ await >>= liftIO . BS.hPut handle - -------------------------------------------------------------------------------- --- Log file sink with batches - -{- | -File sink for optional eventlog log file. --} -fileSinkBatch :: - (MonadIO m) => - Handle -> - ProcessT m (Tick BS.ByteString) Void -fileSinkBatch handle = dropTick ~> fileSink handle diff --git a/src/GHC/Eventlog/Live/Machine/Source.hs b/src/GHC/Eventlog/Live/Machine/Source.hs deleted file mode 100644 --- a/src/GHC/Eventlog/Live/Machine/Source.hs +++ /dev/null @@ -1,144 +0,0 @@ -{- | -Module : GHC.Eventlog.Live.Machine.Source -Description : Machines for processing eventlog data. -Stability : experimental -Portability : portable --} -module GHC.Eventlog.Live.Machine.Source ( - -- * Eventlog source - sourceHandleWait, - sourceHandleBatch, - defaultChunkSizeBytes, -) where - -import Control.Exception (catch, throwIO) -import Control.Monad.IO.Class (MonadIO (..)) -import Data.ByteString qualified as BS -import Data.Function (fix) -import Data.Machine (MachineT (..), construct, yield) -import Data.Word (Word64) -import GHC.Clock (getMonotonicTimeNSec) -import GHC.Eventlog.Live.Machine.Core (Tick (..)) -import System.IO (Handle, hWaitForInput) -import System.IO.Error (isEOFError) - -------------------------------------------------------------------------------- --- Socket source - -{- | -A source which reads chunks from a `Handle`. -When an input is available, it yields an v`Item`. -When the timeout is reached, it yields a v`Tick`. --} -sourceHandleWait :: - (MonadIO m) => - -- | The wait timeout in milliseconds. - Int -> - -- | The number of bytes to read. - Int -> - -- | The eventlog socket handle. - Handle -> - MachineT m k (Tick BS.ByteString) -sourceHandleWait timeoutMilli chunkSizeBytes handle = - construct $ fix $ \loop -> do - ready <- liftIO $ hWaitForInput' handle timeoutMilli - case ready of - Ready -> do - bs <- liftIO $ BS.hGetSome handle chunkSizeBytes - yield (Item bs) - loop - NotReady -> do - yield Tick - loop - EOF -> - pure () - -------------------------------------------------------------------------------- --- Socket source with batches - -{- | -A source which reads chunks from a `Handle`. -When input is available, it yields an v`Item`. -It yields a v`Tick` at each increment of the batch interval. --} -sourceHandleBatch :: - (MonadIO m) => - -- | The batch interval in milliseconds. - Int -> - -- | The number of bytes to read. - Int -> - -- | The eventlog socket handle. - Handle -> - MachineT m k (Tick BS.ByteString) -sourceHandleBatch batchIntervalMs chunkSizeBytes handle = construct start - where - start = do - startTimeMs <- liftIO getMonotonicTimeMilli - batch startTimeMs - batch startTimeMs = waitForInput - where - getRemainingTimeMilli = do - currentTimeMilli <- liftIO getMonotonicTimeMilli - pure $ (startTimeMs + batchIntervalMs) - currentTimeMilli - waitForInput = do - remainingTimeMilli <- getRemainingTimeMilli - if remainingTimeMilli <= 0 - then do - yield Tick - start - else do - ready <- liftIO (hWaitForInput' handle remainingTimeMilli) - case ready of - Ready -> do - chunk <- liftIO $ BS.hGetSome handle chunkSizeBytes - yield (Item chunk) >> waitForInput - NotReady -> waitForInput - EOF -> pure () - -{- | -Eventlog chunk size in bytes. -This should be equal to the page size. --} -defaultChunkSizeBytes :: Int -defaultChunkSizeBytes = 4096 - -{- | -Internal helper. -Return monotonic time in milliseconds, since some unspecified starting point --} -getMonotonicTimeMilli :: IO Int -getMonotonicTimeMilli = nanoToMilli <$> getMonotonicTimeNSec - -{- | -Internal helper. -Convert nanoseconds to milliseconds. -The conversion from 'Word64' to 'Int' is safe. -It cannot overflow due to the division by 1_000_000. --} -nanoToMilli :: Word64 -> Int -nanoToMilli = fromIntegral . (`div` 1_000_000) - -{- | -Internal helper. -Type to represent the state of a handle. --} -data Ready = Ready | NotReady | EOF - -{- | -Internal helper. -Wait for input from a `Handle` for a given number of milliseconds. --} -hWaitForInput' :: - -- | The handle. - Handle -> - -- | The timeout in milliseconds. - Int -> - IO Ready -hWaitForInput' handle timeoutMilli = - catch (boolToReady <$> hWaitForInput handle timeoutMilli) handleEOFError - where - boolToReady True = Ready - boolToReady False = NotReady - handleEOFError err - | isEOFError err = pure EOF - | otherwise = throwIO err diff --git a/src/GHC/Eventlog/Live/Machine/WithStartTime.hs b/src/GHC/Eventlog/Live/Machine/WithStartTime.hs deleted file mode 100644 --- a/src/GHC/Eventlog/Live/Machine/WithStartTime.hs +++ /dev/null @@ -1,88 +0,0 @@ -{- | -Module : GHC.Eventlog.Live.Machine.WithStartTime -Description : Machines for processing eventlog data. -Stability : experimental -Portability : portable --} -module GHC.Eventlog.Live.Machine.WithStartTime ( - WithStartTime (..), - setWithStartTime'value, - tryGetTimeUnixNano, - withStartTime, - withStartTime', - dropStartTime, -) where - -import Control.Monad (forever) -import Data.Machine (Is (..), PlanT, Process, await, construct, mapping, yield) -import GHC.RTS.Events (Event (..), EventInfo, Timestamp) -import GHC.RTS.Events qualified as E - -------------------------------------------------------------------------------- --- Start time - -{- | -Data decorated with a start time in nanoseconds since the Unix epoch. --} -data WithStartTime a = WithStartTime - { value :: !a - , maybeStartTimeUnixNano :: !(Maybe Timestamp) - } - deriving (Functor, Show) - -{- | -Setter for the value of a t`WithStartTime` --} -setWithStartTime'value :: WithStartTime a -> b -> WithStartTime b -setWithStartTime'value (WithStartTime _a t) b = WithStartTime b t - -{- | -If the event has a start time, return `Just` the time of the event in -nanoseconds since the Unix epoch. Otherwise, return `Nothing`. --} -tryGetTimeUnixNano :: WithStartTime Event -> Maybe Timestamp -tryGetTimeUnixNano i = (i.value.evTime +) <$> i.maybeStartTimeUnixNano - -{- | -Wrap every event in t`WithStartTime`. Every event after `E.WallClockTime` will -have its start time field set to `Just` the process start time. - -This machine swallows the first and only `E.WallClockTime` event. --} -withStartTime :: Process Event (WithStartTime Event) -withStartTime = withStartTime' E.evSpec WithStartTime - -{- | -Generalised version of `withStartTime` that can be adapted to work on arbitrary -types using a getter and a setter. --} -withStartTime' :: (a -> EventInfo) -> (a -> Maybe Timestamp -> b) -> Process a b -withStartTime' getEventInfo setStartTime = construct start - where - start = - await >>= \case - value - -- The `WallClockTime` event announces the wall-clock time at which the - -- process was started. - | E.WallClockTime{..} <- getEventInfo value -> do - -- This will start overflowing on Sunday, 21 July 2554 23:34:33, UTC. - let !startTimeNs = sec * 1_000_000_000 + fromIntegral nsec - -- We do not re-emit the `WallClockTime` event. - continue startTimeNs - | otherwise -> - yield (value `setStartTime` Nothing) >> start - continue startTimeUnixNano = - mappingPlan $ \value -> - value `setStartTime` Just startTimeUnixNano - -{- | -Drop the t`WithStartTime` wrapper. --} -dropStartTime :: Process (WithStartTime a) a -dropStartTime = mapping (.value) - -{- | -Internal helper. Variant of `mapping` for plans. --} -mappingPlan :: (a -> b) -> PlanT (Is a) b m a -mappingPlan f = forever (await >>= \a -> yield (f a)) diff --git a/src/GHC/Eventlog/Live/Options.hs b/src/GHC/Eventlog/Live/Options.hs deleted file mode 100644 --- a/src/GHC/Eventlog/Live/Options.hs +++ /dev/null @@ -1,201 +0,0 @@ -{- | -Module : GHC.Eventlog.Live.Options -Description : Command-line option parsers for eventlog machines. -Stability : experimental -Portability : portable --} -module GHC.Eventlog.Live.Options ( - EventlogSource (..), - eventlogSourceParser, - eventlogSocketTimeoutParser, - eventlogSocketTimeoutExponentParser, - heapProfBreakdownParser, - eventlogLogFileParser, - batchIntervalParser, - verbosityParser, - statsParser, -) where - -import Control.Applicative (asum) -import Data.Char (toLower) -import GHC.Eventlog.Live.Machine.Analysis.Heap (heapProfBreakdownEitherReader) -import GHC.Eventlog.Live.Verbosity (Verbosity, verbosityDebug, verbosityError, verbosityInfo, verbosityQuiet, verbosityWarning) -import GHC.RTS.Events (HeapProfBreakdown (..)) -import Options.Applicative qualified as O -import Text.Read (readEither) - --------------------------------------------------------------------------------- --- Eventlog Source - -{- | -The type of eventlog sockets. --} -data EventlogSource - = EventlogStdin - | EventlogFile FilePath - | EventlogSocketUnix FilePath - -{- | -Parser for the eventlog socket. --} -eventlogSourceParser :: O.Parser EventlogSource -eventlogSourceParser = - asum - [ stdinParser - , fileParser - , socketUnixParser - ] - where - stdinParser = - EventlogStdin - <$ O.flag' - () - ( O.long "eventlog-stdin" - <> O.help "Read the eventlog from stdin." - ) - fileParser = - EventlogFile - <$> O.strOption - ( O.long "eventlog-file" - <> O.metavar "FILE" - <> O.help "Read the eventlog from a file." - ) - socketUnixParser = - EventlogSocketUnix - <$> O.strOption - ( O.long "eventlog-socket" - <> O.metavar "SOCKET" - <> O.help "Read the eventlog from a Unix socket." - ) - -{- | -Parser for the intial timeout for exponential backoff. --} -eventlogSocketTimeoutParser :: O.Parser Double -eventlogSocketTimeoutParser = - O.option - O.auto - ( O.long "eventlog-socket-timeout" - <> O.metavar "NUM" - <> O.help "Eventlog socket connection retry timeout in microseconds." - <> O.value 1 - ) - -{- | -Parser for the exponent for exponential backoff. --} -eventlogSocketTimeoutExponentParser :: O.Parser Double -eventlogSocketTimeoutExponentParser = - O.option - O.auto - ( O.long "eventlog-socket-exponent" - <> O.metavar "NUM" - <> O.help "Eventlog socket connection retry timeout exponent." - <> O.value 1 - ) - --------------------------------------------------------------------------------- --- Heap Profile Breakdown - -{- | -Parser for the heap profile breakdown. --} -heapProfBreakdownParser :: O.Parser HeapProfBreakdown -heapProfBreakdownParser = - O.option - (O.eitherReader heapProfBreakdownEitherReader) - ( O.short 'h' - <> O.metavar "Tcmdyrbi" - <> O.help "Heap profile breakdown." - ) - --------------------------------------------------------------------------------- --- Eventlog Log File - -{- | -Parser for the eventlog log file. --} -eventlogLogFileParser :: O.Parser FilePath -eventlogLogFileParser = - O.strOption - ( O.long "eventlog-log-file" - <> O.metavar "FILE" - <> O.help "Use file to log binary eventlog data." - ) - --------------------------------------------------------------------------------- --- Batch Interval - -{- | -Parser for the batch interval. --} -batchIntervalParser :: O.Parser Int -batchIntervalParser = - O.option - O.auto - ( O.long "batch-interval" - <> O.metavar "NUM" - <> O.help "Batch interval in milliseconds." - <> O.value defaultBatchIntervalMs - ) - -{- | -Internal helper. -The default batch interval in milliseconds. --} -defaultBatchIntervalMs :: Int -defaultBatchIntervalMs = 1_000 - --------------------------------------------------------------------------------- --- Verbosity - -{- | -Parser for verbosities. -The default verbosity is `verbosityWarning`. --} -verbosityParser :: O.Parser Verbosity -verbosityParser = - O.option - (O.eitherReader readEitherVerbosity) - ( O.short 'v' - <> O.long "verbosity" - <> O.metavar "quiet|error|warning|info|debug|0-4" - <> O.help "The verbosity threshold for logging." - <> O.value verbosityWarning - ) - -{- | -Internal helper. -Parser for verbosities by number or name. -Case insensitive. --} -readEitherVerbosity :: String -> Either String Verbosity -readEitherVerbosity rawVerbosity = - -- try to parse the verbosity as a number... - case readEither @Word rawVerbosity of - -- if the verbosity string is a number, map it to a verbosity... - Right verbosityThreshold - | verbosityThreshold <= 0 -> Right verbosityQuiet - | verbosityThreshold == 1 -> Right verbosityError - | verbosityThreshold == 2 -> Right verbosityWarning - | verbosityThreshold == 3 -> Right verbosityInfo - | otherwise -> Right verbosityDebug - -- otherwise, match it against the literal names of the levels... - Left _parseError -> case toLower <$> rawVerbosity of - "quiet" -> Right verbosityQuiet - "error" -> Right verbosityError - "warning" -> Right verbosityWarning - "info" -> Right verbosityInfo - "debug" -> Right verbosityDebug - _otherwise -> Left $ "Could not parse verbosity '" <> rawVerbosity <> "'." - --------------------------------------------------------------------------------- --- Statistics - -statsParser :: O.Parser Bool -statsParser = - O.flag False True $ - ( O.short 's' - <> O.long "stats" - <> O.help "Display runtime statistics." - ) diff --git a/src/GHC/Eventlog/Live/Socket.hs b/src/GHC/Eventlog/Live/Socket.hs deleted file mode 100644 --- a/src/GHC/Eventlog/Live/Socket.hs +++ /dev/null @@ -1,177 +0,0 @@ -{-# LANGUAGE OverloadedStrings #-} - -{- | -Module : GHC.Eventlog.Live.Socket -Description : Utilities for running eventlog machines with sockets. -Stability : experimental -Portability : portable --} -module GHC.Eventlog.Live.Socket ( - EventlogSource (..), - Tick (..), - tryConnect, - runWithEventlogSource, -) where - -import Control.Concurrent (threadDelay) -import Control.Exception (Exception (..)) -import Control.Exception qualified as E -import Control.Monad.IO.Unlift (MonadUnliftIO (..)) -import Data.Foldable (traverse_) -import Data.Machine (ProcessT, runT_, (~>)) -import Data.Machine.Fanout (fanout) -import Data.Maybe (fromMaybe) -import Data.Text (Text) -import Data.Text qualified as T -import Data.Void (Void) -import GHC.Eventlog.Live.Logger (logDebug, logInfo) -import GHC.Eventlog.Live.Machine.Core -import GHC.Eventlog.Live.Machine.Decoder -import GHC.Eventlog.Live.Machine.Sink -import GHC.Eventlog.Live.Machine.Source -import GHC.Eventlog.Live.Options (EventlogSource (..)) -import GHC.Eventlog.Live.Verbosity (Verbosity) -import GHC.RTS.Events (Event) -import Network.Socket qualified as S -import System.IO (Handle) -import System.IO qualified as IO -import Text.Printf (printf) - -{- | -Run an event processor with an eventlog socket. --} -runWithEventlogSource :: - (MonadUnliftIO m) => - -- | The logging verbosity. - Verbosity -> - -- | The eventlog socket handle. - EventlogSource -> - -- | The initial timeout in microseconds for exponential backoff. - Double -> - -- | The timeout exponent for exponential backoff. - Double -> - -- | The batch interval in milliseconds. - Int -> - -- | The number of bytes to read (defaults to 4KiB). - Maybe Int -> - -- | An optional file to which to stream binary eventlog data. - Maybe FilePath -> - -- | The event processor. - ProcessT m (Tick Event) Void -> - m () -runWithEventlogSource verbosity eventlogSocket timeoutExponent initialTimeoutMcs batchIntervalMs maybeChuckSizeBytes maybeOutputFile toEventSink = do - withEventlogSource verbosity timeoutExponent initialTimeoutMcs eventlogSocket $ \eventlogSource -> do - let chuckSizeBytes = fromMaybe defaultChunkSizeBytes maybeChuckSizeBytes - let fromSocket = sourceHandleBatch batchIntervalMs chuckSizeBytes eventlogSource - case maybeOutputFile of - Nothing -> - runT_ $ - fromSocket ~> decodeEventBatch ~> toEventSink - Just outputFile -> - withRunInIO $ \runInIO -> - IO.withFile outputFile IO.WriteMode $ \outputHandle -> do - runInIO . runT_ $ - fromSocket - ~> fanout - [ fileSinkBatch outputHandle - , decodeEventBatch ~> toEventSink - ] - -{- | -Run an action with a `Handle` to an `EventlogSource`. --} -withEventlogSource :: - (MonadUnliftIO m) => - -- | The logging verbosity. - Verbosity -> - -- | The initial timeout in microseconds for exponential backoff. - Double -> - -- | The timeout exponent for exponential backoff. - Double -> - -- | The eventlog socket. - EventlogSource -> - (Handle -> m ()) -> - m () -withEventlogSource verbosity initialTimeoutMcs timeoutExponent eventlogSource action = do - withRunInIO $ \runInIO -> - case eventlogSource of - EventlogStdin -> do - logInfo verbosity "Reading eventlog from stdin" - let enter = do - maybeStdinTextEncoding <- IO.hGetEncoding IO.stdin - IO.hSetBinaryMode IO.stdin True - pure maybeStdinTextEncoding - let leave maybeStdinTextEncoding = do - traverse_ (IO.hSetEncoding IO.stdin) maybeStdinTextEncoding - IO.hSetNewlineMode IO.stdin IO.nativeNewlineMode - E.bracket enter leave . const . runInIO . action $ IO.stdin - EventlogFile eventlogFile -> do - logInfo verbosity $ "Reading eventlog from " <> T.pack eventlogFile - IO.withBinaryFile eventlogFile IO.ReadMode $ \handle -> - runInIO $ action handle - EventlogSocketUnix eventlogSocketUnix -> do - logInfo verbosity $ "Waiting to connect on " <> prettyEventlogSocketUnix eventlogSocketUnix - E.bracket (connectRetry verbosity initialTimeoutMcs timeoutExponent eventlogSocketUnix) IO.hClose $ \handle -> - runInIO $ action handle - -{- | -Connect to an `EventlogSource` with retries and non-randomised exponential backoff. --} -connectRetry :: - -- | The logging verbosity. - Verbosity -> - -- | The initial timeout in microseconds for exponential backoff. - Double -> - -- | The timeout exponent for exponential backoff. - Double -> - -- | The eventlog socket. - FilePath -> - IO Handle -connectRetry verbosity initialTimeoutMcs timeoutExponent eventlogSocketUnix = - connectLoop initialTimeoutMcs - where - waitFor :: Double -> IO () - waitFor timeoutMcs = threadDelay $ round $ timeoutMcs * 1_000_000 - - connectLoop :: Double -> IO Handle - connectLoop timeoutMcs = do - let connect = do - logDebug verbosity $ "Trying to connect on " <> prettyEventlogSocketUnix eventlogSocketUnix - handle <- tryConnect eventlogSocketUnix - logInfo verbosity $ "Connected on " <> prettyEventlogSocketUnix eventlogSocketUnix - pure handle - let cleanup (e :: E.IOException) = do - logDebug verbosity $ "Failed to connect on " <> prettyEventlogSocketUnix eventlogSocketUnix <> ": " <> T.pack (displayException e) - logDebug verbosity $ "Waiting " <> prettyTimeoutMcs timeoutMcs <> " to retry..." - waitFor timeoutMcs - connectLoop (timeoutMcs * timeoutExponent) - E.catch connect cleanup - -{- | -Try to connect to a Unix socket. --} -tryConnect :: FilePath -> IO Handle -tryConnect eventlogSocketUnix = - E.bracketOnError (S.socket S.AF_UNIX S.Stream S.defaultProtocol) S.close $ \socket -> do - S.connect socket (S.SockAddrUnix eventlogSocketUnix) - handle <- S.socketToHandle socket IO.ReadMode - IO.hSetBuffering handle IO.NoBuffering - pure handle - -{- | -Interal helper. Pretty-printer for timeout values in microseconds. --} -prettyTimeoutMcs :: Double -> Text -prettyTimeoutMcs timeoutMcs - | timeoutMcs > 8.64e10 = T.pack $ printf "%.2f days" (timeoutMcs / 8.64e10) - | timeoutMcs > 3.6e9 = T.pack $ printf "%.2f hours" (timeoutMcs / 3.6e9) - | timeoutMcs > 6e7 = T.pack $ printf "%.2f minutes" (timeoutMcs / 6e7) - | timeoutMcs > 1e6 = T.pack $ printf "%.2f seconds" (timeoutMcs / 1e6) - | timeoutMcs > 1e3 = T.pack $ printf "%.2f milliseconds" (timeoutMcs / 1e3) - | otherwise = T.pack $ printf "%.2f microseconds" timeoutMcs - -{- | -Internal helper. Pretty-printer for eventlog sockets. --} -prettyEventlogSocketUnix :: FilePath -> Text -prettyEventlogSocketUnix eventlogSocketUnix = "Unix socket " <> T.pack eventlogSocketUnix diff --git a/src/GHC/Eventlog/Live/Verbosity.hs b/src/GHC/Eventlog/Live/Verbosity.hs deleted file mode 100644 --- a/src/GHC/Eventlog/Live/Verbosity.hs +++ /dev/null @@ -1,76 +0,0 @@ -{-# LANGUAGE OverloadedStrings #-} - -{- | -Module : GHC.Eventlog.Live.Verbosity -Description : Logging verbosity for eventlog machines. -Stability : experimental -Portability : portable --} -module GHC.Eventlog.Live.Verbosity ( - Verbosity, - showVerbosity, - verbosityQuiet, - verbosityError, - verbosityWarning, - verbosityInfo, - verbosityDebug, -) where - -import Data.Text (Text) - -------------------------------------------------------------------------------- --- Verbosity -------------------------------------------------------------------------------- - -{- | -The type of logging verbosities supported by the machines -in "GHC.Eventlog.Live.Machines". --} -data Verbosity - = VerbosityDebug - | VerbosityInfo - | VerbosityWarning - | VerbosityError - | VerbosityQuiet - deriving (Eq, Ord) - -{- | -Pretty-printer for t`Verbosity`. --} -showVerbosity :: Verbosity -> Text -showVerbosity = \case - VerbosityDebug -> "Debug" - VerbosityInfo -> "Info" - VerbosityWarning -> "Warning" - VerbosityError -> "Error" - VerbosityQuiet -> "Quiet" - -{- | -Quiet t`Verbosity`. --} -verbosityQuiet :: Verbosity -verbosityQuiet = VerbosityQuiet - -{- | -Error t`Verbosity`. --} -verbosityError :: Verbosity -verbosityError = VerbosityError - -{- | -Warning t`Verbosity`. --} -verbosityWarning :: Verbosity -verbosityWarning = VerbosityWarning - -{- | -Info t`Verbosity`. --} -verbosityInfo :: Verbosity -verbosityInfo = VerbosityInfo - -{- | -Debug t`Verbosity`. --} -verbosityDebug :: Verbosity -verbosityDebug = VerbosityDebug diff --git a/vendor/base-compat-0.15.0/Data/Traversable/Compat.hs b/vendor/base-compat-0.15.0/Data/Traversable/Compat.hs new file mode 100644 --- /dev/null +++ b/vendor/base-compat-0.15.0/Data/Traversable/Compat.hs @@ -0,0 +1,94 @@ +{-# LANGUAGE CPP #-} + +{- | +Module : Data.Traversable.Compat +Description : Compatibility module for `mapAccumM`. +Copyright : (c) 2012-2018 Simon Hengel, + (c) 2014-2018 João Cristóvão, + (c) 2015-2018 Ryan Scott +License : MIT +Stability : experimental +Portability : portable +-} +module Data.Traversable.Compat ( + mapAccumM, +) where + +#if MIN_VERSION_base(4,18,0) +import Data.Traversable (mapAccumM) + +#else +-- !MIN_VERSION_base(4,18,0) + +import Control.Monad (liftM) +import Data.Coerce (Coercible, coerce) + +-- | A state transformer monad parameterized by the state and inner monad. +-- The implementation is copied from the transformers package with the +-- return tuple swapped. +-- +-- /Since: 4.18.0.0/ +newtype StateT s m a = StateT { runStateT :: s -> m (s, a) } + +-- | /Since: 4.18.0.0/ +instance Monad m => Functor (StateT s m) where + fmap = liftM + {-# INLINE fmap #-} + +-- | /Since: 4.18.0.0/ +instance Monad m => Applicative (StateT s m) where + pure a = StateT $ \ s -> return (s, a) + {-# INLINE pure #-} + StateT mf <*> StateT mx = StateT $ \ s -> do + (s', f) <- mf s + (s'', x) <- mx s' + return (s'', f x) + {-# INLINE (<*>) #-} + m *> k = m >> k + {-# INLINE (*>) #-} + +(#.) :: Coercible b c => (b -> c) -> (a -> b) -> (a -> c) +(#.) _f = coerce + +-- | /Since: 4.18.0.0/ +instance (Monad m) => Monad (StateT s m) where + m >>= k = StateT $ \ s -> do + (s', a) <- (.runStateT) m s + (.runStateT) (k a) s' + {-# INLINE (>>=) #-} +# if !(MIN_VERSION_base(4,11,0)) + return = pure +# endif + +-- | The `mapAccumM` function behaves like a combination of `mapM` and +-- `mapAccumL` that traverses the structure while evaluating the actions +-- and passing an accumulating parameter from left to right. +-- It returns a final value of this accumulator together with the new structure. +-- The accummulator is often used for caching the intermediate results of a computation. +-- +-- @since 4.18.0.0 +-- +-- ==== __Examples__ +-- +-- Basic usage: +-- +-- >>> let expensiveDouble a = putStrLn ("Doubling " <> show a) >> pure (2 * a) +-- >>> :{ +-- mapAccumM (\cache a -> case lookup a cache of +-- Nothing -> expensiveDouble a >>= \double -> pure ((a, double):cache, double) +-- Just double -> pure (cache, double) +-- ) [] [1, 2, 3, 1, 2, 3] +-- :} +-- Doubling 1 +-- Doubling 2 +-- Doubling 3 +-- ([(3,6),(2,4),(1,2)],[2,4,6,2,4,6]) +-- +mapAccumM + :: forall m t s a b. (Monad m, Traversable t) + => (s -> a -> m (s, b)) + -> s -> t a -> m (s, t b) +mapAccumM f s t = (.runStateT) (mapM (StateT #. flip f) t) s + +-- !MIN_VERSION_base(4,18,0) +#endif diff --git a/vendor/concurrent-machines-0.3.1.5/src/Data/Machine/Concurrent.hs b/vendor/concurrent-machines-0.3.1.5/src/Data/Machine/Concurrent.hs new file mode 100644 --- /dev/null +++ b/vendor/concurrent-machines-0.3.1.5/src/Data/Machine/Concurrent.hs @@ -0,0 +1,125 @@ +{- HLINT ignore -} +{- FOURMOLU_DISABLE -} +{-# LANGUAGE CPP, GADTs, FlexibleContexts, RankNTypes, ScopedTypeVariables, + TupleSections #-} +-- | The primary use of concurrent machines is to establish a +-- pipelined architecture that can boost overall throughput by running +-- each stage of the pipeline at the same time. The processing, or +-- production, rate of each stage may not be identical, so facilities +-- are provided to loosen the temporal coupling between pipeline +-- stages using buffers. +-- +-- This architecture also lends itself to operations where multiple +-- workers are available for procesisng inputs. If each worker is to +-- process the same set of inputs, consider 'fanout' and +-- 'fanoutSteps'. If each worker is to process a disjoint set of +-- inputs, consider 'scatter'. +module Data.Machine.Concurrent (module Data.Machine, + -- * Concurrent connection + (>~>), (<~<), + -- * Buffered machines + bufferConnect, rollingConnect, + -- * Concurrent processing of shared inputs + fanout, fanoutSteps, + -- * Concurrent multiple-input machines + wye, tee, scatter, splitSum, mergeSum, + splitProd) where +#if defined(__GLASGOW_HASKELL__) && __GLASGOW_HASKELL__ < 710 +import Control.Applicative +#endif +import Control.Concurrent.Async.Lifted +import Control.Monad (join) +import Control.Monad.Trans.Control +import Data.Machine hiding (tee, wye) +import Data.Machine.Concurrent.AsyncStep +import Data.Machine.Concurrent.Buffer +import Data.Machine.Concurrent.Fanout +import Data.Machine.Concurrent.Scatter +import Data.Machine.Concurrent.Wye +import Data.Machine.Concurrent.Tee + +-- | Build a new 'Machine' by adding a 'Process' to the output of an +-- old 'Machine'. The upstream machine is run concurrently with +-- downstream with the aim that upstream will have a yielded value +-- ready as soon as downstream awaits. This effectively creates a +-- buffer between upstream and downstream, or source and sink, that +-- can contain up to one value. +-- +-- @ +-- ('<~<') :: 'Process' b c -> 'Process' a b -> 'Process' a c +-- ('<~<') :: 'Process' c d -> 'Data.Machine.Tee.Tee' a b c -> 'Data.Machine.Tee.Tee' a b d +-- ('<~<') :: 'Process' b c -> 'Machine' k b -> 'Machine' k c +-- @ +(<~<) :: MonadBaseControl IO m + => ProcessT m b c -> MachineT m k b -> MachineT m k c +mp <~< ma = racers ma mp + +-- | Flipped ('<~<'). +(>~>) :: MonadBaseControl IO m + => MachineT m k b -> ProcessT m b c -> MachineT m k c +ma >~> mp = mp <~< ma + +infixl 7 >~> + +-- | We want the first available response. +waitEither' :: MonadBaseControl IO m + => Maybe (Async (StM m a)) -> Async (StM m b) + -> m (Either a b) +waitEither' Nothing y = Right <$> wait y +waitEither' (Just x) y = waitEither x y + +-- | Let a source and a sink chase each other, providing an effective +-- one-element buffer between the two. The idea is to run both +-- concurrently at all times so that as soon as the sink 'Await's, we +-- have a source-yielded value to provide it. This, of course, +-- involves eagerly running the source, percolating its 'Await's up +-- the chain as soon as possible. +racers :: forall m k a b. MonadBaseControl IO m + => MachineT m k a -> ProcessT m a b -> MachineT m k b +racers src snk = MachineT . join $ + go <$> (Just <$> asyncRun src) <*> asyncRun snk + where go :: Maybe (AsyncStep m k a) + -> AsyncStep m (Is a) b + -> m (MachineStep m k b) + go srcA snkA = + waitEither' srcA snkA >>= \n -> case n of + Left (Stop :: MachineStep m k a) -> go Nothing snkA + Left (Yield o k) -> wait snkA >>= \m -> case m of + (Stop :: MachineStep m (Is a) b) -> return Stop + Yield o' k' -> return . Yield o' . MachineT . flushDown k' $ + \f -> join $ go <$> (Just <$> asyncRun k) + <*> asyncRun (f o) + Await f Refl _ -> join $ go <$> (Just <$> asyncRun k) + <*> asyncRun (f o) + Left (Await g kg fg) -> asyncAwait g kg fg $ + MachineT . flip go snkA . Just + Right (Stop :: MachineStep m (Is a) b) -> return Stop + Right (Yield o k) -> asyncRun k >>= + return . Yield o . MachineT . go srcA + Right (Await f Refl ff) -> case srcA of + Nothing -> asyncRun ff >>= go Nothing + Just src' -> wait src' >>= \m -> case m of + Stop -> return Stop + Yield o k -> join $ go <$> (Just <$> asyncRun k) + <*> asyncRun (f o) + a -> feedUp (encased a) $ \o k -> join $ + go <$> (Just <$> asyncRun k) <*> asyncRun (f o) + -- If we have an upstream source value ready, we must flush + -- all available values yielded by downstream until it awaits. + flushDown :: ProcessT m a b + -> ((a -> ProcessT m a b) -> m (MachineStep m k b)) + -> m (MachineStep m k b) + flushDown m k = runMachineT m >>= \s -> case s of + Stop -> return Stop + Yield o m' -> return . Yield o . MachineT $ flushDown m' k + Await f Refl _ -> k f + -- If downstream is awaiting an input, we must pull in all + -- necessary upstream awaits until we have a yielded value to + -- push downstream. + feedUp :: MachineT m k a + -> (a -> MachineT m k a -> m (MachineStep m k b)) + -> m (MachineStep m k b) + feedUp m k = runMachineT m >>= \s -> case s of + Stop -> return Stop + Yield o m' -> k o m' + Await g kg fg -> return $ awaitStep g kg fg (MachineT . flip feedUp k) diff --git a/vendor/concurrent-machines-0.3.1.5/src/Data/Machine/Concurrent/AsyncStep.hs b/vendor/concurrent-machines-0.3.1.5/src/Data/Machine/Concurrent/AsyncStep.hs new file mode 100644 --- /dev/null +++ b/vendor/concurrent-machines-0.3.1.5/src/Data/Machine/Concurrent/AsyncStep.hs @@ -0,0 +1,63 @@ +{- HLINT ignore -} +{- FOURMOLU_DISABLE -} +{-# LANGUAGE FlexibleContexts, GADTs, RankNTypes, ScopedTypeVariables #-} +-- | Internal helpers for taking asynchronous machine steps. +module Data.Machine.Concurrent.AsyncStep where +import Control.Concurrent.Async.Lifted (Async, async, wait) +import Control.Monad.Trans.Control (MonadBaseControl, StM) +import Data.Machine + +-- | Slightly more compact notation for a 'Step'. +type MachineStep m k o = Step k o (MachineT m k o) + +-- | Compact notation for a 'Step' taken asynchronously. +type AsyncStep m k o = Async (StM m (MachineStep m k o)) + +-- | Build an 'Await' step given a continuation that provides +-- subsequent steps. @awaitStep f sel ff k@ is like applying the +-- 'Await' constructor directly, but the continuation @k@ is used to +-- continue the machine. +-- +-- @awaitStep f sel ff k = Await (k . f) sel (k ff)@ +awaitStep :: (a -> d) -> k' a -> d -> (d -> r) -> Step k' b r +awaitStep f sel ff k = Await (k . f) sel (k ff) + +-- | Run one step of a machine as an 'Async' operation. +asyncRun :: MonadBaseControl IO m => MachineT m k o -> m (AsyncStep m k o) +asyncRun = async . runMachineT + +-- | Satisfy a downstream Await by blocking on an upstream step. +stepAsync :: forall m k k' a' d b. + MonadBaseControl IO m + => (forall c. k c -> k' c) + -> AsyncStep m k a' + -> (a' -> d) + -> d + -> d + -> (AsyncStep m k a' -> d -> MachineT m k' b) + -> MachineT m k' b +stepAsync sel src f def prev go = MachineT $ wait src >>= \u -> case u of + Stop -> go' stopped def + Yield a k -> go' k (f a) + Await g kg fg -> return $ awaitStep g (sel kg) fg (MachineT . flip go' prev) + where go' :: MachineT m k a' -> d -> m (MachineStep m k' b) + go' k d = asyncRun k >>= runMachineT . flip go d + +-- | @asyncEncased f x@ launches @x@ and provides the resulting +-- 'AsyncStep' to @f@. Turn a function on 'AsyncStep' to a funciton on +-- 'MachineT'. +asyncEncased :: MonadBaseControl IO m + => (AsyncStep m k1 o1 -> MachineT m k o) + -> MachineT m k1 o1 + -> MachineT m k o +asyncEncased f x = MachineT $ asyncRun x >>= runMachineT . f + +-- | Similar to 'awaitStep', but for continuations that want their inputs +-- to be run asynchronously. +asyncAwait :: MonadBaseControl IO m + => (a -> MachineT m k o) + -> k' a + -> MachineT m k o + -> (AsyncStep m k o -> MachineT m k1 o1) + -> m (Step k' b (MachineT m k1 o1)) +asyncAwait f sel ff = return . awaitStep f sel ff . asyncEncased diff --git a/vendor/concurrent-machines-0.3.1.5/src/Data/Machine/Concurrent/Buffer.hs b/vendor/concurrent-machines-0.3.1.5/src/Data/Machine/Concurrent/Buffer.hs new file mode 100644 --- /dev/null +++ b/vendor/concurrent-machines-0.3.1.5/src/Data/Machine/Concurrent/Buffer.hs @@ -0,0 +1,138 @@ +{- HLINT ignore -} +{- FOURMOLU_DISABLE -} + {-# LANGUAGE CPP, FlexibleContexts, GADTs, ScopedTypeVariables, TupleSections #-} +-- | Place buffers between two machines. This is most useful with +-- irregular production rates. +module Data.Machine.Concurrent.Buffer ( + -- * Blocking buffers + bufferConnect, + -- * Non-blocking (rolling) buffers + rollingConnect, + -- * Internal helpers + mediatedConnect, BufferRoom(..) + ) where +#if defined(__GLASGOW_HASKELL__) && __GLASGOW_HASKELL__ < 710 +import Control.Applicative ((<$>), (<*>)) +#endif +import Control.Concurrent.Async.Lifted (wait, waitEither) +import Control.Monad.Trans.Control (MonadBaseControl) +import Control.Monad (join, (>=>)) +import Data.Machine.Concurrent.AsyncStep +import Data.Machine +import Data.Sequence (ViewL(..), (|>)) +import qualified Data.Sequence as S +#if defined(__GLASGOW_HASKELL__) && __GLASGOW_HASKELL__ < 710 +import Data.Traversable (traverse) +#endif + +-- | Drain downstream until it awaits a value, then pass the awaiting +-- step to the given function. +drain :: Monad m + => MachineStep m k a + -> (MachineStep m k a -> m (MachineStep m k' a)) + -> m (MachineStep m k' a) +drain z k = go z + where go Stop = return Stop + go (Yield o kd) = Yield o . MachineT . go <$> runMachineT kd + go aStep = k aStep + +-- | Feed upstream until it yields a value, then pass the yielded +-- value and next step to the given function. +feedToBursting :: Monad m + => MachineStep m k a + -> (Maybe (a, MachineT m k a) -> m (MachineStep m k b)) + -> m (MachineStep m k b) +feedToBursting z k = go z + where go Stop = k Nothing + go (Await f kf ff) = return $ + Await (\a -> go' (f a)) kf (go' ff) + go (Yield o kk) = k $ Just (o, kk) + go' step = MachineT $ runMachineT step >>= go + +-- | Mediate a 'MachineT' and a 'ProcessT' with a bounded capacity +-- buffer. The source machine runs concurrently with the sink process, +-- and is only blocked when the buffer is full. +bufferConnect :: MonadBaseControl IO m + => Int -> MachineT m k b -> ProcessT m b c -> MachineT m k c +bufferConnect n = mediatedConnect S.empty snoc view + where snoc acc x = (if S.length acc < n - 1 then Vacancy else NoVacancy) $ + acc |> x + view acc = case S.viewl acc of + EmptyL -> Nothing + x :< acc' -> Just (x, acc') + +-- | Mediate a 'MachineT' and a 'ProcessT' with a rolling buffer. The +-- source machine runs concurrently with the sink process and is never +-- blocked. If the sink process can not keep up with upstream, yielded +-- values will be dropped. +rollingConnect :: MonadBaseControl IO m + => Int -> MachineT m k b -> ProcessT m b c -> MachineT m k c +rollingConnect n = mediatedConnect S.empty snoc view + where snoc acc x = Vacancy $ S.take (n-1) acc |> x + view acc = case S.viewl acc of + EmptyL -> Nothing + x :< acc' -> Just (x, acc') + +-- | Indication if the payload value is "full" or not. +data BufferRoom a = NoVacancy a | Vacancy a deriving (Eq, Ord, Show) + +-- | Mediate a 'MachineT' and a 'ProcessT' with a buffer. +-- +-- @mediatedConnect z snoc view source sink@ pipes @source@ into +-- @sink@ through a buffer initialized to @z@ and updated with +-- @snoc@. Upstream is blocked if @snoc@ indicates that the buffer is +-- full after adding a new element. Downstream blocks if @view@ +-- indicates that the buffer is empty. Otherwise, @view@ is expected +-- to return the next element to process and an updated buffer. +mediatedConnect :: forall m t b k c. MonadBaseControl IO m + => t -> (t -> b -> BufferRoom t) -> (t -> Maybe (b,t)) + -> MachineT m k b -> ProcessT m b c -> MachineT m k c +mediatedConnect z snoc view src0 snk0 = + MachineT $ do srcFuture <- asyncRun src0 + snkFuture <- asyncRun snk0 + go z (Just srcFuture) snkFuture + where -- Wait for the next available step + go :: t + -> Maybe (AsyncStep m k b) + -> AsyncStep m (Is b) c + -> m (MachineStep m k c) + go acc src snk = maybe (Left <$> wait snk) (waitEither snk) src >>= + goStep acc . either (Right . (,src)) (Left . (,snk)) + + -- Kick off the next step of both the source and the sink + goAsync :: t + -> Maybe (MachineT m k b) + -> ProcessT m b c + -> m (MachineStep m k c) + goAsync acc src snk = + join $ go acc <$> traverse asyncRun src <*> asyncRun snk + + -- Handle whichever step is ready first + goStep :: t -> Either (MachineStep m k b, AsyncStep m (Is b) c) + (MachineStep m (Is b) c, Maybe (AsyncStep m k b)) + -> m (MachineStep m k c) + goStep acc step = case step of + -- @src@ stepped first + Left (Stop, snk) -> go acc Nothing snk + Left (Await g kg fg, snk) -> + asyncAwait g kg fg (MachineT . flip (go acc) snk . Just) + Left (Yield o k, snk) -> case snoc acc o of + -- add it to the right end of the buffer + Vacancy acc' -> asyncRun k >>= flip (go acc') snk . Just + -- buffer was full + NoVacancy acc' -> + let go' snk' = do src' <- asyncRun k + goStep acc' (Right (snk', Just src')) + in wait snk >>= flip drain go' + + -- @snk@ stepped first + Right (Stop, _) -> return Stop + Right (Yield o k, src) -> do + return $ Yield o (MachineT $ asyncRun k >>= go acc src) + Right (Await f Refl ff, src) -> + case view acc of + Nothing -> maybe (goAsync acc Nothing ff) (wait >=> demandSrc) src + Just (x, acc') -> asyncRun (f x) >>= go acc' src + where demandSrc = flip feedToBursting go' + go' Nothing = goAsync acc Nothing ff + go' (Just (o, k)) = goAsync acc (Just k) (f o) diff --git a/vendor/concurrent-machines-0.3.1.5/src/Data/Machine/Concurrent/Fanout.hs b/vendor/concurrent-machines-0.3.1.5/src/Data/Machine/Concurrent/Fanout.hs new file mode 100644 --- /dev/null +++ b/vendor/concurrent-machines-0.3.1.5/src/Data/Machine/Concurrent/Fanout.hs @@ -0,0 +1,87 @@ +{- HLINT ignore -} +{- FOURMOLU_DISABLE -} +{-# LANGUAGE CPP, FlexibleContexts, GADTs, ScopedTypeVariables #-} +-- | Provide a notion of fanout wherein a single input is passed to +-- several consumers. The consumers are run concurrently. +module Data.Machine.Concurrent.Fanout (fanout, fanoutSteps) where +import Control.Arrow (first, second) +import Control.Concurrent.Async.Lifted (Async, async, wait) +import Control.Monad (foldM) +import Control.Monad.Trans.Control (MonadBaseControl, StM) +import Data.Machine (Step(..), MachineT(..), encased, stopped, ProcessT, Is(..)) +import Data.Machine.Concurrent.AsyncStep (MachineStep) +import Data.Maybe (catMaybes) +#if defined(__GLASGOW_HASKELL__) && __GLASGOW_HASKELL__ < 710 +import Data.Monoid (Monoid, mempty, mconcat) +#endif +import Data.Semigroup (Semigroup(sconcat)) +import Data.List.NonEmpty (NonEmpty((:|))) +#if defined(__GLASGOW_HASKELL__) && __GLASGOW_HASKELL__ < 710 +import Data.Coerce (coerce) +#endif + +-- | Feed a value to a 'ProcessT' at an 'Await' 'Step'. If the +-- 'ProcessT' is awaiting a value, then its next step is +-- returned. Otherwise, the original process is returned. +feed :: forall m a b. MonadBaseControl IO m + => a -> ProcessT m a b + -> m (Async (StM m (MachineStep m (Is a) b))) +feed x m = async $ runMachineT m >>= \(v :: MachineStep m (Is a) b) -> + case v of + Await f Refl _ -> runMachineT (f x) + s -> return s + +-- | Like 'Data.List.mapAccumL' but with a monadic accumulating +-- function. +mapAccumLM :: MonadBaseControl IO m + => (acc -> x -> m (acc, y)) -> acc -> [Async (StM m x)] + -> m (acc, [y]) +mapAccumLM f z = fmap (second ($ [])) . foldM aux (z,id) + where aux (acc,ys) x = do (yielded, nxt) <- wait x >>= f acc + return $ (yielded, (nxt:) . ys) + +-- | Exhaust a sequence of all successive 'Yield' steps taken by a +-- 'MachineT'. Returns the list of yielded values and the next +-- (non-Yield) step of the machine. +flushYields :: Monad m + => Step k o (MachineT m k o) -> m ([o], Maybe (MachineT m k o)) +flushYields = go id + where go rs (Yield o s) = runMachineT s >>= go ((o:) . rs) + go rs Stop = return (rs [], Nothing) + go rs s = return (rs [], Just $ encased s) + +-- | Share inputs with each of a list of processes in lockstep. Any +-- values yielded by the processes for a given input are combined into +-- a single yield from the composite process. +fanout :: (MonadBaseControl IO m, Semigroup r) + => [ProcessT m a r] -> ProcessT m a r +fanout [] = stopped +fanout xs = encased $ Await (MachineT . aux) Refl (fanout xs) + where aux y = do (rs,xs') <- mapM (feed y) xs >>= mapAccumLM yields [] + let nxt = fanout $ catMaybes xs' + case rs of + [] -> runMachineT nxt + (r:rs') -> return $ Yield (sconcat $ r :| rs') nxt + yields rs Stop = return (rs,Nothing) + yields rs y@Yield{} = first (++ rs) <$> flushYields y + yields rs a@Await{} = return (rs, Just $ encased a) + +-- | Share inputs with each of a list of processes in lockstep. If +-- none of the processes yields a value, the composite process will +-- itself yield 'mempty'. The idea is to provide a handle on steps +-- only executed for their side effects. For instance, if you want to +-- run a collection of 'ProcessT's that await but don't yield some +-- number of times, you can use 'fanOutSteps . map (fmap (const ()))' +-- followed by a 'taking' process. +fanoutSteps :: (MonadBaseControl IO m, Monoid r) + => [ProcessT m a r] -> ProcessT m a r +fanoutSteps [] = stopped +fanoutSteps xs = encased $ Await (MachineT . aux) Refl (fanoutSteps xs) + where aux y = do (rs,xs') <- mapM (feed y) xs >>= mapAccumLM yields [] + let nxt = fanoutSteps $ catMaybes xs' + if null rs + then return $ Yield mempty nxt + else return $ Yield (mconcat rs) nxt + yields rs Stop = return (rs,Nothing) + yields rs y@Yield{} = first (++rs) <$> flushYields y + yields rs a@Await{} = return (rs, Just $ encased a) diff --git a/vendor/concurrent-machines-0.3.1.5/src/Data/Machine/Concurrent/Scatter.hs b/vendor/concurrent-machines-0.3.1.5/src/Data/Machine/Concurrent/Scatter.hs new file mode 100644 --- /dev/null +++ b/vendor/concurrent-machines-0.3.1.5/src/Data/Machine/Concurrent/Scatter.hs @@ -0,0 +1,239 @@ +{- HLINT ignore -} +{- FOURMOLU_DISABLE -} +{-# LANGUAGE FlexibleContexts, GADTs, TupleSections, RankNTypes, + ScopedTypeVariables #-} +-- | Routing for splitting and merging processing pipelines. +module Data.Machine.Concurrent.Scatter ( + scatter, mergeSum, splitSum, splitProd + ) where +import Control.Arrow ((***)) +import Control.Concurrent.Async (Async, waitAny) +import Control.Concurrent.Async.Lifted (wait, waitEither, waitBoth) +import Control.Monad ((>=>)) +import Control.Monad.Base (liftBase) +import Control.Monad.Trans.Control (MonadBaseControl, restoreM, StM) +import Data.Machine +import Data.Machine.Concurrent.AsyncStep + +holes :: [a] -> [[a]] +holes = go id + where go _ [] = [] + go x (y:ys) = x ys : go (x . (y:)) ys + +diff :: [a] -> [(a,[a])] +diff xs = zip xs (holes xs) + +waitAnyHole :: MonadBaseControl IO m => [(Async (StM m a), [b])] -> m (a, [b]) +waitAnyHole xs = do (_,(s,b)) <- liftBase $ waitAny xs' + fmap (,b) (restoreM s) + where xs' = map (\(a,b) -> fmap (,b) a) xs + +-- | Produces values from whichever source 'MachineT' yields +-- first. This operation may also be viewed as a /gather/ operation in +-- that all values produced by the given machines are interleaved when +-- fed downstream. Note that inputs are /not/ shared. The composite +-- machine will await an input when any constituent machine awaits an +-- input. That input will be supplied to the awaiting constituent and +-- no other. +-- +-- Some examples of more specific useful types @scatter@ may be used +-- at, +-- +-- @ +-- scatter :: [ProcessT m a b] -> ProcessT m a b +-- scatter :: [SourceT m a] -> SourceT m a +-- @ +-- +-- The former may be used to stream data through a collection of +-- worker 'Process'es, the latter may be used to intersperse values +-- from a collection of sources. +scatter :: MonadBaseControl IO m => [MachineT m k o] -> MachineT m k o +scatter [] = stopped +scatter sinks = MachineT $ mapM asyncRun sinks + >>= waitAnyHole . diff + >>= uncurry go + where go :: MonadBaseControl IO m + => MachineStep m k o + -> [AsyncStep m k o] + -> m (MachineStep m k o) + go Stop [] = return Stop + go Stop sinks' = waitAnyHole (diff sinks') >>= uncurry go + go (Yield o k) sinks' = + asyncRun k >>= return . Yield o . MachineT . goWait . (:sinks') + go (Await f fk ff) sinks' = + asyncAwait f fk ff (MachineT . goWait . (:sinks')) + goWait :: MonadBaseControl IO m + => [AsyncStep m k o] + -> m (MachineStep m k o) + goWait = waitAnyHole . diff >=> uncurry go + +-- | Similar to 'Control.Arrow.|||': split the input between two +-- processes and merge their outputs. +-- +-- Connect two processes to the downstream tails of a 'Machine' that +-- produces 'Either's. The two downstream consumers are run +-- concurrently when possible. When one downstream consumer stops, the +-- other is allowed to run until it stops or the upstream source +-- yields a value the remaining consumer can not handle. +-- +-- @mergeSum sinkL sinkR@ produces a topology like this, +-- +-- @ +-- sinkL +-- / \\ +-- a \\ +-- / \\ +-- source -- Either a b --> -- r --> +-- \\ / +-- b / +-- \\ / +-- sinkR +-- @ +mergeSum :: forall m a b r. MonadBaseControl IO m + => ProcessT m a r -> ProcessT m b r -> ProcessT m (Either a b) r +mergeSum snkL snkR = MachineT $ do sl <- asyncRun snkL + sr <- asyncRun snkR + go sl sr + where go :: AsyncStep m (Is a) r + -> AsyncStep m (Is b) r + -> m (MachineStep m (Is (Either a b)) r) + go sl sr = waitEither sl sr >>= + \(s :: Either (MachineStep m (Is a) r) + (MachineStep m (Is b) r)) -> case s of + Left Stop -> wait sr >>= runMachineT . rightOnly . encased + Right Stop -> wait sl >>= runMachineT . leftOnly . encased + + Left (Yield o k) -> + return . Yield o . MachineT $ asyncRun k >>= flip go sr + Right (Yield o k) -> + return . Yield o . MachineT $ asyncRun k >>= go sl + + Left (Await f Refl ff) -> + return $ + Await (\u -> case u of + Left a -> MachineT $ asyncRun (f a) >>= flip go sr + Right b -> MachineT $ + wait sr >>= forceFeed (go sl) b . encased) + Refl + (MachineT $ asyncRun ff >>= flip go sr) + Right (Await g Refl gg) -> return $ + Await (\u -> case u of + Left a -> + MachineT $ + wait sl >>= forceFeed (flip go sr) a . encased + Right b -> MachineT $ asyncRun (g b) >>= go sl) + Refl + (MachineT $ asyncRun gg >>= go sl) + +-- | Similar to 'Control.Arrow.+++': split the input between two +-- processes, retagging and merging their outputs. +-- +-- The two processes are run concurrently whenever possible. +splitSum :: forall m a b c d. MonadBaseControl IO m + => ProcessT m a b -> ProcessT m c d -> ProcessT m (Either a c) (Either b d) +splitSum snkL snkR = MachineT $ do sl <- asyncRun (fmap lft snkL) + sr <- asyncRun (fmap rgt snkR) + go sl sr + where lft :: b -> Either b d + lft = Left + rgt :: d -> Either b d + rgt = Right + go :: AsyncStep m (Is a) (Either b d) + -> AsyncStep m (Is c) (Either b d) + -> m (MachineStep m (Is (Either a c)) (Either b d)) + go sl sr = waitEither sl sr >>= + \(s :: Either (MachineStep m (Is a) (Either b d)) + (MachineStep m (Is c) (Either b d))) -> case s of + Left Stop -> wait sr >>= runMachineT . rightOnly . encased + Right Stop -> wait sl >>= runMachineT . leftOnly . encased + + Left (Yield o k) -> + return . Yield o . MachineT $ asyncRun k >>= flip go sr + Right (Yield o k) -> + return . Yield o . MachineT $ asyncRun k >>= go sl + + Left (Await f Refl ff) -> + return $ + Await (\u -> case u of + Left a -> MachineT $ asyncRun (f a) >>= flip go sr + Right b -> MachineT $ + wait sr >>= forceFeed (go sl) b . encased) + Refl + (MachineT $ asyncRun ff >>= flip go sr) + Right (Await g Refl gg) -> return $ + Await (\u -> case u of + Left a -> + MachineT $ + wait sl >>= forceFeed (flip go sr) a . encased + Right b -> MachineT $ asyncRun (g b) >>= go sl) + Refl + (MachineT $ asyncRun gg >>= go sl) + +-- | @forceFeed k x p@ runs machine @p@ until it awaits, at which +-- point it is fed @x@. The result of that feeding is asynchronously +-- run, and supplied to the continuation @k@. +forceFeed :: forall m a k b. MonadBaseControl IO m + => (AsyncStep m (Is a) b -> m (MachineStep m k b)) + -> a + -> ProcessT m a b + -> m (MachineStep m k b) +forceFeed go x = aux + where aux p = runMachineT p >>= \v -> case v of + -- Stop -> asyncRun stopped >>= go + Stop -> return Stop + Yield o k -> return . Yield o . MachineT $ aux k + Await f Refl _ -> asyncRun (f x) >>= go + +-- | We have a sink for the Right output of a source, so we want to +-- keep running it as long as upstream does not yield a 'Left' which +-- we can not handle. When upstream yields a 'Left', we 'stop'. +rightOnly :: Monad m => ProcessT m b r -> ProcessT m (Either a b) r +rightOnly snk = repeatedly (await >>= either (const stop) (\x -> yield x)) ~> snk + +-- | We have a sink for the Left output of a source, so we want to +-- keep running it as long as upstream does not yield a 'Right' which +-- we can not handle. When upstream yields a 'Right', we 'stop'. +leftOnly :: Monad m => ProcessT m a r -> ProcessT m (Either a b) r +leftOnly snk = repeatedly (await >>= either (\x -> yield x) (const stop)) ~> snk + +-- | Connect two processes to the downstream tails of a 'Machine' that +-- produces tuples. The two downstream consumers are run +-- concurrently. When one downstream consumer stops, the entire +-- pipeline is stopped. +-- +-- @splitProd sink1 sink2@ produces a topology like this, +-- +-- @ +-- sink1 +-- / \\ +-- a \\ +-- / \\ +-- source -- (a,b) --> -- r --> +-- \\ / +-- b / +-- \\ / +-- sink2 +-- @ +splitProd :: forall m a b r. MonadBaseControl IO m + => ProcessT m a r -> ProcessT m b r -> ProcessT m (a,b) r +splitProd snk1 snk2 = MachineT $ do s1 <- asyncRun snk1 + s2 <- asyncRun snk2 + go s1 s2 + where go :: AsyncStep m (Is a) r + -> AsyncStep m (Is b) r + -> m (MachineStep m (Is (a,b)) r) + go s1 s2 = waitBoth s1 s2 >>= + \(ss :: (MachineStep m (Is a) r, MachineStep m (Is b) r)) -> case ss of + (Stop, _) -> return Stop + (_, Stop) -> return Stop + (Yield o1 k1, Yield o2 k2) -> + return . Yield o1 . encased $ Yield o2 $ MachineT $ + do k1' <- asyncRun k1 + k2' <- asyncRun k2 + go k1' k2' + (Yield o k, _) -> + return . Yield o . MachineT $ asyncRun k >>= flip go s2 + (_, Yield o k) -> + return . Yield o . MachineT $ asyncRun k >>= go s1 + (Await f Refl ff, Await g Refl gg) -> + return $ Await (uncurry splitProd . (f***g)) Refl (splitProd ff gg) diff --git a/vendor/concurrent-machines-0.3.1.5/src/Data/Machine/Concurrent/Tee.hs b/vendor/concurrent-machines-0.3.1.5/src/Data/Machine/Concurrent/Tee.hs new file mode 100644 --- /dev/null +++ b/vendor/concurrent-machines-0.3.1.5/src/Data/Machine/Concurrent/Tee.hs @@ -0,0 +1,37 @@ +{- HLINT ignore -} +{- FOURMOLU_DISABLE -} +{-# LANGUAGE FlexibleContexts, GADTs, ScopedTypeVariables #-} +-- | Support for machines with two inputs from which input may be +-- drawn deterministically. In contrast to "Data.Machine.Tee", the two +-- inputs are eagerly run concurrently in this implementation. +module Data.Machine.Concurrent.Tee where +import Control.Concurrent.Async.Lifted (wait) +import Control.Monad.Trans.Control (MonadBaseControl) +import Data.Machine +import Data.Machine.Concurrent.AsyncStep + +-- | Compose a pair of pipes onto the front of a Tee. +tee :: forall m a a' b b' c. MonadBaseControl IO m + => ProcessT m a a' -> ProcessT m b b' -> TeeT m a' b' c -> TeeT m a b c +tee ma mb m = MachineT $ do srcL <- asyncRun ma + srcR <- asyncRun mb + go m (Just srcL) (Just srcR) + where go :: TeeT m a' b' c + -> Maybe (AsyncStep m (Is a) a') + -> Maybe (AsyncStep m (Is b) b') + -> m (MachineStep m (T a b) c) + go snk srcL srcR = runMachineT snk >>= \v -> case v of + Stop -> return Stop + Yield o k -> return . Yield o . MachineT $ go k srcL srcR + Await f L ff -> maybe (return Stop) wait srcL >>= + \(u :: MachineStep m (Is a) a') -> case u of + Stop -> go ff Nothing srcR + Yield a k -> asyncRun k >>= flip (go (f a)) srcR . Just + Await g Refl fg -> + asyncAwait g L fg $ MachineT . flip (go (encased v)) srcR . Just + Await f R ff -> maybe (return Stop) wait srcR >>= + \(u :: MachineStep m (Is b) b') -> case u of + Stop -> go ff srcL Nothing + Yield b k -> asyncRun k >>= go (f b) srcL . Just + Await g Refl fg -> + asyncAwait g R fg $ MachineT . go (encased v) srcL . Just diff --git a/vendor/concurrent-machines-0.3.1.5/src/Data/Machine/Concurrent/Wye.hs b/vendor/concurrent-machines-0.3.1.5/src/Data/Machine/Concurrent/Wye.hs new file mode 100644 --- /dev/null +++ b/vendor/concurrent-machines-0.3.1.5/src/Data/Machine/Concurrent/Wye.hs @@ -0,0 +1,115 @@ +{- HLINT ignore -} +{- FOURMOLU_DISABLE -} +{-# LANGUAGE CPP, GADTs, FlexibleContexts, RankNTypes, ScopedTypeVariables, + TupleSections #-} +-- | Support for machines with two inputs from which input may be +-- drawn deterministically or non-deterministically. In contrast to +-- "Data.Machine.Wye", the two inputs are eagerly run concurrently in +-- this implementation. +module Data.Machine.Concurrent.Wye (wye) where +#if defined(__GLASGOW_HASKELL__) && __GLASGOW_HASKELL__ < 710 +import Control.Applicative +#endif +import Control.Concurrent.Async.Lifted (wait, waitEither) +import Control.Monad.Trans.Control (MonadBaseControl) +import Data.Machine hiding (wye, (~>), (<~)) +import Data.Machine.Concurrent.AsyncStep + +isX :: Is a c -> Y a b c +isX Refl = X + +isY :: Is b c -> Y a b c +isY Refl = Y + +-- | Only the 'X' input of a 'Wye' is not yet stopped, so we may employ +-- simpler dispatch logic. +wyeOnlyX :: forall a a' b b' c m. MonadBaseControl IO m + => AsyncStep m (Is a) a' -> WyeT m a' b' c -> WyeT m a b c +wyeOnlyX src snk = MachineT $ runMachineT snk >>= \v -> case v of + Stop -> return Stop + Yield o k -> return $ Yield o (wyeOnlyX src k) + Await _ Y ff -> runMachineT $ wye stopped stopped ff + Await f X ff -> runMachineT $ stepAsync isX src f ff (encased v) wyeOnlyX + Await f Z ff -> runMachineT $ + stepAsync isX src (f . Left) ff (encased v) wyeOnlyX + +-- | Only the 'Y' input of a 'Wye' is not yet stopped, so we may +-- employ simpler dispatch logic. +wyeOnlyY :: MonadBaseControl IO m + => AsyncStep m (Is b) b' -> WyeT m a' b' c -> WyeT m a b c +wyeOnlyY src m = MachineT $ runMachineT m >>= \v -> case v of + Stop -> return Stop + Yield o k -> return $ Yield o (wyeOnlyY src k) + Await _ X ff -> runMachineT $ wye stopped stopped ff + Await f Y ff -> runMachineT $ stepAsync isY src f ff (encased v) wyeOnlyY + Await f Z ff -> + runMachineT $ stepAsync isY src (f . Right) ff (encased v) wyeOnlyY + +-- | Precompose a 'Process' onto each input of a 'Wye' (or 'WyeT'). +-- +-- When the choice of input is free (using the 'Z' input descriptor) +-- the two sources will be interleaved. +wye :: forall m a a' b b' c. + (MonadBaseControl IO m) + => ProcessT m a a' -> ProcessT m b b' -> WyeT m a' b' c -> WyeT m a b c +wye ma mb m = MachineT $ do srcL <- asyncRun ma + srcR <- asyncRun mb + go True m srcL srcR + where go :: Bool + -> WyeT m a' b' c + -> AsyncStep m (Is a) a' + -> AsyncStep m (Is b) b' + -> m (MachineStep m (Y a b) c) + go fair snk srcL srcR = runMachineT snk >>= \v -> case v of + Stop -> return Stop + Yield o k -> return . Yield o . MachineT $ go fair k srcL srcR + Await f X ff -> wait srcL >>= + \(u :: MachineStep m (Is a) a') -> case u of + Stop -> runMachineT $ wyeOnlyY srcR ff + Yield a k -> asyncRun k >>= flip (go fair (f a)) srcR + Await g Refl fg -> + asyncAwait g X fg $ MachineT . flip (go fair (encased v)) srcR + Await f Y ff -> wait srcR >>= + \(u :: MachineStep m (Is b) b') -> case u of + Stop -> runMachineT $ wyeOnlyX srcL ff + Yield b k -> asyncRun k >>= go fair (f b) srcL + Await h Refl fh -> + asyncAwait h Y fh $ MachineT . go fair (encased v) srcL + + -- Wait for whoever yields first + Await f Z _ -> + waitFair fair srcL srcR + >>= \(u :: Either (MachineStep m (Is a) a') + (MachineStep m (Is b) b')) -> case u of + Left (Yield a k) -> + asyncRun k >>= \srcL' -> go (not fair) (f $ Left a) srcL' srcR + Right (Yield b k) -> + asyncRun k >>= \srcR' -> go (not fair) (f $ Right b) srcL srcR' + Left Stop -> runMachineT $ wyeOnlyY srcR (encased v) + Right Stop -> runMachineT $ wyeOnlyX srcL (encased v) + + -- The first source to respond wants to await, see what + -- the other source has to offer. + Left la@(Await g Refl fg) -> + wait srcR >>= \(w :: MachineStep m (Is b) b') -> case w of + Stop -> asyncAwait g X fg $ \l' -> wyeOnlyX l' (encased v) + Yield b k -> runMachineT $ wye (encased la) k (f $ Right b) + ra@(Await h Refl fh) -> return $ + Await (\c -> case c of + Left a -> wye (g a) (encased ra) (encased v) + Right b -> wye (encased la) (h b) (encased v)) + Z + (wye fg fh $ encased v) + Right ra@(Await h Refl fh) -> + wait srcL >>= \(w :: MachineStep m (Is a) a') -> case w of + Stop -> asyncAwait h Y fh $ \r' -> wyeOnlyY r' (encased v) + Yield a k -> runMachineT $ wye k (encased ra) (f $ Left a) + la@(Await g Refl fg) -> return $ + Await (\c -> case c of + Left a -> wye (g a) (encased ra) (encased v) + Right b -> wye (encased la) (h b) (encased v)) + Z + (wye fg fh $ encased v) + where waitFair True l r = waitEither l r + waitFair False l r = either Right Left <$> waitEither r l + diff --git a/vendor/concurrent-machines-0.3.1.5/src/Data/Machine/Regulated.hs b/vendor/concurrent-machines-0.3.1.5/src/Data/Machine/Regulated.hs new file mode 100644 --- /dev/null +++ b/vendor/concurrent-machines-0.3.1.5/src/Data/Machine/Regulated.hs @@ -0,0 +1,24 @@ +{- HLINT ignore -} +{- FOURMOLU_DISABLE -} +-- | Slow producers down to run at desired rates. +module Data.Machine.Regulated where +import Control.Concurrent (threadDelay) +import Control.Monad (when) +import Control.Monad.IO.Class (MonadIO(..)) +import Data.Machine.Plan +import Data.Machine.Process +import Data.Machine.Type +import Data.Time.Clock (getCurrentTime, diffUTCTime) + +-- | A pass-through process rate-limited to the given inter-step +-- period in seconds. This may be used to slow down an upstream +-- producer; it can not speed things up. +regulated :: MonadIO m => Double -> ProcessT m a a +regulated target = construct $ liftIO getCurrentTime >>= go 0 + where go dt prevT = + do await >>= \x -> yield x + t <- liftIO getCurrentTime + let e = target - realToFrac (diffUTCTime t prevT) + dt' = dt + 0.5 * e + when (dt' > 0) (liftIO . threadDelay . round $ dt' * 1000000) + go dt' t diff --git a/vendor/hs-opentelemetry-api-1.0.0.0/src/OpenTelemetry/Baggage.hs b/vendor/hs-opentelemetry-api-1.0.0.0/src/OpenTelemetry/Baggage.hs new file mode 100644 --- /dev/null +++ b/vendor/hs-opentelemetry-api-1.0.0.0/src/OpenTelemetry/Baggage.hs @@ -0,0 +1,708 @@ +{- HLINT ignore -} +{- FOURMOLU_DISABLE -} +{-# OPTIONS_GHC -Wno-identities #-} +{-# OPTIONS_GHC -Wno-prepositive-qualified-module #-} + +{-# LANGUAGE CPP #-} +{-# LANGUAGE DeriveLift #-} +{-# LANGUAGE DerivingStrategies #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE QuasiQuotes #-} +{-# LANGUAGE TemplateHaskell #-} + +{- | +Module : OpenTelemetry.Baggage +Copyright : (c) Ian Duncan, 2021-2026 +License : BSD-3 +Description : Propagated key-value metadata for cross-service context +Stability : experimental + += Overview + +Baggage is a set of key-value pairs that propagate alongside trace context +across service boundaries (typically via the @baggage@ HTTP header). Use it +to pass metadata like tenant IDs, feature flags, or routing hints through +your distributed system. + +Baggage is /not/ for span-specific annotations. Use 'OpenTelemetry.Trace.addAttribute' +for that. + += Quick example + +@ +import OpenTelemetry.Baggage + +-- Create baggage: +let bag = insert [token|tenant-id|] (element "abc123") + $ insert [token|region|] (element "us-east-1") + $ empty + +-- Encode for HTTP propagation: +let headerValue = encodeBaggageHeader bag +-- "tenant-id=abc123,region=us-east-1" + +-- Decode from an incoming header: +case decodeBaggageHeader headerBytes of + Right bag -> -- use the baggage + Left err -> -- malformed header +@ + += Thread-local baggage + +Use the functions in "OpenTelemetry.Context.ThreadLocal" to get\/set baggage +on the current thread: + +@ +import OpenTelemetry.Context.ThreadLocal (getContext, adjustContext) +import OpenTelemetry.Context (insertBaggage, lookupBaggage) + +-- Read: +mbag <- lookupBaggage \<$\> getContext +-- Write: +adjustContext (insertBaggage myBaggage) +@ + += Limits + +W3C Baggage specification enforces: + +* Max 8192 bytes total serialized size +* Max 4096 bytes per member +* Max 180 members + +'insertChecked' validates these limits and returns 'Left' 'InvalidBaggage' +on violation. + += Spec reference + + +-} +module OpenTelemetry.Baggage ( + -- * Constructing 'Baggage' structures + Baggage, + empty, + fromHashMap, + values, + Token, + token, + mkToken, + tokenValue, + Element (..), + element, + property, + InvalidBaggage (..), + + -- * Limits (W3C Baggage specification) + maxBaggageBytes, + maxMemberBytes, + maxMembers, + + -- * Modifying 'Baggage' + insert, + insertChecked, + delete, + + -- * Querying 'Baggage' + getValue, + + -- * Encoding and decoding 'Baggage' + encodeBaggageHeader, + encodeBaggageHeaderB, + decodeBaggageHeader, +) where + +import Control.Monad (when) +import qualified Data.ByteString as BS +import qualified Data.ByteString.Builder as B +import qualified Data.ByteString.Builder.Extra as BS +import Data.ByteString.Char8 (ByteString) +import qualified Data.ByteString.Char8 as B8 +import qualified Data.ByteString.Internal as BS +import qualified Data.ByteString.Lazy as L +import Data.ByteString.Unsafe (unsafePackAddressLen) +import qualified Data.HashMap.Strict as H +import Data.Hashable +import Data.Text (Text) +import qualified Data.Text as T +import Data.Text.Encoding (decodeUtf8', encodeUtf8) +import Data.Word (Word8) +import Language.Haskell.TH.Lib +import Language.Haskell.TH.Quote +import Language.Haskell.TH.Syntax +import System.IO.Unsafe + + +{- | A key for a baggage entry, restricted to the set of valid characters + specified in the @token@ definition of RFC 2616: + + https://www.rfc-editor.org/rfc/rfc2616#section-2.2 + + @since 0.0.1.0 +-} +newtype Token = Token ByteString + deriving stock (Show, Eq, Ord) + deriving newtype (Hashable) + + +{- | Convert a 'Token' into a 'ByteString' + +@since 0.0.1.0 +-} +tokenValue :: Token -> ByteString +tokenValue (Token t) = t + +#if MIN_VERSION_template_haskell(2, 17, 0) +instance Lift Token where + liftTyped (Token tok) = liftCode $ unsafeTExpCoerce $ bsToExp tok +#else +instance Lift Token where + liftTyped (Token tok) = unsafeTExpCoerce $ bsToExp tok +#endif + + +{- | An entry into the baggage + +@since 0.0.1.0 +-} +data Element = Element + { value :: Text + , properties :: [Property] + } + deriving stock (Show, Eq) + + +-- | @since 0.0.1.0 +element :: Text -> Element +element t = Element t [] + + +data Property = Property + { propertyKey :: Token + , propertyValue :: Maybe Text + } + deriving stock (Show, Eq) + + +-- | @since 0.0.1.0 +property :: Token -> Maybe Text -> Property +property = Property + + +{- | Baggage is used to annotate telemetry, adding context and information to metrics, traces, and logs. + It is a set of name/value pairs describing user-defined properties. + Each name in Baggage is associated with exactly one value. + + @since 0.0.1.0 +-} +newtype Baggage = Baggage (H.HashMap Token Element) + deriving stock (Show, Eq) + deriving newtype (Semigroup) + + +-- | RFC 2616 token character predicate (no allocation, branchless via table) +isTokenChar :: Char -> Bool +isTokenChar c = w < 128 && tokenTable `BS.index` fromIntegral w /= 0 + where + w = fromEnum c +{-# INLINE isTokenChar #-} + + +-- 128-byte lookup: 1 = valid token char, 0 = invalid +tokenTable :: ByteString +tokenTable = + BS.pack + [ 0 + , 0 + , 0 + , 0 + , 0 + , 0 + , 0 + , 0 + , 0 + , 0 + , 0 + , 0 + , 0 + , 0 + , 0 + , 0 -- 0x00-0x0f + , 0 + , 0 + , 0 + , 0 + , 0 + , 0 + , 0 + , 0 + , 0 + , 0 + , 0 + , 0 + , 0 + , 0 + , 0 + , 0 -- 0x10-0x1f + , 0 + , 1 + , 0 + , 1 + , 1 + , 1 + , 1 + , 1 + , 0 + , 0 + , 1 + , 1 + , 0 + , 1 + , 1 + , 0 -- ! # $ % & ' * + - . + , 1 + , 1 + , 1 + , 1 + , 1 + , 1 + , 1 + , 1 + , 1 + , 1 + , 0 + , 0 + , 0 + , 0 + , 0 + , 0 -- 0-9 + , 0 + , 1 + , 1 + , 1 + , 1 + , 1 + , 1 + , 1 + , 1 + , 1 + , 1 + , 1 + , 1 + , 1 + , 1 + , 1 -- A-O + , 1 + , 1 + , 1 + , 1 + , 1 + , 1 + , 1 + , 1 + , 1 + , 1 + , 1 + , 0 + , 0 + , 0 + , 1 + , 1 -- P-Z ^ _ + , 1 + , 1 + , 1 + , 1 + , 1 + , 1 + , 1 + , 1 + , 1 + , 1 + , 1 + , 1 + , 1 + , 1 + , 1 + , 1 -- ` a-o + , 1 + , 1 + , 1 + , 1 + , 1 + , 1 + , 1 + , 1 + , 1 + , 1 + , 1 + , 0 + , 1 + , 0 + , 1 + , 0 -- p-z | ~ + ] +{-# NOINLINE tokenTable #-} + + +-- Ripped from file-embed-0.0.13 +bsToExp :: (Monad m) => ByteString -> m Exp +#if MIN_VERSION_template_haskell(2, 5, 0) +bsToExp bs = + return $ ConE 'Token + `AppE` (VarE 'unsafePerformIO + `AppE` (VarE 'unsafePackAddressLen + `AppE` LitE (IntegerL $ fromIntegral $ BS.length bs) +#if MIN_VERSION_template_haskell(2, 16, 0) + `AppE` LitE (bytesPrimL ( + let BS.PS ptr off sz = bs + in mkBytes ptr (fromIntegral off) (fromIntegral sz))))) +#elif MIN_VERSION_template_haskell(2, 8, 0) + `AppE` LitE (StringPrimL $ B.unpack bs))) +#else + `AppE` LitE (StringPrimL $ B8.unpack bs))) +#endif +#else +bsToExp bs = do + helper <- [| stringToBs |] + let chars = B8.unpack bs + return $! AppE helper $! LitE $! StringL chars +#endif + + +-- | @since 0.0.1.0 +mkToken :: Text -> Maybe Token +mkToken txt + | T.null txt = Nothing + | txt `T.compareLength` 4096 == GT = Nothing + | T.all isTokenChar txt = Just $ Token $ encodeUtf8 txt + | otherwise = Nothing + + +-- | @since 0.0.1.0 +token :: QuasiQuoter +token = + QuasiQuoter + { quoteExp = parseExp + , quotePat = \_ -> fail "Token as pattern not implemented" + , quoteType = \_ -> fail "Can't use a Baggage Token as a type" + , quoteDec = \_ -> fail "Can't use a Baggage Token as a declaration" + } + where + parseExp = \str -> case mkToken $ T.pack str of + Nothing -> fail (show str ++ " is not a valid Token.") + Just tok -> lift tok + + +-- | @since 0.0.1.0 +data InvalidBaggage + = BaggageTooLong + | MemberTooLong + | TooManyListMembers + | Empty + deriving stock (Show, Eq) + + +-- | @since 0.0.1.0 +encodeBaggageHeader :: Baggage -> ByteString +encodeBaggageHeader = + L.toStrict + . BS.toLazyByteStringWith (BS.untrimmedStrategy (8192 + 16) BS.smallChunkSize) L.empty + . encodeBaggageHeaderB + + +-- | @since 0.0.1.0 +encodeBaggageHeaderB :: Baggage -> B.Builder +encodeBaggageHeaderB (Baggage bmap) = + go 0 True (take maxMembers $ H.toList bmap) + where + go :: Int -> Bool -> [(Token, Element)] -> B.Builder + go _ _ [] = mempty + go totalSoFar isFirst ((tok, el) : rest) = + let memberBs = builderToStrict (encodeMemberB tok el) + memberLen = BS.length memberBs + sep = if isFirst then 0 else 1 + newTotal = totalSoFar + sep + memberLen + in if memberLen > maxMemberBytes + then go totalSoFar isFirst rest + else + if newTotal > maxBaggageBytes + then mempty + else + (if isFirst then mempty else B.char7 ',') + <> B.byteString memberBs + <> go newTotal False rest + + +encodeMemberB :: Token -> Element -> B.Builder +encodeMemberB (Token k) (Element v props) = + B.byteString k + <> B.char7 '=' + <> percentEncodeBuilder (encodeUtf8 v) + <> mconcat (map (\p -> B.char7 ';' <> propEncoderB p) props) + + +propEncoderB :: Property -> B.Builder +propEncoderB (Property (Token k) mv) = + B.byteString k + <> maybe + mempty + (\v -> B.char7 '=' <> percentEncodeBuilder (encodeUtf8 v)) + mv + + +builderToStrict :: B.Builder -> ByteString +builderToStrict = L.toStrict . B.toLazyByteString + + +{- | W3C Baggage: max 8192 bytes total, max 180 members, max 4096 bytes per member + +@since 0.0.1.0 +-} +maxBaggageBytes, maxMemberBytes, maxMembers :: Int +maxBaggageBytes = 8192 +maxMemberBytes = 4096 +maxMembers = 180 + + +-- | @since 0.0.1.0 +decodeBaggageHeader :: ByteString -> Either String Baggage +decodeBaggageHeader bs + | BS.length bs > maxBaggageBytes = Left "Baggage header exceeds 8192 byte limit" + | otherwise = parseBaggageHeader bs + + +parseBaggageHeader :: ByteString -> Either String Baggage +parseBaggageHeader input = do + let stripped = stripOWS input + when (BS.null stripped) $ Left "Empty baggage header" + let rawMembers = splitOnByte 0x2C stripped -- ',' + when (length rawMembers > maxMembers) $ + Left ("Baggage has more than " ++ show maxMembers ++ " members") + members <- mapM parseMember rawMembers + pure $ Baggage $ H.fromList members + + +parseMember :: ByteString -> Either String (Token, Element) +parseMember raw = do + let s = stripOWS raw + let (keyBs, rest0) = B8.span isTokenChar s + when (BS.null keyBs) $ Left "Expected token in baggage member" + let rest1 = stripOWS rest0 + rest2 <- expectByte 0x3D rest1 -- '=' + let rest3 = stripOWS rest2 + (valBs, rest4) = BS.span isValueByte rest3 + val <- case decodeUtf8' (percentDecode valBs) of + Right t -> Right t + Left _ -> Left "Invalid UTF-8 in baggage value" + props <- parseProperties rest4 + pure (Token keyBs, Element val props) + + +parseProperties :: ByteString -> Either String [Property] +parseProperties bs = go (stripOWS bs) + where + go s + | BS.null s = Right [] + | BS.head s == 0x3B = do + -- ';' + let s1 = stripOWS (BS.tail s) + (keyBs, rest0) = B8.span isTokenChar s1 + when (BS.null keyBs) $ Left "Expected token in baggage property" + let rest1 = stripOWS rest0 + if not (BS.null rest1) && BS.head rest1 == 0x3D -- '=' + then do + let rest2 = stripOWS (BS.tail rest1) + (valBs, rest3) = BS.span isValueByte rest2 + rest <- go (stripOWS rest3) + propVal <- case decodeUtf8' (percentDecode valBs) of + Right t -> Right t + Left _ -> Left "Invalid UTF-8 in baggage property value" + pure $ Property (Token keyBs) (Just propVal) : rest + else do + rest <- go rest1 + pure $ Property (Token keyBs) Nothing : rest + | otherwise = Left $ "Unexpected byte in baggage: " ++ show (BS.head s) + + +isValueByte :: Word8 -> Bool +isValueByte w = + w == 0x21 + || (w >= 0x23 && w <= 0x2B) + || (w >= 0x2D && w <= 0x3A) + || (w >= 0x3C && w <= 0x5B) + || (w >= 0x5D && w <= 0x7E) +{-# INLINE isValueByte #-} + + +stripOWS :: ByteString -> ByteString +stripOWS = B8.dropWhile (\c -> c == ' ' || c == '\t') . B8.dropWhileEnd (\c -> c == ' ' || c == '\t') +{-# INLINE stripOWS #-} + + +expectByte :: Word8 -> ByteString -> Either String ByteString +expectByte expected bs + | BS.null bs = Left $ "Expected " ++ show expected ++ " but got end of input" + | BS.head bs == expected = Right (BS.tail bs) + | otherwise = Left $ "Expected " ++ show expected ++ " but got " ++ show (BS.head bs) +{-# INLINE expectByte #-} + + +splitOnByte :: Word8 -> ByteString -> [ByteString] +splitOnByte w bs + | BS.null bs = [] + | otherwise = + let (before, rest) = BS.break (== w) bs + in before : if BS.null rest then [] else splitOnByte w (BS.tail rest) + + +{- | An empty initial baggage value + +@since 0.0.1.0 +-} +empty :: Baggage +empty = Baggage H.empty + + +-- | @since 0.0.1.0 +insert + :: Token + -- ^ The name for which to set the value + -> Element + -- ^ The value to set. Use 'element' to construct a well-formed element value. + -> Baggage + -> Baggage +insert k v (Baggage c) = Baggage (H.insert k v c) + + +{- | Insert a key\/value pair into the baggage with W3C limit enforcement. + +Returns 'Left' 'InvalidBaggage' if adding the entry would violate: + +* 'TooManyListMembers': exceeds 180 entries (W3C ABNF max) +* 'BaggageTooLong': serialized header would exceed 8192 bytes + +@since 0.4.0.0 +-} +insertChecked + :: Token + -> Element + -> Baggage + -> Either InvalidBaggage Baggage +insertChecked k v (Baggage c) = + let c' = H.insert k v c + newCount = H.size c' + newBag = Baggage c' + in if newCount > maxMembers + then Left TooManyListMembers + else + let totalBytes = baggageSerializedSize c' + in if totalBytes > maxBaggageBytes + then Left BaggageTooLong + else Right newBag + + +baggageSerializedSize :: H.HashMap Token Element -> Int +baggageSerializedSize m = + let entries = H.toList m + memberSizes = map (\(tok, el) -> memberByteLen tok el) entries + separators = max 0 (length entries - 1) + in sum memberSizes + separators + where + memberByteLen (Token k) (Element v props) = + BS.length k + + 1 + + BS.length (percentEncode (encodeUtf8 v)) + + sum (map propLen props) + propLen (Property (Token pk) Nothing) = 1 + BS.length pk + propLen (Property (Token pk) (Just pv)) = 1 + BS.length pk + 1 + BS.length (percentEncode (encodeUtf8 pv)) + + +{- | Delete a key/value pair from the baggage. + +@since 0.0.1.0 +-} +delete :: Token -> Baggage -> Baggage +delete k (Baggage c) = Baggage (H.delete k c) + + +{- | Look up a baggage value by name. + +Per the spec, this takes a name and returns the associated value, or +'Nothing' if the name is not present in the baggage. + +@since 0.4.0.0 +-} +getValue :: Token -> Baggage -> Maybe Text +getValue k (Baggage m) = case H.lookup k m of + Just (Element v _) -> Just v + Nothing -> Nothing + + +{- | Returns the name/value pairs in the `Baggage`. The order of name/value pairs + is not significant. + + @since 0.0.1.0 +-} +values :: Baggage -> H.HashMap Token Element +values (Baggage m) = m + + +{- | Convert a 'H.HashMap' into 'Baggage' + +@since 0.0.1.0 +-} +fromHashMap :: H.HashMap Token Element -> Baggage +fromHashMap = Baggage + + +-- Percent-encoding (RFC 3986 unreserved characters) +-- Spaces are always encoded as %20 (not +). + +isUnreserved :: Word8 -> Bool +isUnreserved w = + (w >= 65 && w <= 90) -- A-Z + || (w >= 97 && w <= 122) -- a-z + || (w >= 48 && w <= 57) -- 0-9 + || w == 45 -- - + || w == 46 -- . + || w == 95 -- _ + || w == 126 -- ~ +{-# INLINE isUnreserved #-} + + +percentEncode :: ByteString -> ByteString +percentEncode = L.toStrict . B.toLazyByteString . percentEncodeBuilder +{-# INLINE percentEncode #-} + + +percentEncodeBuilder :: ByteString -> B.Builder +percentEncodeBuilder = BS.foldl' (\acc w -> acc <> encodeWord8 w) mempty + where + encodeWord8 w + | isUnreserved w = B.word8 w + | otherwise = B.char7 '%' <> hexWord8 w + hexWord8 w = + let (hi, lo) = w `divMod` 16 + in B.word8 (hexDigit hi) <> B.word8 (hexDigit lo) + hexDigit n + | n < 10 = n + 48 -- '0' + | otherwise = n + 55 -- 'A' - 10 + + +percentDecode :: ByteString -> ByteString +percentDecode bs = L.toStrict $ B.toLazyByteString $ go 0 + where + len = BS.length bs + go i + | i >= len = mempty + | BS.index bs i == 0x25 + , i + 2 < len -- '%' + , Just hi <- unhex (BS.index bs (i + 1)) + , Just lo <- unhex (BS.index bs (i + 2)) = + B.word8 (hi * 16 + lo) <> go (i + 3) + | otherwise = + B.word8 (BS.index bs i) <> go (i + 1) + unhex w + | w >= 48 && w <= 57 = Just (w - 48) -- 0-9 + | w >= 65 && w <= 70 = Just (w - 55) -- A-F + | w >= 97 && w <= 102 = Just (w - 87) -- a-f + | otherwise = Nothing