From d4e236d288ddf32a57a4e1ebe9d7de9f6d5f99d9 Mon Sep 17 00:00:00 2001
From: Ian Jackson <ijackson@chiark.greenend.org.uk>
Date: Wed, 4 Jul 2018 23:24:09 +0100
Subject: [PATCH] WIP

---
 dgit | 75 +++++++++++++++++++++++++++++++++++++++++++++++-------------
 1 file changed, 59 insertions(+), 16 deletions(-)

diff --git a/dgit b/dgit
index ffdfecdd..f18236a7 100755
--- a/dgit
+++ b/dgit
@@ -614,6 +614,7 @@ our %defcfg = ('dgit.default.distro' => 'debian',
 	       'dgit.default.sshpsql-dbname' => 'service=projectb',
 	       'dgit.default.aptget-components' => 'main',
 	       'dgit.default.dgit-tag-format' => 'new,old,maint',
+	       'dgit.default.source-only-uploads' => 'ok',
 	       'dgit.dsc-url-proto-ok.http'    => 'true',
 	       'dgit.dsc-url-proto-ok.https'   => 'true',
 	       'dgit.dsc-url-proto-ok.git'     => 'true',
@@ -628,6 +629,7 @@ our %defcfg = ('dgit.default.distro' => 'debian',
 	       'dgit-distro.debian.git-check' => 'url',
 	       'dgit-distro.debian.git-check-suffix' => '/info/refs',
 	       'dgit-distro.debian.new-private-pushers' => 't',
+	       'dgit-distro.debian.source-only-uploads' => 'not-wholly-new',
 	       'dgit-distro.debian/push.git-url' => '',
 	       'dgit-distro.debian/push.git-host' => 'push.dgit.debian.org',
 	       'dgit-distro.debian/push.git-user-force' => 'dgit',
@@ -1179,6 +1181,12 @@ sub file_in_archive_ftpmasterapi {
     my $info = api_query($data, "file_in_archive/$pat", 1);
 }
 
+sub package_wholly_new_ftpmasterapi {
+    my ($proto,$data,$pkg) = @_;
+    my $info = api_query($data,"madison?package=${pkg}&f=json");
+    return !!@$info;
+}
+
 #---------- `aptget' archive query method ----------
 
 our $aptget_base;
@@ -1342,34 +1350,55 @@ sub archive_query_aptget {
 }
 
 sub file_in_archive_aptget () { return undef; }
+sub package_wholly_new_aptget () { return undef; }
 
 #---------- `dummyapicat' archive query method ----------
 
 sub archive_query_dummycatapi { archive_query_ftpmasterapi @_; }
 sub canonicalise_suite_dummycatapi { canonicalise_suite_ftpmasterapi @_; }
 
-sub file_in_archive_dummycatapi ($$$) {
-    my ($proto,$data,$filename) = @_;
+sub dummycatapi_run_in_mirror ($@) {
+    # runs $fn with FIA open onto rune
+    my ($rune, $argl, $fn) = @_;
+
     my $mirror = access_cfg('mirror');
     $mirror =~ s#^file://#/# or die "$mirror ?";
-    my @out;
-    my @cmd = (qw(sh -ec), '
-            cd "$1"
-            find -name "$2" -print0 |
-            xargs -0r sha256sum
-        ', qw(x), $mirror, $filename);
+    my @cmd = (qw(sh -ec), 'cd "$1"; shift'."\n".$rune,
+	       qw(x), $mirror, @$argl);
     debugcmd "-|", @cmd;
     open FIA, "-|", @cmd or die $!;
-    while (<FIA>) {
-	chomp or die;
-	printdebug "| $_\n";
-	m/^(\w+)  (\S+)$/ or die "$_ ?";
-	push @out, { sha256sum => $1, filename => $2 };
-    }
-    close FIA or die failedcmd @cmd;
+    my $r = $fn->();
+    close FIA or ($!==0 && $?==141) die failedcmd @cmd;
+    return $r;
+}
+
+sub file_in_archive_dummycatapi ($$$) {
+    my ($proto,$data,$filename) = @_;
+    my @out;
+    dummycatapi_run_in_mirror '
+            find -name "$1" -print0 |
+            xargs -0r sha256sum
+    ', [$filename], sub {
+	while (<FIA>) {
+	    chomp or die;
+	    printdebug "| $_\n";
+	    m/^(\w+)  (\S+)$/ or die "$_ ?";
+	    push @out, { sha256sum => $1, filename => $2 };
+	}
+    };
     return \@out;
 }
 
+sub package_wholly_new_dummycatapi {
+    my ($proto,$data,$pkg) = @_;
+    dummycatapi_run_in_mirror "
+            find -name ${pkg}_*.dsc
+    ", [], sub {
+	undef $/;
+	!!<FIA>;
+    };
+}
+
 #---------- `madison' archive query method ----------
 
 sub archive_query_madison {
@@ -1420,6 +1449,7 @@ sub canonicalise_suite_madison {
 }
 
 sub file_in_archive_madison { return undef; }
+sub package_wholly_new_madison { return undef; }
 
 #---------- `sshpsql' archive query method ----------
 
@@ -1497,6 +1527,7 @@ END
 }
 
 sub file_in_archive_sshpsql ($$$) { return undef; }
+sub package_wholly_new_sshpsql ($$$) { return undef; }
 
 #---------- `dummycat' archive query method ----------
 
@@ -1541,6 +1572,7 @@ sub archive_query_dummycat ($$) {
 }
 
 sub file_in_archive_dummycat () { return undef; }
+sub package_wholly_new_dummycat () { return undef; }
 
 #---------- tag format handling ----------
 
@@ -4419,7 +4451,18 @@ END
 	unless forceing [qw(dsc-changes-mismatch)];
 
     # Check whether this is a source only upload
-    xxxx
+    my $hasdebs = $changes->{Files} =~ m{\.deb$}m;
+    my $sourconlypolicy = access_cfg 'source-only-uploads';
+    if ($sourconlypolicy eq 'ok') {
+    } elsif ($sourconlypolicy eq 'always') {
+	forceable_fail [qw(uploading-binaries)],
+	    "uploading binaries, although distroy policy is source only";
+    } elsif ($sourconlypolicy eq 'never') {
+	forceable_fail [qw(uploading-source-only)],
+	    "source-only upload, although distroy policy requires .debs";
+    } elsif ($sourconlypolicy eq 'not-wholly-new') {
+	if ($new_package) {
+	    my $have = archive_query('package_', 
 
     # Perhaps adjust .dsc to contain right set of origs
     changes_update_origs_from_dsc($dsc, $changes, $upstreamversion,
-- 
2.30.2