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   $main::mail_addr = "";
 633   write_status_file() if $conf::statusdelay;
 634
 635   @$keep_list = ();
 636   msg( "log", "processing ${main::current_incoming_short}/$changes\n" );
 637
 638   # run PGP on the file to check the signature
 639   if ( !( $signator = pgp_check($changes) ) ) {
 640     msg(
 641        "log,mail",
 642        "$main::current_incoming_short/$changes has bad PGP/GnuPG signature!\n"
 643     );
 644     goto remove_only_changes;
 645   } elsif ( $signator eq "LOCAL ERROR" ) {
 646
 647     # An error has appened when starting pgp... Don't process the file,
 648     # but also don't delete it
 649     debug(
 650 "Can't PGP/GnuPG check $main::current_incoming_short/$changes -- don't process it for now"
 651     );
 652     return;
 653   } ## end elsif ( $signator eq "LOCAL ERROR")
 654
 655   # parse the .changes file
 656   open( CHANGES, "<", $changes )
 657     or die "Cannot open ${main::current_incoming_short}/$changes: $!\n";
 658   $pgplines        = 0;
 659   $extralines      = 0;
 660   @files           = ();
 661 outer_loop: while (<CHANGES>) {
 662     if (/^---+(BEGIN|END) PGP .*---+$/) {
 663       ++$pgplines;
 664       next;
 665     }
 666     if ( $pgplines < 1 or $pgplines >= 3 ) {
 667       $extralines++ if length $_ > 1;
 668       next;
 669     }
 670     if (/^Maintainer:\s*/i) {
 671       chomp( $main::mail_addr = $' );
 672       $main::mail_addr = $1 if $main::mail_addr =~ /<([^>]*)>/;
 673     } elsif (/^Source:\s*/i) {
 674       chomp( $pkgname = $' );
 675       $pkgname =~ s/\s+$//;
 676       $main::packages{$pkgname}++;
 677     } elsif (/^Files:/i) {
 678       while (<CHANGES>) {
 679         redo outer_loop if !/^\s/;
 680         my @field = split(/\s+/);
 681         next if @field != 6;
 682
 683         # forbid shell meta chars in the name, we pass it to a
 684         # subshell several times...
 685         $field[5] =~ /$re_file_safe/;
 686         if ( $1 ne $field[5] ) {
 687           msg( "log", "found suspicious filename $field[5]\n" );
 688           msg(
 689             "mail",
 690 "File '$field[5]' mentioned in $main::current_incoming_short/$changes\n",
 691             "has bad characters in its name. Removed.\n"
 692           );
 693           rm( $field[5] );
 694           next;
 695         } ## end if ( $1 ne $field[5] )
 696         push(
 697               @files,
 698               {
 699                 md5  => $field[1],
 700                 size => $field[2],
 701                 name => $field[5]
 702               }
 703             );
 704         push( @filenames, $field[5] );
 705         debug( "includes file $field[5], size $field[2], ", "md5 $field[1]" );
 706       } ## end while (<CHANGES>)
 707     } ## end elsif (/^Files:/i)
 708   } ## end while (<CHANGES>)
 709   close(CHANGES);
 710
 711   # tell check_dir that the files mentioned in this .changes aren't stray,
 712   # we know about them somehow
 713   @$keep_list = @filenames;
 714
 715   # some consistency checks
 716   if ( $extralines ) {
 717     msg( "log,mail",
 718 "$main::current_incoming_short/$changes contained lines outside the pgp signed "
 719 ."part, cannot process\n" );
 720     goto remove_only_changes;
 721   } ## end if ( $extralines )
 722   if ( !$main::mail_addr ) {
 723     msg( "log,mail",
 724 "$main::current_incoming_short/$changes doesn't contain a Maintainer: field; "
 725         . "cannot process\n" );
 726     goto remove_only_changes;
 727   } ## end if ( !$main::mail_addr)
 728   if ( $main::mail_addr !~ /^(buildd_\S+-\S+|\S+\@\S+\.\S+)/ ) {
 729
 730     # doesn't look like a mail address, maybe only the name
 731     my ( $new_addr, @addr_list );
 732     if ( $new_addr = try_to_get_mail_addr( $main::mail_addr, \@addr_list ) ) {
 733
 734       # substitute (unique) found addr, but give a warning
 735       msg(
 736            "mail",
 737            "(The Maintainer: field didn't contain a proper "
 738              . "mail address.\n"
 739          );
 740       msg(
 741            "mail",
 742            "Looking for `$main::mail_addr' in the Debian "
 743              . "keyring gave your address\n"
 744          );
 745       msg( "mail", "as unique result, so I used this.)\n" );
 746       msg( "log",
 747            "Substituted $new_addr for malformed " . "$main::mail_addr\n" );
 748       $main::mail_addr = $new_addr;
 749     } else {
 750
 751       # not found or not unique: hold the job and inform queue maintainer
 752       my $old_addr = $main::mail_addr;
 753       $main::mail_addr = $conf::maintainer_mail;
 754       msg(
 755         "mail",
 756 "The job ${main::current_incoming_short}/$changes doesn't have a correct email\n"
 757       );
 758       msg( "mail", "address in the Maintainer: field:\n" );
 759       msg( "mail", "  $old_addr\n" );
 760       msg( "mail", "A check for this in the Debian keyring gave:\n" );
 761       msg( "mail",
 762            @addr_list
 763            ? "  " . join( ", ", @addr_list ) . "\n"
 764            : "  nothing\n" );
 765       msg( "mail", "Please fix this manually\n" );
 766       msg(
 767         "log",
 768 "Bad Maintainer: field in ${main::current_incoming_short}/$changes: $old_addr\n"
 769       );
 770       goto remove_only_changes;
 771     } ## end else [ if ( $new_addr = try_to_get_mail_addr...
 772   } ## end if ( $main::mail_addr ...
 773   if ( $pgplines < 3 ) {
 774     msg(
 775         "log,mail",
 776         "$main::current_incoming_short/$changes isn't signed with PGP/GnuPG\n"
 777        );
 778     msg( "log", "(uploader $main::mail_addr)\n" );
 779     goto remove_only_changes;
 780   } ## end if ( $pgplines < 3 )
 781   if ( !@files ) {
 782     msg( "log,mail",
 783        "$main::current_incoming_short/$changes doesn't mention any files\n" );
 784     msg( "log", "(uploader $main::mail_addr)\n" );
 785     goto remove_only_changes;
 786   } ## end if ( !@files )
 787
 788   # check for packages that shouldn't be processed
 789   if ( grep( $_ eq $pkgname, @conf::nonus_packages ) ) {
 790     msg(
 791          "log,mail",
 792          "$pkgname is a package that must be uploaded "
 793            . "to nonus.debian.org\n"
 794        );
 795     msg( "log,mail", "instead of target.\n" );
 796     msg( "log,mail",
 797          "Job rejected and removed all files belonging " . "to it:\n" );
 798     msg( "log,mail", "  ", join( ", ", @filenames ), "\n" );
 799     rm( $changes, @filenames );
 800     return;
 801   } ## end if ( grep( $_ eq $pkgname...
 802
 803   $failure_file = $changes . ".failures";
 804   $retries = $last_retry = 0;
 805   if ( -f $failure_file ) {
 806     open( FAILS, "<", $failure_file )
 807       or die "Cannot open $main::current_incoming_short/$failure_file: $!\n";
 808     my $line = <FAILS>;
 809     close(FAILS);
 810     ( $retries, $last_retry ) = ( $1, $2 )
 811       if $line =~ /^(\d+)\s+(\d+)$/;
 812     push( @$keep_list, $failure_file );
 813   } ## end if ( -f $failure_file )
 814
 815   die "Cannot stat ${main::current_incoming_short}/$changes (??): $!\n"
 816     if !( @changes_stats = stat($changes) );
 817
 818   # Make $upload_time the maximum of all modification times of files
 819   # related to this .changes (and the .changes it self). This is the
 820   # last time something changes to these files.
 821   $upload_time = $changes_stats[ST_MTIME];
 822   for $file (@files) {
 823     my @stats;
 824     next if !( @stats = stat( $file->{"name"} ) );
 825     $file->{"stats"} = \@stats;
 826     $upload_time = $stats[ST_MTIME] if $stats[ST_MTIME] > $upload_time;
 827   } ## end for $file (@files)
 828
 829   $do_report = ( time - $upload_time ) > $conf::problem_report_timeout;
 830   $problems_reported = $changes_stats[ST_MODE] & S_ISGID;
 831
 832   # if any of the files is newer than the .changes' ctime (the time
 833   # we sent a report and set the sticky bit), send new problem reports
 834   if ( $problems_reported && $changes_stats[ST_CTIME] < $upload_time ) {
 835     $problems_reported = 0;
 836     chmod +( $changes_stats[ST_MODE] &= ~S_ISGID ), $changes;
 837     debug("upload_time>changes-ctime => resetting problems reported");
 838   }
 839   debug("do_report=$do_report problems_reported=$problems_reported");
 840
 841   # now check all files for correct size and md5 sum
 842   for $file (@files) {
 843     my $filename = $file->{"name"};
 844     if ( !defined( $file->{"stats"} ) ) {
 845
 846       # could be an upload that isn't complete yet, be quiet,
 847       # but don't process the file;
 848       msg( "log,mail", "$filename doesn't exist\n" )
 849         if $do_report && !$problems_reported;
 850       msg( "log", "$filename doesn't exist (ignored for now)\n" )
 851         if !$do_report;
 852       msg( "log", "$filename doesn't exist (already reported)\n" )
 853         if $problems_reported;
 854       ++$errs;
 855     } elsif ( $file->{"stats"}->[ST_SIZE] < $file->{"size"}
 856               && !$do_report )
 857     {
 858
 859       # could be an upload that isn't complete yet, be quiet,
 860       # but don't process the file
 861       msg( "log", "$filename is too small (ignored for now)\n" );
 862       ++$errs;
 863     } elsif ( $file->{"stats"}->[ST_SIZE] != $file->{"size"} ) {
 864       msg( "log,mail", "$filename has incorrect size; deleting it\n" );
 865       rm($filename);
 866       ++$errs;
 867     } elsif ( md5sum($filename) ne $file->{"md5"} ) {
 868       msg( "log,mail",
 869            "$filename has incorrect md5 checksum; ",
 870            "deleting it\n" );
 871       rm($filename);
 872       ++$errs;
 873     } ## end elsif ( md5sum($filename)...
 874   } ## end for $file (@files)
 875
 876   if ($errs) {
 877     if ( ( time - $upload_time ) > $conf::bad_changes_timeout ) {
 878
 879       # if a .changes fails for a really long time (several days
 880       # or so), remove it and all associated files
 881       msg(
 882           "log,mail",
 883           "$main::current_incoming_short/$changes couldn't be processed for ",
 884           int( $conf::bad_changes_timeout / ( 60 * 60 ) ),
 885           " hours and is now deleted\n"
 886          );
 887       msg( "log,mail", "All files it mentions are also removed:\n" );
 888       msg( "log,mail", "  ", join( ", ", @filenames ), "\n" );
 889       rm( $changes, @filenames, $failure_file );
 890     } elsif ( $do_report && !$problems_reported ) {
 891
 892       # otherwise, send a problem report, if not done already
 893       msg(
 894            "mail",
 895            "Due to the errors above, the .changes file couldn't ",
 896            "be processed.\n",
 897            "Please fix the problems for the upload to happen.\n"
 898          );
 899
 900       # remember we already have sent a mail regarding this file
 901       debug("Sending problem report mail and setting SGID bit");
 902       my $mode = $changes_stats[ST_MODE] |= S_ISGID;
 903       msg( "log", "chmod failed: $!" )
 904         if ( chmod( $mode, $changes ) != 1 );
 905     } ## end elsif ( $do_report && !$problems_reported)
 906
 907     # else: be quiet
 908
 909     return;
 910   } ## end if ($errs)
 911
 912   # if this upload already failed earlier, wait until the delay requirement
 913   # is fulfilled
 914   if ( $retries > 0
 915        && ( time - $last_retry ) <
 916        ( $retries == 1 ? $conf::upload_delay_1 : $conf::upload_delay_2 ) )
 917   {
 918     msg( "log", "delaying retry of upload\n" );
 919     return;
 920   } ## end if ( $retries > 0 && (...
 921
 922   if ( $conf::upload_method eq "ftp" ) {
 923     return if !ftp_open();
 924   }
 925
 926   # check if the job is already present on target
 927   # (moved to here, to avoid bothering target as long as there are errors in
 928   # the job)
 929   if ( $ls_l = is_on_target( $changes, @filenames ) ) {
 930     msg(
 931       "log,mail",
 932 "$main::current_incoming_short/$changes is already present on target host:\n"
 933     );
 934     msg( "log,mail", "$ls_l\n" );
 935     msg( "mail",
 936          "Either you already uploaded it, or someone else ",
 937          "came first.\n" );
 938     msg( "log,mail", "Job $changes removed.\n" );
 939     rm( $changes, @filenames, $failure_file );
 940     return;
 941   } ## end if ( $ls_l = is_on_target...
 942
 943   # clear sgid bit before upload, scp would copy it to target. We don't need
 944   # it anymore, we know there are no problems if we come here. Also change
 945   # mode of files to 644 if this should be done locally.
 946   $changes_stats[ST_MODE] &= ~S_ISGID;
 947   if ( !$conf::chmod_on_target ) {
 948     $changes_stats[ST_MODE] &= ~0777;
 949     $changes_stats[ST_MODE] |= 0644;
 950   }
 951   chmod +( $changes_stats[ST_MODE] ), $changes;
 952
 953   # try uploading to target
 954   if ( !copy_to_target( $changes, @filenames ) ) {
 955
 956     # if the upload failed, increment the retry counter and remember the
 957     # current time; both things are written to the .failures file. Don't
 958     # increment the fail counter if the error was due to incoming
 959     # unwritable.
 960     return if !$main::incoming_writable;
 961     if ( ++$retries >= $conf::max_upload_retries ) {
 962       msg( "log,mail",
 963            "$changes couldn't be uploaded for $retries times now.\n" );
 964       msg( "log,mail",
 965            "Giving up and removing it and its associated files:\n" );
 966       msg( "log,mail", "  ", join( ", ", @filenames ), "\n" );
 967       rm( $changes, @filenames, $failure_file );
 968     } else {
 969       $last_retry = time;
 970       if ( open( FAILS, ">", $failure_file ) ) {
 971         print FAILS "$retries $last_retry\n";
 972         close(FAILS);
 973         chmod( 0600, $failure_file )
 974           or die "Cannot set modes of $failure_file: $!\n";
 975       } ## end if ( open( FAILS, ">$failure_file"...
 976       push( @$keep_list, $failure_file );
 977       debug("now $retries failed uploads");
 978       msg(
 979            "mail",
 980            "The upload will be retried in ",
 981            print_time(
 982                          $retries == 1
 983                        ? $conf::upload_delay_1
 984                        : $conf::upload_delay_2
 985                      ),
 986            "\n"
 987          );
 988     } ## end else [ if ( ++$retries >= $conf::max_upload_retries)
 989     return;
 990   } ## end if ( !copy_to_target( ...
 991
 992   # If the files were uploaded ok, remove them
 993   rm( $changes, @filenames, $failure_file );
 994
 995   msg( "mail", "$changes uploaded successfully to $conf::target\n" );
 996   msg( "mail", "along with the files:\n  ", join( "\n  ", @filenames ),
 997        "\n" );
 998   msg( "log",
 999        "$changes processed successfully (uploader $main::mail_addr)\n" );
1000
1001   return;
1002
1003   remove_only_changes:
1004   msg(
1005     "log,mail",
1006     "Removing $main::current_incoming_short/$changes, but keeping its "
1007     . "associated files for now.\n"
1008     );
1009   rm($changes);
1010   return;
1011
1012   # Check for files that have the same stem as the .changes (and weren't
1013   # mentioned there) and delete them. It happens often enough that people
1014   # upload a .orig.tar.gz where it isn't needed and also not in the
1015   # .changes. Explicitly deleting it (and not waiting for the
1016   # $stray_remove_timeout) reduces clutter in the queue dir and maybe also
1017   # educates uploaders :-)
1018
1019   #     my $pattern = debian_file_stem( $changes );
1020   #     my $spattern = substr( $pattern, 0, -1 ); # strip off '*' at end
1021   #     my @other_files = glob($pattern);
1022   # filter out files that have a Debian revision at all and a different
1023   # revision. Those belong to a different upload.
1024   #     if ($changes =~ /^\Q$spattern\E-([\d.+-]+)/) {
1025   #             my $this_rev = $1;
1026   #             @other_files = grep( !/^\Q$spattern\E-([\d.+-]+)/ || $1 eq $this_rev,
1027   #                                                      @other_files);
1028   #}
1029   # Also do not remove those files if a .changes is among them. Then there
1030   # is probably a second upload for another version or another architecture.
1031   #     if (@other_files && !grep( /\.changes$/, @other_files )) {
1032   #             rm( @other_files );
1033   #             msg( "mail", "\nThe following file(s) seemed to belong to the same ".
1034   #                                      "upload, but weren't listed\n" );
1035   #             msg( "mail", "in the .changes file:\n  " );
1036   #             msg( "mail", join( "\n  ", @other_files ), "\n" );
1037   #             msg( "mail", "They have been deleted.\n" );
1038   #             msg( "log", "Deleted files in upload not in $changes: @other_files\n" );
1039   #}
1040 } ## end sub process_changes($\@)
1041
1042 #
1043 # process one .dak-commands file
1044 #
1045 sub process_dak_commands {
1046   my $commands = shift;
1047
1048   msg("log", "processing ${main::current_incoming_short}/$commands\n");
1049
1050   # TODO: get mail address from signed contents
1051   # and NOT implement a third parser for armored PGP...
1052   $main::mail_addr = undef;
1053
1054   # check signature
1055   my $signator = pgp_check($commands);
1056   if (!$signator) {
1057         msg("log,mail",
1058             "$main::current_incoming_short/$commands has bad PGP/GnuPG signature!\n");
1059         msg("log,mail",
1060                 "Removing $main::current_incoming_short/$commands\n");
1061         rm($commands);
1062         return;
1063   }
1064   elsif ($signator eq 'LOCAL ERROR') {
1065         debug("Can't check signature for $main::current_incoming_short/$commands -- don't process it for now");
1066         return;
1067   }
1068   msg("log,mail", "(PGP/GnuPG signature by $signator)\n");
1069
1070   # check target
1071   my @filenames = ($commands);
1072   if (my $ls_l = is_on_target($commands, @filenames)) {
1073         msg("log,mail", "$main::current_incoming_short/$commands is already present on target host:\n");
1074         msg("log,mail", "$ls_l\n");
1075         msg("log,mail", "Job $commands removed.\n");
1076         rm($commands);
1077         return;
1078   }
1079
1080   if (!copy_to_target($commands)) {
1081         msg("log,mail", "$commands couldn't be uploaded to target.\n");
1082         msg("log,mail", "Giving up and removing it.\n");
1083         rm($commands);
1084         return;
1085   }
1086
1087   rm($commands);
1088   msg("mail", "$commands uploaded successfully to $conf::target\n");
1089 }
1090
1091 #
1092 # process one .commands file
1093 #
1094 sub process_commands($) {
1095   my $commands = shift;
1096   my ( @cmds, $cmd, $pgplines, $signator );
1097   local (*COMMANDS);
1098   my ( @files, $file, @removed, $target_delay );
1099
1100   format_status_str( $main::current_changes, $commands );
1101   $main::dstat = "c";
1102   $main::mail_addr = "";
1103   write_status_file() if $conf::statusdelay;
1104
1105   msg( "log", "processing $main::current_incoming_short/$commands\n" );
1106
1107   # run PGP on the file to check the signature
1108   if ( !( $signator = pgp_check($commands) ) ) {
1109     msg(
1110       "log,mail",
1111       "$main::current_incoming_short/$commands has bad PGP/GnuPG signature!\n"
1112     );
1113     goto remove;
1114   } elsif ( $signator eq "LOCAL ERROR" ) {
1115
1116     # An error has appened when starting pgp... Don't process the file,
1117     # but also don't delete it
1118     debug(
1119 "Can't PGP/GnuPG check $main::current_incoming_short/$commands -- don't process it for now"
1120     );
1121     return;
1122   } ## end elsif ( $signator eq "LOCAL ERROR")
1123   msg( "log", "(PGP/GnuPG signature by $signator)\n" );
1124
1125   # parse the .commands file
1126   if ( !open( COMMANDS, "<", $commands ) ) {
1127     msg( "log", "Cannot open $main::current_incoming_short/$commands: $!\n" );
1128     return;
1129   }
1130   $pgplines        = 0;
1131   @cmds            = ();
1132 outer_loop: while (<COMMANDS>) {
1133     if (/^---+(BEGIN|END) PGP .*---+$/) {
1134       ++$pgplines;
1135     } elsif (/^Uploader:\s*/i) {
1136       chomp( $main::mail_addr = $' );
1137       $main::mail_addr = $1 if $main::mail_addr =~ /<([^>]*)>/;
1138     } elsif (/^Commands:/i) {
1139       $_ = $';
1140       for ( ; ; ) {
1141         s/^\s*(.*)\s*$/$1/;    # delete whitespace at both ends
1142         if ( !/^\s*$/ ) {
1143           push( @cmds, $_ );
1144           debug("includes cmd $_");
1145         }
1146         last outer_loop if !defined( $_ = scalar(<COMMANDS>) );
1147         chomp;
1148         redo outer_loop if !/^\s/ || /^$/;
1149       } ## end for ( ; ; )
1150     } ## end elsif (/^Commands:/i)
1151   } ## end while (<COMMANDS>)
1152   close(COMMANDS);
1153
1154   # some consistency checks
1155   if ( !$main::mail_addr || $main::mail_addr !~ /^\S+\@\S+\.\S+/ ) {
1156     msg( "log,mail",
1157 "$main::current_incoming_short/$commands contains no or bad Uploader: field: "
1158         . "$main::mail_addr\n" );
1159     msg( "log,mail",
1160          "cannot process $main::current_incoming_short/$commands\n" );
1161     $main::mail_addr = "";
1162     goto remove;
1163   } ## end if ( !$main::mail_addr...
1164   msg( "log", "(command uploader $main::mail_addr)\n" );
1165
1166   if ( $pgplines < 3 ) {
1167     msg(
1168        "log,mail",
1169        "$main::current_incoming_short/$commands isn't signed with PGP/GnuPG\n"
1170     );
1171     msg(
1172       "mail",
1173       "or the uploaded file is broken. Make sure to transfer in binary mode\n"
1174     );
1175     msg( "mail", "or better yet - use dcut for commands files\n" );
1176     goto remove;
1177   } ## end if ( $pgplines < 3 )
1178
1179   # now process commands
1180   msg(
1181     "mail",
1182 "Log of processing your commands file $main::current_incoming_short/$commands:\n\n"
1183   );
1184   foreach $cmd (@cmds) {
1185     my @word = split( /\s+/, $cmd );
1186     msg( "mail,log", "> @word\n" );
1187     my $selecteddelayed = -1;
1188     next if @word < 1;
1189
1190     if ( $word[0] eq "rm" ) {
1191       foreach ( @word[ 1 .. $#word ] ) {
1192         my $origword = $_;
1193         if (m,^DELAYED/([0-9]+)-day/,) {
1194           $selecteddelayed = $1;
1195           s,^DELAYED/[0-9]+-day/,,;
1196         }
1197         if (m,(^|/)\*,) {
1198           msg("mail,log", "$_: filename component cannot start with a wildcard\n");
1199         } elsif ( $origword eq "--searchdirs" ) {
1200           $selecteddelayed = -2;
1201         } elsif (m,/,) {
1202           msg(
1203             "mail,log",
1204 "$_: filename may not contain slashes except for DELAYED/#-day/ prefixes\n"
1205           );
1206         } else {
1207
1208           # process wildcards but also plain names
1209           my (@thesefiles);
1210           my $pat = quotemeta($_);
1211           $pat =~ s/\\\*/.*/g;
1212           $pat =~ s/\\\?/.?/g;
1213           $pat =~ s/\\([][])/$1/g;
1214
1215           if ( $selecteddelayed < 0 ) {    # scanning or explicitly incoming
1216             opendir( DIR, "." );
1217             push( @thesefiles, grep /^$pat$/, readdir(DIR) );
1218             closedir(DIR);
1219           }
1220           if ( $selecteddelayed >= 0 ) {
1221             my $dir = sprintf( $conf::incoming_delayed, $selecteddelayed );
1222             opendir( DIR, $dir );
1223             push( @thesefiles,
1224                   map ( "$dir/$_", grep /^$pat$/, readdir(DIR) ) );
1225             closedir(DIR);
1226           } elsif ( $selecteddelayed == -2 ) {
1227             for ( my ($adelay) = 0 ;
1228                   ( !@thesefiles ) && $adelay <= $conf::max_delayed ;
1229                   $adelay++ )
1230             {
1231               my $dir = sprintf( $conf::incoming_delayed, $adelay );
1232               opendir( DIR, $dir );
1233               push( @thesefiles,
1234                     map ( "$dir/$_", grep /^$pat$/, readdir(DIR) ) );
1235               closedir(DIR);
1236             } ## end for ( my ($adelay) = 0 ...
1237           } ## end elsif ( $selecteddelayed ...
1238           push( @files, @thesefiles );
1239           if ( !@thesefiles ) {
1240             msg( "mail,log", "$origword did not match anything\n" );
1241           }
1242         } ## end else [ if ( $origword eq "--searchdirs")
1243       } ## end foreach ( @word[ 1 .. $#word...
1244       if ( !@files ) {
1245         msg( "mail,log", "No files to delete\n" );
1246       } else {
1247         @removed = ();
1248         foreach $file (@files) {
1249           if ( !-f $file ) {
1250             msg( "mail,log", "$file: no such file\n" );
1251           } elsif ( $file =~ /$conf::keep_files/ ) {
1252             msg( "mail,log", "$file is protected, cannot " . "remove\n" );
1253           } elsif ( !unlink($file) ) {
1254             msg( "mail,log", "$file: rm: $!\n" );
1255           } else {
1256             $file =~ s,$conf::incoming/?,,;
1257             push( @removed, $file );
1258           }
1259         } ## end foreach $file (@files)
1260         msg( "mail,log", "Files removed: @removed\n" ) if @removed;
1261       } ## end else [ if ( !@files )
1262     } elsif ( $word[0] eq "reschedule" ) {
1263       if ( @word != 3 ) {
1264         msg( "mail,log", "Wrong number of arguments\n" );
1265       } elsif ( $conf::upload_method ne "copy" ) {
1266         msg( "mail,log", "reschedule not available\n" );
1267       } elsif ( $word[1] =~ m,/, || $word[1] !~ m/\.changes/ ) {
1268         msg(
1269            "mail,log",
1270            "$word[1]: filename may not contain slashes and must be .changes\n"
1271         );
1272       } elsif ( !( ($target_delay) = $word[2] =~ m,^([0-9]+)-day$, )
1273                 || $target_delay > $conf::max_delayed )
1274       {
1275         msg(
1276           "mail,log",
1277 "$word[2]: rescheduling target must be #-day with # between 0 and $conf::max_delayed (in particular, no '/' allowed)\n"
1278         );
1279       } elsif ( $word[1] =~ /$conf::keep_files/ ) {
1280         msg( "mail,log", "$word[1] is protected, cannot do stuff with it\n" );
1281       } else {
1282         my ($adelay);
1283         for ( $adelay = 0 ;
1284             $adelay <= $conf::max_delayed
1285             && !-f (
1286               sprintf( "$conf::targetdir_delayed", $adelay ) . "/$word[1]" ) ;
1287             $adelay++ )
1288         {
1289         } ## end for ( $adelay = 0 ; $adelay...
1290         if ( $adelay > $conf::max_delayed ) {
1291           msg( "mail,log", "$word[1] not found\n" );
1292         } elsif ( $adelay == $target_delay ) {
1293           msg( "mail,log", "$word[1] already is in $word[2]\n" );
1294         } else {
1295           my (@thesefiles);
1296           my ($dir) = sprintf( "$conf::targetdir_delayed", $adelay );
1297           my ($target_dir) =
1298             sprintf( "$conf::targetdir_delayed", $target_delay );
1299           push( @thesefiles, $word[1] );
1300           push( @thesefiles,
1301                 get_filelist_from_known_good_changes("$dir/$word[1]") );
1302           for my $afile (@thesefiles) {
1303             if ( $afile =~ m/\.changes$/ ) {
1304               utime undef, undef, ("$dir/$afile");
1305             }
1306             if ( !move("$dir/$afile", "$target_dir/$afile") ) {
1307               msg( "mail,log", "move: $!\n" );
1308             } else {
1309               msg( "mail,log", "$afile moved to $target_delay-day\n" );
1310             }
1311           } ## end for my $afile (@thesefiles)
1312         } ## end else [ if ( $adelay > $conf::max_delayed)
1313       } ## end else [ if ( @word != 3 )
1314     } elsif ( $word[0] eq "cancel" ) {
1315       if ( @word != 2 ) {
1316         msg( "mail,log", "Wrong number of arguments\n" );
1317       } elsif ( $conf::upload_method ne "copy" ) {
1318         msg( "mail,log", "cancel not available\n" );
1319       } elsif (
1320           $word[1] !~ m,$re_file_safe_prefix\.changes\z, )
1321       {
1322         msg( "mail,log",
1323           "argument to cancel must be one .changes filename without path\n" );
1324       } ## end elsif ( $word[1] !~ ...
1325       my (@files) = ();
1326       for ( my ($adelay) = 0 ; $adelay <= $conf::max_delayed ; $adelay++ ) {
1327         my ($dir) = sprintf( "$conf::targetdir_delayed", $adelay );
1328         if ( -f "$dir/$word[1]" ) {
1329           @removed = ();
1330           push( @files, "$word[1]" );
1331           push( @files,
1332                 get_filelist_from_known_good_changes("$dir/$word[1]") );
1333           foreach $file (@files) {
1334             if ( !-f "$dir/$file" ) {
1335               msg( "mail,log", "$dir/$file: no such file\n" );
1336             } elsif ( "$dir/$file" =~ /$conf::keep_files/ ) {
1337               msg( "mail,log",
1338                    "$dir/$file is protected, cannot " . "remove\n" );
1339             } elsif ( !unlink("$dir/$file") ) {
1340               msg( "mail,log", "$dir/$file: rm: $!\n" );
1341             } else {
1342               push( @removed, $file );
1343             }
1344           } ## end foreach $file (@files)
1345           msg( "mail,log", "Files removed from $adelay-day: @removed\n" )
1346             if @removed;
1347         } ## end if ( -f "$dir/$word[1]")
1348       } ## end for ( my ($adelay) = 0 ...
1349       if ( !@files ) {
1350         msg( "mail,log", "No upload found: $word[1]\n" );
1351       }
1352     } else {
1353       msg( "mail,log", "unknown command $word[0]\n" );
1354     }
1355   } ## end foreach $cmd (@cmds)
1356   rm($commands);
1357   msg( "log",
1358        "-- End of $main::current_incoming_short/$commands processing\n" );
1359   return;
1360
1361   remove:
1362   msg("log,mail", "Removing $main::current_incoming_short/$commands\n");
1363   rm($commands);
1364   return;
1365 } ## end sub process_commands($)
1366
1367 sub age_delayed_queues() {
1368   for ( my ($adelay) = 0 ; $adelay <= $conf::max_delayed ; $adelay++ ) {
1369     my ($dir) = sprintf( "$conf::targetdir_delayed", $adelay );
1370     my ($target_dir);
1371     if ( $adelay == 0 ) {
1372       $target_dir = $conf::targetdir;
1373     } else {
1374       $target_dir = sprintf( "$conf::targetdir_delayed", $adelay - 1 );
1375     }
1376     for my $achanges (<$dir/*.changes>) {
1377       my $mtime = ( stat($achanges) )[9];
1378       if ( $mtime + 24 * 60 * 60 <= time || $adelay == 0 ) {
1379         utime undef, undef, ($achanges);
1380         my @thesefiles = ( $achanges =~ m,.*/([^/]*), );
1381         push( @thesefiles, get_filelist_from_known_good_changes($achanges) );
1382         for my $afile (@thesefiles) {
1383           if ( !move("$dir/$afile", "$target_dir/$afile") ) {
1384             msg( "log", "move: $!\n" );
1385           } else {
1386             msg( "log", "$afile moved to $target_dir\n" );
1387           }
1388         } ## end for my $afile (@thesefiles)
1389       } ## end if ( $mtime + 24 * 60 ...
1390     } ## end for my $achanges (<$dir/*.changes>)
1391   } ## end for ( my ($adelay) = 0 ...
1392 } ## end sub age_delayed_queues()
1393
1394 #
1395 # check if a file is already on target
1396 #
1397 sub is_on_target($\@) {
1398   my $file     = shift;
1399   my $filelist = shift;
1400   my $msg;
1401   my $stat;
1402
1403   if ( $conf::upload_method eq "ssh" ) {
1404     ( $msg, $stat ) = ssh_cmd("ls -l $file");
1405   } elsif ( $conf::upload_method eq "ftp" ) {
1406     my $err;
1407     ( $msg, $err ) = ftp_cmd( "dir", $file );
1408     if ($err) {
1409       $stat = 1;
1410       $msg  = $err;
1411     } elsif ( !$msg ) {
1412       $stat = 1;
1413       $msg  = "ls: no such file\n";
1414     } else {
1415       $stat = 0;
1416       $msg = join( "\n", @$msg );
1417     }
1418   } else {
1419     my @allfiles = ($file);
1420     push( @allfiles, @$filelist );
1421     $stat = 1;
1422     $msg  = "no such file";
1423     for my $afile (@allfiles) {
1424       if ( -f "$conf::targetdir/$afile" ) {
1425         $stat = 0;
1426         $msg  = "$afile";
1427       }
1428     } ## end for my $afile (@allfiles)
1429     for ( my ($adelay) = 0 ;
1430           $adelay <= $conf::max_delayed && $stat ;
1431           $adelay++ )
1432     {
1433       for my $afile (@allfiles) {
1434         if (
1435            -f ( sprintf( "$conf::targetdir_delayed", $adelay ) . "/$afile" ) )
1436         {
1437           $stat = 0;
1438           $msg = sprintf( "%d-day", $adelay ) . "/$afile";
1439         } ## end if ( -f ( sprintf( "$conf::targetdir_delayed"...
1440       } ## end for my $afile (@allfiles)
1441     } ## end for ( my ($adelay) = 0 ...
1442   } ## end else [ if ( $conf::upload_method...
1443   chomp($msg);
1444   debug("exit status: $stat, output was: $msg");
1445
1446   return "" if $stat && $msg =~ /no such file/i;    # file not present
1447   msg( "log", "strange ls -l output on target:\n", $msg ), return ""
1448     if $stat || $@;    # some other error, but still try to upload
1449
1450   # ls -l returned 0 -> file already there
1451   $msg =~ s/\s\s+/ /g;    # make multiple spaces into one, to save space
1452   return $msg;
1453 } ## end sub is_on_target($\@)
1454
1455 #
1456 # copy a list of files to target
1457 #
1458 sub copy_to_target(@) {
1459   my @files = @_;
1460   my ( @md5sum, @expected_files, $sum, $name, $msgs, $stat );
1461
1462   $main::dstat = "u";
1463   write_status_file() if $conf::statusdelay;
1464
1465   # copy the files
1466   if ( $conf::upload_method eq "ssh" ) {
1467     ( $msgs, $stat ) = scp_cmd(@files);
1468     goto err if $stat;
1469   } elsif ( $conf::upload_method eq "ftp" ) {
1470     my ( $rv, $file );
1471     if ( !$main::FTP_chan->cwd($main::current_targetdir) ) {
1472       msg( "log,mail",
1473            "Can't cd to $main::current_targetdir on $conf::target\n" );
1474       goto err;
1475     }
1476     foreach $file (@files) {
1477       ( $rv, $msgs ) = ftp_cmd( "put", $file );
1478       goto err if !$rv;
1479     }
1480   } else {
1481     for my $file (@files) {
1482       eval { File::Copy::copy($file, $main::current_targetdir) };
1483       if ($@) {
1484         $stat = 1;
1485         $msgs = $@;
1486         goto err;
1487       }
1488     }
1489   }
1490
1491   # check md5sums or sizes on target against our own
1492   my $have_md5sums = 1;
1493   if ($conf::check_md5sum) {
1494     if ( $conf::upload_method eq "ssh" ) {
1495       ( $msgs, $stat ) = ssh_cmd("md5sum @files");
1496       goto err if $stat;
1497       @md5sum = split( "\n", $msgs );
1498     } elsif ( $conf::upload_method eq "ftp" ) {
1499       my ( $rv, $err, $file );
1500       foreach $file (@files) {
1501         ( $rv, $err ) = ftp_cmd( "quot", "site", "md5sum", $file );
1502         if ($err) {
1503           next if ftp_code() == 550;    # file not found
1504           if ( ftp_code() == 500 ) {    # unimplemented
1505             $have_md5sums = 0;
1506             goto get_sizes_instead;
1507           }
1508           $msgs = $err;
1509           goto err;
1510         } ## end if ($err)
1511         chomp( my $t = ftp_response() );
1512         push( @md5sum, $t );
1513       } ## end foreach $file (@files)
1514       if ( !$have_md5sums ) {
1515       get_sizes_instead:
1516         foreach $file (@files) {
1517           ( $rv, $err ) = ftp_cmd( "size", $file );
1518           if ($err) {
1519             next if ftp_code() == 550;    # file not found
1520             $msgs = $err;
1521             goto err;
1522           }
1523           push( @md5sum, "$rv $file" );
1524         } ## end foreach $file (@files)
1525       } ## end if ( !$have_md5sums )
1526     } else {
1527       for my $file (@files) {
1528         my $md5 = eval { md5sum("$main::current_targetdir/$file") };
1529         if ($@) {
1530           $msgs = $@;
1531           goto err;
1532         }
1533         push @md5sum, "$md5 $file" if $md5;
1534       }
1535     }
1536
1537     @expected_files = @files;
1538     foreach (@md5sum) {
1539       chomp;
1540       ( $sum, $name ) = split;
1541       next if !grep { $_ eq $name } @files;    # a file we didn't upload??
1542       next if $sum eq "md5sum:";               # looks like an error message
1543       if (    ( $have_md5sums && $sum ne md5sum($name) )
1544            || ( !$have_md5sums && $sum != ( -s $name ) ) )
1545       {
1546         msg(
1547              "log,mail",
1548              "Upload of $name to $conf::target failed ",
1549              "(" . ( $have_md5sums ? "md5sum" : "size" ) . " mismatch)\n"
1550            );
1551         goto err;
1552       } ## end if ( ( $have_md5sums &&...
1553
1554       # seen that file, remove it from expect list
1555       @expected_files = map { $_ eq $name ? () : $_ } @expected_files;
1556     } ## end foreach (@md5sum)
1557     if (@expected_files) {
1558       msg( "log,mail", "Failed to upload the files\n" );
1559       msg( "log,mail", "  ", join( ", ", @expected_files ), "\n" );
1560       msg( "log,mail", "(Not present on target after upload)\n" );
1561       goto err;
1562     } ## end if (@expected_files)
1563   } ## end if ($conf::check_md5sum)
1564
1565   if ($conf::chmod_on_target) {
1566
1567     # change file's mode explicitly to 644 on target
1568     if ( $conf::upload_method eq "ssh" ) {
1569       ( $msgs, $stat ) = ssh_cmd("chmod 644 @files");
1570       goto err if $stat;
1571     } elsif ( $conf::upload_method eq "ftp" ) {
1572       my ( $rv, $file );
1573       foreach $file (@files) {
1574         ( $rv, $msgs ) = ftp_cmd( "quot", "site", "chmod", "644", $file );
1575         msg( "log", "Can't chmod $file on target:\n$msgs" )
1576           if $msgs;
1577         goto err if !$rv;
1578       } ## end foreach $file (@files)
1579     } else {
1580       for my $file (@files) {
1581         unless (chmod 0644, "$main::current_targetdir/$file") {
1582           $msgs = "Could not chmod $file: $!";
1583           goto err;
1584         }
1585       }
1586     }
1587   } ## end if ($conf::chmod_on_target)
1588
1589   $main::dstat = "c";
1590   write_status_file() if $conf::statusdelay;
1591   return 1;
1592
1593 err:
1594   msg( "log,mail",
1595        "Upload to $conf::target failed",
1596        $? ? ", last exit status " . sprintf( "%s", $? >> 8 ) : "", "\n" );
1597   msg( "log,mail", "Error messages:\n", $msgs )
1598     if $msgs;
1599
1600   # If "permission denied" was among the errors, test if the incoming is
1601   # writable at all.
1602   if ( $msgs && $msgs =~ /(permission denied|read-?only file)/i ) {
1603     if ( !check_incoming_writable() ) {
1604       msg( "log,mail", "(The incoming directory seems to be ",
1605            "unwritable.)\n" );
1606     }
1607   } ## end if ( $msgs =~ /(permission denied|read-?only file)/i)
1608
1609   # remove bad files or an incomplete upload on target
1610   if ( $conf::upload_method eq "ssh" ) {
1611     ssh_cmd("rm -f @files");
1612   } elsif ( $conf::upload_method eq "ftp" ) {
1613     my $file;
1614     foreach $file (@files) {
1615       my ( $rv, $err );
1616       ( $rv, $err ) = ftp_cmd( "delete", $file );
1617       msg( "log", "Can't delete $file on target:\n$err" )
1618         if $err;
1619     } ## end foreach $file (@files)
1620   } else {
1621     my @tfiles = map { "$main::current_targetdir/$_" } @files;
1622     debug("executing unlink(@tfiles)");
1623     rm(@tfiles);
1624   }
1625   $main::dstat = "c";
1626   write_status_file() if $conf::statusdelay;
1627   return 0;
1628 } ## end sub copy_to_target(@)
1629
1630 #
1631 # check if a file is correctly signed with PGP
1632 #
1633 sub pgp_check($) {
1634   my $file   = shift;
1635   my $output = "";
1636   my $signator;
1637   my $found = 0;
1638   my $stat = 1;
1639   local (*PIPE);
1640   local $_;
1641
1642   if ($file =~ /$re_file_safe/) {
1643     $file = $1;
1644   } else {
1645     msg( "log", "Tainted filename, skipping: $file\n" );
1646     return "LOCAL ERROR";
1647   }
1648
1649   # check the file has only one clear-signed section
1650   my $fh;
1651   unless (open $fh, "<", $file) {
1652           msg("log,mail", "Could not open $file\n");
1653           return "";
1654   }
1655   unless (<$fh> eq "-----BEGIN PGP SIGNED MESSAGE-----\n") {
1656           msg("log,mail", "$file: does not start with a clearsigned message\n");
1657           return "";
1658   }
1659   my $pgplines = 1;
1660   while (<$fh>) {
1661           if (/\A- /) {
1662                   msg("log,mail", "$file: dash-escaped messages are not accepted\n");
1663                   return "";
1664           }
1665           elsif ($_ eq "-----BEGIN PGP SIGNATURE-----\n"
1666                      || $_ eq "-----END PGP SIGNATURE-----\n") {
1667                   $pgplines++;
1668           }
1669           elsif (/\A--/) {
1670                   msg("log,mail", "$file: unexpected OpenPGP armor\n");
1671                   return "";
1672           }
1673           elsif ($pgplines > 3 && /\S/) {
1674                   msg("log,mail", "$file: found text after end of signature\n");
1675                   return "";
1676           }
1677   }
1678   if ($pgplines != 3) {
1679           msg("log,mail", "$file: doesn't seem to be a valid clearsigned OpenPGP message\n");
1680           return "";
1681   }
1682   close $fh;
1683
1684   if ( -x $conf::gpg ) {
1685     my @command = ("$conf::gpg", "--no-options", "--batch", "--no-tty",
1686                    "--trust-model", "always", "--no-default-keyring",
1687                    (map +("--keyring" => $_), @conf::keyrings),
1688                    "--verify", "-");
1689     debug(   "executing " . join(" ", @command) );
1690
1691     my $child = open(PIPE, "-|");
1692     if (!defined($child)) {
1693       msg("log", "Can't open pipe to $conf::gpg: $!\n");
1694       return "LOCAL ERROR";
1695     }
1696     if ($child == 0) {
1697       unless (open(STDERR, ">&", \*STDOUT)) {
1698         print "Could not redirect STDERR.";
1699         exit(-1);
1700       }
1701       unless (open(STDIN, "<", $file)) {
1702         print "Could not open $file: $!";
1703         exit(-1);
1704       }
1705       { exec(@command) }; # BLOCK avoids warning about likely unreachable code
1706       print "Could not exec gpg: $!";
1707       exit(-1);
1708     }
1709
1710     $output .= $_ while (<PIPE>);
1711     close(PIPE);
1712     $stat = $?;
1713   } ## end if ( -x $conf::gpg )
1714
1715   if ($stat) {
1716     msg( "log,mail", "GnuPG signature check failed on $file\n" );
1717     msg( "mail",     $output );
1718     msg( "log,mail", "(Exit status ", $stat >> 8, ")\n" );
1719     return "";
1720   } ## end if ($stat)
1721
1722   $output =~ /^(gpg: )?good signature from (user )?"(.*)"\.?$/im;
1723   ( $signator = $3 ) ||= "unknown signator";
1724   if ($conf::debug) {
1725     debug("GnuPG signature ok (by $signator)");
1726   }
1727   return $signator;
1728 } ## end sub pgp_check($)
1729
1730 # ---------------------------------------------------------------------------
1731 #                                                         the status daemon
1732 # ---------------------------------------------------------------------------
1733
1734 #
1735 # fork a subprocess that watches the 'status' FIFO
1736 #
1737 # that process blocks until someone opens the FIFO, then sends a
1738 # signal (SIGUSR1) to the main process, expects
1739 #
1740 sub fork_statusd() {
1741   my $statusd_pid;
1742   my $main_pid = $$;
1743   my $errs;
1744   local (*STATFIFO);
1745
1746   $statusd_pid = open( STATUSD, "|-" );
1747   die "cannot fork: $!\n" if !defined($statusd_pid);
1748
1749   # parent just returns
1750   if ($statusd_pid) {
1751     msg( "log", "forked status daemon (pid $statusd_pid)\n" );
1752     return $statusd_pid;
1753   }
1754
1755   # child: the status FIFO daemon
1756
1757   # ignore SIGPIPE here, in case some closes the FIFO without completely
1758   # reading it
1759   $SIG{"PIPE"} = "IGNORE";
1760
1761   # also ignore SIGCLD, we don't want to inherit the restart-statusd handler
1762   # from our parent
1763   $SIG{"CHLD"} = "DEFAULT";
1764
1765   rm($conf::statusfile);
1766   $errs = `$conf::mkfifo $conf::statusfile`;
1767   die "$main::progname: cannot create named pipe $conf::statusfile: $errs"
1768     if $?;
1769   chmod( 0644, $conf::statusfile )
1770     or die "Cannot set modes of $conf::statusfile: $!\n";
1771
1772   # close log file, so that log rotating works
1773   close(LOG);
1774   close(STDOUT);
1775   close(STDERR);
1776
1777   while (1) {
1778     my ( $status, $mup, $incw, $ds, $next_run, $last_ping, $currch, $l );
1779
1780     # open the FIFO for writing; this blocks until someone (probably ftpd)
1781     # opens it for reading
1782     open( STATFIFO, ">", $conf::statusfile )
1783       or die "Cannot open $conf::statusfile\n";
1784     select(STATFIFO);
1785
1786     # tell main daemon to send us status infos
1787     kill( $main::signo{"USR1"}, $main_pid );
1788
1789     # get the infos from stdin; must loop until enough bytes received!
1790     my $expect_len = 3 + 2 * STATNUM_LEN + STATSTR_LEN;
1791     for ( $status = "" ; ( $l = length($status) ) < $expect_len ; ) {
1792       sysread( STDIN, $status, $expect_len - $l, $l );
1793     }
1794
1795     # disassemble the status byte stream
1796     my $pos = 0;
1797     foreach (
1798               [ mup       => 1 ],
1799               [ incw      => 1 ],
1800               [ ds        => 1 ],
1801               [ next_run  => STATNUM_LEN ],
1802               [ last_ping => STATNUM_LEN ],
1803               [ currch    => STATSTR_LEN ]
1804             )
1805     {
1806       eval "\$$_->[0] = substr( \$status, $pos, $_->[1] );";
1807       $pos += $_->[1];
1808     } ## end foreach ( [ mup => 1 ], [ incw...
1809     $currch =~ s/\n+//g;
1810
1811     print_status( $mup, $incw, $ds, $next_run, $last_ping, $currch );
1812     close(STATFIFO);
1813
1814     # This sleep is necessary so that we can't reopen the FIFO
1815     # immediately, in case the reader hasn't closed it yet if we get to
1816     # the open again. Is there a better solution for this??
1817     sleep 1;
1818   } ## end while (1)
1819 } ## end sub fork_statusd()
1820
1821 #
1822 # update the status file, in case we use a plain file and not a FIFO
1823 #
1824 sub write_status_file() {
1825
1826   return if !$conf::statusfile;
1827
1828   open( STATFILE, ">", $conf::statusfile )
1829     or ( msg( "log", "Could not open $conf::statusfile: $!\n" ), return );
1830   my $oldsel = select(STATFILE);
1831
1832   print_status(
1833                 $main::target_up,      $main::incoming_writable,
1834                 $main::dstat,          $main::next_run,
1835                 $main::last_ping_time, $main::current_changes
1836               );
1837
1838   select($oldsel);
1839   close(STATFILE);
1840 } ## end sub write_status_file()
1841
1842 sub print_status($$$$$$) {
1843   my $mup       = shift;
1844   my $incw      = shift;
1845   my $ds        = shift;
1846   my $next_run  = shift;
1847   my $last_ping = shift;
1848   my $currch    = shift;
1849   my $approx;
1850   my $version;
1851
1852   ( $version = 'Release: 0.9 $Revision: 1.51 $' ) =~ s/\$ ?//g;
1853   print "debianqueued $version\n";
1854
1855   $approx = $conf::statusdelay ? "approx. " : "";
1856
1857   if ( $mup eq "0" ) {
1858     print "$conf::target is down, queue pausing\n";
1859     return;
1860   } elsif ( $conf::upload_method ne "copy" ) {
1861     print "$conf::target seems to be up, last ping $approx",
1862       print_time( time - $last_ping ), " ago\n";
1863   }
1864
1865   if ( $incw eq "0" ) {
1866     print "The incoming directory is not writable, queue pausing\n";
1867     return;
1868   }
1869
1870   if ( $ds eq "i" ) {
1871     print "Next queue check in $approx", print_time( $next_run - time ), "\n";
1872     return;
1873   } elsif ( $ds eq "c" ) {
1874     print "Checking queue directory\n";
1875   } elsif ( $ds eq "u" ) {
1876     print "Uploading to $conf::target\n";
1877   } else {
1878     print "Bad status data from daemon: \"$mup$incw$ds\"\n";
1879     return;
1880   }
1881
1882   print "Current job is $currch\n" if $currch;
1883 } ## end sub print_status($$$$$$)
1884
1885 #
1886 # format a number for sending to statusd (fixed length STATNUM_LEN)
1887 #
1888 sub format_status_num(\$$) {
1889   my $varref = shift;
1890   my $num    = shift;
1891
1892   $$varref = sprintf "%" . STATNUM_LEN . "d", $num;
1893 } ## end sub format_status_num(\$$)
1894
1895 #
1896 # format a string for sending to statusd (fixed length STATSTR_LEN)
1897 #
1898 sub format_status_str(\$$) {
1899   my $varref = shift;
1900   my $str    = shift;
1901
1902   $$varref = substr( $str, 0, STATSTR_LEN );
1903   $$varref .= "\n" x ( STATSTR_LEN - length($$varref) );
1904 } ## end sub format_status_str(\$$)
1905
1906 #
1907 # send a status string to the status daemon
1908 #
1909 # Avoid all operations that could call malloc() here! Most libc
1910 # implementations aren't reentrant, so we may not call it from a
1911 # signal handler. So use only already-defined variables.
1912 #
1913 sub send_status() {
1914   local $! = 0;    # preserve errno
1915
1916   # re-setup handler, in case we have broken SysV signals
1917   $SIG{"USR1"} = \&send_status;
1918
1919   syswrite( STATUSD, $main::target_up,         1 );
1920   syswrite( STATUSD, $main::incoming_writable, 1 );
1921   syswrite( STATUSD, $main::dstat,             1 );
1922   syswrite( STATUSD, $main::next_run,          STATNUM_LEN );
1923   syswrite( STATUSD, $main::last_ping_time,    STATNUM_LEN );
1924   syswrite( STATUSD, $main::current_changes,   STATSTR_LEN );
1925 } ## end sub send_status()
1926
1927 # ---------------------------------------------------------------------------
1928 #                                                           FTP functions
1929 # ---------------------------------------------------------------------------
1930
1931 #
1932 # open FTP connection to target host if not already open
1933 #
1934 sub ftp_open() {
1935
1936   if ($main::FTP_chan) {
1937
1938     # is already open, but might have timed out; test with a cwd
1939     return $main::FTP_chan
1940       if $main::FTP_chan->cwd($main::current_targetdir);
1941
1942     # cwd didn't work, channel is closed, try to reopen it
1943     $main::FTP_chan = undef;
1944   } ## end if ($main::FTP_chan)
1945
1946   if (
1947        !(
1948           $main::FTP_chan =
1949           Net::FTP->new(
1950                          $conf::target,
1951                          Debug   => $conf::ftpdebug,
1952                          Timeout => $conf::ftptimeout,
1953                          Passive => 1,
1954                        )
1955         )
1956      )
1957   {
1958     msg( "log,mail", "Cannot open FTP server $conf::target\n" );
1959     goto err;
1960   } ## end if ( !( $main::FTP_chan...
1961   if ( !$main::FTP_chan->login() ) {
1962     msg( "log,mail", "Anonymous login on FTP server $conf::target failed\n" );
1963     goto err;
1964   }
1965   if ( !$main::FTP_chan->binary() ) {
1966     msg( "log,mail", "Can't set binary FTP mode on $conf::target\n" );
1967     goto err;
1968   }
1969   if ( !$main::FTP_chan->cwd($main::current_targetdir) ) {
1970     msg( "log,mail",
1971          "Can't cd to $main::current_targetdir on $conf::target\n" );
1972     goto err;
1973   }
1974   debug("opened FTP channel to $conf::target");
1975   return 1;
1976
1977 err:
1978   $main::FTP_chan = undef;
1979   return 0;
1980 } ## end sub ftp_open()
1981
1982 sub ftp_cmd($@) {
1983   my $cmd = shift;
1984   my ( $rv, $err );
1985   my $direct_resp_cmd = ( $cmd eq "quot" );
1986
1987   debug( "executing FTP::$cmd(" . join( ", ", @_ ) . ")" );
1988   $SIG{"ALRM"} = sub { die "timeout in FTP::$cmd\n" };
1989   alarm($conf::remote_timeout);
1990   eval { $rv = $main::FTP_chan->$cmd(@_); };
1991   alarm(0);
1992   $err = "";
1993   $rv = ( ftp_code() =~ /^2/ ) ? 1 : 0 if $direct_resp_cmd;
1994   if ($@) {
1995     $err = $@;
1996     undef $rv;
1997   } elsif ( !$rv ) {
1998     $err = ftp_response();
1999   }
2000   return ( $rv, $err );
2001 } ## end sub ftp_cmd($@)
2002
2003 sub ftp_close() {
2004   if ($main::FTP_chan) {
2005     $main::FTP_chan->quit();
2006     $main::FTP_chan = undef;
2007   }
2008   return 1;
2009 } ## end sub ftp_close()
2010
2011 sub ftp_response() {
2012   return join( '', @{ ${*$main::FTP_chan}{'net_cmd_resp'} } );
2013 }
2014
2015 sub ftp_code() {
2016   return ${*$main::FTP_chan}{'net_cmd_code'};
2017 }
2018
2019 sub ftp_error() {
2020   my $code = ftp_code();
2021   return ( $code =~ /^[45]/ ) ? 1 : 0;
2022 }
2023
2024 # ---------------------------------------------------------------------------
2025 #                                                         utility functions
2026 # ---------------------------------------------------------------------------
2027
2028 sub ssh_cmd($) {
2029   my $cmd = shift;
2030   my ( $msg, $stat );
2031
2032   my $ecmd = "$conf::ssh $conf::ssh_options $conf::target "
2033     . "-l $conf::targetlogin \'cd $main::current_targetdir; $cmd\'";
2034   debug("executing $ecmd");
2035   $SIG{"ALRM"} = sub { die "timeout in ssh command\n" };
2036   alarm($conf::remote_timeout);
2037   eval { $msg = `$ecmd 2>&1`; };
2038   alarm(0);
2039   if ($@) {
2040     $msg  = $@;
2041     $stat = 1;
2042   } else {
2043     $stat = $?;
2044   }
2045   return ( $msg, $stat );
2046 } ## end sub ssh_cmd($)
2047
2048 sub scp_cmd(@) {
2049   my ( $msg, $stat );
2050
2051   my $ecmd = "$conf::scp $conf::ssh_options @_ "
2052     . "$conf::targetlogin\@$conf::target:$main::current_targetdir";
2053   debug("executing $ecmd");
2054   $SIG{"ALRM"} = sub { die "timeout in scp\n" };
2055   alarm($conf::remote_timeout);
2056   eval { $msg = `$ecmd 2>&1`; };
2057   alarm(0);
2058   if ($@) {
2059     $msg  = $@;
2060     $stat = 1;
2061   } else {
2062     $stat = $?;
2063   }
2064   return ( $msg, $stat );
2065 } ## end sub scp_cmd(@)
2066
2067 #
2068 # check if target is alive (code stolen from Net::Ping.pm)
2069 #
2070 sub check_alive(;$) {
2071   my $timeout = shift;
2072   my ( $saddr, $ret, $target_ip );
2073   local (*PINGSOCK);
2074
2075   if ( $conf::upload_method eq "copy" ) {
2076     format_status_num( $main::last_ping_time, time );
2077     $main::target_up = 1;
2078     return;
2079   }
2080
2081   $timeout ||= 30;
2082
2083   if ( !( $target_ip = ( gethostbyname($conf::target) )[4] ) ) {
2084     msg( "log", "Cannot get IP address of $conf::target\n" );
2085     $ret = 0;
2086     goto out;
2087   }
2088   $saddr = pack( 'S n a4 x8', AF_INET, $main::echo_port, $target_ip );
2089   $SIG{'ALRM'} = sub { die };
2090   alarm($timeout);
2091
2092   $ret = $main::tcp_proto;    # avoid warnings about unused variable
2093   $ret = 0;
2094   eval <<'EOM' ;
2095     return unless socket( PINGSOCK, PF_INET, SOCK_STREAM, $main::tcp_proto );
2096     return unless connect( PINGSOCK, $saddr );
2097     $ret = 1;
2098 EOM
2099   alarm(0);
2100   close(PINGSOCK);
2101   msg( "log", "pinging $conf::target: " . ( $ret ? "ok" : "down" ) . "\n" );
2102 out:
2103   $main::target_up = $ret ? "1" : "0";
2104   format_status_num( $main::last_ping_time, time );
2105   write_status_file() if $conf::statusdelay;
2106 } ## end sub check_alive(;$)
2107
2108 #
2109 # check if incoming dir on target is writable
2110 #
2111 sub check_incoming_writable() {
2112   my $testfile = ".debianqueued-testfile";
2113   my ( $msg, $stat );
2114
2115   if ( $conf::upload_method eq "ssh" ) {
2116     ( $msg, $stat ) =
2117       ssh_cmd( "rm -f $testfile; touch $testfile; " . "rm -f $testfile" );
2118   } elsif ( $conf::upload_method eq "ftp" ) {
2119     my $file = "junk-for-writable-test-" . format_time();
2120     $file =~ s/[ :.]/-/g;
2121     local (*F);
2122     open( F, ">", $file );
2123     close(F);
2124     my $rv;
2125     ( $rv, $msg ) = ftp_cmd( "put", $file );
2126     $stat = 0;
2127     $msg = "" if !defined $msg;
2128     unlink $file;
2129     ftp_cmd( "delete", $file );
2130   } elsif ( $conf::upload_method eq "copy" ) {
2131     unless(POSIX::access($main::current_targetdir, &POSIX::W_OK)) {
2132       $msg = "No write access: $!";
2133       $stat = 1;
2134     }
2135   }
2136   chomp($msg);
2137   debug("exit status: $stat, output was: $msg");
2138
2139   if ( !$stat ) {
2140
2141     # change incoming_writable only if ssh didn't return an error
2142     $main::incoming_writable =
2143       ( $msg =~ /(permission denied|read-?only file|cannot create)/i )
2144       ? "0"
2145       : "1";
2146   } else {
2147     debug("local error, keeping old status");
2148   }
2149   debug("incoming_writable = $main::incoming_writable");
2150   write_status_file() if $conf::statusdelay;
2151   return $main::incoming_writable;
2152 } ## end sub check_incoming_writable()
2153
2154 #
2155 # remove a list of files, log failing ones
2156 #
2157 sub rm(@) {
2158   my $done = 0;
2159
2160   foreach (@_) {
2161     ( unlink $_ and ++$done )
2162       or $! == ENOENT
2163       or msg( "log", "Could not delete $_: $!\n" );
2164   }
2165   return $done;
2166 } ## end sub rm(@)
2167
2168 #
2169 # get md5 checksum of a file
2170 #
2171 sub md5sum($) {
2172   my $file = shift;
2173   my $md5 = Digest::MD5->new;
2174
2175   open my $fh, "<", $file or return "";
2176   $md5->addfile($fh);
2177   close $fh;
2178
2179   return $md5->hexdigest;
2180 } ## end sub md5sum($)
2181
2182 #
2183 # output a messages to several destinations
2184 #
2185 # first arg is a comma-separated list of destinations; valid are "log"
2186 # and "mail"; rest is stuff to be printed, just as with print
2187 #
2188 sub msg($@) {
2189   my @dest = split( ',', shift );
2190
2191   if ( grep /log/, @dest ) {
2192     my $now = format_time();
2193     print LOG "$now ", @_;
2194   }
2195
2196   if ( grep /mail/, @dest ) {
2197     $main::mail_text .= join( '', @_ );
2198   }
2199 } ## end sub msg($@)
2200
2201 #
2202 # print a debug messages, if $debug is true
2203 #
2204 sub debug(@) {
2205   return if !$conf::debug;
2206   my $now = format_time();
2207   print LOG "$now DEBUG ", @_, "\n";
2208 }
2209
2210 #
2211 # intialize the "mail" destination of msg() (this clears text,
2212 # address, subject, ...)
2213 #
2214 sub init_mail(;$) {
2215   my $file = shift;
2216
2217   $main::mail_addr    = "";
2218   $main::mail_text    = "";
2219   %main::packages     = ();
2220   $main::mail_subject = $file ? "Processing of $file" : "";
2221 } ## end sub init_mail(;$)
2222
2223 #
2224 # finalize mail to be sent from msg(): check if something present, and
2225 # then send out
2226 #
2227 sub finish_mail() {
2228
2229   debug("No mail for $main::mail_addr")
2230     if $main::mail_addr && !$main::mail_text;
2231   return unless $main::mail_addr && $main::mail_text;
2232
2233   if ( !send_mail( $main::mail_addr, $main::mail_subject, $main::mail_text ) )
2234   {
2235
2236     # store this mail in memory so it isn't lost if executing sendmail
2237     # failed.
2238     push(
2239           @main::stored_mails,
2240           {
2241             addr    => $main::mail_addr,
2242             subject => $main::mail_subject,
2243             text    => $main::mail_text
2244           }
2245         );
2246   } ## end if ( !send_mail( $main::mail_addr...
2247   init_mail();
2248
2249   # try to send out stored mails
2250   my $mailref;
2251   while ( $mailref = shift(@main::stored_mails) ) {
2252     if (
2253          !send_mail( $mailref->{'addr'}, $mailref->{'subject'},
2254                      $mailref->{'text'} )
2255        )
2256     {
2257       unshift( @main::stored_mails, $mailref );
2258       last;
2259     } ## end if ( !send_mail( $mailref...
2260   } ## end while ( $mailref = shift(...
2261 } ## end sub finish_mail()
2262
2263 #
2264 # send one mail
2265 #
2266 sub send_mail($$$) {
2267   my $addr    = shift;
2268   my $subject = shift;
2269   my $text    = shift;
2270
2271   my $package =
2272     keys %main::packages ? join( ' ', keys %main::packages ) : "";
2273
2274   use Email::Send;
2275
2276   unless ( defined($Email::Send::Sendmail::SENDMAIL) ) {
2277     $Email::Send::Sendmail::SENDMAIL = $conf::mail;
2278   }
2279
2280   if ($conf::overridemail) {
2281         $addr = $conf::overridemail;
2282   }
2283
2284   my $date = sprintf "%s",
2285     strftime( "%a, %d %b %Y %T %z", ( localtime(time) ) );
2286   my $message = <<__MESSAGE__;
2287 To: $addr
2288 From: Debian FTP Masters <ftpmaster\@ftp-master.debian.org>
2289 Subject: $subject
2290 Date: $date
2291 X-Debian: DAK
2292 X-DAK: DAK
2293 __MESSAGE__
2294
2295   if ( length $package ) {
2296     $message .= "X-Debian-Package: $package\n";
2297   }
2298
2299   $message .= "\n$text";
2300   $message .= "\nGreetings,\n\n\tYour Debian queue daemon (running on host $main::hostname)\n";
2301
2302   my $mail = Email::Send->new;
2303   for (qw[Sendmail SMTP]) {
2304     $mail->mailer($_) and last if $mail->mailer_available($_);
2305   }
2306
2307   my $ret = $mail->send($message);
2308   if ( $ret && $ret !~ /Message sent|success/ ) {
2309     return 0;
2310   }
2311
2312   return 1;
2313 } ## end sub send_mail($$$)
2314
2315 #
2316 # try to find a mail address for a name in the keyrings
2317 #
2318 sub try_to_get_mail_addr($$) {
2319   my $name    = shift;
2320   my $listref = shift;
2321
2322   @$listref = ();
2323   open( F,
2324             "$conf::gpg --no-options --batch --no-default-keyring "
2325           . "--always-trust --keyring "
2326           . join( " --keyring ", @conf::keyrings )
2327           . " --list-keys |"
2328       ) or return "";
2329   while (<F>) {
2330     if ( /^pub / && / $name / ) {
2331       /<([^>]*)>/;
2332       push( @$listref, $1 );
2333     }
2334   } ## end while (<F>)
2335   close(F);
2336
2337   return ( @$listref >= 1 ) ? $listref->[0] : "";
2338 } ## end sub try_to_get_mail_addr($$)
2339
2340 #
2341 # return current time as string
2342 #
2343 sub format_time() {
2344   my $t;
2345
2346   # omit weekday and year for brevity
2347   ( $t = localtime ) =~ /^\w+\s(.*)\s\d+$/;
2348   return $1;
2349 } ## end sub format_time()
2350
2351 sub print_time($) {
2352   my $secs = shift;
2353   my $hours = int( $secs / ( 60 * 60 ) );
2354
2355   $secs -= $hours * 60 * 60;
2356   return sprintf "%d:%02d:%02d", $hours, int( $secs / 60 ), $secs % 60;
2357 } ## end sub print_time($)
2358
2359 #
2360 # block some signals during queue processing
2361 #
2362 # This is just to avoid data inconsistency or uploads being aborted in the
2363 # middle. Only "soft" signals are blocked, i.e. SIGINT and SIGTERM, try harder
2364 # ones if you really want to kill the daemon at once.
2365 #
2366 sub block_signals() {
2367   POSIX::sigprocmask( SIG_BLOCK, $main::block_sigset );
2368 }
2369
2370 sub unblock_signals() {
2371   POSIX::sigprocmask( SIG_UNBLOCK, $main::block_sigset );
2372 }
2373
2374 #
2375 # process SIGHUP: close log file and reopen it (for logfile cycling)
2376 #
2377 sub close_log($) {
2378   close(LOG);
2379   close(STDOUT);
2380   close(STDERR);
2381
2382   open( LOG, ">>", $conf::logfile )
2383     or die "Cannot open my logfile $conf::logfile: $!\n";
2384   chmod( 0644, $conf::logfile )
2385     or msg( "log", "Cannot set modes of $conf::logfile: $!\n" );
2386   select( ( select(LOG), $| = 1 )[0] );
2387
2388   open( STDOUT, ">&", \*LOG )
2389     or msg( "log",
2390       "$main::progname: Can't redirect stdout to " . "$conf::logfile: $!\n" );
2391   open( STDERR, ">&", \*LOG )
2392     or msg( "log",
2393       "$main::progname: Can't redirect stderr to " . "$conf::logfile: $!\n" );
2394   msg( "log", "Restart after SIGHUP\n" );
2395 } ## end sub close_log($)
2396
2397 #
2398 # process SIGCHLD: check if it was our statusd process
2399 #
2400 sub kid_died($) {
2401   my $pid;
2402
2403   # reap statusd, so that it's no zombie when we try to kill(0) it
2404   waitpid( $main::statusd_pid, WNOHANG );
2405
2406   # Uncomment the following line if your Perl uses unreliable System V signal
2407   # (i.e. if handlers reset to default if the signal is delivered).
2408   # (Unfortunately, the re-setup can't be done in any case, since on some
2409   # systems this will cause the SIGCHLD to be delivered again if there are
2410   # still unreaped children :-(( )
2411
2412   #      $SIG{"CHLD"} = \&kid_died; # resetup handler for SysV
2413 } ## end sub kid_died($)
2414
2415 sub restart_statusd() {
2416
2417   # restart statusd if it died
2418   if ( !kill( 0, $main::statusd_pid ) ) {
2419     close(STATUSD);    # close out pipe end
2420     $main::statusd_pid = fork_statusd();
2421   }
2422 } ## end sub restart_statusd()
2423
2424 #
2425 # process a fatal signal: cleanup and exit
2426 #
2427 sub fatal_signal($) {
2428   my $signame = shift;
2429   my $sig;
2430
2431   # avoid recursions of fatal_signal in case of BSD signals
2432   foreach $sig (qw( ILL ABRT BUS FPE SEGV PIPE )) {
2433     $SIG{$sig} = "DEFAULT";
2434   }
2435
2436   if ( $$ == $main::maind_pid ) {
2437
2438     # only the main daemon should do this
2439     kill( $main::signo{"TERM"}, $main::statusd_pid )
2440       if defined $main::statusd_pid;
2441     unlink( $conf::statusfile, $conf::pidfile );
2442   } ## end if ( $$ == $main::maind_pid)
2443   msg( "log", "Caught SIG$signame -- exiting (pid $$)\n" );
2444   exit 1;
2445 } ## end sub fatal_signal($)
2446
2447 # Local Variables:
2448 #  tab-width: 4
2449 #  fill-column: 78
2450 # End: