view release on metacpan or  search on metacpan

lib/ForgeOps/Tracker.pm  view on Meta::CPAN

use POSIX qw(strftime);
use ForgeOps::Tracker::ChangeDelivery;
use ForgeOps::Tracker::Changes;
use ForgeOps::Tracker::Client;
use ForgeOps::Tracker::Configuration;
use ForgeOps::Tracker::DeliveryQueue;
use ForgeOps::Tracker::EventBuilder;
use ForgeOps::Tracker::MetricBuffer;
use ForgeOps::Tracker::PerformanceFlusher;
use ForgeOps::Tracker::Reporter;
use ForgeOps::Tracker::SpanBuffer;
use ForgeOps::Tracker::SpanDelivery;
use ForgeOps::Tracker::TraceParent;
use Scalar::Util ();
use Time::HiRes ();

# 0.2.0 was never bumped past: that exact tarball was uploaded to PAUSE once (2026-09-11) but
# never made it into the public CPAN index, and PAUSE permanently refuses a second upload of a
# distribution+version pair it already has on record, even one that never indexed (confirmed
# directly: retrying the identical 0.2.0 tarball came back 409 Conflict, not the original success
# response repeated). No functional change from 0.2.0; this bump exists solely to get a fresh,
# uploadable version number.
our $VERSION = '0.13.0';

my $configuration;
my $reporter;
my $performance_flusher;
my $span_queue;
my $change_queue;
my $change_snapshot_sent = 0;
my $environment_warning_given = 0;
my $https_warning_given = 0;
my ($metric_buffer, $infrastructure_metric_buffer);

# The affected user set via set_user() below, if any: a plain package variable, the same
# "shared-nothing between requests" reasoning as sdks/php's own static property (see that
# client's own comment): a typical Perl PSGI deployment (Starman, uWSGI, mod_perl's own prefork
# workers) is one process per worker, forked fresh before serving any request, so this is safely
# request-scoped there without needing a thread-local. Request-handling code under a threaded or
# event-loop-based PSGI server should `local`-ize this instead of assigning to it directly, the
# same way Dancer2 itself already uses `local` for its own per-request state.
our $current_user;

# The breadcrumb trail add_breadcrumb() below appends to: a plain package array, the same
# one-process-per-worker reasoning as $current_user above. Unlike $current_user, it accumulates
# over a request's lifetime rather than being set once, so the PSGI/Dancer2 integrations clear it
# at the start of each request themselves (see clear_breadcrumbs); a prefork worker serves many
# requests in a row, and without that one request's trail would leak into the next. Request-
# handling code under a threaded or event-loop-based PSGI server should `local`-ize this array
# instead, exactly as $current_user's own comment describes.
our @current_breadcrumbs;

# The trace span() and record_span() below record into, if one is open: a plain package variable,
# same reasoning as @current_breadcrumbs above. The PSGI/Dancer2 performance integrations start
# and finish it around every request; finish_trace() always clears it, so nothing leaks into the
# next request a prefork worker serves. Request-handling code under a threaded or event-loop-based
# PSGI server should `local`-ize it instead.
our $current_trace;

# The current request's context, if one is running: { trace_id, parent_span_id, transaction_name,
# endpoint, errored }. Set by start_trace() whether or not span tracing is on (the trace id is also
# what links an error to errors in other services), cleared by finish_trace(), and a plain package
# variable for the same reason as $current_trace above (`local`-ize it the same way under a
# threaded or event-loop PSGI server).
our $current_request;

# Request context remembered for an error that escaped a request (see snapshot_onto), for when it
# is only reported after finish_trace() has already cleared $current_request: the PSGI error
# middleware sits outside the performance one, and Dancer2 runs its on_route_exception hooks in
# whatever order the plugins were loaded. A short list rather than something attached to the
# error itself, since a Perl error is as often a plain string as an object; newest first.
my @escaped;
my $MAX_ESCAPED = 8;
sub _configuration {
    $configuration ||= ForgeOps::Tracker::Configuration->new;
    return $configuration;
}

sub _reporter {
    unless ($reporter) {
        my $config = _configuration();
        my $client = ForgeOps::Tracker::Client->new($config);
        my $delivery_queue = ForgeOps::Tracker::DeliveryQueue->new($config, $client);
        $reporter = ForgeOps::Tracker::Reporter->new($config, ForgeOps::Tracker::EventBuilder->new($config), $delivery_queue);
    }
    return $reporter;
}

