tools/debianqueued-0.9/debianqueued

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