tools/debianqueued-0.9/debianqueued

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