#!/usr/bin/perl -T
## -----------------------------------------------------------------------
##
##   Copyright 2011 Intel Corporation; author: H. Peter Anvin
##
##   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, Inc.; either version 2
##   of the License, or (at your option) any later version;
##   incorporated herein by reference.
##
## -----------------------------------------------------------------------

#
# 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>
# LINK old-path new-path
#		- hard links <old-path> to <new-path>
# DELETE old-path
#		- removes <old-path>
# DIR path
#		- lists the contents of <path> on stdout; must be a directory
# INFO
#		- prints the server version and, with gitolite, the user's rules
# DONE
#		- optional command, terminates transaction
#
# For future consideration:
#
# SYMLINK old-path:new-path
#		- symlinks <old-path> to <new-path>
#

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

use File::Temp qw(tempdir);
use File::Path qw(make_path);
use BSD::Resource;
use Fcntl qw(:DEFAULT :flock :mode);
use POSIX;
use IO::Handle;

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

use Digest::SHA;

my $VERSION = '0.4.0';

# Only the gitolite backend may use these, and only after checking them.
# Everything else goes: gitolite's own G3T_RC, for one, names a file that
# Gitolite::Rc would execute.
my %gl_env = map { $_ => $ENV{$_} } grep { defined($ENV{$_}) }
	qw(HOME GL_USER GL_LIBDIR GL_BINDIR);

# Scrub the environment completely
%ENV = ('PATH' => '/bin:/usr/bin',
		'LANG' => 'C',
		'SHELL' => '/bin/false'); # Nothing in this program should shell out

