X-Git-Url: https://git.decadent.org.uk/gitweb/?a=blobdiff_plain;f=tools%2Fdebianqueued-0.9%2Fdebianqueued;h=d99c8c878d96a974895fb4703827c20091a3d162;hb=d1ba61d1cc6c2fc80d4d7661d58aea4c580690b0;hp=c3fdb7434d07fdbdf01a5cc3abf2e83772f3f507;hpb=9eb4b6222ce4cd1a31956c8781dca415e994cca6;p=dak.git diff --git a/tools/debianqueued-0.9/debianqueued b/tools/debianqueued-0.9/debianqueued index c3fdb743..d99c8c87 100755 --- a/tools/debianqueued-0.9/debianqueued +++ b/tools/debianqueued-0.9/debianqueued @@ -4,6 +4,7 @@ # # Copyright (C) 1997 Roman Hodek # Copyright (C) 2001-2007 Ryan Murray +# Copyright (C) 2008 Thomas Viehmann # # This program is free software. You can redistribute it and/or # modify it under the terms of the GNU General Public License as @@ -13,6 +14,7 @@ # require 5.002; +no lib '.'; use strict; use POSIX; use POSIX qw( strftime sys_stat_h sys_wait_h signal_h ); @@ -20,16 +22,22 @@ use Net::Ping; use Net::FTP; use Socket qw( PF_INET AF_INET SOCK_STREAM ); use Config; +use Sys::Hostname; +use File::Copy; +use Digest::MD5; + +setlocale(&POSIX::LC_ALL, "C"); +$ENV{"LC_ALL"} = "C"; # --------------------------------------------------------------------------- # configuration # --------------------------------------------------------------------------- package conf; -($conf::queued_dir = (($0 !~ m,^/,) ? POSIX::getcwd()."/" : "") . $0) - =~ s,/[^/]+$,,; +( $conf::queued_dir = ( ( $0 !~ m,^/, ) ? POSIX::getcwd() . "/" : "" ) . $0 ) + =~ s,/[^/]+$,,; require "$conf::queued_dir/config"; -my $junk = $conf::debug; # avoid spurious warnings about unused vars +my $junk = $conf::debug; # avoid spurious warnings about unused vars $junk = $conf::ssh_key_file; $junk = $conf::stray_remove_timeout; $junk = $conf::problem_report_timeout; @@ -39,152 +47,158 @@ $junk = $conf::valid_files; $junk = $conf::max_upload_retries; $junk = $conf::upload_delay_1; $junk = $conf::upload_delay_2; -$junk = $conf::ar; -$junk = $conf::gzip; -$junk = $conf::cp; +$junk = $conf::check_md5sum; + #$junk = $conf::ls; -$junk = $conf::chmod; -$junk = $conf::ftpdebug; -$junk = $conf::ftptimeout; -$junk = $conf::no_changes_timeout; -$junk = @conf::nonus_packages; -$junk = @conf::test_binaries; -$junk = @conf::maintainer_mail; -$junk = @conf::targetdir_delayed; -$junk = $conf::mail ||= '/usr/sbin/sendmail'; +$junk = $conf::ftpdebug; +$junk = $conf::ftptimeout; +$junk = @conf::nonus_packages; +$junk = @conf::test_binaries; +$junk = @conf::maintainer_mail; +$junk = @conf::targetdir_delayed; +$junk = $conf::mail ||= '/usr/sbin/sendmail'; +$junk = $conf::overridemail; $conf::target = "localhost" if $conf::upload_method eq "copy"; + package main; -($main::progname = $0) =~ s,.*/,,; +( $main::progname = $0 ) =~ s,.*/,,; + +($main::hostname, undef, undef, undef, undef) = gethostbyname(hostname()); my %packages = (); +my $re_file_safe_prefix = qr/\A([a-zA-Z0-9][a-zA-Z0-9_.:~+-]*)/s; +my $re_file_safe = qr/$re_file_safe_prefix\z/s; # extract -r and -k args $main::arg = ""; -if (@ARGV == 1 && $ARGV[0] =~ /^-[rk]$/) { - $main::arg = ($ARGV[0] eq '-k') ? "kill" : "restart"; - shift @ARGV; +if ( @ARGV == 1 && $ARGV[0] =~ /^-[rk]$/ ) { + $main::arg = ( $ARGV[0] eq '-k' ) ? "kill" : "restart"; + shift @ARGV; } # test for another instance of the queued already running -my ($pid, $delayed_dirs, $adelayedcore); -if (open( PIDFILE, "<$conf::pidfile" )) { - chomp( $pid = ); - close( PIDFILE ); - if (!$pid) { - # remove stale pid file - unlink( $conf::pidfile ); - } - elsif ($main::arg) { - local($|) = 1; - print "Killing running daemon (pid $pid) ..."; - kill( 15, $pid ); - my $cnt = 20; - while( kill( 0, $pid ) && $cnt-- > 0 ) { - sleep 1; - print "."; - } - if (kill( 0, $pid )) { - print " failed!\nProcess $pid still running.\n"; - exit 1; - } - print "ok\n"; - if (-e "$conf::incoming/core") { - unlink( "$conf::incoming/core" ); - print "(Removed core file)\n"; - } - for ($delayed_dirs = 0; $delayed_dirs <= $conf::max_delayed; - $delayed_dirs++) { - $adelayedcore = sprintf( "$conf::incoming_delayed/core", - $delayed_dirs ); - if (-e $adelayedcore) { - unlink( $adelayedcore ); - print "(Removed core file)\n"; - } - } - exit 0 if $main::arg eq "kill"; - } - else { - die "Another $main::progname is already running (pid $pid)\n" - if $pid && kill( 0, $pid ); - } -} -elsif ($main::arg eq "kill") { - die "No daemon running\n"; -} -elsif ($main::arg eq "restart") { - print "(No daemon running; starting anyway)\n"; +my ( $pid, $delayed_dirs, $adelayedcore ); +if ( open( PIDFILE, "<", $conf::pidfile ) ) { + chomp( $pid = ); + close(PIDFILE); + if ( !$pid ) { + + # remove stale pid file + unlink($conf::pidfile); + } elsif ($main::arg) { + local ($|) = 1; + print "Killing running daemon (pid $pid) ..."; + kill( 15, $pid ); + my $cnt = 20; + while ( kill( 0, $pid ) && $cnt-- > 0 ) { + sleep 1; + print "."; + } + if ( kill( 0, $pid ) ) { + print " failed!\nProcess $pid still running.\n"; + exit 1; + } + print "ok\n"; + if ( -e "$conf::incoming/core" ) { + unlink("$conf::incoming/core"); + print "(Removed core file)\n"; + } + for ( $delayed_dirs = 0 ; + $delayed_dirs <= $conf::max_delayed ; + $delayed_dirs++ ) + { + $adelayedcore = + sprintf( "$conf::incoming_delayed/core", $delayed_dirs ); + if ( -e $adelayedcore ) { + unlink($adelayedcore); + print "(Removed core file)\n"; + } + } ## end for ( $delayed_dirs = 0... + exit 0 if $main::arg eq "kill"; + } else { + die "Another $main::progname is already running (pid $pid)\n" + if $pid && kill( 0, $pid ); + } +} elsif ( $main::arg eq "kill" ) { + die "No daemon running\n"; +} elsif ( $main::arg eq "restart" ) { + print "(No daemon running; starting anyway)\n"; } # if started without arguments (initial invocation), then fork -if (!@ARGV) { - # now go to background - die "$main::progname: fork failed: $!\n" unless defined( $pid = fork ); - if ($pid) { - # parent: wait for signal from child (SIGCHLD or SIGUSR1) and exit - my $sigset = POSIX::SigSet->new(); - $sigset->emptyset(); - $SIG{"CHLD"} = sub { }; - $SIG{"USR1"} = sub { }; - POSIX::sigsuspend( $sigset ); - waitpid( $pid, WNOHANG ); - if (kill( 0, $pid )) { - print "Daemon started in background (pid $pid)\n"; - exit 0; - } - else { - exit 1; - } - } - else { - # child - setsid; - if ($conf::upload_method eq "ssh") { - # exec an ssh-agent that starts us again - # force shell to be /bin/sh, ssh-agent may base its decision - # whether to use a fd or a Unix socket on the shell... - $ENV{"SHELL"} = "/bin/sh"; - exec $conf::ssh_agent, $0, "startup", getppid(); - die "$main::progname: Could not exec $conf::ssh_agent: $!\n"; - } - else { - # no need to exec, just set up @ARGV as expected below - @ARGV = ("startup", getppid()); - } - } -} +if ( !@ARGV ) { + + # now go to background + die "$main::progname: fork failed: $!\n" + unless defined( $pid = fork ); + if ($pid) { + + # parent: wait for signal from child (SIGCHLD or SIGUSR1) and exit + my $sigset = POSIX::SigSet->new(); + $sigset->emptyset(); + $SIG{"CHLD"} = sub { }; + $SIG{"USR1"} = sub { }; + POSIX::sigsuspend($sigset); + waitpid( $pid, WNOHANG ); + if ( kill( 0, $pid ) ) { + print "Daemon (on $main::hostname) started in background (pid $pid)\n"; + exit 0; + } else { + exit 1; + } + } else { + + # child + setsid; + if ( $conf::upload_method eq "ssh" ) { + + # exec an ssh-agent that starts us again + # force shell to be /bin/sh, ssh-agent may base its decision + # whether to use a fd or a Unix socket on the shell... + $ENV{"SHELL"} = "/bin/sh"; + exec $conf::ssh_agent, $0, "startup", getppid(); + die "$main::progname: Could not exec $conf::ssh_agent: $!\n"; + } else { + + # no need to exec, just set up @ARGV as expected below + @ARGV = ( "startup", getppid() ); + } + } ## end else [ if ($pid) +} ## end if ( !@ARGV ) die "Please start without any arguments.\n" - if @ARGV != 2 || $ARGV[0] ne "startup"; + if @ARGV != 2 || $ARGV[0] ne "startup"; my $parent_pid = $ARGV[1]; do { - my $version; - ($version = 'Release: 0.9 $Revision: 1.51 $ $Date: 1999/07/08 09:43:21 $ $Author: ftplinux $') =~ s/\$ ?//g; - print "debianqueued $version\n"; + my $version; + ( $version = 'Release: 0.95' ) =~ s/\$ ?//g; + print "debianqueued $version\n"; }; # check if all programs exist my $prg; foreach $prg ( $conf::gpg, $conf::ssh, $conf::scp, $conf::ssh_agent, - $conf::ssh_add, $conf::md5sum, $conf::mail, $conf::mkfifo ) { - die "Required program $prg doesn't exist or isn't executable\n" - if ! -x $prg; -# check for correct upload method -die "Bad upload method '$conf::upload_method'.\n" - if $conf::upload_method ne "ssh" && - $conf::upload_method ne "ftp" && - $conf::upload_method ne "copy"; -die "No keyrings\n" if ! @conf::keyrings; - -} + $conf::ssh_add, $conf::mail, $conf::mkfifo ) +{ + die "Required program $prg doesn't exist or isn't executable\n" + if !-x $prg; + + # check for correct upload method + die "Bad upload method '$conf::upload_method'.\n" + if $conf::upload_method ne "ssh" + && $conf::upload_method ne "ftp" + && $conf::upload_method ne "copy"; + die "No keyrings\n" if !@conf::keyrings; + +} ## end foreach $prg ( $conf::gpg, ... die "statusfile path must be absolute." - if $conf::statusfile !~ m,^/,; + if $conf::statusfile !~ m,^/,; die "upload and target queue paths must be absolute." - if $conf::incoming !~ m,^/, || - $conf::incoming_delayed !~ m,^/, || - $conf::targetdir !~ m,^/, || - $conf::targetdir_delayed !~ m,^/,; - + if $conf::incoming !~ m,^/, + || $conf::incoming_delayed !~ m,^/, + || $conf::targetdir !~ m,^/, + || $conf::targetdir_delayed !~ m,^/,; # --------------------------------------------------------------------------- # initializations @@ -217,14 +231,10 @@ sub ftp_code(); sub ftp_error(); sub ssh_cmd($); sub scp_cmd(@); -sub local_cmd($;$); sub check_alive(;$); sub check_incoming_writable(); sub rm(@); sub md5sum($); -sub is_debian_file($); -sub get_maintainer($); -sub debian_file_stem($); sub msg($@); sub debug(@); sub init_mail(;$); @@ -241,7 +251,7 @@ sub restart_statusd(); sub fatal_signal($); $ENV{"PATH"} = "/bin:/usr/bin"; -$ENV{"IFS"} = "" if defined($ENV{"IFS"} && $ENV{"IFS"} ne ""); +$ENV{"IFS"} = "" if defined( $ENV{"IFS"} && $ENV{"IFS"} ne "" ); # constants for stat sub ST_DEV() { 0 } @@ -255,99 +265,105 @@ sub ST_SIZE() { 7 } sub ST_ATIME() { 8 } sub ST_MTIME() { 9 } sub ST_CTIME() { 10 } + # fixed lengths of data items passed over status pipe sub STATNUM_LEN() { 30 } sub STATSTR_LEN() { 128 } # init list of signals -defined $Config{sig_name} or die "$main::progname: No signal list defined!\n"; +defined $Config{sig_name} + or die "$main::progname: No signal list defined!\n"; my $i = 0; my $name; -foreach $name (split( ' ', $Config{sig_name} )) { - $main::signo{$name} = $i++; +foreach $name ( split( ' ', $Config{sig_name} ) ) { + $main::signo{$name} = $i++; } @main::fatal_signals = qw( INT QUIT ILL TRAP ABRT BUS FPE USR2 SEGV PIPE - TERM XCPU XFSZ PWR ); + TERM XCPU XFSZ PWR ); $main::block_sigset = POSIX::SigSet->new; $main::block_sigset->addset( $main::signo{"INT"} ); $main::block_sigset->addset( $main::signo{"TERM"} ); # some constant net stuff -$main::tcp_proto = (getprotobyname('tcp'))[2] - or die "Cannot get protocol number for 'tcp'\n"; -my $used_service = ($conf::upload_method eq "ssh") ? "ssh" : "ftp"; -$main::echo_port = (getservbyname($used_service, 'tcp'))[2] - or die "Cannot get port number for service '$used_service'\n"; +$main::tcp_proto = ( getprotobyname('tcp') )[2] + or die "Cannot get protocol number for 'tcp'\n"; +my $used_service = ( $conf::upload_method eq "ssh" ) ? "ssh" : "ftp"; +$main::echo_port = ( getservbyname( $used_service, 'tcp' ) )[2] + or die "Cannot get port number for service '$used_service'\n"; # clear queue of stored mails @main::stored_mails = (); # run ssh-add to bring the key into the agent (will use stdin/stdout) -if ($conf::upload_method eq "ssh") { - system "$conf::ssh_add $conf::ssh_key_file" - and die "$main::progname: Running $conf::ssh_add failed ". - "(exit status ", $? >> 8, ")\n"; +if ( $conf::upload_method eq "ssh" ) { + system "$conf::ssh_add $conf::ssh_key_file" + and die "$main::progname: Running $conf::ssh_add failed " + . "(exit status ", $? >> 8, ")\n"; } # change to queue dir -chdir( $conf::incoming ) - or die "$main::progname: cannot cd to $conf::incoming: $!\n"; +chdir($conf::incoming) + or die "$main::progname: cannot cd to $conf::incoming: $!\n"; # needed before /dev/null redirects, some system send a SIGHUP when loosing # the controlling tty $SIG{"HUP"} = "IGNORE"; # open logfile, make it unbuffered -open( LOG, ">>$conf::logfile" ) - or die "Cannot open my logfile $conf::logfile: $!\n"; +open( LOG, ">>", $conf::logfile ) + or die "Cannot open my logfile $conf::logfile: $!\n"; chmod( 0644, $conf::logfile ) - or die "Cannot set modes of $conf::logfile: $!\n"; -select( (select(LOG), $| = 1)[0] ); + or die "Cannot set modes of $conf::logfile: $!\n"; +select( ( select(LOG), $| = 1 )[0] ); -sleep( 1 ); +sleep(1); $SIG{"HUP"} = \&close_log; # redirect stdin, ... to /dev/null -open( STDIN, "&LOG" ) - or die "$main::progname: Can't redirect stdout to $conf::logfile: $!\n"; -open( STDERR, ">&LOG" ) - or die "$main::progname: Can't redirect stderr to $conf::logfile: $!\n"; +open( STDIN, "<", "/dev/null" ) + or die "$main::progname: Can't redirect stdin to /dev/null: $!\n"; +open( STDOUT, ">&", \*LOG ) + or die "$main::progname: Can't redirect stdout to $conf::logfile: $!\n"; +open( STDERR, ">&", \*LOG ) + or die "$main::progname: Can't redirect stderr to $conf::logfile: $!\n"; + # ok, from this point usually no "die" anymore, stderr is gone! -msg( "log", "daemon (pid $$) started\n" ); +msg( "log", "daemon (pid $$) (on $main::hostname) started\n" ); # initialize variables used by send_status before launching the status daemon $main::dstat = "i"; -format_status_num( $main::next_run, time+10 ); +format_status_num( $main::next_run, time + 10 ); format_status_str( $main::current_changes, "" ); check_alive(); -$main::incoming_writable = 1; # assume this for now +$main::incoming_writable = 1; # assume this for now # start the daemon watching the 'status' FIFO -if ($conf::statusfile && $conf::statusdelay == 0) { - $main::statusd_pid = fork_statusd(); - $SIG{"CHLD"} = \&kid_died; # watch out for dead status daemon - # SIGUSR1 triggers status info - $SIG{"USR1"} = \&send_status; -} +if ( $conf::statusfile && $conf::statusdelay == 0 ) { + $main::statusd_pid = fork_statusd(); + $SIG{"CHLD"} = \&kid_died; # watch out for dead status daemon + # SIGUSR1 triggers status info + $SIG{"USR1"} = \&send_status; +} ## end if ( $conf::statusfile... $main::maind_pid = $$; -END { kill( $main::signo{"ABRT"}, $$ ) if defined $main::signo{"ABRT"}; } +END { + kill( $main::signo{"ABRT"}, $$ ) + if defined $main::signo{"ABRT"}; +} # write the pid file -open( PIDFILE, ">$conf::pidfile" ) - or msg( "log", "Can't open $conf::pidfile: $!\n" ); +open( PIDFILE, ">", $conf::pidfile ) + or msg( "log", "Can't open $conf::pidfile: $!\n" ); printf PIDFILE "%5d\n", $$; -close( PIDFILE ); +close(PIDFILE); chmod( 0644, $conf::pidfile ) - or die "Cannot set modes of $conf::pidfile: $!\n"; + or die "Cannot set modes of $conf::pidfile: $!\n"; # other signals will just log an error and exit -foreach ( @main::fatal_signals ) { - $SIG{$_} = \&fatal_signal; +foreach (@main::fatal_signals) { + $SIG{$_} = \&fatal_signal; } # send signal to user-started process that we're ready and it can exit @@ -358,1132 +374,1360 @@ kill( $main::signo{"USR1"}, $parent_pid ); # --------------------------------------------------------------------------- # default to classical incoming/target -$main::current_incoming = $conf::incoming; +$main::current_incoming = $conf::incoming; $main::current_targetdir = $conf::targetdir; $main::dstat = "i"; write_status_file() if $conf::statusdelay; -while( 1 ) { - - # ping target only if there is the possibility that we'll contact it (but - # also don't wait too long). - my @have_changes = <*.changes *.commands>; - for ( my $delayed_dirs = 0; $delayed_dirs <= $conf::max_delayed; - $delayed_dirs++) { - my $adelayeddir = sprintf( "$conf::incoming_delayed", - $delayed_dirs ); - push( @have_changes, - <$adelayeddir/*.changes> ); - } - check_alive() if @have_changes || (time - $main::last_ping_time) > 8*60*60; - - if (@have_changes && $main::target_up) { - check_incoming_writable if !$main::incoming_writable; - check_dir() if $main::incoming_writable; - } - $main::dstat = "i"; - write_status_file() if $conf::statusdelay; - - if ($conf::upload_method eq "copy") { - age_delayed_queues(); - } - - # sleep() returns if we received a signal (SIGUSR1 for status FIFO), so - # calculate the end time once and wait for it being reached. - format_status_num( $main::next_run, time + $conf::queue_delay ); - my $delta; - while( ($delta = calc_delta()) > 0 ) { - debug( "mainloop sleeping $delta secs" ); - sleep( $delta ); - # check if statusd died, if using status FIFO, or update status file - if ($conf::statusdelay) { - write_status_file(); - } - else { - restart_statusd(); - } - } -} +while (1) { + + # ping target only if there is the possibility that we'll contact it (but + # also don't wait too long). + my @have_changes = <*.changes *.commands *.dak-commands>; + for ( my $delayed_dirs = 0 ; + $delayed_dirs <= $conf::max_delayed ; + $delayed_dirs++ ) + { + my $adelayeddir = sprintf( "$conf::incoming_delayed", $delayed_dirs ); + push( @have_changes, <$adelayeddir/*.changes> ); + } ## end for ( my $delayed_dirs ... + check_alive() + if @have_changes || ( time - $main::last_ping_time ) > 8 * 60 * 60; + + if ( @have_changes && $main::target_up ) { + check_incoming_writable if !$main::incoming_writable; + check_dir() if $main::incoming_writable; + } + $main::dstat = "i"; + write_status_file() if $conf::statusdelay; + + if ( $conf::upload_method eq "copy" ) { + age_delayed_queues(); + } + + # sleep() returns if we received a signal (SIGUSR1 for status FIFO), so + # calculate the end time once and wait for it being reached. + format_status_num( $main::next_run, time + $conf::queue_delay ); + my $delta; + while ( ( $delta = calc_delta() ) > 0 ) { + debug("mainloop sleeping $delta secs"); + sleep($delta); + + # check if statusd died, if using status FIFO, or update status file + if ($conf::statusdelay) { + write_status_file(); + } else { + restart_statusd(); + } + } ## end while ( ( $delta = calc_delta... +} ## end while (1) sub calc_delta() { - my $delta; - - $delta = $main::next_run - time; - $delta = $conf::statusdelay - if $conf::statusdelay && $conf::statusdelay < $delta; - return $delta; -} + my $delta; + $delta = $main::next_run - time; + $delta = $conf::statusdelay + if $conf::statusdelay && $conf::statusdelay < $delta; + return $delta; +} ## end sub calc_delta() # --------------------------------------------------------------------------- # main working functions # --------------------------------------------------------------------------- - # # main function for checking the incoming dir # sub check_dir() { - my( @files, @changes, @keep_files, @this_keep_files, @stats, $file , - $adelay ); - - debug( "starting checkdir" ); - $main::dstat = "c"; - write_status_file() if $conf::statusdelay; - - # test if needed binaries are available; this is if they're on maybe - # slow-mounted NFS filesystems - foreach (@conf::test_binaries) { - next if -f $_; - # maybe the mount succeeds now - sleep 5; - next if -f $_; - msg( "log", "binary test failed for $_; delaying queue run\n"); - goto end_run; - } - - for ( $adelay=-1; $adelay <= $conf::max_delayed; $adelay++ ) { - if ( $adelay == -1 ) { - $main::current_incoming = $conf::incoming; - $main::current_incoming_short = ""; - $main::current_targetdir = $conf::targetdir; - } - else { - $main::current_incoming = sprintf( $conf::incoming_delayed, - $adelay ); - $main::current_incoming_short = sprintf( "DELAYED/%d-day", - $adelay ); - $main::current_targetdir = sprintf( $conf::targetdir_delayed, - $adelay ); - } - - # need to clear directory specific variables - undef ( @keep_files ); - undef ( @this_keep_files ); - - chdir ( $main::current_incoming ) - or (msg( "log", - "Cannot change to dir ". - "${main::current_incoming_short}: $!\n" ), - return); - - # look for *.commands files but not in delayed queues - if ( $adelay==-1 ) { - foreach $file ( <*.commands> ) { - init_mail( $file ); - block_signals(); - process_commands( $file ); - unblock_signals(); - $main::dstat = "c"; - write_status_file() if $conf::statusdelay; - finish_mail(); - } - } - opendir( INC, "." ) - or (msg( "log", "Cannot open dir ${main::current_incoming_short}: $!\n" ), - return); - @files = readdir( INC ); - closedir( INC ); - - # process all .changes files found - @changes = grep /\.changes$/, @files; - push( @keep_files, @changes ); # .changes files aren't stray - foreach $file ( @changes ) { - init_mail( $file ); - # wrap in an eval to allow jumpbacks to here with die in case - # of errors - block_signals(); - eval { process_changes( $file, @this_keep_files ); }; - unblock_signals(); - msg( "log,mail", $@ ) if $@; - $main::dstat = "c"; - write_status_file() if $conf::statusdelay; - - # files which are ok in conjunction with this .changes - debug( "$file tells to keep @this_keep_files" ); - push( @keep_files, @this_keep_files ); - finish_mail(); - - # break out of this loop if the incoming dir has become unwritable - goto end_run if !$main::incoming_writable; - } - ftp_close() if $conf::upload_method eq "ftp"; - - # find files which aren't related to any .changes - foreach $file ( @files ) { - # filter out files we never want to delete - next if ! -f $file || # may have disappeared in the meantime - $file eq "." || $file eq ".." || - (grep { $_ eq $file } @keep_files) || - $file =~ /$conf::keep_files/; - # Delete such files if they're older than - # $stray_remove_timeout; they could be part of an - # yet-incomplete upload, with the .changes still missing. - # Cannot send any notification, since owner unknown. - next if !(@stats = stat( $file )); - my $age = time - $stats[ST_MTIME]; - my( $maint, $pattern, @job_files ); - if ($file =~ /^junk-for-writable-test/ || - $file !~ m,$conf::valid_files, || - $age >= $conf::stray_remove_timeout) { - msg( "log", "Deleted stray file ${main::current_incoming_short}/$file\n" ) if rm( $file ); - } - elsif ($age > $conf::no_changes_timeout && - is_debian_file( $file ) && - # not already reported - !($stats[ST_MODE] & S_ISGID) && - ($pattern = debian_file_stem( $file )) && - (@job_files = glob($pattern)) && - # If a .changes is in the list, it has the same stem as the - # found file (probably a .orig.tar.gz). Don't report in this - # case. - !(grep( /\.changes$/, @job_files ))) { - $maint = get_maintainer( $file ); - # Don't send a mail if this looks like the recompilation of a - # package for a non-i386 arch. For those, the maintainer field is - # useless :-( - if (!grep( /(\.dsc|_(i386|all)\.deb)$/, @job_files )) { - msg( "log", "Found an upload without .changes and with no ", - ".dsc file\n" ); - msg( "log", "Not sending a report, because probably ", - "recompilation job\n" ); - } - elsif ($maint) { - init_mail(); - $main::mail_addr = $maint; - $main::mail_addr = $1 if $main::mail_addr =~ /<([^>]*)>/; - $main::mail_subject = "Incomplete upload found in ". - "Debian upload queue"; - msg( "mail", "Probably you are the uploader of the following ". - "file(s) in\n" ); - msg( "mail", "the Debian upload queue directory:\n " ); - msg( "mail", join( "\n ", @job_files ), "\n" ); - msg( "mail", "This looks like an upload, but a .changes file ". - "is missing, so the job\n" ); - msg( "mail", "cannot be processed.\n\n" ); - msg( "mail", "If no .changes file arrives within ", - print_time( $conf::stray_remove_timeout - $age ), - ", the files will be deleted.\n\n" ); - msg( "mail", "If you didn't upload those files, please just ". - "ignore this message.\n" ); - finish_mail(); - msg( "log", "Sending problem report for an upload without a ". - ".changes\n" ); - msg( "log", "Maintainer: $maint\n" ); - } - else { - msg( "log", "Found an upload without .changes, but can't ". - "find a maintainer address\n" ); - } - msg( "log", "Files: @job_files\n" ); - # remember we already have sent a mail regarding this file - foreach ( @job_files ) { - my @st = stat($_); - next if !@st; # file may have disappeared in the meantime - chmod +($st[ST_MODE] |= S_ISGID), $_; - } - } - else { - debug( "found stray file ${main::current_incoming_short}/$file, deleting in ", - print_time($conf::stray_remove_timeout - $age) ); - } - } - } - chdir( $conf::incoming ); - - end_run: - $main::dstat = "i"; - write_status_file() if $conf::statusdelay; -} + my ( @files, @changes, @keep_files, @this_keep_files, @stats, $file, + $adelay ); + + debug("starting checkdir"); + $main::dstat = "c"; + write_status_file() if $conf::statusdelay; + + # test if needed binaries are available; this is if they're on maybe + # slow-mounted NFS filesystems + foreach (@conf::test_binaries) { + next if -f $_; + + # maybe the mount succeeds now + sleep 5; + next if -f $_; + msg( "log", "binary test failed for $_; delaying queue run\n" ); + goto end_run; + } ## end foreach (@conf::test_binaries) + + for ( $adelay = -1 ; $adelay <= $conf::max_delayed ; $adelay++ ) { + if ( $adelay == -1 ) { + $main::current_incoming = $conf::incoming; + $main::current_incoming_short = ""; + $main::current_targetdir = $conf::targetdir; + } else { + $main::current_incoming = sprintf( $conf::incoming_delayed, $adelay ); + $main::current_incoming_short = sprintf( "DELAYED/%d-day", $adelay ); + $main::current_targetdir = sprintf( $conf::targetdir_delayed, $adelay ); + } + + # need to clear directory specific variables + undef(@keep_files); + undef(@this_keep_files); + + chdir($main::current_incoming) + or ( + msg( + "log", + "Cannot change to dir " + . "${main::current_incoming_short}: $!\n" + ), + return + ); + + # look for *.commands and *.dak-commands files but not in delayed queues + if ( $adelay == -1 ) { + foreach $file (<*.commands>) { + next unless $file =~ /$re_file_safe/; + init_mail($file); + block_signals(); + process_commands($file); + unblock_signals(); + $main::dstat = "c"; + write_status_file() if $conf::statusdelay; + finish_mail(); + } ## end foreach $file (<*.commands>) + foreach $file (<*.dak-commands>) { + next unless $file =~ /$re_file_safe/; + init_mail($file); + block_signals(); + process_dak_commands($file); + unblock_signals(); + $main::dstat = "c"; + write_status_file() if $conf::statusdelay; + finish_mail(); + } + } ## end if ( $adelay == -1 ) + opendir( INC, "." ) + or ( + msg( + "log", "Cannot open dir ${main::current_incoming_short}: $!\n" + ), + return + ); + @files = readdir(INC); + closedir(INC); + + # process all .changes files found + @changes = grep /\.changes$/, @files; + push( @keep_files, @changes ); # .changes files aren't stray + foreach $file (@changes) { + next unless $file =~ /$re_file_safe/; + init_mail($file); + + # wrap in an eval to allow jumpbacks to here with die in case + # of errors + block_signals(); + eval { process_changes( $file, @this_keep_files ); }; + unblock_signals(); + msg( "log,mail", $@ ) if $@; + $main::dstat = "c"; + write_status_file() if $conf::statusdelay; + + # files which are ok in conjunction with this .changes + debug("$file tells to keep @this_keep_files"); + push( @keep_files, @this_keep_files ); + finish_mail(); + + # break out of this loop if the incoming dir has become unwritable + goto end_run if !$main::incoming_writable; + } ## end foreach $file (@changes) + ftp_close() if $conf::upload_method eq "ftp"; + + # find files which aren't related to any .changes + foreach $file (@files) { + + # filter out files we never want to delete + next if !-f $file || # may have disappeared in the meantime + $file eq "." + || $file eq ".." + || ( grep { $_ eq $file } @keep_files ) + || $file =~ /$conf::keep_files/; + + # Delete such files if they're older than + # $stray_remove_timeout; they could be part of an + # yet-incomplete upload, with the .changes still missing. + # Cannot send any notification, since owner unknown. + next if !( @stats = stat($file) ); + my $age = time - $stats[ST_MTIME]; + my ( $maint, $pattern, @job_files ); + if ( $file =~ /^junk-for-writable-test/ + || $file !~ m,$conf::valid_files, + || $file !~ /$re_file_safe/ + || $age >= $conf::stray_remove_timeout ) + { + msg( "log", + "Deleted stray file ${main::current_incoming_short}/$file\n" ) + if rm($file); + } else { + debug( +"found stray file ${main::current_incoming_short}/$file, deleting in ", + print_time( $conf::stray_remove_timeout - $age ) + ); + } ## end else [ if ( $file =~ /^junk-for-writable-test/... + } ## end foreach $file (@files) + } ## end for ( $adelay = -1 ; $adelay... + chdir($conf::incoming); + +end_run: + $main::dstat = "i"; + write_status_file() if $conf::statusdelay; +} ## end sub check_dir() sub get_filelist_from_known_good_changes($) { - my $changes = shift; - - local( *CHANGES ); - my(@filenames); - - # parse the .changes file - open( CHANGES, "<$changes" ) - or die "$changes: $!\n"; - outer_loop: while( ) { - if (/^Files:/i) { - while( ) { - redo outer_loop if !/^\s/; - my @field = split( /\s+/ ); - next if @field != 6; - # forbid shell meta chars in the name, we pass it to a - # subshell several times... - $field[5] =~ /^([a-zA-Z0-9.+_:@=%-][~a-zA-Z0-9.+_:@=%-]*)/; - if ($1 ne $field[5]) { - msg( "log", "found suspicious filename $field[5]\n" ); - next; - } - push( @filenames, $field[5] ); - } - } - } - close( CHANGES ); - return @filenames; -} + my $changes = shift; + + local (*CHANGES); + my (@filenames); + + # parse the .changes file + open( CHANGES, "<", $changes ) + or die "$changes: $!\n"; +outer_loop: while () { + if (/^Files:/i) { + while () { + redo outer_loop if !/^\s/; + my @field = split(/\s+/); + next if @field != 6; + + # forbid shell meta chars in the name, we pass it to a + # subshell several times... + $field[5] =~ /$re_file_safe/; + if ( $1 ne $field[5] ) { + msg( "log", "found suspicious filename $field[5]\n" ); + next; + } + push( @filenames, $field[5] ); + } ## end while () + } ## end if (/^Files:/i) + } ## end while () + close(CHANGES); + return @filenames; +} ## end sub get_filelist_from_known_good_changes($) # # process one .changes file # sub process_changes($\@) { - my $changes = shift; - my $keep_list = shift; - my( $pgplines, @files, @filenames, @changes_stats, $failure_file, - $retries, $last_retry, $upload_time, $file, $do_report, $ls_l, - $problems_reported, $errs, $pkgname, $signator ); - local( *CHANGES ); - local( *FAILS ); - - format_status_str( $main::current_changes, "$main::current_incoming_short/$changes" ); - $main::dstat = "c"; - write_status_file() if $conf::statusdelay; - - @$keep_list = (); - msg( "log", "processing ${main::current_incoming_short}/$changes\n" ); - - # parse the .changes file - open( CHANGES, "<$changes" ) - or die "Cannot open ${main::current_incoming_short}/$changes: $!\n"; - $pgplines = 0; - $main::mail_addr = ""; - @files = (); - outer_loop: while( ) { - if (/^---+(BEGIN|END) PGP .*---+$/) { - ++$pgplines; - } - elsif (/^Maintainer:\s*/i) { - chomp( $main::mail_addr = $' ); - $main::mail_addr = $1 if $main::mail_addr =~ /<([^>]*)>/; - } - elsif (/^Source:\s*/i) { - chomp( $pkgname = $' ); - $pkgname =~ s/\s+$//; - $main::packages{$pkgname}++; - } - elsif (/^Files:/i) { - while( ) { - redo outer_loop if !/^\s/; - my @field = split( /\s+/ ); - next if @field != 6; - # forbid shell meta chars in the name, we pass it to a - # subshell several times... - $field[5] =~ /^([a-zA-Z0-9.+_:@=%-][~a-zA-Z0-9.+_:@=%-]*)/; - if ($1 ne $field[5]) { - msg( "log", "found suspicious filename $field[5]\n" ); - msg( "mail", "File '$field[5]' mentioned in $main::current_incoming_short/$changes\n", - "has bad characters in its name. Removed.\n" ); - rm( $field[5] ); - next; - } - push( @files, { md5 => $field[1], - size => $field[2], - name => $field[5] } ); - push( @filenames, $field[5] ); - debug( "includes file $field[5], size $field[2], ", - "md5 $field[1]" ); - } - } - } - close( CHANGES ); - - # tell check_dir that the files mentioned in this .changes aren't stray, - # we know about them somehow - @$keep_list = @filenames; - - # some consistency checks - if (!$main::mail_addr) { - msg( "log,mail", "$main::current_incoming_short/$changes doesn't contain a Maintainer: field; ". - "cannot process\n" ); - goto remove_only_changes; - } - if ($main::mail_addr !~ /^(buildd_\S+-\S+|\S+\@\S+\.\S+)/) { - # doesn't look like a mail address, maybe only the name - my( $new_addr, @addr_list ); - if ($new_addr = try_to_get_mail_addr( $main::mail_addr, \@addr_list )){ - # substitute (unique) found addr, but give a warning - msg( "mail", "(The Maintainer: field didn't contain a proper ". - "mail address.\n" ); - msg( "mail", "Looking for `$main::mail_addr' in the Debian ". - "keyring gave your address\n" ); - msg( "mail", "as unique result, so I used this.)\n" ); - msg( "log", "Substituted $new_addr for malformed ". - "$main::mail_addr\n" ); - $main::mail_addr = $new_addr; - } - else { - # not found or not unique: hold the job and inform queue maintainer - my $old_addr = $main::mail_addr; - $main::mail_addr = $conf::maintainer_mail; - msg( "mail", "The job ${main::current_incoming_short}/$changes doesn't have a correct email\n" ); - msg( "mail", "address in the Maintainer: field:\n" ); - msg( "mail", " $old_addr\n" ); - msg( "mail", "A check for this in the Debian keyring gave:\n" ); - msg( "mail", @addr_list ? - " " . join( ", ", @addr_list ) . "\n" : - " nothing\n" ); - msg( "mail", "Please fix this manually\n" ); - msg( "log", "Bad Maintainer: field in ${main::current_incoming_short}/$changes: $old_addr\n" ); - goto remove_only_changes; - } - } - if ($pgplines < 3) { - msg( "log,mail", "$main::current_incoming_short/$changes isn't signed with PGP/GnuPG\n" ); - msg( "log", "(uploader $main::mail_addr)\n" ); - goto remove_only_changes; - } - if (!@files) { - msg( "log,mail", "$main::current_incoming_short/$changes doesn't mention any files\n" ); - msg( "log", "(uploader $main::mail_addr)\n" ); - goto remove_only_changes; - } - - # check for packages that shouldn't be processed - if (grep( $_ eq $pkgname, @conf::nonus_packages )) { - msg( "log,mail", "$pkgname is a package that must be uploaded ". - "to nonus.debian.org\n" ); - msg( "log,mail", "instead of target.\n" ); - msg( "log,mail", "Job rejected and removed all files belonging ". - "to it:\n" ); - msg( "log,mail", " ", join( ", ", @filenames ), "\n" ); - rm( $changes, @filenames ); - return; - } - - $failure_file = $changes . ".failures"; - $retries = $last_retry = 0; - if (-f $failure_file) { - open( FAILS, "<$failure_file" ) - or die "Cannot open $main::current_incoming_short/$failure_file: $!\n"; - my $line = ; - close( FAILS ); - ( $retries, $last_retry ) = ( $1, $2 ) if $line =~ /^(\d+)\s+(\d+)$/; - push( @$keep_list, $failure_file ); - } - - # run PGP on the file to check the signature - if (!($signator = pgp_check( $changes ))) { - msg( "log,mail", "$main::current_incoming_short/$changes has bad PGP/GnuPG signature!\n" ); - msg( "log", "(uploader $main::mail_addr)\n" ); - remove_only_changes: - msg( "log,mail", "Removing $main::current_incoming_short/$changes, but keeping its associated ", - "files for now.\n" ); - rm( $changes ); - # Set SGID bit on associated files, so that the test for Debian files - # without a .changes doesn't consider them. - foreach ( @filenames ) { - my @st = stat($_); - next if !@st; # file may have disappeared in the meantime - chmod +($st[ST_MODE] |= S_ISGID), $_; - } - return; - } - elsif ($signator eq "LOCAL ERROR") { - # An error has appened when starting pgp... Don't process the file, - # but also don't delete it - debug( "Can't PGP/GnuPG check $main::current_incoming_short/$changes -- don't process it for now" ); - return; - } - - die "Cannot stat ${main::current_incoming_short}/$changes (??): $!\n" - if !(@changes_stats = stat( $changes )); - # Make $upload_time the maximum of all modification times of files - # related to this .changes (and the .changes it self). This is the - # last time something changes to these files. - $upload_time = $changes_stats[ST_MTIME]; - for $file ( @files ) { - my @stats; - next if !(@stats = stat( $file->{"name"} )); - $file->{"stats"} = \@stats; - $upload_time = $stats[ST_MTIME] if $stats[ST_MTIME] > $upload_time; - } - - $do_report = (time - $upload_time) > $conf::problem_report_timeout; - $problems_reported = $changes_stats[ST_MODE] & S_ISGID; - # if any of the files is newer than the .changes' ctime (the time - # we sent a report and set the sticky bit), send new problem reports - if ($problems_reported && $changes_stats[ST_CTIME] < $upload_time) { - $problems_reported = 0; - chmod +($changes_stats[ST_MODE] &= ~S_ISGID), $changes; - debug( "upload_time>changes-ctime => resetting problems reported" ); - } - debug( "do_report=$do_report problems_reported=$problems_reported" ); - - # now check all files for correct size and md5 sum - for $file ( @files ) { - my $filename = $file->{"name"}; - if (!defined( $file->{"stats"} )) { - # could be an upload that isn't complete yet, be quiet, - # but don't process the file; - msg( "log,mail", "$filename doesn't exist\n" ) - if $do_report && !$problems_reported; - msg( "log", "$filename doesn't exist (ignored for now)\n" ) - if !$do_report; - msg( "log", "$filename doesn't exist (already reported)\n" ) - if $problems_reported; - ++$errs; - } - elsif ($file->{"stats"}->[ST_SIZE] < $file->{"size"} && !$do_report) { - # could be an upload that isn't complete yet, be quiet, - # but don't process the file - msg( "log", "$filename is too small (ignored for now)\n" ); - ++$errs; - } - elsif ($file->{"stats"}->[ST_SIZE] != $file->{"size"}) { - msg( "log,mail", "$filename has incorrect size; deleting it\n" ); - rm( $filename ); - ++$errs; - } - elsif (md5sum( $filename ) ne $file->{"md5"}) { - msg( "log,mail", "$filename has incorrect md5 checksum; ", - "deleting it\n" ); - rm( $filename ); - ++$errs; - } - } - - if ($errs) { - if ((time - $upload_time) > $conf::bad_changes_timeout) { - # if a .changes fails for a really long time (several days - # or so), remove it and all associated files - msg( "log,mail", - "$main::current_incoming_short/$changes couldn't be processed for ", - int($conf::bad_changes_timeout/(60*60)), - " hours and is now deleted\n" ); - msg( "log,mail", - "All files it mentions are also removed:\n" ); - msg( "log,mail", " ", join( ", ", @filenames ), "\n" ); - rm( $changes, @filenames, $failure_file ); - } - elsif ($do_report && !$problems_reported) { - # otherwise, send a problem report, if not done already - msg( "mail", - "Due to the errors above, the .changes file couldn't ", - "be processed.\n", - "Please fix the problems for the upload to happen.\n" ); - # remember we already have sent a mail regarding this file - debug( "Sending problem report mail and setting SGID bit" ); - my $mode = $changes_stats[ST_MODE] |= S_ISGID; - msg( "log", "chmod failed: $!" ) if (chmod ($mode, $changes) != 1); - } - # else: be quiet - - return; - } - - # if this upload already failed earlier, wait until the delay requirement - # is fulfilled - if ($retries > 0 && (time - $last_retry) < - ($retries == 1 ? $conf::upload_delay_1 : $conf::upload_delay_2)) { - msg( "log", "delaying retry of upload\n" ); - return; - } - - if ($conf::upload_method eq "ftp") { - return if !ftp_open(); - } - - # check if the job is already present on target - # (moved to here, to avoid bothering target as long as there are errors in - # the job) - if ($ls_l = is_on_target( $changes, @filenames )) { - msg( "log,mail", "$main::current_incoming_short/$changes is already present on target host:\n" ); - msg( "log,mail", "$ls_l\n" ); - msg( "mail", "Either you already uploaded it, or someone else ", - "came first.\n" ); - msg( "log,mail", "Job $changes removed.\n" ); - rm( $changes, @filenames, $failure_file ); - return; - } - - # clear sgid bit before upload, scp would copy it to target. We don't need - # it anymore, we know there are no problems if we come here. Also change - # mode of files to 644 if this should be done locally. - $changes_stats[ST_MODE] &= ~S_ISGID; - if (!$conf::chmod_on_target) { - $changes_stats[ST_MODE] &= ~0777; - $changes_stats[ST_MODE] |= 0644; - } - chmod +($changes_stats[ST_MODE]), $changes; - - # try uploading to target - if (!copy_to_target( $changes, @filenames )) { - # if the upload failed, increment the retry counter and remember the - # current time; both things are written to the .failures file. Don't - # increment the fail counter if the error was due to incoming - # unwritable. - return if !$main::incoming_writable; - if (++$retries >= $conf::max_upload_retries) { - msg( "log,mail", - "$changes couldn't be uploaded for $retries times now.\n" ); - msg( "log,mail", - "Giving up and removing it and its associated files:\n" ); - msg( "log,mail", " ", join( ", ", @filenames ), "\n" ); - rm( $changes, @filenames, $failure_file ); - } - else { - $last_retry = time; - if (open( FAILS, ">$failure_file" )) { - print FAILS "$retries $last_retry\n"; - close( FAILS ); - chmod( 0600, $failure_file ) - or die "Cannot set modes of $failure_file: $!\n"; - } - push( @$keep_list, $failure_file ); - debug( "now $retries failed uploads" ); - msg( "mail", - "The upload will be retried in ", - print_time( $retries == 1 ? $conf::upload_delay_1 : - $conf::upload_delay_2 ), "\n" ); - } - return; - } - - # If the files were uploaded ok, remove them - rm( $changes, @filenames, $failure_file ); - - msg( "mail", "$changes uploaded successfully to $conf::target\n" ); - msg( "mail", "along with the files:\n ", - join( "\n ", @filenames ), "\n" ); - msg( "log", "$changes processed successfully (uploader $main::mail_addr)\n" ); - - # Check for files that have the same stem as the .changes (and weren't - # mentioned there) and delete them. It happens often enough that people - # upload a .orig.tar.gz where it isn't needed and also not in the - # .changes. Explicitly deleting it (and not waiting for the - # $stray_remove_timeout) reduces clutter in the queue dir and maybe also - # educates uploaders :-) - -# my $pattern = debian_file_stem( $changes ); -# my $spattern = substr( $pattern, 0, -1 ); # strip off '*' at end -# my @other_files = glob($pattern); - # filter out files that have a Debian revision at all and a different - # revision. Those belong to a different upload. -# if ($changes =~ /^\Q$spattern\E-([\d.+-]+)/) { -# my $this_rev = $1; -# @other_files = grep( !/^\Q$spattern\E-([\d.+-]+)/ || $1 eq $this_rev, -# @other_files); - #} - # Also do not remove those files if a .changes is among them. Then there - # is probably a second upload for another version or another architecture. -# if (@other_files && !grep( /\.changes$/, @other_files )) { -# rm( @other_files ); -# msg( "mail", "\nThe following file(s) seemed to belong to the same ". -# "upload, but weren't listed\n" ); -# msg( "mail", "in the .changes file:\n " ); -# msg( "mail", join( "\n ", @other_files ), "\n" ); -# msg( "mail", "They have been deleted.\n" ); -# msg( "log", "Deleted files in upload not in $changes: @other_files\n" ); - #} + my $changes = shift; + my $keep_list = shift; + my ( + $pgplines, @files, @filenames, @changes_stats, + $failure_file, $retries, $last_retry, $upload_time, + $file, $do_report, $ls_l, $problems_reported, + $errs, $pkgname, $signator, $extralines + ); + local (*CHANGES); + local (*FAILS); + + format_status_str( $main::current_changes, + "$main::current_incoming_short/$changes" ); + $main::dstat = "c"; + $main::mail_addr = ""; + write_status_file() if $conf::statusdelay; + + @$keep_list = (); + msg( "log", "processing ${main::current_incoming_short}/$changes\n" ); + + # run PGP on the file to check the signature + if ( !( $signator = pgp_check($changes) ) ) { + msg( + "log,mail", + "$main::current_incoming_short/$changes has bad PGP/GnuPG signature!\n" + ); + goto remove_only_changes; + } elsif ( $signator eq "LOCAL ERROR" ) { + + # An error has appened when starting pgp... Don't process the file, + # but also don't delete it + debug( +"Can't PGP/GnuPG check $main::current_incoming_short/$changes -- don't process it for now" + ); + return; + } ## end elsif ( $signator eq "LOCAL ERROR") + + # parse the .changes file + open( CHANGES, "<", $changes ) + or die "Cannot open ${main::current_incoming_short}/$changes: $!\n"; + $pgplines = 0; + $extralines = 0; + @files = (); +outer_loop: while () { + if (/^---+(BEGIN|END) PGP .*---+$/) { + ++$pgplines; + next; + } + if ( $pgplines < 1 or $pgplines >= 3 ) { + $extralines++ if length $_ > 1; + next; + } + if (/^Maintainer:\s*/i) { + chomp( $main::mail_addr = $' ); + $main::mail_addr = $1 if $main::mail_addr =~ /<([^>]*)>/; + } elsif (/^Source:\s*/i) { + chomp( $pkgname = $' ); + $pkgname =~ s/\s+$//; + $main::packages{$pkgname}++; + } elsif (/^Files:/i) { + while () { + redo outer_loop if !/^\s/; + my @field = split(/\s+/); + next if @field != 6; + + # forbid shell meta chars in the name, we pass it to a + # subshell several times... + $field[5] =~ /$re_file_safe/; + if ( $1 ne $field[5] ) { + msg( "log", "found suspicious filename $field[5]\n" ); + msg( + "mail", +"File '$field[5]' mentioned in $main::current_incoming_short/$changes\n", + "has bad characters in its name. Removed.\n" + ); + rm( $field[5] ); + next; + } ## end if ( $1 ne $field[5] ) + push( + @files, + { + md5 => $field[1], + size => $field[2], + name => $field[5] + } + ); + push( @filenames, $field[5] ); + debug( "includes file $field[5], size $field[2], ", "md5 $field[1]" ); + } ## end while () + } ## end elsif (/^Files:/i) + } ## end while () + close(CHANGES); + + # tell check_dir that the files mentioned in this .changes aren't stray, + # we know about them somehow + @$keep_list = @filenames; + + # some consistency checks + if ( $extralines ) { + msg( "log,mail", +"$main::current_incoming_short/$changes contained lines outside the pgp signed " +."part, cannot process\n" ); + goto remove_only_changes; + } ## end if ( $extralines ) + if ( !$main::mail_addr ) { + msg( "log,mail", +"$main::current_incoming_short/$changes doesn't contain a Maintainer: field; " + . "cannot process\n" ); + goto remove_only_changes; + } ## end if ( !$main::mail_addr) + if ( $main::mail_addr !~ /^(buildd_\S+-\S+|\S+\@\S+\.\S+)/ ) { + + # doesn't look like a mail address, maybe only the name + my ( $new_addr, @addr_list ); + if ( $new_addr = try_to_get_mail_addr( $main::mail_addr, \@addr_list ) ) { + + # substitute (unique) found addr, but give a warning + msg( + "mail", + "(The Maintainer: field didn't contain a proper " + . "mail address.\n" + ); + msg( + "mail", + "Looking for `$main::mail_addr' in the Debian " + . "keyring gave your address\n" + ); + msg( "mail", "as unique result, so I used this.)\n" ); + msg( "log", + "Substituted $new_addr for malformed " . "$main::mail_addr\n" ); + $main::mail_addr = $new_addr; + } else { + + # not found or not unique: hold the job and inform queue maintainer + my $old_addr = $main::mail_addr; + $main::mail_addr = $conf::maintainer_mail; + msg( + "mail", +"The job ${main::current_incoming_short}/$changes doesn't have a correct email\n" + ); + msg( "mail", "address in the Maintainer: field:\n" ); + msg( "mail", " $old_addr\n" ); + msg( "mail", "A check for this in the Debian keyring gave:\n" ); + msg( "mail", + @addr_list + ? " " . join( ", ", @addr_list ) . "\n" + : " nothing\n" ); + msg( "mail", "Please fix this manually\n" ); + msg( + "log", +"Bad Maintainer: field in ${main::current_incoming_short}/$changes: $old_addr\n" + ); + goto remove_only_changes; + } ## end else [ if ( $new_addr = try_to_get_mail_addr... + } ## end if ( $main::mail_addr ... + if ( $pgplines < 3 ) { + msg( + "log,mail", + "$main::current_incoming_short/$changes isn't signed with PGP/GnuPG\n" + ); + msg( "log", "(uploader $main::mail_addr)\n" ); + goto remove_only_changes; + } ## end if ( $pgplines < 3 ) + if ( !@files ) { + msg( "log,mail", + "$main::current_incoming_short/$changes doesn't mention any files\n" ); + msg( "log", "(uploader $main::mail_addr)\n" ); + goto remove_only_changes; + } ## end if ( !@files ) + + # check for packages that shouldn't be processed + if ( grep( $_ eq $pkgname, @conf::nonus_packages ) ) { + msg( + "log,mail", + "$pkgname is a package that must be uploaded " + . "to nonus.debian.org\n" + ); + msg( "log,mail", "instead of target.\n" ); + msg( "log,mail", + "Job rejected and removed all files belonging " . "to it:\n" ); + msg( "log,mail", " ", join( ", ", @filenames ), "\n" ); + rm( $changes, @filenames ); + return; + } ## end if ( grep( $_ eq $pkgname... + + $failure_file = $changes . ".failures"; + $retries = $last_retry = 0; + if ( -f $failure_file ) { + open( FAILS, "<", $failure_file ) + or die "Cannot open $main::current_incoming_short/$failure_file: $!\n"; + my $line = ; + close(FAILS); + ( $retries, $last_retry ) = ( $1, $2 ) + if $line =~ /^(\d+)\s+(\d+)$/; + push( @$keep_list, $failure_file ); + } ## end if ( -f $failure_file ) + + die "Cannot stat ${main::current_incoming_short}/$changes (??): $!\n" + if !( @changes_stats = stat($changes) ); + + # Make $upload_time the maximum of all modification times of files + # related to this .changes (and the .changes it self). This is the + # last time something changes to these files. + $upload_time = $changes_stats[ST_MTIME]; + for $file (@files) { + my @stats; + next if !( @stats = stat( $file->{"name"} ) ); + $file->{"stats"} = \@stats; + $upload_time = $stats[ST_MTIME] if $stats[ST_MTIME] > $upload_time; + } ## end for $file (@files) + + $do_report = ( time - $upload_time ) > $conf::problem_report_timeout; + $problems_reported = $changes_stats[ST_MODE] & S_ISGID; + + # if any of the files is newer than the .changes' ctime (the time + # we sent a report and set the sticky bit), send new problem reports + if ( $problems_reported && $changes_stats[ST_CTIME] < $upload_time ) { + $problems_reported = 0; + chmod +( $changes_stats[ST_MODE] &= ~S_ISGID ), $changes; + debug("upload_time>changes-ctime => resetting problems reported"); + } + debug("do_report=$do_report problems_reported=$problems_reported"); + + # now check all files for correct size and md5 sum + for $file (@files) { + my $filename = $file->{"name"}; + if ( !defined( $file->{"stats"} ) ) { + + # could be an upload that isn't complete yet, be quiet, + # but don't process the file; + msg( "log,mail", "$filename doesn't exist\n" ) + if $do_report && !$problems_reported; + msg( "log", "$filename doesn't exist (ignored for now)\n" ) + if !$do_report; + msg( "log", "$filename doesn't exist (already reported)\n" ) + if $problems_reported; + ++$errs; + } elsif ( $file->{"stats"}->[ST_SIZE] < $file->{"size"} + && !$do_report ) + { + + # could be an upload that isn't complete yet, be quiet, + # but don't process the file + msg( "log", "$filename is too small (ignored for now)\n" ); + ++$errs; + } elsif ( $file->{"stats"}->[ST_SIZE] != $file->{"size"} ) { + msg( "log,mail", "$filename has incorrect size; deleting it\n" ); + rm($filename); + ++$errs; + } elsif ( md5sum($filename) ne $file->{"md5"} ) { + msg( "log,mail", + "$filename has incorrect md5 checksum; ", + "deleting it\n" ); + rm($filename); + ++$errs; + } ## end elsif ( md5sum($filename)... + } ## end for $file (@files) + + if ($errs) { + if ( ( time - $upload_time ) > $conf::bad_changes_timeout ) { + + # if a .changes fails for a really long time (several days + # or so), remove it and all associated files + msg( + "log,mail", + "$main::current_incoming_short/$changes couldn't be processed for ", + int( $conf::bad_changes_timeout / ( 60 * 60 ) ), + " hours and is now deleted\n" + ); + msg( "log,mail", "All files it mentions are also removed:\n" ); + msg( "log,mail", " ", join( ", ", @filenames ), "\n" ); + rm( $changes, @filenames, $failure_file ); + } elsif ( $do_report && !$problems_reported ) { + + # otherwise, send a problem report, if not done already + msg( + "mail", + "Due to the errors above, the .changes file couldn't ", + "be processed.\n", + "Please fix the problems for the upload to happen.\n" + ); + + # remember we already have sent a mail regarding this file + debug("Sending problem report mail and setting SGID bit"); + my $mode = $changes_stats[ST_MODE] |= S_ISGID; + msg( "log", "chmod failed: $!" ) + if ( chmod( $mode, $changes ) != 1 ); + } ## end elsif ( $do_report && !$problems_reported) + + # else: be quiet + + return; + } ## end if ($errs) + + # if this upload already failed earlier, wait until the delay requirement + # is fulfilled + if ( $retries > 0 + && ( time - $last_retry ) < + ( $retries == 1 ? $conf::upload_delay_1 : $conf::upload_delay_2 ) ) + { + msg( "log", "delaying retry of upload\n" ); + return; + } ## end if ( $retries > 0 && (... + + return if !ftp_open(); + + # check if the job is already present on target + # (moved to here, to avoid bothering target as long as there are errors in + # the job) + if ( $ls_l = is_on_target( $changes, @filenames ) ) { + msg( + "log,mail", +"$main::current_incoming_short/$changes is already present on target host:\n" + ); + msg( "log,mail", "$ls_l\n" ); + msg( "mail", + "Either you already uploaded it, or someone else ", + "came first.\n" ); + msg( "log,mail", "Job $changes removed.\n" ); + rm( $changes, @filenames, $failure_file ); + return; + } ## end if ( $ls_l = is_on_target... + + # clear sgid bit before upload, scp would copy it to target. We don't need + # it anymore, we know there are no problems if we come here. Also change + # mode of files to 644 if this should be done locally. + $changes_stats[ST_MODE] &= ~S_ISGID; + if ( !$conf::chmod_on_target ) { + $changes_stats[ST_MODE] &= ~0777; + $changes_stats[ST_MODE] |= 0644; + } + chmod +( $changes_stats[ST_MODE] ), $changes; + + # try uploading to target + if ( !copy_to_target( $changes, @filenames ) ) { + + # if the upload failed, increment the retry counter and remember the + # current time; both things are written to the .failures file. Don't + # increment the fail counter if the error was due to incoming + # unwritable. + return if !$main::incoming_writable; + if ( ++$retries >= $conf::max_upload_retries ) { + msg( "log,mail", + "$changes couldn't be uploaded for $retries times now.\n" ); + msg( "log,mail", + "Giving up and removing it and its associated files:\n" ); + msg( "log,mail", " ", join( ", ", @filenames ), "\n" ); + rm( $changes, @filenames, $failure_file ); + } else { + $last_retry = time; + if ( open( FAILS, ">", $failure_file ) ) { + print FAILS "$retries $last_retry\n"; + close(FAILS); + chmod( 0600, $failure_file ) + or die "Cannot set modes of $failure_file: $!\n"; + } ## end if ( open( FAILS, ">$failure_file"... + push( @$keep_list, $failure_file ); + debug("now $retries failed uploads"); + msg( + "mail", + "The upload will be retried in ", + print_time( + $retries == 1 + ? $conf::upload_delay_1 + : $conf::upload_delay_2 + ), + "\n" + ); + } ## end else [ if ( ++$retries >= $conf::max_upload_retries) + return; + } ## end if ( !copy_to_target( ... + + # If the files were uploaded ok, remove them + rm( $changes, @filenames, $failure_file ); + + msg( "mail", "$changes uploaded successfully to $conf::target\n" ); + msg( "mail", "along with the files:\n ", join( "\n ", @filenames ), + "\n" ); + msg( "log", + "$changes processed successfully (uploader $main::mail_addr)\n" ); + + return; + + remove_only_changes: + msg( + "log,mail", + "Removing $main::current_incoming_short/$changes, but keeping its " + . "associated files for now.\n" + ); + rm($changes); + return; + + # Check for files that have the same stem as the .changes (and weren't + # mentioned there) and delete them. It happens often enough that people + # upload a .orig.tar.gz where it isn't needed and also not in the + # .changes. Explicitly deleting it (and not waiting for the + # $stray_remove_timeout) reduces clutter in the queue dir and maybe also + # educates uploaders :-) + + # my $pattern = debian_file_stem( $changes ); + # my $spattern = substr( $pattern, 0, -1 ); # strip off '*' at end + # my @other_files = glob($pattern); + # filter out files that have a Debian revision at all and a different + # revision. Those belong to a different upload. + # if ($changes =~ /^\Q$spattern\E-([\d.+-]+)/) { + # my $this_rev = $1; + # @other_files = grep( !/^\Q$spattern\E-([\d.+-]+)/ || $1 eq $this_rev, + # @other_files); + #} + # Also do not remove those files if a .changes is among them. Then there + # is probably a second upload for another version or another architecture. + # if (@other_files && !grep( /\.changes$/, @other_files )) { + # rm( @other_files ); + # msg( "mail", "\nThe following file(s) seemed to belong to the same ". + # "upload, but weren't listed\n" ); + # msg( "mail", "in the .changes file:\n " ); + # msg( "mail", join( "\n ", @other_files ), "\n" ); + # msg( "mail", "They have been deleted.\n" ); + # msg( "log", "Deleted files in upload not in $changes: @other_files\n" ); + #} +} ## end sub process_changes($\@) + +# +# process one .dak-commands file +# +sub process_dak_commands { + my $commands = shift; + + msg("log", "processing ${main::current_incoming_short}/$commands\n"); + + # TODO: get mail address from signed contents + # and NOT implement a third parser for armored PGP... + $main::mail_addr = undef; + + # check signature + my $signator = pgp_check($commands); + if (!$signator) { + msg("log,mail", + "$main::current_incoming_short/$commands has bad PGP/GnuPG signature!\n"); + msg("log,mail", + "Removing $main::current_incoming_short/$commands\n"); + rm($commands); + return; + } + elsif ($signator eq 'LOCAL ERROR') { + debug("Can't check signature for $main::current_incoming_short/$commands -- don't process it for now"); + return; + } + msg("log,mail", "(PGP/GnuPG signature by $signator)\n"); + + return if !ftp_open(); + + # check target + my @filenames = ($commands); + if (my $ls_l = is_on_target($commands, @filenames)) { + msg("log,mail", "$main::current_incoming_short/$commands is already present on target host:\n"); + msg("log,mail", "$ls_l\n"); + msg("log,mail", "Job $commands removed.\n"); + rm($commands); + return; + } + + if (!copy_to_target($commands)) { + msg("log,mail", "$commands couldn't be uploaded to target.\n"); + msg("log,mail", "Giving up and removing it.\n"); + rm($commands); + return; + } + + rm($commands); + msg("mail", "$commands uploaded successfully to $conf::target\n"); } # # process one .commands file # sub process_commands($) { - my $commands = shift; - my( @cmds, $cmd, $pgplines, $signator ); - local( *COMMANDS ); - my( @files, $file, @removed, $target_delay ); - - format_status_str( $main::current_changes, $commands ); - $main::dstat = "c"; - write_status_file() if $conf::statusdelay; - - msg( "log", "processing $main::current_incoming_short/$commands\n" ); - - # parse the .commands file - if (!open( COMMANDS, "<$commands" )) { - msg( "log", "Cannot open $main::current_incoming_short/$commands: $!\n" ); - return; - } - $pgplines = 0; - $main::mail_addr = ""; - @cmds = (); - outer_loop: while( ) { - if (/^---+(BEGIN|END) PGP .*---+$/) { - ++$pgplines; - } - elsif (/^Uploader:\s*/i) { - chomp( $main::mail_addr = $' ); - $main::mail_addr = $1 if $main::mail_addr =~ /<([^>]*)>/; - } - elsif (/^Commands:/i) { - $_ = $'; - for(;;) { - s/^\s*(.*)\s*$/$1/; # delete whitespace at both ends - if (!/^\s*$/) { - push( @cmds, $_ ); - debug( "includes cmd $_" ); - } - last outer_loop if !defined( $_ = scalar() ); - chomp; - redo outer_loop if !/^\s/ || /^$/; - } - } - } - close( COMMANDS ); - - # some consistency checks - if (!$main::mail_addr || $main::mail_addr !~ /^\S+\@\S+\.\S+/) { - msg( "log,mail", "$main::current_incoming_short/$commands contains no or bad Uploader: field: ". - "$main::mail_addr\n" ); - msg( "log,mail", "cannot process $main::current_incoming_short/$commands\n" ); - $main::mail_addr = ""; - goto remove; - } - msg( "log", "(command uploader $main::mail_addr)\n" ); - - if ($pgplines < 3) { - msg( "log,mail", "$main::current_incoming_short/$commands isn't signed with PGP/GnuPG\n" ); - msg( "mail", "or the uploaded file is broken. Make sure to transfer in binary mode\n" ); - msg( "mail", "or better yet - use dcut for commands files\n"); - goto remove; - } - - # run PGP on the file to check the signature - if (!($signator = pgp_check( $commands ))) { - msg( "log,mail", "$main::current_incoming_short/$commands has bad PGP/GnuPG signature!\n" ); - remove: - msg( "log,mail", "Removing $main::current_incoming_short/$commands\n" ); - rm( $commands ); - return; - } - elsif ($signator eq "LOCAL ERROR") { - # An error has appened when starting pgp... Don't process the file, - # but also don't delete it - debug( "Can't PGP/GnuPG check $main::current_incoming_short/$commands -- don't process it for now" ); - return; - } - msg( "log", "(PGP/GnuPG signature by $signator)\n" ); - - # now process commands - msg( "mail", "Log of processing your commands file $main::current_incoming_short/$commands:\n\n" ); - foreach $cmd ( @cmds ) { - my @word = split( /\s+/, $cmd ); - msg( "mail,log", "> @word\n" ); - next if @word < 1; - - if ($word[0] eq "rm") { - foreach ( @word[1..$#word] ) { - if (m,/,) { - msg( "mail,log", "$_: filename may not contain slashes\n" ); - } - elsif (/[*?[]/) { - # process wildcards but also plain names (for delayed target removal) - my (@thesefiles); - my $pat = quotemeta($_); - $pat =~ s/\\\*/.*/g; - $pat =~ s/\\\?/.?/g; - $pat =~ s/\\([][])/$1/g; - opendir( DIR, "." ); - push (@thesefiles, grep /^$pat$/, readdir(DIR) ); - closedir( DIR ); - for ( my($adelay)=0; (! @thesefiles) && $adelay <= $conf::max_delayed; $adelay++ ) { - my($dir) = sprintf( $conf::incoming_delayed, - $adelay ); - opendir( DIR, "$dir" ); - push( @thesefiles, map ("$dir/$_", grep /^$pat$/, readdir(DIR) )); - closedir( DIR ); - } - push (@files, @thesefiles); - if (! @thesefiles) { - msg( "mail,log", "$_ did not match anything\n" ); - } - } - else { - my (@thesefiles); - $file = $_; - if (-f $file) { - push (@thesefiles, $file); - } - for ( my($adelay)=0; $adelay <= $conf::max_delayed; $adelay++ ) { - my($dir) = sprintf( $conf::incoming_delayed, $adelay ); - if (-f "$dir/$file") { - push (@thesefiles, "$dir/$file"); - } - } - if ($file =~ m/\.changes$/ && $conf::upload_method eq "copy") { - for ( my($adelay)=0; $adelay <= $conf::max_delayed; $adelay++ ) { - my($dir) = sprintf( "$conf::targetdir_delayed",$adelay ); - if (-f "$dir/$file") { - push (@thesefiles, "$dir/$file"); - push (@thesefiles, map( "$dir/$_",get_filelist_from_known_good_changes("$dir/$file"))); - } - } - } - if (!@thesefiles) { - msg( "mail,log", "No file found: $file\n" ); - } - push (@files, @thesefiles); - } - } - if (!@files) { - msg( "mail,log", "No files to delete\n" ); - } - else { - @removed = (); - foreach $file ( @files ) { - if (!-f $file) { - msg( "mail,log", "$file: no such file\n" ); - } - elsif ($file =~ /$conf::keep_files/) { - msg( "mail,log", "$file is protected, cannot ". - "remove\n" ); - } - elsif (!unlink( $file )) { - msg( "mail,log", "$file: rm: $!\n" ); - } - else { - push( @removed, $file ); - } - } - msg( "mail,log", "Files removed: @removed\n" ) if @removed; - } - } - elsif ($word[0] eq "mv") { - if (@word != 3) { - msg( "mail,log", "Wrong number of arguments\n" ); - } - elsif ($word[1] =~ m,/, || $word[1] !~ m/\.changes/) { - msg( "mail,log", "$word[1]: filename may not contain slashes\n" ); - } - elsif (! (($target_delay) = $word[2] =~ m,^([0-9]+)-day$,) || $target_delay > $conf::max_delayed) { - msg( "mail,log", "$word[2]: target must be #-day with # between 0 and $conf::max_delayed (in particular, no '/' allowed)\n"); - } - elsif ($word[1] =~ /$conf::keep_files/) { - msg( "mail,log", "$word[1] is protected, cannot rename\n" ); - } - else { - my($adelay); - for ( $adelay=0; $adelay <= $conf::max_delayed && ! -f (sprintf( "$conf::targetdir_delayed",$adelay )."/$word[1]"); $adelay++ ) { - } - if ( $adelay > $conf::max_delayed) { - msg( "mail,log", "$word[1] not found\n" ); - } - elsif ($adelay == $target_delay) { - msg( "mail,log", "$word[1] already is in $word[2]\n" ); - } - else { - my(@thesefiles); - my($dir) = sprintf( "$conf::targetdir_delayed",$adelay ); - my($target_dir) = sprintf( "$conf::targetdir_delayed",$target_delay ); - push (@thesefiles, $word[1]); - push (@thesefiles, get_filelist_from_known_good_changes("$dir/$word[1]")); - for my $afile(@thesefiles) { - if (! rename "$dir/$afile","$target_dir/$afile") { - msg( "mail,log", "rename: $!\n" ); - } - else { - msg( "mail,log", "$afile moved to $target_delay-day\n" ); - } - } - } - } - } - else { - msg( "mail,log", "unknown command $word[0]\n" ); - } - } - rm( $commands ); - msg( "log", "-- End of $main::current_incoming_short/$commands processing\n" ); -} + my $commands = shift; + my ( @cmds, $cmd, $pgplines, $signator ); + local (*COMMANDS); + my ( @files, $file, @removed, $target_delay ); + + format_status_str( $main::current_changes, $commands ); + $main::dstat = "c"; + $main::mail_addr = ""; + write_status_file() if $conf::statusdelay; + + msg( "log", "processing $main::current_incoming_short/$commands\n" ); + + # run PGP on the file to check the signature + if ( !( $signator = pgp_check($commands) ) ) { + msg( + "log,mail", + "$main::current_incoming_short/$commands has bad PGP/GnuPG signature!\n" + ); + goto remove; + } elsif ( $signator eq "LOCAL ERROR" ) { + + # An error has appened when starting pgp... Don't process the file, + # but also don't delete it + debug( +"Can't PGP/GnuPG check $main::current_incoming_short/$commands -- don't process it for now" + ); + return; + } ## end elsif ( $signator eq "LOCAL ERROR") + msg( "log", "(PGP/GnuPG signature by $signator)\n" ); + + # parse the .commands file + if ( !open( COMMANDS, "<", $commands ) ) { + msg( "log", "Cannot open $main::current_incoming_short/$commands: $!\n" ); + return; + } + $pgplines = 0; + @cmds = (); +outer_loop: while () { + if (/^---+(BEGIN|END) PGP .*---+$/) { + ++$pgplines; + } elsif (/^Uploader:\s*/i) { + chomp( $main::mail_addr = $' ); + $main::mail_addr = $1 if $main::mail_addr =~ /<([^>]*)>/; + } elsif (/^Commands:/i) { + $_ = $'; + for ( ; ; ) { + s/^\s*(.*)\s*$/$1/; # delete whitespace at both ends + if ( !/^\s*$/ ) { + push( @cmds, $_ ); + debug("includes cmd $_"); + } + last outer_loop if !defined( $_ = scalar() ); + chomp; + redo outer_loop if !/^\s/ || /^$/; + } ## end for ( ; ; ) + } ## end elsif (/^Commands:/i) + } ## end while () + close(COMMANDS); + + # some consistency checks + if ( !$main::mail_addr || $main::mail_addr !~ /^\S+\@\S+\.\S+/ ) { + msg( "log,mail", +"$main::current_incoming_short/$commands contains no or bad Uploader: field: " + . "$main::mail_addr\n" ); + msg( "log,mail", + "cannot process $main::current_incoming_short/$commands\n" ); + $main::mail_addr = ""; + goto remove; + } ## end if ( !$main::mail_addr... + msg( "log", "(command uploader $main::mail_addr)\n" ); + + if ( $pgplines < 3 ) { + msg( + "log,mail", + "$main::current_incoming_short/$commands isn't signed with PGP/GnuPG\n" + ); + msg( + "mail", + "or the uploaded file is broken. Make sure to transfer in binary mode\n" + ); + msg( "mail", "or better yet - use dcut for commands files\n" ); + goto remove; + } ## end if ( $pgplines < 3 ) + + # now process commands + msg( + "mail", +"Log of processing your commands file $main::current_incoming_short/$commands:\n\n" + ); + foreach $cmd (@cmds) { + my @word = split( /\s+/, $cmd ); + msg( "mail,log", "> @word\n" ); + my $selecteddelayed = -1; + next if @word < 1; + + if ( $word[0] eq "rm" ) { + foreach ( @word[ 1 .. $#word ] ) { + my $origword = $_; + if (m,^DELAYED/([0-9]+)-day/,) { + $selecteddelayed = $1; + s,^DELAYED/[0-9]+-day/,,; + } + if (m,(^|/)\*,) { + msg("mail,log", "$_: filename component cannot start with a wildcard\n"); + } elsif ( $origword eq "--searchdirs" ) { + $selecteddelayed = -2; + } elsif (m,/,) { + msg( + "mail,log", +"$_: filename may not contain slashes except for DELAYED/#-day/ prefixes\n" + ); + } else { + + # process wildcards but also plain names + my (@thesefiles); + my $pat = quotemeta($_); + $pat =~ s/\\\*/.*/g; + $pat =~ s/\\\?/.?/g; + $pat =~ s/\\([][])/$1/g; + + if ( $selecteddelayed < 0 ) { # scanning or explicitly incoming + opendir( DIR, "." ); + push( @thesefiles, grep /^$pat$/, readdir(DIR) ); + closedir(DIR); + } + if ( $selecteddelayed >= 0 ) { + my $dir = sprintf( $conf::incoming_delayed, $selecteddelayed ); + opendir( DIR, $dir ); + push( @thesefiles, + map ( "$dir/$_", grep /^$pat$/, readdir(DIR) ) ); + closedir(DIR); + } elsif ( $selecteddelayed == -2 ) { + for ( my ($adelay) = 0 ; + ( !@thesefiles ) && $adelay <= $conf::max_delayed ; + $adelay++ ) + { + my $dir = sprintf( $conf::incoming_delayed, $adelay ); + opendir( DIR, $dir ); + push( @thesefiles, + map ( "$dir/$_", grep /^$pat$/, readdir(DIR) ) ); + closedir(DIR); + } ## end for ( my ($adelay) = 0 ... + } ## end elsif ( $selecteddelayed ... + push( @files, @thesefiles ); + if ( !@thesefiles ) { + msg( "mail,log", "$origword did not match anything\n" ); + } + } ## end else [ if ( $origword eq "--searchdirs") + } ## end foreach ( @word[ 1 .. $#word... + if ( !@files ) { + msg( "mail,log", "No files to delete\n" ); + } else { + @removed = (); + foreach $file (@files) { + if ( !-f $file ) { + msg( "mail,log", "$file: no such file\n" ); + } elsif ( $file =~ /$conf::keep_files/ ) { + msg( "mail,log", "$file is protected, cannot " . "remove\n" ); + } elsif ( !unlink($file) ) { + msg( "mail,log", "$file: rm: $!\n" ); + } else { + $file =~ s,$conf::incoming/?,,; + push( @removed, $file ); + } + } ## end foreach $file (@files) + msg( "mail,log", "Files removed: @removed\n" ) if @removed; + } ## end else [ if ( !@files ) + } elsif ( $word[0] eq "reschedule" ) { + if ( @word != 3 ) { + msg( "mail,log", "Wrong number of arguments\n" ); + } elsif ( $conf::upload_method ne "copy" ) { + msg( "mail,log", "reschedule not available\n" ); + } elsif ( $word[1] =~ m,/, || $word[1] !~ m/\.changes/ ) { + msg( + "mail,log", + "$word[1]: filename may not contain slashes and must be .changes\n" + ); + } elsif ( !( ($target_delay) = $word[2] =~ m,^([0-9]+)-day$, ) + || $target_delay > $conf::max_delayed ) + { + msg( + "mail,log", +"$word[2]: rescheduling target must be #-day with # between 0 and $conf::max_delayed (in particular, no '/' allowed)\n" + ); + } elsif ( $word[1] =~ /$conf::keep_files/ ) { + msg( "mail,log", "$word[1] is protected, cannot do stuff with it\n" ); + } else { + my ($adelay); + for ( $adelay = 0 ; + $adelay <= $conf::max_delayed + && !-f ( + sprintf( "$conf::targetdir_delayed", $adelay ) . "/$word[1]" ) ; + $adelay++ ) + { + } ## end for ( $adelay = 0 ; $adelay... + if ( $adelay > $conf::max_delayed ) { + msg( "mail,log", "$word[1] not found\n" ); + } elsif ( $adelay == $target_delay ) { + msg( "mail,log", "$word[1] already is in $word[2]\n" ); + } else { + my (@thesefiles); + my ($dir) = sprintf( "$conf::targetdir_delayed", $adelay ); + my ($target_dir) = + sprintf( "$conf::targetdir_delayed", $target_delay ); + push( @thesefiles, $word[1] ); + push( @thesefiles, + get_filelist_from_known_good_changes("$dir/$word[1]") ); + for my $afile (@thesefiles) { + if ( $afile =~ m/\.changes$/ ) { + utime undef, undef, ("$dir/$afile"); + } + if ( !move("$dir/$afile", "$target_dir/$afile") ) { + msg( "mail,log", "move: $!\n" ); + } else { + msg( "mail,log", "$afile moved to $target_delay-day\n" ); + } + } ## end for my $afile (@thesefiles) + } ## end else [ if ( $adelay > $conf::max_delayed) + } ## end else [ if ( @word != 3 ) + } elsif ( $word[0] eq "cancel" ) { + if ( @word != 2 ) { + msg( "mail,log", "Wrong number of arguments\n" ); + } elsif ( $conf::upload_method ne "copy" ) { + msg( "mail,log", "cancel not available\n" ); + } elsif ( + $word[1] !~ m,$re_file_safe_prefix\.changes\z, ) + { + msg( "mail,log", + "argument to cancel must be one .changes filename without path\n" ); + } ## end elsif ( $word[1] !~ ... + my (@files) = (); + for ( my ($adelay) = 0 ; $adelay <= $conf::max_delayed ; $adelay++ ) { + my ($dir) = sprintf( "$conf::targetdir_delayed", $adelay ); + if ( -f "$dir/$word[1]" ) { + @removed = (); + push( @files, "$word[1]" ); + push( @files, + get_filelist_from_known_good_changes("$dir/$word[1]") ); + foreach $file (@files) { + if ( !-f "$dir/$file" ) { + msg( "mail,log", "$dir/$file: no such file\n" ); + } elsif ( "$dir/$file" =~ /$conf::keep_files/ ) { + msg( "mail,log", + "$dir/$file is protected, cannot " . "remove\n" ); + } elsif ( !unlink("$dir/$file") ) { + msg( "mail,log", "$dir/$file: rm: $!\n" ); + } else { + push( @removed, $file ); + } + } ## end foreach $file (@files) + msg( "mail,log", "Files removed from $adelay-day: @removed\n" ) + if @removed; + } ## end if ( -f "$dir/$word[1]") + } ## end for ( my ($adelay) = 0 ... + if ( !@files ) { + msg( "mail,log", "No upload found: $word[1]\n" ); + } + } else { + msg( "mail,log", "unknown command $word[0]\n" ); + } + } ## end foreach $cmd (@cmds) + rm($commands); + msg( "log", + "-- End of $main::current_incoming_short/$commands processing\n" ); + return; + + remove: + msg("log,mail", "Removing $main::current_incoming_short/$commands\n"); + rm($commands); + return; +} ## end sub process_commands($) sub age_delayed_queues() { - for ( my($adelay)=0 ; $adelay <= $conf::max_delayed ; $adelay++ ) { - my($dir) = sprintf( "$conf::targetdir_delayed",$adelay ); - my($target_dir); - if ($adelay == 0) { - $target_dir = $conf::targetdir; - } - else { - $target_dir = sprintf( "$conf::targetdir_delayed",$adelay-1 ); - } - for my $achanges (<$dir/*.changes>) { - my $mtime = (stat($achanges))[9]; - if ($mtime + 24*60*60 <= time) { - utime undef,undef,($achanges); - my @thesefiles = ($achanges =~ m,.*/([^/]*),); - push (@thesefiles, get_filelist_from_known_good_changes($achanges)); - for my $afile(@thesefiles) { - if (! rename "$dir/$afile","$target_dir/$afile") { - msg( "log", "rename: $!\n" ); - } - else { - msg( "log", "$afile moved to $target_dir\n" ); - } - } - } - } - } -} + for ( my ($adelay) = 0 ; $adelay <= $conf::max_delayed ; $adelay++ ) { + my ($dir) = sprintf( "$conf::targetdir_delayed", $adelay ); + my ($target_dir); + if ( $adelay == 0 ) { + $target_dir = $conf::targetdir; + } else { + $target_dir = sprintf( "$conf::targetdir_delayed", $adelay - 1 ); + } + for my $achanges (<$dir/*.changes>) { + my $mtime = ( stat($achanges) )[9]; + if ( $mtime + 24 * 60 * 60 <= time || $adelay == 0 ) { + utime undef, undef, ($achanges); + my @thesefiles = ( $achanges =~ m,.*/([^/]*), ); + push( @thesefiles, get_filelist_from_known_good_changes($achanges) ); + for my $afile (@thesefiles) { + if ( !move("$dir/$afile", "$target_dir/$afile") ) { + msg( "log", "move: $!\n" ); + } else { + msg( "log", "$afile moved to $target_dir\n" ); + } + } ## end for my $afile (@thesefiles) + } ## end if ( $mtime + 24 * 60 ... + } ## end for my $achanges (<$dir/*.changes>) + } ## end for ( my ($adelay) = 0 ... +} ## end sub age_delayed_queues() # # check if a file is already on target # sub is_on_target($\@) { - my $file = shift; - my $filelist = shift; - my $msg; - my $stat; - - if ($conf::upload_method eq "ssh") { - ($msg, $stat) = ssh_cmd( "ls -l $file" ); - } - elsif ($conf::upload_method eq "ftp") { - my $err; - ($msg, $err) = ftp_cmd( "dir", $file ); - if ($err) { - $stat = 1; - $msg = $err; - } - elsif (!$msg) { - $stat = 1; - $msg = "ls: no such file\n"; - } - else { - $stat = 0; - $msg = join( "\n", @$msg ); - } - } - else { - my @allfiles = ($file); - push ( @allfiles, @$filelist); - $stat = 1; - $msg = "no such file"; - for my $afile(@allfiles) { - if (-f "$conf::incoming/$afile") { - $stat = 0; - $msg = "$afile"; - } - } - for ( my($adelay)=0 ; $adelay <= $conf::max_delayed && $stat ; $adelay++ ) { - for my $afile(@allfiles) { - if (-f (sprintf( "$conf::targetdir_delayed",$adelay )."/$afile")) { - $stat = 0; - $msg = sprintf( "%d-day",$adelay )."/$afile"; - } - } - } - } - chomp( $msg ); - debug( "exit status: $stat, output was: $msg" ); - - return "" if $stat && $msg =~ /no such file/i; # file not present - msg( "log", "strange ls -l output on target:\n", $msg ), return "" - if $stat || $@; # some other error, but still try to upload - - # ls -l returned 0 -> file already there - $msg =~ s/\s\s+/ /g; # make multiple spaces into one, to save space - return $msg; -} + my $file = shift; + my $filelist = shift; + my $msg; + my $stat; + + if ( $conf::upload_method eq "ssh" ) { + ( $msg, $stat ) = ssh_cmd("ls -l $file"); + } elsif ( $conf::upload_method eq "ftp" ) { + my $err; + ( $msg, $err ) = ftp_cmd( "dir", $file ); + if ($err) { + $stat = 1; + $msg = $err; + } elsif ( !$msg ) { + $stat = 1; + $msg = "ls: no such file\n"; + } else { + $stat = 0; + $msg = join( "\n", @$msg ); + } + } else { + my @allfiles = ($file); + push( @allfiles, @$filelist ); + $stat = 1; + $msg = "no such file"; + for my $afile (@allfiles) { + if ( -f "$conf::targetdir/$afile" ) { + $stat = 0; + $msg = "$afile"; + } + } ## end for my $afile (@allfiles) + for ( my ($adelay) = 0 ; + $adelay <= $conf::max_delayed && $stat ; + $adelay++ ) + { + for my $afile (@allfiles) { + if ( + -f ( sprintf( "$conf::targetdir_delayed", $adelay ) . "/$afile" ) ) + { + $stat = 0; + $msg = sprintf( "%d-day", $adelay ) . "/$afile"; + } ## end if ( -f ( sprintf( "$conf::targetdir_delayed"... + } ## end for my $afile (@allfiles) + } ## end for ( my ($adelay) = 0 ... + } ## end else [ if ( $conf::upload_method... + chomp($msg); + debug("exit status: $stat, output was: $msg"); + + return "" if $stat && $msg =~ /no such file/i; # file not present + msg( "log", "strange ls -l output on target:\n", $msg ), return "" + if $stat || $@; # some other error, but still try to upload + + # ls -l returned 0 -> file already there + $msg =~ s/\s\s+/ /g; # make multiple spaces into one, to save space + return $msg; +} ## end sub is_on_target($\@) # # copy a list of files to target # sub copy_to_target(@) { - my @files = @_; - my( @md5sum, @expected_files, $sum, $name, $msgs, $stat ); - - $main::dstat = "u"; - write_status_file() if $conf::statusdelay; - - # copy the files - if ($conf::upload_method eq "ssh") { - ($msgs, $stat) = scp_cmd( @files ); - goto err if $stat; - } - elsif ($conf::upload_method eq "ftp") { - my($rv, $file); - if (!$main::FTP_chan->cwd( $main::current_targetdir )) { - msg( "log,mail", "Can't cd to $main::current_targetdir on $conf::target\n" ); - goto err; - } - foreach $file (@files) { - ($rv, $msgs) = ftp_cmd( "put", $file ); - goto err if !$rv; - } - } - else { - ($msgs, $stat) = local_cmd( "$conf::cp @files $main::current_targetdir", 'NOCD' ); - goto err if $stat; - } - - # check md5sums or sizes on target against our own - my $have_md5sums = 1; - if ($conf::upload_method eq "ssh") { - ($msgs, $stat) = ssh_cmd( "md5sum @files" ); - goto err if $stat; - @md5sum = split( "\n", $msgs ); - } - elsif ($conf::upload_method eq "ftp") { - my ($rv, $err, $file); - foreach $file (@files) { - ($rv, $err) = ftp_cmd( "quot", "site", "md5sum", $file ); - if ($err) { - next if ftp_code() == 550; # file not found - if (ftp_code() == 500) { # unimplemented - $have_md5sums = 0; - goto get_sizes_instead; - } - $msgs = $err; - goto err; - } - chomp( my $t = ftp_response() ); - push( @md5sum, $t ); - } - if (!$have_md5sums) { - get_sizes_instead: - foreach $file (@files) { - ($rv, $err) = ftp_cmd( "size", $file ); - if ($err) { - next if ftp_code() == 550; # file not found - $msgs = $err; - goto err; - } - push( @md5sum, "$rv $file" ); - } - } - } - else { - ($msgs, $stat) = local_cmd( "$conf::md5sum @files" ); - goto err if $stat; - @md5sum = split( "\n", $msgs ); - } - - @expected_files = @files; - foreach (@md5sum) { - chomp; - ($sum,$name) = split; - next if !grep { $_ eq $name } @files; # a file we didn't upload?? - next if $sum eq "md5sum:"; # looks like an error message - if (($have_md5sums && $sum ne md5sum( $name )) || - (!$have_md5sums && $sum != (-s $name))) { - msg( "log,mail", "Upload of $name to $conf::target failed ", - "(".($have_md5sums ? "md5sum" : "size")." mismatch)\n" ); - goto err; - } - # seen that file, remove it from expect list - @expected_files = map { $_ eq $name ? () : $_ } @expected_files; - } - if (@expected_files) { - msg( "log,mail", "Failed to upload the files\n" ); - msg( "log,mail", " ", join( ", ", @expected_files ), "\n" ); - msg( "log,mail", "(Not present on target after upload)\n" ); - goto err; - } - - if ($conf::chmod_on_target) { - # change file's mode explicitly to 644 on target - if ($conf::upload_method eq "ssh") { - ($msgs, $stat) = ssh_cmd( "chmod 644 @files" ); - goto err if $stat; - } - elsif ($conf::upload_method eq "ftp") { - my ($rv, $file); - foreach $file (@files) { - ($rv, $msgs) = ftp_cmd( "quot", "site", "chmod", "644", $file ); - msg( "log", "Can't chmod $file on target:\n$msgs" ) - if $msgs; - goto err if !$rv; - } - } - else { - ($msgs, $stat) = local_cmd( "$conf::chmod 644 @files" ); - goto err if $stat; - } - } - - $main::dstat = "c"; - write_status_file() if $conf::statusdelay; - return 1; - - err: - msg( "log,mail", "Upload to $conf::target failed", - $? ? ", last exit status ".sprintf( "%s", $?>>8 ) : "", "\n" ); - msg( "log,mail", "Error messages:\n", $msgs ) - if $msgs; - - # If "permission denied" was among the errors, test if the incoming is - # writable at all. - if ($msgs =~ /(permission denied|read-?only file)/i) { - if (!check_incoming_writable()) { - msg( "log,mail", "(The incoming directory seems to be ", - "unwritable.)\n" ); - } - } - - # remove bad files or an incomplete upload on target - if ($conf::upload_method eq "ssh") { - ssh_cmd( "rm -f @files" ); - } - elsif ($conf::upload_method eq "ftp") { - my $file; - foreach $file (@files) { - my ($rv, $err); - ($rv, $err) = ftp_cmd( "delete", $file ); - msg( "log", "Can't delete $file on target:\n$err" ) - if $err; - } - } - else { - my @tfiles = map { "$main::current_targetdir/$_" } @files; - debug( "executing unlink(@tfiles)" ); - rm( @tfiles ); - } - $main::dstat = "c"; - write_status_file() if $conf::statusdelay; - return 0; -} + my @files = @_; + my ( @md5sum, @expected_files, $sum, $name, $msgs, $stat ); + + $main::dstat = "u"; + write_status_file() if $conf::statusdelay; + + # copy the files + if ( $conf::upload_method eq "ssh" ) { + ( $msgs, $stat ) = scp_cmd(@files); + goto err if $stat; + } elsif ( $conf::upload_method eq "ftp" ) { + my ( $rv, $file ); + if ( !$main::FTP_chan->cwd($main::current_targetdir) ) { + msg( "log,mail", + "Can't cd to $main::current_targetdir on $conf::target\n" ); + goto err; + } + foreach $file (@files) { + ( $rv, $msgs ) = ftp_cmd( "put", $file ); + goto err if !$rv; + } + } else { + for my $file (@files) { + eval { File::Copy::copy($file, $main::current_targetdir) }; + if ($@) { + $stat = 1; + $msgs = $@; + goto err; + } + } + } + + # check md5sums or sizes on target against our own + my $have_md5sums = 1; + if ($conf::check_md5sum) { + if ( $conf::upload_method eq "ssh" ) { + ( $msgs, $stat ) = ssh_cmd("md5sum @files"); + goto err if $stat; + @md5sum = split( "\n", $msgs ); + } elsif ( $conf::upload_method eq "ftp" ) { + my ( $rv, $err, $file ); + foreach $file (@files) { + ( $rv, $err ) = ftp_cmd( "quot", "site", "md5sum", $file ); + if ($err) { + next if ftp_code() == 550; # file not found + if ( ftp_code() == 500 ) { # unimplemented + $have_md5sums = 0; + goto get_sizes_instead; + } + $msgs = $err; + goto err; + } ## end if ($err) + chomp( my $t = ftp_response() ); + push( @md5sum, $t ); + } ## end foreach $file (@files) + if ( !$have_md5sums ) { + get_sizes_instead: + foreach $file (@files) { + ( $rv, $err ) = ftp_cmd( "size", $file ); + if ($err) { + next if ftp_code() == 550; # file not found + $msgs = $err; + goto err; + } + push( @md5sum, "$rv $file" ); + } ## end foreach $file (@files) + } ## end if ( !$have_md5sums ) + } else { + for my $file (@files) { + my $md5 = eval { md5sum("$main::current_targetdir/$file") }; + if ($@) { + $msgs = $@; + goto err; + } + push @md5sum, "$md5 $file" if $md5; + } + } + + @expected_files = @files; + foreach (@md5sum) { + chomp; + ( $sum, $name ) = split; + next if !grep { $_ eq $name } @files; # a file we didn't upload?? + next if $sum eq "md5sum:"; # looks like an error message + if ( ( $have_md5sums && $sum ne md5sum($name) ) + || ( !$have_md5sums && $sum != ( -s $name ) ) ) + { + msg( + "log,mail", + "Upload of $name to $conf::target failed ", + "(" . ( $have_md5sums ? "md5sum" : "size" ) . " mismatch)\n" + ); + goto err; + } ## end if ( ( $have_md5sums &&... + + # seen that file, remove it from expect list + @expected_files = map { $_ eq $name ? () : $_ } @expected_files; + } ## end foreach (@md5sum) + if (@expected_files) { + msg( "log,mail", "Failed to upload the files\n" ); + msg( "log,mail", " ", join( ", ", @expected_files ), "\n" ); + msg( "log,mail", "(Not present on target after upload)\n" ); + goto err; + } ## end if (@expected_files) + } ## end if ($conf::check_md5sum) + + if ($conf::chmod_on_target) { + + # change file's mode explicitly to 644 on target + if ( $conf::upload_method eq "ssh" ) { + ( $msgs, $stat ) = ssh_cmd("chmod 644 @files"); + goto err if $stat; + } elsif ( $conf::upload_method eq "ftp" ) { + my ( $rv, $file ); + foreach $file (@files) { + ( $rv, $msgs ) = ftp_cmd( "quot", "site", "chmod", "644", $file ); + msg( "log", "Can't chmod $file on target:\n$msgs" ) + if $msgs; + goto err if !$rv; + } ## end foreach $file (@files) + } else { + for my $file (@files) { + unless (chmod 0644, "$main::current_targetdir/$file") { + $msgs = "Could not chmod $file: $!"; + goto err; + } + } + } + } ## end if ($conf::chmod_on_target) + + $main::dstat = "c"; + write_status_file() if $conf::statusdelay; + return 1; + +err: + msg( "log,mail", + "Upload to $conf::target failed", + $? ? ", last exit status " . sprintf( "%s", $? >> 8 ) : "", "\n" ); + msg( "log,mail", "Error messages:\n", $msgs ) + if $msgs; + + # If "permission denied" was among the errors, test if the incoming is + # writable at all. + if ( $msgs && $msgs =~ /(permission denied|read-?only file)/i ) { + if ( !check_incoming_writable() ) { + msg( "log,mail", "(The incoming directory seems to be ", + "unwritable.)\n" ); + } + } ## end if ( $msgs =~ /(permission denied|read-?only file)/i) + + # remove bad files or an incomplete upload on target + if ( $conf::upload_method eq "ssh" ) { + ssh_cmd("rm -f @files"); + } elsif ( $conf::upload_method eq "ftp" ) { + my $file; + foreach $file (@files) { + my ( $rv, $err ); + ( $rv, $err ) = ftp_cmd( "delete", $file ); + msg( "log", "Can't delete $file on target:\n$err" ) + if $err; + } ## end foreach $file (@files) + } else { + my @tfiles = map { "$main::current_targetdir/$_" } @files; + debug("executing unlink(@tfiles)"); + rm(@tfiles); + } + $main::dstat = "c"; + write_status_file() if $conf::statusdelay; + return 0; +} ## end sub copy_to_target(@) # # check if a file is correctly signed with PGP # sub pgp_check($) { - my $file = shift; - my $output = ""; - my $signator; - my $found = 0; - my $stat; - local( *PIPE ); - - $stat = 1; - if (-x $conf::gpg) { - debug( "executing $conf::gpg --no-options --batch ". - "--no-default-keyring --always-trust ". - "--keyring ". join (" --keyring ",@conf::keyrings). - " --verify '$file'" ); - if (!open( PIPE, "$conf::gpg --no-options --batch ". - "--no-default-keyring --always-trust ". - "--keyring " . join (" --keyring ",@conf::keyrings). - " --verify '$file'". - " 2>&1 |" )) { - msg( "log", "Can't open pipe to $conf::gpg: $!\n" ); - return "LOCAL ERROR"; - } - $output .= $_ while( ); - close( PIPE ); - $stat = $?; - } - - if ($stat) { - msg( "log,mail", "GnuPG signature check failed on $file\n" ); - msg( "mail", $output ); - msg( "log,mail", "(Exit status ", $stat >> 8, ")\n" ); - return ""; - } - - $output =~ /^(gpg: )?good signature from (user )?"(.*)"\.?$/im; - ($signator = $3) ||= "unknown signator"; - if ($conf::debug) { - debug( "GnuPG signature ok (by $signator)" ); - } - return $signator; -} - + my $file = shift; + my $output = ""; + my $signator; + my $found = 0; + my $stat = 1; + local (*PIPE); + local $_; + + if ($file =~ /$re_file_safe/) { + $file = $1; + } else { + msg( "log", "Tainted filename, skipping: $file\n" ); + return "LOCAL ERROR"; + } + + # check the file has only one clear-signed section + my $fh; + unless (open $fh, "<", $file) { + msg("log,mail", "Could not open $file\n"); + return ""; + } + unless (<$fh> eq "-----BEGIN PGP SIGNED MESSAGE-----\n") { + msg("log,mail", "$file: does not start with a clearsigned message\n"); + return ""; + } + my $pgplines = 1; + while (<$fh>) { + if (/\A- /) { + msg("log,mail", "$file: dash-escaped messages are not accepted\n"); + return ""; + } + elsif ($_ eq "-----BEGIN PGP SIGNATURE-----\n" + || $_ eq "-----END PGP SIGNATURE-----\n") { + $pgplines++; + } + elsif (/\A--/) { + msg("log,mail", "$file: unexpected OpenPGP armor\n"); + return ""; + } + elsif ($pgplines > 3 && /\S/) { + msg("log,mail", "$file: found text after end of signature\n"); + return ""; + } + } + if ($pgplines != 3) { + msg("log,mail", "$file: doesn't seem to be a valid clearsigned OpenPGP message\n"); + return ""; + } + close $fh; + + if ( -x $conf::gpg ) { + my @command = ("$conf::gpg", "--no-options", "--batch", "--no-tty", + "--trust-model", "always", "--no-default-keyring", + (map +("--keyring" => $_), @conf::keyrings), + "--verify", "-"); + debug( "executing " . join(" ", @command) ); + + my $child = open(PIPE, "-|"); + if (!defined($child)) { + msg("log", "Can't open pipe to $conf::gpg: $!\n"); + return "LOCAL ERROR"; + } + if ($child == 0) { + unless (open(STDERR, ">&", \*STDOUT)) { + print "Could not redirect STDERR."; + exit(-1); + } + unless (open(STDIN, "<", $file)) { + print "Could not open $file: $!"; + exit(-1); + } + { exec(@command) }; # BLOCK avoids warning about likely unreachable code + print "Could not exec gpg: $!"; + exit(-1); + } + + $output .= $_ while (); + close(PIPE); + $stat = $?; + } ## end if ( -x $conf::gpg ) + + if ($stat) { + msg( "log,mail", "GnuPG signature check failed on $file\n" ); + msg( "mail", $output ); + msg( "log,mail", "(Exit status ", $stat >> 8, ")\n" ); + return ""; + } ## end if ($stat) + + $output =~ /^(gpg: )?good signature from (user )?"(.*)"\.?$/im; + ( $signator = $3 ) ||= "unknown signator"; + if ($conf::debug) { + debug("GnuPG signature ok (by $signator)"); + } + return $signator; +} ## end sub pgp_check($) # --------------------------------------------------------------------------- # the status daemon @@ -1491,167 +1735,175 @@ sub pgp_check($) { # # fork a subprocess that watches the 'status' FIFO -# +# # that process blocks until someone opens the FIFO, then sends a -# signal (SIGUSR1) to the main process, expects +# signal (SIGUSR1) to the main process, expects # sub fork_statusd() { - my $statusd_pid; - my $main_pid = $$; - my $errs; - local( *STATFIFO ); - - $statusd_pid = open( STATUSD, "|-" ); - die "cannot fork: $!\n" if !defined( $statusd_pid ); - # parent just returns - if ($statusd_pid) { - msg( "log", "forked status daemon (pid $statusd_pid)\n" ); - return $statusd_pid; - } - # child: the status FIFO daemon - - # ignore SIGPIPE here, in case some closes the FIFO without completely - # reading it - $SIG{"PIPE"} = "IGNORE"; - # also ignore SIGCLD, we don't want to inherit the restart-statusd handler - # from our parent - $SIG{"CHLD"} = "DEFAULT"; - - rm( $conf::statusfile ); - $errs = `$conf::mkfifo $conf::statusfile`; - die "$main::progname: cannot create named pipe $conf::statusfile: $errs" - if $?; - chmod( 0644, $conf::statusfile ) - or die "Cannot set modes of $conf::statusfile: $!\n"; - - # close log file, so that log rotating works - close( LOG ); - close( STDOUT ); - close( STDERR ); - - while( 1 ) { - my( $status, $mup, $incw, $ds, $next_run, $last_ping, $currch, $l ); - - # open the FIFO for writing; this blocks until someone (probably ftpd) - # opens it for reading - open( STATFIFO, ">$conf::statusfile" ) - or die "Cannot open $conf::statusfile\n"; - select( STATFIFO ); - # tell main daemon to send us status infos - kill( $main::signo{"USR1"}, $main_pid ); - - # get the infos from stdin; must loop until enough bytes received! - my $expect_len = 3 + 2*STATNUM_LEN + STATSTR_LEN; - for( $status = ""; ($l = length($status)) < $expect_len; ) { - sysread( STDIN, $status, $expect_len-$l, $l ); - } - - # disassemble the status byte stream - my $pos = 0; - foreach ( [ mup => 1 ], [ incw => 1 ], [ ds => 1 ], - [ next_run => STATNUM_LEN ], [ last_ping => STATNUM_LEN ], - [ currch => STATSTR_LEN ] ) { - eval "\$$_->[0] = substr( \$status, $pos, $_->[1] );"; - $pos += $_->[1]; - } - $currch =~ s/\n+//g; - - print_status( $mup, $incw, $ds, $next_run, $last_ping, $currch ); - close( STATFIFO ); - - # This sleep is necessary so that we can't reopen the FIFO - # immediately, in case the reader hasn't closed it yet if we get to - # the open again. Is there a better solution for this?? - sleep 1; - } -} + my $statusd_pid; + my $main_pid = $$; + my $errs; + local (*STATFIFO); + + $statusd_pid = open( STATUSD, "|-" ); + die "cannot fork: $!\n" if !defined($statusd_pid); + + # parent just returns + if ($statusd_pid) { + msg( "log", "forked status daemon (pid $statusd_pid)\n" ); + return $statusd_pid; + } + + # child: the status FIFO daemon + + # ignore SIGPIPE here, in case some closes the FIFO without completely + # reading it + $SIG{"PIPE"} = "IGNORE"; + + # also ignore SIGCLD, we don't want to inherit the restart-statusd handler + # from our parent + $SIG{"CHLD"} = "DEFAULT"; + + rm($conf::statusfile); + $errs = `$conf::mkfifo $conf::statusfile`; + die "$main::progname: cannot create named pipe $conf::statusfile: $errs" + if $?; + chmod( 0644, $conf::statusfile ) + or die "Cannot set modes of $conf::statusfile: $!\n"; + + # close log file, so that log rotating works + close(LOG); + close(STDOUT); + close(STDERR); + + while (1) { + my ( $status, $mup, $incw, $ds, $next_run, $last_ping, $currch, $l ); + + # open the FIFO for writing; this blocks until someone (probably ftpd) + # opens it for reading + open( STATFIFO, ">", $conf::statusfile ) + or die "Cannot open $conf::statusfile\n"; + select(STATFIFO); + + # tell main daemon to send us status infos + kill( $main::signo{"USR1"}, $main_pid ); + + # get the infos from stdin; must loop until enough bytes received! + my $expect_len = 3 + 2 * STATNUM_LEN + STATSTR_LEN; + for ( $status = "" ; ( $l = length($status) ) < $expect_len ; ) { + sysread( STDIN, $status, $expect_len - $l, $l ); + } + + # disassemble the status byte stream + my $pos = 0; + foreach ( + [ mup => 1 ], + [ incw => 1 ], + [ ds => 1 ], + [ next_run => STATNUM_LEN ], + [ last_ping => STATNUM_LEN ], + [ currch => STATSTR_LEN ] + ) + { + eval "\$$_->[0] = substr( \$status, $pos, $_->[1] );"; + $pos += $_->[1]; + } ## end foreach ( [ mup => 1 ], [ incw... + $currch =~ s/\n+//g; + + print_status( $mup, $incw, $ds, $next_run, $last_ping, $currch ); + close(STATFIFO); + + # This sleep is necessary so that we can't reopen the FIFO + # immediately, in case the reader hasn't closed it yet if we get to + # the open again. Is there a better solution for this?? + sleep 1; + } ## end while (1) +} ## end sub fork_statusd() # # update the status file, in case we use a plain file and not a FIFO # sub write_status_file() { - return if !$conf::statusfile; - - open( STATFILE, ">$conf::statusfile" ) or - (msg( "log", "Could not open $conf::statusfile: $!\n" ), return); - my $oldsel = select( STATFILE ); + return if !$conf::statusfile; - print_status( $main::target_up, $main::incoming_writable, $main::dstat, - $main::next_run, $main::last_ping_time, - $main::current_changes ); + open( STATFILE, ">", $conf::statusfile ) + or ( msg( "log", "Could not open $conf::statusfile: $!\n" ), return ); + my $oldsel = select(STATFILE); - select( $oldsel ); - close( STATFILE ); -} + print_status( + $main::target_up, $main::incoming_writable, + $main::dstat, $main::next_run, + $main::last_ping_time, $main::current_changes + ); + + select($oldsel); + close(STATFILE); +} ## end sub write_status_file() sub print_status($$$$$$) { - my $mup = shift; - my $incw = shift; - my $ds = shift; - my $next_run = shift; - my $last_ping = shift; - my $currch = shift; - my $approx; - my $version; - - ($version = 'Release: 0.9 $Revision: 1.51 $') =~ s/\$ ?//g; - print "debianqueued $version\n"; - - $approx = $conf::statusdelay ? "approx. " : ""; - - if ($mup eq "0") { - print "$conf::target is down, queue pausing\n"; - return; - } - elsif ($conf::upload_method ne "copy") { - print "$conf::target seems to be up, last ping $approx", - print_time(time-$last_ping), " ago\n"; - } - - if ($incw eq "0") { - print "The incoming directory is not writable, queue pausing\n"; - return; - } - - if ($ds eq "i") { - print "Next queue check in $approx",print_time($next_run-time),"\n"; - return; - } - elsif ($ds eq "c") { - print "Checking queue directory\n"; - } - elsif ($ds eq "u") { - print "Uploading to $conf::target\n"; - } - else { - print "Bad status data from daemon: \"$mup$incw$ds\"\n"; - return; - } - - print "Current job is $currch\n" if $currch; -} + my $mup = shift; + my $incw = shift; + my $ds = shift; + my $next_run = shift; + my $last_ping = shift; + my $currch = shift; + my $approx; + my $version; + + ( $version = 'Release: 0.9 $Revision: 1.51 $' ) =~ s/\$ ?//g; + print "debianqueued $version\n"; + + $approx = $conf::statusdelay ? "approx. " : ""; + + if ( $mup eq "0" ) { + print "$conf::target is down, queue pausing\n"; + return; + } elsif ( $conf::upload_method ne "copy" ) { + print "$conf::target seems to be up, last ping $approx", + print_time( time - $last_ping ), " ago\n"; + } + + if ( $incw eq "0" ) { + print "The incoming directory is not writable, queue pausing\n"; + return; + } + + if ( $ds eq "i" ) { + print "Next queue check in $approx", print_time( $next_run - time ), "\n"; + return; + } elsif ( $ds eq "c" ) { + print "Checking queue directory\n"; + } elsif ( $ds eq "u" ) { + print "Uploading to $conf::target\n"; + } else { + print "Bad status data from daemon: \"$mup$incw$ds\"\n"; + return; + } + + print "Current job is $currch\n" if $currch; +} ## end sub print_status($$$$$$) # # format a number for sending to statusd (fixed length STATNUM_LEN) # sub format_status_num(\$$) { - my $varref = shift; - my $num = shift; - - $$varref = sprintf "%".STATNUM_LEN."d", $num; -} + my $varref = shift; + my $num = shift; + + $$varref = sprintf "%" . STATNUM_LEN . "d", $num; +} ## end sub format_status_num(\$$) # # format a string for sending to statusd (fixed length STATSTR_LEN) # sub format_status_str(\$$) { - my $varref = shift; - my $str = shift; + my $varref = shift; + my $str = shift; - $$varref = substr( $str, 0, STATSTR_LEN ); - $$varref .= "\n" x (STATSTR_LEN - length($$varref)); -} + $$varref = substr( $str, 0, STATSTR_LEN ); + $$varref .= "\n" x ( STATSTR_LEN - length($$varref) ); +} ## end sub format_status_str(\$$) # # send a status string to the status daemon @@ -1661,19 +1913,18 @@ sub format_status_str(\$$) { # signal handler. So use only already-defined variables. # sub send_status() { - local $! = 0; # preserve errno - - # re-setup handler, in case we have broken SysV signals - $SIG{"USR1"} = \&send_status; - - syswrite( STATUSD, $main::target_up, 1 ); - syswrite( STATUSD, $main::incoming_writable, 1 ); - syswrite( STATUSD, $main::dstat, 1 ); - syswrite( STATUSD, $main::next_run, STATNUM_LEN ); - syswrite( STATUSD, $main::last_ping_time, STATNUM_LEN ); - syswrite( STATUSD, $main::current_changes, STATSTR_LEN ); -} + local $! = 0; # preserve errno + # re-setup handler, in case we have broken SysV signals + $SIG{"USR1"} = \&send_status; + + syswrite( STATUSD, $main::target_up, 1 ); + syswrite( STATUSD, $main::incoming_writable, 1 ); + syswrite( STATUSD, $main::dstat, 1 ); + syswrite( STATUSD, $main::next_run, STATNUM_LEN ); + syswrite( STATUSD, $main::last_ping_time, STATNUM_LEN ); + syswrite( STATUSD, $main::current_changes, STATSTR_LEN ); +} ## end sub send_status() # --------------------------------------------------------------------------- # FTP functions @@ -1683,81 +1934,94 @@ sub send_status() { # open FTP connection to target host if not already open # sub ftp_open() { - - if ($main::FTP_chan) { - # is already open, but might have timed out; test with a cwd - return $main::FTP_chan if $main::FTP_chan->cwd( $main::current_targetdir ); - # cwd didn't work, channel is closed, try to reopen it - $main::FTP_chan = undef; - } - - if (!($main::FTP_chan = Net::FTP->new( $conf::target, - Debug => $conf::ftpdebug, - Timeout => $conf::ftptimeout ))) { - msg( "log,mail", "Cannot open FTP server $conf::target\n" ); - goto err; - } - if (!$main::FTP_chan->login()) { - msg( "log,mail", "Anonymous login on FTP server $conf::target failed\n" ); - goto err; - } - if (!$main::FTP_chan->binary()) { - msg( "log,mail", "Can't set binary FTP mode on $conf::target\n" ); - goto err; - } - if (!$main::FTP_chan->cwd( $main::current_targetdir )) { - msg( "log,mail", "Can't cd to $main::current_targetdir on $conf::target\n" ); - goto err; - } - debug( "opened FTP channel to $conf::target" ); - return 1; - - err: - $main::FTP_chan = undef; - return 0; -} + return 1 unless $conf::upload_method eq "ftp"; + + if ($main::FTP_chan) { + + # is already open, but might have timed out; test with a cwd + return $main::FTP_chan + if $main::FTP_chan->cwd($main::current_targetdir); + + # cwd didn't work, channel is closed, try to reopen it + $main::FTP_chan = undef; + } ## end if ($main::FTP_chan) + + if ( + !( + $main::FTP_chan = + Net::FTP->new( + $conf::target, + Debug => $conf::ftpdebug, + Timeout => $conf::ftptimeout, + Passive => 1, + ) + ) + ) + { + msg( "log,mail", "Cannot open FTP server $conf::target\n" ); + goto err; + } ## end if ( !( $main::FTP_chan... + if ( !$main::FTP_chan->login() ) { + msg( "log,mail", "Anonymous login on FTP server $conf::target failed\n" ); + goto err; + } + if ( !$main::FTP_chan->binary() ) { + msg( "log,mail", "Can't set binary FTP mode on $conf::target\n" ); + goto err; + } + if ( !$main::FTP_chan->cwd($main::current_targetdir) ) { + msg( "log,mail", + "Can't cd to $main::current_targetdir on $conf::target\n" ); + goto err; + } + debug("opened FTP channel to $conf::target"); + return 1; + +err: + $main::FTP_chan = undef; + return 0; +} ## end sub ftp_open() sub ftp_cmd($@) { - my $cmd = shift; - my ($rv, $err); - my $direct_resp_cmd = ($cmd eq "quot"); - - debug( "executing FTP::$cmd(".join(", ",@_).")" ); - $SIG{"ALRM"} = sub { die "timeout in FTP::$cmd\n" } ; - alarm( $conf::remote_timeout ); - eval { $rv = $main::FTP_chan->$cmd( @_ ); }; - alarm( 0 ); - $err = ""; - $rv = (ftp_code() =~ /^2/) ? 1 : 0 if $direct_resp_cmd; - if ($@) { - $err = $@; - undef $rv; - } - elsif (!$rv) { - $err = ftp_response(); - } - return ($rv, $err); -} + my $cmd = shift; + my ( $rv, $err ); + my $direct_resp_cmd = ( $cmd eq "quot" ); + + debug( "executing FTP::$cmd(" . join( ", ", @_ ) . ")" ); + $SIG{"ALRM"} = sub { die "timeout in FTP::$cmd\n" }; + alarm($conf::remote_timeout); + eval { $rv = $main::FTP_chan->$cmd(@_); }; + alarm(0); + $err = ""; + $rv = ( ftp_code() =~ /^2/ ) ? 1 : 0 if $direct_resp_cmd; + if ($@) { + $err = $@; + undef $rv; + } elsif ( !$rv ) { + $err = ftp_response(); + } + return ( $rv, $err ); +} ## end sub ftp_cmd($@) sub ftp_close() { - if ($main::FTP_chan) { - $main::FTP_chan->quit(); - $main::FTP_chan = undef; - } - return 1; -} + if ($main::FTP_chan) { + $main::FTP_chan->quit(); + $main::FTP_chan = undef; + } + return 1; +} ## end sub ftp_close() sub ftp_response() { - return join( '', @{${*$main::FTP_chan}{'net_cmd_resp'}} ); + return join( '', @{ ${*$main::FTP_chan}{'net_cmd_resp'} } ); } sub ftp_code() { - return ${*$main::FTP_chan}{'net_cmd_code'}; + return ${*$main::FTP_chan}{'net_cmd_code'}; } sub ftp_error() { - my $code = ftp_code(); - return ($code =~ /^[45]/) ? 1 : 0; + my $code = ftp_code(); + return ( $code =~ /^[45]/ ) ? 1 : 0; } # --------------------------------------------------------------------------- @@ -1765,281 +2029,185 @@ sub ftp_error() { # --------------------------------------------------------------------------- sub ssh_cmd($) { - my $cmd = shift; - my ($msg, $stat); - - my $ecmd = "$conf::ssh $conf::ssh_options $conf::target ". - "-l $conf::targetlogin \'cd $main::current_targetdir; $cmd\'"; - debug( "executing $ecmd" ); - $SIG{"ALRM"} = sub { die "timeout in ssh command\n" } ; - alarm( $conf::remote_timeout ); - eval { $msg = `$ecmd 2>&1`; }; - alarm( 0 ); - if ($@) { - $msg = $@; - $stat = 1; - } - else { - $stat = $?; - } - return ($msg, $stat); -} + my $cmd = shift; + my ( $msg, $stat ); + + my $ecmd = "$conf::ssh $conf::ssh_options $conf::target " + . "-l $conf::targetlogin \'cd $main::current_targetdir; $cmd\'"; + debug("executing $ecmd"); + $SIG{"ALRM"} = sub { die "timeout in ssh command\n" }; + alarm($conf::remote_timeout); + eval { $msg = `$ecmd 2>&1`; }; + alarm(0); + if ($@) { + $msg = $@; + $stat = 1; + } else { + $stat = $?; + } + return ( $msg, $stat ); +} ## end sub ssh_cmd($) sub scp_cmd(@) { - my ($msg, $stat); - - my $ecmd = "$conf::scp $conf::ssh_options @_ ". - "$conf::targetlogin\@$conf::target:$main::current_targetdir"; - debug( "executing $ecmd" ); - $SIG{"ALRM"} = sub { die "timeout in scp\n" } ; - alarm( $conf::remote_timeout ); - eval { $msg = `$ecmd 2>&1`; }; - alarm( 0 ); - if ($@) { - $msg = $@; - $stat = 1; - } - else { - $stat = $?; - } - return ($msg, $stat); -} - -sub local_cmd($;$) { - my $cmd = shift; - my $nocd = shift; - my ($msg, $stat); - - my $ecmd = ($nocd ? "" : "cd $main::current_targetdir; ") . $cmd; - debug( "executing $ecmd" ); - $msg = `($ecmd) 2>&1`; - $stat = $?; - return ($msg, $stat); - -} + my ( $msg, $stat ); + + my $ecmd = "$conf::scp $conf::ssh_options @_ " + . "$conf::targetlogin\@$conf::target:$main::current_targetdir"; + debug("executing $ecmd"); + $SIG{"ALRM"} = sub { die "timeout in scp\n" }; + alarm($conf::remote_timeout); + eval { $msg = `$ecmd 2>&1`; }; + alarm(0); + if ($@) { + $msg = $@; + $stat = 1; + } else { + $stat = $?; + } + return ( $msg, $stat ); +} ## end sub scp_cmd(@) # # check if target is alive (code stolen from Net::Ping.pm) # sub check_alive(;$) { - my $timeout = shift; - my( $saddr, $ret, $target_ip ); - local( *PINGSOCK ); - - if ($conf::upload_method eq "copy") { - format_status_num( $main::last_ping_time, time ); - $main::target_up = 1; - return; - } - - $timeout ||= 30; - - if (!($target_ip = (gethostbyname($conf::target))[4])) { - msg( "log", "Cannot get IP address of $conf::target\n" ); - $ret = 0; - goto out; - } - $saddr = pack( 'S n a4 x8', AF_INET, $main::echo_port, $target_ip ); - $SIG{'ALRM'} = sub { die } ; - alarm( $timeout ); - - $ret = $main::tcp_proto; # avoid warnings about unused variable + my $timeout = shift; + my ( $saddr, $ret, $target_ip ); + local (*PINGSOCK); + + if ( $conf::upload_method eq "copy" ) { + format_status_num( $main::last_ping_time, time ); + $main::target_up = 1; + return; + } + + $timeout ||= 30; + + if ( !( $target_ip = ( gethostbyname($conf::target) )[4] ) ) { + msg( "log", "Cannot get IP address of $conf::target\n" ); $ret = 0; - eval <<'EOM' ; + goto out; + } + $saddr = pack( 'S n a4 x8', AF_INET, $main::echo_port, $target_ip ); + $SIG{'ALRM'} = sub { die }; + alarm($timeout); + + $ret = $main::tcp_proto; # avoid warnings about unused variable + $ret = 0; + eval <<'EOM' ; return unless socket( PINGSOCK, PF_INET, SOCK_STREAM, $main::tcp_proto ); return unless connect( PINGSOCK, $saddr ); $ret = 1; EOM - alarm( 0 ); - close( PINGSOCK ); - msg( "log", "pinging $conf::target: " . ($ret ? "ok" : "down") . "\n" ); - out: - $main::target_up = $ret ? "1" : "0"; - format_status_num( $main::last_ping_time, time ); - write_status_file() if $conf::statusdelay; -} + alarm(0); + close(PINGSOCK); + msg( "log", "pinging $conf::target: " . ( $ret ? "ok" : "down" ) . "\n" ); +out: + $main::target_up = $ret ? "1" : "0"; + format_status_num( $main::last_ping_time, time ); + write_status_file() if $conf::statusdelay; +} ## end sub check_alive(;$) # # check if incoming dir on target is writable # sub check_incoming_writable() { - my $testfile = ".debianqueued-testfile"; - my ($msg, $stat); - - if ($conf::upload_method eq "ssh") { - ($msg, $stat) = ssh_cmd( "rm -f $testfile; touch $testfile; ". - "rm -f $testfile" ); - } - elsif ($conf::upload_method eq "ftp") { - my $file = "junk-for-writable-test-".format_time(); - $file =~ s/[ :.]/-/g; - local( *F ); - open( F, ">$file" ); close( F ); - my $rv; - ($rv, $msg) = ftp_cmd( "put", $file ); - $stat = 0; - $msg = "" if !defined $msg; - unlink $file; - ftp_cmd( "delete", $file ); - } - elsif ($conf::upload_method eq "copy") { - ($msg, $stat) = local_cmd( "rm -f $testfile; touch $testfile; ". - "rm -f $testfile" ); - } - chomp( $msg ); - debug( "exit status: $stat, output was: $msg" ); - - if (!$stat) { - # change incoming_writable only if ssh didn't return an error - $main::incoming_writable = - ($msg =~ /(permission denied|read-?only file|cannot create)/i) ? "0":"1"; - } - else { - debug( "local error, keeping old status" ); - } - debug( "incoming_writable = $main::incoming_writable" ); - write_status_file() if $conf::statusdelay; - return $main::incoming_writable; -} + my $testfile = ".debianqueued-testfile"; + my ( $msg, $stat ); + + if ( $conf::upload_method eq "ssh" ) { + ( $msg, $stat ) = + ssh_cmd( "rm -f $testfile; touch $testfile; " . "rm -f $testfile" ); + } elsif ( $conf::upload_method eq "ftp" ) { + my $file = "junk-for-writable-test-" . format_time(); + $file =~ s/[ :.]/-/g; + local (*F); + open( F, ">", $file ); + close(F); + my $rv; + ( $rv, $msg ) = ftp_cmd( "put", $file ); + $stat = 0; + $msg = "" if !defined $msg; + unlink $file; + ftp_cmd( "delete", $file ); + } elsif ( $conf::upload_method eq "copy" ) { + unless(POSIX::access($main::current_targetdir, &POSIX::W_OK)) { + $msg = "No write access: $!"; + $stat = 1; + } + } + chomp($msg); + debug("exit status: $stat, output was: $msg"); + + if ( !$stat ) { + + # change incoming_writable only if ssh didn't return an error + $main::incoming_writable = + ( $msg =~ /(permission denied|read-?only file|cannot create)/i ) + ? "0" + : "1"; + } else { + debug("local error, keeping old status"); + } + debug("incoming_writable = $main::incoming_writable"); + write_status_file() if $conf::statusdelay; + return $main::incoming_writable; +} ## end sub check_incoming_writable() # # remove a list of files, log failing ones # sub rm(@) { - my $done = 0; + my $done = 0; - foreach ( @_ ) { - (unlink $_ and ++$done) - or $! == ENOENT or msg( "log", "Could not delete $_: $!\n" ); - } - return $done; -} + foreach (@_) { + ( unlink $_ and ++$done ) + or $! == ENOENT + or msg( "log", "Could not delete $_: $!\n" ); + } + return $done; +} ## end sub rm(@) # # get md5 checksum of a file # sub md5sum($) { - my $file = shift; - my $line; - - chomp( $line = `$conf::md5sum $file` ); - debug( "md5sum($file): ", $? ? "exit status $?" : - $line =~ /^(\S+)/ ? $1 : "match failed" ); - return $? ? "" : $line =~ /^(\S+)/ ? $1 : ""; -} + my $file = shift; + my $md5 = Digest::MD5->new; -# -# check if a file probably belongs to a Debian upload -# -sub is_debian_file($) { - my $file = shift; - return $file =~ /\.(deb|dsc|(diff|tar)\.gz)$/ && - $file !~ /\.orig\.tar\.gz/; -} - -# -# try to extract maintainer email address from some a non-.changes file -# return "" if not possible -# -sub get_maintainer($) { - my $file = shift; - my $maintainer = ""; - local( *F ); - - if ($file =~ /\.diff\.gz$/) { - # parse a diff - open( F, "$conf::gzip -dc '$file' 2>/dev/null |" ) or return ""; - while( ) { - # look for header line of a file */debian/control - last if m,^\+\+\+\s+[^/]+/debian/control(\s+|$),; - } - while( ) { - last if /^---/; # end of control file patch, no Maintainer: found - # inside control file patch look for Maintainer: field - $maintainer = $1, last if /^\+Maintainer:\s*(.*)$/i; - } - while( ) { } # read to end of file to avoid broken pipe - close( F ) or return ""; - } - elsif ($file =~ /\.(deb|dsc|tar\.gz)$/) { - if ($file =~ /\.deb$/ && $conf::ar) { - # extract control.tar.gz from .deb with ar, then let tar extract - # the control file itself - open( F, "($conf::ar p '$file' control.tar.gz | ". - "$conf::tar -xOf - ". - "--use-compress-program $conf::gzip ". - "control) 2>/dev/null |" ) - or return ""; - } - elsif ($file =~ /\.dsc$/) { - # just do a plain grep - debug( "get_maint: .dsc, no cmd" ); - open( F, "<$file" ) or return ""; - } - elsif ($file =~ /\.tar\.gz$/) { - # let tar extract a file */debian/control - open(F, "$conf::tar -xOf '$file' ". - "--use-compress-program $conf::gzip ". - "\\*/debian/control 2>&1 |") - or return ""; - } - else { - return ""; - } - while( ) { - $maintainer = $1, last if /^Maintainer:\s*(.*)$/i; - } - close( F ) or return ""; - } - - return $maintainer; -} + open my $fh, "<", $file or return ""; + $md5->addfile($fh); + close $fh; -# -# return a pattern that matches all files that probably belong to one job -# -sub debian_file_stem($) { - my $file = shift; - my( $pkg, $version ); + return $md5->hexdigest; +} ## end sub md5sum($) - # strip file suffix - $file =~ s,\.(deb|dsc|changes|(orig\.)?tar\.gz|diff\.gz)$,,; - # if not is *_* (name_version), can't derive a stem and return just - # the file's name - return $file if !($file =~ /^([^_]+)_([^_]+)/); - ($pkg, $version) = ($1, $2); - # strip Debian revision from version - $version =~ s/^(.*)-[\d.+-]+$/$1/; - - return "${pkg}_${version}*"; -} - # # output a messages to several destinations # # first arg is a comma-separated list of destinations; valid are "log" # and "mail"; rest is stuff to be printed, just as with print -# +# sub msg($@) { - my @dest = split( ',', shift ); + my @dest = split( ',', shift ); - if (grep /log/, @dest ) { - my $now = format_time(); - print LOG "$now ", @_; - } + if ( grep /log/, @dest ) { + my $now = format_time(); + print LOG "$now ", @_; + } - if (grep /mail/, @dest ) { - $main::mail_text .= join( '', @_ ); - } -} + if ( grep /mail/, @dest ) { + $main::mail_text .= join( '', @_ ); + } +} ## end sub msg($@) # # print a debug messages, if $debug is true # sub debug(@) { - return if !$conf::debug; - my $now = format_time(); - print LOG "$now DEBUG ", @_, "\n"; + return if !$conf::debug; + my $now = format_time(); + print LOG "$now DEBUG ", @_, "\n"; } # @@ -2047,13 +2215,13 @@ sub debug(@) { # address, subject, ...) # sub init_mail(;$) { - my $file = shift; + my $file = shift; - $main::mail_addr = ""; - $main::mail_text = ""; - %main::packages = (); - $main::mail_subject = $file ? "Processing of $file" : ""; -} + $main::mail_addr = ""; + $main::mail_text = ""; + %main::packages = (); + $main::mail_subject = $file ? "Processing of $file" : ""; +} ## end sub init_mail(;$) # # finalize mail to be sent from msg(): check if something present, and @@ -2061,204 +2229,223 @@ sub init_mail(;$) { # sub finish_mail() { - debug( "No mail for $main::mail_addr" ) - if $main::mail_addr && !$main::mail_text; - return unless $main::mail_addr && $main::mail_text; - - if (!send_mail($main::mail_addr, $main::mail_subject, $main::mail_text)) { - # store this mail in memory so it isn't lost if executing sendmail - # failed. - push( @main::stored_mails, { addr => $main::mail_addr, - subject => $main::mail_subject, - text => $main::mail_text } ); - } - init_mail(); - - # try to send out stored mails - my $mailref; - while( $mailref = shift(@main::stored_mails) ) { - if (!send_mail( $mailref->{'addr'}, $mailref->{'subject'}, - $mailref->{'text'} )) { - unshift( @main::stored_mails, $mailref ); - last; - } - } -} + debug("No mail for $main::mail_addr") + if $main::mail_addr && !$main::mail_text; + return unless $main::mail_addr && $main::mail_text; + + if ( !send_mail( $main::mail_addr, $main::mail_subject, $main::mail_text ) ) + { + + # store this mail in memory so it isn't lost if executing sendmail + # failed. + push( + @main::stored_mails, + { + addr => $main::mail_addr, + subject => $main::mail_subject, + text => $main::mail_text + } + ); + } ## end if ( !send_mail( $main::mail_addr... + init_mail(); + + # try to send out stored mails + my $mailref; + while ( $mailref = shift(@main::stored_mails) ) { + if ( + !send_mail( $mailref->{'addr'}, $mailref->{'subject'}, + $mailref->{'text'} ) + ) + { + unshift( @main::stored_mails, $mailref ); + last; + } ## end if ( !send_mail( $mailref... + } ## end while ( $mailref = shift(... +} ## end sub finish_mail() # # send one mail # sub send_mail($$$) { - my $addr = shift; - my $subject = shift; - my $text = shift; + my $addr = shift; + my $subject = shift; + my $text = shift; + + my $package = + keys %main::packages ? join( ' ', keys %main::packages ) : ""; - my $package = keys %main::packages ? join(' ', keys %main::packages) : ""; + use Email::Send; - use Email::Send; + unless ( defined($Email::Send::Sendmail::SENDMAIL) ) { + $Email::Send::Sendmail::SENDMAIL = $conf::mail; + } - unless (defined($Email::Send::Sendmail::SENDMAIL)) { - $Email::Send::Sendmail::SENDMAIL = $conf::mail; - } + if ($conf::overridemail) { + $addr = $conf::overridemail; + } - my $date = sprintf "%s", strftime("%a, %d %b %Y %T %z", (localtime(time))); - my $message = <<__MESSAGE__; + my $date = sprintf "%s", + strftime( "%a, %d %b %Y %T %z", ( localtime(time) ) ); + my $message = <<__MESSAGE__; To: $addr -From: Archive Administrator +From: Debian FTP Masters Subject: $subject Date: $date X-Debian: DAK +X-DAK: DAK __MESSAGE__ - if (length $package) { - $message .= "X-Debian-Package: $package\n"; - } + if ( length $package ) { + $message .= "X-Debian-Package: $package\n"; + } - $message .= "\n$text"; - $message .= "\nGreetings,\n\n\tYour Debian queue daemon\n"; + $message .= "\n$text"; + $message .= "\nGreetings,\n\n\tYour Debian queue daemon (running on host $main::hostname)\n"; - my $mail = Email::Send->new; - for ( qw[Sendmail SMTP] ) { - $mail->mailer($_) and last if $mail->mailer_available($_); - } + my $mail = Email::Send->new; + for (qw[Sendmail SMTP]) { + $mail->mailer($_) and last if $mail->mailer_available($_); + } - my $ret = $mail->send($message); - if ($ret && $ret !~ /Message sent|success/) { - return 0; - } + my $ret = $mail->send($message); + if ( $ret && $ret !~ /Message sent|success/ ) { + return 0; + } - return 1; -} + return 1; +} ## end sub send_mail($$$) # # try to find a mail address for a name in the keyrings # sub try_to_get_mail_addr($$) { - my $name = shift; - my $listref = shift; - - @$listref = (); - open( F, "$conf::gpg --no-options --batch --no-default-keyring ". - "--always-trust --keyring ". - join (" --keyring ",@conf::keyrings). - " --list-keys |" ) - or return ""; - while( ) { - if (/^pub / && / $name /) { - /<([^>]*)>/; - push( @$listref, $1 ); - } - } - close( F ); - - return (@$listref >= 1) ? $listref->[0] : ""; -} + my $name = shift; + my $listref = shift; + + @$listref = (); + open( F, + "$conf::gpg --no-options --batch --no-default-keyring " + . "--always-trust --keyring " + . join( " --keyring ", @conf::keyrings ) + . " --list-keys |" + ) or return ""; + while () { + if ( /^pub / && / $name / ) { + /<([^>]*)>/; + push( @$listref, $1 ); + } + } ## end while () + close(F); + + return ( @$listref >= 1 ) ? $listref->[0] : ""; +} ## end sub try_to_get_mail_addr($$) # # return current time as string # sub format_time() { - my $t; + my $t; - # omit weekday and year for brevity - ($t = localtime) =~ /^\w+\s(.*)\s\d+$/; - return $1; -} + # omit weekday and year for brevity + ( $t = localtime ) =~ /^\w+\s(.*)\s\d+$/; + return $1; +} ## end sub format_time() sub print_time($) { - my $secs = shift; - my $hours = int($secs/(60*60)); + my $secs = shift; + my $hours = int( $secs / ( 60 * 60 ) ); - $secs -= $hours*60*60; - return sprintf "%d:%02d:%02d", $hours, int($secs/60), $secs % 60; -} + $secs -= $hours * 60 * 60; + return sprintf "%d:%02d:%02d", $hours, int( $secs / 60 ), $secs % 60; +} ## end sub print_time($) # # block some signals during queue processing -# +# # This is just to avoid data inconsistency or uploads being aborted in the # middle. Only "soft" signals are blocked, i.e. SIGINT and SIGTERM, try harder # ones if you really want to kill the daemon at once. # sub block_signals() { - POSIX::sigprocmask( SIG_BLOCK, $main::block_sigset ); + POSIX::sigprocmask( SIG_BLOCK, $main::block_sigset ); } sub unblock_signals() { - POSIX::sigprocmask( SIG_UNBLOCK, $main::block_sigset ); + POSIX::sigprocmask( SIG_UNBLOCK, $main::block_sigset ); } # # process SIGHUP: close log file and reopen it (for logfile cycling) # sub close_log($) { - close( LOG ); - close( STDOUT ); - close( STDERR ); - - open( LOG, ">>$conf::logfile" ) - or die "Cannot open my logfile $conf::logfile: $!\n"; - chmod( 0644, $conf::logfile ) - or msg( "log", "Cannot set modes of $conf::logfile: $!\n" ); - select( (select(LOG), $| = 1)[0] ); - - open( STDOUT, ">&LOG" ) - or msg( "log", "$main::progname: Can't redirect stdout to ". - "$conf::logfile: $!\n" ); - open( STDERR, ">&LOG" ) - or msg( "log", "$main::progname: Can't redirect stderr to ". - "$conf::logfile: $!\n" ); - msg( "log", "Restart after SIGHUP\n" ); -} + close(LOG); + close(STDOUT); + close(STDERR); + + open( LOG, ">>", $conf::logfile ) + or die "Cannot open my logfile $conf::logfile: $!\n"; + chmod( 0644, $conf::logfile ) + or msg( "log", "Cannot set modes of $conf::logfile: $!\n" ); + select( ( select(LOG), $| = 1 )[0] ); + + open( STDOUT, ">&", \*LOG ) + or msg( "log", + "$main::progname: Can't redirect stdout to " . "$conf::logfile: $!\n" ); + open( STDERR, ">&", \*LOG ) + or msg( "log", + "$main::progname: Can't redirect stderr to " . "$conf::logfile: $!\n" ); + msg( "log", "Restart after SIGHUP\n" ); +} ## end sub close_log($) # # process SIGCHLD: check if it was our statusd process # sub kid_died($) { - my $pid; - - # reap statusd, so that it's no zombie when we try to kill(0) it - waitpid( $main::statusd_pid, WNOHANG ); - -# Uncomment the following line if your Perl uses unreliable System V signal -# (i.e. if handlers reset to default if the signal is delivered). -# (Unfortunately, the re-setup can't be done in any case, since on some -# systems this will cause the SIGCHLD to be delivered again if there are -# still unreaped children :-(( ) - -# $SIG{"CHLD"} = \&kid_died; # resetup handler for SysV -} + my $pid; + + # reap statusd, so that it's no zombie when we try to kill(0) it + waitpid( $main::statusd_pid, WNOHANG ); + + # Uncomment the following line if your Perl uses unreliable System V signal + # (i.e. if handlers reset to default if the signal is delivered). + # (Unfortunately, the re-setup can't be done in any case, since on some + # systems this will cause the SIGCHLD to be delivered again if there are + # still unreaped children :-(( ) + + # $SIG{"CHLD"} = \&kid_died; # resetup handler for SysV +} ## end sub kid_died($) sub restart_statusd() { - # restart statusd if it died - if (!kill( 0, $main::statusd_pid)) { - close( STATUSD ); # close out pipe end - $main::statusd_pid = fork_statusd(); - } -} + + # restart statusd if it died + if ( !kill( 0, $main::statusd_pid ) ) { + close(STATUSD); # close out pipe end + $main::statusd_pid = fork_statusd(); + } +} ## end sub restart_statusd() # # process a fatal signal: cleanup and exit # sub fatal_signal($) { - my $signame = shift; - my $sig; - - # avoid recursions of fatal_signal in case of BSD signals - foreach $sig ( qw( ILL ABRT BUS FPE SEGV PIPE ) ) { - $SIG{$sig} = "DEFAULT"; - } - - if ($$ == $main::maind_pid) { - # only the main daemon should do this - kill( $main::signo{"TERM"}, $main::statusd_pid ) - if defined $main::statusd_pid; - unlink( $conf::statusfile, $conf::pidfile ); - } - msg( "log", "Caught SIG$signame -- exiting (pid $$)\n" ); - exit 1; -} - + my $signame = shift; + my $sig; + + # avoid recursions of fatal_signal in case of BSD signals + foreach $sig (qw( ILL ABRT BUS FPE SEGV PIPE )) { + $SIG{$sig} = "DEFAULT"; + } + + if ( $$ == $main::maind_pid ) { + + # only the main daemon should do this + kill( $main::signo{"TERM"}, $main::statusd_pid ) + if defined $main::statusd_pid; + unlink( $conf::statusfile, $conf::pidfile ); + } ## end if ( $$ == $main::maind_pid) + msg( "log", "Caught SIG$signame -- exiting (pid $$)\n" ); + exit 1; +} ## end sub fatal_signal($) # Local Variables: # tab-width: 4