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 );
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,/,) {
1261                                         msg( "mail,log", "$_: filename may not contain slashes\n" );
1262                                 }
1263                                 elsif (/[*?[]/) {
1264                                         # process wildcards
1265                                         my $pat = quotemeta($_);
1266                                         $pat =~ s/\\\*/.*/g;
1267                                         $pat =~ s/\\\?/.?/g;
1268                                         $pat =~ s/\\([][])/$1/g;
1269                                         opendir( DIR, "." );
1270                                         push( @files, grep /^$pat$/, readdir(DIR) );
1271                                         closedir( DIR );
1272                                 }
1273                                 else {
1274                                         push( @files, $_ );
1275                                 }
1276                         }
1277                         if (!@files) {
1278                                 msg( "mail,log", "No files to delete\n" );
1279                         }
1280                         else {
1281                                 @removed = ();
1282                                 foreach $file ( @files ) {
1283                                         if (!-f $file) {
1284                                                 msg( "mail,log", "$file: no such file\n" );
1285                                         }
1286                                         elsif ($file =~ /$conf::keep_files/) {
1287                                                 msg( "mail,log", "$file is protected, cannot ".
1288                                                          "remove\n" );
1289                                         }
1290                                         elsif (!unlink( $file )) {
1291                                                 msg( "mail,log", "$file: rm: $!\n" );
1292                                         }
1293                                         else {
1294                                                 push( @removed, $file );
1295                                         }
1296                                 }
1297                                 msg( "mail,log", "Files removed: @removed\n" ) if @removed;
1298                         }
1299                 }
1300                 elsif ($word[0] eq "mv") {
1301                         if (@word != 3) {
1302                                 msg( "mail,log", "Wrong number of arguments\n" );
1303                         }
1304                         elsif ($word[1] =~ m,/,) {
1305                                 msg( "mail,log", "$word[1]: filename may not contain slashes\n" );
1306                         }
1307                         elsif ($word[2] =~ m,/,) {
1308                                 msg( "mail,log", "$word[2]: filename may not contain slashes\n" );
1309                         }
1310                         elsif (!-f $word[1]) {
1311                                 msg( "mail,log", "$word[1]: no such file\n" );
1312                         }
1313                         elsif (-e $word[2]) {
1314                                 msg( "mail,log", "$word[2]: file exists\n" );
1315                         }
1316                         elsif ($word[1] =~ /$conf::keep_files/) {
1317                                 msg( "mail,log", "$word[1] is protected, cannot rename\n" );
1318                         }
1319                         else {
1320                                 if (!rename( $word[1], $word[2] )) {
1321                                         msg( "mail,log", "rename: $!\n" );
1322                                 }
1323                                 else {
1324                                         msg( "mail,log", "OK\n" );
1325                                 }
1326                         }
1327                 }
1328                 else {
1329                         msg( "mail,log", "unknown command $word[0]\n" );
1330                 }
1331         }
1332         rm( $commands );
1333         msg( "log", "-- End of $main::current_incoming_short/$commands processing\n" );
1334 }
1335
1336 #
1337 # check if a file is already on target
1338 #
1339 sub is_on_target($) {
1340         my $file = shift;
1341         my $msg;
1342         my $stat;
1343
1344         if ($conf::upload_method eq "ssh") {
1345                 ($msg, $stat) = ssh_cmd( "ls -l $file" );
1346         }
1347         elsif ($conf::upload_method eq "ftp") {
1348                 my $err;
1349                 ($msg, $err) = ftp_cmd( "dir", $file );
1350                 if ($err) {
1351                         $stat = 1;
1352                         $msg = $err;
1353                 }
1354                 elsif (!$msg) {
1355                         $stat = 1;
1356                         $msg = "ls: no such file\n";
1357                 }
1358                 else {
1359                         $stat = 0;
1360                         $msg = join( "\n", @$msg );
1361                 }
1362         }
1363         else {
1364                 ($msg, $stat) = local_cmd( "$conf::ls -l $file" );
1365         }
1366         chomp( $msg );
1367         debug( "exit status: $stat, output was: $msg" );
1368
1369         return "" if $stat && $msg =~ /no such file/i; # file not present
1370         msg( "log", "strange ls -l output on target:\n", $msg ), return ""
1371                 if $stat || $@; # some other error, but still try to upload
1372
1373         # ls -l returned 0 -> file already there
1374         $msg =~ s/\s\s+/ /g; # make multiple spaces into one, to save space
1375         return $msg;
1376 }
1377
1378 #
1379 # copy a list of files to target
1380 #
1381 sub copy_to_target(@) {
1382         my @files = @_;
1383         my( @md5sum, @expected_files, $sum, $name, $msgs, $stat );
1384
1385         $main::dstat = "u";
1386         write_status_file() if $conf::statusdelay;
1387
1388         # copy the files
1389         if ($conf::upload_method eq "ssh") {
1390                 ($msgs, $stat) = scp_cmd( @files );
1391                 goto err if $stat;
1392         }
1393         elsif ($conf::upload_method eq "ftp") {
1394                 my($rv, $file);
1395                 if (!$main::FTP_chan->cwd( $main::current_targetdir )) {
1396                         msg( "log,mail", "Can't cd to $main::current_targetdir on $conf::target\n" );
1397                         goto err;
1398                 }
1399                 foreach $file (@files) {
1400                         ($rv, $msgs) = ftp_cmd( "put", $file );
1401                         goto err if !$rv;
1402                 }
1403         }
1404         else {
1405                 ($msgs, $stat) = local_cmd( "$conf::cp @files $main::current_targetdir", 'NOCD' );
1406                 goto err if $stat;
1407         }
1408
1409         # check md5sums or sizes on target against our own
1410         my $have_md5sums = 1;
1411         if ($conf::upload_method eq "ssh") {
1412                 ($msgs, $stat) = ssh_cmd( "md5sum @files" );
1413                 goto err if $stat;
1414                 @md5sum = split( "\n", $msgs );
1415         }
1416         elsif ($conf::upload_method eq "ftp") {
1417                 my ($rv, $err, $file);
1418                 foreach $file (@files) {
1419                         ($rv, $err) = ftp_cmd( "quot", "site", "md5sum", $file );
1420                         if ($err) {
1421                                 next if ftp_code() == 550; # file not found
1422                                 if (ftp_code() == 500) { # unimplemented
1423                                         $have_md5sums = 0;
1424                                         goto get_sizes_instead;
1425                                 }
1426                                 $msgs = $err;
1427                                 goto err;
1428                         }
1429                         chomp( my $t = ftp_response() );
1430                         push( @md5sum, $t );
1431                 }
1432                 if (!$have_md5sums) {
1433                   get_sizes_instead:
1434                         foreach $file (@files) {
1435                                 ($rv, $err) = ftp_cmd( "size", $file );
1436                                 if ($err) {
1437                                         next if ftp_code() == 550; # file not found
1438                                         $msgs = $err;
1439                                         goto err;
1440                                 }
1441                                 push( @md5sum, "$rv $file" );
1442                         }
1443                 }
1444         }
1445         else {
1446                 ($msgs, $stat) = local_cmd( "$conf::md5sum @files" );
1447                 goto err if $stat;
1448                 @md5sum = split( "\n", $msgs );
1449         }
1450
1451         @expected_files = @files;
1452         foreach (@md5sum) {
1453                 chomp;
1454                 ($sum,$name) = split;
1455                 next if !grep { $_ eq $name } @files; # a file we didn't upload??
1456                 next if $sum eq "md5sum:"; # looks like an error message
1457                 if (($have_md5sums && $sum ne md5sum( $name )) ||
1458                         (!$have_md5sums && $sum != (-s $name))) {
1459                         msg( "log,mail", "Upload of $name to $conf::target failed ",
1460                                  "(".($have_md5sums ? "md5sum" : "size")." mismatch)\n" );
1461                         goto err;
1462                 }
1463                 # seen that file, remove it from expect list
1464                 @expected_files = map { $_ eq $name ? () : $_ } @expected_files;
1465         }
1466         if (@expected_files) {
1467                 msg( "log,mail", "Failed to upload the files\n" );
1468                 msg( "log,mail", "  ", join( ", ", @expected_files ), "\n" );
1469                 msg( "log,mail", "(Not present on target after upload)\n" );
1470                 goto err;
1471         }
1472
1473         if ($conf::chmod_on_target) {
1474                 # change file's mode explicitly to 644 on target
1475                 if ($conf::upload_method eq "ssh") {
1476                         ($msgs, $stat) = ssh_cmd( "chmod 644 @files" );
1477                         goto err if $stat;
1478                 }
1479                 elsif ($conf::upload_method eq "ftp") {
1480                         my ($rv, $file);
1481                         foreach $file (@files) {
1482                                 ($rv, $msgs) = ftp_cmd( "quot", "site", "chmod", "644", $file );
1483                                 msg( "log", "Can't chmod $file on target:\n$msgs" )
1484                                         if $msgs;
1485                                 goto err if !$rv;
1486                         }
1487                 }
1488                 else {
1489                         ($msgs, $stat) = local_cmd( "$conf::chmod 644 @files" );
1490                         goto err if $stat;
1491                 }
1492         }
1493
1494         $main::dstat = "c";
1495         write_status_file() if $conf::statusdelay;
1496         return 1;
1497
1498   err:
1499         msg( "log,mail", "Upload to $conf::target failed",
1500                  $? ? ", last exit status ".sprintf( "%s", $?>>8 ) : "", "\n" );
1501         msg( "log,mail", "Error messages:\n", $msgs )
1502                 if $msgs;
1503
1504         # If "permission denied" was among the errors, test if the incoming is
1505         # writable at all.
1506         if ($msgs =~ /(permission denied|read-?only file)/i) {
1507                 if (!check_incoming_writable()) {
1508                         msg( "log,mail", "(The incoming directory seems to be ",
1509                                              "unwritable.)\n" );
1510                 }
1511         }
1512
1513         # remove bad files or an incomplete upload on target
1514         if ($conf::upload_method eq "ssh") {
1515                 ssh_cmd( "rm -f @files" );
1516         }
1517         elsif ($conf::upload_method eq "ftp") {
1518                 my $file;
1519                 foreach $file (@files) {
1520                         my ($rv, $err);
1521                         ($rv, $err) = ftp_cmd( "delete", $file );
1522                         msg( "log", "Can't delete $file on target:\n$err" )
1523                                 if $err;
1524                 }
1525         }
1526         else {
1527                 my @tfiles = map { "$main::current_targetdir/$_" } @files;
1528                 debug( "executing unlink(@tfiles)" );
1529                 rm( @tfiles );
1530         }
1531         $main::dstat = "c";
1532         write_status_file() if $conf::statusdelay;
1533         return 0;
1534 }
1535
1536 #
1537 # check if a file is correctly signed with PGP
1538 #
1539 sub pgp_check($) {
1540         my $file = shift;
1541         my $output = "";
1542         my $signator;
1543         my $found = 0;
1544         my $stat;
1545         local( *PIPE );
1546
1547         $stat = 1;
1548         if (-x $conf::gpg) {
1549                 debug( "executing $conf::gpg --no-options --batch ".
1550                    "--no-default-keyring --always-trust ".
1551                    "--keyring ". join (" --keyring ",@conf::keyrings).
1552                    "--verify '$file'" );
1553                 if (!open( PIPE, "$conf::gpg --no-options --batch ".
1554                    "--no-default-keyring --always-trust ".
1555                    "--keyring " . join (" --keyring ",@conf::keyrings).
1556                    "--verify '$file'".
1557                    " 2>&1 |" )) {
1558                         msg( "log", "Can't open pipe to $conf::gpg: $!\n" );
1559                         return "LOCAL ERROR";
1560                 }
1561                 $output .= $_ while( <PIPE> );
1562                 close( PIPE );
1563                 $stat = $?;
1564         }
1565
1566         if ($stat) {
1567                 msg( "log,mail", "GnuPG signature check failed on $file\n" );
1568                 msg( "mail", $output );
1569                 msg( "log,mail", "(Exit status ", $stat >> 8, ")\n" );
1570                 return "";
1571         }
1572
1573         $output =~ /^(gpg: )?good signature from (user )?"(.*)"\.?$/im;
1574         ($signator = $3) ||= "unknown signator";
1575         if ($conf::debug) {
1576                 debug( "GnuPG signature ok (by $signator)" );
1577         }
1578         return $signator;
1579 }
1580
1581
1582 # ---------------------------------------------------------------------------
1583 #                                                         the status daemon
1584 # ---------------------------------------------------------------------------
1585
1586 #
1587 # fork a subprocess that watches the 'status' FIFO
1588 #
1589 # that process blocks until someone opens the FIFO, then sends a
1590 # signal (SIGUSR1) to the main process, expects
1591 #
1592 sub fork_statusd() {
1593         my $statusd_pid;
1594         my $main_pid = $$;
1595         my $errs;
1596         local( *STATFIFO );
1597
1598         $statusd_pid = open( STATUSD, "|-" );
1599         die "cannot fork: $!\n" if !defined( $statusd_pid );
1600         # parent just returns
1601         if ($statusd_pid) {
1602                 msg( "log", "forked status daemon (pid $statusd_pid)\n" );
1603                 return $statusd_pid;
1604         }
1605         # child: the status FIFO daemon
1606
1607         # ignore SIGPIPE here, in case some closes the FIFO without completely
1608         # reading it
1609         $SIG{"PIPE"} = "IGNORE";
1610         # also ignore SIGCLD, we don't want to inherit the restart-statusd handler
1611         # from our parent
1612         $SIG{"CHLD"} = "DEFAULT";
1613
1614         rm( $conf::statusfile );
1615         $errs = `$conf::mkfifo $conf::statusfile`;
1616         die "$main::progname: cannot create named pipe $conf::statusfile: $errs"
1617                 if $?;
1618         chmod( 0644, $conf::statusfile )
1619                 or die "Cannot set modes of $conf::statusfile: $!\n";
1620
1621         # close log file, so that log rotating works
1622         close( LOG );
1623         close( STDOUT );
1624         close( STDERR );
1625
1626         while( 1 ) {
1627                 my( $status, $mup, $incw, $ds, $next_run, $last_ping, $currch, $l );
1628
1629                 # open the FIFO for writing; this blocks until someone (probably ftpd)
1630                 # opens it for reading
1631                 open( STATFIFO, ">$conf::statusfile" )
1632                         or die "Cannot open $conf::statusfile\n";
1633                 select( STATFIFO );
1634                 # tell main daemon to send us status infos
1635                 kill( $main::signo{"USR1"}, $main_pid );
1636
1637                 # get the infos from stdin; must loop until enough bytes received!
1638                 my $expect_len = 3 + 2*STATNUM_LEN + STATSTR_LEN;
1639                 for( $status = ""; ($l = length($status)) < $expect_len; ) {
1640                         sysread( STDIN, $status, $expect_len-$l, $l );
1641                 }
1642
1643                 # disassemble the status byte stream
1644                 my $pos = 0;
1645                 foreach ( [ mup => 1 ], [ incw => 1 ], [ ds => 1 ],
1646                                   [ next_run => STATNUM_LEN ], [ last_ping => STATNUM_LEN ],
1647                                   [ currch => STATSTR_LEN ] ) {
1648                         eval "\$$_->[0] = substr( \$status, $pos, $_->[1] );";
1649                         $pos += $_->[1];
1650                 }
1651                 $currch =~ s/\n+//g;
1652
1653                 print_status( $mup, $incw, $ds, $next_run, $last_ping, $currch );
1654                 close( STATFIFO );
1655
1656                 # This sleep is necessary so that we can't reopen the FIFO
1657                 # immediately, in case the reader hasn't closed it yet if we get to
1658                 # the open again. Is there a better solution for this??
1659                 sleep 1;
1660         }
1661 }
1662
1663 #
1664 # update the status file, in case we use a plain file and not a FIFO
1665 #
1666 sub write_status_file() {
1667
1668         return if !$conf::statusfile;
1669
1670         open( STATFILE, ">$conf::statusfile" ) or
1671                 (msg( "log", "Could not open $conf::statusfile: $!\n" ), return);
1672         my $oldsel = select( STATFILE );
1673
1674         print_status( $main::target_up, $main::incoming_writable, $main::dstat,
1675                                   $main::next_run, $main::last_ping_time,
1676                                   $main::current_changes );
1677
1678         select( $oldsel );
1679         close( STATFILE );
1680 }
1681
1682 sub print_status($$$$$$) {
1683         my $mup = shift;
1684         my $incw = shift;
1685         my $ds = shift;
1686         my $next_run = shift;
1687         my $last_ping = shift;
1688         my $currch = shift;
1689         my $approx;
1690         my $version;
1691
1692         ($version = 'Release: 0.9 $Revision: 1.51 $') =~ s/\$ ?//g;
1693         print "debianqueued $version\n";
1694
1695         $approx = $conf::statusdelay ? "approx. " : "";
1696
1697         if ($mup eq "0") {
1698                 print "$conf::target is down, queue pausing\n";
1699                 return;
1700         }
1701         elsif ($conf::upload_method ne "copy") {
1702                 print "$conf::target seems to be up, last ping $approx",
1703                           print_time(time-$last_ping), " ago\n";
1704         }
1705
1706         if ($incw eq "0") {
1707                 print "The incoming directory is not writable, queue pausing\n";
1708                 return;
1709         }
1710
1711         if ($ds eq "i") {
1712                 print "Next queue check in $approx",print_time($next_run-time),"\n";
1713                 return;
1714         }
1715         elsif ($ds eq "c") {
1716                 print "Checking queue directory\n";
1717         }
1718         elsif ($ds eq "u") {
1719                 print "Uploading to $conf::target\n";
1720         }
1721         else {
1722                 print "Bad status data from daemon: \"$mup$incw$ds\"\n";
1723                 return;
1724         }
1725
1726         print "Current job is $currch\n" if $currch;
1727 }
1728
1729 #
1730 # format a number for sending to statusd (fixed length STATNUM_LEN)
1731 #
1732 sub format_status_num(\$$) {
1733         my $varref = shift;
1734         my $num = shift;
1735
1736         $$varref = sprintf "%".STATNUM_LEN."d", $num;
1737 }
1738
1739 #
1740 # format a string for sending to statusd (fixed length STATSTR_LEN)
1741 #
1742 sub format_status_str(\$$) {
1743         my $varref = shift;
1744         my $str = shift;
1745
1746         $$varref = substr( $str, 0, STATSTR_LEN );
1747         $$varref .= "\n" x (STATSTR_LEN - length($$varref));
1748 }
1749
1750 #
1751 # send a status string to the status daemon
1752 #
1753 # Avoid all operations that could call malloc() here! Most libc
1754 # implementations aren't reentrant, so we may not call it from a
1755 # signal handler. So use only already-defined variables.
1756 #
1757 sub send_status() {
1758     local $! = 0; # preserve errno
1759
1760         # re-setup handler, in case we have broken SysV signals
1761         $SIG{"USR1"} = \&send_status;
1762
1763         syswrite( STATUSD, $main::target_up, 1 );
1764         syswrite( STATUSD, $main::incoming_writable, 1 );
1765         syswrite( STATUSD, $main::dstat, 1 );
1766         syswrite( STATUSD, $main::next_run, STATNUM_LEN );
1767         syswrite( STATUSD, $main::last_ping_time, STATNUM_LEN );
1768         syswrite( STATUSD, $main::current_changes, STATSTR_LEN );
1769 }
1770
1771
1772 # ---------------------------------------------------------------------------
1773 #                                                           FTP functions
1774 # ---------------------------------------------------------------------------
1775
1776 #
1777 # open FTP connection to target host if not already open
1778 #
1779 sub ftp_open() {
1780
1781         if ($main::FTP_chan) {
1782                 # is already open, but might have timed out; test with a cwd
1783                 return $main::FTP_chan if $main::FTP_chan->cwd( $main::current_targetdir );
1784                 # cwd didn't work, channel is closed, try to reopen it
1785                 $main::FTP_chan = undef;
1786         }
1787
1788         if (!($main::FTP_chan = Net::FTP->new( $conf::target,
1789                                                                                    Debug => $conf::ftpdebug,
1790                                                                                    Timeout => $conf::ftptimeout ))) {
1791                 msg( "log,mail", "Cannot open FTP server $conf::target\n" );
1792                 goto err;
1793         }
1794         if (!$main::FTP_chan->login()) {
1795                 msg( "log,mail", "Anonymous login on FTP server $conf::target failed\n" );
1796                 goto err;
1797         }
1798         if (!$main::FTP_chan->binary()) {
1799                 msg( "log,mail", "Can't set binary FTP mode on $conf::target\n" );
1800                 goto err;
1801         }
1802         if (!$main::FTP_chan->cwd( $main::current_targetdir )) {
1803                 msg( "log,mail", "Can't cd to $main::current_targetdir on $conf::target\n" );
1804                 goto err;
1805         }
1806         debug( "opened FTP channel to $conf::target" );
1807         return 1;
1808
1809   err:
1810         $main::FTP_chan = undef;
1811         return 0;
1812 }
1813
1814 sub ftp_cmd($@) {
1815         my $cmd = shift;
1816         my ($rv, $err);
1817         my $direct_resp_cmd = ($cmd eq "quot");
1818
1819         debug( "executing FTP::$cmd(".join(", ",@_).")" );
1820         $SIG{"ALRM"} = sub { die "timeout in FTP::$cmd\n" } ;
1821         alarm( $conf::remote_timeout );
1822         eval { $rv = $main::FTP_chan->$cmd( @_ ); };
1823         alarm( 0 );
1824         $err = "";
1825         $rv = (ftp_code() =~ /^2/) ? 1 : 0 if $direct_resp_cmd;
1826         if ($@) {
1827                 $err = $@;
1828                 undef $rv;
1829         }
1830         elsif (!$rv) {
1831                 $err = ftp_response();
1832         }
1833         return ($rv, $err);
1834 }
1835
1836 sub ftp_close() {
1837         if ($main::FTP_chan) {
1838                 $main::FTP_chan->quit();
1839                 $main::FTP_chan = undef;
1840         }
1841         return 1;
1842 }
1843
1844 sub ftp_response() {
1845         return join( '', @{${*$main::FTP_chan}{'net_cmd_resp'}} );
1846 }
1847
1848 sub ftp_code() {
1849         return ${*$main::FTP_chan}{'net_cmd_code'};
1850 }
1851
1852 sub ftp_error() {
1853         my $code = ftp_code();
1854         return ($code =~ /^[45]/) ? 1 : 0;
1855 }
1856
1857 # ---------------------------------------------------------------------------
1858 #                                                         utility functions
1859 # ---------------------------------------------------------------------------
1860
1861 sub ssh_cmd($) {
1862         my $cmd = shift;
1863         my ($msg, $stat);
1864
1865         my $ecmd = "$conf::ssh $conf::ssh_options $conf::target ".
1866                            "-l $conf::targetlogin \'cd $main::current_targetdir; $cmd\'";
1867         debug( "executing $ecmd" );
1868         $SIG{"ALRM"} = sub { die "timeout in ssh command\n" } ;
1869         alarm( $conf::remote_timeout );
1870         eval { $msg = `$ecmd 2>&1`; };
1871         alarm( 0 );
1872         if ($@) {
1873                 $msg = $@;
1874                 $stat = 1;
1875         }
1876         else {
1877                 $stat = $?;
1878         }
1879         return ($msg, $stat);
1880 }
1881
1882 sub scp_cmd(@) {
1883         my ($msg, $stat);
1884
1885         my $ecmd = "$conf::scp $conf::ssh_options @_ ".
1886                            "$conf::targetlogin\@$conf::target:$main::current_targetdir";
1887         debug( "executing $ecmd" );
1888         $SIG{"ALRM"} = sub { die "timeout in scp\n" } ;
1889         alarm( $conf::remote_timeout );
1890         eval { $msg = `$ecmd 2>&1`; };
1891         alarm( 0 );
1892         if ($@) {
1893                 $msg = $@;
1894                 $stat = 1;
1895         }
1896         else {
1897                 $stat = $?;
1898         }
1899         return ($msg, $stat);
1900 }
1901
1902 sub local_cmd($;$) {
1903         my $cmd = shift;
1904         my $nocd = shift;
1905         my ($msg, $stat);
1906
1907         my $ecmd = ($nocd ? "" : "cd $main::current_targetdir; ") . $cmd;
1908         debug( "executing $ecmd" );
1909         $msg = `($ecmd) 2>&1`;
1910         $stat = $?;
1911         return ($msg, $stat);
1912
1913 }
1914
1915 #
1916 # check if target is alive (code stolen from Net::Ping.pm)
1917 #
1918 sub check_alive(;$) {
1919     my $timeout = shift;
1920     my( $saddr, $ret, $target_ip );
1921     local( *PINGSOCK );
1922
1923         if ($conf::upload_method eq "copy") {
1924                 format_status_num( $main::last_ping_time, time );
1925                 $main::target_up = 1;
1926                 return;
1927         }
1928
1929     $timeout ||= 30;
1930
1931         if (!($target_ip = (gethostbyname($conf::target))[4])) {
1932                 msg( "log", "Cannot get IP address of $conf::target\n" );
1933                 $ret = 0;
1934                 goto out;
1935         }
1936     $saddr = pack( 'S n a4 x8', AF_INET, $main::echo_port, $target_ip );
1937     $SIG{'ALRM'} = sub { die } ;
1938     alarm( $timeout );
1939
1940         $ret = $main::tcp_proto; # avoid warnings about unused variable
1941     $ret = 0;
1942     eval <<'EOM' ;
1943     return unless socket( PINGSOCK, PF_INET, SOCK_STREAM, $main::tcp_proto );
1944     return unless connect( PINGSOCK, $saddr );
1945     $ret = 1;
1946 EOM
1947     alarm( 0 );
1948     close( PINGSOCK );
1949         msg( "log", "pinging $conf::target: " . ($ret ? "ok" : "down") . "\n" );
1950   out:
1951         $main::target_up = $ret ? "1" : "0";
1952         format_status_num( $main::last_ping_time, time );
1953         write_status_file() if $conf::statusdelay;
1954 }
1955
1956 #
1957 # check if incoming dir on target is writable
1958 #
1959 sub check_incoming_writable() {
1960         my $testfile = ".debianqueued-testfile";
1961         my ($msg, $stat);
1962
1963         if ($conf::upload_method eq "ssh") {
1964                 ($msg, $stat) = ssh_cmd( "rm -f $testfile; touch $testfile; ".
1965                                                                  "rm -f $testfile" );
1966         }
1967         elsif ($conf::upload_method eq "ftp") {
1968                 my $file = "junk-for-writable-test-".format_time();
1969                 $file =~ s/[ :.]/-/g;
1970                 local( *F );
1971                 open( F, ">$file" ); close( F );
1972                 my $rv;
1973                 ($rv, $msg) = ftp_cmd( "put", $file );
1974                 $stat = 0;
1975                 $msg = "" if !defined $msg;
1976                 unlink $file;
1977                 ftp_cmd( "delete", $file );
1978         }
1979         elsif ($conf::upload_method eq "copy") {
1980                 ($msg, $stat) = local_cmd( "rm -f $testfile; touch $testfile; ".
1981                                                                    "rm -f $testfile" );
1982         }
1983         chomp( $msg );
1984         debug( "exit status: $stat, output was: $msg" );
1985
1986         if (!$stat) {
1987                 # change incoming_writable only if ssh didn't return an error
1988                 $main::incoming_writable =
1989                         ($msg =~ /(permission denied|read-?only file|cannot create)/i) ? "0":"1";
1990         }
1991         else {
1992                 debug( "local error, keeping old status" );
1993         }
1994         debug( "incoming_writable = $main::incoming_writable" );
1995         write_status_file() if $conf::statusdelay;
1996         return $main::incoming_writable;
1997 }
1998
1999 #
2000 # remove a list of files, log failing ones
2001 #
2002 sub rm(@) {
2003         my $done = 0;
2004
2005         foreach ( @_ ) {
2006                 (unlink $_ and ++$done)
2007                         or $! == ENOENT or msg( "log", "Could not delete $_: $!\n" );
2008         }
2009         return $done;
2010 }
2011
2012 #
2013 # get md5 checksum of a file
2014 #
2015 sub md5sum($) {
2016         my $file = shift;
2017         my $line;
2018
2019         chomp( $line = `$conf::md5sum $file` );
2020         debug( "md5sum($file): ", $? ? "exit status $?" :
2021                                       $line =~ /^(\S+)/ ? $1 : "match failed" );
2022         return $? ? "" : $line =~ /^(\S+)/ ? $1 : "";
2023 }
2024
2025 #
2026 # check if a file probably belongs to a Debian upload
2027 #
2028 sub is_debian_file($) {
2029         my $file = shift;
2030         return $file =~ /\.(deb|dsc|(diff|tar)\.gz)$/ &&
2031                    $file !~ /\.orig\.tar\.gz/;
2032 }
2033
2034 #
2035 # try to extract maintainer email address from some a non-.changes file
2036 # return "" if not possible
2037 #
2038 sub get_maintainer($) {
2039         my $file = shift;
2040         my $maintainer = "";
2041         local( *F );
2042
2043         if ($file =~ /\.diff\.gz$/) {
2044                 # parse a diff
2045                 open( F, "$conf::gzip -dc '$file' 2>/dev/null |" ) or return "";
2046                 while( <F> ) {
2047                         # look for header line of a file */debian/control
2048                         last if m,^\+\+\+\s+[^/]+/debian/control(\s+|$),;
2049                 }
2050                 while( <F> ) {
2051                         last if /^---/; # end of control file patch, no Maintainer: found
2052                         # inside control file patch look for Maintainer: field
2053                         $maintainer = $1, last if /^\+Maintainer:\s*(.*)$/i;
2054                 }
2055                 while( <F> ) { } # read to end of file to avoid broken pipe
2056                 close( F ) or return "";
2057         }
2058         elsif ($file =~ /\.(deb|dsc|tar\.gz)$/) {
2059                 if ($file =~ /\.deb$/ && $conf::ar) {
2060                         # extract control.tar.gz from .deb with ar, then let tar extract
2061                         # the control file itself
2062                         open( F, "($conf::ar p '$file' control.tar.gz | ".
2063                                      "$conf::tar -xOf - ".
2064                                      "--use-compress-program $conf::gzip ".
2065                                      "control) 2>/dev/null |" )
2066                                 or return "";
2067                 }
2068                 elsif ($file =~ /\.dsc$/) {
2069                         # just do a plain grep
2070                         debug( "get_maint: .dsc, no cmd" );
2071                         open( F, "<$file" ) or return "";
2072                 }
2073                 elsif ($file =~ /\.tar\.gz$/) {
2074                         # let tar extract a file */debian/control
2075                         open(F, "$conf::tar -xOf '$file' ".
2076                                     "--use-compress-program $conf::gzip ".
2077                                     "\\*/debian/control 2>&1 |")
2078                                 or return "";
2079                 }
2080                 else {
2081                         return "";
2082                 }
2083                 while( <F> ) {
2084                         $maintainer = $1, last if /^Maintainer:\s*(.*)$/i;
2085                 }
2086                 close( F ) or return "";
2087         }
2088
2089         return $maintainer;
2090 }
2091
2092 #
2093 # return a pattern that matches all files that probably belong to one job
2094 #
2095 sub debian_file_stem($) {
2096         my $file = shift;
2097         my( $pkg, $version );
2098
2099         # strip file suffix
2100         $file =~ s,\.(deb|dsc|changes|(orig\.)?tar\.gz|diff\.gz)$,,;
2101         # if not is *_* (name_version), can't derive a stem and return just
2102         # the file's name
2103         return $file if !($file =~ /^([^_]+)_([^_]+)/);
2104         ($pkg, $version) = ($1, $2);
2105         # strip Debian revision from version
2106         $version =~ s/^(.*)-[\d.+-]+$/$1/;
2107
2108         return "${pkg}_${version}*";
2109 }
2110
2111 #
2112 # output a messages to several destinations
2113 #
2114 # first arg is a comma-separated list of destinations; valid are "log"
2115 # and "mail"; rest is stuff to be printed, just as with print
2116 #
2117 sub msg($@) {
2118         my @dest = split( ',', shift );
2119
2120         if (grep /log/, @dest ) {
2121                 my $now = format_time();
2122                 print LOG "$now ", @_;
2123         }
2124
2125         if (grep /mail/, @dest ) {
2126                 $main::mail_text .= join( '', @_ );
2127         }
2128 }
2129
2130 #
2131 # print a debug messages, if $debug is true
2132 #
2133 sub debug(@) {
2134         return if !$conf::debug;
2135         my $now = format_time();
2136         print LOG "$now DEBUG ", @_, "\n";
2137 }
2138
2139 #
2140 # intialize the "mail" destination of msg() (this clears text,
2141 # address, subject, ...)
2142 #
2143 sub init_mail(;$) {
2144         my $file = shift;
2145
2146         $main::mail_addr = "";
2147         $main::mail_text = "";
2148         %main::packages  = ();
2149         $main::mail_subject = $file ? "Processing of $file" : "";
2150 }
2151
2152 #
2153 # finalize mail to be sent from msg(): check if something present, and
2154 # then send out
2155 #
2156 sub finish_mail() {
2157
2158         debug( "No mail for $main::mail_addr" )
2159                 if $main::mail_addr && !$main::mail_text;
2160         return unless $main::mail_addr && $main::mail_text;
2161
2162         if (!send_mail($main::mail_addr, $main::mail_subject, $main::mail_text)) {
2163                 # store this mail in memory so it isn't lost if executing sendmail
2164                 # failed.
2165                 push( @main::stored_mails, { addr    => $main::mail_addr,
2166                                                                          subject => $main::mail_subject,
2167                                                                          text    => $main::mail_text } );
2168         }
2169         init_mail();
2170
2171         # try to send out stored mails
2172         my $mailref;
2173         while( $mailref = shift(@main::stored_mails) ) {
2174                 if (!send_mail( $mailref->{'addr'}, $mailref->{'subject'},
2175                                             $mailref->{'text'} )) {
2176                         unshift( @main::stored_mails, $mailref );
2177                         last;
2178                 }
2179         }
2180 }
2181
2182 #
2183 # send one mail
2184 #
2185 sub send_mail($$$) {
2186         my $addr = shift;
2187         my $subject = shift;
2188         my $text = shift;
2189
2190         my $package = keys %main::packages ? join(' ', keys %main::packages) : "";
2191
2192         use Email::Send;
2193
2194         unless (defined($Email::Send::Sendmail::SENDMAIL)) {
2195                 $Email::Send::Sendmail::SENDMAIL = $conf::mail;
2196         }
2197
2198         my $date = sprintf "%s", strftime("%a, %d %b %Y %T %z", (localtime(time)));
2199         my $message = <<__MESSAGE__;
2200 To: $addr
2201 From: Archive Administrator <dak\@ftp-master.debian.org>
2202 Subject: $subject
2203 Date: $date
2204 X-Debian: DAK
2205 __MESSAGE__
2206
2207         if (length $package) {
2208                 $message .= "X-Debian-Package: $package\n";
2209         }
2210
2211         $message .= "\n$text";
2212         $message .= "\nGreetings,\n\n\tYour Debian queue daemon\n";
2213
2214         my $mail = Email::Send->new;
2215         for ( qw[Sendmail SMTP] ) {
2216                 $mail->mailer($_) and last if $mail->mailer_available($_);
2217         }
2218
2219         my $ret = $mail->send($message);
2220         if ($ret && $ret !~ /Message sent|success/) {
2221                 return 0;
2222         }
2223
2224         return 1;
2225 }
2226
2227 #
2228 # try to find a mail address for a name in the keyrings
2229 #
2230 sub try_to_get_mail_addr($$) {
2231         my $name = shift;
2232         my $listref = shift;
2233
2234         @$listref = ();
2235         open( F, "$conf::gpg --no-options --batch --no-default-keyring ".
2236                 "--always-trust --keyring ".
2237                 join (" --keyring ",@conf::keyrings).
2238                 " --list-keys |" )
2239                 or return "";
2240         while( <F> ) {
2241                 if (/^pub / && / $name /) {
2242                         /<([^>]*)>/;
2243                         push( @$listref, $1 );
2244                 }
2245         }
2246         close( F );
2247
2248         return (@$listref >= 1) ? $listref->[0] : "";
2249 }
2250
2251 #
2252 # return current time as string
2253 #
2254 sub format_time() {
2255         my $t;
2256
2257         # omit weekday and year for brevity
2258         ($t = localtime) =~ /^\w+\s(.*)\s\d+$/;
2259         return $1;
2260 }
2261
2262 sub print_time($) {
2263         my $secs = shift;
2264         my $hours = int($secs/(60*60));
2265
2266         $secs -= $hours*60*60;
2267         return sprintf "%d:%02d:%02d", $hours, int($secs/60), $secs % 60;
2268 }
2269
2270 #
2271 # block some signals during queue processing
2272 #
2273 # This is just to avoid data inconsistency or uploads being aborted in the
2274 # middle. Only "soft" signals are blocked, i.e. SIGINT and SIGTERM, try harder
2275 # ones if you really want to kill the daemon at once.
2276 #
2277 sub block_signals() {
2278         POSIX::sigprocmask( SIG_BLOCK, $main::block_sigset );
2279 }
2280
2281 sub unblock_signals() {
2282         POSIX::sigprocmask( SIG_UNBLOCK, $main::block_sigset );
2283 }
2284
2285 #
2286 # process SIGHUP: close log file and reopen it (for logfile cycling)
2287 #
2288 sub close_log($) {
2289         close( LOG );
2290         close( STDOUT );
2291         close( STDERR );
2292
2293         open( LOG, ">>$conf::logfile" )
2294                 or die "Cannot open my logfile $conf::logfile: $!\n";
2295         chmod( 0644, $conf::logfile )
2296                 or msg( "log", "Cannot set modes of $conf::logfile: $!\n" );
2297         select( (select(LOG), $| = 1)[0] );
2298
2299         open( STDOUT, ">&LOG" )
2300                 or msg( "log", "$main::progname: Can't redirect stdout to ".
2301                             "$conf::logfile: $!\n" );
2302         open( STDERR, ">&LOG" )
2303                 or msg( "log", "$main::progname: Can't redirect stderr to ".
2304                             "$conf::logfile: $!\n" );
2305         msg( "log", "Restart after SIGHUP\n" );
2306 }
2307
2308 #
2309 # process SIGCHLD: check if it was our statusd process
2310 #
2311 sub kid_died($) {
2312         my $pid;
2313
2314         # reap statusd, so that it's no zombie when we try to kill(0) it
2315         waitpid( $main::statusd_pid, WNOHANG );
2316
2317 # Uncomment the following line if your Perl uses unreliable System V signal
2318 # (i.e. if handlers reset to default if the signal is delivered).
2319 # (Unfortunately, the re-setup can't be done in any case, since on some
2320 # systems this will cause the SIGCHLD to be delivered again if there are
2321 # still unreaped children :-(( )
2322
2323 #        $SIG{"CHLD"} = \&kid_died; # resetup handler for SysV
2324 }
2325
2326 sub restart_statusd() {
2327         # restart statusd if it died
2328         if (!kill( 0, $main::statusd_pid)) {
2329                 close( STATUSD ); # close out pipe end
2330                 $main::statusd_pid = fork_statusd();
2331         }
2332 }
2333
2334 #
2335 # process a fatal signal: cleanup and exit
2336 #
2337 sub fatal_signal($) {
2338         my $signame = shift;
2339         my $sig;
2340
2341         # avoid recursions of fatal_signal in case of BSD signals
2342         foreach $sig ( qw( ILL ABRT BUS FPE SEGV PIPE ) ) {
2343                 $SIG{$sig} = "DEFAULT";
2344         }
2345
2346         if ($$ == $main::maind_pid) {
2347                 # only the main daemon should do this
2348                 kill( $main::signo{"TERM"}, $main::statusd_pid )
2349                         if defined $main::statusd_pid;
2350                 unlink( $conf::statusfile, $conf::pidfile );
2351         }
2352         msg( "log", "Caught SIG$signame -- exiting (pid $$)\n" );
2353         exit 1;
2354 }
2355
2356
2357 # Local Variables:
2358 #  tab-width: 4
2359 #  fill-column: 78
2360 # End: