our $ignoredirty = 0;
our $rmonerror = 1;
our @deliberatelies;
+our %supersedes;
our $existing_package = 'dpkg';
our $cleanmode = 'dpkg-source';
our $changes_since_version;
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) {
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();
# to control the "tagger" (b) we can do remote signing
my $authline = clogp_authline $clogp;
my $delibs = join(" ", "",@deliberatelies);
+ my $declaredistro = access_basedistro();
open TO, '>', $tfn->('.tmp') or die $!;
print TO <<END or die $!;
object $head
tagger $authline
$package release $cversion for $clogsuite ($csuite) [dgit]
-[dgit distro=$distro$delibs]
+[dgit distro=$declaredistro$delibs]
+END
+ foreach my $ref (sort keys %supersedes) {
+ print TO <<END or die $!;
+[dgit supersede:$ref=$supersedes{$ref}]
END
+ }
+
close TO or die $!;
my $tagobjfn = $tfn->('.tmp');
responder_send_command("param head $head");
responder_send_command("param csuite $csuite");
+ my $forceflag = deliberately('not-fast-forward') ? '+' : '';
+ if ($forceflag && defined $lastpush_hash) {
+ git_for_each_tag_referring($lastpush_hash, sub {
+ my ($objid,$fullrefname,$tagname) = @_;
+ responder_send_command("supersedes $fullrefname=$objid");
+ $supersedes{$fullrefname} = $objid;
+ });
+ }
+
my $tfn = sub { ".git/dgit/tag$_[0]"; };
my $tagobjfn;
create_remote_git_repo();
}
runcmd_ordryrun @git, qw(push),access_giturl(),
- "HEAD:".rrref(), "refs/tags/$tag";
+ $forceflag."HEAD:".rrref(), "refs/tags/$tag";
runcmd_ordryrun @git, qw(update-ref -m), 'dgit push', lrref(), 'HEAD';
if ($we_are_responder) {
$i_param{$1} = $2;
}
+sub i_resp_supersedes ($) {
+ $_[0] =~ m#^(refs/tags/\S+)=(\w+)$#
+ or badproto \*RO, "bad supersedes spec";
+ my $r = system qw(git check-ref-format), $1;
+ die "bad supersedes ref spec ($r)" if $r;
+ $supersedes{$1} = $2;
+}
+
our %i_wanted;
sub i_resp_want ($) {
~ianmdlvl / dgit.git / blobdiff