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