openbsd-ports/infrastructure/build/dpb

#!/usr/bin/perl -w

# $OpenBSD: dpb,v 1.11 2005/01/30 10:07:36 sturm Exp $
# Copyright (c) 2004 Nikolay Sturm <sturm@openbsd.org>.
#
# Redistribution and use in source and binary forms, with or without
# modification, are permitted provided that the following conditions
# are met:
# 1. Redistributions of source code must retain the above copyright
#    notice, this list of conditions and the following disclaimer.
# 2. Redistributions in binary form must reproduce the above copyright
#    notice, this list of conditions and the following disclaimer in the
#    documentation and/or other materials provided with the distribution.
#
# THIS SOFTWARE IS PROVIDED BY THE OPENBSD PROJECT AND CONTRIBUTORS
# ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
# LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR
# A PARTICULAR PURPOSE ARE DISCLAIMED.  IN NO EVENT SHALL THE OPENBSD
# PROJECT OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
# SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT
# LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,
# DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY
# THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT
# (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
# OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
#

use strict;
use File::Temp;
use Getopt::Std;

our $MAKE = "/usr/bin/make";
our $MAKEFLAGS = "BATCH=Yes BIN_PACKAGES=Yes BULK=Yes TRUST_PACKAGES=Yes";
our $PORTSDIR = $ENV{'PORTSDIR'} || "/usr/ports";
our $TMPDIR = $ENV{'PKG_TMPDIR'} || '/var/tmp';
our @SSH = ("/usr/bin/ssh", "-n");

# -A <Arch>: specify architecture of build hosts
# -b: force creation of dependency file
# -c: clean build, i.e. pkg_delete * before building a port
# -d: debug run, don't actually build any packages
# -e: perform expensive operations to get full dependency information in
#     order to optimize build order by package importance
# -F <Hosts File>: one host per line
# -L <Logdir>: use <Logdir> instead of $PORTSDIR/logs/$ARCH
# -S <SUBDIRLIST>: use <SUBDIRLIST> instead of all ports
# -s: build all packages in cwd
# -T <Dependency File>: use <Dependency File> instead of a temporary one
# -t <Timeout>: use this timeout instead of the default
our ($opt_A, $opt_b, $opt_c, $opt_d, $opt_e, $opt_F, $opt_L, $opt_S, $opt_s,
    $opt_T, $opt_t);
getopts('A:bcdeF:L:S:sT:t:');

our $ARCH;
if (defined $opt_A) {
	$ARCH = $opt_A;
} else {
	chomp($ARCH = `/usr/bin/arch -s`);
}

our $HOSTS_FILE = $opt_F || "$PORTSDIR/infrastructure/db/hosts-$ARCH";

our $LOGGER = "$PORTSDIR/infrastructure/build/portslogger ";
$LOGGER .= $opt_L || "$PORTSDIR/logs/$ARCH";

our $TIMEOUT = $opt_t || 60;
push @SSH, "-o ConnectTimeout=$TIMEOUT";


# per slave pid: node, port and retval
our $SLAVES = {};

# per port: slave pid
our $PORTS = {};

# dependency lists
our %depend_on = ();
our %prereqs_of = ();

# per node: fifo, host, pid, shell
our $NODES = {};

# per host: down, nodes, ssh_master
our $HOSTS = {};

our $FREE_NODES = {};
our @DOWN_HOSTS = ();

our $CHECK_HOSTS;
our $check_host_ctr = 0;

our @dead_slaves = ();

sub child_handler()
{
	while ((my $child = waitpid(-1,1)) > 0) {
		my $sig = ($? && 255);
		my $retval = ($? >> 8);

		# host/session died, retry build
		$retval = 255 if $sig > 0 and $retval == 0;
		
		if (defined $SLAVES->{$child}) {
			$SLAVES->{$child}{retval} = $retval;
			push(@dead_slaves, $child);
		} elsif (exists $CHECK_HOSTS->{$child}) {
			$CHECK_HOSTS->{$child} = $retval;
		}
	}
}

