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