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