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,
 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
 833   # now check all files for correct size and md5 sum
 834   for $file (@files) {
 835     my $filename = $file->{"name"};
 836     if ( !defined( $file->{"stats"} ) ) {
 837
 838       # could be an upload that isn't complete yet, be quiet,
 839       # but don't process the file;
 840       msg( "log", "$filename doesn't exist (ignored for now)\n" );
 841       ++$errs;
 842     } elsif ( $file->{"stats"}->[ST_SIZE] < $file->{"size"}
 843               && !$do_report )
 844     {
 845
 846       # could be an upload that isn't complete yet, be quiet,
 847       # but don't process the file
 848       msg( "log", "$filename is too small (ignored for now)\n" );
 849       ++$errs;
 850     } elsif ( $file->{"stats"}->[ST_SIZE] != $file->{"size"} ) {
 851       msg( "log,mail", "$filename has incorrect size; deleting it\n" );
 852       rm($filename);
 853       ++$errs;
 854     } elsif ( md5sum($filename) ne $file->{"md5"} ) {
 855       msg( "log,mail",
 856            "$filename has incorrect md5 checksum; ",
 857            "deleting it\n" );
 858       rm($filename);
 859       ++$errs;
 860     } ## end elsif ( md5sum($filename)...
 861   } ## end for $file (@files)
 862
 863   if ($errs) {
 864     if ( ( time - $upload_time ) > $conf::bad_changes_timeout ) {
 865
 866       # if a .changes fails for a really long time (several days
 867       # or so), remove it and all associated files
 868       msg(
 869           "log,mail",
 870           "$main::current_incoming_short/$changes couldn't be processed for ",
 871           int( $conf::bad_changes_timeout / ( 60 * 60 ) ),
 872           " hours and is now deleted\n"
 873          );
 874       msg( "log,mail", "All files it mentions are also removed:\n" );
 875       msg( "log,mail", "  ", join( ", ", @filenames ), "\n" );
 876       rm( $changes, @filenames, $failure_file );
 877     }
 878
 879     # else: be quiet
 880
 881     return;
 882   } ## end if ($errs)
 883
 884   # if this upload already failed earlier, wait until the delay requirement
 885   # is fulfilled
 886   if ( $retries > 0
 887        && ( time - $last_retry ) <
 888        ( $retries == 1 ? $conf::upload_delay_1 : $conf::upload_delay_2 ) )
 889   {
 890     msg( "log", "delaying retry of upload\n" );
 891     return;
 892   } ## end if ( $retries > 0 && (...
 893
 894   return if !ftp_open();
 895
 896   # check if the job is already present on target
 897   # (moved to here, to avoid bothering target as long as there are errors in
 898   # the job)
 899   if ( $ls_l = is_on_target( $changes, @filenames ) ) {
 900     msg(
 901       "log,mail",
 902 "$main::current_incoming_short/$changes is already present on target host:\n"
 903     );
 904     msg( "log,mail", "$ls_l\n" );
 905     msg( "mail",
 906          "Either you already uploaded it, or someone else ",
 907          "came first.\n" );
 908     msg( "log,mail", "Job $changes removed.\n" );
 909     rm( $changes, @filenames, $failure_file );
 910     return;
 911   } ## end if ( $ls_l = is_on_target...
 912
 913   # clear sgid bit before upload, scp would copy it to target. We don't need
 914   # it anymore, we know there are no problems if we come here. Also change
 915   # mode of files to 644 if this should be done locally.
 916   $changes_stats[ST_MODE] &= ~S_ISGID;
 917   if ( !$conf::chmod_on_target ) {
 918     $changes_stats[ST_MODE] &= ~0777;
 919     $changes_stats[ST_MODE] |= 0644;
 920   }
 921   chmod +( $changes_stats[ST_MODE] ), $changes;
 922
 923   # try uploading to target
 924   if ( !copy_to_target( $changes, @filenames ) ) {
 925
 926     # if the upload failed, increment the retry counter and remember the
 927     # current time; both things are written to the .failures file. Don't
 928     # increment the fail counter if the error was due to incoming
 929     # unwritable.
 930     return if !$main::incoming_writable;
 931     if ( ++$retries >= $conf::max_upload_retries ) {
 932       msg( "log,mail",
 933            "$changes couldn't be uploaded for $retries times now.\n" );
 934       msg( "log,mail",
 935            "Giving up and removing it and its associated files:\n" );
 936       msg( "log,mail", "  ", join( ", ", @filenames ), "\n" );
 937       rm( $changes, @filenames, $failure_file );
 938     } else {
 939       $last_retry = time;
 940       if ( open( FAILS, ">", $failure_file ) ) {
 941         print FAILS "$retries $last_retry\n";
 942         close(FAILS);
 943         chmod( 0600, $failure_file )
 944           or die "Cannot set modes of $failure_file: $!\n";
 945       } ## end if ( open( FAILS, ">$failure_file"...
 946       push( @$keep_list, $failure_file );
 947       debug("now $retries failed uploads");
 948       msg(
 949            "mail",
 950            "The upload will be retried in ",
 951            print_time(
 952                          $retries == 1
 953                        ? $conf::upload_delay_1
 954                        : $conf::upload_delay_2
 955                      ),
 956            "\n"
 957          );
 958     } ## end else [ if ( ++$retries >= $conf::max_upload_retries)
 959     return;
 960   } ## end if ( !copy_to_target( ...
 961
 962   # If the files were uploaded ok, remove them
 963   rm( $changes, @filenames, $failure_file );
 964
 965   msg( "mail", "$changes uploaded successfully to $conf::target\n" );
 966   msg( "mail", "along with the files:\n  ", join( "\n  ", @filenames ),
 967        "\n" );
 968   msg( "log",
 969        "$changes processed successfully (uploader $main::mail_addr)\n" );
 970
 971   return;
 972
 973   remove_only_changes:
 974   msg(
 975     "log,mail",
 976     "Removing $main::current_incoming_short/$changes, but keeping its "
 977     . "associated files for now.\n"
 978     );
 979   rm($changes);
 980   return;
 981
 982   # Check for files that have the same stem as the .changes (and weren't
 983   # mentioned there) and delete them. It happens often enough that people
 984   # upload a .orig.tar.gz where it isn't needed and also not in the
 985   # .changes. Explicitly deleting it (and not waiting for the
 986   # $stray_remove_timeout) reduces clutter in the queue dir and maybe also
 987   # educates uploaders :-)
 988
 989   #     my $pattern = debian_file_stem( $changes );
 990   #     my $spattern = substr( $pattern, 0, -1 ); # strip off '*' at end
 991   #     my @other_files = glob($pattern);
 992   # filter out files that have a Debian revision at all and a different
 993   # revision. Those belong to a different upload.
 994   #     if ($changes =~ /^\Q$spattern\E-([\d.+-]+)/) {
 995   #             my $this_rev = $1;
 996   #             @other_files = grep( !/^\Q$spattern\E-([\d.+-]+)/ || $1 eq $this_rev,
 997   #                                                      @other_files);
 998   #}
 999   # Also do not remove those files if a .changes is among them. Then there
