#!/bin/sh
#! -*-perl-*-
eval 'exec perl -x -S $0 ${1+"$@"}'
    if 0;
# Copyright (C) 2024 Sergey Poznyakoff <gray@gnu.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 3, 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 File::Spec;
use File::stat;
use File::Path qw(make_path);
use File::Copy;
use Pod::Usage;
use Pod::Man;
use Getopt::Long qw(:config gnu_getopt no_ignore_case);
use Data::Dumper;

my @binaries;
my @libfiles = (
    '/lib/x86_64-linux-gnu/libnss_files.so.2',
    '/lib/x86_64-linux-gnu/libnss_dns.so.2'
);
my @devfiles = qw(null);
my %libraries;
my %users;
my %groups;
my $verbose = 0;
my $chrootdir;

my @dirs = qw(bin lib dev etc home);
my %populate = (
    'bin' => \&populate_bin,
    'lib' => \&populate_lib,
    'dev' => \&populate_dev,
    'etc' => \&populate_etc,
    'home' => \&populate_home
);

#
# Auxiliary functions
#
sub resolve_lib {
    my $libname = shift;
    my $tgt = $libname;
    if (-l $libname) {
	$tgt = readlink($libname);
	if (!File::Spec->file_name_is_absolute($tgt)) {
	    $tgt = File::Spec->catfile((File::Spec->splitpath($libname))[1],
				       	$tgt);
	}
    } elsif (! -f $libname) {
	warn "$libname is neither regular file nor a symlink";
    }
    return $tgt
}

sub extract_libdeps {
    my ($bin) = @_;
    my @result;
    open(my $fh, '-|', 'ldd', $bin)
	or die "can't open $bin: $!";
    while (<$fh>) {
	chomp;
	if (m{^\s*(\S+\s*=>\s*)?(/\S+)\s+\(0x[[:xdigit:]]+\)$}) {
	    my $libname = $2;
	    my $tgt = resolve_lib($libname);
 	    $libraries{$tgt} = { libname => $libname, abs => !defined($1) }
	}
    }
    close $fh;
}

sub collect_binaries {
    print "$0: collecting binaries\n" if $verbose;
    foreach my $bin (@binaries) {
	extract_libdeps($bin)
    }
}

sub xcopy {
    my ($src, $dst) = @_;
    if ($verbose) {
	print "$0: copying $src => $dst\n";
    }
    my $sb = stat($src)
	or die "can't stat $src: $!\n";
    copy($src, $dst)
	or die "can't copy $src to $dst: $!\n";
    chmod($sb->mode, $dst)
	or die "can't set file mode of $dst: $!\n";
}

#
# Populate /bin
#
sub populate_bin {
    my ($dirname) = @_;
    foreach my $file (@binaries) {
	my (undef, $srcdir, $tgt) = File::Spec->splitpath($file);
	if (-l $file) {
	    my $src = readlink($file);
	    if (!File::Spec->file_name_is_absolute($src)) {
		$src = File::Spec->catfile($srcdir, $src);
	    }
	    xcopy($src, File::Spec->catfile($dirname, $tgt));
	} else {
	    xcopy($file, File::Spec->catfile($dirname, $tgt));
	}
    }
}

#
# Populate /lib
#
sub populate_lib {
    my ($dirname) = @_;
    while (my ($ref, $lib) = each %libraries) {
	if ($lib->{abs}) {
	    my (undef, $libdirname, $libname) =
		File::Spec->splitpath($lib->{libname});
	    $libdirname = File::Spec->catfile($chrootdir, $libdirname);
	    unless (-d $libdirname) {
		if ($verbose) {
		    print "$0: creating directory $libdirname\n";
		}
		make_path($libdirname, { mode => 0755 })
		    or die "can't create $libdirname: $!\n";
	    }
	    xcopy($lib->{libname}, File::Spec->catfile($libdirname, $libname));
	} else {
	    my (undef, undef, $libname) =
		File::Spec->splitpath($lib->{libname});
   	    xcopy($lib->{libname}, File::Spec->catfile($dirname, $libname));
	}
    }
}

#
# Populate /dev
#
sub str_to_mode {
    my $modestr = shift;
    my %rwx = (
	r => 0,
        w => 1,
        x => 2
    );
 
    my $mode = 0;
    my @m = split //, $modestr;
    shift @m;
    for (my $i = 0; $i <= 8; $i++) {
	if ($m[$i] ne '-') {
	    $mode += 1 << (8 - $i);
        }
    }
    return $mode
}