# The standard function to call on bail
sub fatal($) {
	no bytes;

	my($msg) = @_;

	$msg =~ s/[\x{0000}-\x{001f}\x{007f}-\x{00a0}\x{fffd}-\x{ffff}]/ /g;

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

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

	if (!defined($name) || $whoami != $uid) {
		fatal("You don't exist, go away!");
	}

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

# gitolite runs every user as the same Unix account and says who they
# really are in GL_USER.  Load gitolite's access rules from its libraries
# and return that user name.
sub gitolite_username() {
	# gitolite's USERNAME_PATT, minus groups.  The name also ends up in
	# file names (keyring, per-user tmp dir), so it must not contain '/'.
	my $user = $gl_env{'GL_USER'} // '';
	if ($user !~ /^([0-9A-Za-z][-0-9A-Za-z._\@+]*)\z/) {
		fatal("Missing or invalid GL_USER");
	}
	$ENV{'GL_USER'} = $1;

	foreach my $v ('HOME', 'GL_LIBDIR', 'GL_BINDIR') {
		my $dir = $gl_env{$v};
		# gitolite-shell sets GL_BINDIR, but sig-note-to-kup style
		# callers don't, and gitolite only needs it to run commands
		next if (!defined($dir) && $v eq 'GL_BINDIR');
		if (!defined($dir) || $dir !~ m:^(/[^\0]*)\z:) {
			fatal("Missing or invalid $v");
		}
		$ENV{$v} = $1;
	}

	unshift(@INC, $ENV{'GL_LIBDIR'});
	# Gitolite::Common takes over die and warn for the whole program,
	# which would prefix our errors with "FATAL:" and turn Git.pm's
	# exception objects into strings that git_cmd_try can't catch
	my %sig = map { $_ => $SIG{$_} } ('__DIE__', '__WARN__');
	eval {
		require Gitolite::Easy;
		require Gitolite::Conf::Load;
		1;
	} or fatal("Cannot load the gitolite libraries");
	@SIG{keys %sig} = values %sig;
	# Gitolite::Rc puts GL_BINDIR in front of PATH.  Without one that is
	# an empty entry, which taint mode refuses on the first exec, and the
	# programs we run are all in /bin or /usr/bin anyway
	$ENV{'PATH'} = '/bin:/usr/bin';

	return $ENV{'GL_USER'};
}

# Until we know who the user is
openlog("kup-server", 'ndelay,pid', LOG_LOCAL5);

# Get config values from kup-server.cfg
my $cfg_file = '/etc/kup/kup-server.cfg';

my $cfg = new Config::Simple($cfg_file);

if (!defined($cfg)) {
	fatal('Error reading config file: '.$cfg_file);
}

# unix: one Unix account per uploader, access control by file permissions
# gitolite: one shared account, access control by gitolite rules
my $auth_backend = $cfg->param('auth.backend') // 'unix';
my $user_name;

if ($auth_backend eq 'unix') {
	# gitolite runs everyone as one Unix user, so a gitolite setup that
	# lost its [auth] line would let any user change anything
	if (defined($gl_env{'GL_USER'})) {
		fatal("GL_USER is set, but the auth backend is not gitolite");
	}
	$user_name = my_username();
} elsif ($auth_backend eq 'gitolite') {
	$user_name = gitolite_username();
} else {
	fatal("Unknown auth backend: $auth_backend");
}

closelog();
openlog("kup-server($user_name)", 'ndelay,pid', LOG_LOCAL5);

my $data_path = $cfg->param('paths.data_path');
my $git_path  = $cfg->param('paths.git_path');
my $lock_file = $cfg->param('paths.lock_file');
my $tmp_path  = $cfg->param('paths.tmp_path');
my $pgp_path  = $cfg->param('paths.pgp_path');

# Signatures are checked by the "verifier": gpgv with a <user>.gpg keyring
# in pgp_path, or sq with <user>.asc certificates.  An optional "shadow"
# verifier checks them too, but only logs when it disagrees; it is for
# moving from one verifier to the other.
my %pgp_program = ('gpgv' => '/usr/bin/gpgv', 'sq' => '/usr/bin/sq');

sub pgp_program($) {
	my($v) = @_;

	if (!exists($pgp_program{$v})) {
		fatal("Unknown PGP verifier: $v");
	}
	my $prog = $cfg->param("pgp.$v") // $pgp_program{$v};
	# It is run without a shell, so it can't rely on PATH
	if ($prog !~ m:^(/[^\0]*)\z:) {
		fatal("pgp.$v must be an absolute path");
	}
	return $1;
}

my $pgp_verifier = $cfg->param('pgp.verifier') // 'gpgv';
my $pgp_shadow   = $cfg->param('pgp.shadow') // '';
$pgp_program{$pgp_verifier} = pgp_program($pgp_verifier);
if ($pgp_shadow ne '') {
	if ($pgp_shadow eq $pgp_verifier) {
		fatal("pgp.shadow must differ from pgp.verifier");
	}
	$pgp_program{$pgp_shadow} = pgp_program($pgp_shadow);
}

my $max_data = int($cfg->param('limits.max_data'));
my $bufsiz   = int($cfg->param('limits.bufsiz'));

my $timeout_command      = int($cfg->param('limits.timeout_command'));
my $timeout_data         = int($cfg->param('limits.timeout_data'));
my $timeout_compress     = int($cfg->param('limits.timeout_compress'));
my $timeout_compress_cpu = int($cfg->param('limits.timeout_compress_cpu'));

# Make sure the user can't create insanely large files
setrlimit(RLIMIT_FSIZE, $max_data, $max_data);

# Do we have a [compressors.use] in the config file?
my %zformats;

if (defined($cfg->param('compressors.use'))) {

	foreach my $zformat ($cfg->param('compressors.use')) {
		my $ext = '.' . $zformat;
		# Do we have a path defined?
		if (!defined($cfg->param("compressors.${zformat}"))) {
			# Do we have a section with compress/decompress commands?
			if (!defined($cfg->param("${zformat}.compress_command"))) {
				fatal("Compressor ${zformat} requested, but commands not specified.");
			}
			$zformats{$ext} = {
				'compress'   => $cfg->param("${zformat}.compress_command"),
				'decompress' => $cfg->param("${zformat}.decompress_command"),
			}
        } else {
			# We have old-style definition, so just add -9 and -cd to it
			$zformats{$ext} = {
				'compress' => $cfg->param("compressors.${zformat}") . " -9",
				'decompress' => $cfg->param("compressors.${zformat}") . " -cd",
			}
		}
	}

} else {
	%zformats = (
		'.gz'  => {
			'compress'   => '/bin/gzip -9',
			'decompress' => '/bin/gzip -cd',
		},
		'.bz2' => {
			'compress'   => '/usr/bin/bzip2 -9',
			'decompress' => '/usr/bin/bzip2 -cd',
		},
		'.xz'  => {
			'compress' => '/usr/bin/xz -9',
			'decompress' => '/usr/bin/xz -cd',
		},
	);
}

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

# Create a temporary directory with plenty of randomness
sub make_temp_dir() {
	my $root;
	my $urand;
	my $randbytes;

	# If tmp_path ends in /, we are using per-user tmp directories
	$root = $tmp_path;
	if ($root =~ m:/$:) {
		$root .= $user_name;
	}

	sysopen($urand, '/dev/urandom', O_RDONLY)
		or fatal("/dev/urandom not accessible");
	sysread($urand, $randbytes, 16); # 16 bytes = 128 bits
	close($urand);

	if (length($randbytes) != 16) {
		fatal("/dev/urandom returned a short read");
	}

	my $template = sprintf("%02x" x 16, unpack("C*", $randbytes));

	# $template will be tainted, because it is computed from a file read;
	# check that it looks like we expect and then untaint
	if ($template !~ /^([0-9a-f]{32})$/) {
		fatal("Internal error, a hex string is not a hex string");
	}
	$template = $1.'-XXXXXXXXXXXX';

	umask(077);
	my $dir = tempdir($template, DIR => $root, CLEANUP => 1);
}

my $tmpdir = make_temp_dir();
if (!defined($tmpdir)) {
	fatal("Failed to create session directory");
}
umask(002);

my $lock_fd   = undef;

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;
	}
}

# Encode a string; this is used by the DIR command
# It would probably be more user-friendly if valid, printable,
# multibyte UTF-8 was allowed in the output...
sub url_encode($)
{
	my($s) = @_;

	# Hack to encode an empty string
	return '%' if ($s eq '');

	my $o = '';

	foreach my $c (unpack("C*", $s)) {
		if ($c > 32 && $c < 126 && $c != 37 && $c != 43) {
			$o .= chr($c);
		} elsif ($c == 32) {
			$o .= '+';
		} else {
			$o .= sprintf("%%%02X", $c);
		}
	}

	return $o;
}

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 ($c !~ /^[0-9a-f]{2}$/i);
			$o .= pack("C", hex $c);
			$i += 2;
		} else {
			$o .= $c;
		}
	}

	return $o;
}

# 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;
}

# Decode the argument line
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) || !is_clean_string($a));
			push(@args, $a);
		}
	}

	return ($cmd, @args);
}

# This returns true if the given argument is a valid filename in its
# canonical form.  Double slashes, relative paths, dot files, control
# characters, and malformed UTF-8 is not permitted.  We cap the length
# of each pathname component to 100 bytes to we can add an extension
# without worrying about it, and the entire pathname to 1024 bytes.
sub is_valid_filename($)
{
	use bytes;

	my($f) = @_;

	return 0 if (length($f) > 1024); # Reject ridiculously long paths
	return 0 if (!is_clean_string($f)); # Reject bad UTF-8 and control characters
	return 0 if ($f !~ m:^/:);		# Reject relative paths
	return 0 if ($f =~ m:/$:);		# Reject paths ending in /
	return 0 if ($f =~ m://:);		# Reject double slashes

	# Reject filename components starting with dot or dash, covers . and ..
	return 0 if ($f =~ m:/[\.\-]:);

	# Reject undesirable filename characters anywhere in the name.
	# This isn't inherently security-critical, and could be tuned if
	# users need it...
	return 0 if ($f =~ m:[\!\"\$\&\'\*\;\<\>\?\\\`\|]:);

	# Make sure we can create a filename after adding .bz2 or similar.
	# We can't use the obvious regexp here, because regexps operate on
	# characters, not bytes.  The limit of 100 is semi-arbitrary, but
	# we shouldn't need filenames that long.
	my $n = 0;
	my $nmax = 0;
	for (my $i = 0; $i < length($f); $i++) {
		my $c = substr($f, $i, 1);
		$n = ($c eq '/') ? 0 : $n+1;
		$nmax = ($n > $nmax) ? $n : $nmax;
	}
	return 0 if ($nmax > 100);

	return 1;
}

# Fail unless the user may do $op on $path, which must already be valid.
#
# gitolite rules are written for the fake repo "@kup-server", using the
# path without its leading slash as the ref name:
#
#     repo @kup-server
#         R    = @all
#         RW+C pub/people/USER/ = @all
#
# W puts files (PUT, and LINK or MOVE to a path), + removes them (DELETE,
# MOVE from a path), C makes directories (MKDIR, and MOVE of a directory
# to a path), R lists them (DIR).  As everywhere in gitolite, any W rule
# implies R.
# "read" is about a git tree under git_path, which must be readable as
# a gitolite repo of the same name.
my %gitolite_perm = ('put' => 'W', 'delete' => '+', 'mkdir' => 'C');

# Can the user get $perm on $ref of "@kup-server"?
sub gitolite_can($$)
{
	my($perm, $ref) = @_;

	# On success, gitolite returns the rule that matched
	my $refex = Gitolite::Conf::Load::access('@kup-server', $user_name,
						 $perm, $ref);
	return 0 if ($refex =~ /DENIED/);

	# gitolite puts the user name into "USER" rules as a regex, so the
	# rule for "a.b" also matches the directory "aXb"
	my $name = quotemeta($user_name);
	$refex =~ s:/\Q$user_name\E/:/$name/:g;
	return ($ref =~ /^$refex/);
}

sub authorize($$)
{
	my($op, $path) = @_;

	return if ($auth_backend ne 'gitolite');

	my $ok = 0;
	# gitolite dies on names that kup allows but it doesn't (non-ASCII,
	# brackets, ...); those are simply not covered by any rule
	eval {
		if ($op eq 'read') {
			my($repo) = ($path =~ m:^/(.*?)(\.git)?$:);
			$ok = Gitolite::Easy::can_read($repo);
		} elsif ($op eq 'list') {
			$ok = Gitolite::Easy::can_read('@kup-server');
		} else {
			my $ref = 'refs/heads'.$path;
			# Rules for a directory end in a slash, which "MKDIR /foo"
			# or "DELETE /foo" for that directory itself never match
			$ok = gitolite_can($gitolite_perm{$op}, $ref) ||
				  gitolite_can($gitolite_perm{$op}, $ref.'/');
		}
		1;
	} or syslog(LOG_WARNING, "gitolite: %s", $@ =~ s/\s+$//r);

	fatal("Permission denied: $op $path") if (!$ok);
}

# Return a percentage, valid even if the denominator is zero
sub percentage($$)
{
	my($num, $den) = @_;

	return 100 if $num eq $den || $den eq 0;
	return sprintf('%.1f', 100*$num/$den);
}

sub get_blob($$@)
{
	my($cmd, $name, @args) = @_;
	my($len, $format) = @args;

	if (!defined($format) || $len !~ /^[0-9]+$/) {
		fatal("Bad $cmd command");
	}

	my $zcmd;

	if ($format eq '') {
		undef $zcmd;
	} elsif (!defined($zcmd = $zformats{'.'.$format}{'decompress'})) {
		fatal("Unsupported compression format");
	}

	my $output = $tmpdir.'/'.$name;

	my $outfd;
	my $writefd;
	my $oldstdout;

	local $SIG{'ALRM'} = sub { fatal("Timeout waiting for data"); };

	open($outfd, '>', $output)
		or fatal("Failed to open $cmd file");
	binmode($outfd);

	if (defined($zcmd)) {
		my @c = split(/\s+/, $zcmd);
		open($oldstdout, '>&', \*STDOUT) or die;
		open(STDOUT, '>&', $outfd) or die;
		close($outfd);
		undef $outfd;

		open($outfd, '|-', @c) or die;
		binmode($outfd);

		open(STDOUT, '>&', $oldstdout) or die;
		close($oldstdout);
	}

	# We don't show a progress bar if the transfer is very short or
	# quick, like with typical signatures.
	my $prog_time = time() + 2;
	my $prog_perc = -1;

	my $left = $len;
	while ($left) {
		my $blk = $left < $bufsiz ? $left : $bufsiz;
		my $data;
		my $rl;

		alarm($timeout_data);
		$blk = read(STDIN, $data, $blk);
		alarm(0);

		if ($blk < 1) {
			fatal("End of stream before end of $cmd");
		}

		if (!print $outfd $data) {
			fatal("Write error during $cmd");
		}

		$left -= $blk;

		# STDERR needs to be flushed
		STDERR->autoflush(1);

		my $now  = time();
		my $perc = percentage($len-$left, $len);
		if ($left == 0 ?
			($prog_perc >= 0) :				# Show 100% iff we already showed a progress bar
			($now > $prog_time && $perc != $prog_perc)) {
			printf STDERR "%10u [%-50s] %4s%%\r", $len, '=' x ($perc >> 1), $perc;
			$prog_perc = $perc;
			$prog_time = $now;
		}
	}

	close($outfd)
		or fatal("Write error during $cmd");

	print STDERR "\n" if ($prog_perc >= 0);

	syslog(LOG_DEBUG, "%u bytes read, %u bytes written", $len, -s $output);
	return $len;
}

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

	if (get_blob('DATA', 'data', @args) > $max_data) {
		# This should never happen, as we should have died already
		fatal("DATA output impossibly large");
	}

	$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");
	}
	# Before looking at the disk, so it doesn't tell which repos exist
	authorize('read', $tree);

	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 (!defined($type) || $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");
	}
	authorize('read', $tree);

	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 (!defined($type1) || $type1 !~ /^(tree|commit|tag)$/) {
		fatal("Invalid tree reference");
	}

	my ($sha2, $type2, $len2) = check_ref($repo, $ref2);
	if (!defined($type2) || $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 (get_blob('SIGN', 'data.sign', @args) >= 65536) {
		fatal("SIGN output impossibly large");
	}

	$have_sign = 1;
}

sub term_children(@)
{
	my(%workers) = @_;
	foreach my $c (keys %workers) {
		kill('TERM', $c);
	}
}

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

	my %workers;
	my %infds;
	my $nworkers = 0;

	my $tarsize = -s $tmpdir.'/data';

	foreach my $e (keys(%zformats)) {
		my @c = split(/\s+/, $zformats{$e}{'compress'});

		sysopen($infds{$e}, $tmpdir.'/data', O_RDONLY) or
		    fatal("Failed to open uncompressed data file");

		my $w = fork();

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

		if ($w == 0) {
			open(STDIN, '<&', $infds{$e}) or exit 127;
			close($infds{$e});
			open(STDOUT, '>', $tmpdir.'/data'.$e) or exit 127;

			# This is necessary to work around a bug in Perl 5.10.1;
			# if we don't do this then Perl 5.10.1 seeks to the point
			# in STDIN which matches the number of bytes that has been
			# read from STDIN since the beginning of the script, ignoring
			# the fact that STDIN was just redirected above.
			seek(STDIN, 0, 0);

			setrlimit(RLIMIT_CPU, $timeout_compress_cpu, $timeout_compress_cpu);

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

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

	my $start_time = time();

	# STDERR needs to be flushed
	STDERR->autoflush(1);

	# A pipe to notify SIGCHLD
	pipe(my $sigchldrd, my $sigchldwr)
	    or fatal("Failed to create notification pipe");

	local $SIG{'CHLD'} = sub {
		syswrite($sigchldwr, "\0", 1)
		    or fatal("Notification pipe write error");
	};

	my $waitvec = '';
	vec($waitvec, fileno($sigchldrd),1) = 1;

	my $status_wait = 2; # Frequency of status updates

	while ($nworkers) {
		my $w = waitpid(-1, WNOHANG);
		my $status = $?;

		if ($w == 0) {
			my $now = time();
			if ($now - $start_time >= $timeout_compress) {
				print STDERR "\n";
				term_children(%workers);
				fatal("Timeout compressing output data");
			}

			if (select(my $wvout = $waitvec, undef, undef, $status_wait) == 1) {
				# Drain the notification pipe
				sysread($sigchldrd, my $junk, 1);
			}
		}

		my @ostr = ();
		foreach my $e (sort(keys %infds)) {
			my $fpos = sysseek($infds{$e}, 0, SEEK_CUR);
			push(@ostr,
				sprintf("%s:%4s%%", $e,
					percentage($fpos, $tarsize)));
		}
		print STDERR "Compressing: ", join(' ', @ostr), "\r";

		if (defined($workers{$w})) {
			my $e = $workers{$w};
			undef $workers{$w};
			if ($status) {
				print STDERR "\n";
				term_children(%workers);
				fatal("Failed to compress output data");
			}

			my $zsize = -s $tmpdir.'/data'.$e;

			my $zpc = percentage($zsize, $tarsize);

			syslog(LOG_DEBUG, "%s compression: %u -> %u bytes (%s%%)",
				   $e, $tarsize, $zsize, $zpc);

			$nworkers--;
		}
	}

	close($sigchldrd);
	close($sigchldwr);

	foreach my $fd (values %infds) {
		close($fd);
	}

	print STDERR "\n";
}

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

	my $now = time();

	foreach my $e ('', keys(%zformats), '.sign') {
		utime($now, $now, $tmpdir.'/data'.$e);
	}
}

sub cleanup()
{
	foreach my $e ('', keys(%zformats), '.sign') {
		unlink($tmpdir.'/data'.$e);
	}

	$have_data = 0;
	$have_sign = 0;
}

# Exit codes that mean the verifier did its job; any other result means
# it is broken (sq exits with 2 when it doesn't know an option, say), and
# that must never look like a bad signature
my %pgp_exit_ok = ('gpgv' => { 0 => 1, 1 => 1, 2 => 1 },
		   'sq'   => { 0 => 1, 1 => 1 });

# Read at most 64 KiB of a file; what the verifiers say about one signature
# is far smaller, and anything more would only be logged truncated anyway
sub read_small_file($)
{
	my($file) = @_;
	my $fh;
	open($fh, '<', $file) or return '';
	my $s = '';
	read($fh, $s, 65536);
	close($fh);
	return $s;
}

# Run @cmd without a shell; returns its wait status, stdout and stderr
sub run_capture(@)
{
	my(@cmd) = @_;
	my $out = $tmpdir.'/capture.out';
	my $err = $tmpdir.'/capture.err';

	my $pid = fork();
	if (!defined($pid)) {
		fatal("Fork failed");
	} elsif ($pid == 0) {
		open(STDIN, '<', '/dev/null') or POSIX::_exit(127);
		open(STDOUT, '>', $out) or POSIX::_exit(127);
		open(STDERR, '>', $err) or POSIX::_exit(127);
		{ no warnings 'exec'; exec {$cmd[0]} @cmd; }
		POSIX::_exit(127);
	}
	waitpid($pid, 0);
	my $status = $?;
	my $stdout = read_small_file($out);
	my $stderr = read_small_file($err);
	unlink($out, $err);

	return ($status, $stdout, $stderr);
}

# Squash a program's message into one line for syslog
sub one_line($)
{
	my($s) = @_;
	$s =~ s/\s+/ /g;
	$s =~ s/^ | $//g;
	return substr($s, 0, 500);
}

sub log_broken($$$)
{
	my($what, $status, $stderr) = @_;
	syslog(LOG_ERR, "pgp: %s failed: %s: %s", $what,
		   ($status & 127) ? 'signal '.($status & 127)
						   : 'exit status '.($status >> 8),
		   one_line($stderr));
}

# sq checks that the signing key was live when the signature was made,
# but the signer picks that time, so an expired key could go on signing
# with backdated signatures.  Like gpgv, also require the key to be live
# now.  Returns '' if it is, the reason if it isn't, and undef if sq
# didn't run properly (that is logged).
sub sq_key_not_live()
{
	my($status, $out, $err) = run_capture($pgp_program{'sq'}, 'packet',
										  'dump', $tmpdir.'/data.sign');
	if ($status != 0) {
		log_broken('sq packet dump', $status, $err);
		return undef;
	}
	# The key that signed: a subkey, if one did.  Signatures without an
	# issuer fingerprint only have the key ID, a fingerprint suffix.
	my @issuers = ($out =~ /^\s*Issuer Fingerprint: ([0-9A-F]+)\s*$/mg);
	@issuers = ($out =~ /^\s*Issuer: ([0-9A-F]+)\s*$/mg) if (!@issuers);

	($status, $out, $err) = run_capture($pgp_program{'sq'}, '--home=none',
										'inspect',
										$pgp_path."/${user_name}.asc");
	if ($status != 0) {
		log_broken('sq inspect', $status, $err);
		return undef;
	}
	# One block per key, starting with its fingerprint; sq says
	# "Invalid: <why>" in it if the key is not usable now
	my $why = 'the signing key is not in the keyring';
	foreach my $block (split(/^(?=\s*(?:Fingerprint|Subkey|UserID):)/m, $out)) {
		next if ($block !~ /^\s*(?:Fingerprint|Subkey): ([0-9A-F]+)/);
		my $fpr = $1;
		next if (!grep { $fpr =~ /\Q$_\E$/ } @issuers);
		# With several signatures, one live signing key is enough
		return '' if ($block !~ /^\s*Invalid: (.*)$/m);
		$why = $1;
	}
	return $why;
}

# Check the session's signature with verifier $v.  Returns 1 and the
# signer's fingerprint(s) for a good signature, 0 and the verifier's
# reason for a bad one, and an empty list if the verifier didn't run
# properly (that is logged).
sub run_verifier($)
{
	my($v) = @_;
	my @cmd;

	if ($v eq 'gpgv') {
		@cmd = ($pgp_program{$v}, '--quiet', '--homedir', $tmpdir,
				'--status-fd', '1',
				'--keyring', $pgp_path."/${user_name}.gpg",
				$tmpdir.'/data.sign', $tmpdir.'/data');
	} else {
		# --home=none: no certificate store, no web of trust, nothing
		# from the account's home directory
		@cmd = ($pgp_program{$v}, '--home=none', 'verify',
				'--signer-file', $pgp_path."/${user_name}.asc",
				'--signature-file', $tmpdir.'/data.sign', $tmpdir.'/data');
	}

	my($status, $stdout, $stderr) = run_capture(@cmd);

	# gpgv also exits with 2 when it can't run at all (a bad option, say),
	# but then it hasn't printed any status line.  The one rejection that
	# doesn't print one either is an inline-signed message sent as SIGN.
	if (($status & 127) || !$pgp_exit_ok{$v}{$status >> 8} ||
		($v eq 'gpgv' && $status != 0 && $stdout !~ /^\[GNUPG:\] /m &&
		 $stderr !~ /not a detached signature/)) {
		log_broken($v, $status, $stderr);
		return ();
	}
	return (0, one_line($stderr)) if ($status != 0);

	if ($v eq 'gpgv') {
		# gpgv accepts a signature from a revoked or expired key, and
		# only says so in its status output
		if ($stdout =~ /^\[GNUPG:\] REVKEYSIG /m) {
			return (0, 'the signing key is revoked');
		}
		if ($stdout =~ /^\[GNUPG:\] EXPKEYSIG /m) {
			return (0, 'the signing key has expired');
		}
	} else {
		my $why = sq_key_not_live();
		return () if (!defined($why));
		return (0, $why) if ($why ne '');
	}

	my @fpr = ($v eq 'gpgv')
		? ($stdout =~ /^\[GNUPG:\] VALIDSIG (?:\S+ ){9}([0-9A-F]+)$/mg)
		: ($stderr =~ /signature made by ([0-9A-F]+)/g);
	return (1, join(',', @fpr) || 'unknown');
}

sub signature_valid()
{
	my($ok, $info) = run_verifier($pgp_verifier);
	if (!defined($ok)) {
		fatal("Cannot check signatures right now, please report this");
	}

	if ($pgp_shadow ne '') {
		my($shadow_ok, $shadow_info) = run_verifier($pgp_shadow);
		if (defined($shadow_ok) && $shadow_ok != $ok) {
			syslog(LOG_WARNING, "pgp: %s %s, but shadow %s %s: %s",
				   $pgp_verifier, $ok ? 'accepted' : 'rejected',
				   $pgp_shadow, $shadow_ok ? 'accepted' : 'rejected',
				   $ok ? $shadow_info : $info);
		}
	}

	if ($ok) {
		syslog(LOG_NOTICE, "pgp: signed by %s", $info);
	} else {
		syslog(LOG_NOTICE, "pgp: %s rejected the signature: %s",
			   $pgp_verifier, $info);
	}
	return $ok;
}

# Return true if the filename has one of the extensions in the list
sub has_extension($@) {
	my($file, @exts) = @_;

	foreach my $e (@exts) {
		return 1 if (substr($file, -length($e)) eq $e);
	}

	return 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");
	}
	authorize('put', $file);

	my @install_ext;
	my @conflic_ext;
	my $stem;

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

		make_compressed_data();

		@conflic_ext = ('');
		@install_ext = ('.sign', keys(%zformats));
	} elsif (has_extension($file, '.sign', keys(%zformats))) {
		fatal("$file: Cannot install auxiliary files directly");
	} else {
		$stem = $file;

		@conflic_ext = keys(%zformats);
		@install_ext = ('.sign', '');
	}

	make_timestamps_match();

	foreach my $e (@install_ext) {
		if ($e ne '.sign') {
			# Should we make the digest algo configurable?
			my $sha = Digest::SHA->new('sha256');
			print STDERR "\rCalculating sha256 for ".$stem.$e." ";
			$sha->addfile($tmpdir.'/data'.$e);
			syslog(LOG_NOTICE, "sha256: %s: %s", $stem.$e, $sha->hexdigest);
		}
	}
	print STDERR "... logged.\n";

	lock_tree();

	foreach my $e (@conflic_ext) {
		if (-e $data_path.$stem.$e) {
			fatal("$file: Filename conflict (compressed and uncompressed)");
		}
	}

	my $ok = 1;
	foreach my $e (@install_ext) {
		if (-e $data_path.$stem.$e && ! -f _) {
			fatal("$file: Trying to overwrite a non-file");
		}
	}

	my @undoes = ();
	foreach my $e (@install_ext) {
		my $target = $data_path.$stem.$e;
		if (!rename($tmpdir.'/data'.$e, $target)) {
			my $err = $!;
			unlink(@undoes);
			$! = $err;
			fatal("$file: Failed to install files: $!");
		}
		push(@undoes, $target);
	}

	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");
	}
	authorize('mkdir', $file);

	my @badext = ('.sign', keys(%zformats));

	foreach my $e (@badext) {
		if (substr($file, -length($e)) eq $e) {
			fatal("Protected filename space");
		}
	}

	lock_tree();

	foreach my $e (@badext) {
		if (-e $data_path.$file.$e) {
			fatal("Filename conflict (file and directory)");
		}
	}

	make_path($data_path.$file, {
				mode  => 0777,
				error => \my $err,
	});

	if (@$err) {
		for my $diag (@$err) {
			my ($file, $message) = %$diag;
			if ($file eq '') {
				fatal("General error: $message");
			} else {
				fatal("Problem creating $file: $message");
			}
		}
	}

	unlock_tree();
}

