sub\s results from the CPAN

AWS-XRay

view release on metacpan or search on metacpan

# NAME

AWS::XRay - AWS X-Ray tracing library

# SYNOPSIS

    use AWS::XRay qw/ capture /;

    capture "myApp", sub {
        capture "remote", sub {
            # do something ...
            capture "nested", sub {
                # ...
            };
        };
        capture "myHTTP", sub {
            my $segment = shift;
            # ...
            $segment->{http} = { # modify segment document
                request => {
                    method => "GET",
                    url    => "http://localhost/",
                },
                response => {
                    status => 200,
                },
            };
        };
    };

    my $header;
    capture "source", sub {
        my $segment = shift;
        $header = $segment->trace_header;
    };
    capture_from $header, "dest", sub {
        my $segment = shift;  # is a child of "source" segment
        # ...
    };

# DESCRIPTION

AWS::XRay is a tracing library with AWS X-Ray.

AWS::XRay sends segment data to [AWS X-Ray Daemon](https://docs.aws.amazon.com/xray/latest/devguide/xray-daemon.html).

cpanfile view on Meta::CPAN

requires 'perl', '5.016000';

on 'test' => sub {
    requires 'Test::More', '0.98';
    requires 'IO::Scalar';
    requires 'Test::TCP';
    requires 'HTTP::Server::PSGI';
};

requires 'JSON::XS';
requires 'Types::Serialiser';
requires 'IO::Socket::INET';
requires 'Crypt::URandom';

lib/AWS/XRay.pm view on Meta::CPAN

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

our $VERSION = "0.12";

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;

our $CROAK_INVALID_NAME = 0;
my $VALID_NAME_REGEXP = qr/\A[\p{L}\p{N}\p{Z}_.:\/%&#=+\\\-@]{1,200}\z/;

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));
}

sub is_valid_name {
    $_[0] =~ $VALID_NAME_REGEXP;
}

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

