sbuild 0.67.0-2ubuntu7 / usr / sbin / sbuild-createchroot

#!/usr/bin/perl
#
# Run debootstrap and add a few other files needed to create a working
# sbuild chroot.
# Copyright © 2004 Francesco P. Lovergine <frankie@debian.org>.
# Copyright © 2007-2010 Roger Leigh <rleigh@debian.org>.
#
# 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, see
# <http://www.gnu.org/licenses/>.
#
#######################################################################

use strict;
use warnings;

use Sbuild::AptResolver;

package Conf;

sub setup {
    my $conf = shift;

    my $keyring = '';
    $keyring = '/etc/apt/trusted.gpg'
	if -f '/etc/apt/trusted.gpg';

    my %createchroot_keys = (
	'CHROOT_SUFFIX'				=> {
	    DEFAULT => '-sbuild'
	},
	'FOREIGN'				=> {
	    DEFAULT => 0
	},
	'INCLUDE'				=> {
	    DEFAULT => ''
	},
	'EXCLUDE'				=> {
	    DEFAULT => ''
	},
	'COMPONENTS'				=> {
	    DEFAULT => 'main'
	},
	'RESOLVE_DEPS'				=> {
	    DEFAULT => 1
	},
	'KEEP_DEBOOTSTRAP_DIR'			=> {
	    DEFAULT => 0
	},
	'DEBOOTSTRAP'				=> {
	    DEFAULT => 'debootstrap'
	},
	'KEYRING'				=> {
	    DEFAULT => undef
	},
	'SETUP_ONLY'				=> {
	    DEFAULT => 0
	},
	'MAKE_SBUILD_TARBALL'				=> {
	    DEFAULT => ''
	},
	'KEEP_SBUILD_CHROOT_DIR'			=> {
	    DEFAULT => 0
	},
    );

    $conf->set_allowed_keys(\%createchroot_keys);
}

package Options;

use Sbuild::OptionsBase;
use Sbuild::Conf qw();

BEGIN {
    use Exporter ();
    our (@ISA, @EXPORT);

    @ISA = qw(Exporter Sbuild::OptionsBase);

    @EXPORT = qw();
}

sub set_options {
    my $self = shift;

    $self->add_options(
	"chroot-suffix=s" => sub {
	    $self->set_conf('CHROOT_SUFFIX', $_[1]);
	},
	"arch=s" => sub {
	    $self->set_conf('BUILD_ARCH', $_[1]);
	},
	"foreign" => sub {
	    $self->set_conf('FOREIGN', 1);
	},
	"resolve-deps" => sub {
	    $self->set_conf('RESOLVE_DEPS', 1)
	},
	"no-resolve-deps" => sub {
	    $self->set_conf('RESOLVE_DEPS', 0)
	},
	"keep-debootstrap-dir" => sub {
	    $self->set_conf('KEEP_DEBOOTSTRAP_DIR', 1)
	},
	"debootstrap=s" => sub {
	    $self->set_conf('DEBOOTSTRAP', $_[1])
	},
	"exclude=s" => sub {
	    $self->set_conf('EXCLUDE', $_[1]);
	},
	"include=s" => sub {
	    $self->set_conf('INCLUDE', $_[1]);
	},
	"components=s" => sub {
	    $self->set_conf('COMPONENTS', $_[1]);
	},
	"keyring=s" => sub {
	    $self->set_conf('KEYRING', $_[1]);
	},
	"setup-only" => sub {
	    $self->set_conf('SETUP_ONLY', 1);
	},
	"make-sbuild-tarball=s" => sub {
	    $self->set_conf('MAKE_SBUILD_TARBALL', $_[1]);
	},
	"keep-sbuild-chroot-dir" => sub {
	    $self->set_conf('KEEP_SBUILD_CHROOT_DIR', 1);
	});
}

package main;

use POSIX;
use Getopt::Long qw(:config no_ignore_case auto_abbrev gnu_getopt);
use Sbuild qw(dump_file help_text version_text usage_error check_packages);
use Sbuild::ChrootPlain;
use Sbuild::ChrootRoot;
use Sbuild::Sysconfig;
use Sbuild::Conf qw();
use File::Path qw(mkpath rmtree);
use File::Temp qw(tempfile);
use File::Copy;
use Cwd qw(abs_path);

sub add_items ($@);
sub makedir ($$);

my $conf = Sbuild::Conf::new();
Conf::setup($conf);
exit 1 if !defined($conf);
my $options = Options->new($conf, "sbuild-createchroot", "8");
exit 1 if !defined($options);


