tools/debianqueued-0.9/debianqueued

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