~lamont/launchpad-buildd/wanna-build

#! /usr/bin/perl
#
# rbuilder: build packages on demand
# Copyright (C) 1999 Roman Hodek <Roman.Hodek@informatik.uni-erlangen.de>
#
# This program is free software; you can redistribute it and/or
# modify it under the terms of the GNU General Public License as
# published by the Free Software Foundation; either version 2 of the
# License, or (at your option) any later version.
#
# This program is distributed in the hope that it will be useful, but
# WITHOUT ANY WARRANTY; without even the implied warranty of
# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
# General Public License for more details.
#
# You should have received a copy of the GNU General Public License
# along with this program; if not, write to the Free Software
# Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
#
# $Id: rbuilder,v 1.11 2001/12/17 10:05:02 rnhodek Exp $
#
# $Log: rbuilder,v $
# Revision 1.11  2001/12/17 10:05:02  rnhodek
# Read ~/rbuilder.conf config file.
# Use $sshcmd, $wanna_build_user, $wanna_build_dbbase from config file
# similar to buildd (to access a remote db).
#
# Revision 1.10  2000/06/28 08:06:45  rnhodek
# Changed name 'rbuild' in mail addr. etc. to 'rbuilder'.
#
# Revision 1.9  2000/06/09 12:50:43  rnhodek
# Turn back on that packages are taken by wanna-build; to avoid
# problems, don't give them back on failures.
# Change syntax: separate package name+version from FTP source; this is
# necessary for packages with epochs (no epoch in .dsc filename!).
# If none of the required fields is defined, reply with a general help
# message.
# Handle chrooted builds: copy chroot-DIST links to build dir.
#
# Revision 1.8  1999/07/28 15:48:52  rnhodek
# Don't use wanna-build anymore at all -- it caused too many problems
# (the code is still there, but deactivated by $main::use_wb = 0).
# Don't remove the build dir if upload failed or on .changes
# inconsistencies.
#
# Revision 1.7  1999/07/23 12:40:48  rnhodek
# If the package can't be built or uploaded, give it back later.
#
# Revision 1.6  1999/07/09 14:07:26  rnhodek
# Maintain a file "builders" which maps package_version to a mail addr
# of the person who requested the build.
# If rbuilder receives an old-build mail from wanna-build, try forward
# it to the person who requested the build (addr taken from "builders" file.)
#
# Revision 1.5  1999/06/18 09:37:30  rnhodek
# Added GnuPG support:
#   Now two keyrings (rbuilder-keyring.{pgp,gpg}.
#   If PGP installed and keyring exists, first try PGP; if returns 0
#   status or some comment about the signature, don't try gpg.
#   Otherwise try verifying gpg.
#
# Revision 1.4  1999/06/14 13:18:38  rnhodek
# Fix silly syntax error ($main::wanna-build instead of $main::wanna_build).
# Keep logs in a logs/ dir until they're 100 days old; don't delete them
# after building, because they might be useful for debugging etc.
# In error replies, qoute the original mail (new arg "QUOTE" to reply()).
# If taking the package with wanna-build fails, report wanna-builds
# messages to the user in the reply and the log.
#
# Revision 1.3  1999/05/31 11:33:56  rnhodek
# Remove calls to symlinks of wanna-build (list-needs-build, build-info etc.)
# and use wanna-build itself with appropriate option instead (this removes the
# necessity to have the symlinks; you may still want them for typing
# convenience...)
# Remove assumption that wanna-build & Co. are installed in /usr/local; remove
# absolute paths where possible and otherwise search for it in /usr/local/bin
# and /usr/bin.
# do-merge-*: Remove hardcoded /usr/local/var/debbuild path; extract the path
# from /etc/wanna-build-conf.
#
# Revision 1.2  1999/04/26 09:28:19  rnhodek
# Now can also parse mails signed with MIME/PGP.
#
# Revision 1.1  1999/03/01 13:16:41  rnhodek
# Initial writing.
#
#

use strict;
use Net::FTP;
use File::Basename;

$ENV{'PATH'} = "/bin:/usr/bin:/usr/local/bin";
($main::HOME = $ENV{'HOME'})
	or die "HOME not defined in environment!\n";
