1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
|
# -*- Mode: cperl; coding: utf-8; cperl-indent-level: 4 -*-
# vim: ts=4 sts=4 sw=4:
package CPAN::HTTP::Client;
use strict;
use vars qw(@ISA);
use CPAN::HTTP::Credentials;
use HTTP::Tiny 0.005;
$CPAN::HTTP::Client::VERSION = $CPAN::HTTP::Client::VERSION = "1.9600";
# CPAN::HTTP::Client is adapted from parts of cpanm by Tatsuhiko Miyagawa
# and parts of LWP by Gisle Aas
sub new {
my $class = shift;
my %args = @_;
for my $k ( keys %args ) {
$args{$k} = '' unless defined $args{$k};
}
$args{no_proxy} = [split(",", $args{no_proxy}) ] if $args{no_proxy};
return bless \%args, $class;
}
# This executes a request with redirection (up to 5) and returns the
# response structure generated by HTTP::Tiny
#
# If authentication fails, it will attempt to get new authentication
# information and repeat up to 5 times
sub mirror {
my($self, $uri, $path) = @_;
my $want_proxy = $self->_want_proxy($uri);
my $http = HTTP::Tiny->new(
$want_proxy ? (proxy => $self->{proxy}) : ()
);
my ($response, %headers);
my $retries = 0;
while ( $retries++ < 5 ) {
$response = $http->mirror( $uri, $path, {headers => \%headers} );
if ( $response->{status} eq '401' ) {
last unless $self->_get_auth_params( $response, 'non_proxy' );
}
elsif ( $response->{status} eq '407' ) {
last unless $self->_get_auth_params( $response, 'proxy' );
}
else {
last; # either success or failure
}
my %headers = (
$self->_auth_headers( $uri, 'non_proxy' ),
( $want_proxy ? $self->_auth_headers($uri, 'proxy') : () ),
);
}
return $response;
}
sub _want_proxy {
my ($self, $uri) = @_;
return unless $self->{proxy};
my($host) = $uri =~ m|://([^/:]+)|;
return ! grep { $host =~ /\Q$_\E$/ } @{ $self->{no_proxy} || [] };
}
# Generates the authentication headers for a given mode
# C<mode> is 'proxy' or 'non_proxy'
# C<_${mode}_type> is 'basic' or 'digest'
# C<_${mode}_params> will be the challenge parameters from the 401/407 headers
sub _auth_headers {
my ($self, $uri, $mode) = @_;
# Get names for our mode-specific attributes
my ($type_key, $param_key) = map {"_" . $mode . $_} qw/_type _params/;
# If _prepare_auth has not been called, we can't prepare headers
return unless $self->{$type_key};
# Get user credentials for mode
my $cred_method = "get_" . ($mode ? "proxy" : "non_proxy") ."_credentials";
my ($user, $pass) = return CPAN::HTTP::Credentials->$cred_method;
# Generate the header for the mode & type
my $header = $mode eq 'proxy' ? 'Proxy-Authorization' : 'Authorization';
my $value_method = "_" . $self->{$type_key} . "_auth";
my $value = $self->$value_method($user, $pass, $self->{$param_key}, $uri);
# If we didn't get a value, we didn't have the right modules available
return $value ? ( $header, $value ) : ();
}
# Extract authentication parameters from headers, but clear any prior
# credentials if we failed (so we might prompt user for password again)
sub _get_auth_params {
my ($self, $response, $mode) = @_;
my $prefix = $mode eq 'proxy' ? 'Proxy' : 'WWW';
my ($type_key, $param_key) = map {"_" . $mode . $_} qw/_type _params/;
if ( ! $response->{success} ) { # auth failed
my $method = "clear_${mode}_credentials";
CPAN::HTTP::Credentials->$method;
delete $self->{$_} for $type_key, $param_key;
}
($self->{$type_key}, $self->{$param_key}) =
$self->_get_challenge( $response, "${prefix}-Authenticate");
return $self->{$type_key};
}
# Extract challenge type and parameters for a challenge list
sub _get_challenge {
my ($self, $response, $auth_header) = @_;
my $auth_list = $response->{headers}(lc $auth_header);
return unless defined $auth_list;
$auth_list = [$auth_list] unless ref $auth_list;
for my $challenge (@$auth_list) {
$challenge =~ tr/,/;/; # "," is used to separate auth-params!!
($challenge) = $self->split_header_words($challenge);
my $scheme = shift(@$challenge);
shift(@$challenge); # no value
$challenge = { @$challenge }; # make rest into a hash
unless ($scheme =~ /^(basic|digest)$/) {
next; # bad scheme
}
$scheme = $1; # untainted now
return ($scheme, $challenge);
}
return;
}
# Generate a basic authentication header value
sub _basic_auth {
my ($self, $user, $pass) = @_;
unless ( $CPAN::META->has_usable('MIME::Base64') ) {
$CPAN::Frontend->mywarn(
"MIME::Base64 is required for 'Basic' style authentication"
);
return;
}
return "Basic " . MIME::Base64::encode_base64("$user\:$pass", q{});
}
# Generate a digest authentication header value
sub _digest_auth {
my ($self, $user, $pass, $auth_param, $uri) = @_;
unless ( $CPAN::META->has_usable('Digest::MD5') ) {
$CPAN::Frontend->mywarn(
"Digest::MD5 is required for 'Digest' style authentication"
);
return;
}
my $nc = sprintf "%08X", ++$self->{_nonce_count}{$auth_param->{nonce}};
my $cnonce = sprintf "%8x", time;
my ($path) = $uri =~ m{^\w+?://[^/]+(/.*)$};
$path = "/" unless defined $path;
my $md5 = Digest::MD5->new;
my(@digest);
$md5->add(join(":", $user, $auth_param->{realm}, $pass));
push(@digest, $md5->hexdigest);
$md5->reset;
push(@digest, $auth_param->{nonce});
if ($auth_param->{qop}) {
push(@digest, $nc, $cnonce, ($auth_param->{qop} =~ m|^auth[,;]auth-int$|) ? 'auth' : $auth_param->{qop});
}
$md5->add(join(":", 'GET', $path));
push(@digest, $md5->hexdigest);
$md5->reset;
$md5->add(join(":", @digest));
my($digest) = $md5->hexdigest;
$md5->reset;
my %resp = map { $_ => $auth_param->{$_} } qw(realm nonce opaque);
@resp{qw(username uri response algorithm)} = ($user, $path, $digest, "MD5");
if (($auth_param->{qop} || "") =~ m|^auth([,;]auth-int)?$|) {
@resp{qw(qop cnonce nc)} = ("auth", $cnonce, $nc);
}
my(@order) =
qw(username realm qop algorithm uri nonce nc cnonce response opaque);
my @pairs;
for (@order) {
next unless defined $resp{$_};
push(@pairs, "$_=" . qq("$resp{$_}"));
}
my $auth_value = "Digest " . join(", ", @pairs);
return $auth_value;
}
# split_header_words adapted from HTTP::Headers::Util
sub split_header_words {
my ($self, @words) = @_;
my @res = $self->_split_header_words(@words);
for my $arr (@res) {
for (my $i = @$arr - 2; $i >= 0; $i -= 2) {
$arr->[$i] = lc($arr->[$i]);
}
}
return @res;
}
sub _split_header_words {
my($self, @val) = @_;
my @res;
for (@val) {
my @cur;
while (length) {
if (s/^\s*(=*[^\s=;,]+)//) { # 'token' or parameter 'attribute'
push(@cur, $1);
# a quoted value
if (s/^\s*=\s*\"([^\"\\]*(?:\\.[^\"\\]*)*)\"//) {
my $val = $1;
$val =~ s/\\(.)/$1/g;
push(@cur, $val);
# some unquoted value
}
elsif (s/^\s*=\s*([^;,\s]*)//) {
my $val = $1;
$val =~ s/\s+$//;
push(@cur, $val);
# no value, a lone token
}
else {
push(@cur, undef);
}
}
elsif (s/^\s*,//) {
push(@res, [@cur]) if @cur;
@cur = ();
}
elsif (s/^\s*;// || s/^\s+//) {
# continue
}
else {
die "This should not happen: '$_'";
}
}
push(@res, \@cur) if @cur;
}
@res;
}
1;
|