tools/debianqueued-0.9/debianqueued

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