tools/debianqueued-0.9/debianqueued

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