diff options
Diffstat (limited to 'dgit')
| -rwxr-xr-x | dgit | 148 |
1 files changed, 71 insertions, 77 deletions
@@ -30,7 +30,7 @@ setup_sigwarn(); use IO::Handle; use Data::Dumper; -use LWP::UserAgent; +use WWW::Curl::Easy; use Dpkg::Control::Hash; use File::Path; use File::Spec; @@ -54,6 +54,8 @@ use Debian::Dgit; our $our_version = 'UNRELEASED'; ###substituted### our $absurdity = undef; ###substituted### +$SIG{INT} = 'DEFAULT'; # work around #932841 + our @rpushprotovsn_support = qw(6 5 4); # Reverse order! our $protovsn; @@ -637,20 +639,6 @@ sub progress { our $ua; -sub url_get { - if (!$ua) { - $ua = LWP::UserAgent->new(); - $ua->env_proxy; - } - my $what = $_[$#_]; - progress "downloading $what..."; - my $r = $ua->get(@_) or confess "$!"; - return undef if $r->code == 404; - $r->is_success or fail f_ "failed to fetch %s: %s", - $what, $r->status_line; - return $r->decoded_content(charset => 'none'); -} - our ($dscdata,$dscurl,$dsc,$dsc_checked,$skew_warning_vsn); sub act_local () { return $dryrun_level <= 1; } @@ -1190,56 +1178,72 @@ sub cfg_apply_map ($$$) { $$varref = $_; } -#---------- `ftpmasterapi' archive query method (nascent) ---------- +sub url_fetch ($;@) { + my ($url, %xopts) = @_; + # Ok404 => 1 means give undef for 404 + # AccessBase => 'archive-query' (eg) + # CurlOpts => { key => value } -sub archive_api_query_cmd ($) { - my ($subpath) = @_; - my @cmd = (@curl, qw(-sS)); - my $url = access_cfg('archive-query-url'); - 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; + 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_NOSIGNAL, 1); + $setopt->(CURLOPT_WRITEDATA, \$response_body); + + my $xcurlopts = $xopts{CurlOpts} // { }; + keys %$xcurlopts; + while (my ($k,$v) = each %$xcurlopts) { $setopt->($k,$v); } + + if ($xopts{AccessBase} && $url =~ m#^https://([-.0-9a-z]+)/#) { + foreach my $k ("$xopts{AccessBase}-tls-key", + "$xopts{AccessBase}-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 "query: fetching $url...\n"; + + local $SIG{PIPE} = 'IGNORE'; + + my $x = $curl->perform(); + fail f_ "fetch of %s failed (%s): %s", + $url, $curl->strerror($x), $curl->errbuf + if $x; + + my $code = $curl->getinfo(CURLINFO_HTTP_CODE); + if ($code eq '404' && $xopts{Ok404}) { return undef; } + + fail f_ "fetch of %s gave HTTP code %s", $url, $code + unless $url =~ m#^file://# or $code =~ m/^2/; + return $response_body; +} + +#---------- `ftpmasterapi' archive query method (nascent) ---------- + +sub api_query_raw ($;$) { + my ($subpath, $ok404) = @_; + my $url = access_cfg('archive-query-url'); + $url .= $subpath; + return url_fetch $url, + Ok404 => $ok404, + AccessBase => 'archive-query'; } 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); } @@ -1730,7 +1734,7 @@ sub get_archive_dsc () { foreach my $vinfo (@vsns) { my ($vsn,$vsn_dscurl,$digester,$digest) = @$vinfo; $dscurl = $vsn_dscurl; - $dscdata = url_get($dscurl); + $dscdata = url_fetch($dscurl); if (!$dscdata) { $skew_warning_vsn = $vsn if !defined $skew_warning_vsn; next; @@ -1784,22 +1788,11 @@ sub check_for_git () { my $suffix = access_cfg('git-check-suffix','git-suffix', 'RETURN-UNDEF') // '.git'; my $url = "$prefix/$package$suffix"; - my @cmd = (@curl, qw(-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 - fail +(__ "unexpected results from git check query - "). - Dumper($prefix, $result); - my $code = $1; - if ($code eq '404') { - return 0; - } elsif ($code eq '200') { - return 1; - } else { - die; - } + my $result = url_fetch $url, + CurlOpts => { CURLOPT_NOBODY() => 1 }, + Ok404 => 1, + AccessBase => 'git-check'; + return defined $result; } elsif ($how eq 'true') { return 1; } elsif ($how eq 'false') { @@ -7340,10 +7333,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 () { @@ -7599,6 +7590,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, $_; |