File Coverage

blib/lib/AWS/XRay.pm

Criterion	Covered	Total	%
statement	115	127	90.5
branch	31	48	64.5
condition	11	19	57.8
subroutine	27	28	96.4
pod	8	11	72.7
total	192	233	82.4

package AWS::XRay;

use 5.012000;
use strict;
use warnings;

use Crypt::URandom ();
use IO::Socket::INET;
use Module::Load;
use Time::HiRes ();
use Types::Serialiser;
use AWS::XRay::Segment;
use AWS::XRay::Buffer;

use Exporter 'import';
our @EXPORT_OK = qw/ new_trace_id capture capture_from trace /;

our $VERSION = "0.10";

our $TRACE_ID;
our $SEGMENT_ID;
our $ENABLED;
our $SAMPLED;
our $SAMPLING_RATE = 1;
our $SAMPLER       = sub { rand() < $SAMPLING_RATE };
our $AUTO_FLUSH    = 1;

our @PLUGINS;

our $DAEMON_HOST = "127.0.0.1";
our $DAEMON_PORT = 2000;

if ($ENV{"AWS_XRAY_DAEMON_ADDRESS"}) {
    ($DAEMON_HOST, $DAEMON_PORT) = split /:/, $ENV{"AWS_XRAY_DAEMON_ADDRESS"};
}

my $Sock;

sub sampling_rate {
    my $class = shift;
    if (@_) {
        $SAMPLING_RATE = shift;
    }
    $SAMPLING_RATE;
}

sub sampler {
    my $class = shift;
    if (@_) {
        $SAMPLER = shift;
    }
    $SAMPLER;
}

sub plugins {
    my $class = shift;
    if (@_) {
        @PLUGINS = @_;
        Module::Load::load $_ for @PLUGINS;
    }
    @PLUGINS;
}

sub auto_flush {
    my $class = shift;
    if (@_) {
        my $auto_flush = shift;
        if ($auto_flush != $AUTO_FLUSH) {
            $Sock->close if $Sock && $Sock->can("close");
            undef $Sock; # regenerate
        }
        $AUTO_FLUSH = $auto_flush;
    }
    $AUTO_FLUSH;
}

sub sock {
    $Sock //= AWS::XRay::Buffer->new(
            IO::Socket::INET->new(
                PeerAddr => $DAEMON_HOST || "127.0.0.1",
                PeerPort => $DAEMON_PORT || 2000,
                Proto    => "udp",
            ),
            $AUTO_FLUSH,
        );
}

sub new_trace_id {
    sprintf(
        "1-%x-%s",
        CORE::time(),
        unpack("H*", Crypt::URandom::urandom(12)),
    );
}

sub new_id {
    unpack("H*", Crypt::URandom::urandom(8))
}

# alias for backward compatibility
*trace = \&capture;

sub capture {
    my ($name, $code) = @_;
    my $wantarray = wantarray;

    my $enabled;
    my $sampled = $SAMPLED;
    if (defined $ENABLED) {
        $enabled = $ENABLED ? 1 : 0; # fix true or false (not undef)
    } elsif ($TRACE_ID) {
        $enabled = 0; # called from parent capture
    } else {
        # root capture try sampling
        $sampled = $SAMPLER->() ? 1 : 0;
        $enabled = $sampled     ? 1 : 0;
    }
    local $ENABLED = $enabled;
    local $SAMPLED = $sampled;

    return $code->(AWS::XRay::Segment->new) if !$enabled;

    local $TRACE_ID = $TRACE_ID // new_trace_id();

    my $segment = AWS::XRay::Segment->new({ name => $name });
    unless (defined $segment->{type} && $segment->{type} eq "subsegment") {
        $_->apply_plugin($segment) for @PLUGINS;
    }

    local $SEGMENT_ID = $segment->{id};

    my @ret;
    eval {
        if ($wantarray) {
            @ret = $code->($segment);
        }
        elsif (defined $wantarray) {
            $ret[0] = $code->($segment);
        }
        else {
            $code->($segment);
        }
    };
    my $error = $@;
    if ($error) {
        $segment->{error} = Types::Serialiser::true;
        $segment->{cause} = {
            exceptions => [
                {
                    id      => new_id(),
                    message => "$error",
                    remote  => Types::Serialiser::true,
                },
            ],
        };
    }
    eval {
        $segment->close();
    };
    if ($@) {
        warn $@;
    }
    die $error if $error;
    return $wantarray ? @ret : $ret[0];
}

sub capture_from {
    my ($header, $name, $code) = @_;
    my ($trace_id, $segment_id, $sampled) = parse_trace_header($header);

    local $AWS::XRay::SAMPLED = $sampled // $SAMPLER->();
    local $AWS::XRay::ENABLED = $AWS::XRay::SAMPLED;
    local($AWS::XRay::TRACE_ID, $AWS::XRay::SEGMENT_ID) = ($trace_id, $segment_id);
    capture($name, $code);
}

sub parse_trace_header {
    my $header = shift or return;

    my ($trace_id, $segment_id, $sampled);
    if ($header =~ /Root=([0-9a-fA-F-]+)/) {
        $trace_id = $1;
    }
    if ($header =~ /Parent=([0-9a-fA-F]+)/) {
        $segment_id = $1;
    }
    if ($header =~ /Sampled=([^;]+)/) {
        $sampled = $1;
    }
    return ($trace_id, $segment_id, $sampled);
}

sub add_capture {
    my ($class, $package, @methods) = @_;
    no warnings 'redefine';
    no strict 'refs';
    for my $method (@methods) {
        my $orig = $package->can($method) or next;
        *{"${package}::${method}"} = sub {
            my @args = @_;
            capture(
                $package,
                sub {
                    my $segment = shift;
                    $segment->{metadata}->{method}  = $method;
                    $segment->{metadata}->{package} = $package;
                    $orig->(@args);
                },
            );
        };
    }
}

if ($ENV{LAMBDA_TASK_ROOT}) {
    # AWS::XRay is loaded in AWS Lambda worker.
    # notify the Lambda Runtime that initialization is complete.
    mkdir '/tmp/.aws-xray' or warn "failed to make directory: $!";
    open my $fh, '>', '/tmp/.aws-xray/initialized' or warn "failed to create file: $!";
    close $fh;
    utime undef, undef, '/tmp/.aws-xray/initialized' or warn "failed to touch file: $!";

    # patch the capture
    no warnings 'redefine';
    no strict 'refs';
    my $org = \&capture;
    *capture = sub {
        my ($trace_id, $segment_id, $sampled) = parse_trace_header($ENV{_X_AMZN_TRACE_ID});
        local $AWS::XRay::SAMPLED = $sampled // $SAMPLER->();
        local $AWS::XRay::ENABLED = $AWS::XRay::SAMPLED;
        local($AWS::XRay::TRACE_ID, $AWS::XRay::SEGMENT_ID) = ($trace_id, $segment_id);
        local *capture = $org;
        local *trace = $org;
        capture(@_);
    };
    *trace = \&capture;
}

1;
__END__