X-Git-Url: https://git.decadent.org.uk/gitweb/?a=blobdiff_plain;f=tools%2Fdebianqueued-0.9%2Fdebianqueued;h=d99c8c878d96a974895fb4703827c20091a3d162;hb=d1ba61d1cc6c2fc80d4d7661d58aea4c580690b0;hp=1eb502dcdeba46f4899547407df266750ed88698;hpb=c3d062116b42e70e407321bb7f67213ede900eca;p=dak.git diff --git a/tools/debianqueued-0.9/debianqueued b/tools/debianqueued-0.9/debianqueued index 1eb502dc..d99c8c87 100755 --- a/tools/debianqueued-0.9/debianqueued +++ b/tools/debianqueued-0.9/debianqueued @@ -14,6 +14,7 @@ # require 5.002; +no lib '.'; use strict; use POSIX; use POSIX qw( strftime sys_stat_h sys_wait_h signal_h ); @@ -23,8 +24,10 @@ use Socket qw( PF_INET AF_INET SOCK_STREAM ); use Config; use Sys::Hostname; use File::Copy; +use Digest::MD5; setlocale(&POSIX::LC_ALL, "C"); +$ENV{"LC_ALL"} = "C"; # --------------------------------------------------------------------------- # configuration @@ -44,16 +47,11 @@ $junk = $conf::valid_files; $junk = $conf::max_upload_retries; $junk = $conf::upload_delay_1; $junk = $conf::upload_delay_2; -$junk = $conf::ar; -$junk = $conf::gzip; -$junk = $conf::cp; $junk = $conf::check_md5sum; #$junk = $conf::ls; -$junk = $conf::chmod; $junk = $conf::ftpdebug; $junk = $conf::ftptimeout; -$junk = $conf::no_changes_timeout; $junk = @conf::nonus_packages; $junk = @conf::test_binaries; $junk = @conf::maintainer_mail; @@ -69,6 +67,8 @@ package main; ($main::hostname, undef, undef, undef, undef) = gethostbyname(hostname()); my %packages = (); +my $re_file_safe_prefix = qr/\A([a-zA-Z0-9][a-zA-Z0-9_.:~+-]*)/s; +my $re_file_safe = qr/$re_file_safe_prefix\z/s; # extract -r and -k args $main::arg = ""; @@ -79,7 +79,7 @@ if ( @ARGV == 1 && $ARGV[0] =~ /^-[rk]$/ ) { # test for another instance of the queued already running my ( $pid, $delayed_dirs, $adelayedcore ); -if ( open( PIDFILE, "<$conf::pidfile" ) ) { +if ( open( PIDFILE, "<", $conf::pidfile ) ) { chomp( $pid = ); close(PIDFILE); if ( !$pid ) { @@ -179,7 +179,7 @@ do { # check if all programs exist my $prg; foreach $prg ( $conf::gpg, $conf::ssh, $conf::scp, $conf::ssh_agent, - $conf::ssh_add, $conf::md5sum, $conf::mail, $conf::mkfifo ) + $conf::ssh_add, $conf::mail, $conf::mkfifo ) { die "Required program $prg doesn't exist or isn't executable\n" if !-x $prg; @@ -231,14 +231,10 @@ sub ftp_code(); sub ftp_error(); sub ssh_cmd($); sub scp_cmd(@); -sub local_cmd($;$); sub check_alive(;$); sub check_incoming_writable(); sub rm(@); sub md5sum($); -sub is_debian_file($); -sub get_maintainer($); -sub debian_file_stem($); sub msg($@); sub debug(@); sub init_mail(;$); @@ -316,7 +312,7 @@ chdir($conf::incoming) $SIG{"HUP"} = "IGNORE"; # open logfile, make it unbuffered -open( LOG, ">>$conf::logfile" ) +open( LOG, ">>", $conf::logfile ) or die "Cannot open my logfile $conf::logfile: $!\n"; chmod( 0644, $conf::logfile ) or die "Cannot set modes of $conf::logfile: $!\n"; @@ -326,11 +322,11 @@ sleep(1); $SIG{"HUP"} = \&close_log; # redirect stdin, ... to /dev/null -open( STDIN, "&LOG" ) +open( STDOUT, ">&", \*LOG ) or die "$main::progname: Can't redirect stdout to $conf::logfile: $!\n"; -open( STDERR, ">&LOG" ) +open( STDERR, ">&", \*LOG ) or die "$main::progname: Can't redirect stderr to $conf::logfile: $!\n"; # ok, from this point usually no "die" anymore, stderr is gone! @@ -358,7 +354,7 @@ END { } # write the pid file -open( PIDFILE, ">$conf::pidfile" ) +open( PIDFILE, ">", $conf::pidfile ) or msg( "log", "Can't open $conf::pidfile: $!\n" ); printf PIDFILE "%5d\n", $$; close(PIDFILE); @@ -387,7 +383,7 @@ while (1) { # ping target only if there is the possibility that we'll contact it (but # also don't wait too long). - my @have_changes = <*.changes *.commands>; + my @have_changes = <*.changes *.commands *.dak-commands>; for ( my $delayed_dirs = 0 ; $delayed_dirs <= $conf::max_delayed ; $delayed_dirs++ ) @@ -487,9 +483,10 @@ sub check_dir() { return ); - # look for *.commands files but not in delayed queues + # look for *.commands and *.dak-commands files but not in delayed queues if ( $adelay == -1 ) { foreach $file (<*.commands>) { + next unless $file =~ /$re_file_safe/; init_mail($file); block_signals(); process_commands($file); @@ -498,6 +495,16 @@ sub check_dir() { write_status_file() if $conf::statusdelay; finish_mail(); } ## end foreach $file (<*.commands>) + foreach $file (<*.dak-commands>) { + next unless $file =~ /$re_file_safe/; + init_mail($file); + block_signals(); + process_dak_commands($file); + unblock_signals(); + $main::dstat = "c"; + write_status_file() if $conf::statusdelay; + finish_mail(); + } } ## end if ( $adelay == -1 ) opendir( INC, "." ) or ( @@ -513,6 +520,7 @@ sub check_dir() { @changes = grep /\.changes$/, @files; push( @keep_files, @changes ); # .changes files aren't stray foreach $file (@changes) { + next unless $file =~ /$re_file_safe/; init_mail($file); # wrap in an eval to allow jumpbacks to here with die in case @@ -553,91 +561,12 @@ sub check_dir() { my ( $maint, $pattern, @job_files ); if ( $file =~ /^junk-for-writable-test/ || $file !~ m,$conf::valid_files, + || $file !~ /$re_file_safe/ || $age >= $conf::stray_remove_timeout ) { msg( "log", "Deleted stray file ${main::current_incoming_short}/$file\n" ) if rm($file); - } elsif ( - $age > $conf::no_changes_timeout - && is_debian_file($file) - && - - # not already reported - !( $stats[ST_MODE] & S_ISGID ) - && ( $pattern = debian_file_stem($file) ) - && ( @job_files = glob($pattern) ) - && - - # If a .changes is in the list, it has the same stem as the - # found file (probably a .orig.tar.gz). Don't report in this - # case. - !( grep( /\.changes$/, @job_files ) ) - ) - { - $maint = get_maintainer($file); - - # Don't send a mail if this looks like the recompilation of a - # package for a non-i386 arch. For those, the maintainer field is - # useless :-( - if ( !grep( /(\.dsc|_(i386|all)\.deb)$/, @job_files ) ) { - msg( "log", "Found an upload without .changes and with no ", - ".dsc file\n" ); - msg( "log", - "Not sending a report, because probably ", - "recompilation job\n" ); - } elsif ($maint) { - init_mail(); - $main::mail_addr = $maint; - $main::mail_addr = $1 if $main::mail_addr =~ /<([^>]*)>/; - $main::mail_subject = - "Incomplete upload found in " . "Debian upload queue"; - msg( - "mail", - "Probably you are the uploader of the following " - . "file(s) in\n" - ); - msg( "mail", "the Debian upload queue directory:\n " ); - msg( "mail", join( "\n ", @job_files ), "\n" ); - msg( - "mail", - "This looks like an upload, but a .changes file " - . "is missing, so the job\n" - ); - msg( "mail", "cannot be processed.\n\n" ); - msg( - "mail", - "If no .changes file arrives within ", - print_time( $conf::stray_remove_timeout - $age ), - ", the files will be deleted.\n\n" - ); - msg( - "mail", - "If you didn't upload those files, please just " - . "ignore this message.\n" - ); - finish_mail(); - msg( - "log", - "Sending problem report for an upload without a " - . ".changes\n" - ); - msg( "log", "Maintainer: $maint\n" ); - } else { - msg( - "log", - "Found an upload without .changes, but can't " - . "find a maintainer address\n" - ); - } ## end else [ if ( !grep( /(\.dsc|_(i386|all)\.deb)$/... - msg( "log", "Files: @job_files\n" ); - - # remember we already have sent a mail regarding this file - foreach (@job_files) { - my @st = stat($_); - next if !@st; # file may have disappeared in the meantime - chmod +( $st[ST_MODE] |= S_ISGID ), $_; - } } else { debug( "found stray file ${main::current_incoming_short}/$file, deleting in ", @@ -660,7 +589,7 @@ sub get_filelist_from_known_good_changes($) { my (@filenames); # parse the .changes file - open( CHANGES, "<$changes" ) + open( CHANGES, "<", $changes ) or die "$changes: $!\n"; outer_loop: while () { if (/^Files:/i) { @@ -671,7 +600,7 @@ outer_loop: while () { # forbid shell meta chars in the name, we pass it to a # subshell several times... - $field[5] =~ /^([a-zA-Z0-9.+_:@=%-][~a-zA-Z0-9.+_:@=%-]*)/; + $field[5] =~ /$re_file_safe/; if ( $1 ne $field[5] ) { msg( "log", "found suspicious filename $field[5]\n" ); next; @@ -694,7 +623,7 @@ sub process_changes($\@) { $pgplines, @files, @filenames, @changes_stats, $failure_file, $retries, $last_retry, $upload_time, $file, $do_report, $ls_l, $problems_reported, - $errs, $pkgname, $signator + $errs, $pkgname, $signator, $extralines ); local (*CHANGES); local (*FAILS); @@ -702,21 +631,45 @@ sub process_changes($\@) { format_status_str( $main::current_changes, "$main::current_incoming_short/$changes" ); $main::dstat = "c"; + $main::mail_addr = ""; write_status_file() if $conf::statusdelay; @$keep_list = (); msg( "log", "processing ${main::current_incoming_short}/$changes\n" ); + # run PGP on the file to check the signature + if ( !( $signator = pgp_check($changes) ) ) { + msg( + "log,mail", + "$main::current_incoming_short/$changes has bad PGP/GnuPG signature!\n" + ); + goto remove_only_changes; + } elsif ( $signator eq "LOCAL ERROR" ) { + + # An error has appened when starting pgp... Don't process the file, + # but also don't delete it + debug( +"Can't PGP/GnuPG check $main::current_incoming_short/$changes -- don't process it for now" + ); + return; + } ## end elsif ( $signator eq "LOCAL ERROR") + # parse the .changes file - open( CHANGES, "<$changes" ) + open( CHANGES, "<", $changes ) or die "Cannot open ${main::current_incoming_short}/$changes: $!\n"; $pgplines = 0; - $main::mail_addr = ""; + $extralines = 0; @files = (); outer_loop: while () { if (/^---+(BEGIN|END) PGP .*---+$/) { ++$pgplines; - } elsif (/^Maintainer:\s*/i) { + next; + } + if ( $pgplines < 1 or $pgplines >= 3 ) { + $extralines++ if length $_ > 1; + next; + } + if (/^Maintainer:\s*/i) { chomp( $main::mail_addr = $' ); $main::mail_addr = $1 if $main::mail_addr =~ /<([^>]*)>/; } elsif (/^Source:\s*/i) { @@ -731,7 +684,7 @@ outer_loop: while () { # forbid shell meta chars in the name, we pass it to a # subshell several times... - $field[5] =~ /^([a-zA-Z0-9.+_:@=%-][~a-zA-Z0-9.+_:@=%-]*)/; + $field[5] =~ /$re_file_safe/; if ( $1 ne $field[5] ) { msg( "log", "found suspicious filename $field[5]\n" ); msg( @@ -762,6 +715,12 @@ outer_loop: while () { @$keep_list = @filenames; # some consistency checks + if ( $extralines ) { + msg( "log,mail", +"$main::current_incoming_short/$changes contained lines outside the pgp signed " +."part, cannot process\n" ); + goto remove_only_changes; + } ## end if ( $extralines ) if ( !$main::mail_addr ) { msg( "log,mail", "$main::current_incoming_short/$changes doesn't contain a Maintainer: field; " @@ -846,7 +805,7 @@ outer_loop: while () { $failure_file = $changes . ".failures"; $retries = $last_retry = 0; if ( -f $failure_file ) { - open( FAILS, "<$failure_file" ) + open( FAILS, "<", $failure_file ) or die "Cannot open $main::current_incoming_short/$failure_file: $!\n"; my $line = ; close(FAILS); @@ -855,39 +814,6 @@ outer_loop: while () { push( @$keep_list, $failure_file ); } ## end if ( -f $failure_file ) - # run PGP on the file to check the signature - if ( !( $signator = pgp_check($changes) ) ) { - msg( - "log,mail", - "$main::current_incoming_short/$changes has bad PGP/GnuPG signature!\n" - ); - msg( "log", "(uploader $main::mail_addr)\n" ); - remove_only_changes: - msg( - "log,mail", -"Removing $main::current_incoming_short/$changes, but keeping its associated ", - "files for now.\n" - ); - rm($changes); - - # Set SGID bit on associated files, so that the test for Debian files - # without a .changes doesn't consider them. - foreach (@filenames) { - my @st = stat($_); - next if !@st; # file may have disappeared in the meantime - chmod +( $st[ST_MODE] |= S_ISGID ), $_; - } - return; - } elsif ( $signator eq "LOCAL ERROR" ) { - - # An error has appened when starting pgp... Don't process the file, - # but also don't delete it - debug( -"Can't PGP/GnuPG check $main::current_incoming_short/$changes -- don't process it for now" - ); - return; - } ## end elsif ( $signator eq "LOCAL ERROR") - die "Cannot stat ${main::current_incoming_short}/$changes (??): $!\n" if !( @changes_stats = stat($changes) ); @@ -995,9 +921,7 @@ outer_loop: while () { return; } ## end if ( $retries > 0 && (... - if ( $conf::upload_method eq "ftp" ) { - return if !ftp_open(); - } + return if !ftp_open(); # check if the job is already present on target # (moved to here, to avoid bothering target as long as there are errors in @@ -1043,7 +967,7 @@ outer_loop: while () { rm( $changes, @filenames, $failure_file ); } else { $last_retry = time; - if ( open( FAILS, ">$failure_file" ) ) { + if ( open( FAILS, ">", $failure_file ) ) { print FAILS "$retries $last_retry\n"; close(FAILS); chmod( 0600, $failure_file ) @@ -1074,6 +998,17 @@ outer_loop: while () { msg( "log", "$changes processed successfully (uploader $main::mail_addr)\n" ); + return; + + remove_only_changes: + msg( + "log,mail", + "Removing $main::current_incoming_short/$changes, but keeping its " + . "associated files for now.\n" + ); + rm($changes); + return; + # Check for files that have the same stem as the .changes (and weren't # mentioned there) and delete them. It happens often enough that people # upload a .orig.tar.gz where it isn't needed and also not in the @@ -1104,6 +1039,57 @@ outer_loop: while () { #} } ## end sub process_changes($\@) +# +# process one .dak-commands file +# +sub process_dak_commands { + my $commands = shift; + + msg("log", "processing ${main::current_incoming_short}/$commands\n"); + + # TODO: get mail address from signed contents + # and NOT implement a third parser for armored PGP... + $main::mail_addr = undef; + + # check signature + my $signator = pgp_check($commands); + if (!$signator) { + msg("log,mail", + "$main::current_incoming_short/$commands has bad PGP/GnuPG signature!\n"); + msg("log,mail", + "Removing $main::current_incoming_short/$commands\n"); + rm($commands); + return; + } + elsif ($signator eq 'LOCAL ERROR') { + debug("Can't check signature for $main::current_incoming_short/$commands -- don't process it for now"); + return; + } + msg("log,mail", "(PGP/GnuPG signature by $signator)\n"); + + return if !ftp_open(); + + # check target + my @filenames = ($commands); + if (my $ls_l = is_on_target($commands, @filenames)) { + msg("log,mail", "$main::current_incoming_short/$commands is already present on target host:\n"); + msg("log,mail", "$ls_l\n"); + msg("log,mail", "Job $commands removed.\n"); + rm($commands); + return; + } + + if (!copy_to_target($commands)) { + msg("log,mail", "$commands couldn't be uploaded to target.\n"); + msg("log,mail", "Giving up and removing it.\n"); + rm($commands); + return; + } + + rm($commands); + msg("mail", "$commands uploaded successfully to $conf::target\n"); +} + # # process one .commands file # @@ -1115,17 +1101,35 @@ sub process_commands($) { format_status_str( $main::current_changes, $commands ); $main::dstat = "c"; + $main::mail_addr = ""; write_status_file() if $conf::statusdelay; msg( "log", "processing $main::current_incoming_short/$commands\n" ); + # run PGP on the file to check the signature + if ( !( $signator = pgp_check($commands) ) ) { + msg( + "log,mail", + "$main::current_incoming_short/$commands has bad PGP/GnuPG signature!\n" + ); + goto remove; + } elsif ( $signator eq "LOCAL ERROR" ) { + + # An error has appened when starting pgp... Don't process the file, + # but also don't delete it + debug( +"Can't PGP/GnuPG check $main::current_incoming_short/$commands -- don't process it for now" + ); + return; + } ## end elsif ( $signator eq "LOCAL ERROR") + msg( "log", "(PGP/GnuPG signature by $signator)\n" ); + # parse the .commands file - if ( !open( COMMANDS, "<$commands" ) ) { + if ( !open( COMMANDS, "<", $commands ) ) { msg( "log", "Cannot open $main::current_incoming_short/$commands: $!\n" ); return; } $pgplines = 0; - $main::mail_addr = ""; @cmds = (); outer_loop: while () { if (/^---+(BEGIN|END) PGP .*---+$/) { @@ -1174,27 +1178,6 @@ outer_loop: while () { goto remove; } ## end if ( $pgplines < 3 ) - # run PGP on the file to check the signature - if ( !( $signator = pgp_check($commands) ) ) { - msg( - "log,mail", - "$main::current_incoming_short/$commands has bad PGP/GnuPG signature!\n" - ); - remove: - msg( "log,mail", "Removing $main::current_incoming_short/$commands\n" ); - rm($commands); - return; - } elsif ( $signator eq "LOCAL ERROR" ) { - - # An error has appened when starting pgp... Don't process the file, - # but also don't delete it - debug( -"Can't PGP/GnuPG check $main::current_incoming_short/$commands -- don't process it for now" - ); - return; - } ## end elsif ( $signator eq "LOCAL ERROR") - msg( "log", "(PGP/GnuPG signature by $signator)\n" ); - # now process commands msg( "mail", @@ -1336,7 +1319,7 @@ outer_loop: while () { } elsif ( $conf::upload_method ne "copy" ) { msg( "mail,log", "cancel not available\n" ); } elsif ( - $word[1] !~ m,^[a-zA-Z0-9.+_:@=%-][~a-zA-Z0-9.+_:@=%-]*\.changes$, ) + $word[1] !~ m,$re_file_safe_prefix\.changes\z, ) { msg( "mail,log", "argument to cancel must be one .changes filename without path\n" ); @@ -1375,6 +1358,12 @@ outer_loop: while () { rm($commands); msg( "log", "-- End of $main::current_incoming_short/$commands processing\n" ); + return; + + remove: + msg("log,mail", "Removing $main::current_incoming_short/$commands\n"); + rm($commands); + return; } ## end sub process_commands($) sub age_delayed_queues() { @@ -1491,9 +1480,14 @@ sub copy_to_target(@) { goto err if !$rv; } } else { - ( $msgs, $stat ) = - local_cmd( "$conf::cp @files $main::current_targetdir", 'NOCD' ); - goto err if $stat; + for my $file (@files) { + eval { File::Copy::copy($file, $main::current_targetdir) }; + if ($@) { + $stat = 1; + $msgs = $@; + goto err; + } + } } # check md5sums or sizes on target against our own @@ -1532,9 +1526,14 @@ sub copy_to_target(@) { } ## end foreach $file (@files) } ## end if ( !$have_md5sums ) } else { - ( $msgs, $stat ) = local_cmd("$conf::md5sum @files"); - goto err if $stat; - @md5sum = split( "\n", $msgs ); + for my $file (@files) { + my $md5 = eval { md5sum("$main::current_targetdir/$file") }; + if ($@) { + $msgs = $@; + goto err; + } + push @md5sum, "$md5 $file" if $md5; + } } @expected_files = @files; @@ -1580,8 +1579,12 @@ sub copy_to_target(@) { goto err if !$rv; } ## end foreach $file (@files) } else { - ( $msgs, $stat ) = local_cmd("$conf::chmod 644 @files"); - goto err if $stat; + for my $file (@files) { + unless (chmod 0644, "$main::current_targetdir/$file") { + $msgs = "Could not chmod $file: $!"; + goto err; + } + } } } ## end if ($conf::chmod_on_target) @@ -1598,7 +1601,7 @@ err: # If "permission denied" was among the errors, test if the incoming is # writable at all. - if ( $msgs =~ /(permission denied|read-?only file)/i ) { + if ( $msgs && $msgs =~ /(permission denied|read-?only file)/i ) { if ( !check_incoming_writable() ) { msg( "log,mail", "(The incoming directory seems to be ", "unwritable.)\n" ); @@ -1634,30 +1637,78 @@ sub pgp_check($) { my $output = ""; my $signator; my $found = 0; - my $stat; + my $stat = 1; local (*PIPE); + local $_; + + if ($file =~ /$re_file_safe/) { + $file = $1; + } else { + msg( "log", "Tainted filename, skipping: $file\n" ); + return "LOCAL ERROR"; + } + + # check the file has only one clear-signed section + my $fh; + unless (open $fh, "<", $file) { + msg("log,mail", "Could not open $file\n"); + return ""; + } + unless (<$fh> eq "-----BEGIN PGP SIGNED MESSAGE-----\n") { + msg("log,mail", "$file: does not start with a clearsigned message\n"); + return ""; + } + my $pgplines = 1; + while (<$fh>) { + if (/\A- /) { + msg("log,mail", "$file: dash-escaped messages are not accepted\n"); + return ""; + } + elsif ($_ eq "-----BEGIN PGP SIGNATURE-----\n" + || $_ eq "-----END PGP SIGNATURE-----\n") { + $pgplines++; + } + elsif (/\A--/) { + msg("log,mail", "$file: unexpected OpenPGP armor\n"); + return ""; + } + elsif ($pgplines > 3 && /\S/) { + msg("log,mail", "$file: found text after end of signature\n"); + return ""; + } + } + if ($pgplines != 3) { + msg("log,mail", "$file: doesn't seem to be a valid clearsigned OpenPGP message\n"); + return ""; + } + close $fh; - $stat = 1; if ( -x $conf::gpg ) { - debug( "executing $conf::gpg --no-options --batch " - . "--no-default-keyring --always-trust " - . "--keyring " - . join( " --keyring ", @conf::keyrings ) - . " --verify '$file'" ); - if ( - !open( PIPE, - "$conf::gpg --no-options --batch " - . "--no-default-keyring --always-trust " - . "--keyring " - . join( " --keyring ", @conf::keyrings ) - . " --verify '$file'" - . " 2>&1 |" - ) - ) - { - msg( "log", "Can't open pipe to $conf::gpg: $!\n" ); + my @command = ("$conf::gpg", "--no-options", "--batch", "--no-tty", + "--trust-model", "always", "--no-default-keyring", + (map +("--keyring" => $_), @conf::keyrings), + "--verify", "-"); + debug( "executing " . join(" ", @command) ); + + my $child = open(PIPE, "-|"); + if (!defined($child)) { + msg("log", "Can't open pipe to $conf::gpg: $!\n"); return "LOCAL ERROR"; - } ## end if ( !open( PIPE, "$conf::gpg --no-options --batch "... + } + if ($child == 0) { + unless (open(STDERR, ">&", \*STDOUT)) { + print "Could not redirect STDERR."; + exit(-1); + } + unless (open(STDIN, "<", $file)) { + print "Could not open $file: $!"; + exit(-1); + } + { exec(@command) }; # BLOCK avoids warning about likely unreachable code + print "Could not exec gpg: $!"; + exit(-1); + } + $output .= $_ while (); close(PIPE); $stat = $?; @@ -1730,7 +1781,7 @@ sub fork_statusd() { # open the FIFO for writing; this blocks until someone (probably ftpd) # opens it for reading - open( STATFIFO, ">$conf::statusfile" ) + open( STATFIFO, ">", $conf::statusfile ) or die "Cannot open $conf::statusfile\n"; select(STATFIFO); @@ -1776,7 +1827,7 @@ sub write_status_file() { return if !$conf::statusfile; - open( STATFILE, ">$conf::statusfile" ) + open( STATFILE, ">", $conf::statusfile ) or ( msg( "log", "Could not open $conf::statusfile: $!\n" ), return ); my $oldsel = select(STATFILE); @@ -1883,6 +1934,7 @@ sub send_status() { # open FTP connection to target host if not already open # sub ftp_open() { + return 1 unless $conf::upload_method eq "ftp"; if ($main::FTP_chan) { @@ -2015,19 +2067,6 @@ sub scp_cmd(@) { return ( $msg, $stat ); } ## end sub scp_cmd(@) -sub local_cmd($;$) { - my $cmd = shift; - my $nocd = shift; - my ( $msg, $stat ); - - my $ecmd = ( $nocd ? "" : "cd $main::current_targetdir; " ) . $cmd; - debug("executing $ecmd"); - $msg = `($ecmd) 2>&1`; - $stat = $?; - return ( $msg, $stat ); - -} ## end sub local_cmd($;$) - # # check if target is alive (code stolen from Net::Ping.pm) # @@ -2083,7 +2122,7 @@ sub check_incoming_writable() { my $file = "junk-for-writable-test-" . format_time(); $file =~ s/[ :.]/-/g; local (*F); - open( F, ">$file" ); + open( F, ">", $file ); close(F); my $rv; ( $rv, $msg ) = ftp_cmd( "put", $file ); @@ -2092,8 +2131,10 @@ sub check_incoming_writable() { unlink $file; ftp_cmd( "delete", $file ); } elsif ( $conf::upload_method eq "copy" ) { - ( $msg, $stat ) = - local_cmd( "rm -f $testfile; touch $testfile; " . "rm -f $testfile" ); + unless(POSIX::access($main::current_targetdir, &POSIX::W_OK)) { + $msg = "No write access: $!"; + $stat = 1; + } } chomp($msg); debug("exit status: $stat, output was: $msg"); @@ -2132,106 +2173,14 @@ sub rm(@) { # sub md5sum($) { my $file = shift; - my $line; - - chomp( $line = `$conf::md5sum $file` ); - debug( "md5sum($file): ", - $? ? "exit status $?" - : $line =~ /^(\S+)/ ? $1 - : "match failed" ); - return $? ? "" : $line =~ /^(\S+)/ ? $1 : ""; -} ## end sub md5sum($) + my $md5 = Digest::MD5->new; -# -# check if a file probably belongs to a Debian upload -# -sub is_debian_file($) { - my $file = shift; - return $file =~ /\.(deb|dsc|(diff|tar)\.gz)$/ - && $file !~ /\.orig\.tar\.gz/; -} - -# -# try to extract maintainer email address from some a non-.changes file -# return "" if not possible -# -sub get_maintainer($) { - my $file = shift; - my $maintainer = ""; - local (*F); - - if ( $file =~ /\.diff\.gz$/ ) { - - # parse a diff - open( F, "$conf::gzip -dc '$file' 2>/dev/null |" ) or return ""; - while () { - - # look for header line of a file */debian/control - last if m,^\+\+\+\s+[^/]+/debian/control(\s+|$),; - } - while () { - last if /^---/; # end of control file patch, no Maintainer: found - # inside control file patch look for Maintainer: field - $maintainer = $1, last if /^\+Maintainer:\s*(.*)$/i; - } - while () { } # read to end of file to avoid broken pipe - close(F) or return ""; - } elsif ( $file =~ /\.(deb|dsc|tar\.gz)$/ ) { - if ( $file =~ /\.deb$/ && $conf::ar ) { - - # extract control.tar.gz from .deb with ar, then let tar extract - # the control file itself - open( F, - "($conf::ar p '$file' control.tar.gz | " - . "$conf::tar -xOf - " - . "--use-compress-program $conf::gzip " - . "control) 2>/dev/null |" - ) or return ""; - } elsif ( $file =~ /\.dsc$/ ) { - - # just do a plain grep - debug("get_maint: .dsc, no cmd"); - open( F, "<$file" ) or return ""; - } elsif ( $file =~ /\.tar\.gz$/ ) { - - # let tar extract a file */debian/control - open( F, - "$conf::tar -xOf '$file' " - . "--use-compress-program $conf::gzip " - . "\\*/debian/control 2>&1 |" - ) or return ""; - } else { - return ""; - } - while () { - $maintainer = $1, last if /^Maintainer:\s*(.*)$/i; - } - close(F) or return ""; - } ## end elsif ( $file =~ /\.(deb|dsc|tar\.gz)$/) - - return $maintainer; -} ## end sub get_maintainer($) + open my $fh, "<", $file or return ""; + $md5->addfile($fh); + close $fh; -# -# return a pattern that matches all files that probably belong to one job -# -sub debian_file_stem($) { - my $file = shift; - my ( $pkg, $version ); - - # strip file suffix - $file =~ s,\.(deb|dsc|changes|(orig\.)?tar\.gz|diff\.gz)$,,; - - # if not is *_* (name_version), can't derive a stem and return just - # the file's name - return $file if !( $file =~ /^([^_]+)_([^_]+)/ ); - ( $pkg, $version ) = ( $1, $2 ); - - # strip Debian revision from version - $version =~ s/^(.*)-[\d.+-]+$/$1/; - - return "${pkg}_${version}*"; -} ## end sub debian_file_stem($) + return $md5->hexdigest; +} ## end sub md5sum($) # # output a messages to several destinations @@ -2339,10 +2288,11 @@ sub send_mail($$$) { strftime( "%a, %d %b %Y %T %z", ( localtime(time) ) ); my $message = <<__MESSAGE__; To: $addr -From: Archive Administrator +From: Debian FTP Masters Subject: $subject Date: $date X-Debian: DAK +X-DAK: DAK __MESSAGE__ if ( length $package ) { @@ -2432,16 +2382,16 @@ sub close_log($) { close(STDOUT); close(STDERR); - open( LOG, ">>$conf::logfile" ) + open( LOG, ">>", $conf::logfile ) or die "Cannot open my logfile $conf::logfile: $!\n"; chmod( 0644, $conf::logfile ) or msg( "log", "Cannot set modes of $conf::logfile: $!\n" ); select( ( select(LOG), $| = 1 )[0] ); - open( STDOUT, ">&LOG" ) + open( STDOUT, ">&", \*LOG ) or msg( "log", "$main::progname: Can't redirect stdout to " . "$conf::logfile: $!\n" ); - open( STDERR, ">&LOG" ) + open( STDERR, ">&", \*LOG ) or msg( "log", "$main::progname: Can't redirect stderr to " . "$conf::logfile: $!\n" ); msg( "log", "Restart after SIGHUP\n" );