$main::tempfile = "/bin/tempfile";
$main::wanna_build = -f "/usr/local/bin/wanna-build" ?
	"/usr/local/bin/wanna-build" : "/usr/bin/wanna-build";
$main::sbuild = -f "/usr/local/bin/sbuild" ?
	"/usr/local/bin/sbuild" : "/usr/bin/sbuild";
$main::pgp = "/usr/bin/pgp";
$main::gpg = "/usr/bin/gpg";
$main::cp = "/bin/cp";
$main::date = "/bin/date";
$main::sendmail = "/usr/sbin/sendmail";
$main::pgp_keyring = "$main::HOME/rbuilder-keyring.pgp";
$main::gpg_keyring = "$main::HOME/rbuilder-keyring.gpg";
$main::builders_file = "$main::HOME/builders";

require "$main::HOME/rbuilder.conf" if -r "$main::HOME/rbuilder.conf";

my $ftp_retry = 10;
my $ftp_try_wait = 30*60;

chomp( $main::hostname = `/bin/hostname --fqdn` );
chomp( $main::arch = `/usr/bin/dpkg --print-architecture` );

# using wanna-build is ok again, just don't give packages back...
$main::use_wb = 1;

open( STDOUT, ">>$main::HOME/log" );
open( STDERR, ">&STDOUT" );
$| = 1; select( (select( STDERR ), $| = 1)[0] );

fatal( "Usage: $0 mailfile" ) if !@ARGV;
my $file = "$main::HOME/$ARGV[0]";
fatal( "$file not readable" ) if !-r $file;
$main::mail_file = $file;

my $in_headers = 1;
my ($lastheader, $from_addr, $reply_to, $body_text);
open( F, "<$file" ) or fatal( "Cannot open $file: $!" );
while( <F> ) {
	if (!$in_headers) {
		$body_text .= $_;
		next;
	}
	chomp;
	if (/^$/) {
		$in_headers = 0;
		next;
	}
	elsif (/^\s/ && $lastheader) {
		s/^\s+//;
		$_ = "$lastheader $_";
	}
	if (/^From:\s*/i) {
		$main::from_addr = $';
		chomp( $lastheader = $_ );
	}
	elsif (/^To:\s*/i) {
		$main::to_addr = $';
		chomp( $lastheader = $_ );
	}
	elsif (/^Date:\s*/i) {
		$main::mail_date = $';
		chomp( $lastheader = $_ );
	}
	elsif (/^Reply-To:\s*/i) {
		$main::reply_to = $';
		chomp( $lastheader = $_ );
	}
	elsif (/^Subject:\s*/i) {
		$main::subject = $';
		chomp( $lastheader = $_ );
	}
	elsif (/^Message-Id:\s*/i) {
		$main::msgid = $';
		chomp( $lastheader = $_ );
	}
	elsif (/^Content-Type:\s*/i) {
		$main::content_type = $';
		chomp( $lastheader = $_ );
	}
	else {
		$lastheader = "";
	}
}
close( F );
logger( "-"x50, "\nMail from: $main::from_addr\n" );
$main::reply_addr = $main::reply_to || $main::from_addr;
fatal( "No reply address known!" ) if !$main::reply_addr;

if ($main::subject =~ /^Old build of (\S+) \(dist=\S+\)$/) {
	my $pkg = $1;
	my $reply = get_builder( $pkg ) || $main::reply_addr;
	forward( $reply, $body_text );
	logger( "Was old-build mail; forwarded to $reply\n" );
	unlink( $file );
	exit 0;
}

my $signator;
fatal( "Your message cannot be processed because it is not ".
	   "signed with PGP." )
	 if !($signator = pgp_check( $file ));
fatal( "The signator of this message is unknown and\n".
		"not authorized to use rbuilder." )
	if $signator eq "unknown signator";