sub term_handler()
{
	local $SIG{CHLD} = "IGNORE";
	local $SIG{HUP}  = "IGNORE";
	local $SIG{INT}  = "IGNORE";
	local $SIG{TERM} = "IGNORE";

	foreach my $pid (keys %{$CHECK_HOSTS}, keys %{$SLAVES}) {
		kill INT => $pid;
	}
	
	clean_up(1);
}

sub my_exec($$)
{
	my ($args, $out) = @_;
	
	$SIG{HUP}  = "DEFAULT";
	$SIG{INT}  = "DEFAULT";
	$SIG{TERM} = "DEFAULT";

	open STDOUT, '>', "$out" or
	  die "Cannot redirect STDOUT: $!";
	open STDERR, ">&STDOUT" or
	  die "Cannot redirect STDERR: $!";

	exec @{$args};
	die "Cannot @{$args}: $!";
}

sub reap_slaves()
{
	while (my $c = pop @dead_slaves) {
		update_after_slave($c);
	}
}

sub mark_host_down($)
{
	my $host = shift;

	warn "*** lost $host\n";

	$HOSTS->{$host}{down} = 1;
	push(@DOWN_HOSTS, $host);

	foreach my $node (@{$HOSTS->{$host}{nodes}}) {
		my $nodepid = $NODES->{$node}{pid};

		if (defined $nodepid) {
			kill KILL => $nodepid ;
			child_handler();
			reap_slaves();
		}
		mark_node_down($node);
	}

	kill_ssh_master($host);
}

sub mark_node_down($)
{
	my $node = shift;
	my $nodepid = $NODES->{$node}{pid};

	# active node
	delete $NODES->{$node}{pid};
	delete $SLAVES->{$nodepid} if defined $nodepid;

	# free node
	delete $FREE_NODES->{$node};
}

sub mark_node_free($)
{
	my $node = shift;
	
	$FREE_NODES->{$node} = 1;
}

sub kill_ssh_master($)
{
	my $host = shift;
	my $ssh_mpid = $HOSTS->{$host}{ssh_master};
	
	if (defined $ssh_mpid) {
		kill INT => $ssh_mpid;
		delete $HOSTS->{$host}{ssh_master};
	}
}

sub start_ssh_master($)
{
	my $host = shift;
	my $pid = fork();
	die "fork: $!" unless defined $pid;

	if ($pid > 0) {
		# parent		
		while (not -e "$TMPDIR/ssh-$host") {
			# child died?
			return if ((my $child = waitpid($pid, 1)) > 0);
			
			sleep 1;
		}
		$HOSTS->{$host}{ssh_master} = $pid;
	} else {
		# child
		my @args = (@SSH, "-N", "-M", "-S", "$TMPDIR/ssh-$host",
			    "$host");
		my_exec(\@args, "/dev/null");
	}
}

sub clear_packages($)
{
	my $host = shift;
	my $pid = fork();
	
	die "fork: $!" unless defined $pid;

	if ($pid > 0) {
		# parent

		# just wait for pkg_delete to finish, we don't care
		# about anything else
		waitpid($pid, 0);
	} else {
		# child
		# beware of format, might not work with /bin/sh -c otherwise
		my @args = (@{$NODES->{"$host%0"}{shell}},
			    "/usr/bin/sudo /usr/sbin/pkg_delete -c -q /var/db/pkg/*");
		my_exec(\@args, "/dev/null");
	}
}

sub check_host($)
{
	my $host = shift;
	my $pid = fork();
	die "fork: $!" unless defined $pid;

	if ($pid > 0) {
		# parent
		my $begin = time();
		$CHECK_HOSTS->{$pid} = undef;
		child_handler();
		while (not defined $CHECK_HOSTS->{$pid}) {
			# give ssh a chance to timeout by itself
			if ($begin + $TIMEOUT + 2 > time()) {
				sleep(1);
			} else {
				# ssh did not terminate in time, kill it
				kill INT => $pid;
				return -1;
			}
			child_handler();
		}
		return $CHECK_HOSTS->{$pid};
	} else {
		# child
		my @args = (@SSH, "$host", "exit 0");
		my_exec(\@args, "/dev/null");
	}
}