sub capture {
    my ($name, $code) = @_;
    if (!is_valid_name($name)) {
        my $msg = "invalid segment name: $name";
        $CROAK_INVALID_NAME ? croak($msg) : carp($msg);
    }
    my $wantarray = wantarray;

    my $enabled;
    my $sampled = $SAMPLED;
    if (defined $ENABLED) {

lib/AWS/XRay/Plugin/EC2.pm view on Meta::CPAN

package AWS::XRay::Plugin::EC2;
use strict;
use warnings;

use HTTP::Tiny;

# for test
our $_base_url = "http://169.254.169.254/latest";

sub ID_ADDR() {
    return "$_base_url/meta-data/instance-id";
}

sub AZ_ADDR() {
    return "$_base_url/meta-data/placement/availability-zone";
}

our $METADATA;

sub apply_plugin {
    my ($class, $segment) = @_;

    $METADATA ||= do {
        my $ua = HTTP::Tiny->new(timeout => 1);

        # get token for IMDSv2
        my $token = do {
            my $res = $ua->request(
                "PUT",
                "$_base_url/api/token", {

lib/AWS/XRay/Segment.pm view on Meta::CPAN

use 5.012000;
use strict;
use warnings;

use JSON::XS    ();
use Time::HiRes ();

my $header = qq|{"format":"json","version":1}\n|;
my $json   = JSON::XS->new->utf8;

sub new {
    my $class = shift;
    my $src   = shift;

    return bless {}, "${class}::NoTrace" if !$AWS::XRay::ENABLED;

    my $segment = {
        id         => AWS::XRay::new_id(),
        start_time => Time::HiRes::time(),
        trace_id   => $AWS::XRay::TRACE_ID,
        %$src,
    };
    if (my $parent_id = $AWS::XRay::SEGMENT_ID) {
        # This is a sub segment.
        $segment->{parent_id} = $parent_id;
        $segment->{type}      = "subsegment";
        $segment->{namespace} = "remote";
    }
    bless $segment, $class;
}

# alias for backward compatibility
*send = \&close;

sub close {
    my $self = shift;
    $self->{end_time} //= Time::HiRes::time();
    my $sock = AWS::XRay::sock() or return;
    $sock->print($header, $json->encode({%$self}));
}

sub trace_header {
    my $self = shift;
    my $h    = sprintf("Root=%s;Parent=%s", $self->{trace_id}, $self->{id});
    if (defined $AWS::XRay::SAMPLED) {
        $h .= ";Sampled=$AWS::XRay::SAMPLED";
    }
    return $h;
}

package AWS::XRay::Segment::NoTrace;

sub new {
    my $class = shift;
    bless {}, $class;
}

sub close {
    # do not anything
}

sub trace_header {
    "";
}

1;

t/01_trace.t view on Meta::CPAN

use strict;
use warnings;
use FindBin;
use lib "$FindBin::Bin/../";

use AWS::XRay qw/ capture /;
use Test::More;
use Time::HiRes qw/ sleep /;
use t::Util qw/ reset segments /;

capture "myApp", sub {
    my $seg = shift;
    sleep 0.1;
    capture "remote1", sub { sleep 0.1 };
    capture "remote2", sub {
        sleep 0.1;
        capture "remote3", sub { sleep 0.1 };
    };
    $seg->{annotations}->{foo} = "bar";
};

my @seg = segments();
ok @seg == 4;

my $root = pop @seg;
is $root->{name}, "myApp";
like $root->{trace_id} => qr/\A1-[0-9a-fA-F]{8}-[0-9a-fA-F]{24}\z/, "trace_id format";

t/02_from.t view on Meta::CPAN

use strict;
use warnings;
use FindBin;
use lib "$FindBin::Bin/../";

use AWS::XRay qw/ capture capture_from /;
use Test::More;
use t::Util qw/ reset segments /;

my $header = capture "from", sub {
    my $segment = shift;
    return $segment->trace_header;
};
diag $header;

capture_from $header, "to", sub {
};

my @seg = segments();
ok @seg == 2;

my $from = shift @seg;
is $from->{name}, "from";

my $to = shift @seg;
is $to->{name}      => "to";

t/03_miss_from.t view on Meta::CPAN

use strict;
use warnings;
use FindBin;
use lib "$FindBin::Bin/../";

use AWS::XRay qw/ capture capture_from /;
use Test::More;
use t::Util qw/ reset segments /;

my $header;
capture_from $header, "first", sub {
};

my @seg = segments;
ok @seg == 1;

my $root = shift @seg;
is $root->{name}, "first";
like $root->{trace_id} => qr/\A1-[0-9a-fA-F]{8}-[0-9a-fA-F]{24}\z/, "trace_id format";
like $root->{id}       => qr/\A[0-9a-fA-F]{16}\z/;
is $root->{type}, undef;

t/04_sampling.t view on Meta::CPAN

use warnings;
use FindBin;
use lib "$FindBin::Bin/../";

use AWS::XRay qw/ capture capture_from /;
use Test::More;
use t::Util qw/ reset segments /;

srand(1); # fix seed

subtest "disable", sub {
    reset();
    AWS::XRay->sampling_rate(0);
    capture "root", sub {
        capture "sub $_", sub { }
            for (1 .. 100);
    };
    my @seg = segments();
    ok scalar(@seg) == 0;
};

subtest "enable", sub {
    reset();
    AWS::XRay->sampling_rate(1);
    capture "root", sub {
        capture "sub $_", sub { }
            for (1 .. 100);
    };
    my @seg = segments();
    ok scalar(@seg) == 101;
};

subtest "50%", sub {
    reset();
    AWS::XRay->sampling_rate(0.5);
    for (1 .. 1000) {
        capture "root $_", sub { };
    }
    my @seg = segments();
    ok scalar(@seg) > 400;
    ok scalar(@seg) <= 600;
};

subtest "50% sub", sub {
    for (1 .. 10) {
        reset();
        AWS::XRay->sampling_rate(0.5);
        capture "root", sub {
            capture "sub $_", sub { }
                for (1 .. 100);
        };
        my @seg = segments();
        ok scalar(@seg) == 101 || scalar(@seg) == 0;
        diag @seg if @seg < 100 && @seg > 1;
    }
};

done_testing;

t/05_sampled_header.t view on Meta::CPAN

use Test::More;
use t::Util qw/ reset segments /;

AWS::XRay->sampling_rate(0);

my $trace_id   = AWS::XRay::new_trace_id;
my $segment_id = AWS::XRay::new_id;

my $header1 = "Root=$trace_id;Parent=$segment_id;Sampled=1";
diag $header1;
my $header2 = capture_from $header1, "from", sub {
    my $segment = shift;
    return $segment->trace_header;
};
diag $header2;
capture_from $header2, "to", sub {
    capture "sub", sub { };
};

my @seg = segments();
ok @seg == 3;

my $from = shift @seg;
is $from->{name}, "from";

my $to = pop @seg;
is $to->{name}      => "to";
is $to->{parent_id} => $from->{id};
is $to->{trace_id}  => $from->{trace_id};
is $to->{type}      => "subsegment";

my $sub = pop @seg;
is $sub->{name}      => "sub";
is $sub->{parent_id} => $to->{id};
is $sub->{trace_id}  => $from->{trace_id};
is $sub->{type}      => "subsegment";

done_testing;

t/06_sampler.t view on Meta::CPAN

use 5.12.0;
use strict;
use warnings;
use FindBin;
use lib "$FindBin::Bin/../";

use AWS::XRay qw/ capture capture_from /;
use Test::More;
use t::Util qw/ reset segments /;

subtest "disable", sub {
    reset();
    AWS::XRay->sampler(sub { 0 });
    capture "root", sub {
        capture "sub $_", sub { }
            for (1 .. 100);
    };
    my @seg = segments();
    ok scalar(@seg) == 0;
};

subtest "enable", sub {
    reset();
    AWS::XRay->sampler(sub { 1 });
    capture "root", sub {
        capture "sub $_", sub { }
            for (1 .. 100);
    };
    my @seg = segments();
    ok scalar(@seg) == 101;
};

subtest "odd", sub {
    reset();
    AWS::XRay->sampler(sub { state $count = 0; $count++ % 2 == 0 });
    for (1 .. 1000) {
        capture "root $_", sub { };
    }
    my @seg = segments();
    ok scalar(@seg) == 500;
};

subtest "odd_from", sub {
    reset();
    AWS::XRay->sampler(sub { state $count = 0; $count++ % 2 == 0 });
    for (1 .. 1000) {
        capture_from "", "root $_", sub { };
    }
    my @seg = segments();
    ok scalar(@seg) == 500;
};

done_testing;

t/07_buffer.t view on Meta::CPAN

use strict;
use warnings;
use FindBin;
use lib "$FindBin::Bin/../";

use AWS::XRay::Buffer;
use Test::More;
use IO::Scalar;

subtest "auto_flush=1", sub {
    my $buf;
    my $b = AWS::XRay::Buffer->new(IO::Scalar->new(\$buf), 1);
    $b->print("foo");
    $b->print("bar", "baz");
    is $buf => "foobarbaz";

    $b->print("XXX");
    is $buf => "foobarbazXXX";

    $b->print("YYY");
    $b->close;
    is $buf => "foobarbazXXXYYY";

    $b->print("ZZZ");
    is $buf => "foobarbazXXXYYYZZZ";
};

subtest "auto_flush=0", sub {
    my $buf;
    my $b = AWS::XRay::Buffer->new(IO::Scalar->new(\$buf), 0);
    $b->print("foo");
    $b->print("bar", "baz");
    is $buf => undef;

    $b->flush;
    is $buf => "foobarbaz";

    $b->print("XXX");

t/08_add.t view on Meta::CPAN

use strict;
use warnings;
use FindBin;
use lib "$FindBin::Bin/../";

use AWS::XRay qw/ capture /;
use Test::More;
use Time::HiRes qw/ sleep /;
use t::Util qw/ reset segments /;

sub myApp {
    sleep 0.1;
    capture "remote1", sub { sleep 0.1 };
    capture "remote2", sub {
        sleep 0.1;
        capture "remote3", sub { sleep 0.1 };
    };
}

AWS::XRay->add_capture("main", "myApp");

myApp();

my @seg = segments();
ok @seg == 4;

t/09_wantarray.t view on Meta::CPAN

use strict;
use warnings;
use FindBin;

use Test::More;
use AWS::XRay qw/ capture /;

capture "myApp", sub {
    ok !defined(wantarray), 'void context';
};

my $ret = capture "myApp", sub {
    ok defined(wantarray) && !wantarray, 'scalar context';
};

my @ret = capture "myApp", sub {
    ok defined(wantarray) && wantarray, 'list context';
};

done_testing;

t/10_plugin_ec2_v1.t view on Meta::CPAN


use Test::TCP;
use HTTP::Server::PSGI;
use AWS::XRay qw/ capture /;
use Test::More;
use t::Util qw/ reset segments /;

# mock server of IMDSv1
my $app_server = Test::TCP->new(
    listen => 1,
    code   => sub {
        my $sock   = shift;
        my $server = HTTP::Server::PSGI->new(
            listen_sock => $sock,
        );
        $server->run(
            sub {
                my $env = shift;
                if ($env->{REQUEST_METHOD} ne 'GET') {
                    return [405, [], ['Method Not Allowed']];
                }
                my $path = $env->{PATH_INFO};
                if ($path eq '/meta-data/instance-id') {
                    return [200, [], ['i-1234567890abcdef0']];
                }
                if ($path eq '/meta-data/placement/availability-zone') {
                    return [200, [], ['ap-northeast-1a']];
                }
                return [404, [], ['Not Found']];
            }
        );
    },
    max_wait => 10, # seconds
);
use AWS::XRay::Plugin::EC2;
$AWS::XRay::Plugin::EC2::_base_url = "http://127.0.0.1:" . $app_server->port;

sub myApp {
    capture "remote1", sub { };
}

AWS::XRay->plugins('AWS::XRay::Plugin::EC2');
AWS::XRay->add_capture("main", "myApp");

myApp();

my @seg = segments();

my $root = pop @seg;

t/10_plugin_ec2_v2.t view on Meta::CPAN

use Test::TCP;
use HTTP::Server::PSGI;
use AWS::XRay qw/ capture /;
use Test::More;
use t::Util qw/ reset segments /;

# mock server of IMDSv2
my $token      = "very-secret";
my $app_server = Test::TCP->new(
    listen => 1,
    code   => sub {
        my $sock   = shift;
        my $server = HTTP::Server::PSGI->new(
            listen_sock => $sock,
        );
        $server->run(
            sub {
                my $env    = shift;
                my $method = $env->{REQUEST_METHOD};
                my $path   = $env->{PATH_INFO};
                if ($method eq 'PUT') {
                    if (!$env->{HTTP_X_AWS_EC2_METADATA_TOKEN_TTL_SECONDS}) {
                        return [400, [], ['Bad Request']];
                    }
                    if ($path ne '/api/token') {
                        return [404, [], ['Not Found']];
                    }

t/12_croak_capture.t view on Meta::CPAN

use strict;
use warnings;
use FindBin;
use lib "$FindBin::Bin/../";
use Test::More;
use AWS::XRay qw/ capture /;

subtest "carp", sub {
    local $AWS::XRay::CROAK_INVALID_NAME = 0;
    my $res = capture "my * App", sub {
        "result";
    };
    is $res, "result";
};

subtest "croak", sub {
    local $AWS::XRay::CROAK_INVALID_NAME = 1;
    eval {
        capture "my * App", sub {
            "result";
        };
    };
    diag $@;
    ok $@ =~ /invalid/;
};

done_testing;

t/13_json_encoding.t view on Meta::CPAN

use warnings;
use FindBin;
use lib "$FindBin::Bin/../";

use AWS::XRay ();
use Test::More;
use Encode qw/decode_utf8/;

local $AWS::XRay::ENABLED = 1;

subtest "utf8" => sub {
    my $segment = AWS::XRay::Segment->new({ name => decode_utf8("ã‚") });
    ok $segment->close;
};

done_testing;

t/Util.pm view on Meta::CPAN

use warnings;

use IO::Scalar;
use JSON::XS;
use Exporter 'import';
our @EXPORT_OK = qw/ reset segments /;

my $buf;
no warnings 'redefine';

*AWS::XRay::sock = sub {
    IO::Scalar->new(\$buf);
};
1;

sub reset {
    undef $buf;
}

sub segments {
    return unless $buf;
    $buf =~ s/{"format":"json","version":1}//g;
    my @seg = split /\n/, $buf;
    shift @seg; # despose first ""
    return map { decode_json($_) } @seg;
}

xt/01_overhead.t view on Meta::CPAN

use warnings;

use FindBin;
use lib "$FindBin::Bin/../";

use AWS::XRay qw/ capture capture_from /;
use Test::More;
use Benchmark qw/ timeit timestr /;

my $sampler = {
    none         => sub { 0 },
    "50_percent" => sub { rand() < 0.5 },
    "1_percent"  => sub { rand() < 0.01 },
    all          => sub { 1 },
};

for my $auto_flush ( 0, 1 ) {
    AWS::XRay->auto_flush($auto_flush);
    for my $name (sort keys %$sampler) {
        AWS::XRay->sampler($sampler->{$name});
        my $t = timeit(
            1000,
            sub {
                capture "root", sub {
                    for ( 1 .. 49 ) {
                        capture "sub $_", sub {
                            capture "subsub $_", sub {};
                        };
                    }
                };
                AWS::XRay->sock->flush;
            });
        diag sprintf("auto_flush:%d sampler %s: %d loops of 100 captured code took: %s", $auto_flush, $name, $t->iters, timestr($t));
    }
}

ok 1;

view all matches for this distribution
view release on metacpan - search on metacpan

( run in 1.364 second using v1.00-cache-2.02-grep-82fe00e-cpan-2c419f77a38b )