# along with this program. If not, see <http://www.gnu.org/licenses/>.
use strict;
+$SIG{__WARN__} = sub { die $_[0]; };
use IO::Handle;
use Data::Dumper;
'dgit.default.ssh' => 'ssh',
'dgit.default.archive-query' => 'madison:',
'dgit.default.sshpsql-dbname' => 'service=projectb',
- 'dgit-distro.debian.archive-query' => 'sshpsql:',
+ 'dgit-distro.debian.archive-query' => 'ftpmasterapi:',
'dgit-distro.debian.git-host' => 'dgit-git.debian.net',
'dgit-distro.debian.git-user-force' => 'dgit',
'dgit-distro.debian.git-proto' => 'git+ssh://',
'dgit-distro.debian/alioth.git-proto' => 'git+ssh://',
'dgit-distro.debian/alioth.git-path' => '/git/dgit-repos/repos',
'dgit-distro.debian/alioth.git-create' => 'ssh-cmd',
- 'dgit-distro.debian.sshpsql-host' => 'mirror.ftp-master.debian.org',
'dgit-distro.debian.upload-host' => 'ftp-master', # for dput
'dgit-distro.debian.mirror' => 'http://ftp.debian.org/debian/',
'dgit-distro.debian.backports-quirk' => '(squeeze)-backports*',
'dgit-distro.test-dummy.git-url' => "$td/git",
'dgit-distro.test-dummy.git-host' => "git",
'dgit-distro.test-dummy.git-path' => "$td/git",
- 'dgit-distro.test-dummy.archive-query' => "dummycat:$td/aq",
+ 'dgit-distro.test-dummy.archive-query' => "ftpmasterapi:",
+ 'dgit-distro.test-dummy.archive-query-url' => "file://$td/aq/",
'dgit-distro.test-dummy.mirror' => "file://$td/mirror/",
'dgit-distro.test-dummy.upload-host' => 'test-dummy',
);
return $d;
}
+our %rmad;
+
+sub archive_query ($) {
+ my ($method) = @_;
+ my $query = access_cfg('archive-query','RETURN-UNDEF');
+ $query =~ s/^(\w+):// or badcfg "invalid archive-query method \`$query'";
+ my $proto = $1;
+ my $data = $'; #';
+ { no strict qw(refs); &{"${method}_${proto}"}($proto,$data); }
+}
+
+sub pool_dsc_subpath ($$) {
+ my ($vsn,$component) = @_; # $package is implict arg
+ my $prefix = substr($package, 0, $package =~ m/^l/ ? 4 : 1);
+ return "/pool/$component/$prefix/$package/".dscfn($vsn);
+}
+
+#---------- `ftpmasterapi' archive query method (nascent) ----------
+
sub archive_api_query_cmd ($) {
my ($subpath) = @_;
my @cmd = qw(curl -sS);
return @cmd;
}
-our %rmad;
+sub api_query ($$) {
+ use JSON;
+ my ($data, $subpath) = @_;
+ badcfg "ftpmasterapi archive query method takes no data part"
+ if length $data;
+ my @cmd = archive_api_query_cmd($subpath);
+ my $json = cmdoutput @cmd;
+ return decode_json($json);
+}
-sub archive_query ($) {
- my ($method) = @_;
- my $query = access_cfg('archive-query','RETURN-UNDEF');
- $query =~ s/^(\w+):// or badcfg "invalid archive-query method \`$query'";
- my $proto = $1;
- my $data = $'; #';
- { no strict qw(refs); &{"${method}_${proto}"}($proto,$data); }
+sub canonicalise_suite_ftpmasterapi () {
+ my ($proto,$data) = @_;
+ my $suites = api_query($data, 'suites');
+ my @matched;
+ foreach my $entry (@$suites) {
+ next unless grep {
+ my $v = $entry->{$_};
+ defined $v && $v eq $isuite;
+ } qw(codename name);
+ push @matched, $entry;
+ }
+ fail "unknown suite $isuite" unless @matched;
+ my $cn;
+ eval {
+ @matched==1 or die "multiple matches for suite $isuite\n";
+ $cn = "$matched[0]{codename}";
+ defined $cn or die "suite $isuite info has no codename\n";
+ $cn =~ m/^$suite_re$/ or die "suite $isuite maps to bad codename\n";
+ };
+ die "bad ftpmaster api response: $@\n".Dumper(\@matched)
+ if length $@;
+ return $cn;
}
-sub pool_dsc_subpath ($$) {
- my ($vsn,$component) = @_; # $package is implict arg
- my $prefix = substr($package, 0, $package =~ m/^l/ ? 4 : 1);
- return "/pool/$component/$prefix/$package/".dscfn($vsn);
+sub archive_query_ftpmasterapi () {
+ my ($proto,$data) = @_;
+ my $info = api_query($data, "dsc_in_suite/$isuite/$package");
+ my @rows;
+ my $digester = Digest::SHA->new(256);
+ foreach my $entry (@$info) {
+ eval {
+ my $vsn = "$entry->{version}";
+ my ($ok,$msg) = version_check $vsn;
+ die "bad version: $msg\n" unless $ok;
+ my $component = "$entry->{component}";
+ $component =~ m/^$component_re$/ or die "bad component";
+ my $filename = "$entry->{filename}";
+ $filename && $filename !~ m#[^-+:._~0-9a-zA-Z/]|^[/.]|/[/.]#
+ or die "bad filename";
+ my $sha256sum = "$entry->{sha256sum}";
+ $sha256sum =~ m/^[0-9a-f]+$/ or die "bad sha256sum";
+ push @rows, [ $vsn, "/pool/$component/$filename",
+ $digester, $sha256sum ];
+ };
+ die "bad ftpmaster api response: $@\n".Dumper($entry)
+ if length $@;
+ }
+ @rows = sort { -version_compare($a->[0],$b->[0]) } @rows;
+ return @rows;
}
+#---------- `madison' archive query method ----------
+
sub archive_query_madison {
return map { [ @$_[0..1] ] } madison_get_parse(@_);
}
return $r[0][2];
}
+#---------- `sshpsql' archive query method ----------
+
sub sshpsql ($$$) {
my ($data,$runeinfo,$sql) = @_;
if (!length $data) {
my @rows;
my @cmd = (access_cfg_ssh, $userhost,
access_runeinfo("ssh-psql $runeinfo").
- " export LANG=C;".
+ " export LC_MESSAGES=C; export LC_CTYPE=C;".
" ".shellquote qw(psql -A), $dbname, qw(-c), $sql);
printcmd(\*DEBUG,$debugprefix."|",@cmd) if $debug>0;
open P, "-|", @cmd or die $!;
return $rows[0];
}
+#---------- `dummycat' archive query method ----------
+
sub canonicalise_suite_dummycat ($$) {
my ($proto,$data) = @_;
my $dpath = "$data/suite.$isuite";
return sort { -version_compare($a->[0],$b->[0]); } @rows;
}
+#---------- archive query entrypoints and rest of program ----------
+
sub canonicalise_suite () {
return if defined $csuite;
fail "cannot operate on $isuite suite" if $isuite eq 'UNRELEASED';
END
$hash = $lastpush_hash;
} else {
- fail "archive's .dsc refers to ".$dsc_hash.
- " but this is an ancestor of ".$lastpush_hash;
+ fail "git head (".lrref()."=$lastpush_hash) is not a ".
+ "descendant of archive's .dsc hash ($dsc_hash)";
}
} elsif ($dsc) {
$hash = generate_commit_from_dsc();
}
fetch_from_archive() or no_such_package;
my $vcsgiturl = $dsc->{'Vcs-Git'};
- $vcsgiturl =~ s/\s+-b\s+\S+//g;
if (length $vcsgiturl) {
+ $vcsgiturl =~ s/\s+-b\s+\S+//g;
runcmd @git, qw(remote add vcs-git), $vcsgiturl;
}
runcmd @git, qw(reset --hard), lrref();
~ianmdlvl / dgit.git / blobdiff