File Coverage

blib/lib/PagerDuty/Agent.pm

Criterion	Covered	Total	%
statement	73	86	84.8
branch	18	28	64.2
condition	8	11	72.7
subroutine	20	21	95.2
pod	3	3	100.0
total	122	149	81.8

package PagerDuty::Agent;

use 5.008;
use strict;
use warnings;
use Moo;
use MooX::Types::MooseLike::Base qw/ ArrayRef Int Str /;

our $VERSION = '0.01';

use English '-no_match_vars';
use HTTP::Request::Common 'POST';
use JSON;
use LWP::UserAgent;
use Sys::Hostname;
use Time::Piece;

=head1 NAME

PagerDuty::Agent - A perl PagerDuty client

=head1 VERSION

Version 0.01

=head1 SYNOPSIS

  use PagerDuty::Agent;

  my $agent = PagerDuty::Agent->new( routing_key => '3fcc9112463424b599f996f9e780dfc6' );

  # trigger an event, then resolve it
  my $dedup_key = $agent->trigger_event( 'something is terribly wrong!' );

  if ( $dedup_key ) {
    print "Event created, dedup_key = $dedup_key\n";

    print "Event successfully resolved\n"
      if $agent->resolve_event( $dedup_key );
  }

  # additional context can be passed in
  $agent->trigger_event(
    summary   => 'something is terribly wrong!',
    severity  => 'critical',
    dedup_key => 'abc123',
  );

=head1 DESCRIPTION

This module implements the Events API for submitting events to PagerDuty.

=head1 CONSTRUCTOR

=head2 my $agent = PagerDuty::Agent->new( %options )

=over

=item C<< routing_key => '3fcc9112463424b599f996f9e780dfc6' >>

The routing key or integration key associated with the API integration, found when
viewing the service integration on the PagerDuty site.

=item C<< timeout => 5 >>

Do not wait longer than this number of seconds when attempting to send an event.

=item C<< api_version => 2 >>

Only version 2 is supported.

=back

=cut

has [qw/ post_url routing_key /] => (
    is       => 'ro',
    isa      => Str,
    required => 1,
);

has api_version => (
    is      => 'ro',
    isa     => Int,
    default => 2,
);

has timeout => (
    is      => 'ro',
    isa     => Int,
    default => 5,
);

has json_serializer => (
    is      => 'ro',
    builder => '_build_json_serializer',
    lazy    => 1,
);

has ua_obj => (
    is      => 'ro',
    builder => '_build_ua_obj',
    lazy    => 1,
);

has valid_severities => (
    is      => 'ro',
    isa     => ArrayRef[Str],
    default => sub { [qw/ critical error warning info /] },
);

around BUILDARGS => sub {
    my ($orig, $class, %args) = @_;

    my $routing_key = $args{routing_key}
        or die "must pass routing_key\n";

    delete($args{routing_key});

    my $timeout = delete($args{timeout});

    my $api_version = delete($args{api_version});
    $api_version = 2 unless defined($api_version);

    my $post_url = _post_url_for_version($api_version)
        or die "invalid api version $api_version\n";

    my $ua_obj = delete($args{ua_obj});

    return $class->$orig(
        routing_key => $routing_key,
        post_url => $post_url,

        (defined($api_version) ? (api_version => $api_version) : ()),
        (defined($timeout) ? (timeout => $timeout) : ()),
        (defined($ua_obj) ? (ua_obj => $ua_obj) : ()),
    );
};

=head1 EVENT API

These methods are designed to create and manipulate events.

=head2 my $dedup_key = $agent->trigger_event( $event_summary or %event )

Trigger an event.  The simple form accepts an $event_summary string with textual
details of the event.  The long form accepts additional event context.

When successful, returns the dedup_key.  On error, returns undef and sets $@.

Event parameters when using the long form:

=over

=item C<< summary => 'Server is on fire' >>

Required.  A textual description of the event.

=item C<< class => 'cpu load' >>

The type of event.

=item C<< component => 'mysql' >>

The mechanism responsible for the event.

=item C<< custom_details => { user => 'me' } >>

A hash-ref of key value pairs containing any additional details.

=item C<< dedup_key => 'my unique identifier' >>

This is used for threading like events as well as identifying events already triggered.
If this is not given, one will be generated by the upstream API.

=item C<< group => 'app-stack' >>

The grouping of components.

=item C<< images => [ { src => 'https://img.memecdn.com/silly-humans_o_842106.jpg' } ] >>

One or more images, each specified as a hash-ref containing:

=over

=item C<< src => 'image url' >>

Required.  Must be HTTPS.

=item C<< href => 'link url' >>

Make the image link click-able.

=item C<< alt => 'some alt text' >>

Add alt text to the image.

=back

=item C<< links => [ { text => 'see the docs', href => 'https://google.com' } ] >>

One or more links, each specified as a hash-ref containing:

=over

=item C<< href => 'https://google.com' >>

Required.  Link destination.

=item C<< text => 'click here' >>