sub _performance_flusher {
    unless ($performance_flusher) {
        my $config = _configuration();
        my $client = ForgeOps::Tracker::Client->new($config);
        $performance_flusher = ForgeOps::Tracker::PerformanceFlusher->new($config, $client);
    }
    return $performance_flusher;
}

sub _metric_buffers {
    unless ($metric_buffer) {
        my $config = _configuration();
        my $client = ForgeOps::Tracker::Client->new($config);
        $metric_buffer = ForgeOps::Tracker::MetricBuffer->new(
            $config, sub { $client->deliver_metrics($_[0]); $client->last_status }, sub { $config->{metric_flush_interval} },
        );
        $infrastructure_metric_buffer = ForgeOps::Tracker::MetricBuffer->new(
            $config, sub { $client->deliver_infrastructure_metrics($_[0]); $client->last_status }, sub { $config->{infrastructure_metric_flush_interval} },
        );
    }
    return ($metric_buffer, $infrastructure_metric_buffer);
}

sub _span_queue {
    unless ($span_queue) {
        my $config = _configuration();
        my $client = ForgeOps::Tracker::Client->new($config);
        $span_queue = ForgeOps::Tracker::DeliveryQueue->new($config, ForgeOps::Tracker::SpanDelivery->new($client));
    }
    return $span_queue;
}

sub _change_queue {

lib/ForgeOps/Tracker.pm  view on Meta::CPAN

}

# With a DSN set and an environment that doesn't send, every report is silently dropped, which
# otherwise looks exactly like a broken setup. Said once per process, through the configured logger,
# or as a plain warn (stderr) when there is none. Never without a DSN.
sub _warn_once_if_environment_is_not_enabled {
    my ($config) = @_;
    return if $environment_warning_given;
    return unless defined $config->{dsn} && length $config->{dsn};
    my $environment = $config->{environment} // '';
    my %enabled = %{ $config->{enabled_environments} || {} };
    return if $enabled{$environment};

    $environment_warning_given = 1;
    my $list = join ', ', sort grep { $enabled{$_} } keys %enabled;
    my $message = qq{[ForgeOps] Not sending: this environment is "$environment", and only $list are enabled. }
        . qq{Set FORGE_OPS_ENVIRONMENT=production (or add "$environment" to the enabled environments) to send from here.};
    if ($config->{logger}) {
        $config->log($message);
    } else {
        warn "$message\n";
    }
    return;
}

# A ForgeOps DSN is https, and HTTP::Tiny can only speak https with IO::Socket::SSL and Net::SSLeay
# installed, which aren't core Perl. Without them every delivery fails quietly inside the client,
# which looks exactly like a broken setup. They're prerequisites from 0.12.3 on, so this is for a
# perl where they were removed, or the SDK was copied in rather than installed. Said once per
# process, the same way as the environment warning. Never without a DSN, or for an http one.
sub _warn_once_if_https_is_unavailable {
    my ($config) = @_;
    return if $https_warning_given;
    return unless defined $config->{dsn} && $config->{dsn} =~ m{^https://}i;
    return unless HTTP::Tiny->can('can_ssl');
    my ($ok) = HTTP::Tiny->can_ssl;
    return if $ok;

    $https_warning_given = 1;
    my $message = q{[ForgeOps] Not sending: the DSN is https, and this perl can't make https requests. }
        . q{Install IO::Socket::SSL and Net::SSLeay (cpanm IO::Socket::SSL Net::SSLeay) to send.};
    if ($config->{logger}) {
        $config->log($message);
    } else {
        warn "$message\n";
    }
    return;
}

# report($error, \%context, \%user): report an exception you've already caught, e.g.:
#
#   eval { risky_operation() };
#   if ($@) {
#       ForgeOps::Tracker::report($@, { order_id => $order->id });
#   }
#
# \%user defaults to whatever set_user() last set (undef if nothing did); pass one explicitly to
# override that for this one report.
#
# During a request (between start_trace and finish_trace), the event also carries the request's
# trace_id, transaction_name and endpoint, and the request is marked errored so its trace is sent
# however fast it was. An error one of the integrations saw escape a request falls back to what
# snapshot_onto remembered for it (along with the user and breadcrumb trail), for when it's
# reported only after the request's own state is gone.
sub report {
    my ($error, $context, $user) = @_;
    my $snapshot = $current_request ? undef : _snapshot_for($error);
    $current_request->{errored} = 1 if $current_request;

    my $source = $current_request || $snapshot || {};
    $user = $current_user unless defined $user;
    $user = $snapshot->{user} if !defined $user && $snapshot;
    my @breadcrumbs = @current_breadcrumbs;
    @breadcrumbs = @{ $snapshot->{breadcrumbs} } if !@breadcrumbs && $snapshot;

    _reporter()->report($error, $context, $user, \@breadcrumbs, {
        map { $_ => $source->{$_} } qw(transaction_name endpoint trace_id)
    });
    return;
}

# current_trace_id(): the current request's W3C trace id (32 lowercase hex characters), or undef
# outside a request. Handy for your own logs: it's the id ForgeOps links errors across services
# with.
sub current_trace_id {
    return $current_request ? $current_request->{trace_id} : undef;
}

# set_request_route($transaction_name, $endpoint): names the current request once its route is
# known. $transaction_name is the same name its performance sample and root span use, $endpoint
# the HTTP method plus the route pattern ("GET /users/:id"), never the literal path. The Dancer2
# performance plugin calls this as soon as Dancer2 has matched the route, so an error reported
# from inside the route already carries both; plain PSGI has no route pattern of its own, so a
# PSGI app that has one (from its own router) can call this itself. Does nothing outside a request.
sub set_request_route {
    my ($transaction_name, $endpoint) = @_;
    return unless $current_request;
    $current_request->{transaction_name} = $transaction_name;
    $current_request->{endpoint} = $endpoint;
    return;
}

# snapshot_onto($error): remembers the current request's trace id, transaction name and endpoint,
# plus the affected user and breadcrumb trail, for $error, and marks the request errored. Called by
# the PSGI/Dancer2 performance integrations when an error escapes a request, just before they
# finish its trace, so a report made afterward (see report) still has all of it. The first snapshot
# for the same error wins: the innermost one saw the request closest to where it failed. Never
# dies. Not something app code normally calls directly.
sub snapshot_onto {
    my ($error) = @_;
    eval {
        return unless $current_request && defined $error;
        $current_request->{errored} = 1;
        return if _snapshot_for($error);

        my $entry = {
            (ref $error ? (address => Scalar::Util::refaddr($error), error => $error) : (text => "$error")),
            user        => $current_user,
            breadcrumbs => [ map { { %$_ } } @current_breadcrumbs ],
            map { $_ => $current_request->{$_} } qw(transaction_name endpoint trace_id),
        };
        Scalar::Util::weaken($entry->{error}) if ref $error;
        unshift @escaped, $entry;
        splice @escaped, $MAX_ESCAPED if @escaped > $MAX_ESCAPED;
        1;
    };
    return;
}

sub _snapshot_for {
    my ($error) = @_;
    return undef unless defined $error;
    for my $entry (@escaped) {
        if (ref $error) {
            return $entry if defined $entry->{error} && $entry->{address} == Scalar::Util::refaddr($error);
        } elsif (defined $entry->{text} && $entry->{text} eq $error) {
            return $entry;
        }
    }
    return undef;
}

# set_user(%user): manually attaches an affected user to whatever gets reported for the rest of
# this process (or, under a threaded/event-loop PSGI server, `local`-ize $current_user directly
# instead: see that variable's own comment). id/email/username are all independently optional;
# call with no arguments to clear whatever was set, e.g.:
#
#   ForgeOps::Tracker::set_user(id => $user->id, email => $user->email);
#   ForgeOps::Tracker::set_user(); # clear it
sub set_user {
    my (%user) = @_;
    my %defined = map { $_ => $user{$_} } grep { defined $user{$_} } keys %user;
    $current_user = %defined ? \%defined : undef;
    return;
}

# add_breadcrumb($message, %options): records one entry in a small, bounded trail of recent
# events, attached to whatever report() sends next so an issue's detail page can show what led up
# to it. Options: category (default 'custom'), level (default 'info'), data (a hashref of extra
# detail, default {}). Only the max_breadcrumbs most recent are kept; does nothing when
# track_breadcrumbs is off, e.g.:
#
#   ForgeOps::Tracker::add_breadcrumb('charging card', category => 'payment', data => { order_id => 42 });
sub add_breadcrumb {
    my ($message, %options) = @_;
    my $config = _configuration();
    return unless $config->{track_breadcrumbs};

    push @current_breadcrumbs, {
        category  => defined $options{category} ? $options{category} : 'custom',
        message   => $message,
        level     => defined $options{level} ? $options{level} : 'info',
        timestamp => strftime('%Y-%m-%dT%H:%M:%SZ', gmtime),
        data      => defined $options{data} ? $options{data} : {},
    };

    my $max = $config->{max_breadcrumbs};
    shift @current_breadcrumbs while @current_breadcrumbs > $max;
    return;
}