Girocco/Notify.pm

   1 package Girocco::Notify;
   2
   3 use strict;
   4 use warnings;
   5
   6 BEGIN {
   7         use Girocco::Config;
   8         use Girocco::Util;
   9
  10         use JSON;
  11         use LWP::UserAgent;
  12
  13         use RPC::XML;
  14         use RPC::XML::Client;
  15 }
  16
  17
  18 # This Perl code creates json payload within post-receive hook.
  19
  20 sub json_commit {
  21         my ($proj, $commit) = @_;
  22
  23         my @gcmd = ($Girocco::Config::git_bin, '--git-dir='.$proj->{path});
  24         my $fd;
  25
  26         open $fd, '-|', @gcmd, 'log', '-1', '--pretty=format:%ae %an%n%ai%n%s%n%n%b', $commit
  27                 or die "cannot do git log: $! $?";
  28         my @l = <$fd>;
  29         chomp @l;
  30         close $fd;
  31         my ($ae, $an) = ($l[0] =~ /^(.*?) (.*)$/);
  32         my ($ai) = $l[1];
  33         my $msg = join("\n", splice(@l, 2));
  34         # Up to three trailing newlines in case of no body.
  35         chomp $msg; chomp $msg; chomp $msg;
  36
  37         my ($rf, $af, $mf) = ([], [], []);
  38         open $fd, '-|', @gcmd, 'diff-tree', '--name-status', '-r', "$commit^", $commit
  39                 or die "cannot do git diff-tree: $! $?";
  40         while (<$fd>) {
  41                 chomp;
  42                 my ($s, $file) = split(/\t/, $_);
  43                 if ($s eq 'M') {
  44                         push @$mf, $file;
  45                 } elsif ($s eq 'A') {
  46                         push @$af, $file;
  47                 } elsif ($s eq 'R') {
  48                         push @$rf, $file;
  49                 }
  50         }
  51         close $fd;
  52
  53         return {
  54                 "removed"   => $rf,
  55                 "message"   => $msg,
  56                 "added"     => $af,
  57                 "timestamp" => $ai,
  58                 "modified"  => $mf,
  59                 "url"       => $Girocco::Config::gitweburl."/".$proj->{name}.".git/commit/".$commit,
  60                 "author"    => { "name" => $an, "email" => $ae },
  61                 "id"        => $commit
  62         };
  63 }
  64
  65 sub json {
  66         my ($url, $proj, $user, $ref, $oldrev, $newrev) = @_;
  67
  68         my $pusher = {};
  69         if ($user) {
  70                 $pusher = { "name" => $user->{name} };
  71                 if ($user->{name} ne 'mob') {
  72                         $pusher->{"email"} = $user->{email};
  73                 }
  74         }
  75
  76         my $commits = [];
  77
  78         foreach my $commit (get_commits($proj, $ref, $oldrev, $newrev)) {
  79                 push @$commits, json_commit($proj, $commit);
  80         }
  81
  82         # This is backwards-compatible with GitHub (except the GitHub-specific
  83         # full project name construction sometimes performed in clients)
  84         my $payload = encode_json {
  85                 "before" => $oldrev,
  86                 "after"  => $newrev,
  87                 "ref"    => $ref,
  88
  89                 "repository" => {
  90                         "name"  => $proj->{name},
  91                         # Girocco extension: full_name is full project name,
  92                         # equivalent to GitHub's "owner[name]/name".
  93                         "full_name" => $proj->{name}.".git",
  94
  95                         "url"   => $Girocco::Config::gitweburl.'/'.$proj->{name}.".git",
  96                         # Girocco extension: Pull URL.
  97                         "pull_url" => $Girocco::Config::gitpullurl.'/'.$proj->{name}.".git",
  98
  99                         "owner" => { "name" => "", "email" => $proj->{email} }
 100                 },
 101
 102                 # Girocco extension
 103                 "pusher" => $pusher,
 104
 105                 "commits" => $commits
 106         };
 107
 108         # print "$payload\n";
 109         my $ua = LWP::UserAgent->new;
 110         $ua->timeout(5);
 111         $ua->post($url, { payload => $payload });
 112 }
 113
 114
 115 sub cia_commit {
 116         my ($cianame, $proj, $branch, $commit) = @_;
 117
 118         my @gcmd = ($Girocco::Config::git_bin, '--git-dir='.$proj->{path});
 119         my $fd;
 120
 121         open $fd, '-|', @gcmd, 'log', '-1', '--pretty=format:%an <%ae>%n%at%n%s', $commit
 122                 or die "cannot do git log: $! $?";
 123         my @l = <$fd>;
 124         chomp @l;
 125         close $fd;
 126         foreach (@l) { s/&/&amp;/g; s/</&lt;/g; s/>/&gt;/g; }
 127         my ($a, $at, $subj) = @l;
 128
 129         my @f;
 130         open $fd, '-|', @gcmd, 'diff-tree', '--name-status', '-r', "$commit^", $commit
 131                 or die "cannot do git diff-tree: $! $?";
 132         while (<$fd>) {
 133                 chomp;
 134                 s/&/&amp;/g; s/</&lt;/g; s/>/&gt;/g;
 135                 my ($status, $file) = split(/\t/, $_);
 136                 push @f, $file;
 137         }
 138         close $fd;
 139
 140         my $rev = substr($commit, 0, 12);
 141
 142         my $msg = <<EOT;
 143         <message>
 144                 <generator>
 145                         <name>Girocco::Notify</name>
 146                         <version>1.0</version>
 147                 </generator>
 148                 <source>
 149                         <project>$cianame</project>
 150 EOT
 151         if ($branch ne 'master') { # XXX: Check HEAD instead
 152                 $msg .= "<branch>$branch</branch>";
 153         }
 154         $msg .= "</source>\n";
 155         $msg .= "<timestamp>$at</timestamp>\n";
 156         $msg .= "<body><commit><author>$a</author><revision>$rev</revision>\n";
 157         $msg .= "<url>$Girocco::Config::gitweburl/$proj->{name}.git/commit/$commit</url>\n";
 158         $msg .= "<files>\n";
 159         foreach (@f) { $msg .= "<file>$_</file>\n"; }
 160         $msg .= "</files><log>$subj</log></commit></body></message>\n";
 161
 162         # print "$msg\n";
 163         my $rpc_client = new RPC::XML::Client "http://cia.vc/RPC2";
 164         my $rpc_request = RPC::XML::request->new('hub.deliver', $msg);
 165         #my $rpc_response = $rpc_client->send_request($rpc_request);
 166         #ref $rpc_response or print STDERR "XML-RPC Error: $RPC::XML::ERROR\n";
 167         print "$proj->{name}.git: CIA.vc is defunct ($cianame)\n";
 168 }
 169
 170 sub cia {
 171         my ($cianame, $proj, $ref, $oldrev, $newrev) = @_;
 172
 173         # CIA notifications for branches only
 174         my $branch = $ref;
 175         $branch =~ s#^refs/heads/## or return;
 176
 177         foreach my $commit (get_commits($proj, $ref, $oldrev, $newrev)) {
 178                 cia_commit($cianame, $proj, $branch, $commit);
 179         }
 180 }
 181
 182
 183 sub get_commits {
 184         my ($proj, $ref, $oldrev, $newrev) = @_;
 185
 186         return () if $newrev =~ /^0+$/;
 187
 188         my @gcmd = ($Girocco::Config::git_bin, '--git-dir='.$proj->{path});
 189         my $fd;
 190
 191         open $fd, '-|', @gcmd, 'for-each-ref', '--format=%(refname)', 'refs/heads/'
 192                 or die "cannot do git for-each-ref: $! $?";
 193         my @refs = <$fd>;
 194         chomp @refs;
 195         @refs = grep { $_ ne $ref } @refs;
 196         close $fd;
 197
 198         my @revlims;
 199         if (@refs) {
 200                 open $fd, '-|', @gcmd, 'rev-parse', '--not', @refs
 201                         or die "cannot do git rev-list for revlims: $! $?";
 202                 @revlims = <$fd>;
 203                 chomp @revlims;
 204                 close $fd;
 205         }
 206
 207         my $revspec = (($oldrev =~ /^0+$/) ? $newrev : "$oldrev..$newrev");
 208         open $fd, '-|', @gcmd, 'rev-list', @revlims, $revspec
 209                 or die "cannot do git rev-list: $! $?";
 210         my @revs = <$fd>;
 211         chomp @revs;
 212         close $fd;
 213
 214         return @revs;
 215 }
 216
 217 sub _get_sender_uuid {
 218         my ($proj, $user) = @_;
 219
 220         my $sender;
 221         my $xtrahdr = '';
 222         my $senderemail = $proj->{email};
 223         defined($senderemail) && $senderemail ne ''
 224                 or $senderemail = $Girocco::Config::sender;
 225         if ($user) {
 226                 if ($user->{name} eq 'mob') {
 227                         $sender = "The Mob User <$senderemail>";
 228                 } else {
 229                         my $useremail = $user->{email};
 230                         defined($useremail) && $useremail ne ''
 231                                 or $useremail = $senderemail;
 232                         $sender = "$user->{name} <$useremail>";
 233                         $xtrahdr = "X-User-UUID: $user->{uuid}" if $user->{uuid};
 234                 }
 235         } else {
 236                 $sender = "$proj->{name} <$senderemail>";
 237         }
 238
 239         return ($sender, $xtrahdr);
 240 }
 241
 242 sub _notify_for_ref {
 243         $_[0] =~ m{^refs/heads/.} || $_[0] =~ m{^refs/tags/.};
 244 }
 245
 246 sub ref_change {
 247         my ($proj, $user, $ref, $oldrev, $newrev) = @_;
 248         _notify_for_ref($ref) or return 0;
 249
 250         my $mail_sh_ran = 0;
 251         chdir($proj->{path});
 252
 253         # First, possibly send out various mails
 254         if (($ref =~ m{^refs/heads/.} && $proj->{notifymail}) ||
 255             ($ref =~ m{^refs/tags/.} && ($proj->{notifymail} || $proj->{notifytag}))) {
 256                 my ($sender, $xtrahdr) = _get_sender_uuid($proj, $user);
 257                 my @cmd = ($Girocco::Config::basedir.'/taskd/mail.sh',
 258                         "$ref", "$oldrev", "$newrev", $proj->{name},
 259                         $sender, $xtrahdr);
 260                 if (system(@cmd)) {
 261                         if ($? < 0 && exists($ENV{MAIL_SH_OTHER_BRANCHES})) {
 262                                 # Let's go again
 263                                 delete $ENV{MAIL_SH_OTHER_BRANCHES};
 264                                 system(@cmd);
 265                         }
 266                         $? and warn "mail.sh failed";
 267                 }
 268                 $mail_sh_ran = 1;
 269         }
 270
 271         # Next, send JSON packet to given URL if enabled.
 272         if ($proj->{notifyjson}) {
 273                 json($proj->{notifyjson}, $proj, $user, $ref, $oldrev, $newrev);
 274         }
 275
 276         # Also send CIA notifications.
 277         if ($proj->{notifycia}) {
 278                 cia($proj->{notifycia}, $proj, $ref, $oldrev, $newrev);
 279         }
 280
 281         return $mail_sh_ran;
 282 }
 283
 284 # ref_changes($proj, $user, [$coderef,] [$oldrefs,] @changes)
 285 # $coderef gets called with ($oldrev, $newrev, $refname, $mail_sh_ran) as each
 286 # update is processed where $mail_sh_ran will be true if mail.sh was run
 287 # $oldrefs is an optional hash of $$oldrefs{$refname} = $oldvalue
 288 # @changes is array of [$oldrev, $newrev, $ref]
 289 sub ref_changes {
 290         use IPC::Open2;
 291
 292         my $proj = shift;
 293         my $user = shift;
 294         my $proc;
 295         my $oldrefs;
 296         $proc = shift if ref($_[0]) eq 'CODE';
 297         $oldrefs = shift if ref($_[0]) eq 'HASH';
 298         return if !@_ || ref($_[0]) ne 'ARRAY' || @{$_[0]} != 3 ||
 299                 !${$_[0]}[0] || !${$_[0]}[1] || !${$_[0]}[2];
 300
 301         # don't even try the fancy stuff if there are too many heads
 302         my $maxheads = int(100000 / (1 + length(${$_[0]}[0])));
 303         my $newheadsdone = 0;
 304         my @newheads = grep({$$_[2] =~ m{^refs/heads/.} && $$_[1] !~ /^0+$/} @_);
 305
 306         if ($oldrefs && @newheads && keys(%$oldrefs) + @newheads <= $maxheads) {{
 307                 my $projarg = '--git-dir='.$proj->{path};
 308
 309                 # git merge-base --independent requires v1.7.3 or later
 310                 # We run it and if it fails just end up not processing indep heads last
 311                 # There is no version of merge-base --independent that accepts stdin revs
 312                 my %indep = map { $_ => 1 } split(' ',
 313                         get_git($projarg, 'merge-base', '--independent', map($$_[1], @newheads)) || '');
 314
 315                 # We pass the revisions on stdin so this should never fail unless one of
 316                 # the input revisions is no longer valid (which should never happen).
 317                 # However, if it does, we just fall back to the old non-fancy technique.
 318                 my ($inp, $out, $pid2);
 319                 $pid2 = eval { open2($out, $inp, $Girocco::Config::git_bin, $projarg,
 320                                 'rev-list', '--no-walk', '--reverse', '--stdin') };
 321                 $pid2 or last;
 322                 {
 323                         local $SIG{'PIPE'} = sub {};
 324                         print $inp map("$$_[1]\n", @newheads);
 325                         close $inp;
 326                 }
 327                 my @ordered = <$out>;
 328                 close $out;
 329                 waitpid $pid2, 0;
 330                 @ordered or last; # if we got nothing it failed
 331                 chomp(@ordered);
 332
 333                 my %updates = ();
 334                 push(@{$updates{$$_[1]}}, $_) foreach @newheads;
 335                 my %curheads = %$oldrefs;
 336                 my $headcmp = sub {
 337                         if ($_[0] eq 'refs/heads/master') {
 338                                 return ($_[1] eq 'refs/heads/master') ? 0 : -1;
 339                         } elsif ($_[1] eq 'refs/heads/master') {
 340                                 return 1;
 341                         } else {
 342                                 return $_[0] cmp $_[1];
 343                         }
 344                 };
 345                 foreach (grep(!$indep{$_}, @ordered), grep($indep{$_}, @ordered)) {
 346                         foreach my $change (sort {&$headcmp($$a[2], $$b[2])} @{$updates{$_}}) {
 347                                 my ($old, $new, $ref) = @$change;
 348                                 $ENV{MAIL_SH_OTHER_BRANCHES} = join(' ', values(%curheads));
 349                                 my $ran_mail_sh = ref_change($proj, $user, $ref, $old, $new);
 350                                 &$proc($old, $new, $ref, $ran_mail_sh) if $proc;
 351                                 $curheads{$ref} = $new;
 352                         }
 353                 }
 354                 $newheadsdone = 1;
 355         }}
 356
 357         delete $ENV{MAIL_SH_OTHER_BRANCHES};
 358         foreach (@_) {
 359                 my ($old, $new, $ref) = @$_;
 360                 if (!$newheadsdone || $ref !~ m{^refs/heads/.} || $new =~ /^0+$/) {
 361                         my $ran_mail_sh = ref_change($proj, $user, $ref, $old, $new);
 362                         &$proc($old, $new, $ref, $ran_mail_sh) if $proc;
 363                 }
 364         }
 365 }
 366
 367 1;