sub populate_dev {
    my ($dirname) = @_;
    my %devtab;

    if ($verbose) {
	print "$0: obtaining device node numbers\n";
    }
    open(my $fh, '-|', 'ls', '-l',
	 map { File::Spec->catfile('/dev', $_) } @devfiles)
	or die "failed to run ls: $!\n";
    while (<$fh>) {
	chomp;
	my @fields = split /\s+/;
	next if @fields != 10;
	my ($mode, undef, $owner, $group, $major, $minor,
	    undef, undef, undef, $name) = @fields;
	$major =~ s/,$//;
	(undef, undef, $name) = File::Spec->splitpath($name);
	    
	$devtab{$name} = {
	    type  => substr($mode, 0, 1),
	    mode  => str_to_mode($mode),
	    owner => $owner,
	    group => $group,
	    major => $major,
	    minor => $minor
	};
    }
    close $fh;

    exit(1) unless scalar(keys(%devtab)) == scalar(@devfiles);

    foreach my $dev (@devfiles) {
	my $devname = File::Spec->catfile($dirname, $dev);
	my $d = $devtab{$dev};
	if ($verbose > 1) {
	    print "$0: mknod $devname $d->{type} $d->{major} $d->{minor}\n";
	}
	system('mknod', $devname, $d->{type}, $d->{major}, $d->{minor});
	if ($? == -1) {
	    die "failed to run mknod\n";
	} elsif ($? & 127) {
	    die "mnknod died on signal " . ($? & 127) . "\n";
	} elsif ($?) {
	    die "mnknod exited with code " . ($? >> 8) . "\n";
	}
	$users{$d->{owner}} = xgetpwnam($d->{owner})
	    unless exists($users{$d->{owner}});
	$groups{$d->{group}} = xgetgrnam($d->{group})
	    unless exists($groups{$d->{group}});
	chown $users{$d->{owner}}->[2], $users{$d->{owner}}->[3], $devname;
	chmod $d->{mode}, $devname;
    }
}

#
# Populate /etc
#
sub xgetpwnam {
    my $name = shift;
    my @res = getpwnam $name
	or die "can't get user $name\n";

    return [ @res[0..3], @res[6..8] ];
}

sub xgetpwnam_fixup {
    my $res = xgetpwnam(@_);
    $res->[5] = File::Spec->catfile('/home', $res->[0]);
    $res->[6] = '/bin/nonexistent';
    return $res;
}

sub xgetgrnam {
    my $name = shift;
    my @res = getgrnam $name
	or die "can't get group $name\n";
    $res[3] =~ s/ /,/g;
    return \@res;
}

sub add_userdb {
    my ($href, $name, $getfn) = @_;
    foreach my $key (split /[, ]+/, $name) {
	$href->{$key} = &{$getfn}($key)
	    unless exists($href->{$key});
    }
}

sub add_user_by_gid {
    my ($gid) = @_;
     setpwent();
    while (my @pwd = getpwent()) {
	if ($pwd[3] == $gid) {
	    $users{$pwd[0]} = [
		@pwd[0..3], $pwd[6],
	        File::Spec->catfile('/home', $pwd[0]),
		'/bin/nonexistent'
	    ] unless exists $users{$pwd[0]};
	}
    }
    endgrent();
}

sub add_groups {
    my ($name) = @_;
    foreach my $key (split /[, ]+/, $name) {
	unless (exists($groups{$key})) {
	    # Add the group itself.
	    $groups{$key} = xgetgrnam($key);
	    # Add users from that group.
	    add_users($groups{$key}->[3]);
	    # Add any users, for whom that group is a primary one
	    add_user_by_gid($groups{$key}->[2]);
	}
    }
}

sub add_users {
    my ($name) = @_;
    add_userdb(\%users, $name, \&xgetpwnam_fixup); 
}
	    
sub write_userdb {
    my ($name, $entries) = @_;
    if ($verbose > 0) {
	print "$0: creating $name\n";
    }
    open(my $fh, '>', $name)
	or die "can't open $name for writing: $!\n";
    foreach my $ent (map { $entries->{$_} }
		     sort { $entries->{$a}[2] <=> $entries->{$b}[2] }
		         keys %$entries) {
	print $fh join(":", @$ent)."\n";
    }
    close $fh;
}