sub do_rename($$) {
	my($f,$t) = @_;

	return rename($f, $t);
}
sub undo_rename($$) {
	my($f, $t) = @_;

	rename($t, $f);
}

sub do_link($$) {
	my($f,$t) = @_;

	return link($f, $t);
}
sub undo_link($$) {
	my($f,$t) = @_;

	unlink($t);
}

sub move_or_link_file($@)
{
	my($cmd, @args) = @_;

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

	my $op   = ($cmd eq 'MOVE') ? \&do_rename   : \&do_link;
	my $unop = ($cmd eq 'MOVE') ? \&undo_rename : \&undo_link;

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

	if (!is_valid_filename($from) || !is_valid_filename($to)) {
		fatal("Invalid filename in $cmd command");
	}
	authorize('delete', $from) if ($cmd eq 'MOVE');
	authorize('put', $to);

	if ($from =~ /\.gz$/) {
		if ($to !~ /\.gz$/) {
			fatal("$cmd of .gz file must itself end in .gz");
		}
	} elsif (has_extension($from, '.sign', keys(%zformats))) {
		fatal("$cmd to auxiliary files not supported");
	} elsif (has_extension($to, '.sign', keys(%zformats))) {
		fatal("$cmd to auxiliary filename space");
	}

	lock_tree();

	my $from_stem;
	my $to_stem;
	my @conflic_ext = ();
	my @install_ext = ();
	my $type;

	if (!-e $data_path.$from) {
		fatal("$cmd of nonexistent object");
	} elsif (-d $data_path.$from) {
		if ($cmd ne 'MOVE') {
			fatal("Cannot $cmd a directory");
		}
		# Otherwise a directory made where C is allowed could be moved
		# to where it isn't.  Checked under the lock, so $from can't
		# turn into a directory after the check.
		authorize('mkdir', $to);

		if (-e $data_path.$to) {
			fatal("Directory MOVE destination busy");
		}

		if (!rename($data_path.$from, $data_path.$to)) {
			fatal("$cmd of directory failed");
		}

		unlock_tree();
		return;
	} elsif (-f $data_path.$from) {
		if ($from =~ /^(.*)\.gz$/) {
			$from_stem = $1;

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

			@conflic_ext = ('');
			@install_ext = ('.sign', keys(%zformats));

			$type = 'compressed';
		} else {
			$from_stem = $from;
			$to_stem   = $to;

			@conflic_ext = keys(%zformats);
			@install_ext = ('.sign', '');

			$type = 'plain';
		}
	} else {
		fatal("$cmd of non-directory/non-file not currently supported");
	}

	# If we continue here we're processing a file...

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

	foreach my $e (@install_ext) {
		if (-e $data_path.$to_stem.$e && ! -f _) {
			fatal("Trying to overwrite a non-file");
		}
	}

	my @undoes = ();
	foreach my $e (@install_ext) {
		my $a = [$data_path.$from_stem.$e, $data_path.$to_stem.$e];
		if (!$op->(@$a)) {
			foreach my $u (@undoes) {
				$unop->(@$u);
			}
			fatal("$cmd of $type file failed");
		}
		push(@undoes, $a);
	}

	unlock_tree();
}

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

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

	my($file) = @args;

	if (!is_valid_filename($file)) {
		fatal("Invalid pathname in DELETE command");
	}
	authorize('delete', $file);

	if ($file !~ /\.gz$/ &&
		has_extension($file, '.sign', keys(%zformats))) {
		fatal("DELETE of auxiliary files not supported");
	}

	lock_tree();

	my $stem;
	my @exts;
	my $type;

	if (!-e $data_path.$file) {
		fatal("DELETE of nonexistent object");
	} elsif (-d $data_path.$file) {
		if (!rmdir($data_path.$file)) {
			fatal("DELETE of directory failed");
		}
		unlock_tree();
		return;
	} elsif (-f $data_path.$file) {
		if ($file =~ /^(.*)\.gz$/) {
			$stem = $1;
			@exts = ('.sign', keys(%zformats));
			$type = 'compressed';
		} else {
			$stem = $file;
			@exts = ('.sign', '');
			$type = 'plain';
		}
	} else {
		fatal("DELETE of non-directory/non-file not currently supported");
	}

	# If we continue here we're processing a file...

	foreach my $e (@exts) {
		if (-e $data_path.$stem.$e && ! -f _) {
			fatal("DELETE encountered files and non-files");
		}
	}

	foreach my $e (@exts) {
		if (!unlink($data_path.$stem.$e)) {
			fatal("DELETE of $type file failed");
		}
	}

	unlock_tree();
}

sub mode_string($)
{
	my($mode) = @_;
	my $s;

	if (S_ISREG($mode)) {
		$s = '-';
	} elsif (S_ISDIR($mode)) {
		$s = 'd';
	} elsif (S_ISLNK($mode)) {
		$s = 'l';
	} else {
		# We should not have BLK, CHR, FIFO or SOCK in this hierarchy
		return '??????????';
	}

	$s .= ($mode & S_IRUSR) ? 'r' : '-';
	$s .= ($mode & S_IWUSR) ? 'w' : '-';
	$s .= ($mode & S_ISUID) ?
		(($mode & S_IXUSR) ? 's' : 'S') :
		(($mode & S_IXUSR) ? 'x' : '-');

	$s .= ($mode & S_IRGRP) ? 'r' : '-';
	$s .= ($mode & S_IWGRP) ? 'w' : '-';
	$s .= ($mode & S_ISGID) ?
		(($mode & S_IXGRP) ? 's' : 'S') :
		(($mode & S_IXGRP) ? 'x' : '-');

	$s .= ($mode & S_IROTH) ? 'r' : '-';
	$s .= ($mode & S_IWOTH) ? 'w' : '-';
	$s .= ($mode & S_ISVTX) ?
		(($mode & S_IXOTH) ? 's' : 'S') :
		(($mode & S_IXOTH) ? 'x' : '-');

	return $s;
}

