package CGI::Github::Webhook;

# ABSTRACT: Easily create CGI based GitHub webhooks

use strict;
use warnings;
use 5.010;

our $VERSION = '0.06'; # VERSION

use Moo;
use CGI;
use Data::Dumper;
use JSON;
use Try::Tiny;
use Digest::SHA qw(hmac_sha1_hex);
use File::ShareDir qw(module_dir);
use File::Copy;
use File::Basename;

#=head1 EXPORT
#A list of functions that can be exported.  You can delete this section
#if you don't export anything, such as for a purely object-oriented module.

has badges_from => (
    is => 'rw',
    default => sub { module_dir(__PACKAGE__); },
    isa => sub {
        die "$_[0] needs to be an existing directory"
            unless -d $_[0];
    lazy => 1,

has badge_to => (
    is => 'rw',
    default => sub { return },
    isa => sub {
        die "$_[0] needs have a file suffix"
            if (defined($_[0]) and $_[0] !~ /\./);

has cgi => (
    is => 'ro',
    default => sub { CGI->new() },

has log => (
    is => 'ro',
    default => sub { '/dev/stderr' },
    isa => sub {
        my $dir = dirname($_[0]);
        die "$dir doesn't exist!" unless -d $dir;

has mime_type => (
    is => 'ro',
    default => sub { 'text/plain; charset=utf-8' },

has secret => (
    is => 'ro',
    required => 1,

has text_on_success => (
    is => 'rw',
    default => sub { 'Successfully triggered' },

has text_on_auth_fail => (
    is => 'rw',
    default => sub { 'Authentication failed' },

has text_on_trigger_fail => (
    is => 'rw',
    default => sub { 'Trigger failed' },

has trigger => (
    is => 'rw',
    required => 1,

has trigger_backgrounded => (
    is => 'rw',
    default => 1,

has authenticated => (
    is => 'lazy',

sub _build_authenticated {
    my $self = shift;

    my $logfile = $self->log;
    my $q       = $self->cgi;
    my $secret  = $self->secret;

    open(my $logfh, '>>', $logfile);
    say $logfh "Date: ".localtime;
    say $logfh "Remote IP: ".$q->remote_host()." (".$q->remote_addr().")";

    my $x_hub_signature =
        $q->http('X-Hub-Signature') || '<no-x-hub-signature>';
    my $calculated_signature = 'sha1='.
        hmac_sha1_hex($self->payload // '', $secret);

    print $logfh Dumper($self->payload_perl,
                        $x_hub_signature, $calculated_signature);
    close $logfh;

    return $x_hub_signature eq $calculated_signature;

has payload => (
    is => 'lazy',

sub _build_payload {
    my $self = shift;
    my $q    = $self->cgi;

    if ($q->param('POSTDATA')) {
        return ''.$q->param('POSTDATA');
    } else {

has payload_json => (
    is => 'lazy',

sub _build_payload_json {
    my $self = shift;
    my $q    = $self->cgi;

    my $payload = qq({"payload":"none"});
    if ($self->payload) {
        $payload = $self->payload;
        try {
        } catch {
            s/\"/\'/g; s/\n/ /gs;
            $payload = qq({"error":"$_"});

    return $payload;

has payload_perl => (
    is => 'lazy',

sub _build_payload_perl {
    my $self = shift;

    return decode_json($self->payload_json);

sub deploy_badge {
    my $self = shift;
    return unless $self->badge_to;

    my $basename = shift;
    die "No basename provided" unless defined($basename);

    my $suffix = $self->badge_to;
    $suffix =~ s/^.*(\.[^.]*?)$/$1/;
    my $badge = $self->badges_from.'/'.$basename.$suffix;

    my $logfile = $self->log;
    open(my $logfh, '>>', $logfile);

    my $file_copied = copy($badge, $self->badge_to);
    if ($file_copied) {
        say $logfh "$badge successfully copied to ".$self->badge_to;
        return 1;
    } else {
        say $logfh "Couldn't copy $badge  to ".$self->badge_to.": $!";

sub header {
    my $self = shift;
    if (@_) {
        return $self->cgi->header(@_);
    } else {
        return $self->cgi->header($self->mime_type);

sub send_header {
    my $self = shift;

    print $self->header(@_);

sub run {
    local $| = 1;
    my $self = shift;


    my $logfile = $self->log;
    open(my $logfh, '>>', $logfile);

    if ($self->authenticated) {
        my $trigger = $self->trigger.' >> '.$logfile.' 2>&1 '.
            ($self->trigger_backgrounded ? '&' : '');
        my $rc = system($trigger);
        if ($rc != 0) {
            say $logfh $trigger;
            say $self->text_on_trigger_fail;
            say $logfh $self->text_on_trigger_fail;
            if ($? == -1) {
                say $logfh "Trigger failed to execute: $!";
            } elsif ($? & 127) {
                printf $logfh "child died with signal %d, %s coredump\n",
                ($? & 127),  ($? & 128) ? 'with' : 'without';
            } else {
                printf $logfh "child exited with value %d\n", $? >> 8;
            close $logfh;
            return 0;
        } else {
            say $self->text_on_success;
            say $logfh $self->text_on_success;

            close $logfh;
            return 1;
    } else {
        say $self->text_on_auth_fail;
        say $logfh $self->text_on_auth_fail;
        close $logfh;
        return; # undef or empty list, i.e. false

1; # End of CGI::Github::Webhook



=encoding UTF-8

=head1 NAME

CGI::Github::Webhook - Easily create CGI based GitHub webhooks

=head1 VERSION

version 0.06


CGI::Github::Webhook allows one to easily create simple, CGI-based
GitHub webhooks.


    use CGI::Github::Webhook;

    my $ghwh = CGI::Github::Webhook->new(
        mime_type => 'text/plain',
        trigger => '/srv/some-github-project/bin/',
        trigger_backgrounded => 1,
        secret => 'use a generated password here, nothing valuable',
        log => '/srv/some-github-project/log/trigger.log',


=head2 new

Constructor. Takes a configuration hash (or array) as parameters.

=head3 List of parameters for new() constructor.

They can be used as (Moo-style) accessors on the CGI::Github::Webhook
object, too.

=head4 badges_from

Path where to look for badge files. Defaults to File::ShareDir's

=head4 badge_to

Local path to file to which L<> style badges should
be written. Defaults to undef which means the feature is disabled.

Needs to have a suffix. That suffix will then be used to look for a
file in the right format.

Currently only ".svg" and ".png" suffixes/formats are supported if no
custom badge set is used.

=head4 cgi

The object internally used.

=head4 log

Where to send the trigger's output to. Defaults to '/dev/stderr',
i.e. goes to the web server's error log. Use '/dev/null' to disable.

For now it needs to be a path on the file system. Passing file handles
objects doesn't work (yet).

=head4 mime_type

The mime-type used to return the contents. Defaults to 'text/plain;
charset=utf-8' for now.

=head4 secret

The shared secret you entered on GitHub as secret for this
trigger. Currently required. I recommend to use the output of
L<makepasswd(1)>, L<apg(1)>, L<pwgen(1)> or using
L<Crypt::GeneratePassword> to generate a randon and secure shared

=head4 text_on_success

Text to be returned to GitHub as body if the trigger was successfully
(or at least has been spawned successfully). Defaults to "Successfully

=head4 text_on_auth_fail

Text to be returned to GitHub as body if the authentication
failed. Defaults to "Authentication failed".

=head4 text_on_trigger_fail

Text to be returned to GitHub as body if spawning the trigger
failed. Defaults to "Trigger failed".

=head4 trigger

The script or command which should be called when the webhook is
called. Required.

=head4 trigger_backgrounded

Boolean attribute controlling if the script or command passed as
trigger needs to be started backgrounded (i.e. if it takes longer than
a few seconds) or not. Defaults to 1 (i.e. that the trigger script is


=head4 authenticated

Returns true if the authentication could be
verified and false else. Read-only attribute.

=head4 payload

The payload as passed as payload in the POST request

=head4 payload_json

The payload as passed as payload in the POST request if it is valid
JSON, else an error message in JSON format.

=head4 payload_perl

The payload as perl data structure (hashref) as decoded by
decode_json. If the payload was no valid JSON, it returns a hashref
containing either { payload => 'none' } if there was no payload, or {
error => ... } in case of a decode_json error had been caught.


=head2 deploy_badge

Copies file given as parameter to path given via badge_to
attribute. The parameter needs to be given without file suffix. The
file suffix from the badges attribute will be appended.

Doesn't do anything if badge_to is not set.

=head2 header

Passes arguments to and return value from $self->cgi->header(), i.e. a
shortcut for $self->cgi->header().

If no parameters are passed, $self->mime_type is passed.

=head2 send_header

Passes arguments to $self->header and prints result to STDOUT.

=head2 run

Start the authentication verification and run the trigger if the
authentication succeeds.

Returns true on success, false on error. More precisely it returns a
defined false on error launching the trigger and undef on
authentication error.

=head1 AUTHOR

Axel Beckert, C<< <> >>

=head1 BUGS

Please report any bugs, either via via GitHub Issues at
L<> or via the CPAN
Request Tracker by sending an e-mail to
C<> or submitting a bug report
through the CPAN Request Tracker web interface at

=head1 SUPPORT

You can find documentation for this module with the perldoc command.

    perldoc CGI::Github::Webhook

You can also look for information at:

=over 4

=item * RT: CPAN's request tracker (report bugs here)


=item * AnnoCPAN: Annotated CPAN documentation


=item * CPAN Ratings


=item * Search CPAN




Copyright 2016 Axel Beckert.

This program is free software; you can redistribute it and/or modify it
under the terms of either: the GNU General Public License as published
by the Free Software Foundation; or the Artistic License.

See L<> for more information.

=head1 AUTHOR

Axel Beckert <>


This software is copyright (c) 2016 by Axel Beckert.

This is free software; you can redistribute it and/or modify it under
the same terms as the Perl 5 programming language system itself.