#
# Copyright (C)2013-2019 Ian Jackson
# Copyright (C)2017-2019 Sean Whitton
-# Copyright (C)2019 Matthew Vernon / Sanger Institute
+# Copyright (C)2019 Matthew Vernon / Genome Research Limited
#
# This program is free software: you can redistribute it and/or modify
# it under the terms of the GNU General Public License as published by
#---------- `ftpmasterapi' archive query method (nascent) ----------
-sub archive_api_query_cmd ($) {
- my ($subpath) = @_;
- my @cmd = (@curl, qw(-sS));
- my $url = access_cfg('archive-query-url');
+sub archive_api_query_curl ($) {
+ my ($url) = @_;
+
+ use WWW::Curl::Easy;
+
+ my $curl = WWW::Curl::Easy->new;
+ my $setopt = sub {
+ my ($k,$v) = @_;
+ my $x = $curl->setopt($k, $v);
+ confess "$k $v ".$curl->strerror($x)." ?" if $x;
+ };
+
+ my $response_body;
+ $setopt->(CURLOPT_REDIR_PROTOCOLS, CURLPROTO_HTTPS|CURLPROTO_HTTP);
+ $setopt->(CURLOPT_URL, $url);
+ $setopt->(CURLOPT_WRITEDATA, \$response_body);
+
if ($url =~ m#^https://([-.0-9a-z]+)/#) {
- my $host = $1;
- my $keys = access_cfg('archive-query-tls-key','RETURN-UNDEF') //'';
- foreach my $key (split /\:/, $keys) {
- $key =~ s/\%HOST\%/$host/g;
- if (!stat $key) {
- fail "for $url: stat $key: $!" unless $!==ENOENT;
- next;
- }
- fail f_ "config requested specific TLS key but do not know".
- " how to get curl to use exactly that EE key (%s)",
- $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;
+ foreach my $k (qw(archive-query-tls-key
+ archive-query-tls-curl-ca-args)) {
+ fail "config option $k is obsolete and no longer supported"
+ if defined access_cfg($k, 'RETURN-UNDEF');
}
- # Fixing #790093 properly will involve providing a value
- # for this on clients.
- my $kargs = access_cfg('archive-query-tls-curl-ca-args','RETURN-UNDEF');
- push @cmd, split / /, $kargs if defined $kargs;
}
- push @cmd, $url.$subpath;
- return @cmd;
+
+ printdebug "archive api query: fetching $url...\n";
+
+ my $x = $curl->perform();
+ fail f_ "fetch of %s failed (%s): %s",
+ $url, $curl->strerror($x), $curl->errbuf
+ if $x;
+
+ return $curl->getinfo(CURLINFO_HTTP_CODE), $response_body;
+}
+
+sub api_query_raw ($;$) {
+ my ($subpath, $ok404) = @_;
+ my $url = access_cfg('archive-query-url');
+ $url .= $subpath;
+ my ($code,$json) = archive_api_query_curl($url);
+ return undef if $code eq '404' && $ok404;
+ fail f_ "fetch of %s gave HTTP code %s", $url, $code
+ unless $url =~ m#^file://# or $code =~ m/^2/;
+ return $json;
}
sub api_query ($$;$) {
- use JSON;
my ($data, $subpath, $ok404) = @_;
+ use JSON;
badcfg __ "ftpmasterapi archive query method takes no data part"
if length $data;
- my @cmd = archive_api_query_cmd($subpath);
- my $url = $cmd[$#cmd];
- push @cmd, qw(-w %{http_code});
- my $json = cmdoutput @cmd;
- unless ($json =~ s/\d+\d+\d$//) {
- failedcmd_report_cmd undef, @cmd;
- fail __ "curl failed to print 3-digit HTTP code";
- }
- my $code = $&;
- return undef if $code eq '404' && $ok404;
- fail f_ "fetch of %s gave HTTP code %s", $url, $code
- unless $url =~ m#^file://# or $code =~ m/^2/;
+ my $json = api_query_raw $subpath, $ok404;
+ return undef unless defined $json;
return decode_json($json);
}
}
sub mktree_in_ud_here () {
- playtree_setup $gitcfgs{local};
+ playtree_setup();
}
sub git_write_tree () {
record_maindir();
setup_new_tree();
clone_set_head();
- my $giturl = access_giturl(1);
- if (defined $giturl) {
- runcmd @git, qw(remote add), 'origin', $giturl;
- }
if ($hasgit) {
progress __ "fetching existing git history";
git_fetch_us();
- runcmd_ordryrun_local @git, qw(fetch origin);
} else {
progress __ "starting new git history";
}
badusage __ "need only 1 subpath argument" unless @ARGV==1;
my ($subpath) = @ARGV;
local $isuite = 'DGIT-API-QUERY-CMD';
- my @cmd = archive_api_query_cmd($subpath);
- push @cmd, qw(-f);
- debugcmd ">",@cmd;
- exec @cmd or fail f_ "exec curl: %s\n", $!;
+ my $json = api_query_raw $subpath;
+ print $json or die "$!";
}
sub repos_server_url () {
f_ "%s: warning: ignoring unknown force option %s\n",
$us, $_;
$_='';
+ } elsif (m/^--for-push$/s) {
+ push @ropts, $_;
+ $access_forpush = 1;
} elsif (m/^--config-lookup-explode=(.+)$/s) {
# undocumented, for testing
push @ropts, $_;