Merge branch 'master' of git://repo.or.cz/alt-git
[git/mingw.git] / contrib / continuous / cidaemon
blob4009a151deceb45030fb26c5bfcf1b75a423a493
1 #!/usr/bin/perl
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.
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.
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.
17 # To use multiple daemons on the same system, give them each a
18 # unique queue file and tmpdir.
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.
26 # cidaemon.smtpHost
27 # Hostname of the SMTP server the daemon will send email
28 # through. Defaults to 'localhost'.
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.
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.
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.
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.
54 # cidaemon.name
55 # Human friendly name that the daemon will send emails as.
56 # Defaults to 'cidaemon'.
58 # cidaemon.scanDelay
59 # Number of seconds to sleep between polls of the queue file.
60 # Defaults to 60.
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.
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'.
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.
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.
84 # Per Repository Config
85 # ----------------------
86 # Read from the source repository's config file.
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.
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.
99 # builder.skip
100 # Perl regex patterns of refs that should not be sent to
101 # cidaemon. Updates of these refs will be ignored.
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.
112 local $ENV{PATH} = join ':', qw(
113 /opt/git/bin
114 /usr/bin
115 /bin
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);
128 sub git_config ($;$)
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;
141 package EXCHANGE_NET_SMTP;
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.
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';
154 sub new
156 my $self = shift;
157 my $type = ref($self) || $self;
158 $type->SUPER::new(@_);
161 sub auth
163 my $self = shift;
164 return $self->SUPER::auth(@_) unless $auth_type eq 'login';
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;
173 package main;
175 my ($debug_flag, %recent);
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');
181 my $ex_from_addr = git_config('cidaemon.email', 1);
182 my $ex_from_name = git_config('cidaemon.name') || 'cidaemon';
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";
190 my @nocc_list;
191 open GIT,'git config --get-all cidaemon.nocc|';
192 while (<GIT>) {
193 chop;
194 push @nocc_list, $_;
196 close GIT;
198 sub nocc_author ($)
200 local $_ = shift;
201 foreach my $pat (@nocc_list) {
202 return 1 if /$pat/;
207 sub input_echo ($)
209 my $prompt = shift;
211 local $| = 1;
212 print $prompt;
213 my $input = <STDIN>;
214 chop $input;
215 return $input;
218 sub input_noecho ($)
220 my $prompt = shift;
222 my $end = sub {system('stty','echo');print "\n";exit};
223 local $SIG{TERM} = $end;
224 local $SIG{INT} = $end;
225 system('stty','-echo');
227 local $| = 1;
228 print $prompt;
229 my $input = <STDIN>;
230 system('stty','echo');
231 print "\n";
232 chop $input;
233 return $input;
236 sub rfc2822_date ()
238 strftime("%a, %d %b %Y %H:%M:%S %Z", localtime);
241 sub send_email ($$$)
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 =~ /<(.*)>/;
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
262 $body
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";
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;
280 sub pop_queue ()
282 open LOCK, ">$queue_lock" or die "Can't open $queue_lock: $!";
283 flock LOCK, LOCK_EX;
285 my $queue = -f $queue_name ? retrieve $queue_name : [];
286 my $ent = shift @$queue;
287 nstore $queue, $queue_name;
289 flock LOCK, LOCK_UN;
290 close LOCK;
291 $ent;
294 sub git_exec (@)
296 system('git',@_) == 0 or die "Cannot git " . join(' ', @_) . "\n";
299 sub git_val (@)
301 open(C, '-|','git',@_);
302 my $r = <C>;
303 chop $r if $r;
304 close C;
308 sub do_build ($$)
310 my ($git_dir, $new) = @_;
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;
316 my $result = 1;
317 eval {
318 my $command;
320 local $ENV{GIT_DIR} = $git_dir;
321 $command = git_val 'config','builder.command';
323 die "No builder.command for $git_dir.\n" unless $command;
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";
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;
345 if ($@) {
346 $result = 2;
347 print STDERR "$@\n";
350 chdir '/';
351 system('rm','-rf',$tmp);
352 rmdir $tmp;
353 $result;
356 sub build_failed ($$$$$)
358 my ($git_dir, $ref, $old, $new, $msg) = @_;
360 $git_dir =~ m,/([^/]+)$,;
361 my $repo_name = $1;
362 $ref =~ s,^refs/(heads|tags)/,,;
364 my %authors;
365 my $shortlog;
366 my $revstr;
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 $_;
379 close LOG;
380 open LOG,'-|','git','shortlog',@revs;
381 $shortlog .= $_ while <LOG>;
382 close LOG;
383 $revstr = join(' ', @revs);
386 my @to = sort keys %authors;
387 unless (@to) {
388 print STDERR "error: No authors in $revstr\n";
389 return;
392 my $subject = "[$repo_name] $ref : Build Failed";
393 my $body = <<EOF;
394 Project: $git_dir
395 Branch: $ref
396 Commits: $revstr
398 $shortlog
399 Build Output:
400 --------------------------------------------------------------
401 $msg
403 send_email($subject, $body, \@to);
406 sub run_build ($$$$)
408 my ($git_dir, $ref, $old, $new) = @_;
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";
418 local(*R, *W);
419 pipe R, W or die "cannot pipe builder: $!";
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 $?;
439 print "DONE\n\n" if $debug_flag;
442 sub daemon_loop ()
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;
450 mkdir $tmpdir, 0755;
451 my $pidfile = File::Spec->catfile($tmpdir, "cidaemon.pid");
452 open(O, ">$pidfile"); print O "$$\n"; close O;
454 while ($run) {
455 my $ent = pop_queue;
456 if ($ent) {
457 my ($git_dir, $ref, $old, $new) = @$ent;
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};
467 push @$rec_arr, $new;
469 run_build $git_dir, $ref, $old, $new;
470 } else {
471 sleep $scan_delay;
475 unlink $pidfile;
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";
484 $ex_pass = input_noecho("$ex_user SMTP password: ")
485 if ($ex_user && !$ex_pass);
487 if ($debug_flag) {
488 daemon_loop;
489 exit 0;
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";