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