usage_error("sbuild-createchroot",
	    "Incorrect number of options") if (@ARGV <3 || @ARGV >4);

# Make sure fakeroot and build-essential are installed
$conf->set('INCLUDE', add_items($conf->get('INCLUDE'),
				"fakeroot",
				"build-essential"));

my $suite = $ARGV[0];

# check if schroot name is already in use

my $chrootname = "${suite}-" . $conf->get('BUILD_ARCH') . $conf->get('CHROOT_SUFFIX');

open my $pipe, 'schroot -q -l --all-source-chroots |';
while (my $line = <$pipe>) {
	$line ne "source:$chrootname\n" or die "chroot with name $chrootname already exists";
}
close $pipe;

# Create the target directory in advance so abs_path (which is buggy)
# won't fail.  Remove if abs_path is replaced by something better.
makedir($ARGV[1], 0755);
my $target = abs_path($ARGV[1]);
my $mirror = $ARGV[2];
my $script = undef;

$script = $ARGV[3] if $#ARGV == 3;

if ($conf->get('VERBOSE')) {
    print "I: SUITE: $suite\n";
    print "I: TARGET: $target\n";
    print "I: MIRROR: $mirror\n";
    print "I: SCRIPT: $script\n" if (defined($script));
}

my @args = ("--arch=" . $conf->get('BUILD_ARCH'),
	    "--variant=buildd");
push @args, "--verbose" if $conf->get('VERBOSE');
push @args, "--foreign" if $conf->get('FOREIGN');
push @args, "--keep-debootstrap-dir" if $conf->get('KEEP_DEBOOTSTRAP_DIR');
push @args, "--include=" . $conf->get('INCLUDE') if $conf->get('INCLUDE');
push @args, "--exclude=" . $conf->get('EXCLUDE') if $conf->get('EXCLUDE');
push @args, "--components=" . $conf->get('COMPONENTS')
    if $conf->get('COMPONENTS');
