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