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