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