Required.  Link text.

=back

=item C<< severity => 'error' >>

The severity of the event.  Can be one of critical, error, warning, or info.  Defaults to error.

=item C<< source => 'google.com' >>

The hostname from which this event was triggered.  Defaults to the current hostname.

=item C<< timestamp => '2017-07-12T12:50:22.000-0700' >>

The event timestamp.  This must be a valid ISO 8601 in the complete long form such as the
example.  This defaults to the current local time.


=back

=cut

sub trigger_event {
    my ($self, @params) = @_;

    @params = (summary => $params[0])
        if scalar(@params) == 1;

    return $self->_post_event(
        $self->_format_pd_cef('trigger', @params),
    );
}

=head2 my $success = $agent->acknowledge_event( $dedup_key or %event )

Acknowledge an existing event.  The simple form accepts a $dedup_key.  The long
form accepts the same event parameters as C<< trigger_event >> except C<< summary >>
is interpreted as the reason for acknowledging and C<< dedup_key >> is required.

When successful, returns the dedup_key.  On error, returns undef and sets $@.

=cut

sub acknowledge_event {
    my ($self, @params) = @_;

    @params = (summary => 'no reason given', dedup_key => $params[0])
        if scalar(@params) == 1;

    return $self->_post_event(
        $self->_format_pd_cef('acknowledge', @params),
    );
}

=head2 my $success = $agent->resolve_event( $dedup_key or %event )

This accepts the same parameters as C<< acknowledge_event >> and returns the
same values.

=cut

sub resolve_event {
    my ($self, @params) = @_;

    @params = (summary => 'no reason given', dedup_key => $params[0])
        if scalar(@params) == 1;

    return $self->_post_event(
        $self->_format_pd_cef('resolve', @params),
    );
}

sub _post_event {
    my ($self, $event) = @_;

    unless ($event) {
        $EVAL_ERROR = "unable to parse event parameters";
        warn "$EVAL_ERROR\n";
        return;
    }

    my ($response, $response_code, $response_content);

    eval {
        $self->ua_obj()->timeout($self->timeout());

        my $request = POST(
            $self->post_url(),
            'Content-Type'  => 'application/json',
            'Authorization' => 'Token token='.$self->routing_key(),
            Content         => $self->json_serializer()->encode($event),
        );
        $response = $self->ua_obj()->request($request);

        $response_code = $response->code();
        $response_content = $response->content();
    };

    warn "$EVAL_ERROR\n" if $EVAL_ERROR;

    if ($response && $response->is_success()) {
        return $self->json_serializer()->decode($response_content)->{dedup_key};
    } else {
        if ($response) {
            my $error_message;
            eval {
                $error_message = $self->json_serializer()->decode($response_content)->{error}->{message};
            };

            $error_message = "Unable to parse response from PagerDuty: $EVAL_ERROR"
                if $EVAL_ERROR;

            $EVAL_ERROR = $error_message;
        }

        return;
    }
}

sub _validate_severity {
    my ($self, $severity) = @_;

    return unless defined($severity);

    my %severity_hash = map { $_ => 1 } @{ $self->valid_severities() };

    if (exists($severity_hash{$severity})) {
        return $severity;
    } else {
        warn "unknown severity: $severity\n";
        return;
    }
};

sub _build_json_serializer { JSON->new()->utf8(1)->pretty(1)->allow_nonref(1) }

sub _build_ua_obj {
    return LWP::UserAgent->new(
        keep_alive => 1,
    );
}

sub _post_url_for_version {
    my ($version) = @_;
    return unless defined($version);
    return {
        2 => 'https://events.pagerduty.com/v2/enqueue',
    }->{$version};
}

sub _trim {
    my ($string, $length) = @_;
    return defined($string)
        ? substr($string, 0, $length)
        : undef;
}

sub _format_pd_cef {
    my ($self, $event_action, @params) = @_;

    my %params;

    if (scalar(@params) % 2 == 0) {
        %params = @params;
    } else {
        return;
    }

    $self->_validate_severity($params{severity})
        if defined($params{severity});

    return {
        routing_key  => $self->routing_key(),
        event_action => $event_action,
        dedup_key    => $params{dedup_key},

        images => $params{images},
        links  => $params{links},

        payload => {
            summary        => $params{summary},
            source         => $params{source}     || hostname(),
            severity       => $params{severity}   || 'error',
            timestamp      => $params{timestamp}  || localtime()->strftime('%FT%T.000%z'),
            component      => $params{component},
            group          => $params{group},
            class          => $params{class},
            custom_details => $params{custom_details},
        },
    };
}

=head1 See Also

L<https://v2.developer.pagerduty.com/docs/events-api-v2> - The PagerDuty Events V2 API documentation

L<WebService::PagerDuty> - Another module implementing most of the PagerDuty Events V1 API.

=head1 LICENSE

Copyright (C) 2017 by comScore, Inc

The full text of this license can be found in the LICENSE file included with this module.

=cut

1;