#!/usr/bin/perl
#
# Copyright (C) 2006 Mandriva
# 
# Author: Florent Villard <warly@mandriva.com>
#
# 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, 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., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA.
#
# run commands which needs root privilege
#
use strict;
my $program_name = 'iurt_root_command';
use Mkcd::Commandline qw(parseCommandLine usage);
use MDK::Common qw(any if_);
use File::NCopy qw(copy);
use Iurt::Util qw(plog_init plog);
use Cwd 'realpath';
use File::Path qw(make_path);
use File::Slurp;
use String::Escape;
use File::Basename;

my $arg = @ARGV;
my (@params, %run);
$run{program_name} = $program_name;

my %authorized_modules;
my %authorized_rw_bindmounts = (map { $_ => 1 } qw(/proc /dev/pts /var/cache/icecream));

$run{todo} = [];
@params = ( 
    #    [ "one letter option", "long name option", "number of args (-X means ´at least X´)", "help text", "function to call", "log info"]
    #
    [ "", $program_name, 0, "[--verbose <level>] 
		    [--modprobe <module>] 
		    [--mkdir [--parents] <dir1> <dir2> ... <dirn>]", 
    "$program_name is a perl script to execute commands which need root privilege, it helps probram which needs occasional root privileges for some commands.", 
    sub { $arg or usage($program_name, \@params) }, String::Escape::elide(join(' ', "Running $program_name", @ARGV), 120) ],

    [ "", "cp", [
    ["", "cp", -1, "[-r] <file1> <file2> ... <filen> <dest>", "copy the files to dest",
        sub {    
            my ($tmp, @arg) = @_; 
            $tmp->[0] ||= {}; 
            push @$tmp, @arg; 
            1;
        }, "Setting cp command arguments"], 
        ["r", "recursive", 0, "",  
        "Also copy directories and subdirectories",  
        sub { my ($tmp) = @_; $tmp->[0]{recursive} = 1; 1 }, "Set the recursive flag"], 
    ], "[-r] <file1> <file2> ... <filen> <dest>", 
    "Copy files", 
    \&cp, "Copying files" ],

   [ "", "ln", [
   ["", "ln", 2, "<file1> <file2>", "link file1 to file2",
        sub {    
            my ($tmp, @arg) = @_; 
            $tmp->[0] ||= {}; 
            push @$tmp, @arg; 
            1;
        }, "Setting ln command arguments"], 
    ], "<file1> <file2>", 
    "Link files", 
    \&ln, "Linking files" ],

    [ "", "mkdir", [
    ["", "mkdir", -1, "[--parents] <dir1> <dir2> ... <dirn>", "mkdir create the given path",
        sub {    
            my ($tmp, @arg) = @_; 
            $tmp->[0] ||= {}; 
            push @$tmp, @arg; 
            1;
        }, "Setting auto mode arguments"], 
        ["p", "parents", 0, "",  
        "Also create needed parents directories",  
        sub { my ($tmp) = @_; $tmp->[0]{parents} = 1; 1 }, "Set the parents flag"], 
    ], "[--parents] <dir1> <dir2> ... <dirn>", 
    "mkdir create the given path", 
    \&mkdir, "Creating the path" ],

    [ "", "rm", [
    ["", "rm", -1, "[-r] <file1> <file2> ... <filen>", "remove the provided files",
        sub {    
            my ($tmp, @arg) = @_; 
            $tmp->[0] ||= {}; 
            push @$tmp, @arg; 
            1;
        }, "Setting rm command arguments"], 
        ["r", "recursive", 0, "",  
        "Also create needed parents directories",  
        sub { my ($tmp) = @_; $tmp->[0]{recursive} = 1; 1 }, "Set the recursive flag"], 
    ], "[-r] <file1> <file2> ... <filen>", 
    "Remove files", 
    \&rm, "Removing files" ],

    [ "v", "verbose", 1, "<verbose level>", 
    "modprobe try to modprobe the given module if authorized.", 
    sub { $run{verbose} = $_[0]; 1 }, "Setting verbose level" ],
    
    [ "", "modprobe", 1, "<module>", 
    "modprobe try to modprobe the given module if authorized.", 
    \&modprobe, "Modprobing" ],

    [ "", "tar", [
    ["", "tar", 2, "<file> <directory>", "tar directory into file",
        sub {    
            my ($tmp, @arg) = @_; 
            $tmp->[0] ||= {}; 
            push @$tmp, @arg; 
            1;
        }, "Setting tar command arguments"], 
    ], "<file> <directory>", 
    "Create tarball", 
    \&tar, "Create tarball" ],

    [ "", "untar", [
    ["", "untar", -1, "<file> <directory> [files]", "untar file into directory (optionally selecting files only)",
        sub {    
            my ($tmp, @arg) = @_; 
            $tmp->[0] ||= {}; 
            push @$tmp, @arg; 
            1;
        }, "Setting untar command arguments"], 
    ], "<file> <directory> [files]", 
    "Uncompress tarball", 
    \&untar, "Uncompress tarball" ],

    [ "", "bindmount", 2, "<source> <dest>", 
    "bind mount source on dest", 
    \&bindmount, "Bind mounting" ],

    [ "", "tmpfs", 1, "<directory>", 
    "mount a tmpfs on the given directory", 
    \&tmpfs, "Mount tmpfs" ],

    [ "", "umount", 1, "<directory>", 
    "umount the given directory", 
    \&umount, "Unmounting" ],

    [ "", "btrfs_create", 1, "<directory>", 
    "create a btrfs subvolume", 
    \&btrfs_create, "Create btrfs" ],

    [ "", "btrfs_delete", 1, "<directory>", 
    "delete a btrfs subvolume", 
    \&btrfs_delete, "Delete btrfs" ],

    [ "", "btrfs_snapshot", 2, "<source> <dest>", 
    "create a btrfs snapshot", 
    \&btrfs_snapshot, "btrfs snapshot" ],

    [ "", "netns_create", 1, "<directory>",
    "create a network namespace",
    \&netns_create, "Create network namespace for given chroot" ],

    [ "", "netns_delete", 1, "<directory>",
    "delete a network namespace",
    \&netns_delete, "Delete network namespace for given chroot, killing all processes" ],

    [ "", "useradd", 3, "<directory> <username> [uid]", 
    "Add user in given chroot", 
    \&useradd, "Useradd" ],

    [ "", "urpmi", [
    ["", "urpmi", -1, "urpmi options", "run urpmi with urpmi options (should have chroot options)",
        sub {    
            my ($tmp, @arg) = @_; 
            push @$tmp, @arg; 
            1;
        }, "Setting urpmi options"], 
    ], "urpmi options", 
    "Run urpmi in chroot", 
    \&urpmi, "Run urpmi in chroot" ],
);