my %uid_hash = ();
sub get_usr($)
{
	my($uid) = @_;

	if (defined($uid_hash{$uid})) {
		return $uid_hash{$uid};
	}

	my $usr = getpwuid($uid) || sprintf("%u", $uid);
	$usr = url_encode($usr);		# If we have really strange names...

	$uid_hash{$uid} = $usr;
	return $usr;
}

my %gid_hash = ();
sub get_grp($)
{
	my($gid) = @_;

	if (defined($gid_hash{$gid})) {
		return $gid_hash{$gid};
	}

	my $grp = getgrgid($gid) || sprintf("%u", $gid);
	$grp = url_encode($grp);		# If we have really strange names...

	$gid_hash{$gid} = $grp;
	return $grp;
}

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

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

	my($dir) = @args;

	# DIR / is permitted unlike any other command
	$dir =~ s:/$::g;
	if ($dir ne '' && !is_valid_filename($dir)) {
		fatal("Invalid pathname in DIR command");
	}
	$dir .= '/';
	authorize('list', $dir);

	my $dh;
	if (!opendir($dh, $data_path.$dir)) {
		fatal("Invalid directory in DIR command");
	}

	# Synchronization marker to make output machine-readable
	print '+++ ', url_encode($dir), "\n";

	foreach my $de (sort readdir($dh)) {
		next if ($de =~ /^\./);		# Hidden files include . and ..

		my @st = lstat($data_path.$dir.'/'.$de);

		next unless(scalar(@st) == 13);

		printf "%-10s %3u %-8s %-8s %10u %s %s\n",
				mode_string($st[2]), $st[3],
				get_usr($st[4]), get_grp($st[5]), $st[7],
				POSIX::strftime("%Y-%m-%d %H:%M:%S", gmtime($st[9])),
				url_encode($de);
	}

	closedir($dh);

	# Termination marker to make output machine-readable
	STDOUT->autoflush(1);		# At least try to flush stdout after this line
	print "\n";
	STDOUT->autoflush(0);
}