my ($pkgv, $ftpdir, $dists, @dists, $upload_to);
$body_text =~ /^build\s+(.+)\s*$/m and $pkgv = $1;
$body_text =~ /^fetch(\s+from)?\s+(\S+)\s*$/m and $ftpdir = $2;
$body_text =~ /^distributions\s+(.+)\s*$/m and $dists = $1;
$body_text =~ /^upload(\s+to)?\s+(\S+)\s*$/m and $upload_to = $2;

# general help message if none if the fields is defined
fatal( "This message isn't formatted like a request to rbuilder. The ".
	   "format would be:\n".
	   "  build PACKAGE_VERSION\n".
	   "  fetch from FTP-URL\n".
	   "  distributions DIST-LIST\n".
	   "  upload to FTP-URL\n".
	   "The VERSION in build's argument must include an epoch (if ".
	   "applicable),\n".
	   "even if the epoch isn't in the filename of the .dsc file.\n".
	   "Both FTP-URLs should point to directories. In the fetch directory ".
	   "there\n".
	   "should be at least a .dsc file for the package. The upload ".
	   "directory must\n".
	   "allow anonymous FTP uploads.\n".
	   "The DIST-LIST must contain only the words stable, frozen, or ".
	   "unstable.\n"
	   )
	if !$pkgv && !$ftpdir && !$dists && !$upload_to;

fatal( "Cannot see which package to build.\n".
	   "Syntax:\n".
	   "  build PACKAGE_VERSION (including epoch)\n" )
	if !$pkgv;
fatal( "build argument is not correctly formatted PACKAGE_VERSION\n" )
	if $pkgv !~ /^[a-zA-Z\d.+-]+_(\d+:)?[a-zA-Z\d.+-]+$/;
fatal( "Argument of fetch is not a proper URL\n" )
	if $ftpdir !~ m,^(ftp|http)://,;
if ($main::use_wb) {
	@dists = split( /\s+/, $dists );
	fatal( "Cannot see to build for which distributions.\n".
		   "Syntax:\n".
		   "  distributions [stable] [frozen] [unstable]\n" )
		if !@dists;
	foreach (@dists) {
		fatal( "Bad distribution: $_\n" )
			if !isin( $_, qw(stable frozen unstable));
	}
}
else {
	@dists = ("stable");
}
fatal( "Cannot see where to upload.\n".
	   "Syntax:\n".
	   "  upload ftp://SERVER/PATH\n" )
	if !$upload_to;
fatal( "Argument of upload is not a proper ftp URL\n" )
	if $upload_to !~ m,^ftp://([^/]+)(.*),;
my ($upload_host, $upload_dir) = ($1, $2);

logger( <<"EOF" );
Request from $signator
Reply address is $main::reply_addr
Build: $pkgv
FTP source: $ftpdir
Requested distributions: @dists
Upload to: $upload_to
EOF

my $package = "$ftpdir/$pkgv";

-d "logs" || mkdir( "logs", 0755 );
my $sbuild_date = `date +%Y%m%d-%H%M`;
chomp( $sbuild_date );
my $logfile = "logs/${pkgv}_${sbuild_date}";
open( STDOUT, ">$logfile" );
open( STDERR, ">&STDOUT" );
$| = 1; select( (select( STDERR ), $| = 1)[0] );

$main::builddir = "build-$$";
fatal( "Cannot mkdir $main::builddir" )
	if !mkdir( "$main::builddir", 0755 );
foreach (qw(stable frozen unstable)) {
	system "cp", "-a", "chroot-$_", "$main::builddir";
}
fatal( "Cannot chdir to $main::builddir: $!\n" )
	if !chdir( "$main::builddir" );

