path: root/git-hooks/gerrit-bot

#! /usr/bin/perl

# Copyright (C) 2015 The Qt Company Ltd.
# Contact: http://www.qt.io/licensing/
#
# You may use this file under the terms of the 3-clause BSD license.
# See the file LICENSE from this package for details.
#

use strict;
use warnings;
use POSIX;
use JSON;
use File::Path;
use Gerrit::REST;

# Usage: $0 [instance]
# - default instance is 'sanitybot'
# - configure ssh: Host, Port, User, IdentityFile
# - configure git: git config --global <instance>}.<option> <value>
# Valid options are:
#   gerrithost (mandatory)
#     Target host. The identification is done via SSH.
#   gerritactorhost
#     Target host for inviting reviewers. Falls back go gerrithost.
#   resthost (mandatory)
#     The REST base URL of the target host.
#   restuser
#     The user name for resthost. If omitted, credentials are expected in .netrc.
#   restpass
#     The password for resthost. If omitted, credentials are expected in .netrc.
#   useremail (mandatory)
#     Bot's email address. Used to identify invitations and own actions.
#   inviteonly (default 0)
#     If this flag is set, the bot will only become active if it is a
#     requested reviewer. DON'T USE (see TODO).
#   gitbasedir (mandatory)
#     Base dir for local GIT clones of the projects.
#   gitdofetch
#     Need to fetch the repos or are they local?
#   workers
#     A space-separated list of workers.
#     They are run in a local bare clone of the inspected repository.
#     There must be a workers.<worker> config entry for each worker
#     (note that these entries are NOT namespaced with the instance).
#     The magic string @SHA1@ is replaced by the commit to be checked;
#     @PROJ@ by the gerrit project the worker is run for.
#     It is expected to dump a Gerrit ReviewInput JSON entity to stdout.
#     The output from all workers is merged.
#   excluded (optional)
#     Space-separated list of exclusions of the form <project> or
#     <project>:<branch>.
#   maintainers (optional)
#     Space-separated list of reviewers to add on "special occasions".
#   verbose (default 0)
#     Print progress/result messages.

# TODO
# - Implement some retry mechanism to deal with network failures
# - Make inviteonly actually work beyond the initial startup.
#   See http://code.google.com/p/gerrit/issues/detail?id=1200