sub do_info()
{
	print "kup-server $VERSION\n";

	return if ($auth_backend ne 'gitolite');

	# Show the user's rules for "@kup-server" in kup terms
	my %xlat = (
		'R'    => 'ls',
		'RW'   => 'put',
		'RW+'  => 'put/rm/mv',
		'RWC'  => 'put/mkdir',
		'RW+C' => 'put/rm/mv/mkdir',
		'-'    => '(denied)',
	);
	print "\n";
	Gitolite::Conf::Load::load('@kup-server');
	foreach my $r (Gitolite::Conf::Load::rules('@kup-server', $user_name)) {
		my(undef, $perm, $ref) = @$r;
		$ref =~ s:^refs/heads/::;
		$ref =~ s:/USER/:/$user_name/:;
		$ref = ($ref eq 'refs/.*') ? '/*' : '/'.$ref.'*';
		printf "%-24s %s\n", ($xlat{$perm} // $perm), $ref;
	}
}

sub get_command()
{
	local $SIG{'ALRM'} = sub { fatal("Timeout waiting for command"); };

	alarm($timeout_command);
	my $line = <STDIN>;
	alarm(0);

	return $line;
}

my $line;
while (defined($line = get_command())) {
	# 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' || $cmd eq 'LINK') {
		move_or_link_file($cmd, @args);
	} elsif ($cmd eq 'DELETE') {
		delete_path(@args);
	} elsif ($cmd eq 'DIR') {
		do_dir(@args);
	} elsif ($cmd eq 'INFO') {
		do_info();
	} elsif ($cmd eq 'DONE') {
		last;
	} else {
		fatal("Invalid command");
	}
}

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

# vim: noet:
