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