File Coverage

blib/lib/CGI/Github/Webhook.pm
Criterion Covered Total %
statement 81 116 69.8
branch 8 24 33.3
condition 4 4 100.0
subroutine 20 22 90.9
pod 4 4 100.0
total 117 170 68.8


line stmt bran cond sub pod time code
1             package CGI::Github::Webhook;
2              
3             # ABSTRACT: Easily create CGI based GitHub webhooks
4              
5 2     2   2570 use strict;
  2         2  
  2         44  
6 2     2   5 use warnings;
  2         2  
  2         34  
7 2     2   26 use 5.010;
  2         4  
8              
9             our $VERSION = '0.06'; # VERSION
10              
11 2     2   817 use Moo;
  2         17648  
  2         9  
12 2     2   3465 use CGI;
  2         39829  
  2         8  
13 2     2   1224 use Data::Dumper;
  2         9439  
  2         96  
14 2     2   10 use JSON;
  2         2  
  2         11  
15 2     2   1043 use Try::Tiny;
  2         1809  
  2         102  
16 2     2   8 use Digest::SHA qw(hmac_sha1_hex);
  2         2  
  2         70  
17 2     2   7 use File::ShareDir qw(module_dir);
  2         3  
  2         81  
18 2     2   6 use File::Copy;
  2         2  
  2         79  
19 2     2   8 use File::Basename;
  2         2  
  2         1945  
