tools/debianqueued-0.9/debianqueued

   1 #!/usr/bin/perl -w
   2 #
   3 # debianqueued -- daemon for managing Debian upload queues
   4 #
   5 # Copyright (C) 1997 Roman Hodek <Roman.Hodek@informatik.uni-erlangen.de>
   6 # Copyright (C) 2001-2007 Ryan Murray <rmurray@debian.org>
   7 # Copyright (C) 2008 Thomas Viehmann <tv@beamnet.de>
   8 #
   9 # This program is free software.  You can redistribute it and/or
  10 # modify it under the terms of the GNU General Public License as
  11 # published by the Free Software Foundation: either version 2 or
  12 # (at your option) any later version.
  13 # This program comes with ABSOLUTELY NO WARRANTY!
  14 #
  15
  16 require 5.002;
  17 no lib '.';
  18 use strict;
  19 use POSIX;
  20 use POSIX qw( strftime sys_stat_h sys_wait_h signal_h );
  21 use Net::Ping;
  22 use Net::FTP;
  23 use Socket qw( PF_INET AF_INET SOCK_STREAM );
  24 use Config;
  25 use Sys::Hostname;
  26 use File::Copy;
  27 use Digest::MD5;
  28
  29 setlocale(&POSIX::LC_ALL, "C");
  30
  31 # ---------------------------------------------------------------------------
  32 #                                                               configuration
  33 # ---------------------------------------------------------------------------
  34
  35 package conf;
  36 ( $conf::queued_dir = ( ( $0 !~ m,^/, ) ? POSIX::getcwd() . "/" : "" ) . $0 )
  37   =~ s,/[^/]+$,,;
  38 require "$conf::queued_dir/config";
  39 my $junk = $conf::debug;    # avoid spurious warnings about unused vars
  40 $junk = $conf::ssh_key_file;
  41 $junk = $conf::stray_remove_timeout;
  42 $junk = $conf::problem_report_timeout;
  43 $junk = $conf::queue_delay;
  44 $junk = $conf::keep_files;
  45 $junk = $conf::valid_files;
  46 $junk = $conf::max_upload_retries;
  47 $junk = $conf::upload_delay_1;
  48 $junk = $conf::upload_delay_2;
  49 $junk = $conf::check_md5sum;
  50
  51 #$junk = $conf::ls;
  52 $junk         = $conf::ftpdebug;
  53 $junk         = $conf::ftptimeout;
  54 $junk         = @conf::nonus_packages;
  55 $junk         = @conf::test_binaries;
  56 $junk         = @conf::maintainer_mail;
  57 $junk         = @conf::targetdir_delayed;
  58 $junk         = $conf::mail ||= '/usr/sbin/sendmail';
  59 $junk         = $conf::overridemail;
  60 $conf::target = "localhost" if $conf::upload_method eq "copy";
  61
  62 package main;
  63
  64 ( $main::progname = $0 ) =~ s,.*/,,;
  65
  66 ($main::hostname, undef, undef, undef, undef) = gethostbyname(hostname());
  67
  68 my %packages = ();
  69 my $re_file_safe_prefix = qr/\A([a-zA-Z0-9][a-zA-Z0-9_.:~+-]*)/s;
  70 my $re_file_safe = qr/$re_file_safe_prefix\z/s;
  71
  72 # extract -r and -k args
  73 $main::arg = "";
  74 if ( @ARGV == 1 && $ARGV[0] =~ /^-[rk]$/ ) {
  75   $main::arg = ( $ARGV[0] eq '-k' ) ? "kill" : "restart";
  76   shift @ARGV;
  77 }
  78
  79 # test for another instance of the queued already running
  80 my ( $pid, $delayed_dirs, $adelayedcore );
  81 if ( open( PIDFILE, "<", $conf::pidfile ) ) {
  82   chomp( $pid = <PIDFILE> );
  83   close(PIDFILE);
  84   if ( !$pid ) {
  85
  86     # remove stale pid file
  87     unlink($conf::pidfile);
  88   } elsif ($main::arg) {
  89     local ($|) = 1;
  90     print "Killing running daemon (pid $pid) ...";
  91     kill( 15, $pid );
  92     my $cnt = 20;
  93     while ( kill( 0, $pid ) && $cnt-- > 0 ) {
  94       sleep 1;
  95       print ".";
  96     }
  97     if ( kill( 0, $pid ) ) {
  98       print " failed!\nProcess $pid still running.\n";
  99       exit 1;
 100     }
 101     print "ok\n";
 102     if ( -e "$conf::incoming/core" ) {
 103       unlink("$conf::incoming/core");
 104       print "(Removed core file)\n";
 105     }
 106     for ( $delayed_dirs = 0 ;
 107           $delayed_dirs <= $conf::max_delayed ;
 108           $delayed_dirs++ )
 109     {
 110       $adelayedcore =
 111         sprintf( "$conf::incoming_delayed/core", $delayed_dirs );
 112       if ( -e $adelayedcore ) {
 113         unlink($adelayedcore);
 114         print "(Removed core file)\n";
 115       }
 116     } ## end for ( $delayed_dirs = 0...
 117     exit 0 if $main::arg eq "kill";
 118   } else {
 119     die "Another $main::progname is already running (pid $pid)\n"
 120       if $pid && kill( 0, $pid );
 121   }
 122 } elsif ( $main::arg eq "kill" ) {
 123   die "No daemon running\n";
 124 } elsif ( $main::arg eq "restart" ) {
 125   print "(No daemon running; starting anyway)\n";
 126 }
 127
 128 # if started without arguments (initial invocation), then fork
 129 if ( !@ARGV ) {
 130
 131   # now go to background
 132   die "$main::progname: fork failed: $!\n"
 133     unless defined( $pid = fork );
 134   if ($pid) {
 135
 136     # parent: wait for signal from child (SIGCHLD or SIGUSR1) and exit
 137     my $sigset = POSIX::SigSet->new();
 138     $sigset->emptyset();
 139     $SIG{"CHLD"} = sub { };
 140     $SIG{"USR1"} = sub { };
 141     POSIX::sigsuspend($sigset);
 142     waitpid( $pid, WNOHANG );
 143     if ( kill( 0, $pid ) ) {
 144       print "Daemon (on $main::hostname) started in background (pid $pid)\n";
 145       exit 0;
 146     } else {
 147       exit 1;
 148     }
 149   } else {
 150
 151     # child
 152     setsid;
 153     if ( $conf::upload_method eq "ssh" ) {
 154
 155       # exec an ssh-agent that starts us again
 156       # force shell to be /bin/sh, ssh-agent may base its decision
 157       # whether to use a fd or a Unix socket on the shell...
 158       $ENV{"SHELL"} = "/bin/sh";
 159       exec $conf::ssh_agent, $0, "startup", getppid();
 160       die "$main::progname: Could not exec $conf::ssh_agent: $!\n";
 161     } else {
 162
 163       # no need to exec, just set up @ARGV as expected below
 164       @ARGV = ( "startup", getppid() );
 165     }
 166   } ## end else [ if ($pid)
 167 } ## end if ( !@ARGV )
 168 die "Please start without any arguments.\n"
 169   if @ARGV != 2 || $ARGV[0] ne "startup";
 170 my $parent_pid = $ARGV[1];
 171
 172 do {
 173   my $version;
 174   ( $version = 'Release: 0.95' ) =~ s/\$ ?//g;
 175   print "debianqueued $version\n";
 176 };
 177
 178 # check if all programs exist
 179 my $prg;
 180 foreach $prg ( $conf::gpg, $conf::ssh, $conf::scp, $conf::ssh_agent,
 181                $conf::ssh_add, $conf::mail, $conf::mkfifo )
 182 {
 183   die "Required program $prg doesn't exist or isn't executable\n"
 184     if !-x $prg;
 185
 186   # check for correct upload method
 187   die "Bad upload method '$conf::upload_method'.\n"
 188     if $conf::upload_method ne "ssh"
 189       && $conf::upload_method ne "ftp"
 190       && $conf::upload_method ne "copy";
 191   die "No keyrings\n" if !@conf::keyrings;
 192
 193 } ## end foreach $prg ( $conf::gpg, ...
 194 die "statusfile path must be absolute."
 195   if $conf::statusfile !~ m,^/,;
 196 die "upload and target queue paths must be absolute."
 197   if $conf::incoming !~ m,^/,
 198     || $conf::incoming_delayed !~ m,^/,
 199     || $conf::targetdir !~ m,^/,
 200     || $conf::targetdir_delayed !~ m,^/,;
 201
 202 # ---------------------------------------------------------------------------
 203 #                                                          initializations
 204 # ---------------------------------------------------------------------------
 205
 206 # prototypes
 207 sub calc_delta();
 208 sub check_dir();
 209 sub get_filelist_from_known_good_changes($);
 210 sub age_delayed_queues();
 211 sub process_changes($\@);
 212 sub process_commands($);
 213 sub age_delayed_queues();
 214 sub is_on_target($\@);
 215 sub copy_to_target(@);
 216 sub pgp_check($);
 217 sub check_alive(;$);
 218 sub check_incoming_writable();
 219 sub fork_statusd();
 220 sub write_status_file();
 221 sub print_status($$$$$$);
 222 sub format_status_num(\$$);
 223 sub format_status_str(\$$);
 224 sub send_status();
 225 sub ftp_open();
 226 sub ftp_cmd($@);
 227 sub ftp_close();
 228 sub ftp_response();
 229 sub ftp_code();
 230 sub ftp_error();
 231 sub ssh_cmd($);
 232 sub scp_cmd(@);
 233 sub check_alive(;$);
 234 sub check_incoming_writable();
 235 sub rm(@);
 236 sub md5sum($);
 237 sub msg($@);
 238 sub debug(@);
 239 sub init_mail(;$);
 240 sub finish_mail();
 241 sub send_mail($$$);
 242 sub try_to_get_mail_addr($$);
 243 sub format_time();
 244 sub print_time($);
 245 sub block_signals();
 246 sub unblock_signals();
 247 sub close_log($);
 248 sub kid_died($);
 249 sub restart_statusd();
 250 sub fatal_signal($);
 251
 252 $ENV{"PATH"} = "/bin:/usr/bin";
 253 $ENV{"IFS"} = "" if defined( $ENV{"IFS"} && $ENV{"IFS"} ne "" );
 254
 255 # constants for stat
 256 sub ST_DEV()   { 0 }
 257 sub ST_INO()   { 1 }
 258 sub ST_MODE()  { 2 }
 259 sub ST_NLINK() { 3 }
 260 sub ST_UID()   { 4 }
 261 sub ST_GID()   { 5 }
 262 sub ST_RDEV()  { 6 }
 263 sub ST_SIZE()  { 7 }
 264 sub ST_ATIME() { 8 }
 265 sub ST_MTIME() { 9 }
 266 sub ST_CTIME() { 10 }
 267
 268 # fixed lengths of data items passed over status pipe
 269 sub STATNUM_LEN() { 30 }
 270 sub STATSTR_LEN() { 128 }
 271
 272 # init list of signals
 273 defined $Config{sig_name}
 274   or die "$main::progname: No signal list defined!\n";
 275 my $i = 0;
 276 my $name;
 277 foreach $name ( split( ' ', $Config{sig_name} ) ) {
 278   $main::signo{$name} = $i++;
 279 }
 280
 281 @main::fatal_signals = qw( INT QUIT ILL TRAP ABRT BUS FPE USR2 SEGV PIPE
 282   TERM XCPU XFSZ PWR );
 283
 284 $main::block_sigset = POSIX::SigSet->new;
 285 $main::block_sigset->addset( $main::signo{"INT"} );
 286 $main::block_sigset->addset( $main::signo{"TERM"} );
 287
 288 # some constant net stuff
 289 $main::tcp_proto = ( getprotobyname('tcp') )[2]
 290   or die "Cannot get protocol number for 'tcp'\n";
 291 my $used_service = ( $conf::upload_method eq "ssh" ) ? "ssh" : "ftp";
 292 $main::echo_port = ( getservbyname( $used_service, 'tcp' ) )[2]
 293   or die "Cannot get port number for service '$used_service'\n";
 294
 295 # clear queue of stored mails
 296 @main::stored_mails = ();
 297
 298 # run ssh-add to bring the key into the agent (will use stdin/stdout)
 299 if ( $conf::upload_method eq "ssh" ) {
 300   system "$conf::ssh_add $conf::ssh_key_file"
 301     and die "$main::progname: Running $conf::ssh_add failed "
 302     . "(exit status ", $? >> 8, ")\n";
 303 }
 304
 305 # change to queue dir
 306 chdir($conf::incoming)
 307   or die "$main::progname: cannot cd to $conf::incoming: $!\n";
 308
 309 # needed before /dev/null redirects, some system send a SIGHUP when loosing
 310 # the controlling tty
 311 $SIG{"HUP"} = "IGNORE";
 312
 313 # open logfile, make it unbuffered
 314 open( LOG, ">>", $conf::logfile )
 315   or die "Cannot open my logfile $conf::logfile: $!\n";
 316 chmod( 0644, $conf::logfile )
 317   or die "Cannot set modes of $conf::logfile: $!\n";
 318 select( ( select(LOG), $| = 1 )[0] );
 319
 320 sleep(1);
 321 $SIG{"HUP"} = \&close_log;
 322
 323 # redirect stdin, ... to /dev/null
 324 open( STDIN, "<", "/dev/null" )
 325   or die "$main::progname: Can't redirect stdin to /dev/null: $!\n";
 326 open( STDOUT, ">&", \*LOG )
 327   or die "$main::progname: Can't redirect stdout to $conf::logfile: $!\n";
 328 open( STDERR, ">&", \*LOG )
 329   or die "$main::progname: Can't redirect stderr to $conf::logfile: $!\n";
 330
 331 # ok, from this point usually no "die" anymore, stderr is gone!
 332 msg( "log", "daemon (pid $$) (on $main::hostname) started\n" );
 333
 334 # initialize variables used by send_status before launching the status daemon
 335 $main::dstat = "i";
 336 format_status_num( $main::next_run, time + 10 );
 337 format_status_str( $main::current_changes, "" );
 338 check_alive();
 339 $main::incoming_writable = 1;    # assume this for now
 340
 341 # start the daemon watching the 'status' FIFO
 342 if ( $conf::statusfile && $conf::statusdelay == 0 ) {
 343   $main::statusd_pid = fork_statusd();
 344   $SIG{"CHLD"}       = \&kid_died;       # watch out for dead status daemon
 345                                          # SIGUSR1 triggers status info
 346   $SIG{"USR1"}       = \&send_status;
 347 } ## end if ( $conf::statusfile...
 348 $main::maind_pid = $$;
 349
 350 END {
 351   kill( $main::signo{"ABRT"}, $$ )
 352     if defined $main::signo{"ABRT"};
 353 }
 354
 355 # write the pid file
 356 open( PIDFILE, ">", $conf::pidfile )
 357   or msg( "log", "Can't open $conf::pidfile: $!\n" );
 358 printf PIDFILE "%5d\n", $$;
 359 close(PIDFILE);
 360 chmod( 0644, $conf::pidfile )
 361   or die "Cannot set modes of $conf::pidfile: $!\n";
 362
 363 # other signals will just log an error and exit
 364 foreach (@main::fatal_signals) {
 365   $SIG{$_} = \&fatal_signal;
 366 }
 367
 368 # send signal to user-started process that we're ready and it can exit
 369 kill( $main::signo{"USR1"}, $parent_pid );
 370
 371 # ---------------------------------------------------------------------------
 372 #                                                                the mainloop
 373 # ---------------------------------------------------------------------------
 374
 375 # default to classical incoming/target
 376 $main::current_incoming  = $conf::incoming;
 377 $main::current_targetdir = $conf::targetdir;
 378
 379 $main::dstat = "i";
 380 write_status_file() if $conf::statusdelay;
 381 while (1) {
 382
 383   # ping target only if there is the possibility that we'll contact it (but
 384   # also don't wait too long).
 385   my @have_changes = <*.changes *.commands *.dak-commands>;
 386   for ( my $delayed_dirs = 0 ;
 387         $delayed_dirs <= $conf::max_delayed ;
 388         $delayed_dirs++ )
 389   {
 390     my $adelayeddir = sprintf( "$conf::incoming_delayed", $delayed_dirs );
 391     push( @have_changes, <$adelayeddir/*.changes> );
 392   } ## end for ( my $delayed_dirs ...
 393   check_alive()
 394     if @have_changes || ( time - $main::last_ping_time ) > 8 * 60 * 60;
 395
 396   if ( @have_changes && $main::target_up ) {
 397     check_incoming_writable if !$main::incoming_writable;
 398     check_dir() if $main::incoming_writable;
 399   }
 400   $main::dstat = "i";
 401   write_status_file() if $conf::statusdelay;
 402
 403   if ( $conf::upload_method eq "copy" ) {
 404     age_delayed_queues();
 405   }
 406
 407   # sleep() returns if we received a signal (SIGUSR1 for status FIFO), so
 408   # calculate the end time once and wait for it being reached.
 409   format_status_num( $main::next_run, time + $conf::queue_delay );
 410   my $delta;
 411   while ( ( $delta = calc_delta() ) > 0 ) {
 412     debug("mainloop sleeping $delta secs");
 413     sleep($delta);
 414
 415     # check if statusd died, if using status FIFO, or update status file
 416     if ($conf::statusdelay) {
 417       write_status_file();
 418     } else {
 419       restart_statusd();
 420     }
 421   } ## end while ( ( $delta = calc_delta...
 422 } ## end while (1)
 423
 424 sub calc_delta() {
 425   my $delta;
 426
 427   $delta = $main::next_run - time;
 428   $delta = $conf::statusdelay
 429     if $conf::statusdelay && $conf::statusdelay < $delta;
 430   return $delta;
 431 } ## end sub calc_delta()
 432
 433 # ---------------------------------------------------------------------------
 434 #                                                       main working functions
 435 # ---------------------------------------------------------------------------
 436
 437 #
 438 # main function for checking the incoming dir
 439 #
 440 sub check_dir() {
 441   my ( @files, @changes, @keep_files, @this_keep_files, @stats, $file,
 442        $adelay );
 443
 444   debug("starting checkdir");
 445   $main::dstat = "c";
 446   write_status_file() if $conf::statusdelay;
 447
 448   # test if needed binaries are available; this is if they're on maybe
 449   # slow-mounted NFS filesystems
 450   foreach (@conf::test_binaries) {
 451     next if -f $_;
 452
 453     # maybe the mount succeeds now
 454     sleep 5;
 455     next if -f $_;
 456     msg( "log", "binary test failed for $_; delaying queue run\n" );
 457     goto end_run;
 458   } ## end foreach (@conf::test_binaries)
 459
 460   for ( $adelay = -1 ; $adelay <= $conf::max_delayed ; $adelay++ ) {
 461     if ( $adelay == -1 ) {
 462       $main::current_incoming       = $conf::incoming;
 463       $main::current_incoming_short = "";
 464       $main::current_targetdir      = $conf::targetdir;
 465     } else {
 466       $main::current_incoming = sprintf( $conf::incoming_delayed, $adelay );
 467       $main::current_incoming_short = sprintf( "DELAYED/%d-day", $adelay );
 468       $main::current_targetdir = sprintf( $conf::targetdir_delayed, $adelay );
 469     }
 470
 471     # need to clear directory specific variables
 472     undef(@keep_files);
 473     undef(@this_keep_files);
 474
 475     chdir($main::current_incoming)
 476       or (
 477            msg(
 478                 "log",
 479                 "Cannot change to dir "
 480                   . "${main::current_incoming_short}: $!\n"
 481               ),
 482            return
 483          );
 484
 485     # look for *.commands and *.dak-commands files but not in delayed queues
 486     if ( $adelay == -1 ) {
 487       foreach $file (<*.commands>) {
 488         next unless $file =~ /$re_file_safe/;
 489         init_mail($file);
 490         block_signals();
 491         process_commands($file);
 492         unblock_signals();
 493         $main::dstat = "c";
 494         write_status_file() if $conf::statusdelay;
 495         finish_mail();
 496       } ## end foreach $file (<*.commands>)
 497           foreach $file (<*.dak-commands>) {
 498                 next unless $file =~ /$re_file_safe/;
 499                 init_mail($file);
 500                 block_signals();
 501                 process_dak_commands($file);
 502                 unblock_signals();
 503                 $main::dstat = "c";
 504                 write_status_file() if $conf::statusdelay;
 505                 finish_mail();
 506           }
 507     } ## end if ( $adelay == -1 )
 508     opendir( INC, "." )
 509       or (
 510            msg(
 511                 "log", "Cannot open dir ${main::current_incoming_short}: $!\n"
 512               ),
 513            return
 514          );
 515     @files = readdir(INC);
 516     closedir(INC);
 517
 518     # process all .changes files found
 519     @changes = grep /\.changes$/, @files;
 520     push( @keep_files, @changes );    # .changes files aren't stray
 521     foreach $file (@changes) {
 522       next unless $file =~ /$re_file_safe/;
 523       init_mail($file);
 524
 525       # wrap in an eval to allow jumpbacks to here with die in case
 526       # of errors
 527       block_signals();
 528       eval { process_changes( $file, @this_keep_files ); };
 529       unblock_signals();
 530       msg( "log,mail", $@ ) if $@;
 531       $main::dstat = "c";
 532       write_status_file() if $conf::statusdelay;
 533
 534       # files which are ok in conjunction with this .changes
 535       debug("$file tells to keep @this_keep_files");
 536       push( @keep_files, @this_keep_files );
 537       finish_mail();
 538
 539       # break out of this loop if the incoming dir has become unwritable
 540       goto end_run if !$main::incoming_writable;
 541     } ## end foreach $file (@changes)
 542     ftp_close() if $conf::upload_method eq "ftp";
 543
 544     # find files which aren't related to any .changes
 545     foreach $file (@files) {
 546
 547       # filter out files we never want to delete
 548       next if !-f $file ||    # may have disappeared in the meantime
 549              $file eq "."
 550           || $file eq ".."
 551           || ( grep { $_ eq $file } @keep_files )
 552           || $file =~ /$conf::keep_files/;
 553
 554       # Delete such files if they're older than
 555       # $stray_remove_timeout; they could be part of an
 556       # yet-incomplete upload, with the .changes still missing.
 557       # Cannot send any notification, since owner unknown.
 558       next if !( @stats = stat($file) );
 559       my $age = time - $stats[ST_MTIME];
 560       my ( $maint, $pattern, @job_files );
 561       if (    $file =~ /^junk-for-writable-test/
 562            || $file !~ m,$conf::valid_files,
 563            || $file !~ /$re_file_safe/
 564            || $age >= $conf::stray_remove_timeout )
 565       {
 566         msg( "log",
 567              "Deleted stray file ${main::current_incoming_short}/$file\n" )
 568           if rm($file);
 569       } else {
 570         debug(
 571 "found stray file ${main::current_incoming_short}/$file, deleting in ",
 572           print_time( $conf::stray_remove_timeout - $age )
 573         );
 574       } ## end else [ if ( $file =~ /^junk-for-writable-test/...
 575     } ## end foreach $file (@files)
 576   } ## end for ( $adelay = -1 ; $adelay...
 577   chdir($conf::incoming);
 578
 579 end_run:
 580   $main::dstat = "i";
 581   write_status_file() if $conf::statusdelay;
 582 } ## end sub check_dir()
 583
 584 sub get_filelist_from_known_good_changes($) {
 585   my $changes = shift;
 586
 587   local (*CHANGES);
 588   my (@filenames);
 589
 590   # parse the .changes file
 591   open( CHANGES, "<", $changes )
 592     or die "$changes: $!\n";
 593 outer_loop: while (<CHANGES>) {
 594     if (/^Files:/i) {
 595       while (<CHANGES>) {
 596         redo outer_loop if !/^\s/;
 597         my @field = split(/\s+/);
 598         next if @field != 6;
 599
 600         # forbid shell meta chars in the name, we pass it to a
 601         # subshell several times...
 602         $field[5] =~ /$re_file_safe/;
 603         if ( $1 ne $field[5] ) {
 604           msg( "log", "found suspicious filename $field[5]\n" );
 605           next;
 606         }
 607         push( @filenames, $field[5] );
 608       } ## end while (<CHANGES>)
 609     } ## end if (/^Files:/i)
 610   } ## end while (<CHANGES>)
 611   close(CHANGES);
 612   return @filenames;
 613 } ## end sub get_filelist_from_known_good_changes($)
 614
 615 #
 616 # process one .changes file
 617 #
 618 sub process_changes($\@) {
 619   my $changes   = shift;
 620   my $keep_list = shift;
 621   my (
 622        $pgplines,     @files,     @filenames,  @changes_stats,
 623        $failure_file, $retries,   $last_retry, $upload_time,
 624        $file,         $do_report, $ls_l,       $problems_reported,
 625        $errs,         $pkgname,   $signator,   $extralines
 626      );
 627   local (*CHANGES);
 628   local (*FAILS);
 629
 630   format_status_str( $main::current_changes,
 631                      "$main::current_incoming_short/$changes" );
 632   $main::dstat = "c";
 633   $main::mail_addr = "";
 634   write_status_file() if $conf::statusdelay;
 635
 636   @$keep_list = ();
 637   msg( "log", "processing ${main::current_incoming_short}/$changes\n" );
 638
 639   # run PGP on the file to check the signature
 640   if ( !( $signator = pgp_check($changes) ) ) {
 641     msg(
 642        "log,mail",
 643        "$main::current_incoming_short/$changes has bad PGP/GnuPG signature!\n"
 644     );
 645     goto remove_only_changes;
 646   } elsif ( $signator eq "LOCAL ERROR" ) {
 647
 648     # An error has appened when starting pgp... Don't process the file,
 649     # but also don't delete it
 650     debug(
 651 "Can't PGP/GnuPG check $main::current_incoming_short/$changes -- don't process it for now"
 652     );
 653     return;
 654   } ## end elsif ( $signator eq "LOCAL ERROR")
 655
 656   # parse the .changes file
 657   open( CHANGES, "<", $changes )
 658     or die "Cannot open ${main::current_incoming_short}/$changes: $!\n";
 659   $pgplines        = 0;
 660   $extralines      = 0;
 661   @files           = ();
 662 outer_loop: while (<CHANGES>) {
 663     if (/^---+(BEGIN|END) PGP .*---+$/) {
 664       ++$pgplines;
 665       next;
 666     }
 667     if ( $pgplines < 1 or $pgplines >= 3 ) {
 668       $extralines++ if length $_ > 1;
 669       next;
 670     }
 671     if (/^Maintainer:\s*/i) {
 672       chomp( $main::mail_addr = $' );
 673       $main::mail_addr = $1 if $main::mail_addr =~ /<([^>]*)>/;
 674     } elsif (/^Source:\s*/i) {
 675       chomp( $pkgname = $' );
 676       $pkgname =~ s/\s+$//;
 677       $main::packages{$pkgname}++;
 678     } elsif (/^Files:/i) {
 679       while (<CHANGES>) {
 680         redo outer_loop if !/^\s/;
 681         my @field = split(/\s+/);
 682         next if @field != 6;
 683
 684         # forbid shell meta chars in the name, we pass it to a
 685         # subshell several times...
 686         $field[5] =~ /$re_file_safe/;
 687         if ( $1 ne $field[5] ) {
 688           msg( "log", "found suspicious filename $field[5]\n" );
 689           msg(
 690             "mail",
 691 "File '$field[5]' mentioned in $main::current_incoming_short/$changes\n",
 692             "has bad characters in its name. Removed.\n"
 693           );
 694           rm( $field[5] );
 695           next;
 696         } ## end if ( $1 ne $field[5] )
 697         push(
 698               @files,
 699               {
 700                 md5  => $field[1],
 701                 size => $field[2],
 702                 name => $field[5]
 703               }
 704             );
 705         push( @filenames, $field[5] );
 706         debug( "includes file $field[5], size $field[2], ", "md5 $field[1]" );
 707       } ## end while (<CHANGES>)
 708     } ## end elsif (/^Files:/i)
 709   } ## end while (<CHANGES>)
 710   close(CHANGES);
 711
 712   # tell check_dir that the files mentioned in this .changes aren't stray,
 713   # we know about them somehow
 714   @$keep_list = @filenames;
 715
 716   # some consistency checks
 717   if ( $extralines ) {
 718     msg( "log,mail",
 719 "$main::current_incoming_short/$changes contained lines outside the pgp signed "
 720 ."part, cannot process\n" );
 721     goto remove_only_changes;
 722   } ## end if ( $extralines )
 723   if ( !$main::mail_addr ) {
 724     msg( "log,mail",
 725 "$main::current_incoming_short/$changes doesn't contain a Maintainer: field; "
 726         . "cannot process\n" );
 727     goto remove_only_changes;
 728   } ## end if ( !$main::mail_addr)
 729   if ( $main::mail_addr !~ /^(buildd_\S+-\S+|\S+\@\S+\.\S+)/ ) {
 730
 731     # doesn't look like a mail address, maybe only the name
 732     my ( $new_addr, @addr_list );
 733     if ( $new_addr = try_to_get_mail_addr( $main::mail_addr, \@addr_list ) ) {
 734
 735       # substitute (unique) found addr, but give a warning
 736       msg(
 737            "mail",
 738            "(The Maintainer: field didn't contain a proper "
 739              . "mail address.\n"
 740          );
 741       msg(
 742            "mail",
 743            "Looking for `$main::mail_addr' in the Debian "
 744              . "keyring gave your address\n"
 745          );
 746       msg( "mail", "as unique result, so I used this.)\n" );
 747       msg( "log",
 748            "Substituted $new_addr for malformed " . "$main::mail_addr\n" );
 749       $main::mail_addr = $new_addr;
 750     } else {
 751
 752       # not found or not unique: hold the job and inform queue maintainer
 753       my $old_addr = $main::mail_addr;
 754       $main::mail_addr = $conf::maintainer_mail;
 755       msg(
 756         "mail",
 757 "The job ${main::current_incoming_short}/$changes doesn't have a correct email\n"
 758       );
 759       msg( "mail", "address in the Maintainer: field:\n" );
 760       msg( "mail", "  $old_addr\n" );
 761       msg( "mail", "A check for this in the Debian keyring gave:\n" );
 762       msg( "mail",
 763            @addr_list
 764            ? "  " . join( ", ", @addr_list ) . "\n"
 765            : "  nothing\n" );
 766       msg( "mail", "Please fix this manually\n" );
 767       msg(
 768         "log",
 769 "Bad Maintainer: field in ${main::current_incoming_short}/$changes: $old_addr\n"
 770       );
 771       goto remove_only_changes;
 772     } ## end else [ if ( $new_addr = try_to_get_mail_addr...
 773   } ## end if ( $main::mail_addr ...
 774   if ( $pgplines < 3 ) {
 775     msg(
 776         "log,mail",
 777         "$main::current_incoming_short/$changes isn't signed with PGP/GnuPG\n"
 778        );
 779     msg( "log", "(uploader $main::mail_addr)\n" );
 780     goto remove_only_changes;
 781   } ## end if ( $pgplines < 3 )
 782   if ( !@files ) {
 783     msg( "log,mail",
 784        "$main::current_incoming_short/$changes doesn't mention any files\n" );
 785     msg( "log", "(uploader $main::mail_addr)\n" );
 786     goto remove_only_changes;
 787   } ## end if ( !@files )
 788
 789   # check for packages that shouldn't be processed
 790   if ( grep( $_ eq $pkgname, @conf::nonus_packages ) ) {
 791     msg(
 792          "log,mail",
 793          "$pkgname is a package that must be uploaded "
 794            . "to nonus.debian.org\n"
 795        );
 796     msg( "log,mail", "instead of target.\n" );
 797     msg( "log,mail",
 798          "Job rejected and removed all files belonging " . "to it:\n" );
 799     msg( "log,mail", "  ", join( ", ", @filenames ), "\n" );
 800     rm( $changes, @filenames );
 801     return;
 802   } ## end if ( grep( $_ eq $pkgname...
 803
 804   $failure_file = $changes . ".failures";
 805   $retries = $last_retry = 0;
 806   if ( -f $failure_file ) {
 807     open( FAILS, "<", $failure_file )
 808       or die "Cannot open $main::current_incoming_short/$failure_file: $!\n";
 809     my $line = <FAILS>;
 810     close(FAILS);
 811     ( $retries, $last_retry ) = ( $1, $2 )
 812       if $line =~ /^(\d+)\s+(\d+)$/;
 813     push( @$keep_list, $failure_file );
 814   } ## end if ( -f $failure_file )
 815
 816   die "Cannot stat ${main::current_incoming_short}/$changes (??): $!\n"
 817     if !( @changes_stats = stat($changes) );
 818
 819   # Make $upload_time the maximum of all modification times of files
 820   # related to this .changes (and the .changes it self). This is the
 821   # last time something changes to these files.
 822   $upload_time = $changes_stats[ST_MTIME];
 823   for $file (@files) {
 824     my @stats;
 825     next if !( @stats = stat( $file->{"name"} ) );
 826     $file->{"stats"} = \@stats;
 827     $upload_time = $stats[ST_MTIME] if $stats[ST_MTIME] > $upload_time;
 828   } ## end for $file (@files)
 829
 830   $do_report = ( time - $upload_time ) > $conf::problem_report_timeout;
 831   $problems_reported = $changes_stats[ST_MODE] & S_ISGID;
 832
 833   # if any of the files is newer than the .changes' ctime (the time
 834   # we sent a report and set the sticky bit), send new problem reports
 835   if ( $problems_reported && $changes_stats[ST_CTIME] < $upload_time ) {
 836     $problems_reported = 0;
 837     chmod +( $changes_stats[ST_MODE] &= ~S_ISGID ), $changes;
 838     debug("upload_time>changes-ctime => resetting problems reported");
 839   }
 840   debug("do_report=$do_report problems_reported=$problems_reported");
 841
 842   # now check all files for correct size and md5 sum
 843   for $file (@files) {
 844     my $filename = $file->{"name"};
 845     if ( !defined( $file->{"stats"} ) ) {
 846
 847       # could be an upload that isn't complete yet, be quiet,
 848       # but don't process the file;
 849       msg( "log,mail", "$filename doesn't exist\n" )
 850         if $do_report && !$problems_reported;
 851       msg( "log", "$filename doesn't exist (ignored for now)\n" )
 852         if !$do_report;
 853       msg( "log", "$filename doesn't exist (already reported)\n" )
 854         if $problems_reported;
 855       ++$errs;
 856     } elsif ( $file->{"stats"}->[ST_SIZE] < $file->{"size"}
 857               && !$do_report )
 858     {
 859
 860       # could be an upload that isn't complete yet, be quiet,
 861       # but don't process the file
 862       msg( "log", "$filename is too small (ignored for now)\n" );
 863       ++$errs;
 864     } elsif ( $file->{"stats"}->[ST_SIZE] != $file->{"size"} ) {
 865       msg( "log,mail", "$filename has incorrect size; deleting it\n" );
 866       rm($filename);
 867       ++$errs;
 868     } elsif ( md5sum($filename) ne $file->{"md5"} ) {
 869       msg( "log,mail",
 870            "$filename has incorrect md5 checksum; ",
 871            "deleting it\n" );
 872       rm($filename);
 873       ++$errs;
 874     } ## end elsif ( md5sum($filename)...
 875   } ## end for $file (@files)
 876
 877   if ($errs) {
 878     if ( ( time - $upload_time ) > $conf::bad_changes_timeout ) {
 879
 880       # if a .changes fails for a really long time (several days
 881       # or so), remove it and all associated files
 882       msg(
 883           "log,mail",
 884           "$main::current_incoming_short/$changes couldn't be processed for ",
 885           int( $conf::bad_changes_timeout / ( 60 * 60 ) ),
 886           " hours and is now deleted\n"
 887          );
 888       msg( "log,mail", "All files it mentions are also removed:\n" );
 889       msg( "log,mail", "  ", join( ", ", @filenames ), "\n" );
 890       rm( $changes, @filenames, $failure_file );
 891     } elsif ( $do_report && !$problems_reported ) {
 892
 893       # otherwise, send a problem report, if not done already
 894       msg(
 895            "mail",
 896            "Due to the errors above, the .changes file couldn't ",
 897            "be processed.\n",
 898            "Please fix the problems for the upload to happen.\n"
 899          );
 900
 901       # remember we already have sent a mail regarding this file
 902       debug("Sending problem report mail and setting SGID bit");
 903       my $mode = $changes_stats[ST_MODE] |= S_ISGID;
 904       msg( "log", "chmod failed: $!" )
 905         if ( chmod( $mode, $changes ) != 1 );
 906     } ## end elsif ( $do_report && !$problems_reported)
 907
 908     # else: be quiet
 909
 910     return;
 911   } ## end if ($errs)
 912
 913   # if this upload already failed earlier, wait until the delay requirement
 914   # is fulfilled
 915   if ( $retries > 0
 916        && ( time - $last_retry ) <
 917        ( $retries == 1 ? $conf::upload_delay_1 : $conf::upload_delay_2 ) )
 918   {
 919     msg( "log", "delaying retry of upload\n" );
 920     return;
 921   } ## end if ( $retries > 0 && (...
 922
 923   return if !ftp_open();
 924
 925   # check if the job is already present on target
 926   # (moved to here, to avoid bothering target as long as there are errors in
 927   # the job)
 928   if ( $ls_l = is_on_target( $changes, @filenames ) ) {
 929     msg(
 930       "log,mail",
 931 "$main::current_incoming_short/$changes is already present on target host:\n"
 932     );
 933     msg( "log,mail", "$ls_l\n" );
 934     msg( "mail",
 935          "Either you already uploaded it, or someone else ",
 936          "came first.\n" );
 937     msg( "log,mail", "Job $changes removed.\n" );
 938     rm( $changes, @filenames, $failure_file );
 939     return;
 940   } ## end if ( $ls_l = is_on_target...
 941
 942   # clear sgid bit before upload, scp would copy it to target. We don't need
 943   # it anymore, we know there are no problems if we come here. Also change
 944   # mode of files to 644 if this should be done locally.
 945   $changes_stats[ST_MODE] &= ~S_ISGID;
 946   if ( !$conf::chmod_on_target ) {
 947     $changes_stats[ST_MODE] &= ~0777;
 948     $changes_stats[ST_MODE] |= 0644;
 949   }
 950   chmod +( $changes_stats[ST_MODE] ), $changes;
 951
 952   # try uploading to target
 953   if ( !copy_to_target( $changes, @filenames ) ) {
 954
 955     # if the upload failed, increment the retry counter and remember the
 956     # current time; both things are written to the .failures file. Don't
 957     # increment the fail counter if the error was due to incoming
 958     # unwritable.
 959     return if !$main::incoming_writable;
 960     if ( ++$retries >= $conf::max_upload_retries ) {
 961       msg( "log,mail",
 962            "$changes couldn't be uploaded for $retries times now.\n" );
 963       msg( "log,mail",
 964            "Giving up and removing it and its associated files:\n" );
 965       msg( "log,mail", "  ", join( ", ", @filenames ), "\n" );
 966       rm( $changes, @filenames, $failure_file );
 967     } else {
 968       $last_retry = time;
 969       if ( open( FAILS, ">", $failure_file ) ) {
 970         print FAILS "$retries $last_retry\n";
 971         close(FAILS);
 972         chmod( 0600, $failure_file )
 973           or die "Cannot set modes of $failure_file: $!\n";
 974       } ## end if ( open( FAILS, ">$failure_file"...
 975       push( @$keep_list, $failure_file );
 976       debug("now $retries failed uploads");
 977       msg(
 978            "mail",
 979            "The upload will be retried in ",
 980            print_time(
 981                          $retries == 1
 982                        ? $conf::upload_delay_1
 983                        : $conf::upload_delay_2
 984                      ),
 985            "\n"
 986          );
 987     } ## end else [ if ( ++$retries >= $conf::max_upload_retries)
 988     return;
 989   } ## end if ( !copy_to_target( ...
 990
 991   # If the files were uploaded ok, remove them
 992   rm( $changes, @filenames, $failure_file );
 993
 994   msg( "mail", "$changes uploaded successfully to $conf::target\n" );
 995   msg( "mail", "along with the files:\n  ", join( "\n  ", @filenames ),
 996        "\n" );
 997   msg( "log",
 998        "$changes processed successfully (uploader $main::mail_addr)\n" );
 999
1000   return;
1001
1002   remove_only_changes:
1003   msg(
1004     "log,mail",
1005     "Removing $main::current_incoming_short/$changes, but keeping its "
1006     . "associated files for now.\n"
1007     );
1008   rm($changes);
1009   return;
1010
1011   # Check for files that have the same stem as the .changes (and weren't
1012   # mentioned there) and delete them. It happens often enough that people
1013   # upload a .orig.tar.gz where it isn't needed and also not in the
1014   # .changes. Explicitly deleting it (and not waiting for the
1015   # $stray_remove_timeout) reduces clutter in the queue dir and maybe also
1016   # educates uploaders :-)
1017
1018   #     my $pattern = debian_file_stem( $changes );
1019   #     my $spattern = substr( $pattern, 0, -1 ); # strip off '*' at end
1020   #     my @other_files = glob($pattern);
1021   # filter out files that have a Debian revision at all and a different
1022   # revision. Those belong to a different upload.
1023   #     if ($changes =~ /^\Q$spattern\E-([\d.+-]+)/) {
1024   #             my $this_rev = $1;
1025   #             @other_files = grep( !/^\Q$spattern\E-([\d.+-]+)/ || $1 eq $this_rev,
1026   #                                                      @other_files);
1027   #}
1028   # Also do not remove those files if a .changes is among them. Then there
1029   # is probably a second upload for another version or another architecture.
1030   #     if (@other_files && !grep( /\.changes$/, @other_files )) {
1031   #             rm( @other_files );
1032   #             msg( "mail", "\nThe following file(s) seemed to belong to the same ".
1033   #                                      "upload, but weren't listed\n" );
1034   #             msg( "mail", "in the .changes file:\n  " );
1035   #             msg( "mail", join( "\n  ", @other_files ), "\n" );
1036   #             msg( "mail", "They have been deleted.\n" );
1037   #             msg( "log", "Deleted files in upload not in $changes: @other_files\n" );
1038   #}
1039 } ## end sub process_changes($\@)
1040
1041 #
1042 # process one .dak-commands file
1043 #
1044 sub process_dak_commands {
1045   my $commands = shift;
1046
1047   msg("log", "processing ${main::current_incoming_short}/$commands\n");
1048
1049   # TODO: get mail address from signed contents
1050   # and NOT implement a third parser for armored PGP...
1051   $main::mail_addr = undef;
1052
1053   # check signature
1054   my $signator = pgp_check($commands);
1055   if (!$signator) {
1056         msg("log,mail",
1057             "$main::current_incoming_short/$commands has bad PGP/GnuPG signature!\n");
1058         msg("log,mail",
1059                 "Removing $main::current_incoming_short/$commands\n");
1060         rm($commands);
1061         return;
1062   }
1063   elsif ($signator eq 'LOCAL ERROR') {
1064         debug("Can't check signature for $main::current_incoming_short/$commands -- don't process it for now");
1065         return;
1066   }
1067   msg("log,mail", "(PGP/GnuPG signature by $signator)\n");
1068
1069   return if !ftp_open();
1070
1071   # check target
1072   my @filenames = ($commands);
1073   if (my $ls_l = is_on_target($commands, @filenames)) {
1074         msg("log,mail", "$main::current_incoming_short/$commands is already present on target host:\n");
1075         msg("log,mail", "$ls_l\n");
1076         msg("log,mail", "Job $commands removed.\n");
1077         rm($commands);
1078         return;
1079   }
1080
1081   if (!copy_to_target($commands)) {
1082         msg("log,mail", "$commands couldn't be uploaded to target.\n");
1083         msg("log,mail", "Giving up and removing it.\n");
1084         rm($commands);
1085         return;
1086   }
1087
1088   rm($commands);
1089   msg("mail", "$commands uploaded successfully to $conf::target\n");
1090 }
1091
1092 #
1093 # process one .commands file
1094 #
1095 sub process_commands($) {
1096   my $commands = shift;
1097   my ( @cmds, $cmd, $pgplines, $signator );
1098   local (*COMMANDS);
1099   my ( @files, $file, @removed, $target_delay );
1100
1101   format_status_str( $main::current_changes, $commands );
1102   $main::dstat = "c";
1103   $main::mail_addr = "";
1104   write_status_file() if $conf::statusdelay;
1105
1106   msg( "log", "processing $main::current_incoming_short/$commands\n" );
1107
1108   # run PGP on the file to check the signature
1109   if ( !( $signator = pgp_check($commands) ) ) {
1110     msg(
1111       "log,mail",
1112       "$main::current_incoming_short/$commands has bad PGP/GnuPG signature!\n"
1113     );
1114     goto remove;
1115   } elsif ( $signator eq "LOCAL ERROR" ) {
1116
1117     # An error has appened when starting pgp... Don't process the file,
1118     # but also don't delete it
1119     debug(
1120 "Can't PGP/GnuPG check $main::current_incoming_short/$commands -- don't process it for now"
1121     );
1122     return;
1123   } ## end elsif ( $signator eq "LOCAL ERROR")
1124   msg( "log", "(PGP/GnuPG signature by $signator)\n" );
1125
1126   # parse the .commands file
1127   if ( !open( COMMANDS, "<", $commands ) ) {
1128     msg( "log", "Cannot open $main::current_incoming_short/$commands: $!\n" );
1129     return;
1130   }
1131   $pgplines        = 0;
1132   @cmds            = ();
1133 outer_loop: while (<COMMANDS>) {
1134     if (/^---+(BEGIN|END) PGP .*---+$/) {
1135       ++$pgplines;
1136     } elsif (/^Uploader:\s*/i) {
1137       chomp( $main::mail_addr = $' );
1138       $main::mail_addr = $1 if $main::mail_addr =~ /<([^>]*)>/;
1139     } elsif (/^Commands:/i) {
1140       $_ = $';
1141       for ( ; ; ) {
1142         s/^\s*(.*)\s*$/$1/;    # delete whitespace at both ends
1143         if ( !/^\s*$/ ) {
1144           push( @cmds, $_ );
1145           debug("includes cmd $_");
1146         }
1147         last outer_loop if !defined( $_ = scalar(<COMMANDS>) );
1148         chomp;
1149         redo outer_loop if !/^\s/ || /^$/;
1150       } ## end for ( ; ; )
1151     } ## end elsif (/^Commands:/i)
1152   } ## end while (<COMMANDS>)
1153   close(COMMANDS);
1154
1155   # some consistency checks
1156   if ( !$main::mail_addr || $main::mail_addr !~ /^\S+\@\S+\.\S+/ ) {
1157     msg( "log,mail",
1158 "$main::current_incoming_short/$commands contains no or bad Uploader: field: "
1159         . "$main::mail_addr\n" );
1160     msg( "log,mail",
1161          "cannot process $main::current_incoming_short/$commands\n" );
1162     $main::mail_addr = "";
1163     goto remove;
1164   } ## end if ( !$main::mail_addr...
1165   msg( "log", "(command uploader $main::mail_addr)\n" );
1166
1167   if ( $pgplines < 3 ) {
1168     msg(
1169        "log,mail",
1170        "$main::current_incoming_short/$commands isn't signed with PGP/GnuPG\n"
1171     );
1172     msg(
1173       "mail",
1174       "or the uploaded file is broken. Make sure to transfer in binary mode\n"
1175     );
1176     msg( "mail", "or better yet - use dcut for commands files\n" );
1177     goto remove;
1178   } ## end if ( $pgplines < 3 )
1179
1180   # now process commands
1181   msg(
1182     "mail",
1183 "Log of processing your commands file $main::current_incoming_short/$commands:\n\n"
1184   );
1185   foreach $cmd (@cmds) {
1186     my @word = split( /\s+/, $cmd );
1187     msg( "mail,log", "> @word\n" );
1188     my $selecteddelayed = -1;
1189     next if @word < 1;
1190
1191     if ( $word[0] eq "rm" ) {
1192       foreach ( @word[ 1 .. $#word ] ) {
1193         my $origword = $_;
1194         if (m,^DELAYED/([0-9]+)-day/,) {
1195           $selecteddelayed = $1;
1196           s,^DELAYED/[0-9]+-day/,,;
1197         }
1198         if (m,(^|/)\*,) {
1199           msg("mail,log", "$_: filename component cannot start with a wildcard\n");
1200         } elsif ( $origword eq "--searchdirs" ) {
1201           $selecteddelayed = -2;
1202         } elsif (m,/,) {
1203           msg(
1204             "mail,log",
1205 "$_: filename may not contain slashes except for DELAYED/#-day/ prefixes\n"
1206           );
1207         } else {
1208
1209           # process wildcards but also plain names
1210           my (@thesefiles);
1211           my $pat = quotemeta($_);
1212           $pat =~ s/\\\*/.*/g;
1213           $pat =~ s/\\\?/.?/g;
1214           $pat =~ s/\\([][])/$1/g;
1215
1216           if ( $selecteddelayed < 0 ) {    # scanning or explicitly incoming
1217             opendir( DIR, "." );
1218             push( @thesefiles, grep /^$pat$/, readdir(DIR) );
1219             closedir(DIR);
1220           }
1221           if ( $selecteddelayed >= 0 ) {
1222             my $dir = sprintf( $conf::incoming_delayed, $selecteddelayed );
1223             opendir( DIR, $dir );
1224             push( @thesefiles,
1225                   map ( "$dir/$_", grep /^$pat$/, readdir(DIR) ) );
1226             closedir(DIR);
1227           } elsif ( $selecteddelayed == -2 ) {
1228             for ( my ($adelay) = 0 ;
1229                   ( !@thesefiles ) && $adelay <= $conf::max_delayed ;
1230                   $adelay++ )
1231             {
1232               my $dir = sprintf( $conf::incoming_delayed, $adelay );
1233               opendir( DIR, $dir );
1234               push( @thesefiles,
1235                     map ( "$dir/$_", grep /^$pat$/, readdir(DIR) ) );
1236               closedir(DIR);
1237             } ## end for ( my ($adelay) = 0 ...
1238           } ## end elsif ( $selecteddelayed ...
1239           push( @files, @thesefiles );
1240           if ( !@thesefiles ) {
1241             msg( "mail,log", "$origword did not match anything\n" );
1242           }
1243         } ## end else [ if ( $origword eq "--searchdirs")
1244       } ## end foreach ( @word[ 1 .. $#word...
1245       if ( !@files ) {
1246         msg( "mail,log", "No files to delete\n" );
1247       } else {
1248         @removed = ();
1249         foreach $file (@files) {
1250           if ( !-f $file ) {
1251             msg( "mail,log", "$file: no such file\n" );
1252           } elsif ( $file =~ /$conf::keep_files/ ) {
1253             msg( "mail,log", "$file is protected, cannot " . "remove\n" );
1254           } elsif ( !unlink($file) ) {
1255             msg( "mail,log", "$file: rm: $!\n" );
1256           } else {
1257             $file =~ s,$conf::incoming/?,,;
1258             push( @removed, $file );
1259           }
1260         } ## end foreach $file (@files)
1261         msg( "mail,log", "Files removed: @removed\n" ) if @removed;
1262       } ## end else [ if ( !@files )
1263     } elsif ( $word[0] eq "reschedule" ) {
1264       if ( @word != 3 ) {
1265         msg( "mail,log", "Wrong number of arguments\n" );
1266       } elsif ( $conf::upload_method ne "copy" ) {
1267         msg( "mail,log", "reschedule not available\n" );
1268       } elsif ( $word[1] =~ m,/, || $word[1] !~ m/\.changes/ ) {
1269         msg(
1270            "mail,log",
1271            "$word[1]: filename may not contain slashes and must be .changes\n"
1272         );
1273       } elsif ( !( ($target_delay) = $word[2] =~ m,^([0-9]+)-day$, )
1274                 || $target_delay > $conf::max_delayed )
1275       {
1276         msg(
1277           "mail,log",
1278 "$word[2]: rescheduling target must be #-day with # between 0 and $conf::max_delayed (in particular, no '/' allowed)\n"
1279         );
1280       } elsif ( $word[1] =~ /$conf::keep_files/ ) {
1281         msg( "mail,log", "$word[1] is protected, cannot do stuff with it\n" );
1282       } else {
1283         my ($adelay);
1284         for ( $adelay = 0 ;
1285             $adelay <= $conf::max_delayed
1286             && !-f (
1287               sprintf( "$conf::targetdir_delayed", $adelay ) . "/$word[1]" ) ;
1288             $adelay++ )
1289         {
1290         } ## end for ( $adelay = 0 ; $adelay...
1291         if ( $adelay > $conf::max_delayed ) {
1292           msg( "mail,log", "$word[1] not found\n" );
1293         } elsif ( $adelay == $target_delay ) {
1294           msg( "mail,log", "$word[1] already is in $word[2]\n" );
1295         } else {
1296           my (@thesefiles);
1297           my ($dir) = sprintf( "$conf::targetdir_delayed", $adelay );
1298           my ($target_dir) =
1299             sprintf( "$conf::targetdir_delayed", $target_delay );
1300           push( @thesefiles, $word[1] );
1301           push( @thesefiles,
1302                 get_filelist_from_known_good_changes("$dir/$word[1]") );
1303           for my $afile (@thesefiles) {
1304             if ( $afile =~ m/\.changes$/ ) {
1305               utime undef, undef, ("$dir/$afile");
1306             }
1307             if ( !move("$dir/$afile", "$target_dir/$afile") ) {
1308               msg( "mail,log", "move: $!\n" );
1309             } else {
1310               msg( "mail,log", "$afile moved to $target_delay-day\n" );
1311             }
1312           } ## end for my $afile (@thesefiles)
1313         } ## end else [ if ( $adelay > $conf::max_delayed)
1314       } ## end else [ if ( @word != 3 )
1315     } elsif ( $word[0] eq "cancel" ) {
1316       if ( @word != 2 ) {
1317         msg( "mail,log", "Wrong number of arguments\n" );
1318       } elsif ( $conf::upload_method ne "copy" ) {
1319         msg( "mail,log", "cancel not available\n" );
1320       } elsif (
1321           $word[1] !~ m,$re_file_safe_prefix\.changes\z, )
1322       {
1323         msg( "mail,log",
1324           "argument to cancel must be one .changes filename without path\n" );
1325       } ## end elsif ( $word[1] !~ ...
1326       my (@files) = ();
1327       for ( my ($adelay) = 0 ; $adelay <= $conf::max_delayed ; $adelay++ ) {
1328         my ($dir) = sprintf( "$conf::targetdir_delayed", $adelay );
1329         if ( -f "$dir/$word[1]" ) {
1330           @removed = ();
1331           push( @files, "$word[1]" );
1332           push( @files,
1333                 get_filelist_from_known_good_changes("$dir/$word[1]") );
1334           foreach $file (@files) {
1335             if ( !-f "$dir/$file" ) {
1336               msg( "mail,log", "$dir/$file: no such file\n" );
1337             } elsif ( "$dir/$file" =~ /$conf::keep_files/ ) {
1338               msg( "mail,log",
1339                    "$dir/$file is protected, cannot " . "remove\n" );
1340             } elsif ( !unlink("$dir/$file") ) {
1341               msg( "mail,log", "$dir/$file: rm: $!\n" );
1342             } else {
1343               push( @removed, $file );
1344             }
1345           } ## end foreach $file (@files)
1346           msg( "mail,log", "Files removed from $adelay-day: @removed\n" )
1347             if @removed;
1348         } ## end if ( -f "$dir/$word[1]")
1349       } ## end for ( my ($adelay) = 0 ...
1350       if ( !@files ) {
1351         msg( "mail,log", "No upload found: $word[1]\n" );
1352       }
1353     } else {
1354       msg( "mail,log", "unknown command $word[0]\n" );
1355     }
1356   } ## end foreach $cmd (@cmds)
1357   rm($commands);
1358   msg( "log",
1359        "-- End of $main::current_incoming_short/$commands processing\n" );
1360   return;
1361
1362   remove:
1363   msg("log,mail", "Removing $main::current_incoming_short/$commands\n");
1364   rm($commands);
1365   return;
1366 } ## end sub process_commands($)
1367
1368 sub age_delayed_queues() {
1369   for ( my ($adelay) = 0 ; $adelay <= $conf::max_delayed ; $adelay++ ) {
1370     my ($dir) = sprintf( "$conf::targetdir_delayed", $adelay );
1371     my ($target_dir);
1372     if ( $adelay == 0 ) {
1373       $target_dir = $conf::targetdir;
1374     } else {
1375       $target_dir = sprintf( "$conf::targetdir_delayed", $adelay - 1 );
1376     }
1377     for my $achanges (<$dir/*.changes>) {
1378       my $mtime = ( stat($achanges) )[9];
1379       if ( $mtime + 24 * 60 * 60 <= time || $adelay == 0 ) {
1380         utime undef, undef, ($achanges);
1381         my @thesefiles = ( $achanges =~ m,.*/([^/]*), );
1382         push( @thesefiles, get_filelist_from_known_good_changes($achanges) );
1383         for my $afile (@thesefiles) {
1384           if ( !move("$dir/$afile", "$target_dir/$afile") ) {
1385             msg( "log", "move: $!\n" );
1386           } else {
1387             msg( "log", "$afile moved to $target_dir\n" );
1388           }
1389         } ## end for my $afile (@thesefiles)
1390       } ## end if ( $mtime + 24 * 60 ...
1391     } ## end for my $achanges (<$dir/*.changes>)
1392   } ## end for ( my ($adelay) = 0 ...
1393 } ## end sub age_delayed_queues()
1394
1395 #
1396 # check if a file is already on target
1397 #
1398 sub is_on_target($\@) {
1399   my $file     = shift;
1400   my $filelist = shift;
1401   my $msg;
1402   my $stat;
1403
1404   if ( $conf::upload_method eq "ssh" ) {
1405     ( $msg, $stat ) = ssh_cmd("ls -l $file");
1406   } elsif ( $conf::upload_method eq "ftp" ) {
1407     my $err;
1408     ( $msg, $err ) = ftp_cmd( "dir", $file );
1409     if ($err) {
1410       $stat = 1;
1411       $msg  = $err;
1412     } elsif ( !$msg ) {
1413       $stat = 1;
1414       $msg  = "ls: no such file\n";
1415     } else {
1416       $stat = 0;
1417       $msg = join( "\n", @$msg );
1418     }
1419   } else {
1420     my @allfiles = ($file);
1421     push( @allfiles, @$filelist );
1422     $stat = 1;
1423     $msg  = "no such file";
1424     for my $afile (@allfiles) {
1425       if ( -f "$conf::targetdir/$afile" ) {
1426         $stat = 0;
1427         $msg  = "$afile";
1428       }
1429     } ## end for my $afile (@allfiles)
1430     for ( my ($adelay) = 0 ;
1431           $adelay <= $conf::max_delayed && $stat ;
1432           $adelay++ )
1433     {
1434       for my $afile (@allfiles) {
1435         if (
1436            -f ( sprintf( "$conf::targetdir_delayed", $adelay ) . "/$afile" ) )
1437         {
1438           $stat = 0;
1439           $msg = sprintf( "%d-day", $adelay ) . "/$afile";
1440         } ## end if ( -f ( sprintf( "$conf::targetdir_delayed"...
1441       } ## end for my $afile (@allfiles)
1442     } ## end for ( my ($adelay) = 0 ...
1443   } ## end else [ if ( $conf::upload_method...
1444   chomp($msg);
1445   debug("exit status: $stat, output was: $msg");
1446
1447   return "" if $stat && $msg =~ /no such file/i;    # file not present
1448   msg( "log", "strange ls -l output on target:\n", $msg ), return ""
1449     if $stat || $@;    # some other error, but still try to upload
1450
1451   # ls -l returned 0 -> file already there
1452   $msg =~ s/\s\s+/ /g;    # make multiple spaces into one, to save space
1453   return $msg;
1454 } ## end sub is_on_target($\@)
1455
1456 #
1457 # copy a list of files to target
1458 #
1459 sub copy_to_target(@) {
1460   my @files = @_;
1461   my ( @md5sum, @expected_files, $sum, $name, $msgs, $stat );
1462
1463   $main::dstat = "u";
1464   write_status_file() if $conf::statusdelay;
1465
1466   # copy the files
1467   if ( $conf::upload_method eq "ssh" ) {
1468     ( $msgs, $stat ) = scp_cmd(@files);
1469     goto err if $stat;
1470   } elsif ( $conf::upload_method eq "ftp" ) {
1471     my ( $rv, $file );
1472     if ( !$main::FTP_chan->cwd($main::current_targetdir) ) {
1473       msg( "log,mail",
1474            "Can't cd to $main::current_targetdir on $conf::target\n" );
1475       goto err;
1476     }
1477     foreach $file (@files) {
1478       ( $rv, $msgs ) = ftp_cmd( "put", $file );
1479       goto err if !$rv;
1480     }
1481   } else {
1482     for my $file (@files) {
1483       eval { File::Copy::copy($file, $main::current_targetdir) };
1484       if ($@) {
1485         $stat = 1;
1486         $msgs = $@;
1487         goto err;
1488       }
1489     }
1490   }
1491
1492   # check md5sums or sizes on target against our own
1493   my $have_md5sums = 1;
1494   if ($conf::check_md5sum) {
1495     if ( $conf::upload_method eq "ssh" ) {
1496       ( $msgs, $stat ) = ssh_cmd("md5sum @files");
1497       goto err if $stat;
1498       @md5sum = split( "\n", $msgs );
1499     } elsif ( $conf::upload_method eq "ftp" ) {
1500       my ( $rv, $err, $file );
1501       foreach $file (@files) {
1502         ( $rv, $err ) = ftp_cmd( "quot", "site", "md5sum", $file );
1503         if ($err) {
1504           next if ftp_code() == 550;    # file not found
1505           if ( ftp_code() == 500 ) {    # unimplemented
1506             $have_md5sums = 0;
1507             goto get_sizes_instead;
1508           }
1509           $msgs = $err;
1510           goto err;
1511         } ## end if ($err)
1512         chomp( my $t = ftp_response() );
1513         push( @md5sum, $t );
1514       } ## end foreach $file (@files)
1515       if ( !$have_md5sums ) {
1516       get_sizes_instead:
1517         foreach $file (@files) {
1518           ( $rv, $err ) = ftp_cmd( "size", $file );
1519           if ($err) {
1520             next if ftp_code() == 550;    # file not found
1521             $msgs = $err;
1522             goto err;
1523           }
1524           push( @md5sum, "$rv $file" );
1525         } ## end foreach $file (@files)
1526       } ## end if ( !$have_md5sums )
1527     } else {
1528       for my $file (@files) {
1529         my $md5 = eval { md5sum("$main::current_targetdir/$file") };
1530         if ($@) {
1531           $msgs = $@;
1532           goto err;
1533         }
1534         push @md5sum, "$md5 $file" if $md5;
1535       }
1536     }
1537
1538     @expected_files = @files;
1539     foreach (@md5sum) {
1540       chomp;
1541       ( $sum, $name ) = split;
1542       next if !grep { $_ eq $name } @files;    # a file we didn't upload??
1543       next if $sum eq "md5sum:";               # looks like an error message
1544       if (    ( $have_md5sums && $sum ne md5sum($name) )
1545            || ( !$have_md5sums && $sum != ( -s $name ) ) )
1546       {
1547         msg(
1548              "log,mail",
1549              "Upload of $name to $conf::target failed ",
1550              "(" . ( $have_md5sums ? "md5sum" : "size" ) . " mismatch)\n"
1551            );
1552         goto err;
1553       } ## end if ( ( $have_md5sums &&...
1554
1555       # seen that file, remove it from expect list
1556       @expected_files = map { $_ eq $name ? () : $_ } @expected_files;
1557     } ## end foreach (@md5sum)
1558     if (@expected_files) {
1559       msg( "log,mail", "Failed to upload the files\n" );
1560       msg( "log,mail", "  ", join( ", ", @expected_files ), "\n" );
1561       msg( "log,mail", "(Not present on target after upload)\n" );
1562       goto err;
1563     } ## end if (@expected_files)
1564   } ## end if ($conf::check_md5sum)
1565
1566   if ($conf::chmod_on_target) {
1567
1568     # change file's mode explicitly to 644 on target
1569     if ( $conf::upload_method eq "ssh" ) {
1570       ( $msgs, $stat ) = ssh_cmd("chmod 644 @files");
1571       goto err if $stat;
1572     } elsif ( $conf::upload_method eq "ftp" ) {
1573       my ( $rv, $file );
1574       foreach $file (@files) {
1575         ( $rv, $msgs ) = ftp_cmd( "quot", "site", "chmod", "644", $file );
1576         msg( "log", "Can't chmod $file on target:\n$msgs" )
1577           if $msgs;
1578         goto err if !$rv;
1579       } ## end foreach $file (@files)
1580     } else {
1581       for my $file (@files) {
1582         unless (chmod 0644, "$main::current_targetdir/$file") {
1583           $msgs = "Could not chmod $file: $!";
1584           goto err;
1585         }
1586       }
1587     }
1588   } ## end if ($conf::chmod_on_target)
1589
1590   $main::dstat = "c";
1591   write_status_file() if $conf::statusdelay;
1592   return 1;
1593
1594 err:
1595   msg( "log,mail",
1596        "Upload to $conf::target failed",
1597        $? ? ", last exit status " . sprintf( "%s", $? >> 8 ) : "", "\n" );
1598   msg( "log,mail", "Error messages:\n", $msgs )
1599     if $msgs;
1600
1601   # If "permission denied" was among the errors, test if the incoming is
1602   # writable at all.
1603   if ( $msgs && $msgs =~ /(permission denied|read-?only file)/i ) {
1604     if ( !check_incoming_writable() ) {
1605       msg( "log,mail", "(The incoming directory seems to be ",
1606            "unwritable.)\n" );
1607     }
1608   } ## end if ( $msgs =~ /(permission denied|read-?only file)/i)
1609
1610   # remove bad files or an incomplete upload on target
1611   if ( $conf::upload_method eq "ssh" ) {
1612     ssh_cmd("rm -f @files");
1613   } elsif ( $conf::upload_method eq "ftp" ) {
1614     my $file;
1615     foreach $file (@files) {
1616       my ( $rv, $err );
1617       ( $rv, $err ) = ftp_cmd( "delete", $file );
1618       msg( "log", "Can't delete $file on target:\n$err" )
1619         if $err;
1620     } ## end foreach $file (@files)
1621   } else {
1622     my @tfiles = map { "$main::current_targetdir/$_" } @files;
1623     debug("executing unlink(@tfiles)");
1624     rm(@tfiles);
1625   }
1626   $main::dstat = "c";
1627   write_status_file() if $conf::statusdelay;
1628   return 0;
1629 } ## end sub copy_to_target(@)
1630
1631 #
1632 # check if a file is correctly signed with PGP
1633 #
1634 sub pgp_check($) {
1635   my $file   = shift;
1636   my $output = "";
1637   my $signator;
1638   my $found = 0;
1639   my $stat = 1;
1640   local (*PIPE);
1641   local $_;
1642
1643   if ($file =~ /$re_file_safe/) {
1644     $file = $1;
1645   } else {
1646     msg( "log", "Tainted filename, skipping: $file\n" );
1647     return "LOCAL ERROR";
1648   }
1649
1650   # check the file has only one clear-signed section
1651   my $fh;
1652   unless (open $fh, "<", $file) {
1653           msg("log,mail", "Could not open $file\n");
1654           return "";
1655   }
1656   unless (<$fh> eq "-----BEGIN PGP SIGNED MESSAGE-----\n") {
1657           msg("log,mail", "$file: does not start with a clearsigned message\n");
1658           return "";
1659   }
1660   my $pgplines = 1;
1661   while (<$fh>) {
1662           if (/\A- /) {
1663                   msg("log,mail", "$file: dash-escaped messages are not accepted\n");
1664                   return "";
1665           }
1666           elsif ($_ eq "-----BEGIN PGP SIGNATURE-----\n"
1667                      || $_ eq "-----END PGP SIGNATURE-----\n") {
1668                   $pgplines++;
1669           }
1670           elsif (/\A--/) {
1671                   msg("log,mail", "$file: unexpected OpenPGP armor\n");
1672                   return "";
1673           }
1674           elsif ($pgplines > 3 && /\S/) {
1675                   msg("log,mail", "$file: found text after end of signature\n");
1676                   return "";
1677           }
1678   }
1679   if ($pgplines != 3) {
1680           msg("log,mail", "$file: doesn't seem to be a valid clearsigned OpenPGP message\n");
1681           return "";
1682   }
1683   close $fh;
1684
1685   if ( -x $conf::gpg ) {
1686     my @command = ("$conf::gpg", "--no-options", "--batch", "--no-tty",
1687                    "--trust-model", "always", "--no-default-keyring",
1688                    (map +("--keyring" => $_), @conf::keyrings),
1689                    "--verify", "-");
1690     debug(   "executing " . join(" ", @command) );
1691
1692     my $child = open(PIPE, "-|");
1693     if (!defined($child)) {
1694       msg("log", "Can't open pipe to $conf::gpg: $!\n");
1695       return "LOCAL ERROR";
1696     }
1697     if ($child == 0) {
1698       unless (open(STDERR, ">&", \*STDOUT)) {
1699         print "Could not redirect STDERR.";
1700         exit(-1);
1701       }
1702       unless (open(STDIN, "<", $file)) {
1703         print "Could not open $file: $!";
1704         exit(-1);
1705       }
1706       { exec(@command) }; # BLOCK avoids warning about likely unreachable code
1707       print "Could not exec gpg: $!";
1708       exit(-1);
1709     }
1710
1711     $output .= $_ while (<PIPE>);
1712     close(PIPE);
1713     $stat = $?;
1714   } ## end if ( -x $conf::gpg )
1715
1716   if ($stat) {
1717     msg( "log,mail", "GnuPG signature check failed on $file\n" );
1718     msg( "mail",     $output );
1719     msg( "log,mail", "(Exit status ", $stat >> 8, ")\n" );
1720     return "";
1721   } ## end if ($stat)
1722
1723   $output =~ /^(gpg: )?good signature from (user )?"(.*)"\.?$/im;
1724   ( $signator = $3 ) ||= "unknown signator";
1725   if ($conf::debug) {
1726     debug("GnuPG signature ok (by $signator)");
1727   }
1728   return $signator;
1729 } ## end sub pgp_check($)
1730
1731 # ---------------------------------------------------------------------------
1732 #                                                         the status daemon
1733 # ---------------------------------------------------------------------------
1734
1735 #
1736 # fork a subprocess that watches the 'status' FIFO
1737 #
1738 # that process blocks until someone opens the FIFO, then sends a
1739 # signal (SIGUSR1) to the main process, expects
1740 #
1741 sub fork_statusd() {
1742   my $statusd_pid;
1743   my $main_pid = $$;
1744   my $errs;
1745   local (*STATFIFO);
1746
1747   $statusd_pid = open( STATUSD, "|-" );
1748   die "cannot fork: $!\n" if !defined($statusd_pid);
1749
1750   # parent just returns
1751   if ($statusd_pid) {
1752     msg( "log", "forked status daemon (pid $statusd_pid)\n" );
1753     return $statusd_pid;
1754   }
1755
1756   # child: the status FIFO daemon
1757
1758   # ignore SIGPIPE here, in case some closes the FIFO without completely
1759   # reading it
1760   $SIG{"PIPE"} = "IGNORE";
1761
1762   # also ignore SIGCLD, we don't want to inherit the restart-statusd handler
1763   # from our parent
1764   $SIG{"CHLD"} = "DEFAULT";
1765
1766   rm($conf::statusfile);
1767   $errs = `$conf::mkfifo $conf::statusfile`;
1768   die "$main::progname: cannot create named pipe $conf::statusfile: $errs"
1769     if $?;
1770   chmod( 0644, $conf::statusfile )
1771     or die "Cannot set modes of $conf::statusfile: $!\n";
1772
1773   # close log file, so that log rotating works
1774   close(LOG);
1775   close(STDOUT);
1776   close(STDERR);
1777
1778   while (1) {
1779     my ( $status, $mup, $incw, $ds, $next_run, $last_ping, $currch, $l );
1780
1781     # open the FIFO for writing; this blocks until someone (probably ftpd)
1782     # opens it for reading
1783     open( STATFIFO, ">", $conf::statusfile )
1784       or die "Cannot open $conf::statusfile\n";
1785     select(STATFIFO);
1786
1787     # tell main daemon to send us status infos
1788     kill( $main::signo{"USR1"}, $main_pid );
1789
1790     # get the infos from stdin; must loop until enough bytes received!
1791     my $expect_len = 3 + 2 * STATNUM_LEN + STATSTR_LEN;
1792     for ( $status = "" ; ( $l = length($status) ) < $expect_len ; ) {
1793       sysread( STDIN, $status, $expect_len - $l, $l );
1794     }
1795
1796     # disassemble the status byte stream
1797     my $pos = 0;
1798     foreach (
1799               [ mup       => 1 ],
1800               [ incw      => 1 ],
1801               [ ds        => 1 ],
1802               [ next_run  => STATNUM_LEN ],
1803               [ last_ping => STATNUM_LEN ],
1804               [ currch    => STATSTR_LEN ]
1805             )
1806     {
1807       eval "\$$_->[0] = substr( \$status, $pos, $_->[1] );";
1808       $pos += $_->[1];
1809     } ## end foreach ( [ mup => 1 ], [ incw...
1810     $currch =~ s/\n+//g;
1811
1812     print_status( $mup, $incw, $ds, $next_run, $last_ping, $currch );
1813     close(STATFIFO);
1814
1815     # This sleep is necessary so that we can't reopen the FIFO
1816     # immediately, in case the reader hasn't closed it yet if we get to
1817     # the open again. Is there a better solution for this??
1818     sleep 1;
1819   } ## end while (1)
1820 } ## end sub fork_statusd()
1821
1822 #
1823 # update the status file, in case we use a plain file and not a FIFO
1824 #
1825 sub write_status_file() {
1826
1827   return if !$conf::statusfile;
1828
1829   open( STATFILE, ">", $conf::statusfile )
1830     or ( msg( "log", "Could not open $conf::statusfile: $!\n" ), return );
1831   my $oldsel = select(STATFILE);
1832
1833   print_status(
1834                 $main::target_up,      $main::incoming_writable,
1835                 $main::dstat,          $main::next_run,
1836                 $main::last_ping_time, $main::current_changes
1837               );
1838
1839   select($oldsel);
1840   close(STATFILE);
1841 } ## end sub write_status_file()
1842
1843 sub print_status($$$$$$) {
1844   my $mup       = shift;
1845   my $incw      = shift;
1846   my $ds        = shift;
1847   my $next_run  = shift;
1848   my $last_ping = shift;
1849   my $currch    = shift;
1850   my $approx;
1851   my $version;
1852
1853   ( $version = 'Release: 0.9 $Revision: 1.51 $' ) =~ s/\$ ?//g;
1854   print "debianqueued $version\n";
1855
1856   $approx = $conf::statusdelay ? "approx. " : "";
1857
1858   if ( $mup eq "0" ) {
1859     print "$conf::target is down, queue pausing\n";
1860     return;
1861   } elsif ( $conf::upload_method ne "copy" ) {
1862     print "$conf::target seems to be up, last ping $approx",
1863       print_time( time - $last_ping ), " ago\n";
1864   }
1865
1866   if ( $incw eq "0" ) {
1867     print "The incoming directory is not writable, queue pausing\n";
1868     return;
1869   }
1870
1871   if ( $ds eq "i" ) {
1872     print "Next queue check in $approx", print_time( $next_run - time ), "\n";
1873     return;
1874   } elsif ( $ds eq "c" ) {
1875     print "Checking queue directory\n";
1876   } elsif ( $ds eq "u" ) {
1877     print "Uploading to $conf::target\n";
1878   } else {
1879     print "Bad status data from daemon: \"$mup$incw$ds\"\n";
1880     return;
1881   }
1882
1883   print "Current job is $currch\n" if $currch;
1884 } ## end sub print_status($$$$$$)
1885
1886 #
1887 # format a number for sending to statusd (fixed length STATNUM_LEN)
1888 #
1889 sub format_status_num(\$$) {
1890   my $varref = shift;
1891   my $num    = shift;
1892
1893   $$varref = sprintf "%" . STATNUM_LEN . "d", $num;
1894 } ## end sub format_status_num(\$$)
1895
1896 #
1897 # format a string for sending to statusd (fixed length STATSTR_LEN)
1898 #
1899 sub format_status_str(\$$) {
1900   my $varref = shift;
1901   my $str    = shift;
1902
1903   $$varref = substr( $str, 0, STATSTR_LEN );
1904   $$varref .= "\n" x ( STATSTR_LEN - length($$varref) );
1905 } ## end sub format_status_str(\$$)
1906
1907 #
1908 # send a status string to the status daemon
1909 #
1910 # Avoid all operations that could call malloc() here! Most libc
1911 # implementations aren't reentrant, so we may not call it from a
1912 # signal handler. So use only already-defined variables.
1913 #
1914 sub send_status() {
1915   local $! = 0;    # preserve errno
1916
1917   # re-setup handler, in case we have broken SysV signals
1918   $SIG{"USR1"} = \&send_status;
1919
1920   syswrite( STATUSD, $main::target_up,         1 );
1921   syswrite( STATUSD, $main::incoming_writable, 1 );
1922   syswrite( STATUSD, $main::dstat,             1 );
1923   syswrite( STATUSD, $main::next_run,          STATNUM_LEN );
1924   syswrite( STATUSD, $main::last_ping_time,    STATNUM_LEN );
1925   syswrite( STATUSD, $main::current_changes,   STATSTR_LEN );
1926 } ## end sub send_status()
1927
1928 # ---------------------------------------------------------------------------
1929 #                                                           FTP functions
1930 # ---------------------------------------------------------------------------
1931
1932 #
1933 # open FTP connection to target host if not already open
1934 #
1935 sub ftp_open() {
1936   return 1 unless $conf::upload_method eq "ftp";
1937
1938   if ($main::FTP_chan) {
1939
1940     # is already open, but might have timed out; test with a cwd
1941     return $main::FTP_chan
1942       if $main::FTP_chan->cwd($main::current_targetdir);
1943
1944     # cwd didn't work, channel is closed, try to reopen it
1945     $main::FTP_chan = undef;
1946   } ## end if ($main::FTP_chan)
1947
1948   if (
1949        !(
1950           $main::FTP_chan =
1951           Net::FTP->new(
1952                          $conf::target,
1953                          Debug   => $conf::ftpdebug,
1954                          Timeout => $conf::ftptimeout,
1955                          Passive => 1,
1956                        )
1957         )
1958      )
1959   {
1960     msg( "log,mail", "Cannot open FTP server $conf::target\n" );
1961     goto err;
1962   } ## end if ( !( $main::FTP_chan...
1963   if ( !$main::FTP_chan->login() ) {
1964     msg( "log,mail", "Anonymous login on FTP server $conf::target failed\n" );
1965     goto err;
1966   }
1967   if ( !$main::FTP_chan->binary() ) {
1968     msg( "log,mail", "Can't set binary FTP mode on $conf::target\n" );
1969     goto err;
1970   }
1971   if ( !$main::FTP_chan->cwd($main::current_targetdir) ) {
1972     msg( "log,mail",
1973          "Can't cd to $main::current_targetdir on $conf::target\n" );
1974     goto err;
1975   }
1976   debug("opened FTP channel to $conf::target");
1977   return 1;
1978
1979 err:
1980   $main::FTP_chan = undef;
1981   return 0;
1982 } ## end sub ftp_open()
1983
1984 sub ftp_cmd($@) {
1985   my $cmd = shift;
1986   my ( $rv, $err );
1987   my $direct_resp_cmd = ( $cmd eq "quot" );
1988
1989   debug( "executing FTP::$cmd(" . join( ", ", @_ ) . ")" );
1990   $SIG{"ALRM"} = sub { die "timeout in FTP::$cmd\n" };
1991   alarm($conf::remote_timeout);
1992   eval { $rv = $main::FTP_chan->$cmd(@_); };
1993   alarm(0);
1994   $err = "";
1995   $rv = ( ftp_code() =~ /^2/ ) ? 1 : 0 if $direct_resp_cmd;
1996   if ($@) {
1997     $err = $@;
1998     undef $rv;
1999   } elsif ( !$rv ) {
2000     $err = ftp_response();
2001   }
2002   return ( $rv, $err );
2003 } ## end sub ftp_cmd($@)
2004
2005 sub ftp_close() {
2006   if ($main::FTP_chan) {
2007     $main::FTP_chan->quit();
2008     $main::FTP_chan = undef;
2009   }
2010   return 1;
2011 } ## end sub ftp_close()
2012
2013 sub ftp_response() {
2014   return join( '', @{ ${*$main::FTP_chan}{'net_cmd_resp'} } );
2015 }
2016
2017 sub ftp_code() {
2018   return ${*$main::FTP_chan}{'net_cmd_code'};
2019 }
2020
2021 sub ftp_error() {
2022   my $code = ftp_code();
2023   return ( $code =~ /^[45]/ ) ? 1 : 0;
2024 }
2025
2026 # ---------------------------------------------------------------------------
2027 #                                                         utility functions
2028 # ---------------------------------------------------------------------------
2029
2030 sub ssh_cmd($) {
2031   my $cmd = shift;
2032   my ( $msg, $stat );
2033
2034   my $ecmd = "$conf::ssh $conf::ssh_options $conf::target "
2035     . "-l $conf::targetlogin \'cd $main::current_targetdir; $cmd\'";
2036   debug("executing $ecmd");
2037   $SIG{"ALRM"} = sub { die "timeout in ssh command\n" };
2038   alarm($conf::remote_timeout);
2039   eval { $msg = `$ecmd 2>&1`; };
2040   alarm(0);
2041   if ($@) {
2042     $msg  = $@;
2043     $stat = 1;
2044   } else {
2045     $stat = $?;
2046   }
2047   return ( $msg, $stat );
2048 } ## end sub ssh_cmd($)
2049
2050 sub scp_cmd(@) {
2051   my ( $msg, $stat );
2052
2053   my $ecmd = "$conf::scp $conf::ssh_options @_ "
2054     . "$conf::targetlogin\@$conf::target:$main::current_targetdir";
2055   debug("executing $ecmd");
2056   $SIG{"ALRM"} = sub { die "timeout in scp\n" };
2057   alarm($conf::remote_timeout);
2058   eval { $msg = `$ecmd 2>&1`; };
2059   alarm(0);
2060   if ($@) {
2061     $msg  = $@;
2062     $stat = 1;
2063   } else {
2064     $stat = $?;
2065   }
2066   return ( $msg, $stat );
2067 } ## end sub scp_cmd(@)
2068
2069 #
2070 # check if target is alive (code stolen from Net::Ping.pm)
2071 #
2072 sub check_alive(;$) {
2073   my $timeout = shift;
2074   my ( $saddr, $ret, $target_ip );
2075   local (*PINGSOCK);
2076
2077   if ( $conf::upload_method eq "copy" ) {
2078     format_status_num( $main::last_ping_time, time );
2079     $main::target_up = 1;
2080     return;
2081   }
2082
2083   $timeout ||= 30;
2084
2085   if ( !( $target_ip = ( gethostbyname($conf::target) )[4] ) ) {
2086     msg( "log", "Cannot get IP address of $conf::target\n" );
2087     $ret = 0;
2088     goto out;
2089   }
2090   $saddr = pack( 'S n a4 x8', AF_INET, $main::echo_port, $target_ip );
2091   $SIG{'ALRM'} = sub { die };
2092   alarm($timeout);
2093
2094   $ret = $main::tcp_proto;    # avoid warnings about unused variable
2095   $ret = 0;
2096   eval <<'EOM' ;
2097     return unless socket( PINGSOCK, PF_INET, SOCK_STREAM, $main::tcp_proto );
2098     return unless connect( PINGSOCK, $saddr );
2099     $ret = 1;
2100 EOM
2101   alarm(0);
2102   close(PINGSOCK);
2103   msg( "log", "pinging $conf::target: " . ( $ret ? "ok" : "down" ) . "\n" );
2104 out:
2105   $main::target_up = $ret ? "1" : "0";
2106   format_status_num( $main::last_ping_time, time );
2107   write_status_file() if $conf::statusdelay;
2108 } ## end sub check_alive(;$)
2109
2110 #
2111 # check if incoming dir on target is writable
2112 #
2113 sub check_incoming_writable() {
2114   my $testfile = ".debianqueued-testfile";
2115   my ( $msg, $stat );
2116
2117   if ( $conf::upload_method eq "ssh" ) {
2118     ( $msg, $stat ) =
2119       ssh_cmd( "rm -f $testfile; touch $testfile; " . "rm -f $testfile" );
2120   } elsif ( $conf::upload_method eq "ftp" ) {
2121     my $file = "junk-for-writable-test-" . format_time();
2122     $file =~ s/[ :.]/-/g;
2123     local (*F);
2124     open( F, ">", $file );
2125     close(F);
2126     my $rv;
2127     ( $rv, $msg ) = ftp_cmd( "put", $file );
2128     $stat = 0;
2129     $msg = "" if !defined $msg;
2130     unlink $file;
2131     ftp_cmd( "delete", $file );
2132   } elsif ( $conf::upload_method eq "copy" ) {
2133     unless(POSIX::access($main::current_targetdir, &POSIX::W_OK)) {
2134       $msg = "No write access: $!";
2135       $stat = 1;
2136     }
2137   }
2138   chomp($msg);
2139   debug("exit status: $stat, output was: $msg");
2140
2141   if ( !$stat ) {
2142
2143     # change incoming_writable only if ssh didn't return an error
2144     $main::incoming_writable =
2145       ( $msg =~ /(permission denied|read-?only file|cannot create)/i )
2146       ? "0"
2147       : "1";
2148   } else {
2149     debug("local error, keeping old status");
2150   }
2151   debug("incoming_writable = $main::incoming_writable");
2152   write_status_file() if $conf::statusdelay;
2153   return $main::incoming_writable;
2154 } ## end sub check_incoming_writable()
2155
2156 #
2157 # remove a list of files, log failing ones
2158 #
2159 sub rm(@) {
2160   my $done = 0;
2161
2162   foreach (@_) {
2163     ( unlink $_ and ++$done )
2164       or $! == ENOENT
2165       or msg( "log", "Could not delete $_: $!\n" );
2166   }
2167   return $done;
2168 } ## end sub rm(@)
2169
2170 #
2171 # get md5 checksum of a file
2172 #
2173 sub md5sum($) {
2174   my $file = shift;
2175   my $md5 = Digest::MD5->new;
2176
2177   open my $fh, "<", $file or return "";
2178   $md5->addfile($fh);
2179   close $fh;
2180
2181   return $md5->hexdigest;
2182 } ## end sub md5sum($)
2183
2184 #
2185 # output a messages to several destinations
2186 #
2187 # first arg is a comma-separated list of destinations; valid are "log"
2188 # and "mail"; rest is stuff to be printed, just as with print
2189 #
2190 sub msg($@) {
2191   my @dest = split( ',', shift );
2192
2193   if ( grep /log/, @dest ) {
2194     my $now = format_time();
2195     print LOG "$now ", @_;
2196   }
2197
2198   if ( grep /mail/, @dest ) {
2199     $main::mail_text .= join( '', @_ );
2200   }
2201 } ## end sub msg($@)
2202
2203 #
2204 # print a debug messages, if $debug is true
2205 #
2206 sub debug(@) {
2207   return if !$conf::debug;
2208   my $now = format_time();
2209   print LOG "$now DEBUG ", @_, "\n";
2210 }
2211
2212 #
2213 # intialize the "mail" destination of msg() (this clears text,
2214 # address, subject, ...)
2215 #
2216 sub init_mail(;$) {
2217   my $file = shift;
2218
2219   $main::mail_addr    = "";
2220   $main::mail_text    = "";
2221   %main::packages     = ();
2222   $main::mail_subject = $file ? "Processing of $file" : "";
2223 } ## end sub init_mail(;$)
2224
2225 #
2226 # finalize mail to be sent from msg(): check if something present, and
2227 # then send out
2228 #
2229 sub finish_mail() {
2230
2231   debug("No mail for $main::mail_addr")
2232     if $main::mail_addr && !$main::mail_text;
2233   return unless $main::mail_addr && $main::mail_text;
2234
2235   if ( !send_mail( $main::mail_addr, $main::mail_subject, $main::mail_text ) )
2236   {
2237
2238     # store this mail in memory so it isn't lost if executing sendmail
2239     # failed.
2240     push(
2241           @main::stored_mails,
2242           {
2243             addr    => $main::mail_addr,
2244             subject => $main::mail_subject,
2245             text    => $main::mail_text
2246           }
2247         );
2248   } ## end if ( !send_mail( $main::mail_addr...
2249   init_mail();
2250
2251   # try to send out stored mails
2252   my $mailref;
2253   while ( $mailref = shift(@main::stored_mails) ) {
2254     if (
2255          !send_mail( $mailref->{'addr'}, $mailref->{'subject'},
2256                      $mailref->{'text'} )
2257        )
2258     {
2259       unshift( @main::stored_mails, $mailref );
2260       last;
2261     } ## end if ( !send_mail( $mailref...
2262   } ## end while ( $mailref = shift(...
2263 } ## end sub finish_mail()
2264
2265 #
2266 # send one mail
2267 #
2268 sub send_mail($$$) {
2269   my $addr    = shift;
2270   my $subject = shift;
2271   my $text    = shift;
2272
2273   my $package =
2274     keys %main::packages ? join( ' ', keys %main::packages ) : "";
2275
2276   use Email::Send;
2277
2278   unless ( defined($Email::Send::Sendmail::SENDMAIL) ) {
2279     $Email::Send::Sendmail::SENDMAIL = $conf::mail;
2280   }
2281
2282   if ($conf::overridemail) {
2283         $addr = $conf::overridemail;
2284   }
2285
2286   my $date = sprintf "%s",
2287     strftime( "%a, %d %b %Y %T %z", ( localtime(time) ) );
2288   my $message = <<__MESSAGE__;
2289 To: $addr
2290 From: Debian FTP Masters <ftpmaster\@ftp-master.debian.org>
2291 Subject: $subject
2292 Date: $date
2293 X-Debian: DAK
2294 X-DAK: DAK
2295 __MESSAGE__
2296
2297   if ( length $package ) {
2298     $message .= "X-Debian-Package: $package\n";
2299   }
2300
2301   $message .= "\n$text";
2302   $message .= "\nGreetings,\n\n\tYour Debian queue daemon (running on host $main::hostname)\n";
2303
2304   my $mail = Email::Send->new;
2305   for (qw[Sendmail SMTP]) {
2306     $mail->mailer($_) and last if $mail->mailer_available($_);
2307   }
2308
2309   my $ret = $mail->send($message);
2310   if ( $ret && $ret !~ /Message sent|success/ ) {
2311     return 0;
2312   }
2313
2314   return 1;
2315 } ## end sub send_mail($$$)
2316
2317 #
2318 # try to find a mail address for a name in the keyrings
2319 #
2320 sub try_to_get_mail_addr($$) {
2321   my $name    = shift;
2322   my $listref = shift;
2323
2324   @$listref = ();
2325   open( F,
2326             "$conf::gpg --no-options --batch --no-default-keyring "
2327           . "--always-trust --keyring "
2328           . join( " --keyring ", @conf::keyrings )
2329           . " --list-keys |"
2330       ) or return "";
2331   while (<F>) {
2332     if ( /^pub / && / $name / ) {
2333       /<([^>]*)>/;
2334       push( @$listref, $1 );
2335     }
2336   } ## end while (<F>)
2337   close(F);
2338
2339   return ( @$listref >= 1 ) ? $listref->[0] : "";
2340 } ## end sub try_to_get_mail_addr($$)
2341
2342 #
2343 # return current time as string
2344 #
2345 sub format_time() {
2346   my $t;
2347
2348   # omit weekday and year for brevity
2349   ( $t = localtime ) =~ /^\w+\s(.*)\s\d+$/;
2350   return $1;
2351 } ## end sub format_time()
2352
2353 sub print_time($) {
2354   my $secs = shift;
2355   my $hours = int( $secs / ( 60 * 60 ) );
2356
2357   $secs -= $hours * 60 * 60;
2358   return sprintf "%d:%02d:%02d", $hours, int( $secs / 60 ), $secs % 60;
2359 } ## end sub print_time($)
2360
2361 #
2362 # block some signals during queue processing
2363 #
2364 # This is just to avoid data inconsistency or uploads being aborted in the
2365 # middle. Only "soft" signals are blocked, i.e. SIGINT and SIGTERM, try harder
2366 # ones if you really want to kill the daemon at once.
2367 #
2368 sub block_signals() {
2369   POSIX::sigprocmask( SIG_BLOCK, $main::block_sigset );
2370 }
2371
2372 sub unblock_signals() {
2373   POSIX::sigprocmask( SIG_UNBLOCK, $main::block_sigset );
2374 }
2375
2376 #
2377 # process SIGHUP: close log file and reopen it (for logfile cycling)
2378 #
2379 sub close_log($) {
2380   close(LOG);
2381   close(STDOUT);
2382   close(STDERR);
2383
2384   open( LOG, ">>", $conf::logfile )
2385     or die "Cannot open my logfile $conf::logfile: $!\n";
2386   chmod( 0644, $conf::logfile )
2387     or msg( "log", "Cannot set modes of $conf::logfile: $!\n" );
2388   select( ( select(LOG), $| = 1 )[0] );
2389
2390   open( STDOUT, ">&", \*LOG )
2391     or msg( "log",
2392       "$main::progname: Can't redirect stdout to " . "$conf::logfile: $!\n" );
2393   open( STDERR, ">&", \*LOG )
2394     or msg( "log",
2395       "$main::progname: Can't redirect stderr to " . "$conf::logfile: $!\n" );
2396   msg( "log", "Restart after SIGHUP\n" );
2397 } ## end sub close_log($)
2398
2399 #
2400 # process SIGCHLD: check if it was our statusd process
2401 #
2402 sub kid_died($) {
2403   my $pid;
2404
2405   # reap statusd, so that it's no zombie when we try to kill(0) it
2406   waitpid( $main::statusd_pid, WNOHANG );
2407
2408   # Uncomment the following line if your Perl uses unreliable System V signal
2409   # (i.e. if handlers reset to default if the signal is delivered).
2410   # (Unfortunately, the re-setup can't be done in any case, since on some
2411   # systems this will cause the SIGCHLD to be delivered again if there are
2412   # still unreaped children :-(( )
2413
2414   #      $SIG{"CHLD"} = \&kid_died; # resetup handler for SysV
2415 } ## end sub kid_died($)
2416
2417 sub restart_statusd() {
2418
2419   # restart statusd if it died
2420   if ( !kill( 0, $main::statusd_pid ) ) {
2421     close(STATUSD);    # close out pipe end
2422     $main::statusd_pid = fork_statusd();
2423   }
2424 } ## end sub restart_statusd()
2425
2426 #
2427 # process a fatal signal: cleanup and exit
2428 #
2429 sub fatal_signal($) {
2430   my $signame = shift;
2431   my $sig;
2432
2433   # avoid recursions of fatal_signal in case of BSD signals
2434   foreach $sig (qw( ILL ABRT BUS FPE SEGV PIPE )) {
2435     $SIG{$sig} = "DEFAULT";
2436   }
2437
2438   if ( $$ == $main::maind_pid ) {
2439
2440     # only the main daemon should do this
2441     kill( $main::signo{"TERM"}, $main::statusd_pid )
2442       if defined $main::statusd_pid;
2443     unlink( $conf::statusfile, $conf::pidfile );
2444   } ## end if ( $$ == $main::maind_pid)
2445   msg( "log", "Caught SIG$signame -- exiting (pid $$)\n" );
2446   exit 1;
2447 } ## end sub fatal_signal($)
2448
2449 # Local Variables:
2450 #  tab-width: 4
2451 #  fill-column: 78
2452 # End: