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!
20 use POSIX qw( strftime sys_stat_h sys_wait_h signal_h );
23 use Socket qw( PF_INET AF_INET SOCK_STREAM );
29 setlocale(&POSIX::LC_ALL, "C");
32 # ---------------------------------------------------------------------------
34 # ---------------------------------------------------------------------------
37 ( $conf::queued_dir = ( ( $0 !~ m,^/, ) ? POSIX::getcwd() . "/" : "" ) . $0 )
39 require "$conf::queued_dir/config";
40 my $junk = $conf::debug; # avoid spurious warnings about unused vars
41 $junk = $conf::ssh_key_file;
42 $junk = $conf::stray_remove_timeout;
43 $junk = $conf::problem_report_timeout;
44 $junk = $conf::queue_delay;
45 $junk = $conf::keep_files;
46 $junk = $conf::valid_files;
47 $junk = $conf::max_upload_retries;
48 $junk = $conf::upload_delay_1;
49 $junk = $conf::upload_delay_2;
50 $junk = $conf::check_md5sum;
53 $junk = $conf::ftpdebug;
54 $junk = $conf::ftptimeout;
55 $junk = @conf::nonus_packages;
56 $junk = @conf::test_binaries;
57 $junk = @conf::maintainer_mail;
58 $junk = @conf::targetdir_delayed;
59 $junk = $conf::mail ||= '/usr/sbin/sendmail';
60 $junk = $conf::overridemail;
61 $conf::target = "localhost" if $conf::upload_method eq "copy";
65 ( $main::progname = $0 ) =~ s,.*/,,;
67 ($main::hostname, undef, undef, undef, undef) = gethostbyname(hostname());
70 my $re_file_safe_prefix = qr/\A([a-zA-Z0-9.][a-zA-Z0-9_.:~+-]*)/s;
71 my $re_file_safe = qr/$re_file_safe_prefix\z/s;
73 # extract -r and -k args
75 if ( @ARGV == 1 && $ARGV[0] =~ /^-[rk]$/ ) {
76 $main::arg = ( $ARGV[0] eq '-k' ) ? "kill" : "restart";
80 # test for another instance of the queued already running
81 my ( $pid, $delayed_dirs, $adelayedcore );
82 if ( open( PIDFILE, "<", $conf::pidfile ) ) {
83 chomp( $pid = <PIDFILE> );
87 # remove stale pid file
88 unlink($conf::pidfile);
89 } elsif ($main::arg) {
91 print "Killing running daemon (pid $pid) ...";
94 while ( kill( 0, $pid ) && $cnt-- > 0 ) {
98 if ( kill( 0, $pid ) ) {
99 print " failed!\nProcess $pid still running.\n";
103 if ( -e "$conf::incoming/core" ) {
104 unlink("$conf::incoming/core");
105 print "(Removed core file)\n";
107 for ( $delayed_dirs = 0 ;
108 $delayed_dirs <= $conf::max_delayed ;
112 sprintf( "$conf::incoming_delayed/core", $delayed_dirs );
113 if ( -e $adelayedcore ) {
114 unlink($adelayedcore);
115 print "(Removed core file)\n";
117 } ## end for ( $delayed_dirs = 0...
118 exit 0 if $main::arg eq "kill";
120 die "Another $main::progname is already running (pid $pid)\n"
121 if $pid && kill( 0, $pid );
123 } elsif ( $main::arg eq "kill" ) {
124 die "No daemon running\n";
125 } elsif ( $main::arg eq "restart" ) {
126 print "(No daemon running; starting anyway)\n";
129 # if started without arguments (initial invocation), then fork
132 # now go to background
133 die "$main::progname: fork failed: $!\n"
134 unless defined( $pid = fork );
137 # parent: wait for signal from child (SIGCHLD or SIGUSR1) and exit
138 my $sigset = POSIX::SigSet->new();
140 $SIG{"CHLD"} = sub { };
141 $SIG{"USR1"} = sub { };
142 POSIX::sigsuspend($sigset);
143 waitpid( $pid, WNOHANG );
144 if ( kill( 0, $pid ) ) {
145 print "Daemon (on $main::hostname) started in background (pid $pid)\n";
154 if ( $conf::upload_method eq "ssh" ) {
156 # exec an ssh-agent that starts us again
157 # force shell to be /bin/sh, ssh-agent may base its decision
158 # whether to use a fd or a Unix socket on the shell...
159 $ENV{"SHELL"} = "/bin/sh";
160 exec $conf::ssh_agent, $0, "startup", getppid();
161 die "$main::progname: Could not exec $conf::ssh_agent: $!\n";
164 # no need to exec, just set up @ARGV as expected below
165 @ARGV = ( "startup", getppid() );
167 } ## end else [ if ($pid)
168 } ## end if ( !@ARGV )
169 die "Please start without any arguments.\n"
170 if @ARGV != 2 || $ARGV[0] ne "startup";
171 my $parent_pid = $ARGV[1];
175 ( $version = 'Release: 0.95' ) =~ s/\$ ?//g;
176 print "debianqueued $version\n";
179 # check if all programs exist
181 foreach $prg ( $conf::gpg, $conf::ssh, $conf::scp, $conf::ssh_agent,
182 $conf::ssh_add, $conf::mail, $conf::mkfifo )
184 die "Required program $prg doesn't exist or isn't executable\n"
187 # check for correct upload method
188 die "Bad upload method '$conf::upload_method'.\n"
189 if $conf::upload_method ne "ssh"
190 && $conf::upload_method ne "ftp"
191 && $conf::upload_method ne "copy";
192 die "No keyrings\n" if !@conf::keyrings;
194 } ## end foreach $prg ( $conf::gpg, ...
195 die "statusfile path must be absolute."
196 if $conf::statusfile !~ m,^/,;
197 die "upload and target queue paths must be absolute."
198 if $conf::incoming !~ m,^/,
199 || $conf::incoming_delayed !~ m,^/,
200 || $conf::targetdir !~ m,^/,
201 || $conf::targetdir_delayed !~ m,^/,;
203 # ---------------------------------------------------------------------------
205 # ---------------------------------------------------------------------------
210 sub get_filelist_from_known_good_changes($);
211 sub age_delayed_queues();
212 sub process_changes($\@);
213 sub process_commands($);
214 sub age_delayed_queues();
215 sub is_on_target($\@);
216 sub copy_to_target(@);
219 sub check_incoming_writable();
221 sub write_status_file();
222 sub print_status($$$$$$);
223 sub format_status_num(\$$);
224 sub format_status_str(\$$);
235 sub check_incoming_writable();
243 sub try_to_get_mail_addr($$);
247 sub unblock_signals();
250 sub restart_statusd();
253 $ENV{"PATH"} = "/bin:/usr/bin";
254 $ENV{"IFS"} = "" if defined( $ENV{"IFS"} && $ENV{"IFS"} ne "" );
267 sub ST_CTIME() { 10 }
269 # fixed lengths of data items passed over status pipe
270 sub STATNUM_LEN() { 30 }
271 sub STATSTR_LEN() { 128 }
273 # init list of signals
274 defined $Config{sig_name}
275 or die "$main::progname: No signal list defined!\n";
278 foreach $name ( split( ' ', $Config{sig_name} ) ) {
279 $main::signo{$name} = $i++;
282 @main::fatal_signals = qw( INT QUIT ILL TRAP ABRT BUS FPE USR2 SEGV PIPE
283 TERM XCPU XFSZ PWR );
285 $main::block_sigset = POSIX::SigSet->new;
286 $main::block_sigset->addset( $main::signo{"INT"} );
287 $main::block_sigset->addset( $main::signo{"TERM"} );
289 # some constant net stuff
290 $main::tcp_proto = ( getprotobyname('tcp') )[2]
291 or die "Cannot get protocol number for 'tcp'\n";
292 my $used_service = ( $conf::upload_method eq "ssh" ) ? "ssh" : "ftp";
293 $main::echo_port = ( getservbyname( $used_service, 'tcp' ) )[2]
294 or die "Cannot get port number for service '$used_service'\n";
296 # clear queue of stored mails
297 @main::stored_mails = ();
299 # run ssh-add to bring the key into the agent (will use stdin/stdout)
300 if ( $conf::upload_method eq "ssh" ) {
301 system "$conf::ssh_add $conf::ssh_key_file"
302 and die "$main::progname: Running $conf::ssh_add failed "
303 . "(exit status ", $? >> 8, ")\n";
306 # change to queue dir
307 chdir($conf::incoming)
308 or die "$main::progname: cannot cd to $conf::incoming: $!\n";
310 # needed before /dev/null redirects, some system send a SIGHUP when loosing
311 # the controlling tty
312 $SIG{"HUP"} = "IGNORE";
314 # open logfile, make it unbuffered
315 open( LOG, ">>", $conf::logfile )
316 or die "Cannot open my logfile $conf::logfile: $!\n";
317 chmod( 0644, $conf::logfile )
318 or die "Cannot set modes of $conf::logfile: $!\n";
319 select( ( select(LOG), $| = 1 )[0] );
322 $SIG{"HUP"} = \&close_log;
324 # redirect stdin, ... to /dev/null
325 open( STDIN, "<", "/dev/null" )
326 or die "$main::progname: Can't redirect stdin to /dev/null: $!\n";
327 open( STDOUT, ">&", \*LOG )
328 or die "$main::progname: Can't redirect stdout to $conf::logfile: $!\n";
329 open( STDERR, ">&", \*LOG )
330 or die "$main::progname: Can't redirect stderr to $conf::logfile: $!\n";
332 # ok, from this point usually no "die" anymore, stderr is gone!
333 msg( "log", "daemon (pid $$) (on $main::hostname) started\n" );
335 # initialize variables used by send_status before launching the status daemon
337 format_status_num( $main::next_run, time + 10 );
338 format_status_str( $main::current_changes, "" );
340 $main::incoming_writable = 1; # assume this for now
342 # start the daemon watching the 'status' FIFO
343 if ( $conf::statusfile && $conf::statusdelay == 0 ) {
344 $main::statusd_pid = fork_statusd();
345 $SIG{"CHLD"} = \&kid_died; # watch out for dead status daemon
346 # SIGUSR1 triggers status info
347 $SIG{"USR1"} = \&send_status;
348 } ## end if ( $conf::statusfile...
349 $main::maind_pid = $$;
352 kill( $main::signo{"ABRT"}, $$ )
353 if defined $main::signo{"ABRT"};
357 open( PIDFILE, ">", $conf::pidfile )
358 or msg( "log", "Can't open $conf::pidfile: $!\n" );
359 printf PIDFILE "%5d\n", $$;
361 chmod( 0644, $conf::pidfile )
362 or die "Cannot set modes of $conf::pidfile: $!\n";
364 # other signals will just log an error and exit
365 foreach (@main::fatal_signals) {
366 $SIG{$_} = \&fatal_signal;
369 # send signal to user-started process that we're ready and it can exit
370 kill( $main::signo{"USR1"}, $parent_pid );
372 # ---------------------------------------------------------------------------
374 # ---------------------------------------------------------------------------
376 # default to classical incoming/target
377 $main::current_incoming = $conf::incoming;
378 $main::current_targetdir = $conf::targetdir;
381 write_status_file() if $conf::statusdelay;
384 # ping target only if there is the possibility that we'll contact it (but
385 # also don't wait too long).
386 my @have_changes = <*.changes *.commands *.dak-commands>;
387 for ( my $delayed_dirs = 0 ;
388 $delayed_dirs <= $conf::max_delayed ;
391 my $adelayeddir = sprintf( "$conf::incoming_delayed", $delayed_dirs );
392 push( @have_changes, <$adelayeddir/*.changes> );
393 } ## end for ( my $delayed_dirs ...
395 if @have_changes || ( time - $main::last_ping_time ) > 8 * 60 * 60;
397 if ( @have_changes && $main::target_up ) {
398 check_incoming_writable if !$main::incoming_writable;
399 check_dir() if $main::incoming_writable;
402 write_status_file() if $conf::statusdelay;
404 if ( $conf::upload_method eq "copy" ) {
405 age_delayed_queues();
408 # sleep() returns if we received a signal (SIGUSR1 for status FIFO), so
409 # calculate the end time once and wait for it being reached.
410 format_status_num( $main::next_run, time + $conf::queue_delay );
412 while ( ( $delta = calc_delta() ) > 0 ) {
413 debug("mainloop sleeping $delta secs");
416 # check if statusd died, if using status FIFO, or update status file
417 if ($conf::statusdelay) {
422 } ## end while ( ( $delta = calc_delta...
428 $delta = $main::next_run - time;
429 $delta = $conf::statusdelay
430 if $conf::statusdelay && $conf::statusdelay < $delta;
432 } ## end sub calc_delta()
434 # ---------------------------------------------------------------------------
435 # main working functions
436 # ---------------------------------------------------------------------------
439 # main function for checking the incoming dir
442 my ( @files, @changes, @keep_files, @this_keep_files, @stats, $file,
445 debug("starting checkdir");
447 write_status_file() if $conf::statusdelay;
449 # test if needed binaries are available; this is if they're on maybe
450 # slow-mounted NFS filesystems
451 foreach (@conf::test_binaries) {
454 # maybe the mount succeeds now
457 msg( "log", "binary test failed for $_; delaying queue run\n" );
459 } ## end foreach (@conf::test_binaries)
461 for ( $adelay = -1 ; $adelay <= $conf::max_delayed ; $adelay++ ) {
462 if ( $adelay == -1 ) {
463 $main::current_incoming = $conf::incoming;
464 $main::current_incoming_short = "";
465 $main::current_targetdir = $conf::targetdir;
467 $main::current_incoming = sprintf( $conf::incoming_delayed, $adelay );
468 $main::current_incoming_short = sprintf( "DELAYED/%d-day", $adelay );
469 $main::current_targetdir = sprintf( $conf::targetdir_delayed, $adelay );
472 # need to clear directory specific variables
474 undef(@this_keep_files);
476 chdir($main::current_incoming)
480 "Cannot change to dir "
481 . "${main::current_incoming_short}: $!\n"
486 # look for *.commands and *.dak-commands files but not in delayed queues
487 if ( $adelay == -1 ) {
488 foreach $file (<*.commands>) {
489 next unless $file =~ /$re_file_safe/;
492 process_commands($file);
495 write_status_file() if $conf::statusdelay;
497 } ## end foreach $file (<*.commands>)
498 foreach $file (<*.dak-commands>) {
499 next unless $file =~ /$re_file_safe/;
502 process_dak_commands($file);
505 write_status_file() if $conf::statusdelay;
508 } ## end if ( $adelay == -1 )
512 "log", "Cannot open dir ${main::current_incoming_short}: $!\n"
516 @files = readdir(INC);
519 # process all .changes files found
520 @changes = grep /\.changes$/, @files;
521 push( @keep_files, @changes ); # .changes files aren't stray
522 foreach $file (@changes) {
523 next unless $file =~ /$re_file_safe/;
526 # wrap in an eval to allow jumpbacks to here with die in case
529 eval { process_changes( $file, @this_keep_files ); };
531 msg( "log,mail", $@ ) if $@;
533 write_status_file() if $conf::statusdelay;
535 # files which are ok in conjunction with this .changes
536 debug("$file tells to keep @this_keep_files");
537 push( @keep_files, @this_keep_files );
540 # break out of this loop if the incoming dir has become unwritable
541 goto end_run if !$main::incoming_writable;
542 } ## end foreach $file (@changes)
543 ftp_close() if $conf::upload_method eq "ftp";
545 # find files which aren't related to any .changes
546 foreach $file (@files) {
548 # filter out files we never want to delete
549 next if !-f $file || # may have disappeared in the meantime
552 || ( grep { $_ eq $file } @keep_files )
553 || $file =~ /$conf::keep_files/;
555 # Delete such files if they're older than
556 # $stray_remove_timeout; they could be part of an
557 # yet-incomplete upload, with the .changes still missing.
558 # Cannot send any notification, since owner unknown.
559 next if !( @stats = stat($file) );
560 my $age = time - $stats[ST_MTIME];
561 my ( $maint, $pattern, @job_files );
562 if ( $file =~ /^junk-for-writable-test/
563 || $file !~ m,$conf::valid_files,
564 || $file !~ /$re_file_safe/
565 || $age >= $conf::stray_remove_timeout )
568 "Deleted stray file ${main::current_incoming_short}/$file\n" )
572 "found stray file ${main::current_incoming_short}/$file, deleting in ",
573 print_time( $conf::stray_remove_timeout - $age )
575 } ## end else [ if ( $file =~ /^junk-for-writable-test/...
576 } ## end foreach $file (@files)
577 } ## end for ( $adelay = -1 ; $adelay...
578 chdir($conf::incoming);
582 write_status_file() if $conf::statusdelay;
583 } ## end sub check_dir()
585 sub get_filelist_from_known_good_changes($) {
591 # parse the .changes file
592 open( CHANGES, "<", $changes )
593 or die "$changes: $!\n";
594 outer_loop: while (<CHANGES>) {
597 redo outer_loop if !/^\s/;
598 my @field = split(/\s+/);
601 # forbid shell meta chars in the name, we pass it to a
602 # subshell several times...
603 $field[5] =~ /$re_file_safe/;
604 if ( $1 ne $field[5] ) {
605 msg( "log", "found suspicious filename $field[5]\n" );
608 push( @filenames, $field[5] );
609 } ## end while (<CHANGES>)
610 } ## end if (/^Files:/i)
611 } ## end while (<CHANGES>)
614 } ## end sub get_filelist_from_known_good_changes($)
617 # process one .changes file
619 sub process_changes($\@) {
621 my $keep_list = shift;
623 $pgplines, @files, @filenames, @changes_stats,
624 $failure_file, $retries, $last_retry, $upload_time,
625 $file, $do_report, $ls_l,
626 $errs, $pkgname, $signator, $extralines
631 format_status_str( $main::current_changes,
632 "$main::current_incoming_short/$changes" );
634 $main::mail_addr = "";
635 write_status_file() if $conf::statusdelay;
638 msg( "log", "processing ${main::current_incoming_short}/$changes\n" );
640 # run PGP on the file to check the signature
641 if ( !( $signator = pgp_check($changes) ) ) {
644 "$main::current_incoming_short/$changes has bad PGP/GnuPG signature!\n"
646 goto remove_only_changes;
647 } elsif ( $signator eq "LOCAL ERROR" ) {
649 # An error has appened when starting pgp... Don't process the file,
650 # but also don't delete it
652 "Can't PGP/GnuPG check $main::current_incoming_short/$changes -- don't process it for now"
655 } ## end elsif ( $signator eq "LOCAL ERROR")
657 # parse the .changes file
658 open( CHANGES, "<", $changes )
659 or die "Cannot open ${main::current_incoming_short}/$changes: $!\n";
663 outer_loop: while (<CHANGES>) {
664 if (/^---+(BEGIN|END) PGP .*---+$/) {
668 if ( $pgplines < 1 or $pgplines >= 3 ) {
669 $extralines++ if length $_ > 1;
672 if (/^Maintainer:\s*/i) {
673 chomp( $main::mail_addr = $' );
674 $main::mail_addr = $1 if $main::mail_addr =~ /<([^>]*)>/;
675 } elsif (/^Source:\s*/i) {
676 chomp( $pkgname = $' );
677 $pkgname =~ s/\s+$//;
678 $main::packages{$pkgname}++;
679 } elsif (/^Files:/i) {
681 redo outer_loop if !/^\s/;
682 my @field = split(/\s+/);
685 # forbid shell meta chars in the name, we pass it to a
686 # subshell several times...
687 $field[5] =~ /$re_file_safe/;
688 if ( $1 ne $field[5] ) {
689 msg( "log", "found suspicious filename $field[5]\n" );
692 "File '$field[5]' mentioned in $main::current_incoming_short/$changes\n",
693 "has bad characters in its name. Removed.\n"
697 } ## end if ( $1 ne $field[5] )
706 push( @filenames, $field[5] );
707 debug( "includes file $field[5], size $field[2], ", "md5 $field[1]" );
708 } ## end while (<CHANGES>)
709 } ## end elsif (/^Files:/i)
710 } ## end while (<CHANGES>)
713 # tell check_dir that the files mentioned in this .changes aren't stray,
714 # we know about them somehow
715 @$keep_list = @filenames;
717 # some consistency checks
720 "$main::current_incoming_short/$changes contained lines outside the pgp signed "
721 ."part, cannot process\n" );
722 goto remove_only_changes;
723 } ## end if ( $extralines )
724 if ( !$main::mail_addr ) {
726 "$main::current_incoming_short/$changes doesn't contain a Maintainer: field; "
727 . "cannot process\n" );
728 goto remove_only_changes;
729 } ## end if ( !$main::mail_addr)
730 if ( $main::mail_addr !~ /^(buildd_\S+-\S+|\S+\@\S+\.\S+)/ ) {
732 # doesn't look like a mail address, maybe only the name
733 my ( $new_addr, @addr_list );
734 if ( $new_addr = try_to_get_mail_addr( $main::mail_addr, \@addr_list ) ) {
736 # substitute (unique) found addr, but give a warning
739 "(The Maintainer: field didn't contain a proper "
744 "Looking for `$main::mail_addr' in the Debian "
745 . "keyring gave your address\n"
747 msg( "mail", "as unique result, so I used this.)\n" );
749 "Substituted $new_addr for malformed " . "$main::mail_addr\n" );
750 $main::mail_addr = $new_addr;
753 # not found or not unique: hold the job and inform queue maintainer
754 my $old_addr = $main::mail_addr;
755 $main::mail_addr = $conf::maintainer_mail;
758 "The job ${main::current_incoming_short}/$changes doesn't have a correct email\n"
760 msg( "mail", "address in the Maintainer: field:\n" );
761 msg( "mail", " $old_addr\n" );
762 msg( "mail", "A check for this in the Debian keyring gave:\n" );
765 ? " " . join( ", ", @addr_list ) . "\n"
767 msg( "mail", "Please fix this manually\n" );
770 "Bad Maintainer: field in ${main::current_incoming_short}/$changes: $old_addr\n"
772 goto remove_only_changes;
773 } ## end else [ if ( $new_addr = try_to_get_mail_addr...
774 } ## end if ( $main::mail_addr ...
775 if ( $pgplines < 3 ) {
778 "$main::current_incoming_short/$changes isn't signed with PGP/GnuPG\n"
780 msg( "log", "(uploader $main::mail_addr)\n" );
781 goto remove_only_changes;
782 } ## end if ( $pgplines < 3 )
785 "$main::current_incoming_short/$changes doesn't mention any files\n" );
786 msg( "log", "(uploader $main::mail_addr)\n" );
787 goto remove_only_changes;
788 } ## end if ( !@files )
790 # check for packages that shouldn't be processed
791 if ( grep( $_ eq $pkgname, @conf::nonus_packages ) ) {
794 "$pkgname is a package that must be uploaded "
795 . "to nonus.debian.org\n"
797 msg( "log,mail", "instead of target.\n" );
799 "Job rejected and removed all files belonging " . "to it:\n" );
800 msg( "log,mail", " ", join( ", ", @filenames ), "\n" );
801 rm( $changes, @filenames );
803 } ## end if ( grep( $_ eq $pkgname...
805 $failure_file = $changes . ".failures";
806 $retries = $last_retry = 0;
807 if ( -f $failure_file ) {
808 open( FAILS, "<", $failure_file )
809 or die "Cannot open $main::current_incoming_short/$failure_file: $!\n";
812 ( $retries, $last_retry ) = ( $1, $2 )
813 if $line =~ /^(\d+)\s+(\d+)$/;
814 push( @$keep_list, $failure_file );
815 } ## end if ( -f $failure_file )
817 die "Cannot stat ${main::current_incoming_short}/$changes (??): $!\n"
818 if !( @changes_stats = stat($changes) );
820 # Make $upload_time the maximum of all modification times of files
821 # related to this .changes (and the .changes it self). This is the
822 # last time something changes to these files.
823 $upload_time = $changes_stats[ST_MTIME];
826 next if !( @stats = stat( $file->{"name"} ) );
827 $file->{"stats"} = \@stats;
828 $upload_time = $stats[ST_MTIME] if $stats[ST_MTIME] > $upload_time;
829 } ## end for $file (@files)
831 $do_report = ( time - $upload_time ) > $conf::problem_report_timeout;
833 # now check all files for correct size and md5 sum
835 my $filename = $file->{"name"};
836 if ( !defined( $file->{"stats"} ) ) {
838 # could be an upload that isn't complete yet, be quiet,
839 # but don't process the file;
840 msg( "log", "$filename doesn't exist (ignored for now)\n" );
842 } elsif ( $file->{"stats"}->[ST_SIZE] < $file->{"size"}
846 # could be an upload that isn't complete yet, be quiet,
847 # but don't process the file
848 msg( "log", "$filename is too small (ignored for now)\n" );
850 } elsif ( $file->{"stats"}->[ST_SIZE] != $file->{"size"} ) {
851 msg( "log,mail", "$filename has incorrect size; deleting it\n" );
854 } elsif ( md5sum($filename) ne $file->{"md5"} ) {
856 "$filename has incorrect md5 checksum; ",
860 } ## end elsif ( md5sum($filename)...
861 } ## end for $file (@files)
864 if ( ( time - $upload_time ) > $conf::bad_changes_timeout ) {
866 # if a .changes fails for a really long time (several days
867 # or so), remove it and all associated files
870 "$main::current_incoming_short/$changes couldn't be processed for ",
871 int( $conf::bad_changes_timeout / ( 60 * 60 ) ),
872 " hours and is now deleted\n"
874 msg( "log,mail", "All files it mentions are also removed:\n" );
875 msg( "log,mail", " ", join( ", ", @filenames ), "\n" );
876 rm( $changes, @filenames, $failure_file );
884 # if this upload already failed earlier, wait until the delay requirement
887 && ( time - $last_retry ) <
888 ( $retries == 1 ? $conf::upload_delay_1 : $conf::upload_delay_2 ) )
890 msg( "log", "delaying retry of upload\n" );
892 } ## end if ( $retries > 0 && (...
894 return if !ftp_open();
896 # check if the job is already present on target
897 # (moved to here, to avoid bothering target as long as there are errors in
899 if ( $ls_l = is_on_target( $changes, @filenames ) ) {
902 "$main::current_incoming_short/$changes is already present on target host:\n"
904 msg( "log,mail", "$ls_l\n" );
906 "Either you already uploaded it, or someone else ",
908 msg( "log,mail", "Job $changes removed.\n" );
909 rm( $changes, @filenames, $failure_file );
911 } ## end if ( $ls_l = is_on_target...
913 # clear sgid bit before upload, scp would copy it to target. We don't need
914 # it anymore, we know there are no problems if we come here. Also change
915 # mode of files to 644 if this should be done locally.
916 $changes_stats[ST_MODE] &= ~S_ISGID;
917 if ( !$conf::chmod_on_target ) {
918 $changes_stats[ST_MODE] &= ~0777;
919 $changes_stats[ST_MODE] |= 0644;
921 chmod +( $changes_stats[ST_MODE] ), $changes;
923 # try uploading to target
924 if ( !copy_to_target( $changes, @filenames ) ) {
926 # if the upload failed, increment the retry counter and remember the
927 # current time; both things are written to the .failures file. Don't
928 # increment the fail counter if the error was due to incoming
930 return if !$main::incoming_writable;
931 if ( ++$retries >= $conf::max_upload_retries ) {
933 "$changes couldn't be uploaded for $retries times now.\n" );
935 "Giving up and removing it and its associated files:\n" );
936 msg( "log,mail", " ", join( ", ", @filenames ), "\n" );
937 rm( $changes, @filenames, $failure_file );
940 if ( open( FAILS, ">", $failure_file ) ) {
941 print FAILS "$retries $last_retry\n";
943 chmod( 0600, $failure_file )
944 or die "Cannot set modes of $failure_file: $!\n";
945 } ## end if ( open( FAILS, ">$failure_file"...
946 push( @$keep_list, $failure_file );
947 debug("now $retries failed uploads");
950 "The upload will be retried in ",
953 ? $conf::upload_delay_1
954 : $conf::upload_delay_2
958 } ## end else [ if ( ++$retries >= $conf::max_upload_retries)
960 } ## end if ( !copy_to_target( ...
962 # If the files were uploaded ok, remove them
963 rm( $changes, @filenames, $failure_file );
965 msg( "mail", "$changes uploaded successfully to $conf::target\n" );
966 msg( "mail", "along with the files:\n ", join( "\n ", @filenames ),
969 "$changes processed successfully (uploader $main::mail_addr)\n" );
976 "Removing $main::current_incoming_short/$changes, but keeping its "
977 . "associated files for now.\n"
982 # Check for files that have the same stem as the .changes (and weren't
983 # mentioned there) and delete them. It happens often enough that people
984 # upload a .orig.tar.gz where it isn't needed and also not in the
985 # .changes. Explicitly deleting it (and not waiting for the
986 # $stray_remove_timeout) reduces clutter in the queue dir and maybe also
987 # educates uploaders :-)
989 # my $pattern = debian_file_stem( $changes );
990 # my $spattern = substr( $pattern, 0, -1 ); # strip off '*' at end
991 # my @other_files = glob($pattern);
992 # filter out files that have a Debian revision at all and a different
993 # revision. Those belong to a different upload.
994 # if ($changes =~ /^\Q$spattern\E-([\d.+-]+)/) {
996 # @other_files = grep( !/^\Q$spattern\E-([\d.+-]+)/ || $1 eq $this_rev,
999 # Also do not remove those files if a .changes is among them. Then there
1000 # is probably a second upload for another version or another architecture.
1001 # if (@other_files && !grep( /\.changes$/, @other_files )) {
1002 # rm( @other_files );
1003 # msg( "mail", "\nThe following file(s) seemed to belong to the same ".
1004 # "upload, but weren't listed\n" );
1005 # msg( "mail", "in the .changes file:\n " );
1006 # msg( "mail", join( "\n ", @other_files ), "\n" );
1007 # msg( "mail", "They have been deleted.\n" );
1008 # msg( "log", "Deleted files in upload not in $changes: @other_files\n" );
1010 } ## end sub process_changes($\@)
1013 # process one .dak-commands file
1015 sub process_dak_commands {
1016 my $commands = shift;
1018 msg("log", "processing ${main::current_incoming_short}/$commands\n");
1020 # TODO: get mail address from signed contents
1021 # and NOT implement a third parser for armored PGP...
1022 $main::mail_addr = undef;
1025 my $signator = pgp_check($commands);
1028 "$main::current_incoming_short/$commands has bad PGP/GnuPG signature!\n");
1030 "Removing $main::current_incoming_short/$commands\n");
1034 elsif ($signator eq 'LOCAL ERROR') {
1035 debug("Can't check signature for $main::current_incoming_short/$commands -- don't process it for now");
1038 msg("log,mail", "(PGP/GnuPG signature by $signator)\n");
1040 return if !ftp_open();
1043 my @filenames = ($commands);
1044 if (my $ls_l = is_on_target($commands, @filenames)) {
1045 msg("log,mail", "$main::current_incoming_short/$commands is already present on target host:\n");
1046 msg("log,mail", "$ls_l\n");
1047 msg("log,mail", "Job $commands removed.\n");
1052 if (!copy_to_target($commands)) {
1053 msg("log,mail", "$commands couldn't be uploaded to target.\n");
1054 msg("log,mail", "Giving up and removing it.\n");
1060 msg("mail", "$commands uploaded successfully to $conf::target\n");
1064 # process one .commands file
1066 sub process_commands($) {
1067 my $commands = shift;
1068 my ( @cmds, $cmd, $pgplines, $signator );
1070 my ($file, @removed, $target_delay );
1072 format_status_str( $main::current_changes, $commands );
1074 $main::mail_addr = "";
1075 write_status_file() if $conf::statusdelay;
1077 msg( "log", "processing $main::current_incoming_short/$commands\n" );
1079 # run PGP on the file to check the signature
1080 if ( !( $signator = pgp_check($commands) ) ) {
1083 "$main::current_incoming_short/$commands has bad PGP/GnuPG signature!\n"
1086 } elsif ( $signator eq "LOCAL ERROR" ) {
1088 # An error has appened when starting pgp... Don't process the file,
1089 # but also don't delete it
1091 "Can't PGP/GnuPG check $main::current_incoming_short/$commands -- don't process it for now"
1094 } ## end elsif ( $signator eq "LOCAL ERROR")
1095 msg( "log", "(PGP/GnuPG signature by $signator)\n" );
1097 # parse the .commands file
1098 if ( !open( COMMANDS, "<", $commands ) ) {
1099 msg( "log", "Cannot open $main::current_incoming_short/$commands: $!\n" );
1104 outer_loop: while (<COMMANDS>) {
1105 if (/^---+(BEGIN|END) PGP .*---+$/) {
1107 } elsif (/^Uploader:\s*/i) {
1108 chomp( $main::mail_addr = $' );
1109 $main::mail_addr = $1 if $main::mail_addr =~ /<([^>]*)>/;
1110 } elsif (/^Commands:/i) {
1113 s/^\s*(.*)\s*$/$1/; # delete whitespace at both ends
1116 debug("includes cmd $_");
1118 last outer_loop if !defined( $_ = scalar(<COMMANDS>) );
1120 redo outer_loop if !/^\s/ || /^$/;
1121 } ## end for ( ; ; )
1122 } ## end elsif (/^Commands:/i)
1123 } ## end while (<COMMANDS>)
1126 # some consistency checks
1127 if ( !$main::mail_addr || $main::mail_addr !~ /^\S+\@\S+\.\S+/ ) {
1129 "$main::current_incoming_short/$commands contains no or bad Uploader: field: "
1130 . "$main::mail_addr\n" );
1132 "cannot process $main::current_incoming_short/$commands\n" );
1133 $main::mail_addr = "";
1135 } ## end if ( !$main::mail_addr...
1136 msg( "log", "(command uploader $main::mail_addr)\n" );
1138 if ( $pgplines < 3 ) {
1141 "$main::current_incoming_short/$commands isn't signed with PGP/GnuPG\n"
1145 "or the uploaded file is broken. Make sure to transfer in binary mode\n"
1147 msg( "mail", "or better yet - use dcut for commands files\n" );
1149 } ## end if ( $pgplines < 3 )
1151 # now process commands
1154 "Log of processing your commands file $main::current_incoming_short/$commands:\n\n"
1156 foreach $cmd (@cmds) {
1157 my @word = split( /\s+/, $cmd );
1158 msg( "mail,log", "> @word\n" );
1159 my $selecteddelayed = -1;
1162 if ( $word[0] eq "rm" ) {
1164 foreach ( @word[ 1 .. $#word ] ) {
1166 if (m,^DELAYED/([0-9]+)-day/,) {
1167 $selecteddelayed = $1;
1168 s,^DELAYED/[0-9]+-day/,,;
1171 msg("mail,log", "$_: filename component cannot start with a wildcard\n");
1172 } elsif ( $origword eq "--searchdirs" ) {
1173 $selecteddelayed = -2;
1177 "$_: filename may not contain slashes except for DELAYED/#-day/ prefixes\n"
1181 # process wildcards but also plain names
1183 my $pat = quotemeta($_);
1184 $pat =~ s/\\\*/.*/g;
1185 $pat =~ s/\\\?/.?/g;
1186 $pat =~ s/\\([][])/$1/g;
1188 if ( $selecteddelayed < 0 ) { # scanning or explicitly incoming
1189 opendir( DIR, "." );
1190 push( @thesefiles, grep /^$pat$/, readdir(DIR) );
1193 if ( $selecteddelayed >= 0 ) {
1194 my $dir = sprintf( $conf::incoming_delayed, $selecteddelayed );
1195 opendir( DIR, $dir );
1197 map ( "$dir/$_", grep /^$pat$/, readdir(DIR) ) );
1199 } elsif ( $selecteddelayed == -2 ) {
1200 for ( my ($adelay) = 0 ;
1201 ( !@thesefiles ) && $adelay <= $conf::max_delayed ;
1204 my $dir = sprintf( $conf::incoming_delayed, $adelay );
1205 opendir( DIR, $dir );
1207 map ( "$dir/$_", grep /^$pat$/, readdir(DIR) ) );
1209 } ## end for ( my ($adelay) = 0 ...
1210 } ## end elsif ( $selecteddelayed ...
1211 push( @files, @thesefiles );
1212 if ( !@thesefiles ) {
1213 msg( "mail,log", "$origword did not match anything\n" );
1215 } ## end else [ if ( $origword eq "--searchdirs")
1216 } ## end foreach ( @word[ 1 .. $#word...
1218 msg( "mail,log", "No files to delete\n" );
1221 foreach $file (@files) {
1223 msg( "mail,log", "$file: no such file\n" );
1224 } elsif ( $file =~ /$conf::keep_files/ ) {
1225 msg( "mail,log", "$file is protected, cannot " . "remove\n" );
1226 } elsif ( !unlink($file) ) {
1227 msg( "mail,log", "$file: rm: $!\n" );
1229 $file =~ s,$conf::incoming/?,,;
1230 push( @removed, $file );
1232 } ## end foreach $file (@files)
1233 msg( "mail,log", "Files removed: @removed\n" ) if @removed;
1234 } ## end else [ if ( !@files )
1235 } elsif ( $word[0] eq "reschedule" ) {
1237 msg( "mail,log", "Wrong number of arguments\n" );
1238 } elsif ( $conf::upload_method ne "copy" ) {
1239 msg( "mail,log", "reschedule not available\n" );
1240 } elsif ( $word[1] =~ m,/, || $word[1] !~ m/\.changes/ ) {
1243 "$word[1]: filename may not contain slashes and must be .changes\n"
1245 } elsif ( !( ($target_delay) = $word[2] =~ m,^([0-9]+)-day$, )
1246 || $target_delay > $conf::max_delayed )
1250 "$word[2]: rescheduling target must be #-day with # between 0 and $conf::max_delayed (in particular, no '/' allowed)\n"
1252 } elsif ( $word[1] =~ /$conf::keep_files/ ) {
1253 msg( "mail,log", "$word[1] is protected, cannot do stuff with it\n" );
1257 $adelay <= $conf::max_delayed
1259 sprintf( "$conf::targetdir_delayed", $adelay ) . "/$word[1]" ) ;
1262 } ## end for ( $adelay = 0 ; $adelay...
1263 if ( $adelay > $conf::max_delayed ) {
1264 msg( "mail,log", "$word[1] not found\n" );
1265 } elsif ( $adelay == $target_delay ) {
1266 msg( "mail,log", "$word[1] already is in $word[2]\n" );
1269 my ($dir) = sprintf( "$conf::targetdir_delayed", $adelay );
1271 sprintf( "$conf::targetdir_delayed", $target_delay );
1272 push( @thesefiles, $word[1] );
1274 get_filelist_from_known_good_changes("$dir/$word[1]") );
1275 for my $afile (@thesefiles) {
1276 if ( $afile =~ m/\.changes$/ ) {
1277 utime undef, undef, ("$dir/$afile");
1279 if ( !move("$dir/$afile", "$target_dir/$afile") ) {
1280 msg( "mail,log", "move: $!\n" );
1282 msg( "mail,log", "$afile moved to $target_delay-day\n" );
1284 } ## end for my $afile (@thesefiles)
1285 } ## end else [ if ( $adelay > $conf::max_delayed)
1286 } ## end else [ if ( @word != 3 )
1287 } elsif ( $word[0] eq "cancel" ) {
1289 msg( "mail,log", "Wrong number of arguments\n" );
1290 } elsif ( $conf::upload_method ne "copy" ) {
1291 msg( "mail,log", "cancel not available\n" );
1293 $word[1] !~ m,$re_file_safe_prefix\.changes\z, )
1296 "argument to cancel must be one .changes filename without path\n" );
1297 } ## end elsif ( $word[1] !~ ...
1299 for ( my ($adelay) = 0 ; $adelay <= $conf::max_delayed ; $adelay++ ) {
1300 my ($dir) = sprintf( "$conf::targetdir_delayed", $adelay );
1301 if ( -f "$dir/$word[1]" ) {
1303 push( @files, "$word[1]" );
1305 get_filelist_from_known_good_changes("$dir/$word[1]") );
1306 foreach $file (@files) {
1307 if ( !-f "$dir/$file" ) {
1308 msg( "mail,log", "$dir/$file: no such file\n" );
1309 } elsif ( "$dir/$file" =~ /$conf::keep_files/ ) {
1311 "$dir/$file is protected, cannot " . "remove\n" );
1312 } elsif ( !unlink("$dir/$file") ) {
1313 msg( "mail,log", "$dir/$file: rm: $!\n" );
1315 push( @removed, $file );
1317 } ## end foreach $file (@files)
1318 msg( "mail,log", "Files removed from $adelay-day: @removed\n" )
1320 } ## end if ( -f "$dir/$word[1]")
1321 } ## end for ( my ($adelay) = 0 ...
1323 msg( "mail,log", "No upload found: $word[1]\n" );
1326 msg( "mail,log", "unknown command $word[0]\n" );
1328 } ## end foreach $cmd (@cmds)
1331 "-- End of $main::current_incoming_short/$commands processing\n" );
1335 msg("log,mail", "Removing $main::current_incoming_short/$commands\n");
1338 } ## end sub process_commands($)
1340 sub age_delayed_queues() {
1341 for ( my ($adelay) = 0 ; $adelay <= $conf::max_delayed ; $adelay++ ) {
1342 my ($dir) = sprintf( "$conf::targetdir_delayed", $adelay );
1344 if ( $adelay == 0 ) {
1345 $target_dir = $conf::targetdir;
1347 $target_dir = sprintf( "$conf::targetdir_delayed", $adelay - 1 );
1349 for my $achanges (<$dir/*.changes>) {
1350 my $mtime = ( stat($achanges) )[9];
1351 if ( $mtime + 24 * 60 * 60 <= time || $adelay == 0 ) {
1352 utime undef, undef, ($achanges);
1353 my @thesefiles = ( $achanges =~ m,.*/([^/]*), );
1354 push( @thesefiles, get_filelist_from_known_good_changes($achanges) );
1355 for my $afile (@thesefiles) {
1356 if ( !move("$dir/$afile", "$target_dir/$afile") ) {
1357 msg( "log", "move: $!\n" );
1359 msg( "log", "$afile moved to $target_dir\n" );
1361 } ## end for my $afile (@thesefiles)
1362 } ## end if ( $mtime + 24 * 60 ...
1363 } ## end for my $achanges (<$dir/*.changes>)
1364 } ## end for ( my ($adelay) = 0 ...
1365 } ## end sub age_delayed_queues()
1368 # check if a file is already on target
1370 sub is_on_target($\@) {
1372 my $filelist = shift;
1376 if ( $conf::upload_method eq "ssh" ) {
1377 ( $msg, $stat ) = ssh_cmd("ls -l $file");
1378 } elsif ( $conf::upload_method eq "ftp" ) {
1380 ( $msg, $err ) = ftp_cmd( "dir", $file );
1386 $msg = "ls: no such file\n";
1389 $msg = join( "\n", @$msg );
1392 my @allfiles = ($file);
1393 push( @allfiles, @$filelist );
1395 $msg = "no such file";
1396 for my $afile (@allfiles) {
1397 if ( -f "$conf::targetdir/$afile" ) {
1401 } ## end for my $afile (@allfiles)
1402 for ( my ($adelay) = 0 ;
1403 $adelay <= $conf::max_delayed && $stat ;
1406 for my $afile (@allfiles) {
1408 -f ( sprintf( "$conf::targetdir_delayed", $adelay ) . "/$afile" ) )
1411 $msg = sprintf( "%d-day", $adelay ) . "/$afile";
1412 } ## end if ( -f ( sprintf( "$conf::targetdir_delayed"...
1413 } ## end for my $afile (@allfiles)
1414 } ## end for ( my ($adelay) = 0 ...
1415 } ## end else [ if ( $conf::upload_method...
1417 debug("exit status: $stat, output was: $msg");
1419 return "" if $stat && $msg =~ /no such file/i; # file not present
1420 msg( "log", "strange ls -l output on target:\n", $msg ), return ""
1421 if $stat || $@; # some other error, but still try to upload
1423 # ls -l returned 0 -> file already there
1424 $msg =~ s/\s\s+/ /g; # make multiple spaces into one, to save space
1426 } ## end sub is_on_target($\@)
1429 # copy a list of files to target
1431 sub copy_to_target(@) {
1433 my ( @md5sum, @expected_files, $sum, $name, $msgs, $stat );
1436 write_status_file() if $conf::statusdelay;
1439 if ( $conf::upload_method eq "ssh" ) {
1440 ( $msgs, $stat ) = scp_cmd(@files);
1442 } elsif ( $conf::upload_method eq "ftp" ) {
1444 if ( !$main::FTP_chan->cwd($main::current_targetdir) ) {
1446 "Can't cd to $main::current_targetdir on $conf::target\n" );
1449 foreach $file (@files) {
1450 ( $rv, $msgs ) = ftp_cmd( "put", $file );
1454 for my $file (@files) {
1455 eval { File::Copy::copy($file, $main::current_targetdir) };
1464 # check md5sums or sizes on target against our own
1465 my $have_md5sums = 1;
1466 if ($conf::check_md5sum) {
1467 if ( $conf::upload_method eq "ssh" ) {
1468 ( $msgs, $stat ) = ssh_cmd("md5sum @files");
1470 @md5sum = split( "\n", $msgs );
1471 } elsif ( $conf::upload_method eq "ftp" ) {
1472 my ( $rv, $err, $file );
1473 foreach $file (@files) {
1474 ( $rv, $err ) = ftp_cmd( "quot", "site", "md5sum", $file );
1476 next if ftp_code() == 550; # file not found
1477 if ( ftp_code() == 500 ) { # unimplemented
1479 goto get_sizes_instead;
1484 chomp( my $t = ftp_response() );
1485 push( @md5sum, $t );
1486 } ## end foreach $file (@files)
1487 if ( !$have_md5sums ) {
1489 foreach $file (@files) {
1490 ( $rv, $err ) = ftp_cmd( "size", $file );
1492 next if ftp_code() == 550; # file not found
1496 push( @md5sum, "$rv $file" );
1497 } ## end foreach $file (@files)
1498 } ## end if ( !$have_md5sums )
1500 for my $file (@files) {
1501 my $md5 = eval { md5sum("$main::current_targetdir/$file") };
1506 push @md5sum, "$md5 $file" if $md5;
1510 @expected_files = @files;
1513 ( $sum, $name ) = split;
1514 next if !grep { $_ eq $name } @files; # a file we didn't upload??
1515 next if $sum eq "md5sum:"; # looks like an error message
1516 if ( ( $have_md5sums && $sum ne md5sum($name) )
1517 || ( !$have_md5sums && $sum != ( -s $name ) ) )
1521 "Upload of $name to $conf::target failed ",
1522 "(" . ( $have_md5sums ? "md5sum" : "size" ) . " mismatch)\n"
1525 } ## end if ( ( $have_md5sums &&...
1527 # seen that file, remove it from expect list
1528 @expected_files = map { $_ eq $name ? () : $_ } @expected_files;
1529 } ## end foreach (@md5sum)
1530 if (@expected_files) {
1531 msg( "log,mail", "Failed to upload the files\n" );
1532 msg( "log,mail", " ", join( ", ", @expected_files ), "\n" );
1533 msg( "log,mail", "(Not present on target after upload)\n" );
1535 } ## end if (@expected_files)
1536 } ## end if ($conf::check_md5sum)
1538 if ($conf::chmod_on_target) {
1540 # change file's mode explicitly to 644 on target
1541 if ( $conf::upload_method eq "ssh" ) {
1542 ( $msgs, $stat ) = ssh_cmd("chmod 644 @files");
1544 } elsif ( $conf::upload_method eq "ftp" ) {
1546 foreach $file (@files) {
1547 ( $rv, $msgs ) = ftp_cmd( "quot", "site", "chmod", "644", $file );
1548 msg( "log", "Can't chmod $file on target:\n$msgs" )
1551 } ## end foreach $file (@files)
1553 for my $file (@files) {
1554 unless (chmod 0644, "$main::current_targetdir/$file") {
1555 $msgs = "Could not chmod $file: $!";
1560 } ## end if ($conf::chmod_on_target)
1563 write_status_file() if $conf::statusdelay;
1568 "Upload to $conf::target failed",
1569 $? ? ", last exit status " . sprintf( "%s", $? >> 8 ) : "", "\n" );
1570 msg( "log,mail", "Error messages:\n", $msgs )
1573 # If "permission denied" was among the errors, test if the incoming is
1575 if ( $msgs && $msgs =~ /(permission denied|read-?only file)/i ) {
1576 if ( !check_incoming_writable() ) {
1577 msg( "log,mail", "(The incoming directory seems to be ",
1580 } ## end if ( $msgs =~ /(permission denied|read-?only file)/i)
1582 # remove bad files or an incomplete upload on target
1583 if ( $conf::upload_method eq "ssh" ) {
1584 ssh_cmd("rm -f @files");
1585 } elsif ( $conf::upload_method eq "ftp" ) {
1587 foreach $file (@files) {
1589 ( $rv, $err ) = ftp_cmd( "delete", $file );
1590 msg( "log", "Can't delete $file on target:\n$err" )
1592 } ## end foreach $file (@files)
1594 my @tfiles = map { "$main::current_targetdir/$_" } @files;
1595 debug("executing unlink(@tfiles)");
1599 write_status_file() if $conf::statusdelay;
1601 } ## end sub copy_to_target(@)
1604 # check if a file is correctly signed with PGP
1615 if ($file =~ /$re_file_safe/) {
1618 msg( "log", "Tainted filename, skipping: $file\n" );
1619 return "LOCAL ERROR";
1622 # check the file has only one clear-signed section
1624 unless (open $fh, "<", $file) {
1625 msg("log,mail", "Could not open $file\n");
1628 unless (<$fh> eq "-----BEGIN PGP SIGNED MESSAGE-----\n") {
1629 msg("log,mail", "$file: does not start with a clearsigned message\n");
1635 msg("log,mail", "$file: dash-escaped messages are not accepted\n");
1638 elsif ($_ eq "-----BEGIN PGP SIGNATURE-----\n"
1639 || $_ eq "-----END PGP SIGNATURE-----\n") {
1643 msg("log,mail", "$file: unexpected OpenPGP armor\n");
1646 elsif ($pgplines > 3 && /\S/) {
1647 msg("log,mail", "$file: found text after end of signature\n");
1651 if ($pgplines != 3) {
1652 msg("log,mail", "$file: doesn't seem to be a valid clearsigned OpenPGP message\n");
1657 if ( -x $conf::gpg ) {
1658 my @command = ("$conf::gpg", "--no-options", "--batch", "--no-tty",
1659 "--trust-model", "always", "--no-default-keyring",
1660 (map +("--keyring" => $_), @conf::keyrings),
1662 debug( "executing " . join(" ", @command) );
1664 my $child = open(PIPE, "-|");
1665 if (!defined($child)) {
1666 msg("log", "Can't open pipe to $conf::gpg: $!\n");
1667 return "LOCAL ERROR";
1670 unless (open(STDERR, ">&", \*STDOUT)) {
1671 print "Could not redirect STDERR.";
1674 unless (open(STDIN, "<", $file)) {
1675 print "Could not open $file: $!";
1678 { exec(@command) }; # BLOCK avoids warning about likely unreachable code
1679 print "Could not exec gpg: $!";
1683 $output .= $_ while (<PIPE>);
1686 } ## end if ( -x $conf::gpg )
1689 msg( "log,mail", "GnuPG signature check failed on $file\n" );
1690 msg( "mail", $output );
1691 msg( "log,mail", "(Exit status ", $stat >> 8, ")\n" );
1695 $output =~ /^(gpg: )?good signature from (user )?"(.*)"\.?$/im;
1696 ( $signator = $3 ) ||= "unknown signator";
1698 debug("GnuPG signature ok (by $signator)");
1701 } ## end sub pgp_check($)
1703 # ---------------------------------------------------------------------------
1705 # ---------------------------------------------------------------------------
1708 # fork a subprocess that watches the 'status' FIFO
1710 # that process blocks until someone opens the FIFO, then sends a
1711 # signal (SIGUSR1) to the main process, expects
1713 sub fork_statusd() {
1719 $statusd_pid = open( STATUSD, "|-" );
1720 die "cannot fork: $!\n" if !defined($statusd_pid);
1722 # parent just returns
1724 msg( "log", "forked status daemon (pid $statusd_pid)\n" );
1725 return $statusd_pid;
1728 # child: the status FIFO daemon
1730 # ignore SIGPIPE here, in case some closes the FIFO without completely
1732 $SIG{"PIPE"} = "IGNORE";
1734 # also ignore SIGCLD, we don't want to inherit the restart-statusd handler
1736 $SIG{"CHLD"} = "DEFAULT";
1738 rm($conf::statusfile);
1739 $errs = `$conf::mkfifo $conf::statusfile`;
1740 die "$main::progname: cannot create named pipe $conf::statusfile: $errs"
1742 chmod( 0644, $conf::statusfile )
1743 or die "Cannot set modes of $conf::statusfile: $!\n";
1745 # close log file, so that log rotating works
1751 my ( $status, $mup, $incw, $ds, $next_run, $last_ping, $currch, $l );
1753 # open the FIFO for writing; this blocks until someone (probably ftpd)
1754 # opens it for reading
1755 open( STATFIFO, ">", $conf::statusfile )
1756 or die "Cannot open $conf::statusfile\n";
1759 # tell main daemon to send us status infos
1760 kill( $main::signo{"USR1"}, $main_pid );
1762 # get the infos from stdin; must loop until enough bytes received!
1763 my $expect_len = 3 + 2 * STATNUM_LEN + STATSTR_LEN;
1764 for ( $status = "" ; ( $l = length($status) ) < $expect_len ; ) {
1765 sysread( STDIN, $status, $expect_len - $l, $l );
1768 # disassemble the status byte stream
1774 [ next_run => STATNUM_LEN ],
1775 [ last_ping => STATNUM_LEN ],
1776 [ currch => STATSTR_LEN ]
1779 eval "\$$_->[0] = substr( \$status, $pos, $_->[1] );";
1781 } ## end foreach ( [ mup => 1 ], [ incw...
1782 $currch =~ s/\n+//g;
1784 print_status( $mup, $incw, $ds, $next_run, $last_ping, $currch );
1787 # This sleep is necessary so that we can't reopen the FIFO
1788 # immediately, in case the reader hasn't closed it yet if we get to
1789 # the open again. Is there a better solution for this??
1792 } ## end sub fork_statusd()
1795 # update the status file, in case we use a plain file and not a FIFO
1797 sub write_status_file() {
1799 return if !$conf::statusfile;
1801 open( STATFILE, ">", $conf::statusfile )
1802 or ( msg( "log", "Could not open $conf::statusfile: $!\n" ), return );
1803 my $oldsel = select(STATFILE);
1806 $main::target_up, $main::incoming_writable,
1807 $main::dstat, $main::next_run,
1808 $main::last_ping_time, $main::current_changes
1813 } ## end sub write_status_file()
1815 sub print_status($$$$$$) {
1819 my $next_run = shift;
1820 my $last_ping = shift;
1825 ( $version = 'Release: 0.9 $Revision: 1.51 $' ) =~ s/\$ ?//g;
1826 print "debianqueued $version\n";
1828 $approx = $conf::statusdelay ? "approx. " : "";
1830 if ( $mup eq "0" ) {
1831 print "$conf::target is down, queue pausing\n";
1833 } elsif ( $conf::upload_method ne "copy" ) {
1834 print "$conf::target seems to be up, last ping $approx",
1835 print_time( time - $last_ping ), " ago\n";
1838 if ( $incw eq "0" ) {
1839 print "The incoming directory is not writable, queue pausing\n";
1844 print "Next queue check in $approx", print_time( $next_run - time ), "\n";
1846 } elsif ( $ds eq "c" ) {
1847 print "Checking queue directory\n";
1848 } elsif ( $ds eq "u" ) {
1849 print "Uploading to $conf::target\n";
1851 print "Bad status data from daemon: \"$mup$incw$ds\"\n";
1855 print "Current job is $currch\n" if $currch;
1856 } ## end sub print_status($$$$$$)
1859 # format a number for sending to statusd (fixed length STATNUM_LEN)
1861 sub format_status_num(\$$) {
1865 $$varref = sprintf "%" . STATNUM_LEN . "d", $num;
1866 } ## end sub format_status_num(\$$)
1869 # format a string for sending to statusd (fixed length STATSTR_LEN)
1871 sub format_status_str(\$$) {
1875 $$varref = substr( $str, 0, STATSTR_LEN );
1876 $$varref .= "\n" x ( STATSTR_LEN - length($$varref) );
1877 } ## end sub format_status_str(\$$)
1880 # send a status string to the status daemon
1882 # Avoid all operations that could call malloc() here! Most libc
1883 # implementations aren't reentrant, so we may not call it from a
1884 # signal handler. So use only already-defined variables.
1887 local $! = 0; # preserve errno
1889 # re-setup handler, in case we have broken SysV signals
1890 $SIG{"USR1"} = \&send_status;
1892 syswrite( STATUSD, $main::target_up, 1 );
1893 syswrite( STATUSD, $main::incoming_writable, 1 );
1894 syswrite( STATUSD, $main::dstat, 1 );
1895 syswrite( STATUSD, $main::next_run, STATNUM_LEN );
1896 syswrite( STATUSD, $main::last_ping_time, STATNUM_LEN );
1897 syswrite( STATUSD, $main::current_changes, STATSTR_LEN );
1898 } ## end sub send_status()
1900 # ---------------------------------------------------------------------------
1902 # ---------------------------------------------------------------------------
1905 # open FTP connection to target host if not already open
1908 return 1 unless $conf::upload_method eq "ftp";
1910 if ($main::FTP_chan) {
1912 # is already open, but might have timed out; test with a cwd
1913 return $main::FTP_chan
1914 if $main::FTP_chan->cwd($main::current_targetdir);
1916 # cwd didn't work, channel is closed, try to reopen it
1917 $main::FTP_chan = undef;
1918 } ## end if ($main::FTP_chan)
1925 Debug => $conf::ftpdebug,
1926 Timeout => $conf::ftptimeout,
1932 msg( "log,mail", "Cannot open FTP server $conf::target\n" );
1934 } ## end if ( !( $main::FTP_chan...
1935 if ( !$main::FTP_chan->login() ) {
1936 msg( "log,mail", "Anonymous login on FTP server $conf::target failed\n" );
1939 if ( !$main::FTP_chan->binary() ) {
1940 msg( "log,mail", "Can't set binary FTP mode on $conf::target\n" );
1943 if ( !$main::FTP_chan->cwd($main::current_targetdir) ) {
1945 "Can't cd to $main::current_targetdir on $conf::target\n" );
1948 debug("opened FTP channel to $conf::target");
1952 $main::FTP_chan = undef;
1954 } ## end sub ftp_open()
1959 my $direct_resp_cmd = ( $cmd eq "quot" );
1961 debug( "executing FTP::$cmd(" . join( ", ", @_ ) . ")" );
1962 $SIG{"ALRM"} = sub { die "timeout in FTP::$cmd\n" };
1963 alarm($conf::remote_timeout);
1964 eval { $rv = $main::FTP_chan->$cmd(@_); };
1967 $rv = ( ftp_code() =~ /^2/ ) ? 1 : 0 if $direct_resp_cmd;
1972 $err = ftp_response();
1974 return ( $rv, $err );
1975 } ## end sub ftp_cmd($@)
1978 if ($main::FTP_chan) {
1979 $main::FTP_chan->quit();
1980 $main::FTP_chan = undef;
1983 } ## end sub ftp_close()
1985 sub ftp_response() {
1986 return join( '', @{ ${*$main::FTP_chan}{'net_cmd_resp'} } );
1990 return ${*$main::FTP_chan}{'net_cmd_code'};
1994 my $code = ftp_code();
1995 return ( $code =~ /^[45]/ ) ? 1 : 0;
1998 # ---------------------------------------------------------------------------
2000 # ---------------------------------------------------------------------------
2006 my $ecmd = "$conf::ssh $conf::ssh_options $conf::target "
2007 . "-l $conf::targetlogin \'cd $main::current_targetdir; $cmd\'";
2008 debug("executing $ecmd");
2009 $SIG{"ALRM"} = sub { die "timeout in ssh command\n" };
2010 alarm($conf::remote_timeout);
2011 eval { $msg = `$ecmd 2>&1`; };
2019 return ( $msg, $stat );
2020 } ## end sub ssh_cmd($)
2025 my $ecmd = "$conf::scp $conf::ssh_options @_ "
2026 . "$conf::targetlogin\@$conf::target:$main::current_targetdir";
2027 debug("executing $ecmd");
2028 $SIG{"ALRM"} = sub { die "timeout in scp\n" };
2029 alarm($conf::remote_timeout);
2030 eval { $msg = `$ecmd 2>&1`; };
2038 return ( $msg, $stat );
2039 } ## end sub scp_cmd(@)
2042 # check if target is alive (code stolen from Net::Ping.pm)
2044 sub check_alive(;$) {
2045 my $timeout = shift;
2046 my ( $saddr, $ret, $target_ip );
2049 if ( $conf::upload_method eq "copy" ) {
2050 format_status_num( $main::last_ping_time, time );
2051 $main::target_up = 1;
2057 if ( !( $target_ip = ( gethostbyname($conf::target) )[4] ) ) {
2058 msg( "log", "Cannot get IP address of $conf::target\n" );
2062 $saddr = pack( 'S n a4 x8', AF_INET, $main::echo_port, $target_ip );
2063 $SIG{'ALRM'} = sub { die };
2066 $ret = $main::tcp_proto; # avoid warnings about unused variable
2069 return unless socket( PINGSOCK, PF_INET, SOCK_STREAM, $main::tcp_proto );
2070 return unless connect( PINGSOCK, $saddr );
2075 msg( "log", "pinging $conf::target: " . ( $ret ? "ok" : "down" ) . "\n" );
2077 $main::target_up = $ret ? "1" : "0";
2078 format_status_num( $main::last_ping_time, time );
2079 write_status_file() if $conf::statusdelay;
2080 } ## end sub check_alive(;$)
2083 # check if incoming dir on target is writable
2085 sub check_incoming_writable() {
2086 my $testfile = ".debianqueued-testfile";
2089 if ( $conf::upload_method eq "ssh" ) {
2091 ssh_cmd( "rm -f $testfile; touch $testfile; " . "rm -f $testfile" );
2092 } elsif ( $conf::upload_method eq "ftp" ) {
2093 my $file = "junk-for-writable-test-" . format_time();
2094 $file =~ s/[ :.]/-/g;
2096 open( F, ">", $file );
2099 ( $rv, $msg ) = ftp_cmd( "put", $file );
2101 $msg = "" if !defined $msg;
2103 ftp_cmd( "delete", $file );
2104 } elsif ( $conf::upload_method eq "copy" ) {
2105 unless(POSIX::access($main::current_targetdir, &POSIX::W_OK)) {
2106 $msg = "No write access: $!";
2111 debug("exit status: $stat, output was: $msg");
2115 # change incoming_writable only if ssh didn't return an error
2116 $main::incoming_writable =
2117 ( $msg =~ /(permission denied|read-?only file|cannot create)/i )
2121 debug("local error, keeping old status");
2123 debug("incoming_writable = $main::incoming_writable");
2124 write_status_file() if $conf::statusdelay;
2125 return $main::incoming_writable;
2126 } ## end sub check_incoming_writable()
2129 # remove a list of files, log failing ones
2135 ( unlink $_ and ++$done )
2137 or msg( "log", "Could not delete $_: $!\n" );
2143 # get md5 checksum of a file
2147 my $md5 = Digest::MD5->new;
2149 open my $fh, "<", $file or return "";
2153 return $md5->hexdigest;
2154 } ## end sub md5sum($)
2157 # output a messages to several destinations
2159 # first arg is a comma-separated list of destinations; valid are "log"
2160 # and "mail"; rest is stuff to be printed, just as with print
2163 my @dest = split( ',', shift );
2165 if ( grep /log/, @dest ) {
2166 my $now = format_time();
2167 print LOG "$now ", @_;
2170 if ( grep /mail/, @dest ) {
2171 $main::mail_text .= join( '', @_ );
2173 } ## end sub msg($@)
2176 # print a debug messages, if $debug is true
2179 return if !$conf::debug;
2180 my $now = format_time();
2181 print LOG "$now DEBUG ", @_, "\n";
2185 # intialize the "mail" destination of msg() (this clears text,
2186 # address, subject, ...)
2191 $main::mail_addr = "";
2192 $main::mail_text = "";
2193 %main::packages = ();
2194 $main::mail_subject = $file ? "Processing of $file" : "";
2195 } ## end sub init_mail(;$)
2198 # finalize mail to be sent from msg(): check if something present, and
2203 debug("No mail for $main::mail_addr")
2204 if $main::mail_addr && !$main::mail_text;
2205 return unless $main::mail_addr && $main::mail_text;
2207 if ( !send_mail( $main::mail_addr, $main::mail_subject, $main::mail_text ) )
2210 # store this mail in memory so it isn't lost if executing sendmail
2213 @main::stored_mails,
2215 addr => $main::mail_addr,
2216 subject => $main::mail_subject,
2217 text => $main::mail_text
2220 } ## end if ( !send_mail( $main::mail_addr...
2223 # try to send out stored mails
2225 while ( $mailref = shift(@main::stored_mails) ) {
2227 !send_mail( $mailref->{'addr'}, $mailref->{'subject'},
2228 $mailref->{'text'} )
2231 unshift( @main::stored_mails, $mailref );
2233 } ## end if ( !send_mail( $mailref...
2234 } ## end while ( $mailref = shift(...
2235 } ## end sub finish_mail()
2240 sub send_mail($$$) {
2242 my $subject = shift;
2246 keys %main::packages ? join( ' ', keys %main::packages ) : "";
2248 use Email::Sender::Simple;
2250 if ($conf::overridemail) {
2251 $addr = $conf::overridemail;
2254 my $date = sprintf "%s",
2255 strftime( "%a, %d %b %Y %T %z", ( localtime(time) ) );
2256 my $message = <<__MESSAGE__;
2258 From: Debian FTP Masters <ftpmaster\@ftp-master.debian.org>
2264 Auto-Submitted: auto-generated
2267 if ( length $package ) {
2268 $message .= "X-Debian-Package: $package\n";
2271 $message .= "\n$text";
2272 $message .= "\nGreetings,\n\n\tYour Debian queue daemon (running on host $main::hostname)\n";
2274 return Email::Sender::Simple->try_to_send($message);
2275 } ## end sub send_mail($$$)
2278 # try to find a mail address for a name in the keyrings
2280 sub try_to_get_mail_addr($$) {
2282 my $listref = shift;
2286 "$conf::gpg --no-options --batch --no-default-keyring "
2287 . "--always-trust --keyring "
2288 . join( " --keyring ", @conf::keyrings )
2292 if ( /^pub / && / $name / ) {
2294 push( @$listref, $1 );
2296 } ## end while (<F>)
2299 return ( @$listref >= 1 ) ? $listref->[0] : "";
2300 } ## end sub try_to_get_mail_addr($$)
2303 # return current time as string
2308 # omit weekday and year for brevity
2309 ( $t = localtime ) =~ /^\w+\s(.*)\s\d+$/;
2311 } ## end sub format_time()
2315 my $hours = int( $secs / ( 60 * 60 ) );
2317 $secs -= $hours * 60 * 60;
2318 return sprintf "%d:%02d:%02d", $hours, int( $secs / 60 ), $secs % 60;
2319 } ## end sub print_time($)
2322 # block some signals during queue processing
2324 # This is just to avoid data inconsistency or uploads being aborted in the
2325 # middle. Only "soft" signals are blocked, i.e. SIGINT and SIGTERM, try harder
2326 # ones if you really want to kill the daemon at once.
2328 sub block_signals() {
2329 POSIX::sigprocmask( SIG_BLOCK, $main::block_sigset );
2332 sub unblock_signals() {
2333 POSIX::sigprocmask( SIG_UNBLOCK, $main::block_sigset );
2337 # process SIGHUP: close log file and reopen it (for logfile cycling)
2344 open( LOG, ">>", $conf::logfile )
2345 or die "Cannot open my logfile $conf::logfile: $!\n";
2346 chmod( 0644, $conf::logfile )
2347 or msg( "log", "Cannot set modes of $conf::logfile: $!\n" );
2348 select( ( select(LOG), $| = 1 )[0] );
2350 open( STDOUT, ">&", \*LOG )
2352 "$main::progname: Can't redirect stdout to " . "$conf::logfile: $!\n" );
2353 open( STDERR, ">&", \*LOG )
2355 "$main::progname: Can't redirect stderr to " . "$conf::logfile: $!\n" );
2356 msg( "log", "Restart after SIGHUP\n" );
2357 } ## end sub close_log($)
2360 # process SIGCHLD: check if it was our statusd process
2365 # reap statusd, so that it's no zombie when we try to kill(0) it
2366 waitpid( $main::statusd_pid, WNOHANG );
2368 # Uncomment the following line if your Perl uses unreliable System V signal
2369 # (i.e. if handlers reset to default if the signal is delivered).
2370 # (Unfortunately, the re-setup can't be done in any case, since on some
2371 # systems this will cause the SIGCHLD to be delivered again if there are
2372 # still unreaped children :-(( )
2374 # $SIG{"CHLD"} = \&kid_died; # resetup handler for SysV
2375 } ## end sub kid_died($)
2377 sub restart_statusd() {
2379 # restart statusd if it died
2380 if ( !kill( 0, $main::statusd_pid ) ) {
2381 close(STATUSD); # close out pipe end
2382 $main::statusd_pid = fork_statusd();
2384 } ## end sub restart_statusd()
2387 # process a fatal signal: cleanup and exit
2389 sub fatal_signal($) {
2390 my $signame = shift;
2393 # avoid recursions of fatal_signal in case of BSD signals
2394 foreach $sig (qw( ILL ABRT BUS FPE SEGV PIPE )) {
2395 $SIG{$sig} = "DEFAULT";
2398 if ( $$ == $main::maind_pid ) {
2400 # only the main daemon should do this
2401 kill( $main::signo{"TERM"}, $main::statusd_pid )
2402 if defined $main::statusd_pid;
2403 unlink( $conf::statusfile, $conf::pidfile );
2404 } ## end if ( $$ == $main::maind_pid)
2405 msg( "log", "Caught SIG$signame -- exiting (pid $$)\n" );
2407 } ## end sub fatal_signal($)