sub populate_etc {
    my ($dirname) = @_;

    # Add missing groups.
    while (my ($username, $pwd) = each %users) {
	my @gr = getgrgid($pwd->[3]);
	unless ($groups{$gr[0]}) {
	    $gr[3] =~ s/ /,/g;
	    $groups{$gr[0]} = \@gr
	}
    }

    # Write files.
    write_userdb(File::Spec->catfile($dirname, 'passwd'), \%users);
    write_userdb(File::Spec->catfile($dirname, 'group'), \%groups);

    my $name = File::Spec->catfile($dirname, 'nsswitch.conf');
    if ($verbose > 0) {
	print "$0: creating $name\n";
    }
    open(my $fh, '>', $name)
	or die "can't open $name for writing: $!\n";
    print $fh <<EOT;
passwd	files
group	files
hosts	files dns
EOT
    close $fh;
}

#
# home
#

sub populate_home {
    my ($dirname) = @_;
    while (my ($name, $pwd) = each %users) {
	if ($pwd->[5] =~ m{^/home/(.+)}) {
	    my $homedir = File::Spec->catfile($dirname, $1);
	    mkdir $homedir or die "can't create $homedir: $!\n";
	    chown $pwd->[2], $pwd->[3], $homedir or
		die "can't change ownership of $homedir: $!\n";
	}
    }
}

#
# Configuration file.
#
my %kwtab = (
    chrootdir => \$chrootdir,
    binaries  => \@binaries,
    devices   => \@devfiles,
    libraries => \@libfiles,
    users     => sub { add_users($_[1]) },
    groups    => sub { add_groups($_[1]) }
);
		  
sub read_config {
    my ($filename) = @_;
    open(my $fh, '<', $filename)
	or die "can't open file $filename for reading: $!";
    while (<$fh>) {
	chomp;
	if (/\\$/) {
	    chop;
	    $_ .= <$fh>;
	    redo;
	}
	s/^\s+//;
	s/\s+$//;
	s/#.*//;
	next if $_ eq '';
	my ($kw, $value) = split /\s+/, $_, 2;
	die "$filename:$.: syntax error: missing value\n" unless defined $value;
	$kw = lc($kw);
	die "$filename:$.: unknown keyword\n" unless exists($kwtab{$kw});
	my $handler = $kwtab{$kw};
	if (ref($handler) eq 'ARRAY') {
	    push @$handler, split(/\s+/, $value);
	} elsif (ref($handler) eq 'CODE') {
	    &{$handler}($kw, $value, "$filename:$.");
	} else {
	    $$handler = $value;
	}
    }
    close $fh
}

#
# main
#
sub addnames {
    my ($aref, $arg) = @_;
    push @$aref, split /[, ]+/, $arg;
}

GetOptions('chrootdir|r=s' => \$chrootdir,
	   'binaries|b=s' => sub { addnames(\@binaries, $_[1]) },
	   'devices|d=s' => sub { addnames(\@devfiles, $_[1]) },
	   'libraries|l=s' => sub { addnames(\@libfiles, $_[1]) },
	   'users|u=s' => sub { add_users($_[1]) },
	   'groups|g=s' => sub { add_groups($_[1]) },
	   'verbose|v+' => \$verbose,
	   'help|h' => sub {
	       pod2usage(-exitstatus => 0, -verbose => 2)
	   },
	   'usage' => sub {
	       pod2usage(-exitstatus => 0, -verbose => 0)
	   })
    or pod2usage(-exitstatus => 1, -verbose => 0);

die "$0: must be run as root\n" unless $> == 0;

if (@ARGV == 1) {
    read_config($ARGV[0]);
} elsif (@ARGV != 0) {
    warn "$0: too many arguments\n";
    pod2usage(-exitstatus => 1, -verbose => 0);
}

if (-d $chrootdir) {
    die "$chrootdir already exists\n";
}

if (@binaries == 0) {
    print STDERR "$0: no binaries given\n";
    pod2usage(-exitstatus => 1, -verbose => 0);
}

$users{root} = xgetpwnam('root');
$groups{root} = xgetgrnam('root');

foreach my $libname (@libfiles) {
    my $tgt = resolve_lib($libname);
    $libraries{$tgt} = { libname => $libname };
    extract_libdeps($tgt);
}
    
collect_binaries();

make_path("$chrootdir", { mode => 0755 })
    or die "can't create $chrootdir: $!\n";

