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