X-Git-Url: https://www.chiark.greenend.org.uk/ucgi/~ianmdlvl/git?p=dgit.git;a=blobdiff_plain;f=infra%2Fdgit-repos-policy-debian;h=4dab576f1a4257e3bff41aef8ac4f4b1d30105f1;hp=e00fb5a3fe17e96fae3804c23bb054a6a3a1a2bf;hb=f9da2ff21675a630444be1a65ac27fe387581f26;hpb=bef4fbf5bb46be7ddb1e78d6ebca866648aa9dbf

diff --git a/infra/dgit-repos-policy-debian b/infra/dgit-repos-policy-debian
index e00fb5a3..4dab576f 100755
--- a/infra/dgit-repos-policy-debian
+++ b/infra/dgit-repos-policy-debian
@@ -2,7 +2,9 @@
 # dgit repos policy hook script for Debian
 
 use strict;
-$SIG{__WARN__} = sub { die $_[0]; };
+
+use Debian::Dgit qw(:DEFAULT :policyflags);
+setup_sigwarn();
 
 use POSIX;
 use JSON;
@@ -11,19 +13,21 @@ use DBI;
 use IPC::Open2;
 use Data::Dumper;
 
-use Debian::Dgit qw(:DEFAULT :policyflags);
 use Debian::Dgit::Policy::Debian;
 
 initdebug('%');
 enabledebuglevel $ENV{'DGIT_DRS_DEBUG'};
 
+END { $? = 127; } # deliberate exit uses _exit
+
 our $distro = shift @ARGV // die "need DISTRO";
 our $repos = shift @ARGV // die "need DGIT-REPOS-DIR";
 our $dgitlive = shift @ARGV // die "need DGIT-LIVE-DIR";
+our $distrodir = shift @ARGV // die "need DISTRO-DIR";
 our $action = shift @ARGV // die "need ACTION";
 
 our $publicmode = 02775;
-our $new_upload_propagation_slop = 3600*4 + 100;
+our $new_upload_propagation_slop = 3600*4 + 100;# fixme config;
 
 our $poldbh;
 our $pkg;
@@ -64,6 +68,11 @@ our %deliberately;
 # [1] looking for the relevant git tag for the version number and not
 #    caring what that tag refers to.
 #
+#    When we are doing a push to a fresh repo, any version will do: in
+#    this case, this is the first dgit upload of an existing package,
+#    and we trust that the uploader hasn't included in their git
+#    history any previous non-dgit uploads.
+#
 # A wrinkle: if we approved a push recently, we treat NEW as having
 # a version which is in our history.  This is because the package may
 # still be being uploaded.  (We record this using the timestamp of the
@@ -83,48 +92,55 @@ our %deliberately;
 sub apiquery ($) {
     my ($subpath) = @_;
     local $/=undef;
-    my $cmd = "$dgitlive/dgit -d$distro \$DGIT_TEST_OPTS";
+    my $dgit = "$dgitlive/dgit";
+    $dgit = "dgit" if !stat_exists $dgit;
+    my $cmd = "$dgit -d$distro \$DGIT_TEST_OPTS";
     $cmd .= " -".("D" x $debuglevel) if $debuglevel;
     $cmd .= " archive-api-query $subpath";
     printdebug "apiquery $cmd\n";
     $!=0; $?=0; my $json = `$cmd`;
-    defined $json or die "$subpath $! $?";
+    defined $json && !$? or die "$subpath $! $?";
     my $r = decode_json $json;
     my $d = new Data::Dumper([$r], [qw(r)]);
-    printdebug "apiquery $subpath | ", $d->Dump(), "\n" if $debuglevel>=2;
+    printdebug "apiquery $subpath | ", $d->Dump() if $debuglevel>=2;
     return $r;
 }
 
