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