projtool.pl: do not attempt to check unset error codes
[girocco.git] / Girocco / Notify.pm
blob37fe6009d873afdb338ae19eda996d3a43f47537
1 package Girocco::Notify;
3 use strict;
4 use warnings;
6 use Girocco::Config;
7 use Girocco::Util;
8 use Girocco::HashUtil qw(hmac_sha1);
9 my $have_hmac_sha256;
10 BEGIN {eval{
11 $have_hmac_sha256 = 0;
12 require Digest::SHA;
13 Digest::SHA->import( qw(hmac_sha256) );
14 $have_hmac_sha256 = 1;
17 use LWP::UserAgent;
19 #use RPC::XML;
20 #use RPC::XML::Client;
22 # This Perl code creates json payload within post-receive hook.
24 sub _fixlaxiso {
25 # The %ai %ci formats are ISO 8601 like "1999-12-31 23:59:59 -0100"
26 # The %aI %cI strict ISO 8601 formats aren't available until Git v2.2.0
27 local $_ = shift;
28 s/ /T/; # "1999-12-31 23:59:59 -0100" -> "1999-12-31T23:59:59 -0100"
29 s/ //; # "1999-12-31T23:59:59 -0100" -> "1999-12-31T23:59:59-0100"
30 s/(?<!:)(\d\d)$/:$1/; # "1999-12-31T23:59:59-0100" -> "1999-12-31T23:59:59-01:00"
31 return $_;
34 sub json_commit {
35 my ($proj, $commit, $root) = @_;
37 my @gcmd = ($Girocco::Config::git_bin, '--git-dir='.$proj->{path});
38 my $fd;
40 open $fd, '-|', @gcmd, 'log', '-1', '--pretty=format:%T%n%ae %an%n%ai%n%ce %cn%n%ci%n%s%n%n%b', $commit, '--'
41 or die "cannot do git log: $! $?";
42 my @l = <$fd>;
43 chomp @l;
44 close $fd;
45 my ($tr) = $l[0];
46 my ($ae, $an) = ($l[1] =~ /^(.*?) (.*)$/);
47 #my ($ai) = _fixlaxiso($l[2]);
48 my ($ce, $cn) = ($l[3] =~ /^(.*?) (.*)$/);
49 my ($ci) = _fixlaxiso($l[4]);
50 my $msg = join("\n", splice(@l, 5));
51 # Up to three trailing newlines in case of no body.
52 chomp $msg; chomp $msg; chomp $msg;
54 my ($rf, $af, $mf) = ([], [], []);
55 my $parent = ($commit eq $root) ? "--root" : "$commit^";
56 open $fd, '-|', @gcmd, 'diff-tree', '--name-status', '-r', $parent, $commit, '--'
57 or die "cannot do git diff-tree: $! $?";
58 while (<$fd>) {
59 chomp;
60 my ($s, $file) = split(/\t/, $_);
61 if ($s eq 'M') {
62 push @$mf, $file;
63 } elsif ($s eq 'A') {
64 push @$af, $file;
65 } elsif ($s eq 'R') {
66 push @$rf, $file;
69 close $fd;
71 return {
72 "removed" => $rf,
73 "message" => $msg,
74 "added" => $af,
75 "timestamp" => $ci,
76 "modified" => $mf,
77 "url" => $Girocco::Config::gitweburl."/".$proj->{name}.".git/commit/".$commit,
78 "author" => { "name" => $an, "email" => $ae },
79 "committer" => { "name" => $cn, "email" => $ce },
80 "distinct" => json_bool(1),
81 "id" => $commit,
82 "tree_id" => $tr
83 };
86 sub _jsonagent {
87 my $proj = shift;
88 return "girocco/1.0 (JSON Push Notification) (" .
89 $Girocco::Config::gitweburl."/".$proj->{name}.".git" .
90 ")";
93 sub _projurl {
94 my ($base, $suffix) = @_;
95 defined($base) && $base ne "" or return undef;
96 defined($suffix) && $suffix ne "" or return undef;
97 return $base.'/'.$suffix.'.git';
100 sub _jsonrepo {
101 my $proj = shift;
102 return {
103 "name" => $proj->{name},
104 "default_branch" => $proj->{HEAD},
105 "master_branch" => $proj->{HEAD},
106 "description" => $proj->{desc},
107 # Girocco extension: full_name is full project name,
108 # equivalent to GitHub's "owner[name]/name".
109 "full_name" => $proj->{name}.".git",
111 "url" => _projurl($Girocco::Config::gitweburl,$proj->{name}),
112 "html_url" => _projurl($Girocco::Config::gitweburl,$proj->{name}),
113 "clone_url" => _projurl($Girocco::Config::httppullurl,$proj->{name}),
114 "git_url" => _projurl($Girocco::Config::gitpullurl,$proj->{name}),
115 "ssh_url" => _projurl($Girocco::Config::pushurl,$proj->{name}),
116 "mirror_url" => $proj->{url},
117 # Girocco extension: Git Pull URL.
118 "pull_url" => _projurl($Girocco::Config::gitpullurl,$proj->{name}),
120 "owner" => { "email" => $proj->{email} }
124 sub _jsonpayload {
125 my ($proj, $payload) = @_;
126 my $ct = $proj->{jsontype};
127 if (!defined($ct) || $ct ne 'application/json') {
129 use bytes;
130 # Spaces are expected to be encoded as '+' rather than %20
131 # This is not part of any RFC, but matches the behavior
132 # of the specification that we're emulating here
133 $payload =~ s/([^ A-Za-z0-9_.~-])/sprintf("%%%02X",ord($1))/ge;
134 $payload =~ s/[ ]/+/g; # expected but NOT part of any RFC!
136 $payload = 'payload=' . $payload;
138 return $payload;
141 sub _jsonsigheaders {
142 my ($proj, $payload) = @_;
143 my $hmackey = $proj->{jsonsecret};
144 my @sigheaders = ();
145 if (defined($hmackey) && $hmackey ne "") {
146 my $sig = "sha1=".lc(unpack('H*',hmac_sha1($payload, $hmackey)));
147 push(@sigheaders, X_Hub_Signature => $sig);
148 if ($have_hmac_sha256) {
149 my $sig256 = "sha256=".lc(unpack('H*',hmac_sha256($payload, $hmackey)));
150 push(@sigheaders, X_Hub_Signature_256 => $sig256);
153 return @sigheaders;
156 sub json {
157 my ($url, $proj, $user, $ref, $oldrev, $newrev, $forced) = @_;
159 my $pusher = {};
160 my $sender = {};
161 if ($user) {
162 $pusher = { "name" => $user->{name} };
163 $sender = { "login" => $user->{name} };
164 if ($user->{name} ne 'mob') {
165 $pusher->{"email"} = $user->{email};
169 my $commits = [];
171 my @commits = get_commits($proj, $ref, $oldrev, $newrev);
172 my $root = ($oldrev =~ /^0+$/) ? $commits[$#commits] : "";
173 foreach my $commit (@commits) {
174 push @$commits, json_commit($proj, $commit, $root);
177 # This is backwards-compatible with GitHub (except the GitHub-specific
178 # full project name construction sometimes performed in clients)
179 my $payload = to_json {
180 "before" => $oldrev,
181 "after" => $newrev,
182 "ref" => $ref,
183 "created" => json_bool($oldrev =~ /^0+$/ ? 1 : 0),
184 "deleted" => json_bool($newrev =~ /^0+$/ ? 1 : 0),
185 "forced" => json_bool($forced ? 1 : 0),
186 "repository" => _jsonrepo($proj),
187 "pusher" => $pusher,
188 "sender" => $sender,
189 "commits" => $commits
192 # print "$payload\n";
193 my $ua = LWP::UserAgent->new(agent => _jsonagent($proj));
194 $ua->max_redirect(0); # no redirects allowed
195 $ua->max_size(32768); # there really shouldn't be hardly any response content at all
196 $ua->timeout(5);
197 my $ct = $proj->{jsontype};
198 defined($ct) && $ct eq 'application/json' or
199 $ct = 'application/x-www-form-urlencoded';
200 $payload = _jsonpayload($proj, $payload);
201 my @headers = ( Content_Type => $ct, Content_Length => length($payload) );
202 $ua->post($url, @headers, _jsonsigheaders($proj, $payload), Content => $payload);
206 sub json_test_post {
207 my ($proj, $url) = @_;
208 defined($url) && $url ne "" or $url = $proj->{notifyjson};
209 defined($url) && $url ne "" or return undef;
210 my $ct = $proj->{jsontype};
211 defined($ct) && $ct eq 'application/json' or
212 $ct = 'application/x-www-form-urlencoded';
213 my $hook = {
214 "active" => json_bool(1),
215 "config" => {
216 "content_type" => (($ct =~ /json/) ? "json" : "form"),
217 "url" => $url
219 "events" => [ "push" ]
221 my $payload = to_json {
222 "zen" => 'Why is a raven like a writing desk?',
223 "repository" => _jsonrepo($proj),
224 "hook" => $hook,
225 "sender" => {
226 "url" => _projurl($Girocco::Config::gitweburl,$proj->{name}),
227 "html_url" => _projurl($Girocco::Config::gitweburl,$proj->{name}),
228 "email" => $proj->{email}
231 $payload = _jsonpayload($proj, $payload);
232 my $ua = LWP::UserAgent->new(agent => _jsonagent($proj));
233 $ua->max_redirect(0); # no redirects allowed
234 $ua->max_size(32768); # there really shouldn't be hardly any response content at all
235 $ua->timeout(15); # Allow extra time on initial check
236 my @headers = ( Content_Type => $ct, Content_Length => length($payload) );
237 my $r = $ua->post($url, @headers, _jsonsigheaders($proj, $payload), Content => $payload);
238 return $r->protocol !~ m{HTTP/0\.9}i && $r->is_success; # HTTP/0.9 is NOT okay for this test
242 sub cia_commit {
243 my ($cianame, $proj, $branch, $commit, $root) = @_;
245 my @gcmd = ($Girocco::Config::git_bin, '--git-dir='.$proj->{path});
246 my $fd;
248 open $fd, '-|', @gcmd, 'log', '-1', '--pretty=format:%an <%ae>%n%at%n%s', $commit, '--'
249 or die "cannot do git log: $! $?";
250 my @l = <$fd>;
251 chomp @l;
252 close $fd;
253 foreach (@l) { s/&/&amp;/g; s/</&lt;/g; s/>/&gt;/g; }
254 my ($a, $at, $subj) = @l;
256 my @f;
257 my $parent = ($commit eq $root) ? "--root" : "$commit^";
258 open $fd, '-|', @gcmd, 'diff-tree', '--name-status', '-r', $parent, $commit, '--'
259 or die "cannot do git diff-tree: $! $?";
260 while (<$fd>) {
261 chomp;
262 s/&/&amp;/g; s/</&lt;/g; s/>/&gt;/g;
263 my ($status, $file) = split(/\t/, $_);
264 push @f, $file;
266 close $fd;
268 my $rev = substr($commit, 0, 12);
270 my $msg = <<EOT;
271 <message>
272 <generator>
273 <name>Girocco::Notify</name>
274 <version>1.0</version>
275 </generator>
276 <source>
277 <project>$cianame</project>
279 if ($branch ne 'master') { # XXX: Check HEAD instead
280 $msg .= "<branch>$branch</branch>";
282 $msg .= "</source>\n";
283 $msg .= "<timestamp>$at</timestamp>\n";
284 $msg .= "<body><commit><author>$a</author><revision>$rev</revision>\n";
285 $msg .= "<url>$Girocco::Config::gitweburl/$proj->{name}.git/commit/$commit</url>\n";
286 $msg .= "<files>\n";
287 foreach (@f) { $msg .= "<file>$_</file>\n"; }
288 $msg .= "</files><log>$subj</log></commit></body></message>\n";
290 # print "$msg\n";
291 #my $rpc_client = new RPC::XML::Client "http://cia.vc/RPC2";
292 #my $rpc_request = RPC::XML::request->new('hub.deliver', $msg);
293 #my $rpc_response = $rpc_client->send_request($rpc_request);
294 #ref $rpc_response or print STDERR "XML-RPC Error: $RPC::XML::ERROR\n";
297 sub cia {
298 my ($cianame, $proj, $ref, $oldrev, $newrev) = @_;
300 # CIA notifications for branches only
301 my $branch = $ref;
302 $branch =~ s#^refs/heads/## or return;
304 my @commits = get_commits($proj, $ref, $oldrev, $newrev);
305 my $root = ($oldrev =~ /^0+$/) ? $commits[$#commits] : "";
306 foreach my $commit (@commits) {
307 cia_commit($cianame, $proj, $branch, $commit, $root);
309 print "$proj->{name}.git: CIA.vc is defunct ($cianame)\n";
313 sub get_commits {
314 my ($proj, $ref, $oldrev, $newrev) = @_;
316 return () if $newrev =~ /^0+$/;
318 my @gcmd = ($Girocco::Config::git_bin, '--git-dir='.$proj->{path});
319 my $fd;
321 open $fd, '-|', @gcmd, 'for-each-ref', '--format=%(refname)', 'refs/heads/'
322 or die "cannot do git for-each-ref: $! $?";
323 my @refs = <$fd>;
324 chomp @refs;
325 @refs = grep { $_ ne $ref } @refs;
326 close $fd;
328 my @revlims;
329 if (@refs) {
330 open $fd, '-|', @gcmd, 'rev-parse', '--not', @refs
331 or die "cannot do git rev-list for revlims: $! $?";
332 @revlims = <$fd>;
333 chomp @revlims;
334 close $fd;
337 my $revspec = (($oldrev =~ /^0+$/) ? $newrev : "$oldrev..$newrev");
338 open $fd, '-|', @gcmd, 'rev-list', @revlims, $revspec
339 or die "cannot do git rev-list: $! $?";
340 my @revs = <$fd>;
341 chomp @revs;
342 close $fd;
344 return @revs;
347 sub _get_sender_uuid {
348 my ($proj, $user) = @_;
350 my $sender;
351 my $xtrahdr = '';
352 my $senderemail = $proj->{email};
353 defined($senderemail) && $senderemail ne ''
354 or $senderemail = $Girocco::Config::sender;
355 if ($user) {
356 if ($user->{name} eq 'mob') {
357 $sender = "The Mob User <$senderemail>";
358 } else {
359 my $useremail = $user->{email};
360 defined($useremail) && $useremail ne ''
361 or $useremail = $senderemail;
362 $sender = "$user->{name} <$useremail>";
363 $xtrahdr = "X-User-UUID: $user->{uuid}" if $user->{uuid};
365 } else {
366 $sender = "$proj->{name} <$senderemail>";
369 return ($sender, $xtrahdr);
372 sub _notify_for_ref {
373 $_[0] =~ m{^refs/heads/.} || $_[0] =~ m{^refs/tags/.};
376 my $_ref_change;
377 BEGIN {$_ref_change = sub {
378 my ($proj, $user, $ref, $oldrev, $newrev) = @_;
379 _notify_for_ref($ref) or return (0, 0, undef);
381 my $mail_sh_ran = 0;
382 my $git_ran = 0;
383 my $ind = undef;
384 chdir($proj->{path});
386 # First, possibly send out various mails
387 if (($ref =~ m{^refs/heads/.} && $proj->{notifymail}) ||
388 ($ref =~ m{^refs/tags/.} && ($proj->{notifymail} || $proj->{notifytag}))) {
389 my ($sender, $xtrahdr) = _get_sender_uuid($proj, $user);
390 my @cmd = ($Girocco::Config::basedir.'/taskd/mail.sh',
391 "$ref", "$oldrev", "$newrev", $proj->{name},
392 $sender, $xtrahdr);
393 if (system(@cmd)) {
394 if ($? < 0 && exists($ENV{MAIL_SH_OTHER_BRANCHES})) {
395 # Let's go again
396 delete $ENV{MAIL_SH_OTHER_BRANCHES};
397 system(@cmd);
399 $? and warn "mail.sh failed";
401 $mail_sh_ran = 1;
404 # Next, send JSON packet to given URL if enabled.
405 if ($proj->{notifyjson}) {
406 ($ind, $git_ran) = ref_indicator($proj->{path}, $oldrev, $newrev);
407 json($proj->{notifyjson}, $proj, $user, $ref, $oldrev, $newrev, $ind eq '...');
410 # Also send CIA notifications.
411 if ($proj->{notifycia}) {
412 cia($proj->{notifycia}, $proj, $ref, $oldrev, $newrev);
415 return ($mail_sh_ran, $git_ran, $ind);
418 # ref_changes($proj, $user, [$coderef,] [$oldrefs,] @changes)
419 # $coderef gets called with ($oldrev, $newrev, $refname, $mail_sh_ran, $git_ran, $ind)
420 # as each update is processed where $mail_sh_ran will be true if mail.sh was run
421 # $ran_git will be true if git was run and $ind will be undef unless ref_indicator
422 # was run in which case it will be the ref_indicator '..' or '...' result
423 # $oldrefs is an optional hash of $$oldrefs{$refname} = $oldvalue
424 # @changes is array of [$oldrev, $newrev, $ref]
425 sub ref_changes {
426 use IPC::Open2;
428 my $proj = shift;
429 my $user = shift;
430 my $proc;
431 my $oldrefs;
432 $proc = shift if ref($_[0]) eq 'CODE';
433 $oldrefs = shift if ref($_[0]) eq 'HASH';
434 return if !@_ || ref($_[0]) ne 'ARRAY' || @{$_[0]} != 3 ||
435 !${$_[0]}[0] || !${$_[0]}[1] || !${$_[0]}[2];
437 # run custom notify if present
438 # hook protocol is the same as for Git's post-receive hook where each
439 # line sent to the hook's stdin has the form:
440 # oldhash newhash fullrefname
441 # with the following additions:
442 # * four command line arguments are passed:
443 # 1. project name (e.g. "proj" "proj/fork" "proj/fork/sub" etc.)
444 # 2. "user" responsible for the changes
445 # 3. total number of lines coming on stdin
446 # 4. how many of those lines are "context" lines (sent first)
447 # * "context" lines are sent first before any actual change lines
448 # * "context" lines have the same format except oldhash equals newhash
449 # * "context" lines give the value unchanged refs had at the time
450 # the changes to the non-"context" refs were made
451 # * currently "context" lines are only provided for "refs/heads/..."
452 # * current directory will always be the repository's top-level $GIT_DIR
453 # * the PATH is guaranteed to find the correct Git, utils and $basedir/bin
454 # * the hook need not consume all (or any) of stdin
455 # * the exit code for the hook is ignored (just like Git's post-receive)
456 # * the GIROCCO_BASEDIR environment variable is set to $Girocco::Config::basedir
457 my $customhook;
458 if (($customhook = $proj->_has_notifyhook)) {{
459 my @argv = ();
460 my $argv0;
461 if (is_shellish($customhook)) {
462 $argv0 = $Girocco::Config::posix_sh_bin || "/bin/sh";
463 push(@argv, $argv0, "-c", $customhook.' "$@"');
464 } else {
465 -f $customhook && -x _ or last;
466 $argv0 = $customhook;
468 my $username = "";
469 $username = $user->{name} if $user && defined($user->{name});
470 $username ne "" or $username = "-";
471 push(@argv, $argv0, $proj->{name}, $username);
472 my @mod = grep({$$_[2] =~ m{^refs/.} && $$_[1] ne "" && $$_[2] ne "" && $$_[1] ne $$_[2]} @_);
473 my %modref = map({($$_[2] => 1)} @mod);
474 my %same = ();
475 do {do {$same{$_} = $$oldrefs{$_} if !exists($modref{$_})} foreach keys %$oldrefs} if $oldrefs;
476 my @same = ();
477 push(@same, [$same{$_}, $same{$_}, $_]) foreach sort keys %same;
478 push(@argv, @same + @mod, @same + 0);
479 chdir($proj->{path}) or last;
480 local $ENV{GIROCCO_BASEDIR} = $Girocco::Config::basedir;
481 local $ENV{PATH} = util_path;
482 if (open my $hookpipe, '|-', @argv) {
483 local $SIG{'PIPE'} = sub {};
484 print $hookpipe map("$$_[0] $$_[1] $$_[2]\n", @same, @mod);
485 close $hookpipe;
486 } else {
487 print STDERR "$proj->{name}: failed to run notifyhook \"$customhook\": $!\n";
491 # don't even try the fancy stuff if there are too many heads
492 my $maxheads = int(100000 / (1 + length(${$_[0]}[0])));
493 my $newheadsdone = 0;
494 my @newheads = grep({$$_[2] =~ m{^refs/heads/.} && $$_[1] !~ /^0+$/} @_);
496 if ($oldrefs && @newheads && keys(%$oldrefs) + @newheads <= $maxheads) {{
497 my $projarg = '--git-dir='.$proj->{path};
499 # git merge-base --independent requires v1.7.3 or later
500 # We run it and if it fails just end up not processing indep heads last
501 # There is no version of merge-base --independent that accepts stdin revs
502 my %indep = map { $_ => 1 } split(' ',
503 get_git($projarg, 'merge-base', '--independent', map($$_[1], @newheads)) || '');
505 # We pass the revisions on stdin so this should never fail unless one of
506 # the input revisions is no longer valid (which should never happen).
507 # However, if it does, we just fall back to the old non-fancy technique.
508 my ($inp, $out, $pid2);
509 $pid2 = eval { open2($out, $inp, $Girocco::Config::git_bin, $projarg,
510 'rev-list', '--no-walk', '--reverse', '--stdin') };
511 $pid2 or last;
513 local $SIG{'PIPE'} = sub {};
514 print $inp map("$$_[1]\n", @newheads);
515 close $inp;
517 my @ordered = <$out>;
518 close $out;
519 waitpid $pid2, 0;
520 @ordered or last; # if we got nothing it failed
521 chomp(@ordered);
523 my %updates = ();
524 push(@{$updates{$$_[1]}}, $_) foreach @newheads;
525 my %curheads = %$oldrefs;
526 my $headcmp = sub {
527 if ($_[0] eq 'refs/heads/master') {
528 return ($_[1] eq 'refs/heads/master') ? 0 : -1;
529 } elsif ($_[1] eq 'refs/heads/master') {
530 return 1;
531 } else {
532 return $_[0] cmp $_[1];
535 foreach (grep(!$indep{$_}, @ordered), grep($indep{$_}, @ordered)) {
536 foreach my $change (sort {&$headcmp($$a[2], $$b[2])} @{$updates{$_}}) {
537 my ($old, $new, $ref) = @$change;
538 $ENV{MAIL_SH_OTHER_BRANCHES} = join(' ', values(%curheads));
539 my ($mail_sh_ran, $git_ran, $ind) =
540 &$_ref_change($proj, $user, $ref, $old, $new);
541 &$proc($old, $new, $ref, $mail_sh_ran, $git_ran, $ind) if $proc;
542 $curheads{$ref} = $new;
545 $newheadsdone = 1;
548 delete $ENV{MAIL_SH_OTHER_BRANCHES};
549 foreach (@_) {
550 my ($old, $new, $ref) = @$_;
551 if (!$newheadsdone || $ref !~ m{^refs/heads/.} || $new =~ /^0+$/) {
552 my $ran_mail_sh = &$_ref_change($proj, $user, $ref, $old, $new);
553 &$proc($old, $new, $ref, $ran_mail_sh) if $proc;