my @do_dists;
if ($main::use_wb) {
	my $dist;
	my %do_dists;
	my $wb_errs = "";
	foreach $dist (@dists) {
		next if $do_dists{$dist};
		if (open( PIPE, "$main::sshcmd wanna-build -v --take --dist=$dist ".
				  ($main::wanna_build_dbbase?"--database=$main::wanna_build_dbbase ":"").
				  ($main::wanna_build_user?"--user=$main::wanna_build_user ":"").
				  "$pkgv 2>&1 |" )) {
			while( <PIPE> ) {
				next if /^wanna-build Revision/ || /previous version failed/;
				if (/^\S+:\s*ok/) {
					$do_dists{$dist} = 1;
				}
				elsif (/^\S+:.*NOT OK/) {
					my $line1 = $_;
					my $nextline = <PIPE>;
					$nextline =~ s/^\s+//;
					my $t = "Can't take $pkgv for $dist:\n$line1$nextline\n";
					$wb_errs .= $t;
					print $t;
				}
				elsif (/^\S+:\s*Propagating new state Building also to (\S+) database/) {
					$do_dists{$1} = 1;
				}
				else {
					print $_;
				}
			}
			close( PIPE );
		}
		else {
			fatal( "Can't spawn wanna-build: $!\n" );
		}
	}
	foreach (qw(stable frozen unstable)) {
		push( @do_dists, $_ ) if $do_dists{$_};
	}
	fatal( "Cannot take package for any of the distributions!\n", $wb_errs )
		if !@do_dists;
	logger( "Taken for distributions: @do_dists\n" );
}
else {
	@do_dists = ("stable");
}

add_to_builders( $pkgv, $main::reply_addr );

system "$main::sbuild", "--nolog", "-m$signator",
	   "--dist=$do_dists[0]", "$package";
if ($?) {
	print "sbuild exited with error status $?\n";
	goto end;
}
logger( "Build of $pkgv finished\n" );

my $give_it_back = 0;
my $changes = "${pkgv}_$main::arch.changes";
if (!-f $changes) {
	print "changes file $changes does not exist after build -- no upload\n";
	$give_it_back = 1;
	goto end;
}
if (!open( F, "<$changes" )) {
	print "Cannot open $changes: $!\n";
	$give_it_back = 1;
	goto end;
}
my $changes_text;
{ local($/); undef $/; $changes_text = <F>; }
close( F );

if ($main::use_wb) {
	# change target distributions
	$changes_text =~ s/^Distribution:.*$/Distribution: @do_dists/m;
	open( F, ">$changes" )
		or fatal( "Cannot open $changes for overwriting: $!" );
	print F $changes_text;
	close( F );
}

$changes_text =~ /^Files:\s*\n((^[ 	]+.*\n)*)/m;
my @filelines = split( "\n", $1 );
my @files;
foreach (@filelines) {
	my $f = (split( /\s+/, $_ ))[5];
	if (!-f $f) {
		print "File $f mentioned in .changes does not exist -- no upload\n";
		$give_it_back = 1;
		$main::no_remove = 1;
		goto end;
	}
	push( @files, $f );
}
push( @files, $changes );

for(;;) {
	last if upload();
	if (--$ftp_retry < 0) {
		print "Too many upload failures -- giving up.\n";
		$give_it_back = 1;
		$main::no_remove = 1;
		last;
	}
	print "FTP error -- waiting $ftp_try_wait seconds\n";
	sleep( $ftp_try_wait );
}

end:
# Do NOT give back failed packages! The build daemon would take it
# immediately again...
#if ($main::use_wb) {
#	 if ($give_it_back) {
#		 my $dist;
#		 foreach $dist (@do_dists) {
#			 system "$main::sshcmd wanna-build ".
#					($main::wanna_build_dbbase?"--database=$main::wanna_build_dbbase ":"").
#					($main::wanna_build_user?"--user=$main::wanna_build_user ":"").
#
#					"--give-back --dist=$dist $pkgv";
#		 }
#		 print "Given back $pkgv for distributions: @do_dists\n";
#	 }
#}

chdir( $main::HOME );
open( STDOUT, ">>$main::HOME/log" );
open( STDERR, ">&STDOUT" );
$| = 1; select( (select( STDERR ), $| = 1)[0] );

reply( "FILE", "$logfile" );

foreach (glob( "logs/*" )) {
	if (-M $_ > 100) {
		unlink( $_ );
		logger( "Removed old log file ", basename($_) ,"\n" );
	}
}

system( "rm -rf $main::builddir" ) if $main::builddir && !$main::no_remove;
unlink( $file );
exit 0;


