| #!/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 |
| # 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 BSD::Resource; |
| use Fcntl qw(:DEFAULT :flock :mode); |
| use POSIX; |
| use IO::Handle; |
| |
| use Sys::Syslog qw(:standard :macros); |
| use Git; |
| |
| # 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) { |
| # We haven't called openlog() yet so we need to do it here |
| openlog("kup-server($whoami)", 'ndelay,pid', LOG_LOCAL5); |
| fatal("You don't exist, go away!"); |
| } |
| |
| return (defined($name) && $whoami == $uid) ? $name : $whoami; |
| } |
| |
| my $user_name = my_username(); |
| |
| openlog("kup-server($user_name)", '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); |
| } |
| |
| 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'); |
| |
| 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); |
| |
| # These programs are expected to accept the option |
| # -9 for compression and -cd for decompression to stdout. |
| my %zformats = ( |
| '.gz' => '/bin/gzip', |
| '.bz2' => '/usr/bin/bzip2', |
| '.xz' => '/usr/bin/xz' |
| ); |
| |
| 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; |
| } |
| |
| # Return a percentage, valid even if the denominator is zero |
| sub percentage($$) |
| { |
| my($num, $den) = @_; |
| |
| my $v = eval { int(100*$num/$den); }; |
| return defined($v) ? $v : 100; |
| } |
| |
| 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})) { |
| 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)) { |
| open($oldstdout, '>&', \*STDOUT) or die; |
| open(STDOUT, '>&', $outfd) or die; |
| close($outfd); |
| undef $outfd; |
| |
| open($outfd, '|-', $zcmd, '-cd') 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] %3u%%\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"); |
| } |
| |
| 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"); |
| } |
| |
| 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 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 = ($zformats{$e}, '-9'); |
| |
| 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) { |
| foreach my $c (keys %workers) { |
| kill('TERM', $c); |
| } |
| 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:%3u%%", $e, |
| percentage($fpos, $tarsize))); |
| } |
| print STDERR "Compressing: ", join(' ', @ostr), "\r"; |
| |
| if (defined($workers{$w})) { |
| my $e = $workers{$w}; |
| undef $workers{$w}; |
| if ($status) { |
| foreach my $c (keys %workers) { |
| kill('TERM', $c); |
| } |
| 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 (%d%%)", |
| $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; |
| } |
| |
| sub signature_valid() |
| { |
| my $oldstdout; |
| my $oldstderr; |
| my $devnull; |
| |
| # gpg(v) 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/gpgv', |
| '--quiet', |
| '--homedir', $tmpdir, |
| '--keyring', $pgp_path."/${user_name}.gpg", |
| $tmpdir.'/data.sign', $tmpdir.'/data'); |
| |
| open(STDOUT, '>&', $oldstdout); |
| close($oldstdout); |
| open(STDERR, '>&', $oldstderr); |
| close($oldstderr); |
| |
| return $status == 0; |
| } |
| |
| # 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"); |
| } |
| |
| 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(); |
| |
| 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"); |
| } |
| |
| 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)"); |
| } |
| } |
| |
| if (!mkdir($data_path.$file, 0777)) { |
| fatal("Failed to MKDIR"); |
| } |
| |
| 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"); |
| } |
| |
| 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"); |
| } |
| |
| 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"); |
| } |
| |
| 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 DELETE 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 .= '/'; |
| |
| 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 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 'DONE') { |
| last; |
| } else { |
| fatal("Invalid command"); |
| } |
| } |
| |
| syslog(LOG_NOTICE, "Session completed successfully"); |
| exit 0; |
| |
| # vim: noet: |