path: root/korgupload

#!/usr/bin/perl -T
#
# This script should be run with the permissions of the user that
# is uploading files.
#
# Arguments are whitespace-separated and URL-escaped; a single % means
# a null argument.
#
# It accepts the following commands:
#
# DATA byte-count
#	- receives a new data blob (follows immediately)
# TAR git-tree tree-ish prefix
#	- generate a data blob from a git tree (git archive)
# DIFF git-tree tree-ish tree-ish
#	- generate a data blob as a git tree diff
# SIGN byte-count
#	- updates the current signature blob (follows immediately)
# PUT pathname
#	- installs the current data blob as <pathname>
# MKDIR pathname
#	- creates a new directory
# MOVE old-path new-path
#	- moves <old-path> to <new-path>
# DONE
#	- optional command, terminates transaction
#
# For future consideration:
#
# LINK old-path:new-path
#	- hard links <old-path> to <new-path>
# SYMLINK old-path:new-path
#	- symlinks <old-path> to <new-path>
# DELETE old-path
#	- removes <old-path>
#

use strict;
use warnings;
use bytes;
use Encode qw(encode decode);
use IPC::Open2 qw(open2);

use File::Temp qw(tempdir);
use IO::Uncompress::AnyUncompress qw(anyuncompress $AnyUncompressError) ;
use BSD::Resource;
use Fcntl qw(:DEFAULT :flock);
use POSIX;

use Sys::Syslog qw(:standard :macros);
use Git;

my $data_path = '/home/hpa/kernel.org/test/pub';
my $git_path  = '/home/hpa/kernel.org/test/git';
my $lock_file = '/home/hpa/kernel.org/test/lock';
my $tmp_path  = '/home/hpa/kernel.org/test/tmp';
my $pgp_path  = '/home/hpa/kernel.org/test/pgp';
my $max_data  = 8*1024*1024*1024;
my $bufsiz    = 1024*1024;

%ENV = ('PATH' => '/bin:/usr/bin',
	'LANG' => 'C',
	'SHELL' => '/bin/sh');

setrlimit(RLIMIT_FSIZE, $max_data, RLIM_INFINITY);

umask(077);
my $tmpdir = tempdir(DIR => $tmp_path, CLEANUP => 1);
umask(002);

my $have_data = 0;
my $have_sign = 0;

sub my_username() {
    my $whoami = getuid();
    my ($name,$passwd,$uid,$gid,$quota,$comment,$gcos,$dir,$shell,$expire) = getpwuid($whoami);

    return (defined($name) && $whoami == $uid) ? $name : $whoami;
}

my $user_name = my_username();

openlog("korgupload($user_name)", 'ndelay,pid', LOG_LOCAL5);

my $lock_fd   = undef;

sub fatal($) {
    my($msg) = @_;

    syslog(LOG_CRIT, "%s", $msg);
    die $msg."\n";
}

sub lock_tree()
{
    if (!defined($lock_fd)) {
	open($lock_fd, '<', $lock_file)
	    or fatal("Cannot open lock file");
	flock($lock_fd, LOCK_EX)
	    or fatal("Cannot get file tree lock");
    } else {
	fatal("File tree is already locked");
    }
}

sub unlock_tree()
{
    if (defined($lock_fd)) {
	close($lock_fd);
	undef $lock_fd;
    }
}

sub url_unescape($)
{
    my($s) = @_;
    my $c;
    my $o;

    # A single isolated % sign means an empty string
    return '' if ($s eq '%');

    for (my $i = 0; $i < length($s); $i++) {
	$c = substr($s, $i, 1);
	if ($c eq '+') {
	    $o .= ' ';
	} elsif ($c eq '%') {
	    $c = substr($s, $i+1, 2);
	    return undef if (length($c) != 2);
	    $o .= pack("C", hex $c);
	    $i += 2;
	} else {
	    $o .= $c;
	}
    }

    return $o;
}

sub parse_line($)
{
    my($line) = @_;
    chomp $line;

    if ($line !~ /^([A-Z0-9_]+)(|\s+(|\S|\S.*\S|))\s*$/) {
	return undef;		# Invalid syntax
    }

    my $cmd = $1;
    my @args = ();

    if ($2 ne '') {
	my @rawargs = split(/\s+/, $3);

	foreach my $ra (@rawargs) {
	    my $a = url_unescape($ra);
	    return undef if (!defined($a));
	    push(@args, $a);
	}
    }

    return ($cmd, @args);
}

# Return true if the supplied string is valid UTF-8 without special
# characters
sub is_clean_string($)
{
    no bytes;
    # use feature 'unicode_strings';	-- is this needed here?

    my($b) = @_;
    my $f = decode('UTF-8', $b, Encode::FB_DEFAULT);

    return 0 if ($f =~ m:[\x{0000}-\x{001f}\x{007f}-\x{00a0}\x{fffd}-\x{ffff}]:);
    return 1;
}    

# This returns true if the given argument is a valid filename in its
# canonical form.  Double slashes, relative paths, control characters,
# and malformed UTF-8 is not permitted.
sub is_valid_filename($)
{
    my($f) = @_;

    return 0 if (!is_clean_string($f));
    return 0 if ($f !~ m:^/:);
    return 0 if ($f =~ m:/$:);
    return 0 if ($f =~ m://:);
    return 0 if ($f =~ m:/(\.|\.\.)(/|$):);

    return 1;
}

sub get_raw_data(@)
{
    my @args = @_;

    if (scalar(@args) != 1 || $args[0] !~ /^[0-9]+$/) {
	fatal("Bad DATA command");
    }

    my $output = $tmpdir.'/data';
    anyuncompress(\*STDIN => $output,
		  BinModeOut => 1,
		  InputLength => ($args[0] + 0),
		  Append => 0,
		  AutoClose => 0,
		  Transparent => 1,
		  BlockSize => $bufsiz)
	or fatal("DATA decompression error: $AnyUncompressError");
		  
    $have_data = 1;
}

# Get the canonical name for a git ref and its type
sub check_ref($$)
{
    my($repo, $ref) = @_;

    my $out = undef;

    if (!is_clean_string($ref) || $ref =~ /^-/) {
	return undef;
    }

    # It turns out Git::command_bidi_pipe() is broken under -T
    $ENV{'GIT_DIR'} = $repo->repo_path();

    my $pipe_in;
    my $pipe_out;
    my $pid = open2($pipe_in, $pipe_out, 'git', 'cat-file', '--batch-check');
    print $pipe_out $ref, "\n";
    close($pipe_out);
    $out = <$pipe_in>;
    chomp $out;
    waitpid($pid, 0);
    
    if ($? == 0 && $out =~ /^([0-9a-f]{40}) (\S+) ([0-9]+)$/) {
	return ($1, $2, $3+0);
    } else {
	return undef;
    }
}

sub get_tar_data(@)
{
    my @args = @_;

    if (scalar(@args) != 3) {
	fatal("Bad TAR command");
    }

    my($tree, $ref, $prefix) = @args;

    if (!is_valid_filename($tree)) {
	fatal("Invalid pathname in TAR command");
    }

    if (!is_clean_string($prefix)) {
	fatal("Invalid prefix string");
    }

    if ($tree !~ /\.git$/ || ! -d $git_path.$tree ||
	! -d $git_path.$tree.'/objects') {
	fatal("No such git tree");
    }

    my $repo;
    git_cmd_try {
	$repo = Git->repository(Repository => $git_path.$tree);
    } "Invalid git repository\n";

    my ($sha, $type, $len) = check_ref($repo, $ref);
    if ($type !~ /^(tree|commit|tag)$/) {
	fatal("Invalid tree reference");
    }

    syslog(LOG_INFO, "tar ref ${sha}");

    git_cmd_try {
	$repo->command_noisy('archive', '--format=tar', '--prefix='.$prefix,
			     '-o', $tmpdir.'/data', $ref);
    } "Failed to acquire tarball\n";
		  
    $have_data = 1;
}

sub get_diff_data(@)
{
    my @args = @_;

    if (scalar(@args) != 3) {
	fatal("Bad DIFF command");
    }

    my($tree, $ref1, $ref2) = @args;

    if (!is_valid_filename($tree)) {
	fatal("Invalid pathname in DIFF command");
    }

    if ($tree !~ /\.git$/ || ! -d $git_path.$tree ||
	! -d $git_path.$tree.'/objects') {
	fatal("No such git tree");
    }

    my $repo;
    git_cmd_try {
	$repo = Git->repository(Repository => $git_path.$tree);
    } "Invalid git repository\n";

    my ($sha1, $type1, $len1) = check_ref($repo, $ref1);
    if ($type1 !~ /^(tree|commit|tag)$/) {
	fatal("Invalid tree reference");
    }
    
    my ($sha2, $type2, $len2) = check_ref($repo, $ref2);
    if ($type2 !~ /^(tree|commit|tag)$/) {
	fatal("Invalid tree reference");
    }

    syslog(LOG_INFO, "diff refs ${sha1}..${sha2}");

    git_cmd_try {
	my $oldstdout;
	my $out;

	open($oldstdout, '>&', \*STDOUT) or die;
	sysopen($out, $tmpdir.'/data', O_WRONLY|O_CREAT|O_TRUNC) or die;
	open(STDOUT, '>&', $out) or die;
	close($out);
	
	$repo->command_noisy('diff-tree', '-p', $sha1, $sha2);

	open(STDOUT, '>&', $oldstdout);
	close($oldstdout);
    } "Failed to acquire patch file\n";
		  
    $have_data = 1;
}

sub get_sign_data(@)
{
    my @args = @_;

    if (scalar(@args) != 1 || $args[0] !~ /^[0-9]+$/) {
	fatal("Bad SIGN command");
    }

    my $output = $tmpdir.'/sign';
    anyuncompress(\*STDIN => $output,
		  BinModeOut => 1,
		  InputLength => ($args[0] + 0),
		  Append => 0,
		  AutoClose => 0,
		  Transparent => 1,
		  BlockSize => $bufsiz)
	or fatal("SIGN decompression error: $AnyUncompressError");
		  
    if ((-s $output) >= 65536) {
	fatal("SIGN output impossibly large");
    }

    $have_sign = 1;
}

sub make_compressed_data()
{
    die if (!$have_data);

    my %workers;
    my @cmds = (['/bin/gzip', '-9'],
		['/usr/bin/bzip2', '-9'],
		['/usr/bin/xz', '-9']);
    my @exts = ('.gz', '.bz2', '.xz');
    my $nworkers = 0;

    for (my $i = 0; $i < scalar @cmds; $i++) {
	my @c = @{$cmds[$i]};
	my $e = $exts[$i];

	my $w = fork();

	if (!defined($w)) {
	    fatal("Fork failed");
	}

	if ($w == 0) {
	    sysopen(RAW, $tmpdir.'/data', O_RDONLY)
		or exit 127;
	    sysopen(OUT, $tmpdir.'/data'.$e, O_WRONLY|O_CREAT|O_TRUNC, 0666)
		or exit 127;

	    open(STDIN,  '<&', \*RAW) or exit 127;
	    open(STDOUT, '>&', \*OUT) or exit 127;
	    close(RAW);
	    close(OUT);

	    exec {$c[0]} @c;
	    exit 127;
	}

	$workers{$w}++;
	$nworkers++;
    }

    while ($nworkers) {
	my $w = wait();
	my $status = $?;

	if ($workers{$w}) {
	    undef $workers{$w};
	    if ($status) {
		foreach my $c (keys %workers) {
		    kill('TERM', $c);
		}
		fatal("Failed to compress output data");
	    }
	}

	$nworkers--;
    }
}

sub make_timestamps_match()
{
    die if (!$have_data || !$have_sign);

    my $now = time();
    
    utime($now, $now, $tmpdir.'/data');
    utime($now, $now, $tmpdir.'/data.gz');
    utime($now, $now, $tmpdir.'/data.bz2');
    utime($now, $now, $tmpdir.'/data.xz');
    utime($now, $now, $tmpdir.'/sign');
}

sub cleanup()
{
    unlink($tmpdir.'/data');
    unlink($tmpdir.'/data.gz');
    unlink($tmpdir.'/data.bz2');
    unlink($tmpdir.'/data.xz');
    unlink($tmpdir.'/sign');
    $have_data = 0;
    $have_sign = 0;
}

sub signature_valid()
{
    my $oldstdout;
    my $oldstderr;
    my $devnull;

    # gpg likes to chat on the console no matter what...
    open($devnull, '>', '/dev/null')
	or fatal("Cannot open /dev/null");
    open($oldstdout, '>&', \*STDOUT)
	or fatal("dup error");
    open($oldstderr, '>&', \*STDERR)
	or fatal("dup error");
    open(STDOUT, '>&', $devnull)
	or fatal("dup error");
    open(STDERR, '>&', $devnull)
	or fatal("dup error");
    close($devnull);

    my $status =
	system('/usr/bin/gpg', '--batch', '--no-tty',
	       '--homedir', $tmpdir,
	       '--no-options',
	       '--no-auto-key-locate',
	       '--no-default-keyring',
	       '--keyring', $pgp_path."/${user_name}.gpg",
	       '--display-charset', 'utf-8',
	       '--verify', $tmpdir.'/sign', $tmpdir.'/data');

    open(STDOUT, '>&', $oldstdout);
    close($oldstdout);
    open(STDERR, '>&', $oldstderr);
    close($oldstderr);

    return $status == 0;
}

sub put_file(@)
{
    my @args = @_;

    if (scalar(@args) != 1) {
	fatal("Bad PUT command");
    }

    my($file) = @args;

    if (!$have_data) {
	fatal("PUT without DATA");
    }
    if (!$have_sign) {
	fatal("PUT without SIGN");
    }

    if (!signature_valid()) {
	fatal("Signature invalid");
    }

    if (!is_valid_filename($file)) {
	fatal("Invalid filename in PUT command");
    }

    if ($file =~ /^(.*)\.gz$/) {
	my $stem = $1;
	make_compressed_data();
	make_timestamps_match();

	lock_tree();

	if (-e $data_path.$stem) {
	    fatal("Filename conflict (compressed and uncompressed)");
	}
	if ((-e $data_path.$stem.'.gz' && ! -f _)
	    (-e $data_path.$stem.'.bz2' && ! -f _)
	    (-e $data_path.$stem.'.xz' && ! -f _)
	    (-e $data_path.$stem.'.sign' && ! -f _)) {
	    fatal("Trying to overwrite a non-file");
	}

	if (!rename($tmpdir.'/data.gz',  $data_path.$stem.'.gz') ||
	    !rename($tmpdir.'/data.bz2', $data_path.$stem.'.bz2') ||
	    !rename($tmpdir.'/data.xz',  $data_path.$stem.'.xz') ||
	    !rename($tmpdir.'/sign',     $data_path.$stem.'.sign')) {
	    unlink($data_path.$stem.'.gz');
	    unlink($data_path.$stem.'.bz2');
	    unlink($data_path.$stem.'.xz');
	    unlink($data_path.$stem.'.sign');
	    fatal("Failed to install files");
	}
	unlock_tree();
    } elsif ($file =~ /\.(sign|bz2|xz)$/) {
	fatal("Cannot install .sign, .bz2 or .xz files directly");
    } else {
	make_timestamps_match();

	lock_tree();

	if (-e $data_path.$file.'.gz' ||
	    -e $data_path.$file.'.bz2' ||
	    -e $data_path.$file.'.xz') {
	    fatal("Filename conflict (compressed and uncompressed)");
	}
	if ((-e $data_path.$file && ! -f _) ||
	    (-e $data_path.$file.'.sign' && ! -f _)){
	    fatal("Attempting to overwrite a non-file");
	}

	if (!rename($tmpdir.'/data', $data_path.$file) ||
	    !rename($tmpdir.'/sign', $data_path.$file.'.sign')) {
	    unlink($data_path.$file);
	    unlink($data_path.$file.'.sign');
	    fatal("Failed to install files");
	}
	unlock_tree();
    }

    cleanup();
}

sub do_mkdir(@)
{
    my @args = @_;

    if (scalar(@args) != 1) {
	fatal("Bad MKDIR command");
    }

    my($file) = @args;

    if (!is_valid_filename($file)) {
	fatal("Invalid filename in MKDIR command");
    }

    if ($file =~ /\.(gz|bz2|xz|sign)$/) {
	fatal("Protected filename space");
    }

    lock_tree();

    if (-e $data_path.$file.'.gz' ||
	-e $data_path.$file.'.bz2' ||
	-e $data_path.$file.'.xz' ||
	-e $data_path.$file.'.sign') {
	fatal("Filename conflict (file and directory)");
    }

    if (!mkdir($data_path.$file, 0777)) {
	fatal("Failed to MKDIR");
    }

    unlock_tree();
}

sub move_file(@)
{
    my @args = @_;

    if (scalar(@args) != 2) {
	fatal("Bad MOVE command");
    }

    my($from, $to) = @args;

    if (!is_valid_filename($from) || !is_valid_filename($to)) {
	fatal("Invalid filename in MOVE command");
    }

    if ($from =~ /\.(bz2|xz|sign)$/) {
	fatal("MOVE of individual .bz2, .xz, or .sign files not supported");
    }
    if ($to =~ /\.(bz2|xz|sign)$/) {
	fatal("MOVE to filename ending in .bz2, .xz or .sign");
    }
    
    if ($from =~ /\.gz$/ && $to !~ /\.gz$/) {
	fatal("MOVE of .gz file must itself end in .gz");
    }
    if ($from !~ /\.gz$/ && $to =~ /\.gz$/) {
	fatal("MOVE of non-.gz file must not end in .gz");
    }

    lock_tree();

    if (-d $data_path.$from) {
	if (!rename($data_path.$from, $data_path.$to)) {
	    fatal("MOVE of directory failed");
	}
    } elsif (-f $data_path.$from) {
	if ($from =~ /^(.*)\.gz$/) {
	    my $from_stem = $1;

	    die if ($to !~ /^(.*)\.gz$/); # Should already be checked
	    my $to_stem = $1;

	    if (-e $data_path.$to_stem) {
		fatal("Filename conflict (compressed and uncompressed)");
	    }

	    if ((-e $data_path.$to_stem.'.gz' && ! -f _)
		(-e $data_path.$to_stem.'.bz2' && ! -f _)
		(-e $data_path.$to_stem.'.xz' && ! -f _)
		(-e $data_path.$to_stem.'.sign' && ! -f _)) {
		fatal("Trying to overwrite a non-file");
	    }

	    if (!rename($data_path.$from_stem.'.gz',   $data_path.$to_stem.'.gz') ||
		!rename($data_path.$from_stem.'.bz2',  $data_path.$to_stem.'.bz2') ||
		!rename($data_path.$from_stem.'.xz',   $data_path.$to_stem.'.xz') ||
		!rename($data_path.$from_stem.'.sign', $data_path.$to_stem.'.sign')) {
		fatal("MOVE of compressed file failed");
	    }
	} else {
	    if (-e $data_path.$to.'.gz' ||
		-e $data_path.$to.'.bz2' ||
		-e $data_path.$to.'.xz') {
		fatal("Filename conflict (compressed and uncompressed)");
	    }

	    if ((-e $data_path.$to && ! -f _) ||
		(-e $data_path.$to.'.sign' && ! -f _)) {
		fatal("Trying to overwrite non-directory");
	    }

	    if (!rename($data_path.$from, $data_path.$to) ||
		!rename($data_path.$from.'.sign', $data_path.$to.'.sign') {
		fatal("MOVE of plain file failed");
	    }
	}
    } else {
	fatal("MOVE of non-directory/non-file not currently supported");
    }

    unlock_tree();
}

my $line;
while (defined($line = <STDIN>)) {
    # Ignore lines with only whitespace or starting with #
    next if ($line =~ /^\s*(|\#.*)$/);

    chomp $line;

    if (!is_clean_string($line) || length($line) > 4096) {
	syslog(LOG_ERR, "Received garbage input");
	fatal("Invalid command");
    }

    syslog(LOG_NOTICE, "Cmd: $line");

    my($cmd, @args) = parse_line($line);

    if (!defined($cmd)) {
	fatal("Syntax error");
    }

    if ($cmd eq 'DATA') {
	get_raw_data(@args);
    } elsif ($cmd eq 'TAR') {
	get_tar_data(@args);
    } elsif ($cmd eq 'DIFF') {
	get_diff_data(@args);
    } elsif ($cmd eq 'SIGN') {
	get_sign_data(@args);
    } elsif ($cmd eq 'PUT') {
	put_file(@args);
    } elsif ($cmd eq 'MKDIR') {
	do_mkdir(@args);
    } elsif ($cmd eq 'MOVE') {
	move_file(@args);
    } elsif ($cmd eq 'DONE') {
	last;
    } else {
	fatal("Invalid command");
    }
}

syslog(LOG_NOTICE, "Session completed successfully");
exit 0;