sub upload {
	my $ftp;

	print "\nNow uploading files to ftp://$upload_host/$upload_dir\n";
	if (!($ftp = Net::FTP->new( $upload_host, timeout => 800, debug => 1 ))) {
		print "Cannot connect to $upload_host: $@\n";
		return 0;
	}
	if (!$ftp->login( "anonymous","rbuilder\@$main::hostname" )) {
		print "Cannot login to $upload_host: $@\n";
		return 0;
	}
	$ftp->binary();
	if (!$ftp->cwd( $upload_dir )) {
		print "Cannot cd to $upload_dir: $@\n";
		return 0;
	}
	foreach (@files) {
		next if $main::ftpdone{$_} eq "ok";
		my $rv;
		if ($main::ftpdone{$_} eq "maybe") {
			$rv = $ftp->append( $_ );
		}
		else {
			$rv = $ftp->put( $_ );
		}
		if (!$rv) {
			print "Cannot upload $_: $@\n";
			$main::ftpdone{$_} = "maybe";
			return 0;
		}
		print "Uploaded $_\n";
	}
	$ftp->quit();
	return 1;
}

sub pgp_check($) {
	my $file = shift;
	my $output = "";
	my $signator;
	my $is_tmpfile = 0;
	my $found = 0;
	my $stat;
	local( *PIPE );
	
	fatal( "No keyring (PGP or GnuPG) exists!" )
		if ! -f $main::pgp_keyring && ! -f $main::gpg_keyring;

	if ($main::content_type &&
		$main::content_type =~ m,multipart/signed, &&
		$main::content_type =~ /pgp/i &&
		(my ($bound) = ($main::content_type =~ /boundary=(\S+);/i))) {
		my $file2 = "$file.pgptmp";
		local( *F, *F2 );
		if (!open( F, "<$file" )) {
			fatal( "Can't open $file: $!" );
			return "LOCAL ERROR";
		}
		if (!open( F2, ">$file2" )) {
			fatal( "Can't open $file2: $!" );
			return "LOCAL ERROR";
		}
		my $state = 0;
		while( <F> ) {
			if (/^--\Q$bound\E(--)?$/) {
				if ($state == 0) {
					print F2 "-----BEGIN PGP SIGNED MESSAGE-----\n\n";
					$state = 1;
					next;
				}
				elsif ($state == 1) {
					while( ($_ = <F>) !~ /^---+BEGIN PGP SIGNATURE---+$/ ) {}
					$state = 2;
				}
				elsif ($state == 2) {
					next;
				}
			}
			print F2;
		}
		close( F2 );
		close( F );
		$file = $file2;
		$is_tmpfile = 1;
	}

	$stat = 1;
	if (-x $main::pgp && -f $main::pgp_keyring) {
		if (!open( PIPE, "$main::pgp -f +batchmode +verbose=0 ".
				   "+pubring=$main::pgp_keyring <'$file' 2>&1 >/dev/null |" )) {
			fatal( "Can't open pipe to $main::pgp: $!" );
			unlink( $file ) if $is_tmpfile;
			return "LOCAL ERROR";
		}
		$output .= $_ while( <PIPE> );
		close( PIPE );
		$stat = $?;
		$found = 1 if !$stat || $output =~ /^(good|bad) signature from/im
	}

	if (!$found && -x $main::gpg && -f $main::gpg_keyring) {
		if (!open( PIPE, "$main::gpg --no-options --batch ".
				   "--no-default-keyring --keyring $main::gpg_keyring ".
				   " --verify '$file' 2>&1 |" )) {
			fatal( "Can't open pipe to $main::gpg: $!" );
			unlink( $file ) if $is_tmpfile;
			return "LOCAL ERROR";
		}
		$output .= $_ while( <PIPE> );
		close( PIPE );
		$stat = $?;
	}

	unlink( $file ) if $is_tmpfile;
	return "" if $stat;
	$output =~ /^(gpg: )?good signature from (user )?"(.*)"\.?$/im;
	($signator = $3) ||= "unknown signator";
	return $signator;
}

sub reply {
	my $subject;
	my $quote = "";
	local( *MAIL, *F2 );

	if (!$main::reply_addr) {
		warn "no reply address set";
		return;
	}
	
	$main::no_reply = 1;
	if (!open( MAIL, "|$main::sendmail -t -oem" )) {
		fatal( "Could not open pipe to $conf::mail: $!" );
		goto out;
	}

	if (@_[0] eq "QUOTE") {
		shift @_;
		if (-f $main::mail_file && open( F2, "<$main::mail_file" )) {
			{ local($/); $quote = <F2>; }
			$quote =~ s/^/> /mg;
			close( F2 );
		}
	}
	
	$subject = $main::subject ? "Re: $main::subject" : "Re: your request";
	print MAIL <<"EOF";
From: $main::arch remote builder <rbuilder\@$main::hostname>
To: $main::reply_addr
Subject: $subject
EOF
	print MAIL "In-Reply-To: $main::msgid\n" if $main::msgid;
	print MAIL "\n";

	if ($_[0] eq "FILE") {
		open( F2, "<$_[1]" );
		while( <F2> ) { print MAIL $_; }
		close( F2 );
	}
	else {
		print MAIL @_;
	}
	print MAIL "\n$quote\n" if $quote;
	print MAIL "\nGreetings,\n\n\tYour $main::arch remote builder\n";
	if (!close( MAIL )) {
		fatal( "$main::sendmail failed (exit status ", $? >> 8, ")\n" );
		goto out;
	}

  out:
	$main::no_reply = 0;
}

sub forward {
	my $to = shift;
	my $body = shift;
	local( *MAIL );

	if (!open( MAIL, "|$main::sendmail -t -oem" )) {
		fatal( "Could not open pipe to $conf::mail: $!" );
		return;
	}

	print MAIL <<"EOF";
From: $main::from_addr
To: $main::to_addr
Resent-From: $main::arch remote builder <rbuilder\@$main::hostname>
Resent-To: $to
Subject: $main::subject
Date: $main::mail_date
Message-Id: $main::msgid

EOF
	print MAIL $body;

	if (!close( MAIL )) {
		fatal( "$main::sendmail failed (exit status ", $? >> 8, ")\n" );
		return;
	}
}

sub add_to_builders {
	my $pkg = shift;
	my $addr = shift;
	local( *FI, *FO );

	if (!open( FI, "<$main::builders_file" )) {
		logger( "Cannot open $main::builders_file: $!\n" );
		return;
	}
	if (!open( FO, ">$main::builders_file.new" )) {
		logger( "Cannot open $main::builders_file: $!\n" );
		close( FI );
		return;
	}

	while( <FI> ) {
		next if !/^(\S+)\s+(.*)$/;
		print FO $_ if $1 ne $pkg;
	}
	print FO "$pkg $addr\n";
	
	close( FI );
	close( FO );
	
	system "mv $main::builders_file.new $main::builders_file";
}

sub get_builder {
	my $pkg = shift;
	local( *F );
	
	if (!open( F, "<$main::builders_file" )) {
		logger( "Cannot open $main::builders_file: $!\n" );
		return "";
	}
	while( <F> ) {
		next if !/^(\S+)\s+(.*)$/;
		if ($1 eq $pkg) {
			close( F );
			return $2;
		}
	}
	close( F );
	return "";
}

sub fatal {
	logger( @_ );
	if ($main::reply_addr && !$main::no_reply) {
		reply( "QUOTE", "FATAL ERROR: ", @_, "\n" );
	}
	else {
		warn "wanna-build-mail: FATAL ERROR: ", @_, "\n";
	}

	chdir( $main::HOME );
	system( "rm -rf $main::builddir" ) if $main::builddir;
	unlink( $file );
	exit 1;
}

sub logger {
	local( *F );
	my( $str, @lines );
	my $date = `/bin/date '+%Y %b %d %H:%M:%S'`;
	chomp( $date );
	
	open( F, ">>$main::HOME/log" ) or return;
	foreach (@_) {
		$str .= $_;
	}
	@lines = split( "\n", $str );
	foreach (@lines) {
		print F "$date: ", $_, "\n";
	}
	close( F );
}

sub isin {
	my $val = shift;
	return grep( $_ eq $val, @_ );
}