my %commands_with_more_args = (
    "--urpmi" => [ \&urpmi, "urpmi" ],
    "--urpmi-addmedia" => [ \&urpmi_addmedia, "urpmi.addmedia" ],
    "--chroot" => [ \&run_chroot, "chroot" ],
);

open(my $LOG, ">&STDERR");

plog_init($program_name, $LOG, $run{verbose});
#plog_init($program_name, $LOG, 7, 1);

my $todo;

# (blino) do not use mkcd to parse complicated command lines with unhandled options
# I fail to make mkcd not parse arguments after -- on command line
if (my $command = $commands_with_more_args{$ARGV[0]}) {
    my (undef, @options) = @ARGV;
    $todo = [ [ $command->[0], \@options, $command->[1] ] ];
} else {
    $todo = parseCommandLine($program_name, \@ARGV, \@params);
    @ARGV and usage($program_name, \@params, "@ARGV, too many arguments");
}

my $ok = 1;
foreach my $t (@$todo)  {
    plog('DEBUG', $t->[2]);
    my $ok2 = &{$t->[0]}(\%run, @{$t->[1]});
    $ok2 or plog("ERROR: $t->[2]");
    $ok &&= $ok2;
}
plog('DEBUG', "Success!") if $ok;
exit !$ok;

sub modprobe {
    my ($_run, $module) = @_;
    if (!$authorized_modules{$module}) {
	plog("ERROR: unauthorized module $module");
	return 0;
    }
    
    return 1 if any { /^$module\b/ } read_file("/proc/modules");

    system("/sbin/depmod", "-a");
    !system("/sbin/modprobe", "-f", $module);
}

sub mkdir {
    my ($_run, $opt, @dir) = @_;
    foreach my $path (@dir) {
	-d $path and next;
	if ($path =~ m,/dev|/proc|/root|/var, && $path !~ /chroot/) {
	    plog('FAIL', "ERROR: $path creation forbidden");
	}
	if ($opt->{parents}) {
	    make_path($path);
	} else {
	    mkdir $path;
	}
    }
    1;
}

sub rm {
    my ($_run, $opt, @files) = @_;
    my $ok = 1;
    my $done;

    foreach my $f (@files) {
	if (-d $f) {
	    if (!$opt->{recursive}) {
		plog('WARN', "can't remove directories without the -r option");
		$ok = 0;
	    } else {
		if (!check_path_authorized($f)) {
		    plog('FAIL', "removal of $f forbidden");
		    $ok = 0;
		} else {
		    system('rm', '-rf', $f);
		    plog('DEBUG', "removing $f");
		    $done = 1;
		}
	    }
	} else {
	    if (!check_path_authorized($f)) {
		plog("removal of $f forbidden");
		$ok = 0;
	    } else {
		# CM: The original regexp was /\*?/, which doesn't seem to be
		#     what we want. Check if we can always glob instead of
		#     testing, or if glob expansion is needed at all

		if ($f =~ /[*?]/) {
		    foreach my $file (glob $f) {
			if (!check_path_authorized($f)) {
			    plog('FAIL', "removal of $f forbidden");
			    $ok = 0;
			} else {
			    unlink $file;
			    $done = 1;
			    plog('DEBUG', "removing $file");
			}
		    }
		} else {
		    unlink $f;
		    $done = 1;
		    plog('DEBUG', "removing $f");
		}
	    }
	}
    }
    if (!$done) { plog('DEBUG', "nothing deleted") }
    $ok;
}

sub cp {
    my ($_run, $opt, @files) = @_;
    my $ok = 1;
    my $done;
    my $dest = pop @files;
    check_path_authorized($dest) or return;
    foreach my $f (@files) {
	if (-d $f) {
	    if (!$opt->{recursive}) {
		plog('WARN', "can't copy directories without the -r option");
		$ok = 0;
	    } else {
		system('cp', '-raf', $f);
		plog('DEBUG', "copying $f -> $dest");
		$done = 1;
	    }
	} else {
	    if ($f =~ /\*?/) {
		foreach my $file (glob $f) {
		    if (copy $file, $dest) {
			$done = 1;
			plog('DEBUG', "copying $file -> $dest");
		    } else {
			$ok = 0;
			plog('FAIL', "copying $file to $dest failed ($!)");
		    }
		}
	    } else {
		if (copy $f, $dest) {
		    $done = 1;
		    plog('DEBUG', "copying $f -> $dest");
		} else {
		    $ok = 0;
		    plog('FAIL', "copying $f to $dest failed ($!)");
		}
	    }
	}
    }
    if (!$done) { plog('DEBUG', "nothing copied") }
    $ok;
}

sub ln {
    my ($_run, $_opt, $file1, $file2) = @_;
    check_path_authorized($file1) && check_path_authorized($file2) or return;
    link $file1, $file2;
}

sub check_path_authorized {
    my ($path) = @_;
    if (!$ENV{SUDO_USER}) {
	plog('FAIL', "must be run from sudo");
	return;
    }
    my $authorized = (getpwnam($ENV{SUDO_USER}))[7];
    if (!$authorized) {
	plog('FAIL', "can't find home for $ENV{SUDO_USER}");
	return;
    }

    #- check authorization for canonicalized path (with .. and symlinks resolved)
    my $realpath = realpath($path);
    if ($realpath !~ /^\Q$authorized\E/) {
	plog('FAIL', "$path forbidden");
	return;
    }

    1;
}

sub tar {
    my ($_run, $_opt, $file, $dir) = @_;
    if (!$file || !$dir) {
	plog('FAIL', "tar: missing arguments");
	return;	
    }
    check_path_authorized($file) && check_path_authorized($dir) or return;
    return !system('tar', 'caf', $file, '-C', $dir, '.');
}

sub untar {
    my ($_run, $_opt, $file, $dir, @o_files) = @_;
    if (!$file || !$dir) {
	plog('FAIL', "untar: missing arguments");
	return;	
    }
    check_path_authorized($file) && check_path_authorized($dir) or return;
    if (any { /^-/ } @o_files) {
	plog('FAIL', "untar: options forbidden");
	return;	
    }
    make_path($dir);
    return !system('tar', 'xf', $file, '-C', $dir, @o_files);
}

