From f83446fc224cb0cdf6f2377ca41a9b9f2f4b1d19 Mon Sep 17 00:00:00 2001
From: Colin Watson <cjwatson@debian.org>
Date: Mon, 20 Jul 2015 11:35:45 +0100
Subject: [PATCH] WIP

---
 debian/control |   2 +-
 dgit           | 201 ++++++++++++++++++++++++++++++++++++++++++++++++++++-----
 dgit.1         |   6 +-
 3 files changed, 190 insertions(+), 19 deletions(-)

diff --git a/debian/control b/debian/control
index 88dfdb1..0051e26 100644
--- a/debian/control
+++ b/debian/control
@@ -13,7 +13,7 @@ Depends: perl, libwww-perl, libdpkg-perl, git-core, devscripts, dpkg-dev,
          ${misc:Depends},
          coreutils (>= 8.23-1~) | realpath,
          libdigest-sha-perl, dput, curl,
-         libjson-perl, ca-certificates
+         libjson-perl, ca-certificates, liburi-perl
 Recommends: ssh-client
 Suggests: sbuild
 Architecture: all
diff --git a/dgit b/dgit
index e02a6bd..43ad831 100755
--- a/dgit
+++ b/dgit
@@ -34,6 +34,7 @@ use POSIX;
 use IPC::Open2;
 use Digest::SHA;
 use Digest::MD5;
+use URI::Escape;
 
 use Debian::Dgit;
 
@@ -479,8 +480,8 @@ our %defcfg = ('dgit.default.distro' => 'debian',
 # 'dgit-distro.debian.archive-query-tls-key',
 #    '/etc/ssl/certs/%HOST%.pem:/etc/dgit/%HOST%.pem',
 # ^ this does not work because curl is broken nowadays
-# Fixing #790093 properly will involve providing providing the key
-# in some pacagke and maybe updating these paths.
+# Fixing #790093 properly will involve providing the key in some
+# package and maybe updating these paths.
 #
 # 'dgit-distro.debian.archive-query-tls-curl-args',
 #   '--ca-path=/etc/ssl/ca-debian',
@@ -491,8 +492,23 @@ our %defcfg = ('dgit.default.distro' => 'debian',
 	       'dgit-distro.debian.mirror' => 'http://ftp.debian.org/debian/',
  'dgit-distro.debian.backports-quirk' => '(squeeze)-backports*',
  'dgit-distro.debian-backports.mirror' => 'http://backports.debian.org/debian-backports/',
-	       'dgit-distro.ubuntu.git-check' => 'false',
- 'dgit-distro.ubuntu.mirror' => 'http://archive.ubuntu.com/ubuntu',
+	       'dgit-distro.ubuntu.archive-query' => 'launchpad:',
+	       'dgit-distro.ubuntu.git-check' => 'url',
+	       'dgit-distro.ubuntu.git-check-proto' => 'https://',
+	       'dgit-distro.ubuntu.git-check-suffix' => '/info/refs?service=git-upload-pack',
+	       'dgit-distro.ubuntu.git-create' => 'true',
+	       'dgit-distro.ubuntu.git-host' => 'git.launchpad.net',
+	       'dgit-distro.ubuntu.git-path' => '/ubuntu/+source',
+	       'dgit-distro.ubuntu.git-proto' => 'git+ssh://',
+	       'dgit-distro.ubuntu.git-url-suffix' => '',
+	       'dgit-distro.ubuntu.launchpad-instance' => 'production',
+	       'dgit-distro.ubuntu.launchpad-api-version' => 'devel',
+# 'dgit-distro.ubuntu.launchpad-tls-key',
+#    '/etc/ssl/certs/%HOST%.pem:/etc/dgit/%HOST%.pem',
+# ^ this does not work because curl is broken nowadays
+# Fixing #790093 properly will involve providing the key
+# in some package and maybe updating these paths.
+ 'dgit-distro.ubuntu.mirror' => 'http://archive.ubuntu.com/ubuntu/',
 	       'dgit-distro.test-dummy.ssh' => "$td/ssh",
 	       'dgit-distro.test-dummy.username' => "alice",
 	       'dgit-distro.test-dummy.git-check' => "ssh-cmd",
@@ -738,10 +754,24 @@ sub access_gituserhost () {
     return access_someuserhost('git');
 }
 
+sub access_gitcheckurl () {
+    my $url = access_cfg('git-check-url','git-url','RETURN-UNDEF');
+    if (!length $url) {
+	my $proto = access_cfg('git-check-proto','git-proto','RETURN-UNDEF');
+	return undef unless defined $proto;
+	$url =
+	    $proto.
+	    access_gituserhost().
+	    access_cfg('git-check-path','git-path');
+    }
+    my $suffix = access_cfg('git-check-suffix','git-url-suffix',
+			    'RETURN-UNDEF') // '.git';
+    return "$url/$package$suffix";
+}
+
 sub access_giturl (;$) {
     my ($optional) = @_;
     my $url = access_cfg('git-url','RETURN-UNDEF');
-    my $suffix;
     if (!length $url) {
 	my $proto = access_cfg('git-proto', 'RETURN-UNDEF');
 	return undef unless defined $proto;
@@ -749,10 +779,8 @@ sub access_giturl (;$) {
 	    $proto.
 	    access_gituserhost().
 	    access_cfg('git-path');
-    } else {
-	$suffix = access_cfg('git-url-suffix','RETURN-UNDEF');
     }
-    $suffix //= '.git';
+    my $suffix = access_cfg('git-url-suffix','RETURN-UNDEF') // '.git';
     return "$url/$package$suffix";
 }	       
 
@@ -1089,6 +1117,140 @@ sub archive_query_dummycat ($$) {
     return sort { -version_compare($a->[0],$b->[0]); } @rows;
 }
 
+#---------- `launchpad' archive query method ----------
+
+sub launchpad_lookup_service_root ($) {
+    # Transcribed from launchpadlib/uris.py, omitting edge since that's only
+    # for backward compatibility.
+    my %service_roots = (
+	production => 'https://api.launchpad.net/',
+	qastaging => 'https://api.qastaging.launchpad.net/',
+	staging => 'https://api.staging.launchpad.net/',
+	dev => 'https://api.launchpad.dev/',
+	dogfood => 'https://api.dogfood.paddev.net/',
+	test_dev => 'https://api.launchpad.dev:8085/',
+    );
+    my ($instance) = @_;
+    if (exists $service_roots{$instance}) {
+	return $service_roots{$instance};
+    } else {
+	return $instance;
+    }
+}
+
+sub launchpad_query_cmd ($) {
+    my ($subpath) = @_;
+    my @cmd = qw(curl -sS);
+    my $prefix = '';
+    unless (defined URI->new($subpath)->scheme) {
+	my $instance = access_cfg('launchpad-instance');
+	my $service_root = launchpad_lookup_service_root($instance);
+	if ($service_root !~ m#^https://([-.0-9a-z]+)/#) {
+	    badcfg "unknown Launchpad instance: $instance";
+	}
+	my $api_version = access_cfg('launchpad-api-version');
+	$prefix = $service_root.$api_version.'/';
+    }
+    my $host = $1;
+    my $keys = access_cfg('launchpad-tls-key','RETURN-UNDEF') // '';
+    foreach my $key (split /\:/, $keys) {
+	$key =~ s/\%HOST\%/$host/g;
+	if (!stat $key) {
+	    fail "stat $key: $!" unless $!==ENOENT;
+	    next;
+	}
+	fail "config requested specific TLS key but do not know".
+	    " how to get curl to use exactly that EE key ($key)";
+#	push @cmd, "--cacert", $key, "--capath", "/dev/enoent";
+#       # Sadly the above line does not work because of changes
+#       # to gnutls.   The real fix for #790093 may involve
+#       # new curl options.
+	last;
+    }
+    # Fixing #790093 properly will involve providing a value
+    # for this on clients.
+    my $kargs = access_cfg('launchpad-tls-curl-ca-args','RETURN-UNDEF');
+    push @cmd, split / /, $kargs if defined $kargs;
+    push @cmd, $prefix.$subpath;
+    return @cmd;
+}
+
+sub launchpad_query ($$) {
+    use JSON;
+    my ($data, $subpath) = @_;
+    badcfg "launchpad archive query method takes no data part"
+	if length $data;
+    my @cmd = launchpad_query_cmd($subpath);
+    my $json = cmdoutput @cmd;
+    return decode_json($json);
+}
+
+sub launchpad_split_suite ($) {
+    # Split a suite name into series and "pocket" (e.g. -proposed)
+    # parts, with the pocket canonicalised for use with the Launchpad
+    # API.  The set of available pockets is hardcoded but has not
+    # changed in a long time.
+    my ($suite) = @_;
+    if ($suite =~ /^(.*)-(security|updates|proposed|backports)$/) {
+	return $1, ucfirst($2);
+    } else {
+	return $suite, 'Release';
+    }
+}
+
+sub canonicalise_suite_launchpad () {
+    # Canonicalisation is trivial, but check that the suite exists.
+    my ($proto, $data) = @_;
+    my $basedistro = access_basedistro();
+    my ($iseries, $ipocket) = launchpad_split_suite($isuite);
+    my $series = launchpad_query($data, "$basedistro/series");
+    fail "unknown series $iseries" unless grep {
+	my $v = $_->{name};
+	defined $v && $v eq $iseries;
+    } @{$series->{entries}};
+    return $isuite;
+}
+
+sub archive_query_launchpad () {
+    my ($proto, $data) = @_;
+    my $basedistro = access_basedistro();
+    my ($iseries, $ipocket) = launchpad_split_suite($isuite);
+    my $qseries = uri_escape($iseries);
+    my $qpocket = uri_escape($ipocket);
+    my $qpackage = uri_escape($package);
+    my $info = launchpad_query($data, "$basedistro/+archive/primary".
+	"?ws.op=getPublishedSources&distro_series=/$basedistro/$qseries".
+	"&pocket=$qpocket&source_name=$qpackage&exact_match=true&".
+	"status=Published");
+    my @rows;
+    my $digester = Digest::SHA->new(256);
+    foreach my $entry (@{$info->{entries}}) {
+	eval {
+	    my $vsn = $entry->{source_package_version};
+	    my ($ok, $msg) = version_check $vsn;
+	    die "bad version: $msg\n" unless $ok;
+	    my $component = $entry->{component_name};
+	    $component =~ m/^$component_re$/ or die "bad component";
+	    my $files = launchpad_query($data,
+		"$entry->{self_link}?ws.op=sourceFileUrls&include_meta=true");
+	    my $dsc;
+	    foreach my $file (@$files) {
+		if ($file->{url} =~ /\.dsc$/ and exists $file->{sha256}) {
+		    $dsc = $file;
+		    last;
+		}
+	    }
+	    die "no usable .dsc in sourceFileUrls response:\n".Dumper($files)
+		unless defined $dsc;
+	    push @rows, [ $vsn, $dsc->{url}, $digester, $dsc->{sha256} ];
+	};
+	die "bad launchpad api response: $@\n".Dumper($entry)
+	    if length $@;
+    }
+    @rows = sort { -version_compare($a->[0], $b->[0]) } @rows;
+    return @rows;
+}
+
 #---------- archive query entrypoints and rest of program ----------
 
 sub canonicalise_suite () {
@@ -1105,7 +1267,11 @@ sub get_archive_dsc () {
     my @vsns = archive_query('archive_query');
     foreach my $vinfo (@vsns) {
 	my ($vsn,$subpath,$digester,$digest) = @$vinfo;
-	$dscurl = access_cfg('mirror').$subpath;
+	if (defined URI->new($subpath)->scheme) {
+	    $dscurl = $subpath;
+	} else {
+	    $dscurl = access_cfg('mirror').$subpath;
+	}
 	$dscdata = url_get($dscurl);
 	if (!$dscdata) {
 	    $skew_warning_vsn = $vsn if !defined $skew_warning_vsn;
@@ -1154,20 +1320,21 @@ sub check_for_git () {
 	failedcmd @cmd unless $r =~ m/^[01]$/;
 	return $r+0;
     } elsif ($how eq 'url') {
-	my $prefix = access_cfg('git-check-url','git-url');
-	my $suffix = access_cfg('git-check-suffix','git-suffix',
-				'RETURN-UNDEF') // '.git';
-	my $url = "$prefix/$package$suffix";
+	my $url = access_gitcheckurl();
 	my @cmd = (qw(curl -sS -I), $url);
 	my $result = cmdoutput @cmd;
 	$result =~ s/^\S+ 200 .*\n\r?\n//;
 	# curl -sS -I with https_proxy prints
 	# HTTP/1.0 200 Connection established
-	$result =~ m/^\S+ (404|200) /s or
+	# Launchpad (at least) returns 401 rather than 404, since for an
+	# anonymous request "not found" might in fact mean that the
+	# repository is private, and so the user-agent needs to be given
+	# a chance to try HTTP basic auth.
+	$result =~ m/^\S+ (404|401|200) /s or
 	    fail "unexpected results from git check query - ".
-	        Dumper($prefix, $result);
+	        Dumper($url, $result);
 	my $code = $1;
-	if ($code eq '404') {
+	if ($code eq '404' or $code eq '401') {
 	    return 0;
 	} elsif ($code eq '200') {
 	    return 1;
@@ -1484,7 +1651,7 @@ sub complete_file_from_dsc ($$) {
 	$furl .= "/$f";
 	die "$f ?" unless $f =~ m/^\Q${package}\E_/;
 	die "$f ?" if $f =~ m#/#;
-	runcmd_ordryrun_local @curl,qw(-o),$tf,'--',"$furl";
+	runcmd_ordryrun_local @curl,qw(-L -o),$tf,'--',"$furl";
 	return 0 if !act_local();
 	$downloaded = 1;
     }
diff --git a/dgit.1 b/dgit.1
index 926a9c6..9dada34 100644
--- a/dgit.1
+++ b/dgit.1
@@ -714,13 +714,17 @@ or when pushing and
 .TP
 .BR dgit-distro. \fIdistro\fR .git-check " " true | false | url | ssh-cmd
 .TP
+.BI dgit-distro. distro .git-check-proto
+.TP
+.BI dgit-distro. distro .git-check-path
+.TP
 .BI dgit-distro. distro .git-check-suffix
 .TP
 .BR dgit-distro. \fIdistro\fR .diverts.divert " " new-distro | / \fIdistro-suffix\fR
 .TP
 .BI dgit-distro. distro .git-create " " ssh-cmd | true
 .TP
-.BR dgit-distro. \fIdistro\fR .archive-query " " ftpmasterapi: " | " madison: "\fIdistro\fR | " dummycat: "\fI/path\fR  | " sshpsql: \fIuser\fR @ \fIhost\fR : \fIdbname\fR
+.BR dgit-distro. \fIdistro\fR .archive-query " " ftpmasterapi: " | " madison: "\fIdistro\fR | " dummycat: "\fI/path\fR | " sshpsql: \fIuser\fR @ \fIhost\fR : \fIdbname\fR | " launchpad: "
 .TP
 .BR dgit-distro. \fIdistro\fR .archive-query- ( url | tls-key | curl-ca-args )
 .TP
-- 
2.7.4