push @args, "--keyring=" . $conf->get('KEYRING') if $conf->get('KEYRING');
push @args, "--no-check-gpg" if ($conf->get('KEYRING') // "") eq "";
push @args, $conf->get('RESOLVE_DEPS') ?
    "--resolve-deps" : "--no-resolve-deps";
push @args, "$suite", "$target", "$mirror";
push @args, "$script" if $script;

# Set the path to debootstrap
my $debootstrap = $conf->get('DEBOOTSTRAP');

# Get the name of the debootstrap binary
my $debootstrap_bin = $debootstrap;
$debootstrap_bin =~ s/^.*\///s;

if ($conf->get('VERBOSE')) {
    print "I: Running $debootstrap_bin " . join(' ',@args) . "\n";
}

# Run debootstrap with specified options.
if (!$conf->get('SETUP_ONLY')) {
    !system($debootstrap, @args) or die "E: Error running $debootstrap_bin";
}

# Set up minimal /etc/hosts.
my $hosts = "${target}/etc/hosts";
open(HOSTS, ">$hosts")
    or die "Can't open $hosts for writing";
print HOSTS "127.0.0.1 " . $conf->get('HOSTNAME') . " localhost";
close HOSTS or die "Can't close $hosts";

# Display /etc/hosts.
print "I: Configured /etc/hosts:\n";
dump_file("$hosts");

# Set up minimal /usr/sbin/policy-rc.d.
my $policy_rc_d = "${target}/usr/sbin/policy-rc.d";
open(POLICY_RC_D, ">$policy_rc_d")
    or die "Can't open $policy_rc_d for writing";
print POLICY_RC_D <<"EOF";
#!/bin/sh
echo "All runlevel operations denied by policy" >&2
exit 101
EOF

close POLICY_RC_D or die "Can't close $policy_rc_d";

!system("chown", "root:", "$policy_rc_d")
    or die "E: Failed to set root: ownership on $policy_rc_d";
!system("chmod", "0775", "$policy_rc_d")
    or die "E: Failed to set 0755 permissions on $policy_rc_d";

# Display /usr/sbin/policy-rc.d.
print "I: Configured /usr/sbin/policy-rc.d:\n";
dump_file("$policy_rc_d");



# Set up minimal /etc/apt/sources.list
my $sources = "${target}/etc/apt/sources.list";
my $comps = join(' ',split(/,/,$conf->get('COMPONENTS')));
open(SOURCES, ">$sources")
    or die "Can't open $sources for writing";
print SOURCES "deb $mirror $suite $comps\n";
print SOURCES "deb-src $mirror $suite $comps\n";
close SOURCES or die "Can't close $sources";

# Display /etc/apt/sources.list.
print "I: Configured APT /etc/apt/sources.list:\n";
dump_file("${target}/etc/apt/sources.list");
print "I: Please add any additional APT sources to ${target}/etc/apt/sources.list\n";

# Write out schroot chroot configuration.

# Determine the schroot chroot configuration to use.
my $config_entry;
my $arch = $conf->get('BUILD_ARCH');
if ($conf->get('MAKE_SBUILD_TARBALL')) {
    my $tarball = $conf->get('MAKE_SBUILD_TARBALL');

    # Default to using tar gzip compression if unable to determine compression
    # mode via file extension.
    if ($tarball !~ /\.(tgz|tbz|tlz|txz|tar(\.(gz|bz2|lz|xz))?)$/) {
        print "I: Renaming sbuild tarball '$tarball' to '$tarball.tar.gz'\n";
        $tarball .= ".tar.gz";
        $conf->set('MAKE_SBUILD_TARBALL', $tarball);
    }

    $config_entry = <<"EOF";
[$chrootname]
type=file
description=Debian $suite/$arch autobuilder
file=$tarball
groups=root,sbuild
root-groups=root,sbuild
profile=sbuild
EOF
} else {
    $config_entry = <<"EOF";
[$chrootname]
type=directory
union-type=overlay
description=Debian $suite/$arch autobuilder
directory=$target
groups=root,sbuild
root-groups=root,sbuild
profile=sbuild
EOF
}

if (-d "/etc/schroot/chroot.d") {
    # TODO: Don't hardcode path
    my $SCHROOT_CONF =
	new File::Temp( TEMPLATE => "$chrootname-XXXXXX",
			DIR => "/etc/schroot/chroot.d",
			UNLINK => 0)
	or die "Can't open schroot configuration file: $!\n";

    print $SCHROOT_CONF "$config_entry";

    my ($personality, $personality_message);
    # Detect whether personality might be needed.
    if ($conf->get('ARCH') ne $conf->get('BUILD_ARCH')) {
	# Take care of the known case(s).
	if ($conf->get('BUILD_ARCH') eq 'i386' &&
	    $conf->get('ARCH') eq 'amd64') {
	    $personality='linux32';
	    $personality_message =
		"I: Added personality=$personality automatically (i386 on amd64).\n";
	} else {
	    $personality_message =
		"W: The selected architecture and the current architecture do not match\n" .
		"W: (" . $conf->get('BUILD_ARCH') . " versus " . $conf->get('ARCH') . ").\n" .
		"I: You probably need to add a personality option (see schroot(1)).\n" .
		"I: You may want to report your use case to the sbuild developers so that\n" .
		"I: the appropriate option gets automatically added in the future.\n\n";
	}
    }

    # Add personality if detected.
    print $SCHROOT_CONF "personality=$personality\n" if $personality;

    # Needed to display file below.
    $SCHROOT_CONF->flush();

    # Display schroot configuration.
    print "I: schroot chroot configuration written to $SCHROOT_CONF.\n";
    chmod 0644, "$SCHROOT_CONF";
    dump_file("$SCHROOT_CONF");
    print "I: Please rename and modify this file as required.\n";
    print $personality_message if $personality_message;
}

if (! -d "$Sbuild::Sysconfig::paths{'SBUILD_SYSCONF_DIR'}/chroot") {
    makedir("$Sbuild::Sysconfig::paths{'SBUILD_SYSCONF_DIR'}/chroot", 0775);
}

my $chrootlink = "$Sbuild::Sysconfig::paths{'SBUILD_SYSCONF_DIR'}/chroot/$chrootname";
if ((defined $chrootlink) && (! $conf->get('MAKE_SBUILD_TARBALL'))) {
    if (! -e $chrootlink) {
	if (symlink($target, $chrootlink)) {
	    print "I: sudo chroot configuration linked as $Sbuild::Sysconfig::paths{'SBUILD_SYSCONF_DIR'}/chroot/$chrootname.\n";
	} else {
	    print STDERR "E: Failed to symlink $target to $chrootlink: $!\n";
	}
    } else {
	print "W: Not creating symlink $target to $chrootlink: file already exists\n";

    }
}

# Add sbuild user and group to chroot
system("getent passwd sbuild >> '$target/etc/passwd'");
system("getent group sbuild >> '$target/etc/group'");

if ($conf->get('ARCH') eq $conf->get('HOST_ARCH')) {
    my $session = Sbuild::ChrootPlain->new($conf, $target);
    my $host = Sbuild::ChrootRoot->new($conf);
    if (defined($session)) {
	$session->set('Log Stream', \*STDOUT);

	if (!$session->begin_session() || !$host->begin_session()) {
	    print STDERR "E: Error creating chroot session: skipping apt update\n";
	} else {
	    my $resolver = Sbuild::AptResolver->new($conf, $session, $host);
	    $resolver->setup();

	    print "I: Setting reference package list.\n";
	    check_packages($session, "set");

	    print "I: Updating chroot.\n";
	    my $status = $resolver->update();
	    print "W: Failed to update APT package lists\n"
		if ($status);

	    $status = $resolver->distupgrade();
	    print "W: Failed to upgrade chroot\n"
		if ($status);

	    $resolver->cleanup();
	    $session->end_session();
	    $session = undef;
	}
    }
} else {
    print "W: The selected architecture and the current architecture do not match\n";
    print "W: (" . $conf->get('BUILD_ARCH') . " versus " . $conf->get('ARCH') . ").\n";
    print "W: Not automatically updating APT package lists.\n";
    print "I: Run \"apt-get update\" and \"apt-get dist-upgrade\" prior to use.\n";
    print "I: Run \"sbuild-checkpackages --set\" to set reference package list.\n";
}

# This block makes the tarball chroot if one has been requested and delete
# the sbuild chroot directory created, unless it's been requested to keep the
# directory.
if ($conf->get('MAKE_SBUILD_TARBALL')) {
    my ($tmpfh, $tmpfile) = tempfile("XXXXXX");
    my @program_list;

    # Change program arguments accordingly
    if ($conf->get('MAKE_SBUILD_TARBALL') =~ /\.tar$/) {
        @program_list = ("/bin/tar", "-cf", "$tmpfile", "-C", "$target", "./");
    } elsif ($conf->get('MAKE_SBUILD_TARBALL') =~ /(\.tar\.gz|\.tgz)$/) {
        @program_list = ("/bin/tar", "-czf", "$tmpfile", "-C", "$target", "./");
    } elsif ($conf->get('MAKE_SBUILD_TARBALL') =~ /(\.tar\.bz2|\.tbz)$/) {
        @program_list = ("/bin/tar", "-cjf", "$tmpfile", "-C", "$target", "./");
    } elsif ($conf->get('MAKE_SBUILD_TARBALL') =~ /(\.tar\.lz|\.tlz)$/) {
        @program_list = ("/bin/tar", "--lzma", "-cf", "$tmpfile", "-C", "$target", "./");
    } elsif ($conf->get('MAKE_SBUILD_TARBALL') =~ /(\.tar\.xz|\.txz)$/) {
        @program_list = ("/bin/tar", "-cJf", "$tmpfile", "-C", "$target", "./");
    }

    system(@program_list) == 0 or die "Could not create chroot tarball: $?\n";

    move("$tmpfile", $conf->get('MAKE_SBUILD_TARBALL'));
    chmod 0644, $conf->get('MAKE_SBUILD_TARBALL');
    if (! $conf->get('KEEP_SBUILD_CHROOT_DIR')) {
	rmtree("$target");
	print "I: chroot $target has been removed.\n";
    } else {
	print "I: chroot $target has been kept.\n";
    }
}

print "I: Successfully set up $suite chroot.\n";
print "I: Run \"sbuild-adduser\" to add new sbuild users.\n";

exit 0;

# Add items to the start of a comma-separated list, and remove the
# items from later in the list if they were already in the list.
sub add_items ($@) {
    my $items = shift;
    my @add = @_;

    my $ret = '';
    my %values;

    foreach (@_) {
	$values{$_} = '';
	$ret .= "$_,"
    }

    # Only add if not already used, to eliminate duplicates.
    foreach (split (/,/,$items)) {
	$ret .= "$_," if (!defined($values{$_}));
    }

    # Remove trailing comma.
    $ret =~ s/,$//;

    return $ret;
}

sub makedir ($$) {
    my $dir = shift;
    my $perms = shift;

    mkpath($dir,
	   { mode => $perms,
	     verbose => 1,
	     error => \my $error
	   });

    for my $diag (@$error) {
	my ($file, $message) = each %$diag;
	print "E: Can't make directory $file: $message\n";
    }
}