-sub specific_suite_has_vsn_in_our_history ($) {
-    my ($suite) = @_;
-    my $in_suite = apiquery "/dsc_in_suite/$suite/$pkg";
+sub vsn_in_our_history ($) {
+    my ($vsn) = @_;
+
+    my $tagref = "refs/tags/".debiantag $vsn, $distro;
+    printdebug " checking history  vsn=$vsn tagref=$tagref\n";
+    $?=0; my $r = system qw(git show-ref --verify --quiet), $tagref;
+    return 1 if !$r;
+    return 0 if $r==256;
+    die "$pkg tagref $tagref $? $!";
+}
+
+sub specific_suite_has_suitable_vsn ($$) {
+    my ($suite, $vsn_check) = @_; # tests $vsn_check->($version)
+    my $in_suite = apiquery "dsc_in_suite/$suite/$pkg";
     foreach my $entry (@$in_suite) {
 	my $vsn = $entry->{version};
 	die "$pkg ?" unless defined $vsn;
-	my $tag = debiantag $vsn;
-	$?=0; my $r = system qw(git show-ref --verify --quiet), $tag;
-	return 1 if !$r;
-	next if $r==256;
-	die "$pkg tag $tag $? $!";
+	printdebug " checking history found suite=$suite vsn=$vsn\n";
+	return 1 if $vsn_check->($vsn);
     }
     return 0;
 }
 
 sub new_has_vsn_in_our_history () {
-    stat $pkgdir or die "$pkgdir $!";
-    my $mtime = ((stat _)[9]);
-    my $age = time -  $mtime;
-    return 1 if $age < $new_upload_propagation_slop;
-    return specific_suite_has_vsn_in_our_history('new');
+    return specific_suite_has_suitable_vsn('new', \&vsn_in_our_history);
 }
 
-sub good_suite_has_vsn_in_our_history () {
-    my $suites = apiquery "/suites";
+sub good_suite_has_suitable_vsn ($) {
+    my ($vsn_check) = @_; # as for specific_suite_has_specific_vsn
+    my $suites = apiquery "suites";
     foreach my $suitei (@$suites) {
 	my $suite = $suitei->{name};
 	die unless defined $suite;
 	next if $suite =~ m/\bnew$/;
-	return 1 if specific_suite_has_vsn_in_our_history($suite);
+	return 1 if specific_suite_has_suitable_vsn($suite, $vsn_check);
     }
     return 0;
 }
@@ -150,21 +166,28 @@ sub getpackage () {
 }
 
 sub add_taint ($$) {
-    my ($refobj, $reason);
+    my ($refobj, $reason) = @_;
+
+    printdebug "TAINTING $refobj\n",
+        (map { "\%| $_" } split "\n", $reason),
+        "\n";
 
     my $tf = new File::Temp or die $!;
     print $tf "$refobj^0\n" or die $!;
+    flush $tf or die $!;
+    seek $tf,0,0 or die $!;
 
     my $gcfpid = open GCF, "-|";
     defined $gcfpid or die $!;
     if (!$gcfpid) {
 	open STDIN, "<&", $tf or die $!;
-	exec 'git', 'cat-file';
+	exec 'git', 'cat-file', '--batch';
 	die $!;
     }
 
     close $tf or die $!;
     $_ = <GCF>;
+    defined $_ or die;
     m/^(\w+) (\w+) (\d+)\n/ or die "$_ ?";
     my $gitobjid = $1;
     my $gitobjtype = $2;
@@ -178,7 +201,7 @@ sub add_taint ($$) {
     close GCF;
 
     $poldbh->do("INSERT INTO taints".
-		" (package, gitobjid, gitobjtype, gitobjdata, time, comment)",
+		" (package, gitobjid, gitobjtype, gitobjdata, time, comment)".
 		" VALUES (?,?,?,?,?,?)", {},
 		$pkg, $gitobjid, $gitobjtype, $gitobjdata, time, $reason);
 
@@ -186,9 +209,9 @@ sub add_taint ($$) {
     die unless defined $taint_id;
 
     $poldbh->do("INSERT INTO taintoverrides".
-		" (taint_id, deliberately)",
-		" VALUES (?, 'include-questionable-history')", {},
-		$taint_id);
+		" (taint_id, deliberately)".
+		" VALUES (?, '--deliberately-include-questionable-history')", 
+		{}, $taint_id);
 }
 
 sub add_taint_by_tag ($$) {
@@ -199,19 +222,31 @@ sub add_taint_by_tag ($$) {
 	      " removed from NEW (ie, rejected) (or never arrived)");
 }
 
-sub action_check_package () {
-    getpackage();
+sub check_package () {
     return 0 unless $pkg_exists;
     return 0 unless $pkg_secret;
 
+    printdebug "check_package\n";
+
     chdir $pkgdir or die "$pkgdir $!";
-    return if new_has_vsn_in_our_history();
 
-    if (good_suite_has_vsn_in_our_history) {
+    stat '.' or die "$pkgdir $!";
+    my $mtime = ((stat _)[9]);
+    my $age = time -  $mtime;
+    printdebug "check_package age=$age\n";
+
+    if (good_suite_has_suitable_vsn(\&vsn_in_our_history)) {
 	chmod $publicmode, "." or die $!;
+	$pkg_secret = 0;
 	return 0;
     }
 
+    return 0 if $age < $new_upload_propagation_slop;
+
+    return 0 if new_has_vsn_in_our_history();
+
+    printdebug "check_package secret, deleted, tainting\n";
+
     git_for_each_ref('refs/tags', sub {
 	my ($objid,$objtype,$fullrefname,$tagname) = @_;
 	add_taint_by_tag($tagname,$objid);
@@ -220,6 +255,11 @@ sub action_check_package () {
     return FRESHREPO;
 }
 
+sub action_check_package () {
+    getpackage();
+    return check_package();
+}
+
 sub getpushinfo () {
     die unless @ARGV >= 4;
     $version = shift @ARGV;
@@ -231,10 +271,14 @@ sub getpushinfo () {
     }
 }
 
-sub deliberately ($) { return $deliberately{$_[0]}; }
+sub deliberately ($) { return $deliberately{"--deliberately-$_[0]"}; }
 
 sub action_push () {
     getpackage();
+    getpushinfo();
+
+    check_package(); # might make package public, or might add taints
+
     return 0 unless $pkg_exists;
     return 0 unless $pkg_secret;
 
@@ -243,23 +287,24 @@ sub action_push () {
 
     if (deliberately('not-fast-forward')) {
 	add_taint(server_ref($suite),
-		  "suite $suite when --deliberately-not-fast-forward".
+		  "rewound suite $suite; --deliberately-not-fast-forward".
 		  " specified in signed tag $tagname for upload of".
-		  " version $version into suite $suite");
+		  " version $version");
 	return NOFFCHECK|FRESHREPO;
     }
     if (deliberately('include-questionable-history')) {
 	return 0;
     }
-    die "Package is in NEW and has not been accepted or rejected yet;".
+    die "\nPackage is in NEW and has not been accepted or rejected yet;".
 	" use a --deliberately option to specify whether you are".
 	" keeping or discarding the previously pushed history. ".
-	" Please RTFM dgit(1).\n";
+	" Please RTFM dgit(1).\n\n";
 }
 
 sub action_push_confirm () {
     getpackage();
-    die unless @ARGV;
+    getpushinfo();
+    die unless @ARGV >= 1;
     my $freshrepo = shift @ARGV;
 
     my $initq = $poldbh->prepare(<<END);
@@ -268,11 +313,17 @@ sub action_push_confirm () {
 END
     $initq->execute($pkg);
 
+    my @objscatcmd = qw(git);
+    push @objscatcmd, qw(--git-dir), $freshrepo if length $freshrepo;
+    push @objscatcmd, qw(cat-file --batch);
+    debugcmd '|',@objscatcmd if $debuglevel>=2;
+
     my @taintids;
     my $chkinput = tempfile();
     while (my $taint = $initq->fetchrow_hashref()) {
 	push @taintids, $taint->{taint_id};
 	print $chkinput $taint->{gitobjid}, "\n" or die $!;
+	printdebug '|> ', $taint->{gitobjid}, "\n" if $debuglevel>=2;
     }
     flush $chkinput or die $!;
     seek $chkinput,0,0 or die $!;
@@ -280,16 +331,17 @@ END
     my $checkpid = open CHKOUT, "-|" // die $!;
     if (!$checkpid) {
 	open STDIN, "<&", $chkinput or die $!;
-	exec qw(git cat-file --batch) or die $!;
+	exec @objscatcmd or die $!;
     }
 
     my ($taintinfoq,$overridesanyq,$untaintq,$overridesq);
 
     my $overridesstmt = <<END;
-        SELECT deliberately FROM taintoverrides WHERE ( 1
+        SELECT deliberately FROM taintoverrides WHERE (
+            1=0
 END
     my @overridesv = sort keys %deliberately;
-    $overridesstmt .= join '', (<<END x @overridesv);
+    $overridesstmt .= <<END foreach @overridesv;
             OR deliberately = ?
 END
     $overridesstmt .= <<END;
@@ -300,18 +352,21 @@ END
     my $mustreject=0;
 
     while (my $taintid = shift @taintids) {
-	# git cat-file prints a spurious newline after it gets EOF
-	# This is not documented.  I guess it might go away.  So we
-	# just read what we expect and then let it get SIGPIPE.
 	$!=0; $_ = <CHKOUT>;
-	die "$? $!" unless defined $_;
+	die "($taintid @objscatcmd) $!" unless defined $_;
+	printdebug "|< ", $_ if $debuglevel>=2;
 
 	next if m/^\w+ missing$/;
-	die unless m/^(\w+) (\w+) (\d+)\s/;
+	die "($taintid @objscatcmd) $_ ?" unless m/^(\w+) (\w+) (\d+)\s/;
 	my ($objid,$objtype,$nbytes) = ($1,$2,$3);
 
 	my $drop;
-	(read CHKOUT, $drop, $nbytes) == $nbytes or die;
+	(read CHKOUT, $drop, $nbytes) == $nbytes
+	    or die "($taintid @objscatcmd) $!";
+
+	$!=0; $_ = <CHKOUT>;
+	die "($taintid @objscatcmd) $!" unless defined $_;
+	die "($taintid @objscatcmd) $_ ?" if m/\S/;
 
 	$taintinfoq ||= $poldbh->prepare(<<END);
             SELECT package, time, comment FROM taints WHERE taint_id =  ?
@@ -319,7 +374,7 @@ END
         $taintinfoq->execute($taintid);
 
 	my $ti = $taintinfoq->fetchrow_hashref();
-	die unless $ti;
+	die "($taintid)" unless $ti;
 
 	my $timeshow = defined $ti->{time}
 	    ? " at time ".strftime("%Y-%m-%d %H:%M:%S Z", gmtime $ti->{time})
@@ -335,6 +390,8 @@ Taint recorded$timeshow for $pkgshow
 Reason: $ti->{comment}
 END
 
+        printdebug "SQL overrides: @overridesv $taintid /\n$overridesstmt\n";
+
         $overridesq ||= $poldbh->prepare($overridesstmt);
 	$overridesq->execute(@overridesv, $taintid);
 	my ($ovwhy) = $overridesq->fetchrow_array();
@@ -371,13 +428,17 @@ END
     }
 
     if (length $freshrepo) {
-	if (!good_suite_has_vsn_in_our_history()) {
+	if (!good_suite_has_suitable_vsn(sub { 1; })) {
 	    stat $freshrepo or die "$freshrepo $!";
 	    my $oldmode = ((stat _)[2]);
 	    my $oldwrites = $oldmode & 0222;
 	    # remove r and x bits which have corresponding w bits clear
-	    my $newmode = $oldmode & ($oldwrites << 1) & ($oldwrites > 1);
+	    my $newmode = $oldmode &
+		(~0555 | ($oldwrites << 1) | ($oldwrites >> 1));
+	    printdebug sprintf "chmod %#o (was %#o) %s\n",
+	        $newmode, $oldmode, $freshrepo;
 	    chmod $newmode, $freshrepo or die $!;
+	    utime undef, undef, $freshrepo or die $!;
 	}
     }
 
@@ -392,7 +453,7 @@ sub action_check_list () {
 	statpackage();
 	next unless $pkg_exists;
 	next unless $pkg_secret;
-	printdebug "$pkg\n" or die $!;
+	print "$pkg\n" or die $!;
     }
     closedir L or die $!;
     close STDOUT or die $!;
@@ -407,24 +468,43 @@ if (!$fn) {
 }
 
 my $sleepy=0;
-our $rcode = 127;
+my $rcode;
 
-for (;;) {
-    poldb_setup(poldb_path($repos));
-    $stderr = '';
+my $db_busy_exception= 'Debian::Dgit::Policy::Debian::DB_BUSY';
 
-    $rcode = $fn->();
-    die unless defined $rcode;
+my @orgargv = @ARGV;
 
-    eval { $poldbh->commit; };
+for (;;) {
+    @ARGV = @orgargv;
+    eval {
+	poldb_setup(poldb_path($repos), sub {
+	    $poldbh->{HandleError} = sub {
+		return 0 unless $poldbh->err == 5; # SQLITE_BUSY, not in .pm :-(
+		die bless { }, $db_busy_exception;
+	    };
+
+	    eval ($ENV{'DGIT_RPD_TEST_DBLOOP_HOOK'}//'');
+	    die $@ if length $@;
+	    # used by tests/tests/debpolicy-dbretry
+        });
+
+	$stderr = '';
+
+	$rcode = $fn->();
+	die unless defined $rcode;
+
+	$poldbh->commit;
+    };
     last unless length $@;
+    die $@ unless ref $@ eq $db_busy_exception;
 
     die if $sleepy >= 20;
-    print STDERR "[policy database busy, retrying]\n";
-    sleep ++$sleepy;
+    $sleepy++;
+    print STDERR "[policy database busy, retrying (${sleepy}s)]\n";
 
-    $poldbh->rollback;
+    eval { $poldbh->rollback; };
 }
 
-print STDERR $stderr;
-exit $rcode;
+print STDERR $stderr or die $!;
+flush STDERR or die $!;
+_exit $rcode;