sub check_hosts()
{
	# don't check hosts in debug mode and only every so often
	# in regular mode
	return if defined $opt_d or ($check_host_ctr++ % 60 != 0);

	foreach my $host (keys %{$HOSTS}) {
		next if ($host =~ /^localhost/);
		my $retval = check_host($host);

		if ($retval == 0 and $HOSTS->{$host}{down}) {
			warn "*** $host is back\n";
			start_ssh_master($host);
			foreach my $node (@{$HOSTS->{$host}{nodes}}) {
				mark_node_free($node);
			}
			delete $HOSTS->{$host}{down};
		} elsif ($retval !=0 and $HOSTS->{$host}{down}) {
			# host is still down, do nothing
		} elsif ($retval == 0 and not $HOSTS->{$host}{down}) {
			# host is still up
			start_ssh_master($host) if not -e "$TMPDIR/ssh-$host";
		} elsif ($retval != 0 and not $HOSTS->{$host}{down}) {
			# host is down
			mark_host_down($host);
		}
	}
}

sub update_after_slave($)
{
	my $pid = shift;
	return unless defined $SLAVES->{$pid};
	
	my $node = $SLAVES->{$pid}{node};
	my $port = $SLAVES->{$pid}{port};
	my $retval = $SLAVES->{$pid}{retval};

	delete $SLAVES->{$pid};
	delete $NODES->{$node}{pid};

	if ($retval == 0) {
		print "<== built $port\n";

		update_prereqs_of($port);
		delete $prereqs_of{$port};
	} elsif ($retval == 1) {
		print "<== failure building $port\n";

		remove_port($port);
	} elsif ($retval == 255) {
		warn "*** $node died with signal, retrying $port later.\n";
	} else {
		warn "*** Unexpected return code $retval from $node "
		    . "for $port.\n";

		remove_port($port);
	}
	delete $PORTS->{$port};
	mark_node_free($node);
}

sub find_free_node()
{
	while (1) {
		child_handler();
		reap_slaves();
		check_hosts();

		foreach my $n (keys %{$FREE_NODES}) {
			if (defined $FREE_NODES->{$n}) {
				delete $FREE_NODES->{$n};
				return $n;
			}
		}

		sleep(1);
	}
}

# we failed to build $port, thus no $dep can be build (recursive)
# if $dep is not build, it no longer depends on $pre
sub remove_port($);

sub remove_port($)
{
	my $port = shift;
	
	for (my $i = 0; $i <= $#{$depend_on{$port}}; $i++) {
		my $dep = ${$depend_on{$port}}[$i];
		foreach my $pre (@{$prereqs_of{$dep}}) {
			next if $pre eq $dep;
			remove_from_list(\@{$depend_on{$pre}}, $dep);
			$i-- if $pre eq $port;
		}
		remove_port($dep) unless $dep eq $port;
	}
	warn "*** will not build $port\n";
	delete $prereqs_of{$port};
	delete $depend_on{$port};
}

# generate full dependency information
# This is computational intensive!
sub push_dep($$);

sub push_dep($$)
{
	my ($a, $b) = @_;
	
	foreach my $depends_on_a (@{$depend_on{$a}}) {
		foreach my $prereq_of_b (@{$prereqs_of{$b}}) {
			my $gotcha = 0;

			foreach my $p (@{$prereqs_of{$depends_on_a}}) {
				if ($p eq $prereq_of_b) {
					$gotcha = 1;
					last;
				}
			}
			next unless $gotcha == 0;
			
			push_dep($depends_on_a, $prereq_of_b)
			  unless $depends_on_a eq $a and $prereq_of_b eq $b;
		}
	}
	push(@{$prereqs_of{$a}}, $b);
	push(@{$depend_on{$b}}, $a);
}

sub parse_dependency_file()
{
	open(my $fh, "sort -u $opt_T |") or die "Could not open $opt_T: $!";

 	while (<$fh>) {
 		chomp;
 		my ($a, $b) = split /\s+/;

		# ensure $a and $b are really port specs and not gibberish
		# category/{subcategory/}*port{\,flavor}*{\,-subpackage}
		my $borked = 0;
		foreach my $p ($a, $b) {
			if (not defined $p or $p eq "") {
				warn "*** empty port spec in deplist\n";
				$borked = 1;
				last;
			}
			if (not $p =~ /(\w*\/)+[-.\w]+(,\w+)*(,-[\w]+)*/) {
				warn "*** broken deplist entry: $p\n";
				$borked = 1;
			}
		}
		next if $borked == 1;

 		# ensure every port depends on itself, needed by build logic
 		# ports depending on the key
 		$depend_on{$a} = [$a] unless defined $depend_on{$a};
 		$depend_on{$b} = [$b] unless defined $depend_on{$b};
 		# ports, the key depends on
 		$prereqs_of{$a} = [$a] unless defined $prereqs_of{$a};
 		$prereqs_of{$b} = [$b] unless defined $prereqs_of{$b};

		if ($a ne $b) {
			if (defined $opt_e) {
				push_dep($a, $b);
			} else {
				push(@{$prereqs_of{$a}}, $b);
				push(@{$depend_on{$b}}, $a);
			}
		}
 	}
	close($fh);
}

sub parse_hosts_file()
{
	my $sysctl = "/sbin/sysctl -n hw.ncpu";

	open(my $fh, "<", $HOSTS_FILE) or die "Could not open $HOSTS_FILE: $!\n";

	while (<$fh>) {
		chomp;
		my $host = $_;
		my ($ncpu, $local);
		
		if (/^localhost/) {
			$ncpu = `$sysctl`;
			$local = 1;
		} else {
			$ncpu = `@SSH $host $sysctl`;
			$local = 0
		}

		if (not defined $ncpu or $ncpu eq "") {
			warn "*** Host $host does not answer, not using it.\n";
			next;
		} elsif ($ncpu > 1 and defined $opt_c) {
			$ncpu = 1;
			warn "*** Only using one node on $host due to '-c'\n";
		}

		$HOSTS->{$host}{nodes} = ();

		for (my $i = 0; $i < $ncpu; $i++) {
			my $node = "$host%$i";

			push @{$HOSTS->{$host}{nodes}}, $node;
			
			mark_node_free($node);
			$NODES->{$node}{fifo} =
			  "$TMPDIR/dpb-$node.log";
			$NODES->{$node}{host} = $host;
			if ($local == 1) {
				@{$NODES->{$node}{shell}} = ("/bin/sh", "-c");
			} else {
				@{$NODES->{$node}{shell}} =
				  (@SSH, "-S", "$TMPDIR/ssh-$host", "$host");
			}
		}
	}
	close($fh);
}

sub build_package($$$$)
{
	my ($node, $port, $flavor, $fullport) = @_;

	my $pid = fork();
	die "fork: $!" unless defined $pid;
	
	if ($pid > 0) {
		# parent
		$SLAVES->{$pid} = {};
		$SLAVES->{$pid}{node} = $node;
		$SLAVES->{$pid}{port} = $fullport;
		$SLAVES->{$pid}{retval} = undef;
		$PORTS->{$fullport} = $pid;
		$NODES->{$node}{pid} = $pid;

		return;
	} else {
		# child
		$SIG{HUP}  = "DEFAULT";
		$SIG{INT}  = "DEFAULT";
		$SIG{TERM} = "DEFAULT";
		$0 = "dpb [slave] - $port";

		print "==> building $port";
		print ", FLAVOR \"$flavor\"" if defined $flavor;
		print " on $node\n";

		if (defined $opt_d) {
			sleep(1);
		} else {
			my $arg = "cd $PORTSDIR/$port && ";
			$arg .= "FLAVOR=\"$flavor\" " if defined $flavor;
			$arg .= "$MAKE $MAKEFLAGS package";
			my @args = (@{$NODES->{$node}{shell}}, $arg);
			
			start_logger($node);
			clear_packages($NODES->{$node}{host}) if defined $opt_c;
			my_exec(\@args, "$NODES->{$node}{fifo}");
		}
		exit 0;
	}
}

sub update_prereqs_of($)
{
	my $port = shift;

	return unless defined @{$depend_on{$port}};

	# remove $port from lists of prerequisites
	foreach my $depending (@{$depend_on{$port}}) {
		next unless defined @{$prereqs_of{$depending}};
		remove_from_list(\@{$prereqs_of{$depending}}, $port);
	}
}