my $instance = 'sanitybot';
$instance = $ARGV[0] if ($#ARGV > -1);

# Doing this is less expensive than calling git repeatedly.
my %config = ();
for (`git config -l`) {
  /^([^=]+)=(.*$)/;
  $config{$1} = $2;
}

sub getcfg($;$)
{
  my ($key, $def) = @_;
  my $fkey = $instance.'.'.$key;
  if (defined $config{$fkey}) {
    return $config{$fkey};
  } elsif (@_ > 1) {
    return $def;
  } else {
    die $fkey." not set.\n";
  }
}

my $GERRIT_HOST = getcfg 'gerrithost';
my $GERRIT_ACTOR_HOST = getcfg 'gerritactorhost', $GERRIT_HOST;
my $USER_EMAIL = getcfg 'useremail';
my $INVITE_ONLY = getcfg 'inviteonly', 0;
my $REST_HOST = getcfg 'resthost';
my $REST_USER = getcfg 'restuser', undef;
my $REST_PASS = getcfg 'restpass', undef;
my $GIT_BASEDIR = getcfg 'gitbasedir';
my $GIT_DO_FETCH = getcfg 'gitdofetch';
my $WORKERS = getcfg 'workers';
my %EXCLUDED_PROJECTS = map { $_ => 1 } split(/\s+/, getcfg('excluded', ""));
my @MAINTAINERS = split(/\s+/, getcfg('maintainers', ""));
my $verbose = getcfg 'verbose', 0;

my @gerrit = ("ssh", $GERRIT_HOST, "gerrit");
my @gerrit_actor = ("ssh", $GERRIT_ACTOR_HOST, "gerrit");
my $gerrit_rest = Gerrit::REST->new($REST_HOST, $REST_USER, $REST_PASS);

my %processed = ();
my %skipfetch = ();

sub printerr($)
{
  my ($msg) = @_;
  die $msg.": execution failed: ".$!."\n" if ($? < 0);
  die $msg.": command crashed with signal ".$?."\n" if ($? & 127);
  print STDERR $msg.".\n";
}

sub merge_hashes($$);

sub merge_hashes($$)
{
  my ($base, $ext) = @_;

  for my $k (keys %$ext) {
    my $br = \$$base{$k};
    my $ev = $$ext{$k};
    if (!defined($$br)) {
      $$br = $ev;
    } else {
      my $bt = ref($$br);
      my $et = ref($ev);
      die "Values for '$k' have different types ($bt, $et).\n" if ($bt ne $et);
      if ($et eq "HASH") {
        merge_hashes($$br, $ev);
      } elsif ($et eq "ARRAY") {
        push @$$br, @$ev;
      } elsif ($et eq "") {
        $$br = $$br."\n\n".$ev;
      } else {
        die "Values for '$k' have unsupported type $bt.\n";
      }
    }
  }
}

sub process_commit($$$$$)
{
  my ($number, $project, $branch, $ref, $rev) = @_;

  if (defined $processed{$ref}) {
    return;
  }
  $processed{$ref} = 1;
  my $orig_project = $project;
  $project =~ s,/$,,; # XXX Workaround QTQAINFRA-381
  my $verdict = {};
  my @invite;
  if (defined($EXCLUDED_PROJECTS{$project}) || defined($EXCLUDED_PROJECTS{$project.":".$branch})) {
    $verbose and print "===== ".strftime("%c", localtime(time()))." ===== excluding commit ".$ref." in ".$project."\n";
    $$verdict{message} = "(skipped)";
    $$verdict{labels}{'Sanity-Review'} = 1;
  } else {
    $verbose and print "===== ".strftime("%c", localtime(time()))." ===== processing commit ".$ref." in ".$project."\n";
    my $GIT_DIR = $GIT_BASEDIR."/".$project.".git";
    if (!-d $GIT_DIR) {
      mkpath $GIT_DIR or die "cannot create ".$GIT_DIR.": ".$!;
    }
    chdir $GIT_DIR or die "cannot change to ".$GIT_DIR.": ".$!;
    if ($GIT_DO_FETCH) {
      if (!-d $GIT_DIR."/refs/remotes" and `git config remote.origin.url` eq "") {
        if (!-d $GIT_DIR."/refs") {
          if (system("git", "init", "--bare")) {
            printerr "Init of ".$project." failed";
            return;
          }
        }
        if (system("git", "remote", "add", "origin", 'ssh://'.$GERRIT_HOST.'/'.$project)) {
          printerr "Adding remote for ".$project." failed";
          return;
        }
      }
      my @mainlines;
      if (!defined $skipfetch{$project}) {
        # Update refs, otherwise the selective fetches start from scratch each time.
        chomp(@mainlines = `git config remote.origin.fetch`);
        $skipfetch{$project} = 1;
      }
      if (system("git", "fetch", "-f", "--prune", "origin", $ref.":refs/changes/".$number, @mainlines)) {
        printerr "GIT fetch of ".$ref." from ".$project." failed";
        return;
      }
      $verbose and print "===== ".strftime("%c", localtime(time()))." ===== fetched change\n";
    }

    for my $w (split(/ /, $WORKERS)) {
      my $worker = $config{'workers.'.$w};
      die "workers.$worker not set.\n" if (!defined($worker));
      $worker =~ s/\@PROJ\@/$project/g;
      $worker =~ s/\@SHA1\@/$rev/g;
      my $output;
      open VERDICT, $worker." 2>&1 |" or die "cannot run worker '$w': ".$!;
      {
        local $/;
        $output = <VERDICT>;
      }
      close VERDICT;
      while ($output =~ s/^([^\{][^\n]*\n)//s) {
        print STDERR "Non-JSON output from worker '$w': $1\n";
      }
      die "Worker '$w' for commit ".$ref." in ".$project." crashed with signal ".$?.".\n" if ($? & 127);
      die "Worker '$w' returned non-zero exit code for commit ".$ref." in ".$project.".\n" if ($?);
      my $vd = {};
      if (length($output) > 50000) {
        $$vd{message} = "**** Worker '$w' produced an unreasonable amount of output. You should ask the bot maintainers for advice.";
        push @invite, @MAINTAINERS;
      } else {
        $vd = decode_json($output);
        defined($vd) or die "cannot decode verdict from worker '$w' as JSON\n";
        if (defined($$vd{invite})) {
          push @invite, @{$$vd{invite}};
          delete $$vd{invite};
        }
      }
      merge_hashes($verdict, $vd);
    }
  }
  if (@invite) {
    if (system(@gerrit_actor, "set-reviewers", (map { ('-a', $_) } @invite), '--', $rev)) {
      print "===== ".strftime("%c", localtime(time()))." ===== invitation FAILED\n";
      printerr("Inviting reviewers to ".$rev." (".$project."/".$ref.") failed");
    } else {
      $verbose and print "Invited @invite to ".$rev." (".$project."/".$ref.")\n";
    }
  }
  eval {
    $gerrit_rest->POST("/changes/$number/revisions/$rev/review", $verdict);
  };
  if ($@) {
    print "===== ".strftime("%c", localtime(time()))." ===== verdict NOT submitted\n";
    print STDERR "Submission of REST verdict for ".$rev." (".$project."/".$ref.") failed: $@\n";
    return;
  }
  $verbose and print "Submitted verdict for ".$rev." (".$project."/".$ref.")\n";
}

sub do_move($$$)
{
  my ($chg, $author, $target) = @_;
  my $branch = $$chg{'branch'};
  if ($target eq $branch) {
    return "The change already targets $branch";
  }
  # FIXME: this doesn't work, as for some reason the event stream does not include the status.
  #my %allowed_status = ('NEW' => 1, 'DEFERRED' => 1, 'DRAFT' => 1, 'ABANDONED' => 1);
  #my $status = $$chg{'status'};
  #return "$status changes cannot be moved" if (!$allowed_status{$status});
  my $project = $$chg{'project'};
  my $id = $$chg{'id'};
  # First, check there's no such review on that branch already
  my $query = "project:$project change:$id branch:$target";
  open(my $qry, "-|", @gerrit, "query", "--format", "JSON", $query) or die "cannot run ssh: ".$!;
  while (<$qry>) {
    my $review = decode_json($_);
    defined($review) or die "cannot decode JSON string '".chomp($_)."'\n";
    if (my $url = $$review{'url'}) {
      return "Cannot move: Conflicting change $url - please ask a Gerrit admin for help.";
    }
  }
  close $qry;
  # Only allow the change owner to execute move
  if ($$author{'username'} ne $$chg{'owner'}{'username'}) {
    return "Only the owner is allowed to move a change";
  }
  my $number = $$chg{'number'};
  open(my $retarget, "gerrit_retarget_changes x $target $number 2>&1 |")
    or die "Cannot run gerrit_retarget_changes: ".$!;
  my @output = <$retarget>;
  return "Moved from $branch" if (close($retarget));
  return ($! ? "Failed to move ($!)\n" : "Move rejected ($?)\n") . join(' ', @output);
}

sub process_move($$$) {
  my ($chg, $author, $target) = @_;
  my $number = $$chg{'number'};
  $gerrit_rest->POST("/changes/$number/revisions/current/review",
                     { message => do_move($chg, $author, $target) });
}

$| = 1; # make STDOUT autoflush

open UPDATES, "-|", @gerrit, "stream-events" or die "cannot run ssh: ".$!;

# Try to ensure that the event streaming has started before we make the snapshot, to avoid a race.
# Of course, the first connect may be still delayed ...
sleep(1);

my @query = ("status:open");
push @query, "reviewer:".$USER_EMAIL if ($INVITE_ONLY);
open STATUS, "-|", @gerrit, "query", "--format", "JSON", "--current-patch-set", @query or die "cannot run ssh: ".$!;
REVIEW: while (<STATUS>) {
  my $review = decode_json($_);
  defined($review) or die "cannot decode JSON string '".chomp($_)."'\n";
  my $number = $$review{'number'};
  my $project = $$review{'project'};
  my $branch = $$review{'branch'};
  my $cps = $$review{'currentPatchSet'};
  if (defined $cps) {
    my $status = $$review{'status'};
    if ($status ne 'NEW' and $status ne 'DRAFT') {
       next REVIEW;
    }
    my $ref = $$cps{'ref'};
    my $revision = $$cps{'revision'};
    my $approvals = $$cps{'approvals'};
    if (defined $approvals) {
      foreach my $appr (@$approvals) {
        my $by = $$appr{'by'};
        defined $$by{'email'} or next;   # The reviewer may be gone and thus have no valid mail any more.
        if ($$by{'email'} eq $USER_EMAIL) {
          next REVIEW;
        }
      }
    }
    process_commit($number, $project, $branch, $ref, $revision);
  }
}
close STATUS;

while (<UPDATES>) {
  my $update = decode_json($_);
  defined($update) or die "cannot decode JSON string '".chomp($_)."'\n";
  my $type = $$update{'type'};
  if (defined($type)) {
    if ($type eq 'patchset-created') {
      my $chg = $$update{'change'};
      my $ps = $$update{'patchSet'};
      process_commit($$chg{'number'}, $$chg{'project'}, $$chg{'branch'}, $$ps{'ref'}, $$ps{'revision'});
    } elsif ($type eq 'ref-updated') {
      my $rup = $$update{'refUpdate'};
      delete $skipfetch{$$rup{'project'}};
    } elsif ($type eq 'comment-added') {
      my $cmd = $$update{'comment'};
      if ($cmd =~ /^(?:gerrit-)?bot:\h*(?:please\h+)?move\h+(?:back\h+)?to\h+(?:branch\h+)?([\w.\/-]*\w)\b/im) {
        process_move($$update{'change'}, $$update{'author'}, $1);
      }
    }
  }
}
close UPDATES;