foreach my $dir (@dirs) {
    my $dirname = File::Spec->catfile($chrootdir, $dir);
    if ($verbose) {
	print "$0: creating directory $dirname\n";
    }
    make_path("$dirname", { mode => 0755 })
	or die "can't create $dirname: $!\n";
    if (my $fun = $populate{$dir}) {
	if ($verbose) {
	    print "$0: populating directory $dirname\n";
	}
	&{$fun}($dirname);
    }
}

=head1 NAME

mkchroot - make a chroot directory

=head1 SYNOPSIS

B<mkchroot>
[B<-v>]
[B<-b I<LIST>>]
[B<-d I<LIST>>]
[B<-g I<LIST>>]
[B<-l I<LIST>>]
[B<-r I<DIR>>]
[B<-u I<LIST>>]
[B<--binaries=I<LIST>>]
[B<--chrootdir=I<DIR>>]
[B<--devices=I<LIST>>]
[B<--groups=I<LIST>>]
[B<--libraries=I<LIST>>]
[B<--users=I<LIST>>]
[B<--verbose>]
[I<CONFIG>]

B<mkchroot>
[B<-h>]
[B<--help>]
[B<--usage>]

=head1 DESCRIPTION

Creates and populates a chroot filesystem for use with B<rush> and similar
programs.  The directory is populated with the binary files indicated at
the invocation and shared libraries they depend on.

The user is supposed to supply the name of the chroot filesystem to create
and a list of full pathnames of the binaries to be installed there.  This
and other optional data can be supplied either on the command line, via
options, or in the confgiuration file.

=head1 OPTIONS

The following options are understood.  In the discussion below,
I<LIST> stands for a list of names separated by commas or whitespace.

=over 4

=item B<-v>, B<--verbose>

Increase output verbosity.

=item B<-r>, B<--chrootdir=I<DIR>>

Specify the name of the chroot directory.  This option is mandatory.

As a safety measure, the program will refuse to proceed if I<DIR> already
exists.

=item B<-b>, B<--binaries=I<LIST>>

Names of the binary files to be installed in the chroot filesystem.
I<LIST> is a list of absolute file names.

This option is mandatory.

=item B<-d>, B<--devices=I<LIST>>

Names of the device files to be installed in the B</dev> subdirectory of
the chroot filesystem.  I<LIST> is the list of node names.

By default, only B</dev/null> is installed.

=item B<-l>, B<--libraries=I<LIST>>

List of additional shared libraries to install.

=item B<-u>, B<--users=I<LIST>>

List of user names to include in the user database of the newly created
chroot filesystem.

=item B<-g>, B<--groups=I<LIST>>

Additional groups to copy from the system group database to the B</etc/group>
file of the created filesystem.  For each group from the list, all users from
that group will be added to the user database.

=back

=head1 CONFIGURATION

Configuration file provides a convenient way of supplying the necessary
information to B<mkchroot>.  When used, it is given as the only argument
to the program.  When both command-line option and configuration file are
given, the information from the latter augment that given by the former.

The configuration file contains a list of keywords with values, each on
a separate line.  Very long logical lines can be split into shorter
physical lines, by ending each line except the last one with a backslash
character.  Keywords and values are separated by any amount of whitespace.
Leading and trailing whitespace is ignored (with one exception: a backslash
used as line continuation character must be followed by newline character,
with no whitespace in between).  Comments are introduced by the B<#> character
and extend to the end of the logical line where it appears.

Depending on a keyword, its value may be either a single string or a list
of strings.  In the later case, elements of the list are separated by any
amount of whitespace.

All keywords are case-insensitive.

The following keywords are understood:

=over 4

=item B<chrootdir>

Defines the name of the top-level directory under which to create the chroot
filesystem.

=item B<binaries>

A list of absolute names of the binary files to install.

=item B<devices>

A list of device (node) names to install.  Device numbers are taken from
the host filesystem.

=item B<libraries>

A list of additional shared libraries to install.

=item B<users>

A list of user names to copy from the system user database to that of the
chroot filesystem.

=item B<groups>

A list of additional system groups to add to the group database of the
created filesystem.  For each group from the list, all users from that
group will be added to the user database.

=back

=head1 SEE ALSO

B<rush>(8).

=head1 BUGS

Several values are hardcoded:

=over 4

=item

The pathnames of the B<libnss_file> and B<libnss_dns> shared libraries.

=item

Name of the shell set for users copied to the chroot user database
(B</bin/nonexistent>).

=back

=head1 AUTHOR

Sergey Poznyakoff <gray@gnu.org>