20              
21              
22             #=head1 EXPORT
23             #
24             #A list of functions that can be exported. You can delete this section
25             #if you don't export anything, such as for a purely object-oriented module.
26              
27              
28             has badges_from => (
29             is => 'rw',
30             default => sub { module_dir(__PACKAGE__); },
31             isa => sub {
32             die "$_[0] needs to be an existing directory"
33             unless -d $_[0];
34             },
35             lazy => 1,
36             );
37              
38              
39             has badge_to => (
40             is => 'rw',
41             default => sub { return },
42             isa => sub {
43             die "$_[0] needs have a file suffix"
44             if (defined($_[0]) and $_[0] !~ /\./);
45             },
46             );
47              
48              
49             has cgi => (
50             is => 'ro',
51             default => sub { CGI->new() },
52             );
53              
54              
55             has log => (
56             is => 'ro',
57             default => sub { '/dev/stderr' },
58             isa => sub {
59             my $dir = dirname($_[0]);
60             die "$dir doesn't exist!" unless -d $dir;
61             },
62             );
63              
64              
65             has mime_type => (
66             is => 'ro',
67             default => sub { 'text/plain; charset=utf-8' },
68             );
69              
70              
71             has secret => (
72             is => 'ro',
73             required => 1,
74             );
75              
76              
77             has text_on_success => (
78             is => 'rw',
79             default => sub { 'Successfully triggered' },
80             );
81              
82              
83             has text_on_auth_fail => (
84             is => 'rw',
85             default => sub { 'Authentication failed' },
86             );
87              
88              
89             has text_on_trigger_fail => (
90             is => 'rw',
91             default => sub { 'Trigger failed' },
92             );
93              
94              
95              
96             has trigger => (
97             is => 'rw',
98             required => 1,
99             );
100              
101              
102             has trigger_backgrounded => (
103             is => 'rw',
104             default => 1,
105             );
106              
107              
108             has authenticated => (
109             is => 'lazy',
110             );
111              
112             sub _build_authenticated {
113 4     4   1723 my $self = shift;
114              
115 4         9 my $logfile = $self->log;
116 4         6 my $q = $self->cgi;
117 4         7 my $secret = $self->secret;
118              
119 4         129 open(my $logfh, '>>', $logfile);
120 4         211 say $logfh "Date: ".localtime;
121 4         17 say $logfh "Remote IP: ".$q->remote_host()." (".$q->remote_addr().")";
122              
123 4   100     35 my $x_hub_signature =
124             $q->http('X-Hub-Signature') || '';
125 4   100     126 my $calculated_signature = 'sha1='.
126             hmac_sha1_hex($self->payload // '', $secret);
127              
128 4         68 print $logfh Dumper($self->payload_perl,
129             $x_hub_signature, $calculated_signature);
130 4         443 close $logfh;
131              
132 4         34 return $x_hub_signature eq $calculated_signature;
133             }
134              
135              
136             has payload => (
137             is => 'lazy',
138             );
139              
140             sub _build_payload {
141 4     4   1751 my $self = shift;
142 4         10 my $q = $self->cgi;
143              
144 4 100       8 if ($q->param('POSTDATA')) {
145 3         53 return ''.$q->param('POSTDATA');
146             } else {
147 1         27 return;
148             }
149             }
150              
151              
152             has payload_json => (
153             is => 'lazy',
154             );
155              
156             sub _build_payload_json {
157 4     4   1380 my $self = shift;
158 4         7 my $q = $self->cgi;
159              
160 4         6 my $payload = qq({"payload":"none"});
161 4 100       52 if ($self->payload) {
162 3         51 $payload = $self->payload;
163             try {
164 3     3   102 decode_json($payload);
165             } catch {
166 1     1   9 s/\"/\'/g; s/\n/ /gs;
  1         2  
167 1         3 $payload = qq({"error":"$_"});
168 3         32 };
169             }
170              
171 4         64 return $payload;
172             }
173              
174              
175             has payload_perl => (
176             is => 'lazy',
177             );
178              
179             sub _build_payload_perl {
180 4     4   583 my $self = shift;
181              
182 4         41 return decode_json($self->payload_json);
183             }
184              
185              
186             sub deploy_badge {
187 3     3 1 530 my $self = shift;
188 3 50       23 return unless $self->badge_to;
189              
190 3         766 my $basename = shift;
191 3 50       7 die "No basename provided" unless defined($basename);
192              
193 3         40 my $suffix = $self->badge_to;
194 3         18 $suffix =~ s/^.*(\.[^.]*?)$/$1/;
195 3         57 my $badge = $self->badges_from.'/'.$basename.$suffix;
196              
197 3         27 my $logfile = $self->log;
198 3         69 open(my $logfh, '>>', $logfile);
199              
200 3         49 my $file_copied = copy($badge, $self->badge_to);
201 3 50       647 if ($file_copied) {
202 3         63 say $logfh "$badge successfully copied to ".$self->badge_to;
203 3         78 return 1;
204             } else {
205 0         0 say $logfh "Couldn't copy $badge to ".$self->badge_to.": $!";
206 0         0 return;
207             }
208             }
209              
210              
211             sub header {
212 4     4 1 47 my $self = shift;
213 4 50       10 if (@_) {
214 0         0 return $self->cgi->header(@_);
215             } else {
216 4         19 return $self->cgi->header($self->mime_type);
217             }
218             }
219              
220              
221             sub send_header {
222 0     0 1   my $self = shift;
223              
224 0           print $self->header(@_);
225             }
226              
227              
228             sub run {
229 0     0 1   local $| = 1;
230 0           my $self = shift;
231              
232 0           $self->send_header();
233              
234 0           my $logfile = $self->log;
235 0           open(my $logfh, '>>', $logfile);
236              
237 0 0         if ($self->authenticated) {
238 0 0         my $trigger = $self->trigger.' >> '.$logfile.' 2>&1 '.
239             ($self->trigger_backgrounded ? '&' : '');
240 0           my $rc = system($trigger);
241 0 0         if ($rc != 0) {
242 0           say $logfh $trigger;
243 0           say $self->text_on_trigger_fail;
244 0           say $logfh $self->text_on_trigger_fail;
245 0 0         if ($? == -1) {
    0          
246 0           say $logfh "Trigger failed to execute: $!";
247 0           $self->deploy_badge('errored');
248             } elsif ($? & 127) {
249 0 0         printf $logfh "child died with signal %d, %s coredump\n",
250             ($? & 127), ($? & 128) ? 'with' : 'without';
251 0           $self->deploy_badge('errored');
252             } else {
253 0           printf $logfh "child exited with value %d\n", $? >> 8;
254 0           $self->deploy_badge('failed');
255             }
256 0           close $logfh;
257 0           return 0;
258             } else {
259 0           $self->deploy_badge('success');
260 0           say $self->text_on_success;
261 0           say $logfh $self->text_on_success;
262              
263 0           close $logfh;
264 0           return 1;
265             }
266             } else {
267 0           say $self->text_on_auth_fail;
268 0           say $logfh $self->text_on_auth_fail;
269 0           close $logfh;
270 0           return; # undef or empty list, i.e. false
271             }
272             }
273              
274              
275             1; # End of CGI::Github::Webhook
276              
277             __END__