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>
7 # Copyright (C) 2008 Thomas Viehmann <tv@beamnet.de>
9 # This program is free software. You can redistribute it and/or
10 # modify it under the terms of the GNU General Public License as
11 # published by the Free Software Foundation: either version 2 or
12 # (at your option) any later version.
13 # This program comes with ABSOLUTELY NO WARRANTY!
19 use POSIX qw( strftime sys_stat_h sys_wait_h signal_h );
22 use Socket qw( PF_INET AF_INET SOCK_STREAM );
25 # ---------------------------------------------------------------------------
27 # ---------------------------------------------------------------------------
30 ($conf::queued_dir = (($0 !~ m,^/,) ? POSIX::getcwd()."/" : "") . $0)
32 require "$conf::queued_dir/config";
33 my $junk = $conf::debug; # avoid spurious warnings about unused vars
34 $junk = $conf::ssh_key_file;
35 $junk = $conf::stray_remove_timeout;
36 $junk = $conf::problem_report_timeout;
37 $junk = $conf::queue_delay;
38 $junk = $conf::keep_files;
39 $junk = $conf::valid_files;
40 $junk = $conf::max_upload_retries;
41 $junk = $conf::upload_delay_1;
42 $junk = $conf::upload_delay_2;
48 $junk = $conf::ftpdebug;
49 $junk = $conf::ftptimeout;
50 $junk = $conf::no_changes_timeout;
51 $junk = @conf::nonus_packages;
52 $junk = @conf::test_binaries;
53 $junk = @conf::maintainer_mail;
54 $junk = @conf::targetdir_delayed;
55 $junk = $conf::mail ||= '/usr/sbin/sendmail';
56 $conf::target = "localhost" if $conf::upload_method eq "copy";
59 ($main::progname = $0) =~ s,.*/,,;
63 # extract -r and -k args
65 if (@ARGV == 1 && $ARGV[0] =~ /^-[rk]$/) {
66 $main::arg = ($ARGV[0] eq '-k') ? "kill" : "restart";
70 # test for another instance of the queued already running
71 my ($pid, $delayed_dirs, $adelayedcore);
72 if (open( PIDFILE, "<$conf::pidfile" )) {
73 chomp( $pid = <PIDFILE> );
76 # remove stale pid file
77 unlink( $conf::pidfile );
81 print "Killing running daemon (pid $pid) ...";
84 while( kill( 0, $pid ) && $cnt-- > 0 ) {
88 if (kill( 0, $pid )) {
89 print " failed!\nProcess $pid still running.\n";
93 if (-e "$conf::incoming/core") {
94 unlink( "$conf::incoming/core" );
95 print "(Removed core file)\n";
97 for ($delayed_dirs = 0; $delayed_dirs <= $conf::max_delayed;
99 $adelayedcore = sprintf( "$conf::incoming_delayed/core",
101 if (-e $adelayedcore) {
102 unlink( $adelayedcore );
103 print "(Removed core file)\n";
106 exit 0 if $main::arg eq "kill";
109 die "Another $main::progname is already running (pid $pid)\n"
110 if $pid && kill( 0, $pid );
113 elsif ($main::arg eq "kill") {
114 die "No daemon running\n";
116 elsif ($main::arg eq "restart") {
117 print "(No daemon running; starting anyway)\n";
120 # if started without arguments (initial invocation), then fork
122 # now go to background
123 die "$main::progname: fork failed: $!\n" unless defined( $pid = fork );
125 # parent: wait for signal from child (SIGCHLD or SIGUSR1) and exit
126 my $sigset = POSIX::SigSet->new();
128 $SIG{"CHLD"} = sub { };
129 $SIG{"USR1"} = sub { };
130 POSIX::sigsuspend( $sigset );
131 waitpid( $pid, WNOHANG );
132 if (kill( 0, $pid )) {
133 print "Daemon started in background (pid $pid)\n";
143 if ($conf::upload_method eq "ssh") {
144 # exec an ssh-agent that starts us again
145 # force shell to be /bin/sh, ssh-agent may base its decision
146 # whether to use a fd or a Unix socket on the shell...
147 $ENV{"SHELL"} = "/bin/sh";
148 exec $conf::ssh_agent, $0, "startup", getppid();
149 die "$main::progname: Could not exec $conf::ssh_agent: $!\n";
152 # no need to exec, just set up @ARGV as expected below
153 @ARGV = ("startup", getppid());
157 die "Please start without any arguments.\n"
158 if @ARGV != 2 || $ARGV[0] ne "startup";
159 my $parent_pid = $ARGV[1];
163 ($version = 'Release: 0.9 $Revision: 1.51 $ $Date: 1999/07/08 09:43:21 $ $Author: ftplinux $') =~ s/\$ ?//g;
164 print "debianqueued $version\n";
167 # check if all programs exist
169 foreach $prg ( $conf::gpg, $conf::ssh, $conf::scp, $conf::ssh_agent,
170 $conf::ssh_add, $conf::md5sum, $conf::mail, $conf::mkfifo ) {
171 die "Required program $prg doesn't exist or isn't executable\n"
173 # check for correct upload method
174 die "Bad upload method '$conf::upload_method'.\n"
175 if $conf::upload_method ne "ssh" &&
176 $conf::upload_method ne "ftp" &&
177 $conf::upload_method ne "copy";
178 die "No keyrings\n" if ! @conf::keyrings;
181 die "statusfile path must be absolute."
182 if $conf::statusfile !~ m,^/,;
183 die "upload and target queue paths must be absolute."
184 if $conf::incoming !~ m,^/, ||
185 $conf::incoming_delayed !~ m,^/, ||
186 $conf::targetdir !~ m,^/, ||
187 $conf::targetdir_delayed !~ m,^/,;
190 # ---------------------------------------------------------------------------
192 # ---------------------------------------------------------------------------
197 sub get_filelist_from_known_good_changes($);
198 sub age_delayed_queues();
199 sub process_changes($\@);
200 sub process_commands($);
201 sub age_delayed_queues();
202 sub is_on_target($\@);
203 sub copy_to_target(@);
206 sub check_incoming_writable();
208 sub write_status_file();
209 sub print_status($$$$$$);
210 sub format_status_num(\$$);
211 sub format_status_str(\$$);
223 sub check_incoming_writable();
226 sub is_debian_file($);
227 sub get_maintainer($);
228 sub debian_file_stem($);
234 sub try_to_get_mail_addr($$);
238 sub unblock_signals();
241 sub restart_statusd();
244 $ENV{"PATH"} = "/bin:/usr/bin";
245 $ENV{"IFS"} = "" if defined($ENV{"IFS"} && $ENV{"IFS"} ne "");
258 sub ST_CTIME() { 10 }
259 # fixed lengths of data items passed over status pipe
260 sub STATNUM_LEN() { 30 }
261 sub STATSTR_LEN() { 128 }
263 # init list of signals
264 defined $Config{sig_name} or die "$main::progname: No signal list defined!\n";
267 foreach $name (split( ' ', $Config{sig_name} )) {
268 $main::signo{$name} = $i++;
271 @main::fatal_signals = qw( INT QUIT ILL TRAP ABRT BUS FPE USR2 SEGV PIPE
272 TERM XCPU XFSZ PWR );
274 $main::block_sigset = POSIX::SigSet->new;
275 $main::block_sigset->addset( $main::signo{"INT"} );
276 $main::block_sigset->addset( $main::signo{"TERM"} );
278 # some constant net stuff
279 $main::tcp_proto = (getprotobyname('tcp'))[2]
280 or die "Cannot get protocol number for 'tcp'\n";
281 my $used_service = ($conf::upload_method eq "ssh") ? "ssh" : "ftp";
282 $main::echo_port = (getservbyname($used_service, 'tcp'))[2]
283 or die "Cannot get port number for service '$used_service'\n";
285 # clear queue of stored mails
286 @main::stored_mails = ();
288 # run ssh-add to bring the key into the agent (will use stdin/stdout)
289 if ($conf::upload_method eq "ssh") {
290 system "$conf::ssh_add $conf::ssh_key_file"
291 and die "$main::progname: Running $conf::ssh_add failed ".
292 "(exit status ", $? >> 8, ")\n";
295 # change to queue dir
296 chdir( $conf::incoming )
297 or die "$main::progname: cannot cd to $conf::incoming: $!\n";
299 # needed before /dev/null redirects, some system send a SIGHUP when loosing
300 # the controlling tty
301 $SIG{"HUP"} = "IGNORE";
303 # open logfile, make it unbuffered
304 open( LOG, ">>$conf::logfile" )
305 or die "Cannot open my logfile $conf::logfile: $!\n";
306 chmod( 0644, $conf::logfile )
307 or die "Cannot set modes of $conf::logfile: $!\n";
308 select( (select(LOG), $| = 1)[0] );
311 $SIG{"HUP"} = \&close_log;
313 # redirect stdin, ... to /dev/null
314 open( STDIN, "</dev/null" )
315 or die "$main::progname: Can't redirect stdin to /dev/null: $!\n";
316 open( STDOUT, ">&LOG" )
317 or die "$main::progname: Can't redirect stdout to $conf::logfile: $!\n";
318 open( STDERR, ">&LOG" )
319 or die "$main::progname: Can't redirect stderr to $conf::logfile: $!\n";
320 # ok, from this point usually no "die" anymore, stderr is gone!
321 msg( "log", "daemon (pid $$) started\n" );
323 # initialize variables used by send_status before launching the status daemon
325 format_status_num( $main::next_run, time+10 );
326 format_status_str( $main::current_changes, "" );
328 $main::incoming_writable = 1; # assume this for now
330 # start the daemon watching the 'status' FIFO
331 if ($conf::statusfile && $conf::statusdelay == 0) {
332 $main::statusd_pid = fork_statusd();
333 $SIG{"CHLD"} = \&kid_died; # watch out for dead status daemon
334 # SIGUSR1 triggers status info
335 $SIG{"USR1"} = \&send_status;
337 $main::maind_pid = $$;
339 END { kill( $main::signo{"ABRT"}, $$ ) if defined $main::signo{"ABRT"}; }
342 open( PIDFILE, ">$conf::pidfile" )
343 or msg( "log", "Can't open $conf::pidfile: $!\n" );
344 printf PIDFILE "%5d\n", $$;
346 chmod( 0644, $conf::pidfile )
347 or die "Cannot set modes of $conf::pidfile: $!\n";
349 # other signals will just log an error and exit
350 foreach ( @main::fatal_signals ) {
351 $SIG{$_} = \&fatal_signal;
354 # send signal to user-started process that we're ready and it can exit
355 kill( $main::signo{"USR1"}, $parent_pid );
357 # ---------------------------------------------------------------------------
359 # ---------------------------------------------------------------------------
361 # default to classical incoming/target
362 $main::current_incoming = $conf::incoming;
363 $main::current_targetdir = $conf::targetdir;
366 write_status_file() if $conf::statusdelay;
369 # ping target only if there is the possibility that we'll contact it (but
370 # also don't wait too long).
371 my @have_changes = <*.changes *.commands>;
372 for ( my $delayed_dirs = 0; $delayed_dirs <= $conf::max_delayed;
374 my $adelayeddir = sprintf( "$conf::incoming_delayed",
377 <$adelayeddir/*.changes> );
379 check_alive() if @have_changes || (time - $main::last_ping_time) > 8*60*60;
381 if (@have_changes && $main::target_up) {
382 check_incoming_writable if !$main::incoming_writable;
383 check_dir() if $main::incoming_writable;
386 write_status_file() if $conf::statusdelay;
388 if ($conf::upload_method eq "copy") {
389 age_delayed_queues();
392 # sleep() returns if we received a signal (SIGUSR1 for status FIFO), so
393 # calculate the end time once and wait for it being reached.
394 format_status_num( $main::next_run, time + $conf::queue_delay );
396 while( ($delta = calc_delta()) > 0 ) {
397 debug( "mainloop sleeping $delta secs" );
399 # check if statusd died, if using status FIFO, or update status file
400 if ($conf::statusdelay) {
412 $delta = $main::next_run - time;
413 $delta = $conf::statusdelay
414 if $conf::statusdelay && $conf::statusdelay < $delta;
419 # ---------------------------------------------------------------------------
420 # main working functions
421 # ---------------------------------------------------------------------------
425 # main function for checking the incoming dir
428 my( @files, @changes, @keep_files, @this_keep_files, @stats, $file ,
431 debug( "starting checkdir" );
433 write_status_file() if $conf::statusdelay;
435 # test if needed binaries are available; this is if they're on maybe
436 # slow-mounted NFS filesystems
437 foreach (@conf::test_binaries) {
439 # maybe the mount succeeds now
442 msg( "log", "binary test failed for $_; delaying queue run\n");
446 for ( $adelay=-1; $adelay <= $conf::max_delayed; $adelay++ ) {
447 if ( $adelay == -1 ) {
448 $main::current_incoming = $conf::incoming;
449 $main::current_incoming_short = "";
450 $main::current_targetdir = $conf::targetdir;
453 $main::current_incoming = sprintf( $conf::incoming_delayed,
455 $main::current_incoming_short = sprintf( "DELAYED/%d-day",
457 $main::current_targetdir = sprintf( $conf::targetdir_delayed,
461 # need to clear directory specific variables
462 undef ( @keep_files );
463 undef ( @this_keep_files );
465 chdir ( $main::current_incoming )
467 "Cannot change to dir ".
468 "${main::current_incoming_short}: $!\n" ),
471 # look for *.commands files but not in delayed queues
473 foreach $file ( <*.commands> ) {
476 process_commands( $file );
479 write_status_file() if $conf::statusdelay;
484 or (msg( "log", "Cannot open dir ${main::current_incoming_short}: $!\n" ),
486 @files = readdir( INC );
489 # process all .changes files found
490 @changes = grep /\.changes$/, @files;
491 push( @keep_files, @changes ); # .changes files aren't stray
492 foreach $file ( @changes ) {
494 # wrap in an eval to allow jumpbacks to here with die in case
497 eval { process_changes( $file, @this_keep_files ); };
499 msg( "log,mail", $@ ) if $@;
501 write_status_file() if $conf::statusdelay;
503 # files which are ok in conjunction with this .changes
504 debug( "$file tells to keep @this_keep_files" );
505 push( @keep_files, @this_keep_files );
508 # break out of this loop if the incoming dir has become unwritable
509 goto end_run if !$main::incoming_writable;
511 ftp_close() if $conf::upload_method eq "ftp";
513 # find files which aren't related to any .changes
514 foreach $file ( @files ) {
515 # filter out files we never want to delete
516 next if ! -f $file || # may have disappeared in the meantime
517 $file eq "." || $file eq ".." ||
518 (grep { $_ eq $file } @keep_files) ||
519 $file =~ /$conf::keep_files/;
520 # Delete such files if they're older than
521 # $stray_remove_timeout; they could be part of an
522 # yet-incomplete upload, with the .changes still missing.
523 # Cannot send any notification, since owner unknown.
524 next if !(@stats = stat( $file ));
525 my $age = time - $stats[ST_MTIME];
526 my( $maint, $pattern, @job_files );
527 if ($file =~ /^junk-for-writable-test/ ||
528 $file !~ m,$conf::valid_files, ||
529 $age >= $conf::stray_remove_timeout) {
530 msg( "log", "Deleted stray file ${main::current_incoming_short}/$file\n" ) if rm( $file );
532 elsif ($age > $conf::no_changes_timeout &&
533 is_debian_file( $file ) &&
534 # not already reported
535 !($stats[ST_MODE] & S_ISGID) &&
536 ($pattern = debian_file_stem( $file )) &&
537 (@job_files = glob($pattern)) &&
538 # If a .changes is in the list, it has the same stem as the
539 # found file (probably a .orig.tar.gz). Don't report in this
541 !(grep( /\.changes$/, @job_files ))) {
542 $maint = get_maintainer( $file );
543 # Don't send a mail if this looks like the recompilation of a
544 # package for a non-i386 arch. For those, the maintainer field is
546 if (!grep( /(\.dsc|_(i386|all)\.deb)$/, @job_files )) {
547 msg( "log", "Found an upload without .changes and with no ",
549 msg( "log", "Not sending a report, because probably ",
550 "recompilation job\n" );
554 $main::mail_addr = $maint;
555 $main::mail_addr = $1 if $main::mail_addr =~ /<([^>]*)>/;
556 $main::mail_subject = "Incomplete upload found in ".
557 "Debian upload queue";
558 msg( "mail", "Probably you are the uploader of the following ".
560 msg( "mail", "the Debian upload queue directory:\n " );
561 msg( "mail", join( "\n ", @job_files ), "\n" );
562 msg( "mail", "This looks like an upload, but a .changes file ".
563 "is missing, so the job\n" );
564 msg( "mail", "cannot be processed.\n\n" );
565 msg( "mail", "If no .changes file arrives within ",
566 print_time( $conf::stray_remove_timeout - $age ),
567 ", the files will be deleted.\n\n" );
568 msg( "mail", "If you didn't upload those files, please just ".
569 "ignore this message.\n" );
571 msg( "log", "Sending problem report for an upload without a ".
573 msg( "log", "Maintainer: $maint\n" );
576 msg( "log", "Found an upload without .changes, but can't ".
577 "find a maintainer address\n" );
579 msg( "log", "Files: @job_files\n" );
580 # remember we already have sent a mail regarding this file
581 foreach ( @job_files ) {
583 next if !@st; # file may have disappeared in the meantime
584 chmod +($st[ST_MODE] |= S_ISGID), $_;
588 debug( "found stray file ${main::current_incoming_short}/$file, deleting in ",
589 print_time($conf::stray_remove_timeout - $age) );
593 chdir( $conf::incoming );
597 write_status_file() if $conf::statusdelay;
600 sub get_filelist_from_known_good_changes($) {
606 # parse the .changes file
607 open( CHANGES, "<$changes" )
608 or die "$changes: $!\n";
609 outer_loop: while( <CHANGES> ) {
612 redo outer_loop if !/^\s/;
613 my @field = split( /\s+/ );
615 # forbid shell meta chars in the name, we pass it to a
616 # subshell several times...
617 $field[5] =~ /^([a-zA-Z0-9.+_:@=%-][~a-zA-Z0-9.+_:@=%-]*)/;
618 if ($1 ne $field[5]) {
619 msg( "log", "found suspicious filename $field[5]\n" );
622 push( @filenames, $field[5] );
631 # process one .changes file
633 sub process_changes($\@) {
635 my $keep_list = shift;
636 my( $pgplines, @files, @filenames, @changes_stats, $failure_file,
637 $retries, $last_retry, $upload_time, $file, $do_report, $ls_l,
638 $problems_reported, $errs, $pkgname, $signator );
642 format_status_str( $main::current_changes, "$main::current_incoming_short/$changes" );
644 write_status_file() if $conf::statusdelay;
647 msg( "log", "processing ${main::current_incoming_short}/$changes\n" );
649 # parse the .changes file
650 open( CHANGES, "<$changes" )
651 or die "Cannot open ${main::current_incoming_short}/$changes: $!\n";
653 $main::mail_addr = "";
655 outer_loop: while( <CHANGES> ) {
656 if (/^---+(BEGIN|END) PGP .*---+$/) {
659 elsif (/^Maintainer:\s*/i) {
660 chomp( $main::mail_addr = $' );
661 $main::mail_addr = $1 if $main::mail_addr =~ /<([^>]*)>/;
663 elsif (/^Source:\s*/i) {
664 chomp( $pkgname = $' );
665 $pkgname =~ s/\s+$//;
666 $main::packages{$pkgname}++;
670 redo outer_loop if !/^\s/;
671 my @field = split( /\s+/ );
673 # forbid shell meta chars in the name, we pass it to a
674 # subshell several times...
675 $field[5] =~ /^([a-zA-Z0-9.+_:@=%-][~a-zA-Z0-9.+_:@=%-]*)/;
676 if ($1 ne $field[5]) {
677 msg( "log", "found suspicious filename $field[5]\n" );
678 msg( "mail", "File '$field[5]' mentioned in $main::current_incoming_short/$changes\n",
679 "has bad characters in its name. Removed.\n" );
683 push( @files, { md5 => $field[1],
685 name => $field[5] } );
686 push( @filenames, $field[5] );
687 debug( "includes file $field[5], size $field[2], ",
694 # tell check_dir that the files mentioned in this .changes aren't stray,
695 # we know about them somehow
696 @$keep_list = @filenames;
698 # some consistency checks
699 if (!$main::mail_addr) {
700 msg( "log,mail", "$main::current_incoming_short/$changes doesn't contain a Maintainer: field; ".
701 "cannot process\n" );
702 goto remove_only_changes;
704 if ($main::mail_addr !~ /^(buildd_\S+-\S+|\S+\@\S+\.\S+)/) {
705 # doesn't look like a mail address, maybe only the name
706 my( $new_addr, @addr_list );
707 if ($new_addr = try_to_get_mail_addr( $main::mail_addr, \@addr_list )){
708 # substitute (unique) found addr, but give a warning
709 msg( "mail", "(The Maintainer: field didn't contain a proper ".
711 msg( "mail", "Looking for `$main::mail_addr' in the Debian ".
712 "keyring gave your address\n" );
713 msg( "mail", "as unique result, so I used this.)\n" );
714 msg( "log", "Substituted $new_addr for malformed ".
715 "$main::mail_addr\n" );
716 $main::mail_addr = $new_addr;
719 # not found or not unique: hold the job and inform queue maintainer
720 my $old_addr = $main::mail_addr;
721 $main::mail_addr = $conf::maintainer_mail;
722 msg( "mail", "The job ${main::current_incoming_short}/$changes doesn't have a correct email\n" );
723 msg( "mail", "address in the Maintainer: field:\n" );
724 msg( "mail", " $old_addr\n" );
725 msg( "mail", "A check for this in the Debian keyring gave:\n" );
726 msg( "mail", @addr_list ?
727 " " . join( ", ", @addr_list ) . "\n" :
729 msg( "mail", "Please fix this manually\n" );
730 msg( "log", "Bad Maintainer: field in ${main::current_incoming_short}/$changes: $old_addr\n" );
731 goto remove_only_changes;
735 msg( "log,mail", "$main::current_incoming_short/$changes isn't signed with PGP/GnuPG\n" );
736 msg( "log", "(uploader $main::mail_addr)\n" );
737 goto remove_only_changes;
740 msg( "log,mail", "$main::current_incoming_short/$changes doesn't mention any files\n" );
741 msg( "log", "(uploader $main::mail_addr)\n" );
742 goto remove_only_changes;
745 # check for packages that shouldn't be processed
746 if (grep( $_ eq $pkgname, @conf::nonus_packages )) {
747 msg( "log,mail", "$pkgname is a package that must be uploaded ".
748 "to nonus.debian.org\n" );
749 msg( "log,mail", "instead of target.\n" );
750 msg( "log,mail", "Job rejected and removed all files belonging ".
752 msg( "log,mail", " ", join( ", ", @filenames ), "\n" );
753 rm( $changes, @filenames );
757 $failure_file = $changes . ".failures";
758 $retries = $last_retry = 0;
759 if (-f $failure_file) {
760 open( FAILS, "<$failure_file" )
761 or die "Cannot open $main::current_incoming_short/$failure_file: $!\n";
764 ( $retries, $last_retry ) = ( $1, $2 ) if $line =~ /^(\d+)\s+(\d+)$/;
765 push( @$keep_list, $failure_file );
768 # run PGP on the file to check the signature
769 if (!($signator = pgp_check( $changes ))) {
770 msg( "log,mail", "$main::current_incoming_short/$changes has bad PGP/GnuPG signature!\n" );
771 msg( "log", "(uploader $main::mail_addr)\n" );
773 msg( "log,mail", "Removing $main::current_incoming_short/$changes, but keeping its associated ",
774 "files for now.\n" );
776 # Set SGID bit on associated files, so that the test for Debian files
777 # without a .changes doesn't consider them.
778 foreach ( @filenames ) {
780 next if !@st; # file may have disappeared in the meantime
781 chmod +($st[ST_MODE] |= S_ISGID), $_;
785 elsif ($signator eq "LOCAL ERROR") {
786 # An error has appened when starting pgp... Don't process the file,
787 # but also don't delete it
788 debug( "Can't PGP/GnuPG check $main::current_incoming_short/$changes -- don't process it for now" );
792 die "Cannot stat ${main::current_incoming_short}/$changes (??): $!\n"
793 if !(@changes_stats = stat( $changes ));
794 # Make $upload_time the maximum of all modification times of files
795 # related to this .changes (and the .changes it self). This is the
796 # last time something changes to these files.
797 $upload_time = $changes_stats[ST_MTIME];
798 for $file ( @files ) {
800 next if !(@stats = stat( $file->{"name"} ));
801 $file->{"stats"} = \@stats;
802 $upload_time = $stats[ST_MTIME] if $stats[ST_MTIME] > $upload_time;
805 $do_report = (time - $upload_time) > $conf::problem_report_timeout;
806 $problems_reported = $changes_stats[ST_MODE] & S_ISGID;
807 # if any of the files is newer than the .changes' ctime (the time
808 # we sent a report and set the sticky bit), send new problem reports
809 if ($problems_reported && $changes_stats[ST_CTIME] < $upload_time) {
810 $problems_reported = 0;
811 chmod +($changes_stats[ST_MODE] &= ~S_ISGID), $changes;
812 debug( "upload_time>changes-ctime => resetting problems reported" );
814 debug( "do_report=$do_report problems_reported=$problems_reported" );
816 # now check all files for correct size and md5 sum
817 for $file ( @files ) {
818 my $filename = $file->{"name"};
819 if (!defined( $file->{"stats"} )) {
820 # could be an upload that isn't complete yet, be quiet,
821 # but don't process the file;
822 msg( "log,mail", "$filename doesn't exist\n" )
823 if $do_report && !$problems_reported;
824 msg( "log", "$filename doesn't exist (ignored for now)\n" )
826 msg( "log", "$filename doesn't exist (already reported)\n" )
827 if $problems_reported;
830 elsif ($file->{"stats"}->[ST_SIZE] < $file->{"size"} && !$do_report) {
831 # could be an upload that isn't complete yet, be quiet,
832 # but don't process the file
833 msg( "log", "$filename is too small (ignored for now)\n" );
836 elsif ($file->{"stats"}->[ST_SIZE] != $file->{"size"}) {
837 msg( "log,mail", "$filename has incorrect size; deleting it\n" );
841 elsif (md5sum( $filename ) ne $file->{"md5"}) {
842 msg( "log,mail", "$filename has incorrect md5 checksum; ",
850 if ((time - $upload_time) > $conf::bad_changes_timeout) {
851 # if a .changes fails for a really long time (several days
852 # or so), remove it and all associated files
854 "$main::current_incoming_short/$changes couldn't be processed for ",
855 int($conf::bad_changes_timeout/(60*60)),
856 " hours and is now deleted\n" );
858 "All files it mentions are also removed:\n" );
859 msg( "log,mail", " ", join( ", ", @filenames ), "\n" );
860 rm( $changes, @filenames, $failure_file );
862 elsif ($do_report && !$problems_reported) {
863 # otherwise, send a problem report, if not done already
865 "Due to the errors above, the .changes file couldn't ",
867 "Please fix the problems for the upload to happen.\n" );
868 # remember we already have sent a mail regarding this file
869 debug( "Sending problem report mail and setting SGID bit" );
870 my $mode = $changes_stats[ST_MODE] |= S_ISGID;
871 msg( "log", "chmod failed: $!" ) if (chmod ($mode, $changes) != 1);
878 # if this upload already failed earlier, wait until the delay requirement
880 if ($retries > 0 && (time - $last_retry) <
881 ($retries == 1 ? $conf::upload_delay_1 : $conf::upload_delay_2)) {
882 msg( "log", "delaying retry of upload\n" );
886 if ($conf::upload_method eq "ftp") {
887 return if !ftp_open();
890 # check if the job is already present on target
891 # (moved to here, to avoid bothering target as long as there are errors in
893 if ($ls_l = is_on_target( $changes, @filenames )) {
894 msg( "log,mail", "$main::current_incoming_short/$changes is already present on target host:\n" );
895 msg( "log,mail", "$ls_l\n" );
896 msg( "mail", "Either you already uploaded it, or someone else ",
898 msg( "log,mail", "Job $changes removed.\n" );
899 rm( $changes, @filenames, $failure_file );
903 # clear sgid bit before upload, scp would copy it to target. We don't need
904 # it anymore, we know there are no problems if we come here. Also change
905 # mode of files to 644 if this should be done locally.
906 $changes_stats[ST_MODE] &= ~S_ISGID;
907 if (!$conf::chmod_on_target) {
908 $changes_stats[ST_MODE] &= ~0777;
909 $changes_stats[ST_MODE] |= 0644;
911 chmod +($changes_stats[ST_MODE]), $changes;
913 # try uploading to target
914 if (!copy_to_target( $changes, @filenames )) {
915 # if the upload failed, increment the retry counter and remember the
916 # current time; both things are written to the .failures file. Don't
917 # increment the fail counter if the error was due to incoming
919 return if !$main::incoming_writable;
920 if (++$retries >= $conf::max_upload_retries) {
922 "$changes couldn't be uploaded for $retries times now.\n" );
924 "Giving up and removing it and its associated files:\n" );
925 msg( "log,mail", " ", join( ", ", @filenames ), "\n" );
926 rm( $changes, @filenames, $failure_file );
930 if (open( FAILS, ">$failure_file" )) {
931 print FAILS "$retries $last_retry\n";
933 chmod( 0600, $failure_file )
934 or die "Cannot set modes of $failure_file: $!\n";
936 push( @$keep_list, $failure_file );
937 debug( "now $retries failed uploads" );
939 "The upload will be retried in ",
940 print_time( $retries == 1 ? $conf::upload_delay_1 :
941 $conf::upload_delay_2 ), "\n" );
946 # If the files were uploaded ok, remove them
947 rm( $changes, @filenames, $failure_file );
949 msg( "mail", "$changes uploaded successfully to $conf::target\n" );
950 msg( "mail", "along with the files:\n ",
951 join( "\n ", @filenames ), "\n" );
952 msg( "log", "$changes processed successfully (uploader $main::mail_addr)\n" );
954 # Check for files that have the same stem as the .changes (and weren't
955 # mentioned there) and delete them. It happens often enough that people
956 # upload a .orig.tar.gz where it isn't needed and also not in the
957 # .changes. Explicitly deleting it (and not waiting for the
958 # $stray_remove_timeout) reduces clutter in the queue dir and maybe also
959 # educates uploaders :-)
961 # my $pattern = debian_file_stem( $changes );
962 # my $spattern = substr( $pattern, 0, -1 ); # strip off '*' at end
963 # my @other_files = glob($pattern);
964 # filter out files that have a Debian revision at all and a different
965 # revision. Those belong to a different upload.
966 # if ($changes =~ /^\Q$spattern\E-([\d.+-]+)/) {
968 # @other_files = grep( !/^\Q$spattern\E-([\d.+-]+)/ || $1 eq $this_rev,
971 # Also do not remove those files if a .changes is among them. Then there
972 # is probably a second upload for another version or another architecture.
973 # if (@other_files && !grep( /\.changes$/, @other_files )) {
974 # rm( @other_files );
975 # msg( "mail", "\nThe following file(s) seemed to belong to the same ".
976 # "upload, but weren't listed\n" );
977 # msg( "mail", "in the .changes file:\n " );
978 # msg( "mail", join( "\n ", @other_files ), "\n" );
979 # msg( "mail", "They have been deleted.\n" );
980 # msg( "log", "Deleted files in upload not in $changes: @other_files\n" );
985 # process one .commands file
987 sub process_commands($) {
988 my $commands = shift;
989 my( @cmds, $cmd, $pgplines, $signator );
991 my( @files, $file, @removed, $target_delay );
993 format_status_str( $main::current_changes, $commands );
995 write_status_file() if $conf::statusdelay;
997 msg( "log", "processing $main::current_incoming_short/$commands\n" );
999 # parse the .commands file
1000 if (!open( COMMANDS, "<$commands" )) {
1001 msg( "log", "Cannot open $main::current_incoming_short/$commands: $!\n" );
1005 $main::mail_addr = "";
1007 outer_loop: while( <COMMANDS> ) {
1008 if (/^---+(BEGIN|END) PGP .*---+$/) {
1011 elsif (/^Uploader:\s*/i) {
1012 chomp( $main::mail_addr = $' );
1013 $main::mail_addr = $1 if $main::mail_addr =~ /<([^>]*)>/;
1015 elsif (/^Commands:/i) {
1018 s/^\s*(.*)\s*$/$1/; # delete whitespace at both ends
1021 debug( "includes cmd $_" );
1023 last outer_loop if !defined( $_ = scalar(<COMMANDS>) );
1025 redo outer_loop if !/^\s/ || /^$/;
1031 # some consistency checks
1032 if (!$main::mail_addr || $main::mail_addr !~ /^\S+\@\S+\.\S+/) {
1033 msg( "log,mail", "$main::current_incoming_short/$commands contains no or bad Uploader: field: ".
1034 "$main::mail_addr\n" );
1035 msg( "log,mail", "cannot process $main::current_incoming_short/$commands\n" );
1036 $main::mail_addr = "";
1039 msg( "log", "(command uploader $main::mail_addr)\n" );
1041 if ($pgplines < 3) {
1042 msg( "log,mail", "$main::current_incoming_short/$commands isn't signed with PGP/GnuPG\n" );
1043 msg( "mail", "or the uploaded file is broken. Make sure to transfer in binary mode\n" );
1044 msg( "mail", "or better yet - use dcut for commands files\n");
1048 # run PGP on the file to check the signature
1049 if (!($signator = pgp_check( $commands ))) {
1050 msg( "log,mail", "$main::current_incoming_short/$commands has bad PGP/GnuPG signature!\n" );
1052 msg( "log,mail", "Removing $main::current_incoming_short/$commands\n" );
1056 elsif ($signator eq "LOCAL ERROR") {
1057 # An error has appened when starting pgp... Don't process the file,
1058 # but also don't delete it
1059 debug( "Can't PGP/GnuPG check $main::current_incoming_short/$commands -- don't process it for now" );
1062 msg( "log", "(PGP/GnuPG signature by $signator)\n" );
1064 # now process commands
1065 msg( "mail", "Log of processing your commands file $main::current_incoming_short/$commands:\n\n" );
1066 foreach $cmd ( @cmds ) {
1067 my @word = split( /\s+/, $cmd );
1068 msg( "mail,log", "> @word\n" );
1069 my $selecteddelayed = -1;
1072 if ($word[0] eq "rm") {
1073 foreach ( @word[1..$#word] ) {
1075 if (m,^DELAYED/([0-9]+)-day/,) {
1076 $selecteddelayed = $1;
1077 s,^DELAYED/[0-9]+-day/,,;
1079 if ($origword eq "--searchdirs") {
1080 $selecteddelayed = -2;
1083 msg( "mail,log", "$_: filename may not contain slashes except for DELAYED/#-day/ prefixes\n" );
1086 # process wildcards but also plain names
1088 my $pat = quotemeta($_);
1089 $pat =~ s/\\\*/.*/g;
1090 $pat =~ s/\\\?/.?/g;
1091 $pat =~ s/\\([][])/$1/g;
1093 if ( $selecteddelayed < 0) { # scanning or explicitly incoming
1094 opendir( DIR, "." );
1095 push (@thesefiles, grep /^$pat$/, readdir(DIR) );
1098 if ( $selecteddelayed >= 0) {
1099 my $dir = sprintf( $conf::incoming_delayed, $selecteddelayed );
1100 opendir( DIR, $dir );
1101 push( @thesefiles, map ("$dir/$_", grep /^$pat$/, readdir(DIR) ));
1104 elsif ( $selecteddelayed == -2) {
1105 for ( my($adelay)=0; (! @thesefiles) && $adelay <= $conf::max_delayed; $adelay++ ) {
1106 my $dir = sprintf( $conf::incoming_delayed, $adelay );
1107 opendir( DIR, $dir);
1108 push( @thesefiles, map ("$dir/$_", grep /^$pat$/, readdir(DIR) ));
1112 push (@files, @thesefiles);
1113 if (! @thesefiles) {
1114 msg( "mail,log", "$origword did not match anything\n" );
1119 msg( "mail,log", "No files to delete\n" );
1123 foreach $file ( @files ) {
1125 msg( "mail,log", "$file: no such file\n" );
1127 elsif ($file =~ /$conf::keep_files/) {
1128 msg( "mail,log", "$file is protected, cannot ".
1131 elsif (!unlink( $file )) {
1132 msg( "mail,log", "$file: rm: $!\n" );
1135 $file =~ s,$conf::incoming/?,,;
1136 push( @removed, $file );
1139 msg( "mail,log", "Files removed: @removed\n" ) if @removed;
1142 elsif ($word[0] eq "reschedule") {
1144 msg( "mail,log", "Wrong number of arguments\n" );
1146 elsif ($conf::upload_method ne "copy") {
1147 msg( "mail,log", "reschedule not available\n" );
1149 elsif ($word[1] =~ m,/, || $word[1] !~ m/\.changes/) {
1150 msg( "mail,log", "$word[1]: filename may not contain slashes and must be .changes\n" );
1152 elsif (! (($target_delay) = $word[2] =~ m,^([0-9]+)-day$,) || $target_delay > $conf::max_delayed) {
1153 msg( "mail,log", "$word[2]: rescheduling target must be #-day with # between 0 and $conf::max_delayed (in particular, no '/' allowed)\n");
1155 elsif ($word[1] =~ /$conf::keep_files/) {
1156 msg( "mail,log", "$word[1] is protected, cannot do stuff with it\n" );
1160 for ( $adelay=0; $adelay <= $conf::max_delayed && ! -f (sprintf( "$conf::targetdir_delayed",$adelay )."/$word[1]"); $adelay++ ) {
1162 if ( $adelay > $conf::max_delayed) {
1163 msg( "mail,log", "$word[1] not found\n" );
1165 elsif ($adelay == $target_delay) {
1166 msg( "mail,log", "$word[1] already is in $word[2]\n" );
1170 my($dir) = sprintf( "$conf::targetdir_delayed",$adelay );
1171 my($target_dir) = sprintf( "$conf::targetdir_delayed",$target_delay );
1172 push (@thesefiles, $word[1]);
1173 push (@thesefiles, get_filelist_from_known_good_changes("$dir/$word[1]"));
1174 for my $afile(@thesefiles) {
1175 if ($afile =~ m/\.changes$/) {
1176 utime undef,undef,("$dir/$afile");
1178 if (! rename "$dir/$afile","$target_dir/$afile") {
1179 msg( "mail,log", "rename: $!\n" );
1182 msg( "mail,log", "$afile moved to $target_delay-day\n" );
1188 elsif ($word[0] eq "cancel") {
1190 msg( "mail,log", "Wrong number of arguments\n" );
1192 elsif ($conf::upload_method ne "copy") {
1193 msg( "mail,log", "cancel not available\n" );
1195 elsif ($word[1] !~ m,^[a-zA-Z0-9.+_:@=%-][~a-zA-Z0-9.+_:@=%-]*\.changes$,) {
1196 msg( "mail,log", "argument to cancel must be one .changes filename without path\n" );
1199 for ( my($adelay)=0; $adelay <= $conf::max_delayed; $adelay++ ) {
1200 my($dir) = sprintf( "$conf::targetdir_delayed",$adelay );
1201 if (-f "$dir/$word[1]") {
1203 push (@files, "$word[1]");
1204 push (@files,get_filelist_from_known_good_changes("$dir/$word[1]"));
1205 foreach $file ( @files ) {
1206 if (!-f "$dir/$file") {
1207 msg( "mail,log", "$dir/$file: no such file\n" );
1209 elsif ("$dir/$file" =~ /$conf::keep_files/) {
1210 msg( "mail,log", "$dir/$file is protected, cannot ".
1213 elsif (!unlink( "$dir/$file" )) {
1214 msg( "mail,log", "$dir/$file: rm: $!\n" );
1217 push( @removed, $file );
1220 msg( "mail,log", "Files removed from $adelay-day: @removed\n" ) if @removed;
1224 msg( "mail,log", "No upload found: $word[1]\n" );
1228 msg( "mail,log", "unknown command $word[0]\n" );
1232 msg( "log", "-- End of $main::current_incoming_short/$commands processing\n" );
1235 sub age_delayed_queues() {
1236 for ( my($adelay)=0 ; $adelay <= $conf::max_delayed ; $adelay++ ) {
1237 my($dir) = sprintf( "$conf::targetdir_delayed",$adelay );
1240 $target_dir = $conf::targetdir;
1243 $target_dir = sprintf( "$conf::targetdir_delayed",$adelay-1 );
1245 for my $achanges (<$dir/*.changes>) {
1246 my $mtime = (stat($achanges))[9];
1247 if ($mtime + 24*60*60 <= time || $adelay==0) {
1248 utime undef,undef,($achanges);
1249 my @thesefiles = ($achanges =~ m,.*/([^/]*),);
1250 push (@thesefiles, get_filelist_from_known_good_changes($achanges));
1251 for my $afile(@thesefiles) {
1252 if (! rename "$dir/$afile","$target_dir/$afile") {
1253 msg( "log", "rename: $!\n" );
1256 msg( "log", "$afile moved to $target_dir\n" );
1265 # check if a file is already on target
1267 sub is_on_target($\@) {
1269 my $filelist = shift;
1273 if ($conf::upload_method eq "ssh") {
1274 ($msg, $stat) = ssh_cmd( "ls -l $file" );
1276 elsif ($conf::upload_method eq "ftp") {
1278 ($msg, $err) = ftp_cmd( "dir", $file );
1285 $msg = "ls: no such file\n";
1289 $msg = join( "\n", @$msg );
1293 my @allfiles = ($file);
1294 push ( @allfiles, @$filelist);
1296 $msg = "no such file";
1297 for my $afile(@allfiles) {
1298 if (-f "$conf::targetdir/$afile") {
1303 for ( my($adelay)=0 ; $adelay <= $conf::max_delayed && $stat ; $adelay++ ) {
1304 for my $afile(@allfiles) {
1305 if (-f (sprintf( "$conf::targetdir_delayed",$adelay )."/$afile")) {
1307 $msg = sprintf( "%d-day",$adelay )."/$afile";
1313 debug( "exit status: $stat, output was: $msg" );
1315 return "" if $stat && $msg =~ /no such file/i; # file not present
1316 msg( "log", "strange ls -l output on target:\n", $msg ), return ""
1317 if $stat || $@; # some other error, but still try to upload
1319 # ls -l returned 0 -> file already there
1320 $msg =~ s/\s\s+/ /g; # make multiple spaces into one, to save space
1325 # copy a list of files to target
1327 sub copy_to_target(@) {
1329 my( @md5sum, @expected_files, $sum, $name, $msgs, $stat );
1332 write_status_file() if $conf::statusdelay;
1335 if ($conf::upload_method eq "ssh") {
1336 ($msgs, $stat) = scp_cmd( @files );
1339 elsif ($conf::upload_method eq "ftp") {
1341 if (!$main::FTP_chan->cwd( $main::current_targetdir )) {
1342 msg( "log,mail", "Can't cd to $main::current_targetdir on $conf::target\n" );
1345 foreach $file (@files) {
1346 ($rv, $msgs) = ftp_cmd( "put", $file );
1351 ($msgs, $stat) = local_cmd( "$conf::cp @files $main::current_targetdir", 'NOCD' );
1355 # check md5sums or sizes on target against our own
1356 my $have_md5sums = 1;
1357 if ($conf::upload_method eq "ssh") {
1358 ($msgs, $stat) = ssh_cmd( "md5sum @files" );
1360 @md5sum = split( "\n", $msgs );
1362 elsif ($conf::upload_method eq "ftp") {
1363 my ($rv, $err, $file);
1364 foreach $file (@files) {
1365 ($rv, $err) = ftp_cmd( "quot", "site", "md5sum", $file );
1367 next if ftp_code() == 550; # file not found
1368 if (ftp_code() == 500) { # unimplemented
1370 goto get_sizes_instead;
1375 chomp( my $t = ftp_response() );
1376 push( @md5sum, $t );
1378 if (!$have_md5sums) {
1380 foreach $file (@files) {
1381 ($rv, $err) = ftp_cmd( "size", $file );
1383 next if ftp_code() == 550; # file not found
1387 push( @md5sum, "$rv $file" );
1392 ($msgs, $stat) = local_cmd( "$conf::md5sum @files" );
1394 @md5sum = split( "\n", $msgs );
1397 @expected_files = @files;
1400 ($sum,$name) = split;
1401 next if !grep { $_ eq $name } @files; # a file we didn't upload??
1402 next if $sum eq "md5sum:"; # looks like an error message
1403 if (($have_md5sums && $sum ne md5sum( $name )) ||
1404 (!$have_md5sums && $sum != (-s $name))) {
1405 msg( "log,mail", "Upload of $name to $conf::target failed ",
1406 "(".($have_md5sums ? "md5sum" : "size")." mismatch)\n" );
1409 # seen that file, remove it from expect list
1410 @expected_files = map { $_ eq $name ? () : $_ } @expected_files;
1412 if (@expected_files) {
1413 msg( "log,mail", "Failed to upload the files\n" );
1414 msg( "log,mail", " ", join( ", ", @expected_files ), "\n" );
1415 msg( "log,mail", "(Not present on target after upload)\n" );
1419 if ($conf::chmod_on_target) {
1420 # change file's mode explicitly to 644 on target
1421 if ($conf::upload_method eq "ssh") {
1422 ($msgs, $stat) = ssh_cmd( "chmod 644 @files" );
1425 elsif ($conf::upload_method eq "ftp") {
1427 foreach $file (@files) {
1428 ($rv, $msgs) = ftp_cmd( "quot", "site", "chmod", "644", $file );
1429 msg( "log", "Can't chmod $file on target:\n$msgs" )
1435 ($msgs, $stat) = local_cmd( "$conf::chmod 644 @files" );
1441 write_status_file() if $conf::statusdelay;
1445 msg( "log,mail", "Upload to $conf::target failed",
1446 $? ? ", last exit status ".sprintf( "%s", $?>>8 ) : "", "\n" );
1447 msg( "log,mail", "Error messages:\n", $msgs )
1450 # If "permission denied" was among the errors, test if the incoming is
1452 if ($msgs =~ /(permission denied|read-?only file)/i) {
1453 if (!check_incoming_writable()) {
1454 msg( "log,mail", "(The incoming directory seems to be ",
1459 # remove bad files or an incomplete upload on target
1460 if ($conf::upload_method eq "ssh") {
1461 ssh_cmd( "rm -f @files" );
1463 elsif ($conf::upload_method eq "ftp") {
1465 foreach $file (@files) {
1467 ($rv, $err) = ftp_cmd( "delete", $file );
1468 msg( "log", "Can't delete $file on target:\n$err" )
1473 my @tfiles = map { "$main::current_targetdir/$_" } @files;
1474 debug( "executing unlink(@tfiles)" );
1478 write_status_file() if $conf::statusdelay;
1483 # check if a file is correctly signed with PGP
1494 if (-x $conf::gpg) {
1495 debug( "executing $conf::gpg --no-options --batch ".
1496 "--no-default-keyring --always-trust ".
1497 "--keyring ". join (" --keyring ",@conf::keyrings).
1498 " --verify '$file'" );
1499 if (!open( PIPE, "$conf::gpg --no-options --batch ".
1500 "--no-default-keyring --always-trust ".
1501 "--keyring " . join (" --keyring ",@conf::keyrings).
1502 " --verify '$file'".
1504 msg( "log", "Can't open pipe to $conf::gpg: $!\n" );
1505 return "LOCAL ERROR";
1507 $output .= $_ while( <PIPE> );
1513 msg( "log,mail", "GnuPG signature check failed on $file\n" );
1514 msg( "mail", $output );
1515 msg( "log,mail", "(Exit status ", $stat >> 8, ")\n" );
1519 $output =~ /^(gpg: )?good signature from (user )?"(.*)"\.?$/im;
1520 ($signator = $3) ||= "unknown signator";
1522 debug( "GnuPG signature ok (by $signator)" );
1528 # ---------------------------------------------------------------------------
1530 # ---------------------------------------------------------------------------
1533 # fork a subprocess that watches the 'status' FIFO
1535 # that process blocks until someone opens the FIFO, then sends a
1536 # signal (SIGUSR1) to the main process, expects
1538 sub fork_statusd() {
1544 $statusd_pid = open( STATUSD, "|-" );
1545 die "cannot fork: $!\n" if !defined( $statusd_pid );
1546 # parent just returns
1548 msg( "log", "forked status daemon (pid $statusd_pid)\n" );
1549 return $statusd_pid;
1551 # child: the status FIFO daemon
1553 # ignore SIGPIPE here, in case some closes the FIFO without completely
1555 $SIG{"PIPE"} = "IGNORE";
1556 # also ignore SIGCLD, we don't want to inherit the restart-statusd handler
1558 $SIG{"CHLD"} = "DEFAULT";
1560 rm( $conf::statusfile );
1561 $errs = `$conf::mkfifo $conf::statusfile`;
1562 die "$main::progname: cannot create named pipe $conf::statusfile: $errs"
1564 chmod( 0644, $conf::statusfile )
1565 or die "Cannot set modes of $conf::statusfile: $!\n";
1567 # close log file, so that log rotating works
1573 my( $status, $mup, $incw, $ds, $next_run, $last_ping, $currch, $l );
1575 # open the FIFO for writing; this blocks until someone (probably ftpd)
1576 # opens it for reading
1577 open( STATFIFO, ">$conf::statusfile" )
1578 or die "Cannot open $conf::statusfile\n";
1580 # tell main daemon to send us status infos
1581 kill( $main::signo{"USR1"}, $main_pid );
1583 # get the infos from stdin; must loop until enough bytes received!
1584 my $expect_len = 3 + 2*STATNUM_LEN + STATSTR_LEN;
1585 for( $status = ""; ($l = length($status)) < $expect_len; ) {
1586 sysread( STDIN, $status, $expect_len-$l, $l );
1589 # disassemble the status byte stream
1591 foreach ( [ mup => 1 ], [ incw => 1 ], [ ds => 1 ],
1592 [ next_run => STATNUM_LEN ], [ last_ping => STATNUM_LEN ],
1593 [ currch => STATSTR_LEN ] ) {
1594 eval "\$$_->[0] = substr( \$status, $pos, $_->[1] );";
1597 $currch =~ s/\n+//g;
1599 print_status( $mup, $incw, $ds, $next_run, $last_ping, $currch );
1602 # This sleep is necessary so that we can't reopen the FIFO
1603 # immediately, in case the reader hasn't closed it yet if we get to
1604 # the open again. Is there a better solution for this??
1610 # update the status file, in case we use a plain file and not a FIFO
1612 sub write_status_file() {
1614 return if !$conf::statusfile;
1616 open( STATFILE, ">$conf::statusfile" ) or
1617 (msg( "log", "Could not open $conf::statusfile: $!\n" ), return);
1618 my $oldsel = select( STATFILE );
1620 print_status( $main::target_up, $main::incoming_writable, $main::dstat,
1621 $main::next_run, $main::last_ping_time,
1622 $main::current_changes );
1628 sub print_status($$$$$$) {
1632 my $next_run = shift;
1633 my $last_ping = shift;
1638 ($version = 'Release: 0.9 $Revision: 1.51 $') =~ s/\$ ?//g;
1639 print "debianqueued $version\n";
1641 $approx = $conf::statusdelay ? "approx. " : "";
1644 print "$conf::target is down, queue pausing\n";
1647 elsif ($conf::upload_method ne "copy") {
1648 print "$conf::target seems to be up, last ping $approx",
1649 print_time(time-$last_ping), " ago\n";
1653 print "The incoming directory is not writable, queue pausing\n";
1658 print "Next queue check in $approx",print_time($next_run-time),"\n";
1661 elsif ($ds eq "c") {
1662 print "Checking queue directory\n";
1664 elsif ($ds eq "u") {
1665 print "Uploading to $conf::target\n";
1668 print "Bad status data from daemon: \"$mup$incw$ds\"\n";
1672 print "Current job is $currch\n" if $currch;
1676 # format a number for sending to statusd (fixed length STATNUM_LEN)
1678 sub format_status_num(\$$) {
1682 $$varref = sprintf "%".STATNUM_LEN."d", $num;
1686 # format a string for sending to statusd (fixed length STATSTR_LEN)
1688 sub format_status_str(\$$) {
1692 $$varref = substr( $str, 0, STATSTR_LEN );
1693 $$varref .= "\n" x (STATSTR_LEN - length($$varref));
1697 # send a status string to the status daemon
1699 # Avoid all operations that could call malloc() here! Most libc
1700 # implementations aren't reentrant, so we may not call it from a
1701 # signal handler. So use only already-defined variables.
1704 local $! = 0; # preserve errno
1706 # re-setup handler, in case we have broken SysV signals
1707 $SIG{"USR1"} = \&send_status;
1709 syswrite( STATUSD, $main::target_up, 1 );
1710 syswrite( STATUSD, $main::incoming_writable, 1 );
1711 syswrite( STATUSD, $main::dstat, 1 );
1712 syswrite( STATUSD, $main::next_run, STATNUM_LEN );
1713 syswrite( STATUSD, $main::last_ping_time, STATNUM_LEN );
1714 syswrite( STATUSD, $main::current_changes, STATSTR_LEN );
1718 # ---------------------------------------------------------------------------
1720 # ---------------------------------------------------------------------------
1723 # open FTP connection to target host if not already open
1727 if ($main::FTP_chan) {
1728 # is already open, but might have timed out; test with a cwd
1729 return $main::FTP_chan if $main::FTP_chan->cwd( $main::current_targetdir );
1730 # cwd didn't work, channel is closed, try to reopen it
1731 $main::FTP_chan = undef;
1734 if (!($main::FTP_chan = Net::FTP->new( $conf::target,
1735 Debug => $conf::ftpdebug,
1736 Timeout => $conf::ftptimeout ))) {
1737 msg( "log,mail", "Cannot open FTP server $conf::target\n" );
1740 if (!$main::FTP_chan->login()) {
1741 msg( "log,mail", "Anonymous login on FTP server $conf::target failed\n" );
1744 if (!$main::FTP_chan->binary()) {
1745 msg( "log,mail", "Can't set binary FTP mode on $conf::target\n" );
1748 if (!$main::FTP_chan->cwd( $main::current_targetdir )) {
1749 msg( "log,mail", "Can't cd to $main::current_targetdir on $conf::target\n" );
1752 debug( "opened FTP channel to $conf::target" );
1756 $main::FTP_chan = undef;
1763 my $direct_resp_cmd = ($cmd eq "quot");
1765 debug( "executing FTP::$cmd(".join(", ",@_).")" );
1766 $SIG{"ALRM"} = sub { die "timeout in FTP::$cmd\n" } ;
1767 alarm( $conf::remote_timeout );
1768 eval { $rv = $main::FTP_chan->$cmd( @_ ); };
1771 $rv = (ftp_code() =~ /^2/) ? 1 : 0 if $direct_resp_cmd;
1777 $err = ftp_response();
1783 if ($main::FTP_chan) {
1784 $main::FTP_chan->quit();
1785 $main::FTP_chan = undef;
1790 sub ftp_response() {
1791 return join( '', @{${*$main::FTP_chan}{'net_cmd_resp'}} );
1795 return ${*$main::FTP_chan}{'net_cmd_code'};
1799 my $code = ftp_code();
1800 return ($code =~ /^[45]/) ? 1 : 0;
1803 # ---------------------------------------------------------------------------
1805 # ---------------------------------------------------------------------------
1811 my $ecmd = "$conf::ssh $conf::ssh_options $conf::target ".
1812 "-l $conf::targetlogin \'cd $main::current_targetdir; $cmd\'";
1813 debug( "executing $ecmd" );
1814 $SIG{"ALRM"} = sub { die "timeout in ssh command\n" } ;
1815 alarm( $conf::remote_timeout );
1816 eval { $msg = `$ecmd 2>&1`; };
1825 return ($msg, $stat);
1831 my $ecmd = "$conf::scp $conf::ssh_options @_ ".
1832 "$conf::targetlogin\@$conf::target:$main::current_targetdir";
1833 debug( "executing $ecmd" );
1834 $SIG{"ALRM"} = sub { die "timeout in scp\n" } ;
1835 alarm( $conf::remote_timeout );
1836 eval { $msg = `$ecmd 2>&1`; };
1845 return ($msg, $stat);
1848 sub local_cmd($;$) {
1853 my $ecmd = ($nocd ? "" : "cd $main::current_targetdir; ") . $cmd;
1854 debug( "executing $ecmd" );
1855 $msg = `($ecmd) 2>&1`;
1857 return ($msg, $stat);
1862 # check if target is alive (code stolen from Net::Ping.pm)
1864 sub check_alive(;$) {
1865 my $timeout = shift;
1866 my( $saddr, $ret, $target_ip );
1869 if ($conf::upload_method eq "copy") {
1870 format_status_num( $main::last_ping_time, time );
1871 $main::target_up = 1;
1877 if (!($target_ip = (gethostbyname($conf::target))[4])) {
1878 msg( "log", "Cannot get IP address of $conf::target\n" );
1882 $saddr = pack( 'S n a4 x8', AF_INET, $main::echo_port, $target_ip );
1883 $SIG{'ALRM'} = sub { die } ;
1886 $ret = $main::tcp_proto; # avoid warnings about unused variable
1889 return unless socket( PINGSOCK, PF_INET, SOCK_STREAM, $main::tcp_proto );
1890 return unless connect( PINGSOCK, $saddr );
1895 msg( "log", "pinging $conf::target: " . ($ret ? "ok" : "down") . "\n" );
1897 $main::target_up = $ret ? "1" : "0";
1898 format_status_num( $main::last_ping_time, time );
1899 write_status_file() if $conf::statusdelay;
1903 # check if incoming dir on target is writable
1905 sub check_incoming_writable() {
1906 my $testfile = ".debianqueued-testfile";
1909 if ($conf::upload_method eq "ssh") {
1910 ($msg, $stat) = ssh_cmd( "rm -f $testfile; touch $testfile; ".
1911 "rm -f $testfile" );
1913 elsif ($conf::upload_method eq "ftp") {
1914 my $file = "junk-for-writable-test-".format_time();
1915 $file =~ s/[ :.]/-/g;
1917 open( F, ">$file" ); close( F );
1919 ($rv, $msg) = ftp_cmd( "put", $file );
1921 $msg = "" if !defined $msg;
1923 ftp_cmd( "delete", $file );
1925 elsif ($conf::upload_method eq "copy") {
1926 ($msg, $stat) = local_cmd( "rm -f $testfile; touch $testfile; ".
1927 "rm -f $testfile" );
1930 debug( "exit status: $stat, output was: $msg" );
1933 # change incoming_writable only if ssh didn't return an error
1934 $main::incoming_writable =
1935 ($msg =~ /(permission denied|read-?only file|cannot create)/i) ? "0":"1";
1938 debug( "local error, keeping old status" );
1940 debug( "incoming_writable = $main::incoming_writable" );
1941 write_status_file() if $conf::statusdelay;
1942 return $main::incoming_writable;
1946 # remove a list of files, log failing ones
1952 (unlink $_ and ++$done)
1953 or $! == ENOENT or msg( "log", "Could not delete $_: $!\n" );
1959 # get md5 checksum of a file
1965 chomp( $line = `$conf::md5sum $file` );
1966 debug( "md5sum($file): ", $? ? "exit status $?" :
1967 $line =~ /^(\S+)/ ? $1 : "match failed" );
1968 return $? ? "" : $line =~ /^(\S+)/ ? $1 : "";
1972 # check if a file probably belongs to a Debian upload
1974 sub is_debian_file($) {
1976 return $file =~ /\.(deb|dsc|(diff|tar)\.gz)$/ &&
1977 $file !~ /\.orig\.tar\.gz/;
1981 # try to extract maintainer email address from some a non-.changes file
1982 # return "" if not possible
1984 sub get_maintainer($) {
1986 my $maintainer = "";
1989 if ($file =~ /\.diff\.gz$/) {
1991 open( F, "$conf::gzip -dc '$file' 2>/dev/null |" ) or return "";
1993 # look for header line of a file */debian/control
1994 last if m,^\+\+\+\s+[^/]+/debian/control(\s+|$),;
1997 last if /^---/; # end of control file patch, no Maintainer: found
1998 # inside control file patch look for Maintainer: field
1999 $maintainer = $1, last if /^\+Maintainer:\s*(.*)$/i;
2001 while( <F> ) { } # read to end of file to avoid broken pipe
2002 close( F ) or return "";
2004 elsif ($file =~ /\.(deb|dsc|tar\.gz)$/) {
2005 if ($file =~ /\.deb$/ && $conf::ar) {
2006 # extract control.tar.gz from .deb with ar, then let tar extract
2007 # the control file itself
2008 open( F, "($conf::ar p '$file' control.tar.gz | ".
2009 "$conf::tar -xOf - ".
2010 "--use-compress-program $conf::gzip ".
2011 "control) 2>/dev/null |" )
2014 elsif ($file =~ /\.dsc$/) {
2015 # just do a plain grep
2016 debug( "get_maint: .dsc, no cmd" );
2017 open( F, "<$file" ) or return "";
2019 elsif ($file =~ /\.tar\.gz$/) {
2020 # let tar extract a file */debian/control
2021 open(F, "$conf::tar -xOf '$file' ".
2022 "--use-compress-program $conf::gzip ".
2023 "\\*/debian/control 2>&1 |")
2030 $maintainer = $1, last if /^Maintainer:\s*(.*)$/i;
2032 close( F ) or return "";
2039 # return a pattern that matches all files that probably belong to one job
2041 sub debian_file_stem($) {
2043 my( $pkg, $version );
2046 $file =~ s,\.(deb|dsc|changes|(orig\.)?tar\.gz|diff\.gz)$,,;
2047 # if not is *_* (name_version), can't derive a stem and return just
2049 return $file if !($file =~ /^([^_]+)_([^_]+)/);
2050 ($pkg, $version) = ($1, $2);
2051 # strip Debian revision from version
2052 $version =~ s/^(.*)-[\d.+-]+$/$1/;
2054 return "${pkg}_${version}*";
2058 # output a messages to several destinations
2060 # first arg is a comma-separated list of destinations; valid are "log"
2061 # and "mail"; rest is stuff to be printed, just as with print
2064 my @dest = split( ',', shift );
2066 if (grep /log/, @dest ) {
2067 my $now = format_time();
2068 print LOG "$now ", @_;
2071 if (grep /mail/, @dest ) {
2072 $main::mail_text .= join( '', @_ );
2077 # print a debug messages, if $debug is true
2080 return if !$conf::debug;
2081 my $now = format_time();
2082 print LOG "$now DEBUG ", @_, "\n";
2086 # intialize the "mail" destination of msg() (this clears text,
2087 # address, subject, ...)
2092 $main::mail_addr = "";
2093 $main::mail_text = "";
2094 %main::packages = ();
2095 $main::mail_subject = $file ? "Processing of $file" : "";
2099 # finalize mail to be sent from msg(): check if something present, and
2104 debug( "No mail for $main::mail_addr" )
2105 if $main::mail_addr && !$main::mail_text;
2106 return unless $main::mail_addr && $main::mail_text;
2108 if (!send_mail($main::mail_addr, $main::mail_subject, $main::mail_text)) {
2109 # store this mail in memory so it isn't lost if executing sendmail
2111 push( @main::stored_mails, { addr => $main::mail_addr,
2112 subject => $main::mail_subject,
2113 text => $main::mail_text } );
2117 # try to send out stored mails
2119 while( $mailref = shift(@main::stored_mails) ) {
2120 if (!send_mail( $mailref->{'addr'}, $mailref->{'subject'},
2121 $mailref->{'text'} )) {
2122 unshift( @main::stored_mails, $mailref );
2131 sub send_mail($$$) {
2133 my $subject = shift;
2136 my $package = keys %main::packages ? join(' ', keys %main::packages) : "";
2140 unless (defined($Email::Send::Sendmail::SENDMAIL)) {
2141 $Email::Send::Sendmail::SENDMAIL = $conf::mail;
2144 my $date = sprintf "%s", strftime("%a, %d %b %Y %T %z", (localtime(time)));
2145 my $message = <<__MESSAGE__;
2147 From: Archive Administrator <dak\@ftp-master.debian.org>
2153 if (length $package) {
2154 $message .= "X-Debian-Package: $package\n";
2157 $message .= "\n$text";
2158 $message .= "\nGreetings,\n\n\tYour Debian queue daemon\n";
2160 my $mail = Email::Send->new;
2161 for ( qw[Sendmail SMTP] ) {
2162 $mail->mailer($_) and last if $mail->mailer_available($_);
2165 my $ret = $mail->send($message);
2166 if ($ret && $ret !~ /Message sent|success/) {
2174 # try to find a mail address for a name in the keyrings
2176 sub try_to_get_mail_addr($$) {
2178 my $listref = shift;
2181 open( F, "$conf::gpg --no-options --batch --no-default-keyring ".
2182 "--always-trust --keyring ".
2183 join (" --keyring ",@conf::keyrings).
2187 if (/^pub / && / $name /) {
2189 push( @$listref, $1 );
2194 return (@$listref >= 1) ? $listref->[0] : "";
2198 # return current time as string
2203 # omit weekday and year for brevity
2204 ($t = localtime) =~ /^\w+\s(.*)\s\d+$/;
2210 my $hours = int($secs/(60*60));
2212 $secs -= $hours*60*60;
2213 return sprintf "%d:%02d:%02d", $hours, int($secs/60), $secs % 60;
2217 # block some signals during queue processing
2219 # This is just to avoid data inconsistency or uploads being aborted in the
2220 # middle. Only "soft" signals are blocked, i.e. SIGINT and SIGTERM, try harder
2221 # ones if you really want to kill the daemon at once.
2223 sub block_signals() {
2224 POSIX::sigprocmask( SIG_BLOCK, $main::block_sigset );
2227 sub unblock_signals() {
2228 POSIX::sigprocmask( SIG_UNBLOCK, $main::block_sigset );
2232 # process SIGHUP: close log file and reopen it (for logfile cycling)
2239 open( LOG, ">>$conf::logfile" )
2240 or die "Cannot open my logfile $conf::logfile: $!\n";
2241 chmod( 0644, $conf::logfile )
2242 or msg( "log", "Cannot set modes of $conf::logfile: $!\n" );
2243 select( (select(LOG), $| = 1)[0] );
2245 open( STDOUT, ">&LOG" )
2246 or msg( "log", "$main::progname: Can't redirect stdout to ".
2247 "$conf::logfile: $!\n" );
2248 open( STDERR, ">&LOG" )
2249 or msg( "log", "$main::progname: Can't redirect stderr to ".
2250 "$conf::logfile: $!\n" );
2251 msg( "log", "Restart after SIGHUP\n" );
2255 # process SIGCHLD: check if it was our statusd process
2260 # reap statusd, so that it's no zombie when we try to kill(0) it
2261 waitpid( $main::statusd_pid, WNOHANG );
2263 # Uncomment the following line if your Perl uses unreliable System V signal
2264 # (i.e. if handlers reset to default if the signal is delivered).
2265 # (Unfortunately, the re-setup can't be done in any case, since on some
2266 # systems this will cause the SIGCHLD to be delivered again if there are
2267 # still unreaped children :-(( )
2269 # $SIG{"CHLD"} = \&kid_died; # resetup handler for SysV
2272 sub restart_statusd() {
2273 # restart statusd if it died
2274 if (!kill( 0, $main::statusd_pid)) {
2275 close( STATUSD ); # close out pipe end
2276 $main::statusd_pid = fork_statusd();
2281 # process a fatal signal: cleanup and exit
2283 sub fatal_signal($) {
2284 my $signame = shift;
2287 # avoid recursions of fatal_signal in case of BSD signals
2288 foreach $sig ( qw( ILL ABRT BUS FPE SEGV PIPE ) ) {
2289 $SIG{$sig} = "DEFAULT";
2292 if ($$ == $main::maind_pid) {
2293 # only the main daemon should do this
2294 kill( $main::signo{"TERM"}, $main::statusd_pid )
2295 if defined $main::statusd_pid;
2296 unlink( $conf::statusfile, $conf::pidfile );
2298 msg( "log", "Caught SIG$signame -- exiting (pid $$)\n" );