sub remove_from_list(\@$)
{
	my ($list, $entry) = @_;

	for (my $i = 0; $i <= $#{$list}; $i++) {
		if (${$list}[$i] eq $entry) {
			splice(@{$list}, $i, 1);
			$i--;
		}
	}
}

sub start_logger()
{
	my $node = shift;
	my $fifo = $NODES->{$node}{fifo};

	unless (-p $fifo) {
		system("mkfifo $fifo") and
		  die "Cannot create $fifo: $!";
	}
	
	my $pid = fork();
	die "fork: $!" unless defined $pid;

	if ($pid > 0) {
		# parent
		
		return;
	} else {
		# child
		# dies on its own on EOF
		my @args = ("$LOGGER < $fifo");
		my_exec(\@args, "/dev/null");
	}
}

sub clean_up($)
{
	# only remove self generated dependency file
	unlink($opt_T) if ref $opt_T;

	foreach my $node (keys %{$NODES}) {
		kill_ssh_master($NODES->{$node}{host});
		unlink($NODES->{$node}{fifo}) if -p $NODES->{$node}{fifo};
	}

	exit(shift);
}

# MAIN
$SIG{HUP}  = \&term_handler;
$SIG{INT}  = \&term_handler;
$SIG{TERM} = \&term_handler;
$0 = "dpb [master]";

# collect dependency data
if (defined $opt_b or not defined $opt_T or not -f $opt_T) {
	my $arg = "cd $PORTSDIR && $MAKE ";

	unless (defined $opt_T) {
		$opt_T = new File::Temp( TEMPLATE => 'all-depends.XXXXXXXXXX',
					 DIR => $TMPDIR,
					 UNLINK => 0 );
	}

	if (defined $opt_s and defined $opt_S) {
		die "-s and -S are mutually exclusive!";
	} elsif (defined $opt_s) {
		# cwd is somewhere in the ports tree, just build from here
		$arg = "$MAKE ";
	} elsif (defined $opt_S) {
		die "SUBDIRLIST $opt_S not found!" unless (-f $opt_S);
		$arg .= "SUBDIRLIST=$opt_S ";
	}

	$arg .= "ECHO_MSG=: all-dir-depends > $opt_T";
	
	print "==> creating dependency file\n";
	system($arg) and die "$MAKE all-dir-depends: $!";
} else {
	print "==> using dependency file $opt_T\n";
}

parse_dependency_file();
parse_hosts_file();

check_hosts();

my @keys_prereqs = (keys %prereqs_of);
my @keys_PORTS = ();
do {
	# sort ports by their importance, i.e. by the number of other
	# ports depending on them
	foreach my $k (sort {$#{$depend_on{$b}} <=> $#{$depend_on{$a}}}
	    @keys_prereqs) {
		# only compile ports that don't have unbuilt dependencies
		if ($#{$prereqs_of{$k}} == 0) {
			my $node = find_free_node();
			my ($port, $flavor);
			my @spec = split(/,/, $k);

			# do not try to build multiple SUBPACKAGEs of the same
			# port in parallel
			my $build_conflict = 0;
			
			$port = $spec[0];
			# a build for a different subpackage might be running
			foreach (keys %{$PORTS}) {
				my @key_spec = split(/,/);
				if ($port eq $key_spec[0]) {
					$build_conflict = 1;
				}
			}
			for (my $i = 1; $i <= $#spec; $i++) {
				if (not $spec[$i] =~ /^-/ and defined $flavor) {
					$flavor = join(" ", $flavor, $spec[$i]);
				} elsif (not $spec[$i] =~ /^-/) {
					$flavor = $spec[$i];
				}
			}

			if ($build_conflict == 0) {
				build_package($node, $port, $flavor, $k);
			} else {
				mark_node_free($node);
				next;
			}

			last;
		}
	}

	check_hosts();

	child_handler();
	reap_slaves();

	# create new key set, taking currently building ports into account
	@keys_PORTS = (keys %{$PORTS});
	@keys_prereqs = ();
	foreach my $k (keys %prereqs_of) {
		push(@keys_prereqs, $k) unless defined $PORTS->{$k};
	}
	
	sleep(1);
	
} while ($#keys_prereqs >= 0 or $#keys_PORTS >= 0);

print "==> done, cleaning up\n";
clean_up(0);