Merge git://git.kernel.org/pub/scm/gitk/gitk
[git] / 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 }