policy-client-query: dgit: use tainted-objects query

Add the config for controlling policy-client-query calls.  For now we
default to "unknown" everywhere.

If supported, check if tainted objects are reachable from $dgithead,
and report them.

Signed-off-by: Ian Jackson <ijackson@chiark.greenend.org.uk>

1 files changed, 77 insertions, 0 deletions

diff --git a/dgit b/dgit
index 00ad811..f7bfc0f 100755
--- a/dgit
+++ b/dgit
@@ -105,6 +105,7 @@ our %forceopts = map { $_=>0 }
        dsc-changes-mismatch changes-origs-exactly
        uploading-binaries uploading-source-only
        reusing-version
+       push-tainted
        import-gitapply-absurd
        import-gitapply-no-absurd
        import-dsc-with-dgit-field);
@@ -749,6 +750,7 @@ our %defcfg = ('dgit.default.distro' => 'debian',
 	       'dgit.default.sshpsql-dbname' => 'service=projectb',
 	       'dgit.default.aptget-components' => 'main',
 	       'dgit.default.source-only-uploads' => 'ok',
+	       'dgit.default.policy-query-supported-ssh' => 'unknown',
 	       'dgit.dsc-url-proto-ok.http'    => 'true',
 	       'dgit.dsc-url-proto-ok.https'   => 'true',
 	       'dgit.dsc-url-proto-ok.git'     => 'true',
@@ -4560,6 +4562,61 @@ sub sign_changes ($) {
     }
 }
 
+sub tainted_objects_precheck ($$) {
+    my ($json, $dgithead) = @_;
+    my %taints;
+  ROW: foreach my $row (@{ decode_json $json }) {
+	my $objid = $row->{gitobjid};
+	my ($gtype, $dummy) = git_cat_file $objid, undef;
+	next if $gtype eq 'missing';
+	if ($gtype ne $row->{gitobjtype}) {
+	    print STDERR f_ <<'END', $objid, $gtype, $row->{gitobjtype};
+warning: server says object %s type %s is tainted, but here it has type %s
+END
+	}
+	foreach my $override (@{ $row->{overrides} }) {
+	    next ROW if grep { $_ eq $override } @deliberatelies;
+	}
+	push @{ $taints{$objid} }, $row;
+    }
+
+    open GRL, "-|",
+      @git, qw(rev-list --objects --in-commit-order --pretty=format:),
+            $dgithead
+	    or confess "$!";
+    my $trouble = 0;
+    my $found = sub {
+	my ($objid) = @_;
+	my $taints = $taints{$objid};
+	return unless $taints && @$taints;
+	print STDERR f_ "would want to push tainted object %s\n", $objid;
+	foreach my $row (@$taints) {
+	    if (grep m{^--deliberately-}, @{ $row->{overrides} }) {
+		print STDERR f_ " overrideable (--deliberately): %s\n", $row->{comment};
+	    } else {
+		print STDERR f_ " not overrideable: %s\n", $row->{comment};
+	    }
+	    $trouble = 1;
+	}
+    };
+    my $c_commit;
+    while (<GRL>) {
+	if (m{^commit (\w+)$}) {
+	    $c_commit = $1;
+	    $found->($1, __ 'commit');
+	} elsif (m{(^\w{20}\w*) } && defined $c_commit) {
+	    $found->($1, f_ 'object within commit %s', $c_commit);
+	} else {
+	    confess "$_ ?";
+	}
+    }
+    GRL->error and die $!;
+    close GRL or confess "$? $!";
+    forceable_fail [qw(push-tainted)],
+      __ "pushing tainted objects (which server would reject)"
+      if $trouble;
+}
+
 sub dopush () {
     printdebug "actually entering push\n";
 
@@ -4800,6 +4857,26 @@ ENDT
 	          $sourceonlypolicy;
     }
 
+    # Try to detect if we're about to be rejected due to tainted objects
+    my $pq_supported = access_cfg 'policy-query-supported-ssh';
+    if ($pq_supported !~ m/false/) {
+	my @cmd =
+	  (access_cfg_ssh, access_gituserhost(),
+	   access_runeinfo("policy-client-query $package tainted-objects ").
+	   " true");
+	my $json = cmdoutput_errok @cmd;
+	if (!defined $json) {
+	    # "unknown" means try the call, but don't mind if it
+	    # fails.  (This is OK, as a best effort, because then the
+	    # server will enforce the check and this machinery is just
+	    # to prevent late failures.)
+	    failedcmd @cmd unless $pq_supported =~ m/unknown/;
+	} elsif (!length $json) {
+	} else {
+	    tainted_objects_precheck $json, $dgithead;
+	}
+    }
+
     # Perhaps adjust .dsc to contain right set of origs
     changes_update_origs_from_dsc($dsc, $changes, $upstreamversion,
 				  $changesfile)