tools/debianqueued-0.9/debianqueued

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