1 | package LWP::Protocol::http;
|
---|
2 |
|
---|
3 | use strict;
|
---|
4 |
|
---|
5 | require HTTP::Response;
|
---|
6 | require HTTP::Status;
|
---|
7 | require Net::HTTP;
|
---|
8 |
|
---|
9 | use vars qw(@ISA @EXTRA_SOCK_OPTS);
|
---|
10 |
|
---|
11 | require LWP::Protocol;
|
---|
12 | @ISA = qw(LWP::Protocol);
|
---|
13 |
|
---|
14 | my $CRLF = "\015\012";
|
---|
15 |
|
---|
16 | sub _new_socket
|
---|
17 | {
|
---|
18 | my($self, $host, $port, $timeout) = @_;
|
---|
19 | my $conn_cache = $self->{ua}{conn_cache};
|
---|
20 | if ($conn_cache) {
|
---|
21 | if (my $sock = $conn_cache->withdraw($self->socket_type, "$host:$port")) {
|
---|
22 | return $sock if $sock && !$sock->can_read(0);
|
---|
23 | # if the socket is readable, then either the peer has closed the
|
---|
24 | # connection or there are some garbage bytes on it. In either
|
---|
25 | # case we abandon it.
|
---|
26 | $sock->close;
|
---|
27 | }
|
---|
28 | }
|
---|
29 |
|
---|
30 | local($^W) = 0; # IO::Socket::INET can be noisy
|
---|
31 | my $sock = $self->socket_class->new(PeerAddr => $host,
|
---|
32 | PeerPort => $port,
|
---|
33 | LocalAddr => $self->{ua}{local_address},
|
---|
34 | Proto => 'tcp',
|
---|
35 | Timeout => $timeout,
|
---|
36 | KeepAlive => !!$conn_cache,
|
---|
37 | SendTE => 1,
|
---|
38 | $self->_extra_sock_opts($host, $port),
|
---|
39 | );
|
---|
40 |
|
---|
41 | unless ($sock) {
|
---|
42 | # IO::Socket::INET leaves additional error messages in $@
|
---|
43 | my $status = "Can't connect to $host:$port";
|
---|
44 | if ($@ =~ /\bconnect: (.*)/ ||
|
---|
45 | $@ =~ /\b(Bad hostname)\b/ ||
|
---|
46 | $@ =~ /\b(certificate verify failed)\b/ ||
|
---|
47 | $@ =~ /\b(Crypt-SSLeay can't verify hostnames)\b/
|
---|
48 | ) {
|
---|
49 | $status .= " ($1)";
|
---|
50 | }
|
---|
51 | die "$status\n\n$@";
|
---|
52 | }
|
---|
53 |
|
---|
54 | # perl 5.005's IO::Socket does not have the blocking method.
|
---|
55 | eval { $sock->blocking(0); };
|
---|
56 |
|
---|
57 | $sock;
|
---|
58 | }
|
---|
59 |
|
---|
60 | sub socket_type
|
---|
61 | {
|
---|
62 | return "http";
|
---|
63 | }
|
---|
64 |
|
---|
65 | sub socket_class
|
---|
66 | {
|
---|
67 | my $self = shift;
|
---|
68 | (ref($self) || $self) . "::Socket";
|
---|
69 | }
|
---|
70 |
|
---|
71 | sub _extra_sock_opts # to be overridden by subclass
|
---|
72 | {
|
---|
73 | return @EXTRA_SOCK_OPTS;
|
---|
74 | }
|
---|
75 |
|
---|
76 | sub _check_sock
|
---|
77 | {
|
---|
78 | #my($self, $req, $sock) = @_;
|
---|
79 | }
|
---|
80 |
|
---|
81 | sub _get_sock_info
|
---|
82 | {
|
---|
83 | my($self, $res, $sock) = @_;
|
---|
84 | if (defined(my $peerhost = $sock->peerhost)) {
|
---|
85 | $res->header("Client-Peer" => "$peerhost:" . $sock->peerport);
|
---|
86 | }
|
---|
87 | }
|
---|
88 |
|
---|
89 | sub _fixup_header
|
---|
90 | {
|
---|
91 | my($self, $h, $url, $proxy) = @_;
|
---|
92 |
|
---|
93 | # Extract 'Host' header
|
---|
94 | my $hhost = $url->authority;
|
---|
95 | if ($hhost =~ s/^([^\@]*)\@//) { # get rid of potential "user:pass@"
|
---|
96 | # add authorization header if we need them. HTTP URLs do
|
---|
97 | # not really support specification of user and password, but
|
---|
98 | # we allow it.
|
---|
99 | if (defined($1) && not $h->header('Authorization')) {
|
---|
100 | require URI::Escape;
|
---|
101 | $h->authorization_basic(map URI::Escape::uri_unescape($_),
|
---|
102 | split(":", $1, 2));
|
---|
103 | }
|
---|
104 | }
|
---|
105 | $h->init_header('Host' => $hhost);
|
---|
106 |
|
---|
107 | if ($proxy) {
|
---|
108 | # Check the proxy URI's userinfo() for proxy credentials
|
---|
109 | # export http_proxy="http://proxyuser:proxypass@proxyhost:port"
|
---|
110 | my $p_auth = $proxy->userinfo();
|
---|
111 | if(defined $p_auth) {
|
---|
112 | require URI::Escape;
|
---|
113 | $h->proxy_authorization_basic(map URI::Escape::uri_unescape($_),
|
---|
114 | split(":", $p_auth, 2))
|
---|
115 | }
|
---|
116 | }
|
---|
117 | }
|
---|
118 |
|
---|
119 | sub hlist_remove {
|
---|
120 | my($hlist, $k) = @_;
|
---|
121 | $k = lc $k;
|
---|
122 | for (my $i = @$hlist - 2; $i >= 0; $i -= 2) {
|
---|
123 | next unless lc($hlist->[$i]) eq $k;
|
---|
124 | splice(@$hlist, $i, 2);
|
---|
125 | }
|
---|
126 | }
|
---|
127 |
|
---|
128 | sub request
|
---|
129 | {
|
---|
130 | my($self, $request, $proxy, $arg, $size, $timeout) = @_;
|
---|
131 |
|
---|
132 | $size ||= 4096;
|
---|
133 |
|
---|
134 | # check method
|
---|
135 | my $method = $request->method;
|
---|
136 | unless ($method =~ /^[A-Za-z0-9_!\#\$%&\'*+\-.^\`|~]+$/) { # HTTP token
|
---|
137 | return HTTP::Response->new( &HTTP::Status::RC_BAD_REQUEST,
|
---|
138 | 'Library does not allow method ' .
|
---|
139 | "$method for 'http:' URLs");
|
---|
140 | }
|
---|
141 |
|
---|
142 | my $url = $request->uri;
|
---|
143 | my($host, $port, $fullpath);
|
---|
144 |
|
---|
145 | # Check if we're proxy'ing
|
---|
146 | if (defined $proxy) {
|
---|
147 | # $proxy is an URL to an HTTP server which will proxy this request
|
---|
148 | $host = $proxy->host;
|
---|
149 | $port = $proxy->port;
|
---|
150 | $fullpath = $method eq "CONNECT" ?
|
---|
151 | ($url->host . ":" . $url->port) :
|
---|
152 | $url->as_string;
|
---|
153 | }
|
---|
154 | else {
|
---|
155 | $host = $url->host;
|
---|
156 | $port = $url->port;
|
---|
157 | $fullpath = $url->path_query;
|
---|
158 | $fullpath = "/$fullpath" unless $fullpath =~ m,^/,;
|
---|
159 | }
|
---|
160 |
|
---|
161 | # connect to remote site
|
---|
162 | my $socket = $self->_new_socket($host, $port, $timeout);
|
---|
163 |
|
---|
164 | my $http_version = "";
|
---|
165 | if (my $proto = $request->protocol) {
|
---|
166 | if ($proto =~ /^(?:HTTP\/)?(1.\d+)$/) {
|
---|
167 | $http_version = $1;
|
---|
168 | $socket->http_version($http_version);
|
---|
169 | $socket->send_te(0) if $http_version eq "1.0";
|
---|
170 | }
|
---|
171 | }
|
---|
172 |
|
---|
173 | $self->_check_sock($request, $socket);
|
---|
174 |
|
---|
175 | my @h;
|
---|
176 | my $request_headers = $request->headers->clone;
|
---|
177 | $self->_fixup_header($request_headers, $url, $proxy);
|
---|
178 |
|
---|
179 | $request_headers->scan(sub {
|
---|
180 | my($k, $v) = @_;
|
---|
181 | $k =~ s/^://;
|
---|
182 | $v =~ s/\n/ /g;
|
---|
183 | push(@h, $k, $v);
|
---|
184 | });
|
---|
185 |
|
---|
186 | my $content_ref = $request->content_ref;
|
---|
187 | $content_ref = $$content_ref if ref($$content_ref);
|
---|
188 | my $chunked;
|
---|
189 | my $has_content;
|
---|
190 |
|
---|
191 | if (ref($content_ref) eq 'CODE') {
|
---|
192 | my $clen = $request_headers->header('Content-Length');
|
---|
193 | $has_content++ if $clen;
|
---|
194 | unless (defined $clen) {
|
---|
195 | push(@h, "Transfer-Encoding" => "chunked");
|
---|
196 | $has_content++;
|
---|
197 | $chunked++;
|
---|
198 | }
|
---|
199 | }
|
---|
200 | else {
|
---|
201 | # Set (or override) Content-Length header
|
---|
202 | my $clen = $request_headers->header('Content-Length');
|
---|
203 | if (defined($$content_ref) && length($$content_ref)) {
|
---|
204 | $has_content = length($$content_ref);
|
---|
205 | if (!defined($clen) || $clen ne $has_content) {
|
---|
206 | if (defined $clen) {
|
---|
207 | warn "Content-Length header value was wrong, fixed";
|
---|
208 | hlist_remove(\@h, 'Content-Length');
|
---|
209 | }
|
---|
210 | push(@h, 'Content-Length' => $has_content);
|
---|
211 | }
|
---|
212 | }
|
---|
213 | elsif ($clen) {
|
---|
214 | warn "Content-Length set when there is no content, fixed";
|
---|
215 | hlist_remove(\@h, 'Content-Length');
|
---|
216 | }
|
---|
217 | }
|
---|
218 |
|
---|
219 | my $write_wait = 0;
|
---|
220 | $write_wait = 2
|
---|
221 | if ($request_headers->header("Expect") || "") =~ /100-continue/;
|
---|
222 |
|
---|
223 | my $req_buf = $socket->format_request($method, $fullpath, @h);
|
---|
224 | #print "------\n$req_buf\n------\n";
|
---|
225 |
|
---|
226 | if (!$has_content || $write_wait || $has_content > 8*1024) {
|
---|
227 | WRITE:
|
---|
228 | {
|
---|
229 | # Since this just writes out the header block it should almost
|
---|
230 | # always succeed to send the whole buffer in a single write call.
|
---|
231 | my $n = $socket->syswrite($req_buf, length($req_buf));
|
---|
232 | unless (defined $n) {
|
---|
233 | redo WRITE if $!{EINTR};
|
---|
234 | if ($!{EAGAIN}) {
|
---|
235 | select(undef, undef, undef, 0.1);
|
---|
236 | redo WRITE;
|
---|
237 | }
|
---|
238 | die "write failed: $!";
|
---|
239 | }
|
---|
240 | if ($n) {
|
---|
241 | substr($req_buf, 0, $n, "");
|
---|
242 | }
|
---|
243 | else {
|
---|
244 | select(undef, undef, undef, 0.5);
|
---|
245 | }
|
---|
246 | redo WRITE if length $req_buf;
|
---|
247 | }
|
---|
248 | }
|
---|
249 |
|
---|
250 | my($code, $mess, @junk);
|
---|
251 | my $drop_connection;
|
---|
252 |
|
---|
253 | if ($has_content) {
|
---|
254 | my $eof;
|
---|
255 | my $wbuf;
|
---|
256 | my $woffset = 0;
|
---|
257 | INITIAL_READ:
|
---|
258 | if ($write_wait) {
|
---|
259 | # skip filling $wbuf when waiting for 100-continue
|
---|
260 | # because if the response is a redirect or auth required
|
---|
261 | # the request will be cloned and there is no way
|
---|
262 | # to reset the input stream
|
---|
263 | # return here via the label after the 100-continue is read
|
---|
264 | }
|
---|
265 | elsif (ref($content_ref) eq 'CODE') {
|
---|
266 | my $buf = &$content_ref();
|
---|
267 | $buf = "" unless defined($buf);
|
---|
268 | $buf = sprintf "%x%s%s%s", length($buf), $CRLF, $buf, $CRLF
|
---|
269 | if $chunked;
|
---|
270 | substr($buf, 0, 0) = $req_buf if $req_buf;
|
---|
271 | $wbuf = \$buf;
|
---|
272 | }
|
---|
273 | else {
|
---|
274 | if ($req_buf) {
|
---|
275 | my $buf = $req_buf . $$content_ref;
|
---|
276 | $wbuf = \$buf;
|
---|
277 | }
|
---|
278 | else {
|
---|
279 | $wbuf = $content_ref;
|
---|
280 | }
|
---|
281 | $eof = 1;
|
---|
282 | }
|
---|
283 |
|
---|
284 | my $fbits = '';
|
---|
285 | vec($fbits, fileno($socket), 1) = 1;
|
---|
286 |
|
---|
287 | WRITE:
|
---|
288 | while ($write_wait || $woffset < length($$wbuf)) {
|
---|
289 |
|
---|
290 | my $sel_timeout = $timeout;
|
---|
291 | if ($write_wait) {
|
---|
292 | $sel_timeout = $write_wait if $write_wait < $sel_timeout;
|
---|
293 | }
|
---|
294 | my $time_before;
|
---|
295 | $time_before = time if $sel_timeout;
|
---|
296 |
|
---|
297 | my $rbits = $fbits;
|
---|
298 | my $wbits = $write_wait ? undef : $fbits;
|
---|
299 | my $sel_timeout_before = $sel_timeout;
|
---|
300 | SELECT:
|
---|
301 | {
|
---|
302 | my $nfound = select($rbits, $wbits, undef, $sel_timeout);
|
---|
303 | if ($nfound < 0) {
|
---|
304 | if ($!{EINTR} || $!{EAGAIN}) {
|
---|
305 | if ($time_before) {
|
---|
306 | $sel_timeout = $sel_timeout_before - (time - $time_before);
|
---|
307 | $sel_timeout = 0 if $sel_timeout < 0;
|
---|
308 | }
|
---|
309 | redo SELECT;
|
---|
310 | }
|
---|
311 | die "select failed: $!";
|
---|
312 | }
|
---|
313 | }
|
---|
314 |
|
---|
315 | if ($write_wait) {
|
---|
316 | $write_wait -= time - $time_before;
|
---|
317 | $write_wait = 0 if $write_wait < 0;
|
---|
318 | }
|
---|
319 |
|
---|
320 | if (defined($rbits) && $rbits =~ /[^\0]/) {
|
---|
321 | # readable
|
---|
322 | my $buf = $socket->_rbuf;
|
---|
323 | my $n = $socket->sysread($buf, 1024, length($buf));
|
---|
324 | unless (defined $n) {
|
---|
325 | die "read failed: $!" unless $!{EINTR} || $!{EAGAIN};
|
---|
326 | # if we get here the rest of the block will do nothing
|
---|
327 | # and we will retry the read on the next round
|
---|
328 | }
|
---|
329 | elsif ($n == 0) {
|
---|
330 | # the server closed the connection before we finished
|
---|
331 | # writing all the request content. No need to write any more.
|
---|
332 | $drop_connection++;
|
---|
333 | last WRITE;
|
---|
334 | }
|
---|
335 | $socket->_rbuf($buf);
|
---|
336 | if (!$code && $buf =~ /\015?\012\015?\012/) {
|
---|
337 | # a whole response header is present, so we can read it without blocking
|
---|
338 | ($code, $mess, @h) = $socket->read_response_headers(laxed => 1,
|
---|
339 | junk_out => \@junk,
|
---|
340 | );
|
---|
341 | if ($code eq "100") {
|
---|
342 | $write_wait = 0;
|
---|
343 | undef($code);
|
---|
344 | goto INITIAL_READ;
|
---|
345 | }
|
---|
346 | else {
|
---|
347 | $drop_connection++;
|
---|
348 | last WRITE;
|
---|
349 | # XXX should perhaps try to abort write in a nice way too
|
---|
350 | }
|
---|
351 | }
|
---|
352 | }
|
---|
353 | if (defined($wbits) && $wbits =~ /[^\0]/) {
|
---|
354 | my $n = $socket->syswrite($$wbuf, length($$wbuf), $woffset);
|
---|
355 | unless (defined $n) {
|
---|
356 | die "write failed: $!" unless $!{EINTR} || $!{EAGAIN};
|
---|
357 | $n = 0; # will retry write on the next round
|
---|
358 | }
|
---|
359 | elsif ($n == 0) {
|
---|
360 | die "write failed: no bytes written";
|
---|
361 | }
|
---|
362 | $woffset += $n;
|
---|
363 |
|
---|
364 | if (!$eof && $woffset >= length($$wbuf)) {
|
---|
365 | # need to refill buffer from $content_ref code
|
---|
366 | my $buf = &$content_ref();
|
---|
367 | $buf = "" unless defined($buf);
|
---|
368 | $eof++ unless length($buf);
|
---|
369 | $buf = sprintf "%x%s%s%s", length($buf), $CRLF, $buf, $CRLF
|
---|
370 | if $chunked;
|
---|
371 | $wbuf = \$buf;
|
---|
372 | $woffset = 0;
|
---|
373 | }
|
---|
374 | }
|
---|
375 | } # WRITE
|
---|
376 | }
|
---|
377 |
|
---|
378 | ($code, $mess, @h) = $socket->read_response_headers(laxed => 1, junk_out => \@junk)
|
---|
379 | unless $code;
|
---|
380 | ($code, $mess, @h) = $socket->read_response_headers(laxed => 1, junk_out => \@junk)
|
---|
381 | if $code eq "100";
|
---|
382 |
|
---|
383 | my $response = HTTP::Response->new($code, $mess);
|
---|
384 | my $peer_http_version = $socket->peer_http_version;
|
---|
385 | $response->protocol("HTTP/$peer_http_version");
|
---|
386 | {
|
---|
387 | local $HTTP::Headers::TRANSLATE_UNDERSCORE;
|
---|
388 | $response->push_header(@h);
|
---|
389 | }
|
---|
390 | $response->push_header("Client-Junk" => \@junk) if @junk;
|
---|
391 |
|
---|
392 | $response->request($request);
|
---|
393 | $self->_get_sock_info($response, $socket);
|
---|
394 |
|
---|
395 | if ($method eq "CONNECT") {
|
---|
396 | $response->{client_socket} = $socket; # so it can be picked up
|
---|
397 | return $response;
|
---|
398 | }
|
---|
399 |
|
---|
400 | if (my @te = $response->remove_header('Transfer-Encoding')) {
|
---|
401 | $response->push_header('Client-Transfer-Encoding', \@te);
|
---|
402 | }
|
---|
403 | $response->push_header('Client-Response-Num', scalar $socket->increment_response_count);
|
---|
404 |
|
---|
405 | my $complete;
|
---|
406 | $response = $self->collect($arg, $response, sub {
|
---|
407 | my $buf = ""; #prevent use of uninitialized value in SSLeay.xs
|
---|
408 | my $n;
|
---|
409 | READ:
|
---|
410 | {
|
---|
411 | $n = $socket->read_entity_body($buf, $size);
|
---|
412 | unless (defined $n) {
|
---|
413 | redo READ if $!{EINTR} || $!{EAGAIN};
|
---|
414 | die "read failed: $!";
|
---|
415 | }
|
---|
416 | redo READ if $n == -1;
|
---|
417 | }
|
---|
418 | $complete++ if !$n;
|
---|
419 | return \$buf;
|
---|
420 | } );
|
---|
421 | $drop_connection++ unless $complete;
|
---|
422 |
|
---|
423 | @h = $socket->get_trailers;
|
---|
424 | if (@h) {
|
---|
425 | local $HTTP::Headers::TRANSLATE_UNDERSCORE;
|
---|
426 | $response->push_header(@h);
|
---|
427 | }
|
---|
428 |
|
---|
429 | # keep-alive support
|
---|
430 | unless ($drop_connection) {
|
---|
431 | if (my $conn_cache = $self->{ua}{conn_cache}) {
|
---|
432 | my %connection = map { (lc($_) => 1) }
|
---|
433 | split(/\s*,\s*/, ($response->header("Connection") || ""));
|
---|
434 | if (($peer_http_version eq "1.1" && !$connection{close}) ||
|
---|
435 | $connection{"keep-alive"})
|
---|
436 | {
|
---|
437 | $conn_cache->deposit($self->socket_type, "$host:$port", $socket);
|
---|
438 | }
|
---|
439 | }
|
---|
440 | }
|
---|
441 |
|
---|
442 | $response;
|
---|
443 | }
|
---|
444 |
|
---|
445 |
|
---|
446 | #-----------------------------------------------------------
|
---|
447 | package LWP::Protocol::http::SocketMethods;
|
---|
448 |
|
---|
449 | sub ping {
|
---|
450 | my $self = shift;
|
---|
451 | !$self->can_read(0);
|
---|
452 | }
|
---|
453 |
|
---|
454 | sub increment_response_count {
|
---|
455 | my $self = shift;
|
---|
456 | return ++${*$self}{'myhttp_response_count'};
|
---|
457 | }
|
---|
458 |
|
---|
459 | #-----------------------------------------------------------
|
---|
460 | package LWP::Protocol::http::Socket;
|
---|
461 | use vars qw(@ISA);
|
---|
462 | @ISA = qw(LWP::Protocol::http::SocketMethods Net::HTTP);
|
---|
463 |
|
---|
464 | 1;
|
---|