contrib/continuous/cidaemon

   1 #!/usr/bin/perl
   2 #
   3 # A daemon that waits for update events sent by its companion
   4 # post-receive-cinotify hook, checks out a new copy of source,
   5 # compiles it, and emails the guilty parties if the compile
   6 # (and optionally test suite) fails.
   7 #
   8 # To use this daemon, configure it and run it.  It will disconnect
   9 # from your terminal and fork into the background.  The daemon must
  10 # have local filesystem access to the source repositories, as it
  11 # uses objects/info/alternates to avoid copying objects.
  12 #
  13 # Add its companion post-receive-cinotify hook as the post-receive
  14 # hook to each repository that the daemon should monitor.  Yes, a
  15 # single daemon can monitor more than one repository.
  16 #
  17 # To use multiple daemons on the same system, give them each a
  18 # unique queue file and tmpdir.
  19 #
  20 # Global Config
  21 # -------------
  22 # Reads from a Git style configuration file.  This will be
  23 # ~/.gitconfig by default but can be overridden by setting
  24 # the GIT_CONFIG_FILE environment variable before starting.
  25 #
  26 # cidaemon.smtpHost
  27 #   Hostname of the SMTP server the daemon will send email
  28 #   through.  Defaults to 'localhost'.
  29 #
  30 # cidaemon.smtpUser
  31 #   Username to authenticate to the SMTP server as.  This
  32 #   variable is optional; if it is not supplied then no
  33 #   authentication will be performed.
  34 #
  35 # cidaemon.smtpPassword
  36 #   Password to authenticate to the SMTP server as.  This
  37 #   variable is optional.  If not supplied but smtpUser was,
  38 #   the daemon prompts for the password before forking into
  39 #   the background.
  40 #
  41 # cidaemon.smtpAuth
  42 #   Type of authentication to perform with the SMTP server.
  43 #   If set to 'login' and smtpUser was defined, this will
  44 #   use the AUTH LOGIN command, which is suitable for use
  45 #   with at least one version of Microsoft Exchange Server.
  46 #   If not set the daemon will use whatever auth methods
  47 #   are supported by your version of Net::SMTP.
  48 #
  49 # cidaemon.email
  50 #   Email address that daemon generated emails will be sent
  51 #   from.  This should be a useful email address within your
  52 #   organization.  Required.
  53 #
  54 # cidaemon.name
  55 #   Human friendly name that the daemon will send emails as.
  56 #   Defaults to 'cidaemon'.
  57 #
  58 # cidaemon.scanDelay
  59 #   Number of seconds to sleep between polls of the queue file.
  60 #   Defaults to 60.
  61 #
  62 # cidaemon.recentCache
  63 #   Number of recent commit SHA-1s per repository to cache and
  64 #   skip building if they appear again.  This is useful to avoid
  65 #   rebuilding the same commit multiple times just because it was
  66 #   pushed into more than one branch.  Defaults to 100.
  67 #
  68 # cidaemon.tmpdir
  69 #   Scratch directory to create the builds within.  The daemon
  70 #   makes a new subdirectory for each build, then deletes it when
  71 #   the build has finished.  The pid file is also placed here.
  72 #   Defaults to '/tmp'.
  73 #
  74 # cidaemon.queue
  75 #   Path to the queue file that the post-receive-cinotify hook
  76 #   appends events to.  This file is polled by the daemon.  It
  77 #   must not be on an NFS mount (uses flock).  Required.
  78 #
  79 # cidaemon.nocc
  80 #   Perl regex patterns to match against author and committer
  81 #   lines.  If a pattern matches, that author or committer will
  82 #   not be notified of a build failure.
  83 #
  84 # Per Repository Config
  85 # ----------------------
  86 # Read from the source repository's config file.
  87 #
  88 # builder.command
  89 #   Shell command to execute the build.  This command must
  90 #   return 0 on "success" and non-zero on failure.  If you
  91 #   also want to run a test suite, make sure your command
  92 #   does that too.  Required.
  93 #
  94 # builder.queue
  95 #   Queue file to notify the cidaemon through.  Should match
  96 #   cidaemon.queue.  If not set the hook will not notify the
  97 #   cidaemon.
  98 #
  99 # builder.skip
 100 #   Perl regex patterns of refs that should not be sent to
 101 #   cidaemon.  Updates of these refs will be ignored.
 102 #
 103 # builder.newBranchBase
 104 #   Glob patterns of refs that should be used to form the
 105 #   'old' revions of a newly created ref.  This should set
 106 #   to be globs that match your 'mainline' branches.  This
 107 #   way a build failure of a brand new topic branch does not
 108 #   attempt to email everyone since the beginning of time;
 109 #   instead it only emails those authors of commits not in
 110 #   these 'mainline' branches.
 111
 112 local $ENV{PATH} = join ':', qw(
 113         /opt/git/bin
 114         /usr/bin
 115         /bin
 116         );
 117
 118 use strict;
 119 use warnings;
 120 use FindBin qw($RealBin);
 121 use File::Spec;
 122 use lib File::Spec->catfile($RealBin, '..', 'perl5');
 123 use Storable qw(retrieve nstore);
 124 use Fcntl ':flock';
 125 use POSIX qw(strftime);
 126 use Getopt::Long qw(:config no_auto_abbrev auto_help);
 127
 128 sub git_config ($;$)
 129 {
 130         my $var = shift;
 131         my $required = shift || 0;
 132         local *GIT;
 133         open GIT, '-|','git','config','--get',$var;
 134         my $r = <GIT>;
 135         chop $r if $r;
 136         close GIT;
 137         die "error: $var not set.\n" if ($required && !$r);
 138         return $r;
 139 }
 140
 141 package EXCHANGE_NET_SMTP;
 142
 143 # Microsoft Exchange Server requires an 'AUTH LOGIN'
 144 # style of authentication.  This is different from
 145 # the default supported by Net::SMTP so we subclass
 146 # and override the auth method to support that.
 147
 148 use Net::SMTP;
 149 use Net::Cmd;
 150 use MIME::Base64 qw(encode_base64);
 151 our @ISA = qw(Net::SMTP);
 152 our $auth_type = ::git_config 'cidaemon.smtpAuth';
 153
 154 sub new
 155 {
 156         my $self = shift;
 157         my $type = ref($self) || $self;
 158         $type->SUPER::new(@_);
 159 }
 160
 161 sub auth
 162 {
 163         my $self = shift;
 164         return $self->SUPER::auth(@_) unless $auth_type eq 'login';
 165
 166         my $user = encode_base64 shift, '';
 167         my $pass = encode_base64 shift, '';
 168         return 0 unless CMD_MORE == $self->command("AUTH LOGIN")->response;
 169         return 0 unless CMD_MORE == $self->command($user)->response;
 170         CMD_OK == $self->command($pass)->response;
 171 }
 172
 173 package main;
 174
 175 my ($debug_flag, %recent);
 176
 177 my $ex_host = git_config('cidaemon.smtpHost') || 'localhost';
 178 my $ex_user = git_config('cidaemon.smtpUser');
 179 my $ex_pass = git_config('cidaemon.smtpPassword');
 180
 181 my $ex_from_addr = git_config('cidaemon.email', 1);
 182 my $ex_from_name = git_config('cidaemon.name') || 'cidaemon';
 183
 184 my $scan_delay = git_config('cidaemon.scanDelay') || 60;
 185 my $recent_size = git_config('cidaemon.recentCache') || 100;
 186 my $tmpdir = git_config('cidaemon.tmpdir') || '/tmp';
 187 my $queue_name = git_config('cidaemon.queue', 1);
 188 my $queue_lock = "$queue_name.lock";
 189
 190 my @nocc_list;
 191 open GIT,'git config --get-all cidaemon.nocc|';
 192 while (<GIT>) {
 193         chop;
 194         push @nocc_list, $_;
 195 }
 196 close GIT;
 197
 198 sub nocc_author ($)
 199 {
 200         local $_ = shift;
 201         foreach my $pat (@nocc_list) {
 202                 return 1 if /$pat/;
 203         }
 204         0;
 205 }
 206
 207 sub input_echo ($)
 208 {
 209         my $prompt = shift;
 210
 211         local $| = 1;
 212         print $prompt;
 213         my $input = <STDIN>;
 214         chop $input;
 215         return $input;
 216 }
 217
 218 sub input_noecho ($)
 219 {
 220         my $prompt = shift;
 221
 222         my $end = sub {system('stty','echo');print "\n";exit};
 223         local $SIG{TERM} = $end;
 224         local $SIG{INT} = $end;
 225         system('stty','-echo');
 226
 227         local $| = 1;
 228         print $prompt;
 229         my $input = <STDIN>;
 230         system('stty','echo');
 231         print "\n";
 232         chop $input;
 233         return $input;
 234 }
 235
 236 sub rfc2822_date ()
 237 {
 238          strftime("%a, %d %b %Y %H:%M:%S %Z", localtime);
 239 }
 240
 241 sub send_email ($$$)
 242 {
 243         my ($subj, $body, $to) = @_;
 244         my $now = rfc2822_date;
 245         my $to_str = '';
 246         my @rcpt_to;
 247         foreach (@$to) {
 248                 my $s = $_;
 249                 $s =~ s/^/"/;
 250                 $s =~ s/(\s+<)/"$1/;
 251                 $to_str .= ', ' if $to_str;
 252                 $to_str .= $s;
 253                 push @rcpt_to, $1 if $s =~ /<(.*)>/;
 254         }
 255         die "Nobody to send to.\n" unless @rcpt_to;
 256         my $msg = <<EOF;
 257 From: "$ex_from_name" <$ex_from_addr>
 258 To: $to_str
 259 Date: $now
 260 Subject: $subj
 261
 262 $body
 263 EOF
 264
 265         my $smtp = EXCHANGE_NET_SMTP->new(Host => $ex_host)
 266                 or die "Cannot connect to $ex_host: $!\n";
 267         if ($ex_user && $ex_pass) {
 268                 $smtp->auth($ex_user,$ex_pass)
 269                         or die "$ex_host rejected $ex_user\n";
 270         }
 271         $smtp->mail($ex_from_addr)
 272                 or die "$ex_host rejected $ex_from_addr\n";
 273         scalar($smtp->recipient(@rcpt_to, { SkipBad => 1 }))
 274                 or die "$ex_host did not accept any addresses.\n";
 275         $smtp->data($msg)
 276                 or die "$ex_host rejected message data\n";
 277         $smtp->quit;
 278 }
 279
 280 sub pop_queue ()
 281 {
 282         open LOCK, ">$queue_lock" or die "Can't open $queue_lock: $!";
 283         flock LOCK, LOCK_EX;
 284
 285         my $queue = -f $queue_name ? retrieve $queue_name : [];
 286         my $ent = shift @$queue;
 287         nstore $queue, $queue_name;
 288
 289         flock LOCK, LOCK_UN;
 290         close LOCK;
 291         $ent;
 292 }
 293
 294 sub git_exec (@)
 295 {
 296         system('git',@_) == 0 or die "Cannot git " . join(' ', @_) . "\n";
 297 }
 298
 299 sub git_val (@)
 300 {
 301         open(C, '-|','git',@_);
 302         my $r = <C>;
 303         chop $r if $r;
 304         close C;
 305         $r;
 306 }
 307
 308 sub do_build ($$)
 309 {
 310         my ($git_dir, $new) = @_;
 311
 312         my $tmp = File::Spec->catfile($tmpdir, "builder$$");
 313         system('rm','-rf',$tmp) == 0 or die "Cannot clear $tmp\n";
 314         die "Cannot clear $tmp.\n" if -e $tmp;
 315
 316         my $result = 1;
 317         eval {
 318                 my $command;
 319                 {
 320                         local $ENV{GIT_DIR} = $git_dir;
 321                         $command = git_val 'config','builder.command';
 322                 }
 323                 die "No builder.command for $git_dir.\n" unless $command;
 324
 325                 git_exec 'clone','-n','-l','-s',$git_dir,$tmp;
 326                 chmod 0700, $tmp or die "Cannot lock $tmp\n";
 327                 chdir $tmp or die "Cannot enter $tmp\n";
 328
 329                 git_exec 'update-ref','HEAD',$new;
 330                 git_exec 'read-tree','-m','-u','HEAD','HEAD';
 331                 system $command;
 332                 if ($? == -1) {
 333                         print STDERR "failed to execute '$command': $!\n";
 334                         $result = 1;
 335                 } elsif ($? & 127) {
 336                         my $sig = $? & 127;
 337                         print STDERR "'$command' died from signal $sig\n";
 338                         $result = 1;
 339                 } else {
 340                         my $r = $? >> 8;
 341                         print STDERR "'$command' exited with $r\n" if $r;
 342                         $result = $r;
 343                 }
 344         };
 345         if ($@) {
 346                 $result = 2;
 347                 print STDERR "$@\n";
 348         }
 349
 350         chdir '/';
 351         system('rm','-rf',$tmp);
 352         rmdir $tmp;
 353         $result;
 354 }
 355
 356 sub build_failed ($$$$$)
 357 {
 358         my ($git_dir, $ref, $old, $new, $msg) = @_;
 359
 360         $git_dir =~ m,/([^/]+)$,;
 361         my $repo_name = $1;
 362         $ref =~ s,^refs/(heads|tags)/,,;
 363
 364         my %authors;
 365         my $shortlog;
 366         my $revstr;
 367         {
 368                 local $ENV{GIT_DIR} = $git_dir;
 369                 my @revs = ($new);
 370                 push @revs, '--not', @$old if @$old;
 371                 open LOG,'-|','git','rev-list','--pretty=raw',@revs;
 372                 while (<LOG>) {
 373                         if (s/^(author|committer) //) {
 374                                 chomp;
 375                                 s/>.*$/>/;
 376                                 $authors{$_} = 1 unless nocc_author $_;
 377                         }
 378                 }
 379                 close LOG;
 380                 open LOG,'-|','git','shortlog',@revs;
 381                 $shortlog .= $_ while <LOG>;
 382                 close LOG;
 383                 $revstr = join(' ', @revs);
 384         }
 385
 386         my @to = sort keys %authors;
 387         unless (@to) {
 388                 print STDERR "error: No authors in $revstr\n";
 389                 return;
 390         }
 391
 392         my $subject = "[$repo_name] $ref : Build Failed";
 393         my $body = <<EOF;
 394 Project: $git_dir
 395 Branch:  $ref
 396 Commits: $revstr
 397
 398 $shortlog
 399 Build Output:
 400 --------------------------------------------------------------
 401 $msg
 402 EOF
 403         send_email($subject, $body, \@to);
 404 }
 405
 406 sub run_build ($$$$)
 407 {
 408         my ($git_dir, $ref, $old, $new) = @_;
 409
 410         if ($debug_flag) {
 411                 my @revs = ($new);
 412                 push @revs, '--not', @$old if @$old;
 413                 print "BUILDING $git_dir\n";
 414                 print "  BRANCH: $ref\n";
 415                 print "  COMMITS: ", join(' ', @revs), "\n";
 416         }
 417
 418         local(*R, *W);
 419         pipe R, W or die "cannot pipe builder: $!";
 420
 421         my $builder = fork();
 422         if (!defined $builder) {
 423                 die "cannot fork builder: $!";
 424         } elsif (0 == $builder) {
 425                 close R;
 426                 close STDIN;open(STDIN, '/dev/null');
 427                 open(STDOUT, '>&W');
 428                 open(STDERR, '>&W');
 429                 exit do_build $git_dir, $new;
 430         } else {
 431                 close W;
 432                 my $out = '';
 433                 $out .= $_ while <R>;
 434                 close R;
 435                 waitpid $builder, 0;
 436                 build_failed $git_dir, $ref, $old, $new, $out if $?;
 437         }
 438
 439         print "DONE\n\n" if $debug_flag;
 440 }
 441
 442 sub daemon_loop ()
 443 {
 444         my $run = 1;
 445         my $stop_sub = sub {$run = 0};
 446         $SIG{HUP} = $stop_sub;
 447         $SIG{INT} = $stop_sub;
 448         $SIG{TERM} = $stop_sub;
 449
 450         mkdir $tmpdir, 0755;
 451         my $pidfile = File::Spec->catfile($tmpdir, "cidaemon.pid");
 452         open(O, ">$pidfile"); print O "$$\n"; close O;
 453
 454         while ($run) {
 455                 my $ent = pop_queue;
 456                 if ($ent) {
 457                         my ($git_dir, $ref, $old, $new) = @$ent;
 458
 459                         $ent = $recent{$git_dir};
 460                         $recent{$git_dir} = $ent = [[], {}] unless $ent;
 461                         my ($rec_arr, $rec_hash) = @$ent;
 462                         next if $rec_hash->{$new}++;
 463                         while (@$rec_arr >= $recent_size) {
 464                                 my $to_kill = shift @$rec_arr;
 465                                 delete $rec_hash->{$to_kill};
 466                         }
 467                         push @$rec_arr, $new;
 468
 469                         run_build $git_dir, $ref, $old, $new;
 470                 } else {
 471                         sleep $scan_delay;
 472                 }
 473         }
 474
 475         unlink $pidfile;
 476 }
 477
 478 $debug_flag = 0;
 479 GetOptions(
 480         'debug|d' => \$debug_flag,
 481         'smtp-user=s' => \$ex_user,
 482 ) or die "usage: $0 [--debug] [--smtp-user=user]\n";
 483
 484 $ex_pass = input_noecho("$ex_user SMTP password: ")
 485         if ($ex_user && !$ex_pass);
 486
 487 if ($debug_flag) {
 488         daemon_loop;
 489         exit 0;
 490 }
 491
 492 my $daemon = fork();
 493 if (!defined $daemon) {
 494         die "cannot fork daemon: $!";
 495 } elsif (0 == $daemon) {
 496         close STDIN;open(STDIN, '/dev/null');
 497         close STDOUT;open(STDOUT, '>/dev/null');
 498         close STDERR;open(STDERR, '>/dev/null');
 499         daemon_loop;
 500         exit 0;
 501 } else {
 502         print "Daemon $daemon running in the background.\n";
 503 }