3 # debianqueued -- daemon for managing Debian upload queues
5 # Copyright (C) 1997 Roman Hodek <Roman.Hodek@informatik.uni-erlangen.de>
6 # Copyright (C) 2001-2007 Ryan Murray <rmurray@debian.org>
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!
14 # $Id: debianqueued,v 1.51 1999/07/08 09:43:21 ftplinux Exp $
16 # $Log: debianqueued,v $
17 # Revision 1.51 1999/07/08 09:43:21 ftplinux
18 # Bumped release number to 0.9
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
23 # In several messages, also mention GnuPG.
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.
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.
36 # Revision 1.47 1998/05/14 14:21:44 ftplinux
37 # Bumped release number to 0.8
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.
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
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.
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
56 # Fill in forgotten pattern for mail addr in process_commands.
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.
64 # Revision 1.41 1998/03/31 09:06:00 ftplinux
65 # Implemented handling of improper mail addresses in Maintainer: field.
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.
72 # Revision 1.39 1998/03/23 14:05:14 ftplinux
73 # Bumped release number to 0.7
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
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.
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
93 # Revision 1.36 1998/02/17 10:53:47 ftplinux
94 # Added test for binaries on maybe-slow NFS filesystems (@conf::test_binaries)
96 # Revision 1.35 1997/12/16 13:19:28 ftplinux
97 # Bumped release number to 0.6
99 # Revision 1.34 1997/12/09 13:51:24 ftplinux
100 # Implemented rejecting of nonus packages (new config var @nonus_packages)
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
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.
114 # Revision 1.32 1997/11/20 15:18:47 ftplinux
115 # Bumped release number to 0.5
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
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.
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.
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.
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.
139 # Revision 1.26 1997/10/30 14:01:05 ftplinux
140 # Implemented .commands files
142 # Revision 1.25 1997/10/30 13:05:29 ftplinux
143 # Removed date from status version info (too long)
145 # Revision 1.24 1997/10/30 13:04:02 ftplinux
146 # Print revision, version, and date in status data
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.
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.
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.
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
170 # Revision 1.19 1997/09/25 11:20:42 ftplinux
171 # Bumped release number to 0.4
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
177 # Revision 1.17 1997/09/16 10:53:35 ftplinux
178 # Made logging more verbose in queued and dqueued-watcher
180 # Revision 1.16 1997/08/12 09:54:39 ftplinux
181 # Bumped release number
183 # Revision 1.15 1997/08/11 12:49:09 ftplinux
184 # Implemented logfile rotating
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.
190 # Revision 1.13 1997/08/11 08:48:31 ftplinux
191 # Aaarg... forgot the alarm(0)'s
193 # Revision 1.12 1997/08/07 09:25:22 ftplinux
194 # Added timeout for remote operations
196 # Revision 1.11 1997/07/28 13:20:38 ftplinux
197 # Added release numner to startup message
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.
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.
208 # Revision 1.8 1997/07/25 10:23:03 ftplinux
209 # Made SIGCHLD handling more portable between perl versions
211 # Revision 1.7 1997/07/09 10:15:16 ftplinux
212 # Change RCS Header: to Id:
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.
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.
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.
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.
233 # Revision 1.2 1997/07/03 13:06:49 ftplinux
234 # Little last changes before beta release
236 # Revision 1.1.1.1 1997/07/03 12:54:59 ftplinux
237 # Import initial sources
244 use POSIX qw( strftime sys_stat_h sys_wait_h signal_h );
247 use Socket qw( PF_INET AF_INET SOCK_STREAM );
250 # ---------------------------------------------------------------------------
252 # ---------------------------------------------------------------------------
255 ($conf::queued_dir = (($0 !~ m,^/,) ? POSIX::getcwd()."/" : "") . $0)
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;
272 $junk = $conf::chmod;
273 $junk = $conf::ftpdebug;
274 $junk = $conf::ftptimeout;
275 $junk = $conf::no_changes_timeout;
276 $junk = @conf::nonus_packages;
277 $junk = @conf::test_binaries;
278 $junk = @conf::maintainer_mail;
279 $junk = @conf::targetdir_delayed;
280 $junk = $conf::mail ||= '/usr/sbin/sendmail';
281 $conf::target = "localhost" if $conf::upload_method eq "copy";
284 ($main::progname = $0) =~ s,.*/,,;
288 # extract -r and -k args
290 if (@ARGV == 1 && $ARGV[0] =~ /^-[rk]$/) {
291 $main::arg = ($ARGV[0] eq '-k') ? "kill" : "restart";
295 # test for another instance of the queued already running
296 my ($pid, $delayed_dirs, $adelayedcore);
297 if (open( PIDFILE, "<$conf::pidfile" )) {
298 chomp( $pid = <PIDFILE> );
301 # remove stale pid file
302 unlink( $conf::pidfile );
306 print "Killing running daemon (pid $pid) ...";
309 while( kill( 0, $pid ) && $cnt-- > 0 ) {
313 if (kill( 0, $pid )) {
314 print " failed!\nProcess $pid still running.\n";
318 if (-e "$conf::incoming/core") {
319 unlink( "$conf::incoming/core" );
320 print "(Removed core file)\n";
322 for ($delayed_dirs = 0; $delayed_dirs <= $conf::max_delayed;
324 $adelayedcore = sprintf( "$conf::incoming_delayed/core",
326 if (-e $adelayedcore) {
327 unlink( $adelayedcore );
328 print "(Removed core file)\n";
331 exit 0 if $main::arg eq "kill";
334 die "Another $main::progname is already running (pid $pid)\n"
335 if $pid && kill( 0, $pid );
338 elsif ($main::arg eq "kill") {
339 die "No daemon running\n";
341 elsif ($main::arg eq "restart") {
342 print "(No daemon running; starting anyway)\n";
345 # if started without arguments (initial invocation), then fork
347 # now go to background
348 die "$main::progname: fork failed: $!\n" unless defined( $pid = fork );
350 # parent: wait for signal from child (SIGCHLD or SIGUSR1) and exit
351 my $sigset = POSIX::SigSet->new();
353 $SIG{"CHLD"} = sub { };
354 $SIG{"USR1"} = sub { };
355 POSIX::sigsuspend( $sigset );
356 waitpid( $pid, WNOHANG );
357 if (kill( 0, $pid )) {
358 print "Daemon started in background (pid $pid)\n";
368 if ($conf::upload_method eq "ssh") {
369 # exec an ssh-agent that starts us again
370 # force shell to be /bin/sh, ssh-agent may base its decision
371 # whether to use a fd or a Unix socket on the shell...
372 $ENV{"SHELL"} = "/bin/sh";
373 exec $conf::ssh_agent, $0, "startup", getppid();
374 die "$main::progname: Could not exec $conf::ssh_agent: $!\n";
377 # no need to exec, just set up @ARGV as expected below
378 @ARGV = ("startup", getppid());
382 die "Please start without any arguments.\n"
383 if @ARGV != 2 || $ARGV[0] ne "startup";
384 my $parent_pid = $ARGV[1];
388 ($version = 'Release: 0.9 $Revision: 1.51 $ $Date: 1999/07/08 09:43:21 $ $Author: ftplinux $') =~ s/\$ ?//g;
389 print "debianqueued $version\n";
392 # check if all programs exist
394 foreach $prg ( $conf::gpg, $conf::ssh, $conf::scp, $conf::ssh_agent,
395 $conf::ssh_add, $conf::md5sum, $conf::mail, $conf::mkfifo ) {
396 die "Required program $prg doesn't exist or isn't executable\n"
398 # check for correct upload method
399 die "Bad upload method '$conf::upload_method'.\n"
400 if $conf::upload_method ne "ssh" &&
401 $conf::upload_method ne "ftp" &&
402 $conf::upload_method ne "copy";
403 die "No keyrings\n" if ! @conf::keyrings;
406 die "statusfile path must be absolute."
407 if $conf::statusfile !~ m,^/,;
408 die "upload and target queue paths must be absolute."
409 if $conf::incoming !~ m,^/, ||
410 $conf::incoming_delayed !~ m,^/, ||
411 $conf::targetdir !~ m,^/, ||
412 $conf::targetdir_delayed !~ m,^/,;
415 # ---------------------------------------------------------------------------
417 # ---------------------------------------------------------------------------
422 sub process_changes($\@);
423 sub process_commands($);
425 sub copy_to_target(@);
428 sub check_incoming_writable();
430 sub write_status_file();
431 sub print_status($$$$$$);
432 sub format_status_num(\$$);
433 sub format_status_str(\$$);
445 sub check_incoming_writable();
448 sub is_debian_file($);
449 sub get_maintainer($);
450 sub debian_file_stem($);
456 sub try_to_get_mail_addr($$);
460 sub unblock_signals();
463 sub restart_statusd();
466 $ENV{"PATH"} = "/bin:/usr/bin";
467 $ENV{"IFS"} = "" if defined($ENV{"IFS"} && $ENV{"IFS"} ne "");
480 sub ST_CTIME() { 10 }
481 # fixed lengths of data items passed over status pipe
482 sub STATNUM_LEN() { 30 }
483 sub STATSTR_LEN() { 128 }
485 # init list of signals
486 defined $Config{sig_name} or die "$main::progname: No signal list defined!\n";
489 foreach $name (split( ' ', $Config{sig_name} )) {
490 $main::signo{$name} = $i++;
493 @main::fatal_signals = qw( INT QUIT ILL TRAP ABRT BUS FPE USR2 SEGV PIPE
494 TERM XCPU XFSZ PWR );
496 $main::block_sigset = POSIX::SigSet->new;
497 $main::block_sigset->addset( $main::signo{"INT"} );
498 $main::block_sigset->addset( $main::signo{"TERM"} );
500 # some constant net stuff
501 $main::tcp_proto = (getprotobyname('tcp'))[2]
502 or die "Cannot get protocol number for 'tcp'\n";
503 my $used_service = ($conf::upload_method eq "ssh") ? "ssh" : "ftp";
504 $main::echo_port = (getservbyname($used_service, 'tcp'))[2]
505 or die "Cannot get port number for service '$used_service'\n";
507 # clear queue of stored mails
508 @main::stored_mails = ();
510 # run ssh-add to bring the key into the agent (will use stdin/stdout)
511 if ($conf::upload_method eq "ssh") {
512 system "$conf::ssh_add $conf::ssh_key_file"
513 and die "$main::progname: Running $conf::ssh_add failed ".
514 "(exit status ", $? >> 8, ")\n";
517 # change to queue dir
518 chdir( $conf::incoming )
519 or die "$main::progname: cannot cd to $conf::incoming: $!\n";
521 # needed before /dev/null redirects, some system send a SIGHUP when loosing
522 # the controlling tty
523 $SIG{"HUP"} = "IGNORE";
525 # open logfile, make it unbuffered
526 open( LOG, ">>$conf::logfile" )
527 or die "Cannot open my logfile $conf::logfile: $!\n";
528 chmod( 0644, $conf::logfile )
529 or die "Cannot set modes of $conf::logfile: $!\n";
530 select( (select(LOG), $| = 1)[0] );
533 $SIG{"HUP"} = \&close_log;
535 # redirect stdin, ... to /dev/null
536 open( STDIN, "</dev/null" )
537 or die "$main::progname: Can't redirect stdin to /dev/null: $!\n";
538 open( STDOUT, ">&LOG" )
539 or die "$main::progname: Can't redirect stdout to $conf::logfile: $!\n";
540 open( STDERR, ">&LOG" )
541 or die "$main::progname: Can't redirect stderr to $conf::logfile: $!\n";
542 # ok, from this point usually no "die" anymore, stderr is gone!
543 msg( "log", "daemon (pid $$) started\n" );
545 # initialize variables used by send_status before launching the status daemon
547 format_status_num( $main::next_run, time+10 );
548 format_status_str( $main::current_changes, "" );
550 $main::incoming_writable = 1; # assume this for now
552 # start the daemon watching the 'status' FIFO
553 if ($conf::statusfile && $conf::statusdelay == 0) {
554 $main::statusd_pid = fork_statusd();
555 $SIG{"CHLD"} = \&kid_died; # watch out for dead status daemon
556 # SIGUSR1 triggers status info
557 $SIG{"USR1"} = \&send_status;
559 $main::maind_pid = $$;
561 END { kill( $main::signo{"ABRT"}, $$ ) if defined $main::signo{"ABRT"}; }
564 open( PIDFILE, ">$conf::pidfile" )
565 or msg( "log", "Can't open $conf::pidfile: $!\n" );
566 printf PIDFILE "%5d\n", $$;
568 chmod( 0644, $conf::pidfile )
569 or die "Cannot set modes of $conf::pidfile: $!\n";
571 # other signals will just log an error and exit
572 foreach ( @main::fatal_signals ) {
573 $SIG{$_} = \&fatal_signal;
576 # send signal to user-started process that we're ready and it can exit
577 kill( $main::signo{"USR1"}, $parent_pid );
579 # ---------------------------------------------------------------------------
581 # ---------------------------------------------------------------------------
583 # default to classical incoming/target
584 $main::current_incoming = $conf::incoming;
585 $main::current_targetdir = $conf::targetdir;
588 write_status_file() if $conf::statusdelay;
591 # ping target only if there is the possibility that we'll contact it (but
592 # also don't wait too long).
593 my @have_changes = <*.changes *.commands>;
594 for ( my $delayed_dirs = 0; $delayed_dirs <= $conf::max_delayed;
596 my $adelayeddir = sprintf( "$conf::incoming_delayed",
599 <$adelayeddir/*.changes $adelayeddir/*.commands> );
601 check_alive() if @have_changes || (time - $main::last_ping_time) > 8*60*60;
603 if (@have_changes && $main::target_up) {
604 check_incoming_writable if !$main::incoming_writable;
605 check_dir() if $main::incoming_writable;
608 write_status_file() if $conf::statusdelay;
610 # sleep() returns if we received a signal (SIGUSR1 for status FIFO), so
611 # calculate the end time once and wait for it being reached.
612 format_status_num( $main::next_run, time + $conf::queue_delay );
614 while( ($delta = calc_delta()) > 0 ) {
615 debug( "mainloop sleeping $delta secs" );
617 # check if statusd died, if using status FIFO, or update status file
618 if ($conf::statusdelay) {
630 $delta = $main::next_run - time;
631 $delta = $conf::statusdelay
632 if $conf::statusdelay && $conf::statusdelay < $delta;
637 # ---------------------------------------------------------------------------
638 # main working functions
639 # ---------------------------------------------------------------------------
643 # main function for checking the incoming dir
646 my( @files, @changes, @keep_files, @this_keep_files, @stats, $file ,
649 debug( "starting checkdir" );
651 write_status_file() if $conf::statusdelay;
653 # test if needed binaries are available; this is if they're on maybe
654 # slow-mounted NFS filesystems
655 foreach (@conf::test_binaries) {
657 # maybe the mount succeeds now
660 msg( "log", "binary test failed for $_; delaying queue run\n");
664 for ( $adelay=-1; $adelay <= $conf::max_delayed; $adelay++ ) {
665 if ( $adelay == -1 ) {
666 $main::current_incoming = $conf::incoming;
667 $main::current_incoming_short = "";
668 $main::current_targetdir = $conf::targetdir;
671 $main::current_incoming = sprintf( $conf::incoming_delayed,
673 $main::current_incoming_short = sprintf( "DELAYED/%d-day",
675 $main::current_targetdir = sprintf( $conf::targetdir_delayed,
679 # need to clear directory specific variables
680 undef ( @keep_files );
681 undef ( @this_keep_files );
683 chdir ( $main::current_incoming )
685 "Cannot change to dir ".
686 "${main::current_incoming_short}: $!\n" ),
689 # look for *.commands files
690 foreach $file ( <*.commands> ) {
693 process_commands( $file );
696 write_status_file() if $conf::statusdelay;
701 or (msg( "log", "Cannot open dir ${main::current_incoming_short}: $!\n" ),
703 @files = readdir( INC );
706 # process all .changes files found
707 @changes = grep /\.changes$/, @files;
708 push( @keep_files, @changes ); # .changes files aren't stray
709 foreach $file ( @changes ) {
711 # wrap in an eval to allow jumpbacks to here with die in case
714 eval { process_changes( $file, @this_keep_files ); };
716 msg( "log,mail", $@ ) if $@;
718 write_status_file() if $conf::statusdelay;
720 # files which are ok in conjunction with this .changes
721 debug( "$file tells to keep @this_keep_files" );
722 push( @keep_files, @this_keep_files );
725 # break out of this loop if the incoming dir has become unwritable
726 goto end_run if !$main::incoming_writable;
728 ftp_close() if $conf::upload_method eq "ftp";
730 # find files which aren't related to any .changes
731 foreach $file ( @files ) {
732 # filter out files we never want to delete
733 next if ! -f $file || # may have disappeared in the meantime
734 $file eq "." || $file eq ".." ||
735 (grep { $_ eq $file } @keep_files) ||
736 $file =~ /$conf::keep_files/;
737 # Delete such files if they're older than
738 # $stray_remove_timeout; they could be part of an
739 # yet-incomplete upload, with the .changes still missing.
740 # Cannot send any notification, since owner unknown.
741 next if !(@stats = stat( $file ));
742 my $age = time - $stats[ST_MTIME];
743 my( $maint, $pattern, @job_files );
744 if ($file =~ /^junk-for-writable-test/ ||
745 $file !~ m,$conf::valid_files, ||
746 $age >= $conf::stray_remove_timeout) {
747 msg( "log", "Deleted stray file ${main::current_incoming_short}/$file\n" ) if rm( $file );
749 elsif ($age > $conf::no_changes_timeout &&
750 is_debian_file( $file ) &&
751 # not already reported
752 !($stats[ST_MODE] & S_ISGID) &&
753 ($pattern = debian_file_stem( $file )) &&
754 (@job_files = glob($pattern)) &&
755 # If a .changes is in the list, it has the same stem as the
756 # found file (probably a .orig.tar.gz). Don't report in this
758 !(grep( /\.changes$/, @job_files ))) {
759 $maint = get_maintainer( $file );
760 # Don't send a mail if this looks like the recompilation of a
761 # package for a non-i386 arch. For those, the maintainer field is
763 if (!grep( /(\.dsc|_(i386|all)\.deb)$/, @job_files )) {
764 msg( "log", "Found an upload without .changes and with no ",
766 msg( "log", "Not sending a report, because probably ",
767 "recompilation job\n" );
771 $main::mail_addr = $maint;
772 $main::mail_addr = $1 if $main::mail_addr =~ /<([^>]*)>/;
773 $main::mail_subject = "Incomplete upload found in ".
774 "Debian upload queue";
775 msg( "mail", "Probably you are the uploader of the following ".
777 msg( "mail", "the Debian upload queue directory:\n " );
778 msg( "mail", join( "\n ", @job_files ), "\n" );
779 msg( "mail", "This looks like an upload, but a .changes file ".
780 "is missing, so the job\n" );
781 msg( "mail", "cannot be processed.\n\n" );
782 msg( "mail", "If no .changes file arrives within ",
783 print_time( $conf::stray_remove_timeout - $age ),
784 ", the files will be deleted.\n\n" );
785 msg( "mail", "If you didn't upload those files, please just ".
786 "ignore this message.\n" );
788 msg( "log", "Sending problem report for an upload without a ".
790 msg( "log", "Maintainer: $maint\n" );
793 msg( "log", "Found an upload without .changes, but can't ".
794 "find a maintainer address\n" );
796 msg( "log", "Files: @job_files\n" );
797 # remember we already have sent a mail regarding this file
798 foreach ( @job_files ) {
800 next if !@st; # file may have disappeared in the meantime
801 chmod +($st[ST_MODE] |= S_ISGID), $_;
805 debug( "found stray file ${main::current_incoming_short}/$file, deleting in ",
806 print_time($conf::stray_remove_timeout - $age) );
810 chdir( $conf::incoming );
814 write_status_file() if $conf::statusdelay;
818 # process one .changes file
820 sub process_changes($\@) {
822 my $keep_list = shift;
823 my( $pgplines, @files, @filenames, @changes_stats, $failure_file,
824 $retries, $last_retry, $upload_time, $file, $do_report, $ls_l,
825 $problems_reported, $errs, $pkgname, $signator );
829 format_status_str( $main::current_changes, "$main::current_incoming_short/$changes" );
831 write_status_file() if $conf::statusdelay;
834 msg( "log", "processing ${main::current_incoming_short}/$changes\n" );
836 # parse the .changes file
837 open( CHANGES, "<$changes" )
838 or die "Cannot open ${main::current_incoming_short}/$changes: $!\n";
840 $main::mail_addr = "";
842 outer_loop: while( <CHANGES> ) {
843 if (/^---+(BEGIN|END) PGP .*---+$/) {
846 elsif (/^Maintainer:\s*/i) {
847 chomp( $main::mail_addr = $' );
848 $main::mail_addr = $1 if $main::mail_addr =~ /<([^>]*)>/;
850 elsif (/^Source:\s*/i) {
851 chomp( $pkgname = $' );
852 $pkgname =~ s/\s+$//;
853 $main::packages{$pkgname}++;
857 redo outer_loop if !/^\s/;
858 my @field = split( /\s+/ );
860 # forbid shell meta chars in the name, we pass it to a
861 # subshell several times...
862 $field[5] =~ /^([a-zA-Z0-9.+_:@=%-][~a-zA-Z0-9.+_:@=%-]*)/;
863 if ($1 ne $field[5]) {
864 msg( "log", "found suspicious filename $field[5]\n" );
865 msg( "mail", "File '$field[5]' mentioned in $main::current_incoming_short/$changes\n",
866 "has bad characters in its name. Removed.\n" );
870 push( @files, { md5 => $field[1],
872 name => $field[5] } );
873 push( @filenames, $field[5] );
874 debug( "includes file $field[5], size $field[2], ",
881 # tell check_dir that the files mentioned in this .changes aren't stray,
882 # we know about them somehow
883 @$keep_list = @filenames;
885 # some consistency checks
886 if (!$main::mail_addr) {
887 msg( "log,mail", "$main::current_incoming_short/$changes doesn't contain a Maintainer: field; ".
888 "cannot process\n" );
889 goto remove_only_changes;
891 if ($main::mail_addr !~ /^(buildd_\S+-\S+|\S+\@\S+\.\S+)/) {
892 # doesn't look like a mail address, maybe only the name
893 my( $new_addr, @addr_list );
894 if ($new_addr = try_to_get_mail_addr( $main::mail_addr, \@addr_list )){
895 # substitute (unique) found addr, but give a warning
896 msg( "mail", "(The Maintainer: field didn't contain a proper ".
898 msg( "mail", "Looking for `$main::mail_addr' in the Debian ".
899 "keyring gave your address\n" );
900 msg( "mail", "as unique result, so I used this.)\n" );
901 msg( "log", "Substituted $new_addr for malformed ".
902 "$main::mail_addr\n" );
903 $main::mail_addr = $new_addr;
906 # not found or not unique: hold the job and inform queue maintainer
907 my $old_addr = $main::mail_addr;
908 $main::mail_addr = $conf::maintainer_mail;
909 msg( "mail", "The job ${main::current_incoming_short}/$changes doesn't have a correct email\n" );
910 msg( "mail", "address in the Maintainer: field:\n" );
911 msg( "mail", " $old_addr\n" );
912 msg( "mail", "A check for this in the Debian keyring gave:\n" );
913 msg( "mail", @addr_list ?
914 " " . join( ", ", @addr_list ) . "\n" :
916 msg( "mail", "Please fix this manually\n" );
917 msg( "log", "Bad Maintainer: field in ${main::current_incoming_short}/$changes: $old_addr\n" );
918 goto remove_only_changes;
922 msg( "log,mail", "$main::current_incoming_short/$changes isn't signed with PGP/GnuPG\n" );
923 msg( "log", "(uploader $main::mail_addr)\n" );
924 goto remove_only_changes;
927 msg( "log,mail", "$main::current_incoming_short/$changes doesn't mention any files\n" );
928 msg( "log", "(uploader $main::mail_addr)\n" );
929 goto remove_only_changes;
932 # check for packages that shouldn't be processed
933 if (grep( $_ eq $pkgname, @conf::nonus_packages )) {
934 msg( "log,mail", "$pkgname is a package that must be uploaded ".
935 "to nonus.debian.org\n" );
936 msg( "log,mail", "instead of target.\n" );
937 msg( "log,mail", "Job rejected and removed all files belonging ".
939 msg( "log,mail", " ", join( ", ", @filenames ), "\n" );
940 rm( $changes, @filenames );
944 $failure_file = $changes . ".failures";
945 $retries = $last_retry = 0;
946 if (-f $failure_file) {
947 open( FAILS, "<$failure_file" )
948 or die "Cannot open $main::current_incoming_short/$failure_file: $!\n";
951 ( $retries, $last_retry ) = ( $1, $2 ) if $line =~ /^(\d+)\s+(\d+)$/;
952 push( @$keep_list, $failure_file );
955 # run PGP on the file to check the signature
956 if (!($signator = pgp_check( $changes ))) {
957 msg( "log,mail", "$main::current_incoming_short/$changes has bad PGP/GnuPG signature!\n" );
958 msg( "log", "(uploader $main::mail_addr)\n" );
960 msg( "log,mail", "Removing $main::current_incoming_short/$changes, but keeping its associated ",
961 "files for now.\n" );
963 # Set SGID bit on associated files, so that the test for Debian files
964 # without a .changes doesn't consider them.
965 foreach ( @filenames ) {
967 next if !@st; # file may have disappeared in the meantime
968 chmod +($st[ST_MODE] |= S_ISGID), $_;
972 elsif ($signator eq "LOCAL ERROR") {
973 # An error has appened when starting pgp... Don't process the file,
974 # but also don't delete it
975 debug( "Can't PGP/GnuPG check $main::current_incoming_short/$changes -- don't process it for now" );
979 die "Cannot stat ${main::current_incoming_short}/$changes (??): $!\n"
980 if !(@changes_stats = stat( $changes ));
981 # Make $upload_time the maximum of all modification times of files
982 # related to this .changes (and the .changes it self). This is the
983 # last time something changes to these files.
984 $upload_time = $changes_stats[ST_MTIME];
985 for $file ( @files ) {
987 next if !(@stats = stat( $file->{"name"} ));
988 $file->{"stats"} = \@stats;
989 $upload_time = $stats[ST_MTIME] if $stats[ST_MTIME] > $upload_time;
992 $do_report = (time - $upload_time) > $conf::problem_report_timeout;
993 $problems_reported = $changes_stats[ST_MODE] & S_ISGID;
994 # if any of the files is newer than the .changes' ctime (the time
995 # we sent a report and set the sticky bit), send new problem reports
996 if ($problems_reported && $changes_stats[ST_CTIME] < $upload_time) {
997 $problems_reported = 0;
998 chmod +($changes_stats[ST_MODE] &= ~S_ISGID), $changes;
999 debug( "upload_time>changes-ctime => resetting problems reported" );
1001 debug( "do_report=$do_report problems_reported=$problems_reported" );
1003 # now check all files for correct size and md5 sum
1004 for $file ( @files ) {
1005 my $filename = $file->{"name"};
1006 if (!defined( $file->{"stats"} )) {
1007 # could be an upload that isn't complete yet, be quiet,
1008 # but don't process the file;
1009 msg( "log,mail", "$filename doesn't exist\n" )
1010 if $do_report && !$problems_reported;
1011 msg( "log", "$filename doesn't exist (ignored for now)\n" )
1013 msg( "log", "$filename doesn't exist (already reported)\n" )
1014 if $problems_reported;
1017 elsif ($file->{"stats"}->[ST_SIZE] < $file->{"size"} && !$do_report) {
1018 # could be an upload that isn't complete yet, be quiet,
1019 # but don't process the file
1020 msg( "log", "$filename is too small (ignored for now)\n" );
1023 elsif ($file->{"stats"}->[ST_SIZE] != $file->{"size"}) {
1024 msg( "log,mail", "$filename has incorrect size; deleting it\n" );
1028 elsif (md5sum( $filename ) ne $file->{"md5"}) {
1029 msg( "log,mail", "$filename has incorrect md5 checksum; ",
1037 if ((time - $upload_time) > $conf::bad_changes_timeout) {
1038 # if a .changes fails for a really long time (several days
1039 # or so), remove it and all associated files
1041 "$main::current_incoming_short/$changes couldn't be processed for ",
1042 int($conf::bad_changes_timeout/(60*60)),
1043 " hours and is now deleted\n" );
1045 "All files it mentions are also removed:\n" );
1046 msg( "log,mail", " ", join( ", ", @filenames ), "\n" );
1047 rm( $changes, @filenames, $failure_file );
1049 elsif ($do_report && !$problems_reported) {
1050 # otherwise, send a problem report, if not done already
1052 "Due to the errors above, the .changes file couldn't ",
1054 "Please fix the problems for the upload to happen.\n" );
1055 # remember we already have sent a mail regarding this file
1056 debug( "Sending problem report mail and setting SGID bit" );
1057 my $mode = $changes_stats[ST_MODE] |= S_ISGID;
1058 msg( "log", "chmod failed: $!" ) if (chmod ($mode, $changes) != 1);
1065 # if this upload already failed earlier, wait until the delay requirement
1067 if ($retries > 0 && (time - $last_retry) <
1068 ($retries == 1 ? $conf::upload_delay_1 : $conf::upload_delay_2)) {
1069 msg( "log", "delaying retry of upload\n" );
1073 if ($conf::upload_method eq "ftp") {
1074 return if !ftp_open();
1077 # check if the job is already present on target
1078 # (moved to here, to avoid bothering target as long as there are errors in
1080 if ($ls_l = is_on_target( $changes )) {
1081 msg( "log,mail", "$main::current_incoming_short/$changes is already present on target host:\n" );
1082 msg( "log,mail", "$ls_l\n" );
1083 msg( "mail", "Either you already uploaded it, or someone else ",
1085 msg( "log,mail", "Job $changes removed.\n" );
1086 rm( $changes, @filenames, $failure_file );
1090 # clear sgid bit before upload, scp would copy it to target. We don't need
1091 # it anymore, we know there are no problems if we come here. Also change
1092 # mode of files to 644 if this should be done locally.
1093 $changes_stats[ST_MODE] &= ~S_ISGID;
1094 if (!$conf::chmod_on_target) {
1095 $changes_stats[ST_MODE] &= ~0777;
1096 $changes_stats[ST_MODE] |= 0644;
1098 chmod +($changes_stats[ST_MODE]), $changes;
1100 # try uploading to target
1101 if (!copy_to_target( $changes, @filenames )) {
1102 # if the upload failed, increment the retry counter and remember the
1103 # current time; both things are written to the .failures file. Don't
1104 # increment the fail counter if the error was due to incoming
1106 return if !$main::incoming_writable;
1107 if (++$retries >= $conf::max_upload_retries) {
1109 "$changes couldn't be uploaded for $retries times now.\n" );
1111 "Giving up and removing it and its associated files:\n" );
1112 msg( "log,mail", " ", join( ", ", @filenames ), "\n" );
1113 rm( $changes, @filenames, $failure_file );
1117 if (open( FAILS, ">$failure_file" )) {
1118 print FAILS "$retries $last_retry\n";
1120 chmod( 0600, $failure_file )
1121 or die "Cannot set modes of $failure_file: $!\n";
1123 push( @$keep_list, $failure_file );
1124 debug( "now $retries failed uploads" );
1126 "The upload will be retried in ",
1127 print_time( $retries == 1 ? $conf::upload_delay_1 :
1128 $conf::upload_delay_2 ), "\n" );
1133 # If the files were uploaded ok, remove them
1134 rm( $changes, @filenames, $failure_file );
1136 msg( "mail", "$changes uploaded successfully to $conf::target\n" );
1137 msg( "mail", "along with the files:\n ",
1138 join( "\n ", @filenames ), "\n" );
1139 msg( "log", "$changes processed successfully (uploader $main::mail_addr)\n" );
1141 # Check for files that have the same stem as the .changes (and weren't
1142 # mentioned there) and delete them. It happens often enough that people
1143 # upload a .orig.tar.gz where it isn't needed and also not in the
1144 # .changes. Explicitly deleting it (and not waiting for the
1145 # $stray_remove_timeout) reduces clutter in the queue dir and maybe also
1146 # educates uploaders :-)
1148 # my $pattern = debian_file_stem( $changes );
1149 # my $spattern = substr( $pattern, 0, -1 ); # strip off '*' at end
1150 # my @other_files = glob($pattern);
1151 # filter out files that have a Debian revision at all and a different
1152 # revision. Those belong to a different upload.
1153 # if ($changes =~ /^\Q$spattern\E-([\d.+-]+)/) {
1154 # my $this_rev = $1;
1155 # @other_files = grep( !/^\Q$spattern\E-([\d.+-]+)/ || $1 eq $this_rev,
1158 # Also do not remove those files if a .changes is among them. Then there
1159 # is probably a second upload for another version or another architecture.
1160 # if (@other_files && !grep( /\.changes$/, @other_files )) {
1161 # rm( @other_files );
1162 # msg( "mail", "\nThe following file(s) seemed to belong to the same ".
1163 # "upload, but weren't listed\n" );
1164 # msg( "mail", "in the .changes file:\n " );
1165 # msg( "mail", join( "\n ", @other_files ), "\n" );
1166 # msg( "mail", "They have been deleted.\n" );
1167 # msg( "log", "Deleted files in upload not in $changes: @other_files\n" );
1172 # process one .commands file
1174 sub process_commands($) {
1175 my $commands = shift;
1176 my( @cmds, $cmd, $pgplines, $signator );
1179 format_status_str( $main::current_changes, $commands );
1181 write_status_file() if $conf::statusdelay;
1183 msg( "log", "processing $main::current_incoming_short/$commands\n" );
1185 # parse the .commands file
1186 if (!open( COMMANDS, "<$commands" )) {
1187 msg( "log", "Cannot open $main::current_incoming_short/$commands: $!\n" );
1191 $main::mail_addr = "";
1193 outer_loop: while( <COMMANDS> ) {
1194 if (/^---+(BEGIN|END) PGP .*---+$/) {
1197 elsif (/^Uploader:\s*/i) {
1198 chomp( $main::mail_addr = $' );
1199 $main::mail_addr = $1 if $main::mail_addr =~ /<([^>]*)>/;
1201 elsif (/^Commands:/i) {
1204 s/^\s*(.*)\s*$/$1/; # delete whitespace at both ends
1207 debug( "includes cmd $_" );
1209 last outer_loop if !defined( $_ = scalar(<COMMANDS>) );
1211 redo outer_loop if !/^\s/ || /^$/;
1217 # some consistency checks
1218 if (!$main::mail_addr || $main::mail_addr !~ /^\S+\@\S+\.\S+/) {
1219 msg( "log,mail", "$main::current_incoming_short/$commands contains no or bad Uploader: field: ".
1220 "$main::mail_addr\n" );
1221 msg( "log,mail", "cannot process $main::current_incoming_short/$commands\n" );
1222 $main::mail_addr = "";
1225 msg( "log", "(command uploader $main::mail_addr)\n" );
1227 if ($pgplines < 3) {
1228 msg( "log,mail", "$main::current_incoming_short/$commands isn't signed with PGP/GnuPG\n" );
1229 msg( "mail", "or the uploaded file is broken. Make sure to transfer in binary mode\n" );
1230 msg( "mail", "or better yet - use dcut for commands files\n");
1234 # run PGP on the file to check the signature
1235 if (!($signator = pgp_check( $commands ))) {
1236 msg( "log,mail", "$main::current_incoming_short/$commands has bad PGP/GnuPG signature!\n" );
1238 msg( "log,mail", "Removing $main::current_incoming_short/$commands\n" );
1242 elsif ($signator eq "LOCAL ERROR") {
1243 # An error has appened when starting pgp... Don't process the file,
1244 # but also don't delete it
1245 debug( "Can't PGP/GnuPG check $main::current_incoming_short/$commands -- don't process it for now" );
1248 msg( "log", "(PGP/GnuPG signature by $signator)\n" );
1250 # now process commands
1251 msg( "mail", "Log of processing your commands file $main::current_incoming_short/$commands:\n\n" );
1252 foreach $cmd ( @cmds ) {
1253 my @word = split( /\s+/, $cmd );
1254 msg( "mail,log", "> @word\n" );
1257 if ($word[0] eq "rm") {
1258 my( @files, $file, @removed );
1259 foreach ( @word[1..$#word] ) {
1261 msg( "mail,log", "$_: filename may not contain slashes\n" );
1265 my $pat = quotemeta($_);
1266 $pat =~ s/\\\*/.*/g;
1267 $pat =~ s/\\\?/.?/g;
1268 $pat =~ s/\\([][])/$1/g;
1269 opendir( DIR, "." );
1270 push( @files, grep /^$pat$/, readdir(DIR) );
1278 msg( "mail,log", "No files to delete\n" );
1282 foreach $file ( @files ) {
1284 msg( "mail,log", "$file: no such file\n" );
1286 elsif ($file =~ /$conf::keep_files/) {
1287 msg( "mail,log", "$file is protected, cannot ".
1290 elsif (!unlink( $file )) {
1291 msg( "mail,log", "$file: rm: $!\n" );
1294 push( @removed, $file );
1297 msg( "mail,log", "Files removed: @removed\n" ) if @removed;
1300 elsif ($word[0] eq "mv") {
1302 msg( "mail,log", "Wrong number of arguments\n" );
1304 elsif ($word[1] =~ m,/,) {
1305 msg( "mail,log", "$word[1]: filename may not contain slashes\n" );
1307 elsif ($word[2] =~ m,/,) {
1308 msg( "mail,log", "$word[2]: filename may not contain slashes\n" );
1310 elsif (!-f $word[1]) {
1311 msg( "mail,log", "$word[1]: no such file\n" );
1313 elsif (-e $word[2]) {
1314 msg( "mail,log", "$word[2]: file exists\n" );
1316 elsif ($word[1] =~ /$conf::keep_files/) {
1317 msg( "mail,log", "$word[1] is protected, cannot rename\n" );
1320 if (!rename( $word[1], $word[2] )) {
1321 msg( "mail,log", "rename: $!\n" );
1324 msg( "mail,log", "OK\n" );
1329 msg( "mail,log", "unknown command $word[0]\n" );
1333 msg( "log", "-- End of $main::current_incoming_short/$commands processing\n" );
1337 # check if a file is already on target
1339 sub is_on_target($) {
1344 if ($conf::upload_method eq "ssh") {
1345 ($msg, $stat) = ssh_cmd( "ls -l $file" );
1347 elsif ($conf::upload_method eq "ftp") {
1349 ($msg, $err) = ftp_cmd( "dir", $file );
1356 $msg = "ls: no such file\n";
1360 $msg = join( "\n", @$msg );
1364 ($msg, $stat) = local_cmd( "$conf::ls -l $file" );
1367 debug( "exit status: $stat, output was: $msg" );
1369 return "" if $stat && $msg =~ /no such file/i; # file not present
1370 msg( "log", "strange ls -l output on target:\n", $msg ), return ""
1371 if $stat || $@; # some other error, but still try to upload
1373 # ls -l returned 0 -> file already there
1374 $msg =~ s/\s\s+/ /g; # make multiple spaces into one, to save space
1379 # copy a list of files to target
1381 sub copy_to_target(@) {
1383 my( @md5sum, @expected_files, $sum, $name, $msgs, $stat );
1386 write_status_file() if $conf::statusdelay;
1389 if ($conf::upload_method eq "ssh") {
1390 ($msgs, $stat) = scp_cmd( @files );
1393 elsif ($conf::upload_method eq "ftp") {
1395 if (!$main::FTP_chan->cwd( $main::current_targetdir )) {
1396 msg( "log,mail", "Can't cd to $main::current_targetdir on $conf::target\n" );
1399 foreach $file (@files) {
1400 ($rv, $msgs) = ftp_cmd( "put", $file );
1405 ($msgs, $stat) = local_cmd( "$conf::cp @files $main::current_targetdir", 'NOCD' );
1409 # check md5sums or sizes on target against our own
1410 my $have_md5sums = 1;
1411 if ($conf::upload_method eq "ssh") {
1412 ($msgs, $stat) = ssh_cmd( "md5sum @files" );
1414 @md5sum = split( "\n", $msgs );
1416 elsif ($conf::upload_method eq "ftp") {
1417 my ($rv, $err, $file);
1418 foreach $file (@files) {
1419 ($rv, $err) = ftp_cmd( "quot", "site", "md5sum", $file );
1421 next if ftp_code() == 550; # file not found
1422 if (ftp_code() == 500) { # unimplemented
1424 goto get_sizes_instead;
1429 chomp( my $t = ftp_response() );
1430 push( @md5sum, $t );
1432 if (!$have_md5sums) {
1434 foreach $file (@files) {
1435 ($rv, $err) = ftp_cmd( "size", $file );
1437 next if ftp_code() == 550; # file not found
1441 push( @md5sum, "$rv $file" );
1446 ($msgs, $stat) = local_cmd( "$conf::md5sum @files" );
1448 @md5sum = split( "\n", $msgs );
1451 @expected_files = @files;
1454 ($sum,$name) = split;
1455 next if !grep { $_ eq $name } @files; # a file we didn't upload??
1456 next if $sum eq "md5sum:"; # looks like an error message
1457 if (($have_md5sums && $sum ne md5sum( $name )) ||
1458 (!$have_md5sums && $sum != (-s $name))) {
1459 msg( "log,mail", "Upload of $name to $conf::target failed ",
1460 "(".($have_md5sums ? "md5sum" : "size")." mismatch)\n" );
1463 # seen that file, remove it from expect list
1464 @expected_files = map { $_ eq $name ? () : $_ } @expected_files;
1466 if (@expected_files) {
1467 msg( "log,mail", "Failed to upload the files\n" );
1468 msg( "log,mail", " ", join( ", ", @expected_files ), "\n" );
1469 msg( "log,mail", "(Not present on target after upload)\n" );
1473 if ($conf::chmod_on_target) {
1474 # change file's mode explicitly to 644 on target
1475 if ($conf::upload_method eq "ssh") {
1476 ($msgs, $stat) = ssh_cmd( "chmod 644 @files" );
1479 elsif ($conf::upload_method eq "ftp") {
1481 foreach $file (@files) {
1482 ($rv, $msgs) = ftp_cmd( "quot", "site", "chmod", "644", $file );
1483 msg( "log", "Can't chmod $file on target:\n$msgs" )
1489 ($msgs, $stat) = local_cmd( "$conf::chmod 644 @files" );
1495 write_status_file() if $conf::statusdelay;
1499 msg( "log,mail", "Upload to $conf::target failed",
1500 $? ? ", last exit status ".sprintf( "%s", $?>>8 ) : "", "\n" );
1501 msg( "log,mail", "Error messages:\n", $msgs )
1504 # If "permission denied" was among the errors, test if the incoming is
1506 if ($msgs =~ /(permission denied|read-?only file)/i) {
1507 if (!check_incoming_writable()) {
1508 msg( "log,mail", "(The incoming directory seems to be ",
1513 # remove bad files or an incomplete upload on target
1514 if ($conf::upload_method eq "ssh") {
1515 ssh_cmd( "rm -f @files" );
1517 elsif ($conf::upload_method eq "ftp") {
1519 foreach $file (@files) {
1521 ($rv, $err) = ftp_cmd( "delete", $file );
1522 msg( "log", "Can't delete $file on target:\n$err" )
1527 my @tfiles = map { "$main::current_targetdir/$_" } @files;
1528 debug( "executing unlink(@tfiles)" );
1532 write_status_file() if $conf::statusdelay;
1537 # check if a file is correctly signed with PGP
1548 if (-x $conf::gpg) {
1549 debug( "executing $conf::gpg --no-options --batch ".
1550 "--no-default-keyring --always-trust ".
1551 "--keyring ". join (" --keyring ",@conf::keyrings).
1552 "--verify '$file'" );
1553 if (!open( PIPE, "$conf::gpg --no-options --batch ".
1554 "--no-default-keyring --always-trust ".
1555 "--keyring " . join (" --keyring ",@conf::keyrings).
1558 msg( "log", "Can't open pipe to $conf::gpg: $!\n" );
1559 return "LOCAL ERROR";
1561 $output .= $_ while( <PIPE> );
1567 msg( "log,mail", "GnuPG signature check failed on $file\n" );
1568 msg( "mail", $output );
1569 msg( "log,mail", "(Exit status ", $stat >> 8, ")\n" );
1573 $output =~ /^(gpg: )?good signature from (user )?"(.*)"\.?$/im;
1574 ($signator = $3) ||= "unknown signator";
1576 debug( "GnuPG signature ok (by $signator)" );
1582 # ---------------------------------------------------------------------------
1584 # ---------------------------------------------------------------------------
1587 # fork a subprocess that watches the 'status' FIFO
1589 # that process blocks until someone opens the FIFO, then sends a
1590 # signal (SIGUSR1) to the main process, expects
1592 sub fork_statusd() {
1598 $statusd_pid = open( STATUSD, "|-" );
1599 die "cannot fork: $!\n" if !defined( $statusd_pid );
1600 # parent just returns
1602 msg( "log", "forked status daemon (pid $statusd_pid)\n" );
1603 return $statusd_pid;
1605 # child: the status FIFO daemon
1607 # ignore SIGPIPE here, in case some closes the FIFO without completely
1609 $SIG{"PIPE"} = "IGNORE";
1610 # also ignore SIGCLD, we don't want to inherit the restart-statusd handler
1612 $SIG{"CHLD"} = "DEFAULT";
1614 rm( $conf::statusfile );
1615 $errs = `$conf::mkfifo $conf::statusfile`;
1616 die "$main::progname: cannot create named pipe $conf::statusfile: $errs"
1618 chmod( 0644, $conf::statusfile )
1619 or die "Cannot set modes of $conf::statusfile: $!\n";
1621 # close log file, so that log rotating works
1627 my( $status, $mup, $incw, $ds, $next_run, $last_ping, $currch, $l );
1629 # open the FIFO for writing; this blocks until someone (probably ftpd)
1630 # opens it for reading
1631 open( STATFIFO, ">$conf::statusfile" )
1632 or die "Cannot open $conf::statusfile\n";
1634 # tell main daemon to send us status infos
1635 kill( $main::signo{"USR1"}, $main_pid );
1637 # get the infos from stdin; must loop until enough bytes received!
1638 my $expect_len = 3 + 2*STATNUM_LEN + STATSTR_LEN;
1639 for( $status = ""; ($l = length($status)) < $expect_len; ) {
1640 sysread( STDIN, $status, $expect_len-$l, $l );
1643 # disassemble the status byte stream
1645 foreach ( [ mup => 1 ], [ incw => 1 ], [ ds => 1 ],
1646 [ next_run => STATNUM_LEN ], [ last_ping => STATNUM_LEN ],
1647 [ currch => STATSTR_LEN ] ) {
1648 eval "\$$_->[0] = substr( \$status, $pos, $_->[1] );";
1651 $currch =~ s/\n+//g;
1653 print_status( $mup, $incw, $ds, $next_run, $last_ping, $currch );
1656 # This sleep is necessary so that we can't reopen the FIFO
1657 # immediately, in case the reader hasn't closed it yet if we get to
1658 # the open again. Is there a better solution for this??
1664 # update the status file, in case we use a plain file and not a FIFO
1666 sub write_status_file() {
1668 return if !$conf::statusfile;
1670 open( STATFILE, ">$conf::statusfile" ) or
1671 (msg( "log", "Could not open $conf::statusfile: $!\n" ), return);
1672 my $oldsel = select( STATFILE );
1674 print_status( $main::target_up, $main::incoming_writable, $main::dstat,
1675 $main::next_run, $main::last_ping_time,
1676 $main::current_changes );
1682 sub print_status($$$$$$) {
1686 my $next_run = shift;
1687 my $last_ping = shift;
1692 ($version = 'Release: 0.9 $Revision: 1.51 $') =~ s/\$ ?//g;
1693 print "debianqueued $version\n";
1695 $approx = $conf::statusdelay ? "approx. " : "";
1698 print "$conf::target is down, queue pausing\n";
1701 elsif ($conf::upload_method ne "copy") {
1702 print "$conf::target seems to be up, last ping $approx",
1703 print_time(time-$last_ping), " ago\n";
1707 print "The incoming directory is not writable, queue pausing\n";
1712 print "Next queue check in $approx",print_time($next_run-time),"\n";
1715 elsif ($ds eq "c") {
1716 print "Checking queue directory\n";
1718 elsif ($ds eq "u") {
1719 print "Uploading to $conf::target\n";
1722 print "Bad status data from daemon: \"$mup$incw$ds\"\n";
1726 print "Current job is $currch\n" if $currch;
1730 # format a number for sending to statusd (fixed length STATNUM_LEN)
1732 sub format_status_num(\$$) {
1736 $$varref = sprintf "%".STATNUM_LEN."d", $num;
1740 # format a string for sending to statusd (fixed length STATSTR_LEN)
1742 sub format_status_str(\$$) {
1746 $$varref = substr( $str, 0, STATSTR_LEN );
1747 $$varref .= "\n" x (STATSTR_LEN - length($$varref));
1751 # send a status string to the status daemon
1753 # Avoid all operations that could call malloc() here! Most libc
1754 # implementations aren't reentrant, so we may not call it from a
1755 # signal handler. So use only already-defined variables.
1758 local $! = 0; # preserve errno
1760 # re-setup handler, in case we have broken SysV signals
1761 $SIG{"USR1"} = \&send_status;
1763 syswrite( STATUSD, $main::target_up, 1 );
1764 syswrite( STATUSD, $main::incoming_writable, 1 );
1765 syswrite( STATUSD, $main::dstat, 1 );
1766 syswrite( STATUSD, $main::next_run, STATNUM_LEN );
1767 syswrite( STATUSD, $main::last_ping_time, STATNUM_LEN );
1768 syswrite( STATUSD, $main::current_changes, STATSTR_LEN );
1772 # ---------------------------------------------------------------------------
1774 # ---------------------------------------------------------------------------
1777 # open FTP connection to target host if not already open
1781 if ($main::FTP_chan) {
1782 # is already open, but might have timed out; test with a cwd
1783 return $main::FTP_chan if $main::FTP_chan->cwd( $main::current_targetdir );
1784 # cwd didn't work, channel is closed, try to reopen it
1785 $main::FTP_chan = undef;
1788 if (!($main::FTP_chan = Net::FTP->new( $conf::target,
1789 Debug => $conf::ftpdebug,
1790 Timeout => $conf::ftptimeout ))) {
1791 msg( "log,mail", "Cannot open FTP server $conf::target\n" );
1794 if (!$main::FTP_chan->login()) {
1795 msg( "log,mail", "Anonymous login on FTP server $conf::target failed\n" );
1798 if (!$main::FTP_chan->binary()) {
1799 msg( "log,mail", "Can't set binary FTP mode on $conf::target\n" );
1802 if (!$main::FTP_chan->cwd( $main::current_targetdir )) {
1803 msg( "log,mail", "Can't cd to $main::current_targetdir on $conf::target\n" );
1806 debug( "opened FTP channel to $conf::target" );
1810 $main::FTP_chan = undef;
1817 my $direct_resp_cmd = ($cmd eq "quot");
1819 debug( "executing FTP::$cmd(".join(", ",@_).")" );
1820 $SIG{"ALRM"} = sub { die "timeout in FTP::$cmd\n" } ;
1821 alarm( $conf::remote_timeout );
1822 eval { $rv = $main::FTP_chan->$cmd( @_ ); };
1825 $rv = (ftp_code() =~ /^2/) ? 1 : 0 if $direct_resp_cmd;
1831 $err = ftp_response();
1837 if ($main::FTP_chan) {
1838 $main::FTP_chan->quit();
1839 $main::FTP_chan = undef;
1844 sub ftp_response() {
1845 return join( '', @{${*$main::FTP_chan}{'net_cmd_resp'}} );
1849 return ${*$main::FTP_chan}{'net_cmd_code'};
1853 my $code = ftp_code();
1854 return ($code =~ /^[45]/) ? 1 : 0;
1857 # ---------------------------------------------------------------------------
1859 # ---------------------------------------------------------------------------
1865 my $ecmd = "$conf::ssh $conf::ssh_options $conf::target ".
1866 "-l $conf::targetlogin \'cd $main::current_targetdir; $cmd\'";
1867 debug( "executing $ecmd" );
1868 $SIG{"ALRM"} = sub { die "timeout in ssh command\n" } ;
1869 alarm( $conf::remote_timeout );
1870 eval { $msg = `$ecmd 2>&1`; };
1879 return ($msg, $stat);
1885 my $ecmd = "$conf::scp $conf::ssh_options @_ ".
1886 "$conf::targetlogin\@$conf::target:$main::current_targetdir";
1887 debug( "executing $ecmd" );
1888 $SIG{"ALRM"} = sub { die "timeout in scp\n" } ;
1889 alarm( $conf::remote_timeout );
1890 eval { $msg = `$ecmd 2>&1`; };
1899 return ($msg, $stat);
1902 sub local_cmd($;$) {
1907 my $ecmd = ($nocd ? "" : "cd $main::current_targetdir; ") . $cmd;
1908 debug( "executing $ecmd" );
1909 $msg = `($ecmd) 2>&1`;
1911 return ($msg, $stat);
1916 # check if target is alive (code stolen from Net::Ping.pm)
1918 sub check_alive(;$) {
1919 my $timeout = shift;
1920 my( $saddr, $ret, $target_ip );
1923 if ($conf::upload_method eq "copy") {
1924 format_status_num( $main::last_ping_time, time );
1925 $main::target_up = 1;
1931 if (!($target_ip = (gethostbyname($conf::target))[4])) {
1932 msg( "log", "Cannot get IP address of $conf::target\n" );
1936 $saddr = pack( 'S n a4 x8', AF_INET, $main::echo_port, $target_ip );
1937 $SIG{'ALRM'} = sub { die } ;
1940 $ret = $main::tcp_proto; # avoid warnings about unused variable
1943 return unless socket( PINGSOCK, PF_INET, SOCK_STREAM, $main::tcp_proto );
1944 return unless connect( PINGSOCK, $saddr );
1949 msg( "log", "pinging $conf::target: " . ($ret ? "ok" : "down") . "\n" );
1951 $main::target_up = $ret ? "1" : "0";
1952 format_status_num( $main::last_ping_time, time );
1953 write_status_file() if $conf::statusdelay;
1957 # check if incoming dir on target is writable
1959 sub check_incoming_writable() {
1960 my $testfile = ".debianqueued-testfile";
1963 if ($conf::upload_method eq "ssh") {
1964 ($msg, $stat) = ssh_cmd( "rm -f $testfile; touch $testfile; ".
1965 "rm -f $testfile" );
1967 elsif ($conf::upload_method eq "ftp") {
1968 my $file = "junk-for-writable-test-".format_time();
1969 $file =~ s/[ :.]/-/g;
1971 open( F, ">$file" ); close( F );
1973 ($rv, $msg) = ftp_cmd( "put", $file );
1975 $msg = "" if !defined $msg;
1977 ftp_cmd( "delete", $file );
1979 elsif ($conf::upload_method eq "copy") {
1980 ($msg, $stat) = local_cmd( "rm -f $testfile; touch $testfile; ".
1981 "rm -f $testfile" );
1984 debug( "exit status: $stat, output was: $msg" );
1987 # change incoming_writable only if ssh didn't return an error
1988 $main::incoming_writable =
1989 ($msg =~ /(permission denied|read-?only file|cannot create)/i) ? "0":"1";
1992 debug( "local error, keeping old status" );
1994 debug( "incoming_writable = $main::incoming_writable" );
1995 write_status_file() if $conf::statusdelay;
1996 return $main::incoming_writable;
2000 # remove a list of files, log failing ones
2006 (unlink $_ and ++$done)
2007 or $! == ENOENT or msg( "log", "Could not delete $_: $!\n" );
2013 # get md5 checksum of a file
2019 chomp( $line = `$conf::md5sum $file` );
2020 debug( "md5sum($file): ", $? ? "exit status $?" :
2021 $line =~ /^(\S+)/ ? $1 : "match failed" );
2022 return $? ? "" : $line =~ /^(\S+)/ ? $1 : "";
2026 # check if a file probably belongs to a Debian upload
2028 sub is_debian_file($) {
2030 return $file =~ /\.(deb|dsc|(diff|tar)\.gz)$/ &&
2031 $file !~ /\.orig\.tar\.gz/;
2035 # try to extract maintainer email address from some a non-.changes file
2036 # return "" if not possible
2038 sub get_maintainer($) {
2040 my $maintainer = "";
2043 if ($file =~ /\.diff\.gz$/) {
2045 open( F, "$conf::gzip -dc '$file' 2>/dev/null |" ) or return "";
2047 # look for header line of a file */debian/control
2048 last if m,^\+\+\+\s+[^/]+/debian/control(\s+|$),;
2051 last if /^---/; # end of control file patch, no Maintainer: found
2052 # inside control file patch look for Maintainer: field
2053 $maintainer = $1, last if /^\+Maintainer:\s*(.*)$/i;
2055 while( <F> ) { } # read to end of file to avoid broken pipe
2056 close( F ) or return "";
2058 elsif ($file =~ /\.(deb|dsc|tar\.gz)$/) {
2059 if ($file =~ /\.deb$/ && $conf::ar) {
2060 # extract control.tar.gz from .deb with ar, then let tar extract
2061 # the control file itself
2062 open( F, "($conf::ar p '$file' control.tar.gz | ".
2063 "$conf::tar -xOf - ".
2064 "--use-compress-program $conf::gzip ".
2065 "control) 2>/dev/null |" )
2068 elsif ($file =~ /\.dsc$/) {
2069 # just do a plain grep
2070 debug( "get_maint: .dsc, no cmd" );
2071 open( F, "<$file" ) or return "";
2073 elsif ($file =~ /\.tar\.gz$/) {
2074 # let tar extract a file */debian/control
2075 open(F, "$conf::tar -xOf '$file' ".
2076 "--use-compress-program $conf::gzip ".
2077 "\\*/debian/control 2>&1 |")
2084 $maintainer = $1, last if /^Maintainer:\s*(.*)$/i;
2086 close( F ) or return "";
2093 # return a pattern that matches all files that probably belong to one job
2095 sub debian_file_stem($) {
2097 my( $pkg, $version );
2100 $file =~ s,\.(deb|dsc|changes|(orig\.)?tar\.gz|diff\.gz)$,,;
2101 # if not is *_* (name_version), can't derive a stem and return just
2103 return $file if !($file =~ /^([^_]+)_([^_]+)/);
2104 ($pkg, $version) = ($1, $2);
2105 # strip Debian revision from version
2106 $version =~ s/^(.*)-[\d.+-]+$/$1/;
2108 return "${pkg}_${version}*";
2112 # output a messages to several destinations
2114 # first arg is a comma-separated list of destinations; valid are "log"
2115 # and "mail"; rest is stuff to be printed, just as with print
2118 my @dest = split( ',', shift );
2120 if (grep /log/, @dest ) {
2121 my $now = format_time();
2122 print LOG "$now ", @_;
2125 if (grep /mail/, @dest ) {
2126 $main::mail_text .= join( '', @_ );
2131 # print a debug messages, if $debug is true
2134 return if !$conf::debug;
2135 my $now = format_time();
2136 print LOG "$now DEBUG ", @_, "\n";
2140 # intialize the "mail" destination of msg() (this clears text,
2141 # address, subject, ...)
2146 $main::mail_addr = "";
2147 $main::mail_text = "";
2148 %main::packages = ();
2149 $main::mail_subject = $file ? "Processing of $file" : "";
2153 # finalize mail to be sent from msg(): check if something present, and
2158 debug( "No mail for $main::mail_addr" )
2159 if $main::mail_addr && !$main::mail_text;
2160 return unless $main::mail_addr && $main::mail_text;
2162 if (!send_mail($main::mail_addr, $main::mail_subject, $main::mail_text)) {
2163 # store this mail in memory so it isn't lost if executing sendmail
2165 push( @main::stored_mails, { addr => $main::mail_addr,
2166 subject => $main::mail_subject,
2167 text => $main::mail_text } );
2171 # try to send out stored mails
2173 while( $mailref = shift(@main::stored_mails) ) {
2174 if (!send_mail( $mailref->{'addr'}, $mailref->{'subject'},
2175 $mailref->{'text'} )) {
2176 unshift( @main::stored_mails, $mailref );
2185 sub send_mail($$$) {
2187 my $subject = shift;
2190 my $package = keys %main::packages ? join(' ', keys %main::packages) : "";
2194 unless (defined($Email::Send::Sendmail::SENDMAIL)) {
2195 $Email::Send::Sendmail::SENDMAIL = $conf::mail;
2198 my $date = sprintf "%s", strftime("%a, %d %b %Y %T %z", (localtime(time)));
2199 my $message = <<__MESSAGE__;
2201 From: Archive Administrator <dak\@ftp-master.debian.org>
2207 if (length $package) {
2208 $message .= "X-Debian-Package: $package\n";
2211 $message .= "\n$text";
2212 $message .= "\nGreetings,\n\n\tYour Debian queue daemon\n";
2214 my $mail = Email::Send->new;
2215 for ( qw[Sendmail SMTP] ) {
2216 $mail->mailer($_) and last if $mail->mailer_available($_);
2219 my $ret = $mail->send($message);
2220 if ($ret && $ret !~ /Message sent|success/) {
2228 # try to find a mail address for a name in the keyrings
2230 sub try_to_get_mail_addr($$) {
2232 my $listref = shift;
2235 open( F, "$conf::gpg --no-options --batch --no-default-keyring ".
2236 "--always-trust --keyring ".
2237 join (" --keyring ",@conf::keyrings).
2241 if (/^pub / && / $name /) {
2243 push( @$listref, $1 );
2248 return (@$listref >= 1) ? $listref->[0] : "";
2252 # return current time as string
2257 # omit weekday and year for brevity
2258 ($t = localtime) =~ /^\w+\s(.*)\s\d+$/;
2264 my $hours = int($secs/(60*60));
2266 $secs -= $hours*60*60;
2267 return sprintf "%d:%02d:%02d", $hours, int($secs/60), $secs % 60;
2271 # block some signals during queue processing
2273 # This is just to avoid data inconsistency or uploads being aborted in the
2274 # middle. Only "soft" signals are blocked, i.e. SIGINT and SIGTERM, try harder
2275 # ones if you really want to kill the daemon at once.
2277 sub block_signals() {
2278 POSIX::sigprocmask( SIG_BLOCK, $main::block_sigset );
2281 sub unblock_signals() {
2282 POSIX::sigprocmask( SIG_UNBLOCK, $main::block_sigset );
2286 # process SIGHUP: close log file and reopen it (for logfile cycling)
2293 open( LOG, ">>$conf::logfile" )
2294 or die "Cannot open my logfile $conf::logfile: $!\n";
2295 chmod( 0644, $conf::logfile )
2296 or msg( "log", "Cannot set modes of $conf::logfile: $!\n" );
2297 select( (select(LOG), $| = 1)[0] );
2299 open( STDOUT, ">&LOG" )
2300 or msg( "log", "$main::progname: Can't redirect stdout to ".
2301 "$conf::logfile: $!\n" );
2302 open( STDERR, ">&LOG" )
2303 or msg( "log", "$main::progname: Can't redirect stderr to ".
2304 "$conf::logfile: $!\n" );
2305 msg( "log", "Restart after SIGHUP\n" );
2309 # process SIGCHLD: check if it was our statusd process
2314 # reap statusd, so that it's no zombie when we try to kill(0) it
2315 waitpid( $main::statusd_pid, WNOHANG );
2317 # Uncomment the following line if your Perl uses unreliable System V signal
2318 # (i.e. if handlers reset to default if the signal is delivered).
2319 # (Unfortunately, the re-setup can't be done in any case, since on some
2320 # systems this will cause the SIGCHLD to be delivered again if there are
2321 # still unreaped children :-(( )
2323 # $SIG{"CHLD"} = \&kid_died; # resetup handler for SysV
2326 sub restart_statusd() {
2327 # restart statusd if it died
2328 if (!kill( 0, $main::statusd_pid)) {
2329 close( STATUSD ); # close out pipe end
2330 $main::statusd_pid = fork_statusd();
2335 # process a fatal signal: cleanup and exit
2337 sub fatal_signal($) {
2338 my $signame = shift;
2341 # avoid recursions of fatal_signal in case of BSD signals
2342 foreach $sig ( qw( ILL ABRT BUS FPE SEGV PIPE ) ) {
2343 $SIG{$sig} = "DEFAULT";
2346 if ($$ == $main::maind_pid) {
2347 # only the main daemon should do this
2348 kill( $main::signo{"TERM"}, $main::statusd_pid )
2349 if defined $main::statusd_pid;
2350 unlink( $conf::statusfile, $conf::pidfile );
2352 msg( "log", "Caught SIG$signame -- exiting (pid $$)\n" );