Initial commit

.github/workflows/test.yml

@@ -0,0 +1,67 @@
+name: Test
+
+on:
+  pull_request:
+    branches:
+      - main
+  push:
+    branches:
+      - main
+
+jobs:
+  build:
+    strategy:
+      fail-fast: false
+      matrix:
+        os: [ ubuntu-latest ]
+
+        # All supported Perl versions except latest.
+        perl: [
+          '5.32', '5.34', '5.36',
+        ]
+
+        # Variants of the latest Perl.
+        include:
+          - os: macos-latest
+            perl: '5.38'
+
+          # This is effectively our normal one: all features and cover.
+          - name: ' (all)'
+            os: ubuntu-latest
+            perl: '5.38'
+            cover: true
+
+    runs-on: ${{ matrix.os }}
+
+    name: v${{ matrix.perl }} on ${{ matrix.os }}${{ matrix.name }}
+
+    steps:
+      - uses: actions/checkout@v2
+
+      - uses: shogo82148/actions-setup-perl@v1
+        with:
+          perl-version: ${{ matrix.perl }}
+
+      # FIXME: Why do we need to install M:B:T manually
+      # if cpanm --showdeps correctly reports it as a dependency?
+      - name: Install dependencies
+        run: |
+          cpanm --installdeps -n .
+          cpanm -n Module::Build::Tiny
+
+      - if: ${{ matrix.cover }}
+        run: |
+          cpanm -n Devel::Cover::Report::Coveralls
+
+      - name: Build
+        run: |
+          perl Build.PL
+          perl Build build
+
+      - if: ${{ matrix.cover }}
+        env:
+          GITHUB_TOKEN: ${{ secrets.GITHUB_TOKEN }}
+        run: cover -report Coveralls -test
+
+      - if: ${{ !matrix.cover }}
+        run: perl Build test

.gitignore

@@ -0,0 +1,12 @@
+*~
+*.swp
+*.swo
+.build/
+cover_db/
+
+# Build artifacts
+Build
+blib/
+MYMETA.*
+_build_params
+Dancer2-Plugin-OpenTelemetry*

cpanfile

@@ -0,0 +1,9 @@
+requires 'Dancer2';
+requires 'Feature::Compat::Try';
+requires 'OpenTelemetry', '0.010';
+requires 'Syntax::Keyword::Dynamically';
+
+on test => sub {
+    requires 'Test2::MojoX';
+    requires 'Test2::V0';
+};

dist.ini

@@ -0,0 +1,9 @@
+name    = Dancer2-Plugin-OpenTelemetry
+author  = José Joaquín Atria <[email protected]>
+license = Perl_5
+copyright_holder = José Joaquín Atria
+copyright_year   = 2023
+
+version = 0.001
+
+[@Basic]

lib/Dancer2/Plugin/OpenTelemetry.pm

@@ -0,0 +1,146 @@
+package Dancer2::Plugin::OpenTelemetry;
+
+use strict;
+use warnings;
+use experimental 'signatures';
+
+use Dancer2::Plugin;
+use OpenTelemetry -all;
+use OpenTelemetry::Constants -span;
+
+use constant BACKGROUND => 'otel.plugin.dancer2.background';
+
+sub BUILD ( $plugin, @ ) {
+    my %tracer = %{
+        $plugin->config->{tracer} // {
+            name => otel_config('SERVICE_NAME') // 'dancer2',
+        },
+    };
+
+    $plugin->app->add_hook(
+        Dancer2::Core::Hook->new(
+            name => 'before',
+            code => sub ( $app ) {
+                my $req = $app->request;
+
+                # Make sure we only handle each request once
+                # This protects us against duplicating efforts in the
+                # event of eg. a `forward` or a `pass`.
+                return if $req->env->{+BACKGROUND};
+
+                # Since our changes to the current context are global,
+                # we try to store a copy of the previous "background"
+                # context to restore it after we are done
+                # As long as we do this, these global changes _should_
+                # be invisible to other well-behaved applications that
+                # rely on this context and are using dynamically as
+                # appropriate.
+                $req->env->{+BACKGROUND} = otel_current_context;
+
+                my $url = URI->new(
+                    $req->scheme . '://' . $req->host . $req->uri
+                );
+
+                my $method  = $req->method;
+                my $route   = $req->route->spec_route;
+                my $agent   = $req->agent;
+                my $query   = $url->query;
+                my $version = $req->protocol =~ s{.*/}{}r;
+
+                # https://opentelemetry.io/docs/specs/semconv/http/http-spans/#setting-serveraddress-and-serverport-attributes
+                my $hostport;
+                if ( my $fwd = $req->header('forwarded') ) {
+                    my ($first) = split ',', $fwd, 2;
+                    $hostport = $1 // $2 if $first =~ /host=(?:"([^"]+)"|([^;]+))/;
+                }
+
+                $hostport //= $req->header('x-forwarded-proto')
+                    // $req->header('host');
+
+                my ( $host, $port ) = $hostport =~ /(.*?)(?::([0-9]+))?$/g;
+
+                my $context = otel_propagator->extract(
+                    $req,
+                    undef,
+                    sub ( $carrier, $key ) { scalar $carrier->header($key) },
+                );
+
+                my $span = otel_tracer_provider->tracer(%tracer)->create_span(
+                    name       => $method . ' ' . $route,
+                    parent     => $context,
+                    kind       => SPAN_KIND_SERVER,
+                    attributes => {
+                        'http.request.method'            => $method,
+                        'network.protocol.version'       => $version,
+                        'url.path'                       => $url->path,
+                        'url.scheme'                     => $url->scheme,
+                        'http.route'                     => $route,
+                        'client.address'                 => $req->address,
+                      # 'client.port'                    => ..., # TODO
+                        $host  ? ( 'server.address'      => $host  ) : (),
+                        $port  ? ( 'server.port'         => $port  ) : (),
+                        $agent ? ( 'user_agent.original' => $agent ) : (),
+                        $query ? ( 'url.query'           => $query ) : (),
+                    },
+                );
+
+                # Normally we would set this with `dynamically`, to ensure
+                # that any previous context was restored after the fact.
+                # However, that requires us to be have a scope that wraps
+                # around the entire request, and Dancer2 does not have such
+                # a hook.
+                # We can do that with the Plack middleware, but that has no
+                # way to hook into the Dancer2 router at span-creation time,
+                # so we have no way to generate a low-cardinality span name
+                # early enough for it to be used in a sampling decision.
+                otel_current_context
+                    = otel_context_with_span( $span, $context );
+            },
+        ),
+    );
+
+    $plugin->app->add_hook(
+        Dancer2::Core::Hook->new(
+            name => 'after',
+            code => sub ( $res ) {
+                return unless my $context
+                    = delete $plugin->app->request->env->{+BACKGROUND};
+
+                my $code  = $res->status;
+                my $error = $code >= 400 && $code < 600;
+                otel_span_from_context
+                    ->set_status( $error ? SPAN_STATUS_ERROR : SPAN_STATUS_OK )
+                    ->set_attribute( 'http.response.status_code' => $code )
+                    ->end;
+
+                otel_current_context = $context;
+            },
+        ),
+    );
+
+    $plugin->app->add_hook(
+        Dancer2::Core::Hook->new(
+            name => 'on_route_exception',
+            code => sub ( $, $error ) {
+                return unless my $context
+                    = delete $plugin->app->request->env->{+BACKGROUND};
+
+                my ($message) = split /\n/, "$error", 2;
+                $message =~ s/ at \S+ line \d+\.$//a;
+
+                otel_span_from_context
+                    ->record_exception($error)
+                    ->set_status( SPAN_STATUS_ERROR, $message )
+                    ->set_attribute(
+                        'error.type' => ref $error || 'string',
+                        'http.response.status_code' => 500,
+                    )
+                    ->end;
+
+                otel_current_context = $context;
+            },
+        ),
+    );
+}
+
+1;