sub btrfs_create {
    my ($_run, $dest) = @_;
    check_path_authorized($dest) or return;
    return !system("btrfs", "subvolume", "create", $dest);
}

sub btrfs_delete {
    my ($_run, $dest) = @_;
    check_path_authorized($dest) or return;
    return !system("btrfs", "subvolume", "delete", $dest);
}

sub btrfs_snapshot {
    my ($_run, $source, $dest) = @_;
    check_path_authorized($dest) or return;
    return !system("btrfs", "subvolume", "snapshot", $source, $dest);
}

sub netns_create {
    my ($_run, $dest) = @_;
    check_path_authorized($dest) or return;
    my $nsname = basename($dest);
    system("ip", "netns", "add", $nsname) and return;
    system("ip", "netns", "exec", $nsname, "ifconfig", "lo", "up");
    # We don't configure a DNS server so make sure one is not excepted
    system("sed -i 's|^hosts:|hosts: files|' $dest/etc/nsswitch.conf");
    # Some packages want a default route
    system("ip", "netns", "exec", $nsname, "ip", "route", "add", "0.0.0.0/0", "dev", "lo");
    my $hostname = `hostname`;
    system("echo '127.0.0.1 localhost $hostname' > $dest/etc/hosts");
    system("echo > $dest/etc/resolv.conf");
    return 1;
}

sub netns_delete {
    my ($_run, $dest) = @_;
    check_path_authorized($dest) or return;
    my $nsname = basename($dest);
    system("ip netns pids $nsname | xargs -r kill -9");
    return !system("ip", "netns", "del", $nsname);
}

sub bindmount {
    my ($_run, $source, $dest) = @_;
    check_path_authorized($dest) or return;
    system("mount", "--bind", $source, $dest) == 0 or return;
    if (!$authorized_rw_bindmounts{$source}) {
        system("mount", "-o", "remount,ro", $dest) == 0 or return;
    }
    return 1;
}

sub tmpfs {
    my ($_run, $dir) = @_;
    check_path_authorized($dir) or return;
    return !system("mount", "none", "-t", "tmpfs", $dir);
}

sub umount {
    my ($_run, $dir) = @_;
    check_path_authorized($dir) or return;
    return !system("umount", $dir);
}

sub useradd {
    my ($_run, $dir, $username, $o_uid) = @_;
    check_path_authorized($dir) or return;
    return system('chroot', $dir, 'useradd', if_($o_uid, '-o', '--uid', $o_uid), $username) == 0
      || system('chroot', $dir, 'id', $username) == 0;
}

sub check_urpmi_chroot_options {
    my ($options) = @_;

    # get all --something options
    my %optvals;
    my $current_opt;
    foreach (@$options) {
        if (/^--/) {
            $current_opt = $_;
        } else {
            if ($current_opt) {
                $optvals{$current_opt} = $_;
            }
            undef $current_opt;
        }
    }

    # check that urpmi is rooted and using allowed chroot paths
    my $is_rooted = 0;
    foreach (qw(--root --urpmi-root)) {
        if ($optvals{$_}) {
            check_path_authorized($optvals{$_}) or return;
            $is_rooted = 1;
        }
    }
    if (!$is_rooted) {
	plog('FAIL', "urpmi commands must be rooted");
	return;	
    }

    return 1;
}

sub urpmi {
    my ($_run, @options) = @_;
    return check_urpmi_chroot_options(\@options) && !system('urpmi', @options);
}

sub urpmi_addmedia {
	my ($_run, @options) = @_;
	return check_urpmi_chroot_options(\@options) && !system('urpmi.addmedia', @options);
}

sub run_chroot {
    my ($_run, $dir, @options) = @_;
    if (!$dir) {
	plog('FAIL', "chroot: need directory argument");
	return;	
    }
    check_path_authorized($dir) or return;

    my $nsname = basename($dir);
    if (!system("ip netns list | grep -q '^$nsname\$'"))  {
	return !system("ip", "netns", "exec", $nsname, "chroot", $dir, @options);
    } else {
	return !system("chroot", $dir, @options);
    }
}