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