dgit: archive_api_query_curl: Add a bit of debug

[dgit.git] / dgit

diff --git a/dgit b/dgit
index 0e0ff6575c3e79bc67227b809e36c876b53fb4f1..7e975e121233455a192d1d6b440ee9ef32fef279 100755 (executable)
--- a/dgit
+++ b/dgit
@@ -4,7 +4,7 @@
 #
 # 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
@@ -117,7 +117,6 @@ our $rewritemap = 'dgit-rewrite/map';
 
 our @dpkg_source_ignores = qw(-i(?:^|/)\.git(?:/|$) -I.git);
 
-our (@git) = qw(git);
 our (@dget) = qw(dget);
 our (@curl) = (qw(curl --proto-redir), '-all,http,https', qw(-L));
 our (@dput) = qw(dput);
@@ -1193,54 +1192,59 @@ sub cfg_apply_map ($$$) {
 
 #---------- `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);
 }
 
@@ -1835,7 +1839,7 @@ sub prep_ud () {
 }
 
 sub mktree_in_ud_here () {
-    playtree_setup $gitcfgs{local};
+    playtree_setup();
 }
 
 sub git_write_tree () {
@@ -3883,14 +3887,9 @@ sub clone ($) {
     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";
     }
@@ -7346,10 +7345,8 @@ sub cmd_archive_api_query {
     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 () {
@@ -7605,6 +7602,9 @@ sub parseopts () {
                    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, $_;