1000   # is probably a second upload for another version or another architecture.
1001   #     if (@other_files && !grep( /\.changes$/, @other_files )) {
1002   #             rm( @other_files );
1003   #             msg( "mail", "\nThe following file(s) seemed to belong to the same ".
1004   #                                      "upload, but weren't listed\n" );
1005   #             msg( "mail", "in the .changes file:\n  " );
1006   #             msg( "mail", join( "\n  ", @other_files ), "\n" );
1007   #             msg( "mail", "They have been deleted.\n" );
1008   #             msg( "log", "Deleted files in upload not in $changes: @other_files\n" );
1009   #}
1010 } ## end sub process_changes($\@)
1011
1012 #
1013 # process one .dak-commands file
1014 #
1015 sub process_dak_commands {
1016   my $commands = shift;
1017
1018   msg("log", "processing ${main::current_incoming_short}/$commands\n");
1019
1020   # TODO: get mail address from signed contents
1021   # and NOT implement a third parser for armored PGP...
1022   $main::mail_addr = undef;
1023
1024   # check signature
1025   my $signator = pgp_check($commands);
1026   if (!$signator) {
1027         msg("log,mail",
1028             "$main::current_incoming_short/$commands has bad PGP/GnuPG signature!\n");
1029         msg("log,mail",
1030                 "Removing $main::current_incoming_short/$commands\n");
1031         rm($commands);
1032         return;
1033   }
1034   elsif ($signator eq 'LOCAL ERROR') {
1035         debug("Can't check signature for $main::current_incoming_short/$commands -- don't process it for now");
1036         return;
1037   }
1038   msg("log,mail", "(PGP/GnuPG signature by $signator)\n");
1039
1040   return if !ftp_open();
1041
1042   # check target
1043   my @filenames = ($commands);
1044   if (my $ls_l = is_on_target($commands, @filenames)) {
1045         msg("log,mail", "$main::current_incoming_short/$commands is already present on target host:\n");
1046         msg("log,mail", "$ls_l\n");
1047         msg("log,mail", "Job $commands removed.\n");
1048         rm($commands);
1049         return;
1050   }
1051
1052   if (!copy_to_target($commands)) {
1053         msg("log,mail", "$commands couldn't be uploaded to target.\n");
1054         msg("log,mail", "Giving up and removing it.\n");
1055         rm($commands);
1056         return;
1057   }
1058
1059   rm($commands);
1060   msg("mail", "$commands uploaded successfully to $conf::target\n");
1061 }
1062
1063 #
1064 # process one .commands file
1065 #
1066 sub process_commands($) {
1067   my $commands = shift;
1068   my ( @cmds, $cmd, $pgplines, $signator );
1069   local (*COMMANDS);
1070   my ($file, @removed, $target_delay );
1071
1072   format_status_str( $main::current_changes, $commands );
1073   $main::dstat = "c";
1074   $main::mail_addr = "";
1075   write_status_file() if $conf::statusdelay;
1076
1077   msg( "log", "processing $main::current_incoming_short/$commands\n" );
1078
1079   # run PGP on the file to check the signature
1080   if ( !( $signator = pgp_check($commands) ) ) {
1081     msg(
1082       "log,mail",
1083       "$main::current_incoming_short/$commands has bad PGP/GnuPG signature!\n"
1084     );
1085     goto remove;
1086   } elsif ( $signator eq "LOCAL ERROR" ) {
1087
1088     # An error has appened when starting pgp... Don't process the file,
1089     # but also don't delete it
1090     debug(
1091 "Can't PGP/GnuPG check $main::current_incoming_short/$commands -- don't process it for now"
1092     );
1093     return;
1094   } ## end elsif ( $signator eq "LOCAL ERROR")
1095   msg( "log", "(PGP/GnuPG signature by $signator)\n" );
1096
1097   # parse the .commands file
1098   if ( !open( COMMANDS, "<", $commands ) ) {
1099     msg( "log", "Cannot open $main::current_incoming_short/$commands: $!\n" );
1100     return;
1101   }
1102   $pgplines        = 0;
1103   @cmds            = ();
1104 outer_loop: while (<COMMANDS>) {
1105     if (/^---+(BEGIN|END) PGP .*---+$/) {
1106       ++$pgplines;
1107     } elsif (/^Uploader:\s*/i) {
1108       chomp( $main::mail_addr = $' );
1109       $main::mail_addr = $1 if $main::mail_addr =~ /<([^>]*)>/;
1110     } elsif (/^Commands:/i) {
1111       $_ = $';
1112       for ( ; ; ) {
1113         s/^\s*(.*)\s*$/$1/;    # delete whitespace at both ends
1114         if ( !/^\s*$/ ) {
1115           push( @cmds, $_ );
1116           debug("includes cmd $_");
1117         }
1118         last outer_loop if !defined( $_ = scalar(<COMMANDS>) );
1119         chomp;
1120         redo outer_loop if !/^\s/ || /^$/;
1121       } ## end for ( ; ; )
1122     } ## end elsif (/^Commands:/i)
1123   } ## end while (<COMMANDS>)
1124   close(COMMANDS);
1125
1126   # some consistency checks
1127   if ( !$main::mail_addr || $main::mail_addr !~ /^\S+\@\S+\.\S+/ ) {
1128     msg( "log,mail",
1129 "$main::current_incoming_short/$commands contains no or bad Uploader: field: "
1130         . "$main::mail_addr\n" );
1131     msg( "log,mail",
1132          "cannot process $main::current_incoming_short/$commands\n" );
1133     $main::mail_addr = "";
1134     goto remove;
1135   } ## end if ( !$main::mail_addr...
1136   msg( "log", "(command uploader $main::mail_addr)\n" );
1137
1138   if ( $pgplines < 3 ) {
1139     msg(
1140        "log,mail",
1141        "$main::current_incoming_short/$commands isn't signed with PGP/GnuPG\n"
1142     );
1143     msg(
1144       "mail",
1145       "or the uploaded file is broken. Make sure to transfer in binary mode\n"
1146     );
1147     msg( "mail", "or better yet - use dcut for commands files\n" );
1148     goto remove;
1149   } ## end if ( $pgplines < 3 )
1150
1151   # now process commands
1152   msg(
1153     "mail",
1154 "Log of processing your commands file $main::current_incoming_short/$commands:\n\n"
1155   );
1156   foreach $cmd (@cmds) {
1157     my @word = split( /\s+/, $cmd );
1158     msg( "mail,log", "> @word\n" );
1159     my $selecteddelayed = -1;
1160     next if @word < 1;
1161
1162     if ( $word[0] eq "rm" ) {
1163       my @files = ();
1164       foreach ( @word[ 1 .. $#word ] ) {
1165         my $origword = $_;
1166         if (m,^DELAYED/([0-9]+)-day/,) {
1167           $selecteddelayed = $1;
1168           s,^DELAYED/[0-9]+-day/,,;
1169         }
1170         if (m,(^|/)\*,) {
1171           msg("mail,log", "$_: filename component cannot start with a wildcard\n");
1172         } elsif ( $origword eq "--searchdirs" ) {
1173           $selecteddelayed = -2;
1174         } elsif (m,/,) {
1175           msg(
1176             "mail,log",
1177 "$_: filename may not contain slashes except for DELAYED/#-day/ prefixes\n"
1178           );
1179         } else {
1180
1181           # process wildcards but also plain names
1182           my (@thesefiles);
1183           my $pat = quotemeta($_);
1184           $pat =~ s/\\\*/.*/g;
1185           $pat =~ s/\\\?/.?/g;
1186           $pat =~ s/\\([][])/$1/g;
1187
1188           if ( $selecteddelayed < 0 ) {    # scanning or explicitly incoming
1189             opendir( DIR, "." );
1190             push( @thesefiles, grep /^$pat$/, readdir(DIR) );
1191             closedir(DIR);
1192           }
1193           if ( $selecteddelayed >= 0 ) {
1194             my $dir = sprintf( $conf::incoming_delayed, $selecteddelayed );
1195             opendir( DIR, $dir );
1196             push( @thesefiles,
1197                   map ( "$dir/$_", grep /^$pat$/, readdir(DIR) ) );
1198             closedir(DIR);
1199           } elsif ( $selecteddelayed == -2 ) {
1200             for ( my ($adelay) = 0 ;
1201                   ( !@thesefiles ) && $adelay <= $conf::max_delayed ;
1202                   $adelay++ )
1203             {
1204               my $dir = sprintf( $conf::incoming_delayed, $adelay );
1205               opendir( DIR, $dir );
1206               push( @thesefiles,
1207                     map ( "$dir/$_", grep /^$pat$/, readdir(DIR) ) );
1208               closedir(DIR);
1209             } ## end for ( my ($adelay) = 0 ...
1210           } ## end elsif ( $selecteddelayed ...
1211           push( @files, @thesefiles );
1212           if ( !@thesefiles ) {
1213             msg( "mail,log", "$origword did not match anything\n" );
1214           }
1215         } ## end else [ if ( $origword eq "--searchdirs")
1216       } ## end foreach ( @word[ 1 .. $#word...
1217       if ( !@files ) {
1218         msg( "mail,log", "No files to delete\n" );
1219       } else {
1220         @removed = ();
1221         foreach $file (@files) {
1222           if ( !-f $file ) {
1223             msg( "mail,log", "$file: no such file\n" );
1224           } elsif ( $file =~ /$conf::keep_files/ ) {
1225             msg( "mail,log", "$file is protected, cannot " . "remove\n" );
1226           } elsif ( !unlink($file) ) {
1227             msg( "mail,log", "$file: rm: $!\n" );
1228           } else {
1229             $file =~ s,$conf::incoming/?,,;
1230             push( @removed, $file );
1231           }
1232         } ## end foreach $file (@files)
1233         msg( "mail,log", "Files removed: @removed\n" ) if @removed;
1234       } ## end else [ if ( !@files )
1235     } elsif ( $word[0] eq "reschedule" ) {
1236       if ( @word != 3 ) {
1237         msg( "mail,log", "Wrong number of arguments\n" );
1238       } elsif ( $conf::upload_method ne "copy" ) {
1239         msg( "mail,log", "reschedule not available\n" );
1240       } elsif ( $word[1] =~ m,/, || $word[1] !~ m/\.changes/ ) {
1241         msg(
1242            "mail,log",
1243            "$word[1]: filename may not contain slashes and must be .changes\n"
1244         );
1245       } elsif ( !( ($target_delay) = $word[2] =~ m,^([0-9]+)-day$, )
1246                 || $target_delay > $conf::max_delayed )
1247       {
1248         msg(
1249           "mail,log",
1250 "$word[2]: rescheduling target must be #-day with # between 0 and $conf::max_delayed (in particular, no '/' allowed)\n"
1251         );
1252       } elsif ( $word[1] =~ /$conf::keep_files/ ) {
1253         msg( "mail,log", "$word[1] is protected, cannot do stuff with it\n" );
1254       } else {
1255         my ($adelay);
1256         for ( $adelay = 0 ;
1257             $adelay <= $conf::max_delayed
1258             && !-f (
1259               sprintf( "$conf::targetdir_delayed", $adelay ) . "/$word[1]" ) ;
1260             $adelay++ )
1261         {
1262         } ## end for ( $adelay = 0 ; $adelay...
1263         if ( $adelay > $conf::max_delayed ) {
1264           msg( "mail,log", "$word[1] not found\n" );
1265         } elsif ( $adelay == $target_delay ) {
1266           msg( "mail,log", "$word[1] already is in $word[2]\n" );
1267         } else {
1268           my (@thesefiles);
1269           my ($dir) = sprintf( "$conf::targetdir_delayed", $adelay );
1270           my ($target_dir) =
1271             sprintf( "$conf::targetdir_delayed", $target_delay );
1272           push( @thesefiles, $word[1] );
1273           push( @thesefiles,
1274                 get_filelist_from_known_good_changes("$dir/$word[1]") );
1275           for my $afile (@thesefiles) {
1276             if ( $afile =~ m/\.changes$/ ) {
1277               utime undef, undef, ("$dir/$afile");
1278             }
1279             if ( !move("$dir/$afile", "$target_dir/$afile") ) {
1280               msg( "mail,log", "move: $!\n" );
1281             } else {
1282               msg( "mail,log", "$afile moved to $target_delay-day\n" );
1283             }
1284           } ## end for my $afile (@thesefiles)
1285         } ## end else [ if ( $adelay > $conf::max_delayed)
1286       } ## end else [ if ( @word != 3 )
1287     } elsif ( $word[0] eq "cancel" ) {
1288       if ( @word != 2 ) {
1289         msg( "mail,log", "Wrong number of arguments\n" );
1290       } elsif ( $conf::upload_method ne "copy" ) {
1291         msg( "mail,log", "cancel not available\n" );
1292       } elsif (
1293           $word[1] !~ m,$re_file_safe_prefix\.changes\z, )
1294       {
1295         msg( "mail,log",
1296           "argument to cancel must be one .changes filename without path\n" );
1297       } ## end elsif ( $word[1] !~ ...
1298       my (@files) = ();
1299       for ( my ($adelay) = 0 ; $adelay <= $conf::max_delayed ; $adelay++ ) {
1300         my ($dir) = sprintf( "$conf::targetdir_delayed", $adelay );
1301         if ( -f "$dir/$word[1]" ) {
1302           @removed = ();
1303           push( @files, "$word[1]" );
1304           push( @files,
1305                 get_filelist_from_known_good_changes("$dir/$word[1]") );
1306           foreach $file (@files) {
1307             if ( !-f "$dir/$file" ) {
1308               msg( "mail,log", "$dir/$file: no such file\n" );
1309             } elsif ( "$dir/$file" =~ /$conf::keep_files/ ) {
1310               msg( "mail,log",
1311                    "$dir/$file is protected, cannot " . "remove\n" );
1312             } elsif ( !unlink("$dir/$file") ) {
1313               msg( "mail,log", "$dir/$file: rm: $!\n" );
1314             } else {
1315               push( @removed, $file );
1316             }
1317           } ## end foreach $file (@files)
1318           msg( "mail,log", "Files removed from $adelay-day: @removed\n" )
1319             if @removed;
1320         } ## end if ( -f "$dir/$word[1]")
1321       } ## end for ( my ($adelay) = 0 ...
1322       if ( !@files ) {
1323         msg( "mail,log", "No upload found: $word[1]\n" );
1324       }
1325     } else {
1326       msg( "mail,log", "unknown command $word[0]\n" );
1327     }
1328   } ## end foreach $cmd (@cmds)
1329   rm($commands);
1330   msg( "log",
1331        "-- End of $main::current_incoming_short/$commands processing\n" );
1332   return;
1333
1334   remove:
1335   msg("log,mail", "Removing $main::current_incoming_short/$commands\n");
1336   rm($commands);
1337   return;
1338 } ## end sub process_commands($)
1339
1340 sub age_delayed_queues() {
1341   for ( my ($adelay) = 0 ; $adelay <= $conf::max_delayed ; $adelay++ ) {
1342     my ($dir) = sprintf( "$conf::targetdir_delayed", $adelay );
1343     my ($target_dir);
1344     if ( $adelay == 0 ) {
1345       $target_dir = $conf::targetdir;
1346     } else {
1347       $target_dir = sprintf( "$conf::targetdir_delayed", $adelay - 1 );
1348     }
1349     for my $achanges (<$dir/*.changes>) {
1350       my $mtime = ( stat($achanges) )[9];
1351       if ( $mtime + 24 * 60 * 60 <= time || $adelay == 0 ) {
1352         utime undef, undef, ($achanges);
1353         my @thesefiles = ( $achanges =~ m,.*/([^/]*), );
1354         push( @thesefiles, get_filelist_from_known_good_changes($achanges) );
1355         for my $afile (@thesefiles) {
1356           if ( !move("$dir/$afile", "$target_dir/$afile") ) {
1357             msg( "log", "move: $!\n" );
1358           } else {
1359             msg( "log", "$afile moved to $target_dir\n" );
1360           }
1361         } ## end for my $afile (@thesefiles)
1362       } ## end if ( $mtime + 24 * 60 ...
1363     } ## end for my $achanges (<$dir/*.changes>)
1364   } ## end for ( my ($adelay) = 0 ...
1365 } ## end sub age_delayed_queues()
1366
1367 #
1368 # check if a file is already on target
1369 #
1370 sub is_on_target($\@) {
1371   my $file     = shift;
1372   my $filelist = shift;
1373   my $msg;
1374   my $stat;
1375
1376   if ( $conf::upload_method eq "ssh" ) {
1377     ( $msg, $stat ) = ssh_cmd("ls -l $file");
1378   } elsif ( $conf::upload_method eq "ftp" ) {
1379     my $err;
1380     ( $msg, $err ) = ftp_cmd( "dir", $file );
1381     if ($err) {
1382       $stat = 1;
1383       $msg  = $err;
1384     } elsif ( !$msg ) {
1385       $stat = 1;
1386       $msg  = "ls: no such file\n";
1387     } else {
1388       $stat = 0;
1389       $msg = join( "\n", @$msg );
1390     }
1391   } else {
1392     my @allfiles = ($file);
1393     push( @allfiles, @$filelist );
1394     $stat = 1;
1395     $msg  = "no such file";
1396     for my $afile (@allfiles) {
1397       if ( -f "$conf::targetdir/$afile" ) {
1398         $stat = 0;
1399         $msg  = "$afile";
1400       }
1401     } ## end for my $afile (@allfiles)
1402     for ( my ($adelay) = 0 ;
1403           $adelay <= $conf::max_delayed && $stat ;
1404           $adelay++ )
1405     {
1406       for my $afile (@allfiles) {
1407         if (
1408            -f ( sprintf( "$conf::targetdir_delayed", $adelay ) . "/$afile" ) )
1409         {
1410           $stat = 0;
1411           $msg = sprintf( "%d-day", $adelay ) . "/$afile";
1412         } ## end if ( -f ( sprintf( "$conf::targetdir_delayed"...
1413       } ## end for my $afile (@allfiles)
1414     } ## end for ( my ($adelay) = 0 ...
1415   } ## end else [ if ( $conf::upload_method...
1416   chomp($msg);
1417   debug("exit status: $stat, output was: $msg");
1418
1419   return "" if $stat && $msg =~ /no such file/i;    # file not present
1420   msg( "log", "strange ls -l output on target:\n", $msg ), return ""
1421     if $stat || $@;    # some other error, but still try to upload
1422
1423   # ls -l returned 0 -> file already there
1424   $msg =~ s/\s\s+/ /g;    # make multiple spaces into one, to save space
1425   return $msg;
1426 } ## end sub is_on_target($\@)
1427
1428 #
1429 # copy a list of files to target
1430 #
1431 sub copy_to_target(@) {
1432   my @files = @_;
1433   my ( @md5sum, @expected_files, $sum, $name, $msgs, $stat );
1434
1435   $main::dstat = "u";
1436   write_status_file() if $conf::statusdelay;
1437
1438   # copy the files
1439   if ( $conf::upload_method eq "ssh" ) {
1440     ( $msgs, $stat ) = scp_cmd(@files);
1441     goto err if $stat;
1442   } elsif ( $conf::upload_method eq "ftp" ) {
1443     my ( $rv, $file );
1444     if ( !$main::FTP_chan->cwd($main::current_targetdir) ) {
1445       msg( "log,mail",
1446            "Can't cd to $main::current_targetdir on $conf::target\n" );
1447       goto err;
1448     }
1449     foreach $file (@files) {
1450       ( $rv, $msgs ) = ftp_cmd( "put", $file );
1451       goto err if !$rv;
1452     }
1453   } else {
1454     for my $file (@files) {
1455       eval { File::Copy::copy($file, $main::current_targetdir) };
1456       if ($@) {
1457         $stat = 1;
1458         $msgs = $@;
1459         goto err;
1460       }
1461     }
1462   }
1463
1464   # check md5sums or sizes on target against our own
1465   my $have_md5sums = 1;
1466   if ($conf::check_md5sum) {
1467     if ( $conf::upload_method eq "ssh" ) {
1468       ( $msgs, $stat ) = ssh_cmd("md5sum @files");
1469       goto err if $stat;
1470       @md5sum = split( "\n", $msgs );
1471     } elsif ( $conf::upload_method eq "ftp" ) {
1472       my ( $rv, $err, $file );
1473       foreach $file (@files) {
1474         ( $rv, $err ) = ftp_cmd( "quot", "site", "md5sum", $file );
1475         if ($err) {
1476           next if ftp_code() == 550;    # file not found
1477           if ( ftp_code() == 500 ) {    # unimplemented
1478             $have_md5sums = 0;
1479             goto get_sizes_instead;
1480           }
1481           $msgs = $err;
1482           goto err;
1483         } ## end if ($err)
1484         chomp( my $t = ftp_response() );
1485         push( @md5sum, $t );
1486       } ## end foreach $file (@files)
1487       if ( !$have_md5sums ) {
1488       get_sizes_instead:
1489         foreach $file (@files) {
1490           ( $rv, $err ) = ftp_cmd( "size", $file );
1491           if ($err) {
1492             next if ftp_code() == 550;    # file not found
1493             $msgs = $err;
1494             goto err;
1495           }
1496           push( @md5sum, "$rv $file" );
1497         } ## end foreach $file (@files)
1498       } ## end if ( !$have_md5sums )
1499     } else {
1500       for my $file (@files) {
1501         my $md5 = eval { md5sum("$main::current_targetdir/$file") };
1502         if ($@) {
1503           $msgs = $@;
1504           goto err;
1505         }
1506         push @md5sum, "$md5 $file" if $md5;
1507       }
1508     }
1509
1510     @expected_files = @files;
1511     foreach (@md5sum) {
1512       chomp;
1513       ( $sum, $name ) = split;
1514       next if !grep { $_ eq $name } @files;    # a file we didn't upload??
1515       next if $sum eq "md5sum:";               # looks like an error message
1516       if (    ( $have_md5sums && $sum ne md5sum($name) )
1517            || ( !$have_md5sums && $sum != ( -s $name ) ) )
1518       {
1519         msg(
1520              "log,mail",
1521              "Upload of $name to $conf::target failed ",
1522              "(" . ( $have_md5sums ? "md5sum" : "size" ) . " mismatch)\n"
1523            );
1524         goto err;
1525       } ## end if ( ( $have_md5sums &&...
1526
1527       # seen that file, remove it from expect list
1528       @expected_files = map { $_ eq $name ? () : $_ } @expected_files;
1529     } ## end foreach (@md5sum)
1530     if (@expected_files) {
1531       msg( "log,mail", "Failed to upload the files\n" );
1532       msg( "log,mail", "  ", join( ", ", @expected_files ), "\n" );
1533       msg( "log,mail", "(Not present on target after upload)\n" );
1534       goto err;
1535     } ## end if (@expected_files)
1536   } ## end if ($conf::check_md5sum)
1537
1538   if ($conf::chmod_on_target) {
1539
1540     # change file's mode explicitly to 644 on target
1541     if ( $conf::upload_method eq "ssh" ) {
1542       ( $msgs, $stat ) = ssh_cmd("chmod 644 @files");
1543       goto err if $stat;
1544     } elsif ( $conf::upload_method eq "ftp" ) {
1545       my ( $rv, $file );
1546       foreach $file (@files) {
1547         ( $rv, $msgs ) = ftp_cmd( "quot", "site", "chmod", "644", $file );
1548         msg( "log", "Can't chmod $file on target:\n$msgs" )
1549           if $msgs;
1550         goto err if !$rv;
1551       } ## end foreach $file (@files)
1552     } else {
1553       for my $file (@files) {
1554         unless (chmod 0644, "$main::current_targetdir/$file") {
1555           $msgs = "Could not chmod $file: $!";
1556           goto err;
1557         }
1558       }
1559     }
1560   } ## end if ($conf::chmod_on_target)
1561
1562   $main::dstat = "c";
1563   write_status_file() if $conf::statusdelay;
1564   return 1;
1565
1566 err:
1567   msg( "log,mail",
1568        "Upload to $conf::target failed",
1569        $? ? ", last exit status " . sprintf( "%s", $? >> 8 ) : "", "\n" );
1570   msg( "log,mail", "Error messages:\n", $msgs )
1571     if $msgs;
1572
1573   # If "permission denied" was among the errors, test if the incoming is
1574   # writable at all.
1575   if ( $msgs && $msgs =~ /(permission denied|read-?only file)/i ) {
1576     if ( !check_incoming_writable() ) {
1577       msg( "log,mail", "(The incoming directory seems to be ",
1578            "unwritable.)\n" );
1579     }
1580   } ## end if ( $msgs =~ /(permission denied|read-?only file)/i)
1581
1582   # remove bad files or an incomplete upload on target
1583   if ( $conf::upload_method eq "ssh" ) {
1584     ssh_cmd("rm -f @files");
1585   } elsif ( $conf::upload_method eq "ftp" ) {
1586     my $file;
1587     foreach $file (@files) {
1588       my ( $rv, $err );
1589       ( $rv, $err ) = ftp_cmd( "delete", $file );
1590       msg( "log", "Can't delete $file on target:\n$err" )
1591         if $err;
1592     } ## end foreach $file (@files)
1593   } else {
1594     my @tfiles = map { "$main::current_targetdir/$_" } @files;
1595     debug("executing unlink(@tfiles)");
1596     rm(@tfiles);
1597   }
1598   $main::dstat = "c";
1599   write_status_file() if $conf::statusdelay;
1600   return 0;
1601 } ## end sub copy_to_target(@)
1602
1603 #
1604 # check if a file is correctly signed with PGP
1605 #
1606 sub pgp_check($) {
1607   my $file   = shift;
1608   my $output = "";
1609   my $signator;
1610   my $found = 0;
1611   my $stat = 1;
1612   local (*PIPE);
1613   local $_;
1614
1615   if ($file =~ /$re_file_safe/) {
1616     $file = $1;
1617   } else {
1618     msg( "log", "Tainted filename, skipping: $file\n" );
1619     return "LOCAL ERROR";
1620   }
1621
1622   # check the file has only one clear-signed section
1623   my $fh;
1624   unless (open $fh, "<", $file) {
1625           msg("log,mail", "Could not open $file\n");
1626           return "";
1627   }
1628   unless (<$fh> eq "-----BEGIN PGP SIGNED MESSAGE-----\n") {
1629           msg("log,mail", "$file: does not start with a clearsigned message\n");
1630           return "";
1631   }
1632   my $pgplines = 1;
1633   while (<$fh>) {
1634           if (/\A- /) {
1635                   msg("log,mail", "$file: dash-escaped messages are not accepted\n");
1636                   return "";
1637           }
1638           elsif ($_ eq "-----BEGIN PGP SIGNATURE-----\n"
1639                      || $_ eq "-----END PGP SIGNATURE-----\n") {
1640                   $pgplines++;
1641           }
1642           elsif (/\A--/) {
1643                   msg("log,mail", "$file: unexpected OpenPGP armor\n");
1644                   return "";
1645           }
1646           elsif ($pgplines > 3 && /\S/) {
1647                   msg("log,mail", "$file: found text after end of signature\n");
1648                   return "";
1649           }
1650   }
1651   if ($pgplines != 3) {
1652           msg("log,mail", "$file: doesn't seem to be a valid clearsigned OpenPGP message\n");
1653           return "";
1654   }
1655   close $fh;
1656
1657   if ( -x $conf::gpg ) {
1658     my @command = ("$conf::gpg", "--no-options", "--batch", "--no-tty",
1659                    "--trust-model", "always", "--no-default-keyring",
1660                    (map +("--keyring" => $_), @conf::keyrings),
1661                    "--verify", "-");
1662     debug(   "executing " . join(" ", @command) );
1663
1664     my $child = open(PIPE, "-|");
1665     if (!defined($child)) {
1666       msg("log", "Can't open pipe to $conf::gpg: $!\n");
1667       return "LOCAL ERROR";
1668     }
1669     if ($child == 0) {
1670       unless (open(STDERR, ">&", \*STDOUT)) {
1671         print "Could not redirect STDERR.";
1672         exit(-1);
1673       }
1674       unless (open(STDIN, "<", $file)) {
1675         print "Could not open $file: $!";
1676         exit(-1);
1677       }
1678       { exec(@command) }; # BLOCK avoids warning about likely unreachable code
1679       print "Could not exec gpg: $!";
1680       exit(-1);
1681     }
1682
1683     $output .= $_ while (<PIPE>);
1684     close(PIPE);
1685     $stat = $?;
1686   } ## end if ( -x $conf::gpg )
1687
1688   if ($stat) {
1689     msg( "log,mail", "GnuPG signature check failed on $file\n" );
1690     msg( "mail",     $output );
1691     msg( "log,mail", "(Exit status ", $stat >> 8, ")\n" );
1692     return "";
1693   } ## end if ($stat)
1694
1695   $output =~ /^(gpg: )?good signature from (user )?"(.*)"\.?$/im;
1696   ( $signator = $3 ) ||= "unknown signator";
1697   if ($conf::debug) {
1698     debug("GnuPG signature ok (by $signator)");
1699   }
1700   return $signator;
1701 } ## end sub pgp_check($)
1702
1703 # ---------------------------------------------------------------------------
1704 #                                                         the status daemon
1705 # ---------------------------------------------------------------------------
1706
1707 #
1708 # fork a subprocess that watches the 'status' FIFO
1709 #
1710 # that process blocks until someone opens the FIFO, then sends a
1711 # signal (SIGUSR1) to the main process, expects
1712 #
1713 sub fork_statusd() {
1714   my $statusd_pid;
1715   my $main_pid = $$;
1716   my $errs;
1717   local (*STATFIFO);
1718
1719   $statusd_pid = open( STATUSD, "|-" );
1720   die "cannot fork: $!\n" if !defined($statusd_pid);
1721
1722   # parent just returns
1723   if ($statusd_pid) {
1724     msg( "log", "forked status daemon (pid $statusd_pid)\n" );
1725     return $statusd_pid;
1726   }
1727
1728   # child: the status FIFO daemon
1729
1730   # ignore SIGPIPE here, in case some closes the FIFO without completely
1731   # reading it
1732   $SIG{"PIPE"} = "IGNORE";
1733
1734   # also ignore SIGCLD, we don't want to inherit the restart-statusd handler
1735   # from our parent
1736   $SIG{"CHLD"} = "DEFAULT";
1737
1738   rm($conf::statusfile);
1739   $errs = `$conf::mkfifo $conf::statusfile`;
1740   die "$main::progname: cannot create named pipe $conf::statusfile: $errs"
1741     if $?;
1742   chmod( 0644, $conf::statusfile )
1743     or die "Cannot set modes of $conf::statusfile: $!\n";
1744
1745   # close log file, so that log rotating works
1746   close(LOG);
1747   close(STDOUT);
1748   close(STDERR);
1749
1750   while (1) {
1751     my ( $status, $mup, $incw, $ds, $next_run, $last_ping, $currch, $l );
1752
1753     # open the FIFO for writing; this blocks until someone (probably ftpd)
1754     # opens it for reading
1755     open( STATFIFO, ">", $conf::statusfile )
1756       or die "Cannot open $conf::statusfile\n";
1757     select(STATFIFO);
1758
1759     # tell main daemon to send us status infos
1760     kill( $main::signo{"USR1"}, $main_pid );
1761
1762     # get the infos from stdin; must loop until enough bytes received!
1763     my $expect_len = 3 + 2 * STATNUM_LEN + STATSTR_LEN;
1764     for ( $status = "" ; ( $l = length($status) ) < $expect_len ; ) {
1765       sysread( STDIN, $status, $expect_len - $l, $l );
1766     }
1767
1768     # disassemble the status byte stream
1769     my $pos = 0;
1770     foreach (
1771               [ mup       => 1 ],
1772               [ incw      => 1 ],
1773               [ ds        => 1 ],
1774               [ next_run  => STATNUM_LEN ],
1775               [ last_ping => STATNUM_LEN ],
1776               [ currch    => STATSTR_LEN ]
1777             )
1778     {
1779       eval "\$$_->[0] = substr( \$status, $pos, $_->[1] );";
1780       $pos += $_->[1];
1781     } ## end foreach ( [ mup => 1 ], [ incw...
1782     $currch =~ s/\n+//g;
1783
1784     print_status( $mup, $incw, $ds, $next_run, $last_ping, $currch );
1785     close(STATFIFO);
1786
1787     # This sleep is necessary so that we can't reopen the FIFO
1788     # immediately, in case the reader hasn't closed it yet if we get to
1789     # the open again. Is there a better solution for this??
1790     sleep 1;
1791   } ## end while (1)
1792 } ## end sub fork_statusd()
1793
1794 #
1795 # update the status file, in case we use a plain file and not a FIFO
1796 #
1797 sub write_status_file() {
1798
1799   return if !$conf::statusfile;
1800
1801   open( STATFILE, ">", $conf::statusfile )
1802     or ( msg( "log", "Could not open $conf::statusfile: $!\n" ), return );
1803   my $oldsel = select(STATFILE);
1804
1805   print_status(
1806                 $main::target_up,      $main::incoming_writable,
1807                 $main::dstat,          $main::next_run,
1808                 $main::last_ping_time, $main::current_changes
1809               );
1810
1811   select($oldsel);
1812   close(STATFILE);
1813 } ## end sub write_status_file()
1814
1815 sub print_status($$$$$$) {
1816   my $mup       = shift;
1817   my $incw      = shift;
1818   my $ds        = shift;
1819   my $next_run  = shift;
1820   my $last_ping = shift;
1821   my $currch    = shift;
1822   my $approx;
1823   my $version;
1824
1825   ( $version = 'Release: 0.9 $Revision: 1.51 $' ) =~ s/\$ ?//g;
1826   print "debianqueued $version\n";
1827
1828   $approx = $conf::statusdelay ? "approx. " : "";
1829
1830   if ( $mup eq "0" ) {
1831     print "$conf::target is down, queue pausing\n";
1832     return;
1833   } elsif ( $conf::upload_method ne "copy" ) {
1834     print "$conf::target seems to be up, last ping $approx",
1835       print_time( time - $last_ping ), " ago\n";
1836   }
1837
1838   if ( $incw eq "0" ) {
1839     print "The incoming directory is not writable, queue pausing\n";
1840     return;
1841   }
1842
1843   if ( $ds eq "i" ) {
1844     print "Next queue check in $approx", print_time( $next_run - time ), "\n";
1845     return;
1846   } elsif ( $ds eq "c" ) {
1847     print "Checking queue directory\n";
1848   } elsif ( $ds eq "u" ) {
1849     print "Uploading to $conf::target\n";
1850   } else {
1851     print "Bad status data from daemon: \"$mup$incw$ds\"\n";
1852     return;
1853   }
1854
1855   print "Current job is $currch\n" if $currch;
1856 } ## end sub print_status($$$$$$)
1857
1858 #
1859 # format a number for sending to statusd (fixed length STATNUM_LEN)
1860 #
1861 sub format_status_num(\$$) {
1862   my $varref = shift;
1863   my $num    = shift;
1864
1865   $$varref = sprintf "%" . STATNUM_LEN . "d", $num;
1866 } ## end sub format_status_num(\$$)
1867
1868 #
1869 # format a string for sending to statusd (fixed length STATSTR_LEN)
1870 #
1871 sub format_status_str(\$$) {
1872   my $varref = shift;
1873   my $str    = shift;
1874
1875   $$varref = substr( $str, 0, STATSTR_LEN );
1876   $$varref .= "\n" x ( STATSTR_LEN - length($$varref) );
1877 } ## end sub format_status_str(\$$)
1878
1879 #
1880 # send a status string to the status daemon
1881 #
1882 # Avoid all operations that could call malloc() here! Most libc
1883 # implementations aren't reentrant, so we may not call it from a
1884 # signal handler. So use only already-defined variables.
1885 #
1886 sub send_status() {
1887   local $! = 0;    # preserve errno
1888
1889   # re-setup handler, in case we have broken SysV signals
1890   $SIG{"USR1"} = \&send_status;
1891
1892   syswrite( STATUSD, $main::target_up,         1 );
1893   syswrite( STATUSD, $main::incoming_writable, 1 );
1894   syswrite( STATUSD, $main::dstat,             1 );
1895   syswrite( STATUSD, $main::next_run,          STATNUM_LEN );
1896   syswrite( STATUSD, $main::last_ping_time,    STATNUM_LEN );
1897   syswrite( STATUSD, $main::current_changes,   STATSTR_LEN );
1898 } ## end sub send_status()
1899
1900 # ---------------------------------------------------------------------------
1901 #                                                           FTP functions
1902 # ---------------------------------------------------------------------------
1903
1904 #
1905 # open FTP connection to target host if not already open
1906 #
1907 sub ftp_open() {
1908   return 1 unless $conf::upload_method eq "ftp";
1909
1910   if ($main::FTP_chan) {
1911
1912     # is already open, but might have timed out; test with a cwd
1913     return $main::FTP_chan
1914       if $main::FTP_chan->cwd($main::current_targetdir);
1915
1916     # cwd didn't work, channel is closed, try to reopen it
1917     $main::FTP_chan = undef;
1918   } ## end if ($main::FTP_chan)
1919
1920   if (
1921        !(
1922           $main::FTP_chan =
1923           Net::FTP->new(
1924                          $conf::target,
1925                          Debug   => $conf::ftpdebug,
1926                          Timeout => $conf::ftptimeout,
1927                          Passive => 1,
1928                        )
1929         )
1930      )
1931   {
1932     msg( "log,mail", "Cannot open FTP server $conf::target\n" );
1933     goto err;
1934   } ## end if ( !( $main::FTP_chan...
1935   if ( !$main::FTP_chan->login() ) {
1936     msg( "log,mail", "Anonymous login on FTP server $conf::target failed\n" );
1937     goto err;
1938   }
1939   if ( !$main::FTP_chan->binary() ) {
1940     msg( "log,mail", "Can't set binary FTP mode on $conf::target\n" );
1941     goto err;
1942   }
1943   if ( !$main::FTP_chan->cwd($main::current_targetdir) ) {
1944     msg( "log,mail",
1945          "Can't cd to $main::current_targetdir on $conf::target\n" );
1946     goto err;
1947   }
1948   debug("opened FTP channel to $conf::target");
1949   return 1;
1950
1951 err:
1952   $main::FTP_chan = undef;
1953   return 0;
1954 } ## end sub ftp_open()
1955
1956 sub ftp_cmd($@) {
1957   my $cmd = shift;
1958   my ( $rv, $err );
1959   my $direct_resp_cmd = ( $cmd eq "quot" );
1960
1961   debug( "executing FTP::$cmd(" . join( ", ", @_ ) . ")" );
1962   $SIG{"ALRM"} = sub { die "timeout in FTP::$cmd\n" };
1963   alarm($conf::remote_timeout);
1964   eval { $rv = $main::FTP_chan->$cmd(@_); };
1965   alarm(0);
1966   $err = "";
1967   $rv = ( ftp_code() =~ /^2/ ) ? 1 : 0 if $direct_resp_cmd;
1968   if ($@) {
1969     $err = $@;
1970     undef $rv;
1971   } elsif ( !$rv ) {
1972     $err = ftp_response();
1973   }
1974   return ( $rv, $err );
1975 } ## end sub ftp_cmd($@)
1976
1977 sub ftp_close() {
1978   if ($main::FTP_chan) {
1979     $main::FTP_chan->quit();
1980     $main::FTP_chan = undef;
1981   }
1982   return 1;
1983 } ## end sub ftp_close()
1984
1985 sub ftp_response() {
1986   return join( '', @{ ${*$main::FTP_chan}{'net_cmd_resp'} } );
1987 }
1988
1989 sub ftp_code() {
1990   return ${*$main::FTP_chan}{'net_cmd_code'};
1991 }
1992
1993 sub ftp_error() {
1994   my $code = ftp_code();
1995   return ( $code =~ /^[45]/ ) ? 1 : 0;
1996 }
1997
1998 # ---------------------------------------------------------------------------
1999 #                                                         utility functions
2000 # ---------------------------------------------------------------------------
2001
2002 sub ssh_cmd($) {
2003   my $cmd = shift;
2004   my ( $msg, $stat );
2005
2006   my $ecmd = "$conf::ssh $conf::ssh_options $conf::target "
2007     . "-l $conf::targetlogin \'cd $main::current_targetdir; $cmd\'";
2008   debug("executing $ecmd");
2009   $SIG{"ALRM"} = sub { die "timeout in ssh command\n" };
2010   alarm($conf::remote_timeout);
2011   eval { $msg = `$ecmd 2>&1`; };
2012   alarm(0);
2013   if ($@) {
2014     $msg  = $@;
2015     $stat = 1;
2016   } else {
2017     $stat = $?;
2018   }
2019   return ( $msg, $stat );
2020 } ## end sub ssh_cmd($)
2021
2022 sub scp_cmd(@) {
2023   my ( $msg, $stat );
2024
2025   my $ecmd = "$conf::scp $conf::ssh_options @_ "
2026     . "$conf::targetlogin\@$conf::target:$main::current_targetdir";
2027   debug("executing $ecmd");
2028   $SIG{"ALRM"} = sub { die "timeout in scp\n" };
2029   alarm($conf::remote_timeout);
2030   eval { $msg = `$ecmd 2>&1`; };
2031   alarm(0);
2032   if ($@) {
2033     $msg  = $@;
2034     $stat = 1;
2035   } else {
2036     $stat = $?;
2037   }
2038   return ( $msg, $stat );
2039 } ## end sub scp_cmd(@)
2040
2041 #
2042 # check if target is alive (code stolen from Net::Ping.pm)
2043 #
2044 sub check_alive(;$) {
2045   my $timeout = shift;
2046   my ( $saddr, $ret, $target_ip );
2047   local (*PINGSOCK);
2048
2049   if ( $conf::upload_method eq "copy" ) {
2050     format_status_num( $main::last_ping_time, time );
2051     $main::target_up = 1;
2052     return;
2053   }
2054
2055   $timeout ||= 30;
2056
2057   if ( !( $target_ip = ( gethostbyname($conf::target) )[4] ) ) {
2058     msg( "log", "Cannot get IP address of $conf::target\n" );
2059     $ret = 0;
2060     goto out;
2061   }
2062   $saddr = pack( 'S n a4 x8', AF_INET, $main::echo_port, $target_ip );
2063   $SIG{'ALRM'} = sub { die };
2064   alarm($timeout);
2065
2066   $ret = $main::tcp_proto;    # avoid warnings about unused variable
2067   $ret = 0;
2068   eval <<'EOM' ;
2069     return unless socket( PINGSOCK, PF_INET, SOCK_STREAM, $main::tcp_proto );
2070     return unless connect( PINGSOCK, $saddr );
2071     $ret = 1;
2072 EOM
2073   alarm(0);
2074   close(PINGSOCK);
2075   msg( "log", "pinging $conf::target: " . ( $ret ? "ok" : "down" ) . "\n" );
2076 out:
2077   $main::target_up = $ret ? "1" : "0";
2078   format_status_num( $main::last_ping_time, time );
2079   write_status_file() if $conf::statusdelay;
2080 } ## end sub check_alive(;$)
2081
2082 #
2083 # check if incoming dir on target is writable
2084 #
2085 sub check_incoming_writable() {
2086   my $testfile = ".debianqueued-testfile";
2087   my ( $msg, $stat );
2088
2089   if ( $conf::upload_method eq "ssh" ) {
2090     ( $msg, $stat ) =
2091       ssh_cmd( "rm -f $testfile; touch $testfile; " . "rm -f $testfile" );
2092   } elsif ( $conf::upload_method eq "ftp" ) {
2093     my $file = "junk-for-writable-test-" . format_time();
2094     $file =~ s/[ :.]/-/g;
2095     local (*F);
2096     open( F, ">", $file );
2097     close(F);
2098     my $rv;
2099     ( $rv, $msg ) = ftp_cmd( "put", $file );
2100     $stat = 0;
2101     $msg = "" if !defined $msg;
2102     unlink $file;
2103     ftp_cmd( "delete", $file );
2104   } elsif ( $conf::upload_method eq "copy" ) {
2105     unless(POSIX::access($main::current_targetdir, &POSIX::W_OK)) {
2106       $msg = "No write access: $!";
2107       $stat = 1;
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::Sender::Simple;
2249
2250   if ($conf::overridemail) {
2251         $addr = $conf::overridemail;
2252   }
2253
2254   my $date = sprintf "%s",
2255     strftime( "%a, %d %b %Y %T %z", ( localtime(time) ) );
2256   my $message = <<__MESSAGE__;
2257 To: $addr
2258 From: Debian FTP Masters <ftpmaster\@ftp-master.debian.org>
2259 Subject: $subject
2260 Date: $date
2261 X-Debian: DAK
2262 X-DAK: DAK
2263 Precedence: bulk
2264 Auto-Submitted: auto-generated
2265 __MESSAGE__
2266
2267   if ( length $package ) {
2268     $message .= "X-Debian-Package: $package\n";
2269   }
2270
2271   $message .= "\n$text";
2272   $message .= "\nGreetings,\n\n\tYour Debian queue daemon (running on host $main::hostname)\n";
2273
2274   return Email::Sender::Simple->try_to_send($message);
2275 } ## end sub send_mail($$$)
2276
2277 #
2278 # try to find a mail address for a name in the keyrings
2279 #
2280 sub try_to_get_mail_addr($$) {
2281   my $name    = shift;
2282   my $listref = shift;
2283
2284   @$listref = ();
2285   open( F,
2286             "$conf::gpg --no-options --batch --no-default-keyring "
2287           . "--always-trust --keyring "
2288           . join( " --keyring ", @conf::keyrings )
2289           . " --list-keys |"
2290       ) or return "";
2291   while (<F>) {
2292     if ( /^pub / && / $name / ) {
2293       /<([^>]*)>/;
2294       push( @$listref, $1 );
2295     }
2296   } ## end while (<F>)
2297   close(F);
2298
2299   return ( @$listref >= 1 ) ? $listref->[0] : "";
2300 } ## end sub try_to_get_mail_addr($$)
2301
2302 #
2303 # return current time as string
2304 #
2305 sub format_time() {
2306   my $t;
2307
2308   # omit weekday and year for brevity
2309   ( $t = localtime ) =~ /^\w+\s(.*)\s\d+$/;
2310   return $1;
2311 } ## end sub format_time()
2312
2313 sub print_time($) {
2314   my $secs = shift;
2315   my $hours = int( $secs / ( 60 * 60 ) );
2316
2317   $secs -= $hours * 60 * 60;
2318   return sprintf "%d:%02d:%02d", $hours, int( $secs / 60 ), $secs % 60;
2319 } ## end sub print_time($)
2320
2321 #
2322 # block some signals during queue processing
2323 #
2324 # This is just to avoid data inconsistency or uploads being aborted in the
2325 # middle. Only "soft" signals are blocked, i.e. SIGINT and SIGTERM, try harder
2326 # ones if you really want to kill the daemon at once.
2327 #
2328 sub block_signals() {
2329   POSIX::sigprocmask( SIG_BLOCK, $main::block_sigset );
2330 }
2331
2332 sub unblock_signals() {
2333   POSIX::sigprocmask( SIG_UNBLOCK, $main::block_sigset );
2334 }
2335
2336 #
2337 # process SIGHUP: close log file and reopen it (for logfile cycling)
2338 #
2339 sub close_log($) {
2340   close(LOG);
2341   close(STDOUT);
2342   close(STDERR);
2343
2344   open( LOG, ">>", $conf::logfile )
2345     or die "Cannot open my logfile $conf::logfile: $!\n";
2346   chmod( 0644, $conf::logfile )
2347     or msg( "log", "Cannot set modes of $conf::logfile: $!\n" );
2348   select( ( select(LOG), $| = 1 )[0] );
2349
2350   open( STDOUT, ">&", \*LOG )
2351     or msg( "log",
2352       "$main::progname: Can't redirect stdout to " . "$conf::logfile: $!\n" );
2353   open( STDERR, ">&", \*LOG )
2354     or msg( "log",
2355       "$main::progname: Can't redirect stderr to " . "$conf::logfile: $!\n" );
2356   msg( "log", "Restart after SIGHUP\n" );
2357 } ## end sub close_log($)
2358
2359 #
2360 # process SIGCHLD: check if it was our statusd process
2361 #
2362 sub kid_died($) {
2363   my $pid;
2364
2365   # reap statusd, so that it's no zombie when we try to kill(0) it
2366   waitpid( $main::statusd_pid, WNOHANG );
2367
2368   # Uncomment the following line if your Perl uses unreliable System V signal
2369   # (i.e. if handlers reset to default if the signal is delivered).
2370   # (Unfortunately, the re-setup can't be done in any case, since on some
2371   # systems this will cause the SIGCHLD to be delivered again if there are
2372   # still unreaped children :-(( )
2373
2374   #      $SIG{"CHLD"} = \&kid_died; # resetup handler for SysV
2375 } ## end sub kid_died($)
2376
2377 sub restart_statusd() {
2378
2379   # restart statusd if it died
2380   if ( !kill( 0, $main::statusd_pid ) ) {
2381     close(STATUSD);    # close out pipe end
2382     $main::statusd_pid = fork_statusd();
2383   }
2384 } ## end sub restart_statusd()
2385
2386 #
2387 # process a fatal signal: cleanup and exit
2388 #
2389 sub fatal_signal($) {
2390   my $signame = shift;
2391   my $sig;
2392
2393   # avoid recursions of fatal_signal in case of BSD signals
2394   foreach $sig (qw( ILL ABRT BUS FPE SEGV PIPE )) {
2395     $SIG{$sig} = "DEFAULT";
2396   }
2397
2398   if ( $$ == $main::maind_pid ) {
2399
2400     # only the main daemon should do this
2401     kill( $main::signo{"TERM"}, $main::statusd_pid )
2402       if defined $main::statusd_pid;
2403     unlink( $conf::statusfile, $conf::pidfile );
2404   } ## end if ( $$ == $main::maind_pid)
2405   msg( "log", "Caught SIG$signame -- exiting (pid $$)\n" );
2406   exit 1;
2407 } ## end sub fatal_signal($)
2408
2409 # Local Variables:
2410 #  tab-width: 4
2411 #  fill-column: 78
2412 # End: