ViewVC Help
View File | Revision Log | Show Annotations | Download File
/cvs/AnyEvent-HTTP/HTTP.pm
(Generate patch)

Comparing AnyEvent-HTTP/HTTP.pm (file contents):
Revision 1.24 by root, Wed Jul 2 01:30:33 2008 UTC vs.
Revision 1.42 by root, Mon Jul 6 00:08:16 2009 UTC

… …
39package AnyEvent::HTTP; 39package AnyEvent::HTTP;
40 40
41use strict; 41use strict;
42no warnings; 42no warnings;
43 43
44use Carp; 44use Errno ();
45 45
46use AnyEvent (); 46use AnyEvent 4.452 ();
47use AnyEvent::Util (); 47use AnyEvent::Util ();
48use AnyEvent::Socket (); 48use AnyEvent::Socket ();
49use AnyEvent::Handle (); 49use AnyEvent::Handle ();
50 50
51use base Exporter::; 51use base Exporter::;
52 52
53our $VERSION = '1.03'; 53our $VERSION = '1.12';
54 54
55our @EXPORT = qw(http_get http_post http_head http_request); 55our @EXPORT = qw(http_get http_post http_head http_request);
56 56
57our $USERAGENT = "Mozilla/5.0 (compatible; AnyEvent::HTTP/$VERSION; +http://software.schmorp.de/pkg/AnyEvent)"; 57our $USERAGENT = "Mozilla/5.0 (compatible; U; AnyEvent-HTTP/$VERSION; +http://software.schmorp.de/pkg/AnyEvent)";
58our $MAX_RECURSE = 10; 58our $MAX_RECURSE = 10;
59our $MAX_PERSISTENT = 8; 59our $MAX_PERSISTENT = 8;
60our $PERSISTENT_TIMEOUT = 2; 60our $PERSISTENT_TIMEOUT = 2;
61our $TIMEOUT = 300; 61our $TIMEOUT = 300;
62 62
… …
71my %CO_SLOT; # number of open connections, and wait queue, per host 71my %CO_SLOT; # number of open connections, and wait queue, per host
72 72
73=item http_get $url, key => value..., $cb->($data, $headers) 73=item http_get $url, key => value..., $cb->($data, $headers)
74 74
75Executes an HTTP-GET request. See the http_request function for details on 75Executes an HTTP-GET request. See the http_request function for details on
76additional parameters. 76additional parameters and the return value.
77 77
78=item http_head $url, key => value..., $cb->($data, $headers) 78=item http_head $url, key => value..., $cb->($data, $headers)
79 79
80Executes an HTTP-HEAD request. See the http_request function for details on 80Executes an HTTP-HEAD request. See the http_request function for details
81additional parameters. 81on additional parameters and the return value.
82 82
83=item http_post $url, $body, key => value..., $cb->($data, $headers) 83=item http_post $url, $body, key => value..., $cb->($data, $headers)
84 84
85Executes an HTTP-POST request with a request body of C<$bod>. See the 85Executes an HTTP-POST request with a request body of C<$body>. See the
86http_request function for details on additional parameters. 86http_request function for details on additional parameters and the return
87value.
87 88
88=item http_request $method => $url, key => value..., $cb->($data, $headers) 89=item http_request $method => $url, key => value..., $cb->($data, $headers)
89 90
90Executes a HTTP request of type C<$method> (e.g. C<GET>, C<POST>). The URL 91Executes a HTTP request of type C<$method> (e.g. C<GET>, C<POST>). The URL
91must be an absolute http or https URL. 92must be an absolute http or https URL.
92 93
94When called in void context, nothing is returned. In other contexts,
95C<http_request> returns a "cancellation guard" - you have to keep the
96object at least alive until the callback get called. If the object gets
97destroyed before the callbakc is called, the request will be cancelled.
98
93The callback will be called with the response data as first argument 99The callback will be called with the response body data as first argument
94(or C<undef> if it wasn't available due to errors), and a hash-ref with 100(or C<undef> if an error occured), and a hash-ref with response headers as
95response headers as second argument. 101second argument.
96 102
97All the headers in that hash are lowercased. In addition to the response 103All the headers in that hash are lowercased. In addition to the response
98headers, the "pseudo-headers" C<HTTPVersion>, C<Status> and C<Reason> 104headers, the "pseudo-headers" C<HTTPVersion>, C<Status> and C<Reason>
99contain the three parts of the HTTP Status-Line of the same name. The 105contain the three parts of the HTTP Status-Line of the same name. The
100pseudo-header C<URL> contains the original URL (which can differ from the 106pseudo-header C<URL> contains the original URL (which can differ from the
101requested URL when following redirects). 107requested URL when following redirects).
102 108
103If the server sends a header multiple lines, then their contents will be 109If the server sends a header multiple times, then their contents will be
104joined together with C<\x00>. 110joined together with a comma (C<,>), as per the HTTP spec.
105 111
106If an internal error occurs, such as not being able to resolve a hostname, 112If an internal error occurs, such as not being able to resolve a hostname,
107then C<$data> will be C<undef>, C<< $headers->{Status} >> will be C<599> 113then C<$data> will be C<undef>, C<< $headers->{Status} >> will be C<59x>
108and the C<Reason> pseudo-header will contain an error message. 114(usually C<599>) and the C<Reason> pseudo-header will contain an error
115message.
109 116
110A typical callback might look like this: 117A typical callback might look like this:
111 118
112 sub { 119 sub {
113 my ($body, $hdr) = @_; 120 my ($body, $hdr) = @_;
… …
159based on the original netscape specification. 166based on the original netscape specification.
160 167
161The C<$hash_ref> must be an (initially empty) hash reference which will 168The C<$hash_ref> must be an (initially empty) hash reference which will
162get updated automatically. It is possible to save the cookie_jar to 169get updated automatically. It is possible to save the cookie_jar to
163persistent storage with something like JSON or Storable, but this is not 170persistent storage with something like JSON or Storable, but this is not
164recommended, as expire times are currently being ignored. 171recommended, as expiry times are currently being ignored.
165 172
166Note that this cookie implementation is not of very high quality, nor 173Note that this cookie implementation is not of very high quality, nor
167meant to be complete. If you want complete cookie management you have to 174meant to be complete. If you want complete cookie management you have to
168do that on your own. C<cookie_jar> is meant as a quick fix to get some 175do that on your own. C<cookie_jar> is meant as a quick fix to get some
169cookie-using sites working. Cookies are a privacy disaster, do not use 176cookie-using sites working. Cookies are a privacy disaster, do not use
170them unless required to. 177them unless required to.
178
179=item tls_ctx => $scheme | $tls_ctx
180
181Specifies the AnyEvent::TLS context to be used for https connections. This
182parameter follows the same rules as the C<tls_ctx> parameter to
183L<AnyEvent::Handle>, but additionally, the two strings C<low> or
184C<high> can be specified, which give you a predefined low-security (no
185verification, highest compatibility) and high-security (CA and common-name
186verification) TLS context.
187
188The default for this option is C<low>, which could be interpreted as "give
189me the page, no matter what".
190
191=item on_header => $callback->($headers)
192
193When specified, this callback will be called with the header hash as soon
194as headers have been successfully received from the remote server (not on
195locally-generated errors).
196
197It has to return either true (in which case AnyEvent::HTTP will continue),
198or false, in which case AnyEvent::HTTP will cancel the download (and call
199the finish callback with an error code of C<598>).
200
201This callback is useful, among other things, to quickly reject unwanted
202content, which, if it is supposed to be rare, can be faster than first
203doing a C<HEAD> request.
204
205Example: cancel the request unless the content-type is "text/html".
206
207 on_header => sub {
208 $_[0]{"content-type"} =~ /^text\/html\s*(?:;|$)/
209 },
210
211=item on_body => $callback->($partial_body, $headers)
212
213When specified, all body data will be passed to this callback instead of
214to the completion callback. The completion callback will get the empty
215string instead of the body data.
216
217It has to return either true (in which case AnyEvent::HTTP will continue),
218or false, in which case AnyEvent::HTTP will cancel the download (and call
219the completion callback with an error code of C<598>).
220
221This callback is useful when the data is too large to be held in memory
222(so the callback writes it to a file) or when only some information should
223be extracted, or when the body should be processed incrementally.
224
225It is usually preferred over doing your own body handling via
226C<want_body_handle>.
227
228=item want_body_handle => $enable
229
230When enabled (default is disabled), the behaviour of AnyEvent::HTTP
231changes considerably: after parsing the headers, and instead of
232downloading the body (if any), the completion callback will be
233called. Instead of the C<$body> argument containing the body data, the
234callback will receive the L<AnyEvent::Handle> object associated with the
235connection. In error cases, C<undef> will be passed. When there is no body
236(e.g. status C<304>), the empty string will be passed.
237
238The handle object might or might not be in TLS mode, might be connected to
239a proxy, be a persistent connection etc., and configured in unspecified
240ways. The user is responsible for this handle (it will not be used by this
241module anymore).
242
243This is useful with some push-type services, where, after the initial
244headers, an interactive protocol is used (typical example would be the
245push-style twitter API which starts a JSON/XML stream).
246
247If you think you need this, first have a look at C<on_body>, to see if
248that doesn'T solve your problem in a better way.
171 249
172=back 250=back
173 251
174Example: make a simple HTTP GET request for http://www.nethype.de/ 252Example: make a simple HTTP GET request for http://www.nethype.de/
175 253
… …
188 my ($body, $hdr) = @_; 266 my ($body, $hdr) = @_;
189 use Data::Dumper; 267 use Data::Dumper;
190 print Dumper $hdr; 268 print Dumper $hdr;
191 } 269 }
192 ; 270 ;
271
272Example: make another simple HTTP GET request, but immediately try to
273cancel it.
274
275 my $request = http_request GET => "http://www.nethype.de/", sub {
276 my ($body, $hdr) = @_;
277 print "$body\n";
278 };
279
280 undef $request;
193 281
194=cut 282=cut
195 283
196sub _slot_schedule; 284sub _slot_schedule;
197sub _slot_schedule($) { 285sub _slot_schedule($) {
… …
221 push @{ $CO_SLOT{$_[0]}[1] }, $_[1]; 309 push @{ $CO_SLOT{$_[0]}[1] }, $_[1];
222 310
223 _slot_schedule $_[0]; 311 _slot_schedule $_[0];
224} 312}
225 313
314our $qr_nl = qr<\015?\012>;
315our $qr_nlnl = qr<\015?\012\015?\012>;
316
317our $TLS_CTX_LOW = { cache => 1, sslv2 => 1 };
318our $TLS_CTX_HIGH = { cache => 1, verify => 1, verify_peername => "https" };
319
226sub http_request($$@) { 320sub http_request($$@) {
227 my $cb = pop; 321 my $cb = pop;
228 my ($method, $url, %arg) = @_; 322 my ($method, $url, %arg) = @_;
229 323
230 my %hdr; 324 my %hdr;
325
326 $arg{tls_ctx} = $TLS_CTX_LOW if $arg{tls_ctx} eq "low" || !exists $arg{tls_ctx};
327 $arg{tls_ctx} = $TLS_CTX_HIGH if $arg{tls_ctx} eq "high";
231 328
232 $method = uc $method; 329 $method = uc $method;
233 330
234 if (my $hdr = $arg{headers}) { 331 if (my $hdr = $arg{headers}) {
235 while (my ($k, $v) = each %$hdr) { 332 while (my ($k, $v) = each %$hdr) {
… …
237 } 334 }
238 } 335 }
239 336
240 my $recurse = exists $arg{recurse} ? delete $arg{recurse} : $MAX_RECURSE; 337 my $recurse = exists $arg{recurse} ? delete $arg{recurse} : $MAX_RECURSE;
241 338
242 return $cb->(undef, { Status => 599, Reason => "recursion limit reached", URL => $url }) 339 return $cb->(undef, { Status => 599, Reason => "Too many redirections", URL => $url })
243 if $recurse < 0; 340 if $recurse < 0;
244 341
245 my $proxy = $arg{proxy} || $PROXY; 342 my $proxy = $arg{proxy} || $PROXY;
246 my $timeout = $arg{timeout} || $TIMEOUT; 343 my $timeout = $arg{timeout} || $TIMEOUT;
247 344
248 $hdr{"user-agent"} ||= $USERAGENT;
249
250 my ($scheme, $authority, $upath, $query, $fragment) = 345 my ($uscheme, $uauthority, $upath, $query, $fragment) =
251 $url =~ m|(?:([^:/?#]+):)?(?://([^/?#]*))?([^?#]*)(?:\?([^#]*))?(?:#(.*))?|; 346 $url =~ m|(?:([^:/?#]+):)?(?://([^/?#]*))?([^?#]*)(?:\?([^#]*))?(?:#(.*))?|;
252 347
253 $scheme = lc $scheme; 348 $uscheme = lc $uscheme;
254 349
255 my $uport = $scheme eq "http" ? 80 350 my $uport = $uscheme eq "http" ? 80
256 : $scheme eq "https" ? 443 351 : $uscheme eq "https" ? 443
257 : return $cb->(undef, { Status => 599, Reason => "only http and https URL schemes supported", URL => $url }); 352 : return $cb->(undef, { Status => 599, Reason => "Only http and https URL schemes supported", URL => $url });
258 353
259 $hdr{referer} ||= "$scheme://$authority$upath"; # leave out fragment and query string, just a heuristic
260
261 $authority =~ /^(?: .*\@ )? ([^\@:]+) (?: : (\d+) )?$/x 354 $uauthority =~ /^(?: .*\@ )? ([^\@:]+) (?: : (\d+) )?$/x
262 or return $cb->(undef, { Status => 599, Reason => "unparsable URL", URL => $url }); 355 or return $cb->(undef, { Status => 599, Reason => "Unparsable URL", URL => $url });
263 356
264 my $uhost = $1; 357 my $uhost = $1;
265 $uport = $2 if defined $2; 358 $uport = $2 if defined $2;
266 359
267 $uhost =~ s/^\[(.*)\]$/$1/; 360 $uhost =~ s/^\[(.*)\]$/$1/;
… …
269 362
270 $upath =~ s%^/?%/%; 363 $upath =~ s%^/?%/%;
271 364
272 # cookie processing 365 # cookie processing
273 if (my $jar = $arg{cookie_jar}) { 366 if (my $jar = $arg{cookie_jar}) {
274 %$jar = () if $jar->{version} < 1; 367 %$jar = () if $jar->{version} != 1;
275 368
276 my @cookie; 369 my @cookie;
277 370
278 while (my ($chost, $v) = each %$jar) { 371 while (my ($chost, $v) = each %$jar) {
372 if ($chost =~ /^\./) {
279 next unless $chost eq substr $uhost, -length $chost; 373 next unless $chost eq substr $uhost, -length $chost;
280 next unless $chost =~ /^\./; 374 } elsif ($chost =~ /\./) {
375 next unless $chost eq $uhost;
376 } else {
377 next;
378 }
281 379
282 while (my ($cpath, $v) = each %$v) { 380 while (my ($cpath, $v) = each %$v) {
283 next unless $cpath eq substr $upath, 0, length $cpath; 381 next unless $cpath eq substr $upath, 0, length $cpath;
284 382
285 while (my ($k, $v) = each %$v) { 383 while (my ($k, $v) = each %$v) {
286 next if $scheme ne "https" && exists $v->{secure}; 384 next if $uscheme ne "https" && exists $v->{secure};
385 my $value = $v->{value};
386 $value =~ s/([\\"])/\\$1/g;
287 push @cookie, "$k=$v->{value}"; 387 push @cookie, "$k=\"$value\"";
288 } 388 }
289 } 389 }
290 } 390 }
291 391
292 $hdr{cookie} = join "; ", @cookie 392 $hdr{cookie} = join "; ", @cookie
293 if @cookie; 393 if @cookie;
294 } 394 }
295 395
296 my ($rhost, $rport, $rpath); # request host, port, path 396 my ($rhost, $rport, $rscheme, $rpath); # request host, port, path
297 397
298 if ($proxy) { 398 if ($proxy) {
299 ($rhost, $rport, $scheme) = @$proxy; 399 ($rpath, $rhost, $rport, $rscheme) = ($url, @$proxy);
300 $rpath = $url; 400
401 # don't support https requests over https-proxy transport,
402 # can't be done with tls as spec'ed, unless you double-encrypt.
403 $rscheme = "http" if $uscheme eq "https" && $rscheme eq "https";
301 } else { 404 } else {
302 ($rhost, $rport, $rpath) = ($uhost, $uport, $upath); 405 ($rhost, $rport, $rscheme, $rpath) = ($uhost, $uport, $uscheme, $upath);
303 $hdr{host} = $uhost;
304 } 406 }
305 407
408 $hdr{"user-agent"} ||= $USERAGENT;
409 $hdr{referer} ||= "$uscheme://$uauthority$upath"; # leave out fragment and query string, just a heuristic
410
411 $hdr{host} = "$uhost:$uport";
306 $hdr{"content-length"} = length $arg{body}; 412 $hdr{"content-length"} = length $arg{body};
307 413
308 my %state = (connect_guard => 1); 414 my %state = (connect_guard => 1);
309 415
310 _get_slot $uhost, sub { 416 _get_slot $uhost, sub {
… …
312 418
313 return unless $state{connect_guard}; 419 return unless $state{connect_guard};
314 420
315 $state{connect_guard} = AnyEvent::Socket::tcp_connect $rhost, $rport, sub { 421 $state{connect_guard} = AnyEvent::Socket::tcp_connect $rhost, $rport, sub {
316 $state{fh} = shift 422 $state{fh} = shift
317 or return $cb->(undef, { Status => 599, Reason => "$!", URL => $url }); 423 or return (%state = (), $cb->(undef, { Status => 599, Reason => "$!", URL => $url }));
424 pop; # free memory, save a tree
318 425
319 delete $state{connect_guard}; # reduce memory usage, save a tree 426 return unless delete $state{connect_guard};
320 427
321 # get handle 428 # get handle
322 $state{handle} = new AnyEvent::Handle 429 $state{handle} = new AnyEvent::Handle
323 fh => $state{fh}, 430 fh => $state{fh},
324 ($scheme eq "https" ? (tls => "connect") : ()); 431 timeout => $timeout,
432 peername => $rhost,
433 tls_ctx => $arg{tls_ctx};
325 434
326 # limit the number of persistent connections 435 # limit the number of persistent connections
436 # keepalive not yet supported
327 if ($KA_COUNT{$_[1]} < $MAX_PERSISTENT_PER_HOST) { 437 if ($KA_COUNT{$_[1]} < $MAX_PERSISTENT_PER_HOST) {
328 ++$KA_COUNT{$_[1]}; 438 ++$KA_COUNT{$_[1]};
329 $state{handle}{ka_count_guard} = AnyEvent::Util::guard { --$KA_COUNT{$_[1]} }; 439 $state{handle}{ka_count_guard} = AnyEvent::Util::guard {
440 --$KA_COUNT{$_[1]}
441 };
330 $hdr{connection} = "keep-alive"; 442 $hdr{connection} = "keep-alive";
331 delete $hdr{connection}; # keep-alive not yet supported
332 } else { 443 } else {
333 delete $hdr{connection}; 444 delete $hdr{connection};
334 } 445 }
335 446
336 # (re-)configure handle 447 # (re-)configure handle
337 $state{handle}->timeout ($timeout);
338 $state{handle}->on_error (sub { 448 $state{handle}->on_error (sub {
339 my $errno = "$!";
340 %state = (); 449 %state = ();
341 $cb->(undef, { Status => 599, Reason => $errno, URL => $url }); 450 $cb->(undef, { Status => 599, Reason => $_[2], URL => $url });
342 }); 451 });
343 $state{handle}->on_eof (sub { 452 $state{handle}->on_eof (sub {
344 %state = (); 453 %state = ();
345 $cb->(undef, { Status => 599, Reason => "unexpected end-of-file", URL => $url }); 454 $cb->(undef, { Status => 599, Reason => "Unexpected end-of-file", URL => $url });
346 }); 455 });
347 456
457 $state{handle}->starttls ("connect") if $rscheme eq "https";
458
459 # handle actual, non-tunneled, request
460 my $handle_actual_request = sub {
461 $state{handle}->starttls ("connect") if $uscheme eq "https" && !exists $state{handle}{tls};
462
348 # send request 463 # send request
349 $state{handle}->push_write ( 464 $state{handle}->push_write (
350 "$method $rpath HTTP/1.0\015\012" 465 "$method $rpath HTTP/1.0\015\012"
351 . (join "", map "$_: $hdr{$_}\015\012", keys %hdr) 466 . (join "", map "\u$_: $hdr{$_}\015\012", keys %hdr)
352 . "\015\012" 467 . "\015\012"
353 . (delete $arg{body}) 468 . (delete $arg{body})
354 );
355
356 %hdr = (); # reduce memory usage, save a kitten
357
358 # status line
359 $state{handle}->push_read (line => qr/\015?\012/, sub {
360 $_[1] =~ /^HTTP\/([0-9\.]+) \s+ ([0-9]{3}) \s+ ([^\015\012]+)/ix
361 or return (%state = (), $cb->(undef, { Status => 599, Reason => "invalid server response ($_[1])", URL => $url }));
362
363 my %hdr = ( # response headers
364 HTTPVersion => "\x00$1",
365 Status => "\x00$2",
366 Reason => "\x00$3",
367 URL => "\x00$url"
368 ); 469 );
369 470
471 %hdr = (); # reduce memory usage, save a kitten
472
473 # status line
474 $state{handle}->push_read (line => $qr_nl, sub {
475 $_[1] =~ /^HTTP\/([0-9\.]+) \s+ ([0-9]{3}) (?: \s+ ([^\015\012]*) )?/ix
476 or return (%state = (), $cb->(undef, { Status => 599, Reason => "Invalid server response ($_[1])", URL => $url }));
477
478 my %hdr = ( # response headers
479 HTTPVersion => ",$1",
480 Status => ",$2",
481 Reason => ",$3",
482 URL => ",$url"
483 );
484
370 # headers, could be optimized a bit 485 # headers, could be optimized a bit
371 $state{handle}->unshift_read (line => qr/\015?\012\015?\012/, sub { 486 $state{handle}->unshift_read (line => $qr_nlnl, sub {
372 for ("$_[1]\012") { 487 for ("$_[1]\012") {
373 # we support spaces in field names, as lotus domino 488 y/\015//d; # weed out any \015, as they show up in the weirdest of places.
374 # creates them. 489
490 # things seen, not parsed:
491 # p3pP="NON CUR OTPi OUR NOR UNI"
492
375 $hdr{lc $1} .= "\x00$2" 493 $hdr{lc $1} .= ",$2"
376 while /\G 494 while /\G
377 ([^:\000-\037]+): 495 ([^:\000-\037]+):
378 [\011\040]* 496 [\011\040]*
379 ((?: [^\015\012]+ | \015?\012[\011\040] )*) 497 ((?: [^\012]+ | \012[\011\040] )*)
380 \015?\012 498 \012
381 /gxc; 499 /gxc;
382 500
383 /\G$/ 501 /\G$/
384 or return (%state = (), $cb->(undef, { Status => 599, Reason => "garbled response headers", URL => $url })); 502 or return (%state = (), $cb->(undef, { Status => 599, Reason => "Garbled response headers", URL => $url }));
385 } 503 }
386 504
387 substr $_, 0, 1, "" 505 substr $_, 0, 1, ""
388 for values %hdr; 506 for values %hdr;
389 507
390 my $finish = sub { 508 # redirect handling
391 %state = (); 509 # microsoft and other shitheads don't give a shit for following standards,
510 # try to support some common forms of broken Location headers.
511 if ($hdr{location} !~ /^(?: $ | [^:\/?\#]+ : )/x) {
512 $hdr{location} =~ s/^\.\/+//;
392 513
393 # set-cookie processing 514 my $url = "$rscheme://$uhost:$uport";
394 if ($arg{cookie_jar} && exists $hdr{"set-cookie"}) {
395 for (split /\x00/, $hdr{"set-cookie"}) {
396 my ($cookie, @arg) = split /;\s*/;
397 my ($name, $value) = split /=/, $cookie, 2;
398 my %kv = (value => $value, map { split /=/, $_, 2 } @arg);
399
400 my $cdom = (delete $kv{domain}) || $uhost;
401 my $cpath = (delete $kv{path}) || "/";
402
403 $cdom =~ s/^.?/./; # make sure it starts with a "."
404 515
405 next if $cdom =~ /\.$/; 516 unless ($hdr{location} =~ s/^\///) {
406 517 $url .= $upath;
407 # this is not rfc-like and not netscape-like. go figure. 518 $url =~ s/\/[^\/]*$//;
408 my $ndots = $cdom =~ y/.//; 519 }
409 next if $ndots < ($cdom =~ /\.[^.][^.]\.[^.][^.]$/ ? 3 : 2); 520
410 521 $hdr{location} = "$url/$hdr{location}";
522 }
523
524 my $redirect;
525
526 if ($recurse) {
527 if ($hdr{Status} =~ /^30[12]$/ && $method ne "POST") {
528 # apparently, mozilla et al. just change POST to GET here
529 # more research is needed before we do the same
411 # store it 530 $redirect = 1;
412 $arg{cookie_jar}{version} = 1; 531 } elsif ($hdr{Status} == 303) {
413 $arg{cookie_jar}{$cdom}{$cpath}{$name} = \%kv; 532 # even http/1.1 is unclear on how to mutate the method
533 $method = "GET" unless $method eq "HEAD";
534 $redirect = 1;
535 } elsif ($hdr{Status} == 307 && $method =~ /^(?:GET|HEAD)$/) {
536 $redirect = 1;
414 } 537 }
415 } 538 }
416 539
417 # microsoft and other assholes don't give a shit for following standards, 540 my $finish = sub {
418 # try to support a common form of broken Location header. 541 $state{handle}->destroy if $state{handle};
419 $_[1]{location} =~ s%^/%$scheme://$uhost:$uport/% 542 %state = ();
543
544 # set-cookie processing
545 if ($arg{cookie_jar}) {
546 for ($_[1]{"set-cookie"}) {
547 # parse NAME=VALUE
548 my @kv;
549
550 while (/\G\s* ([^=;,[:space:]]+) \s*=\s* (?: "((?:[^\\"]+|\\.)*)" | ([^=;,[:space:]]*) )/gcxs) {
551 my $name = $1;
552 my $value = $3;
553
554 unless ($value) {
555 $value = $2;
556 $value =~ s/\\(.)/$1/gs;
557 }
558
559 push @kv, $name => $value;
560
561 last unless /\G\s*;/gc;
562 }
563
564 last unless @kv;
565
566 my $name = shift @kv;
567 my %kv = (value => shift @kv, @kv);
568
569 my $cdom;
570 my $cpath = (delete $kv{path}) || "/";
571
420 if exists $_[1]{location}; 572 if (exists $kv{domain}) {
573 $cdom = delete $kv{domain};
574
575 $cdom =~ s/^\.?/./; # make sure it starts with a "."
421 576
422 if ($_[1]{Status} =~ /^30[12]$/ && $recurse && $method ne "POST") { 577 next if $cdom =~ /\.$/;
423 # apparently, mozilla et al. just change POST to GET here 578
424 # more research is needed before we do the same 579 # this is not rfc-like and not netscape-like. go figure.
425 http_request ($method, $_[1]{location}, %arg, recurse => $recurse - 1, $cb); 580 my $ndots = $cdom =~ y/.//;
426 } elsif ($_[1]{Status} == 303 && $recurse) { 581 next if $ndots < ($cdom =~ /\.[^.][^.]\.[^.][^.]$/ ? 3 : 2);
427 # even http/1.1 is unlear on how to mutate the method 582 } else {
428 $method = "GET" unless $method eq "HEAD"; 583 $cdom = $uhost;
584 }
585
586 # store it
587 $arg{cookie_jar}{version} = 1;
588 $arg{cookie_jar}{$cdom}{$cpath}{$name} = \%kv;
589
590 redo if /\G\s*,/gc;
591 }
592 }
593
594 if ($redirect) {
595 # we ignore any errors, as it is very common to receive
596 # Content-Length != 0 but no actual body
597 # we also access %hdr, as $_[1] might be an erro
429 http_request ($method => $_[1]{location}, %arg, recurse => $recurse - 1, $cb); 598 http_request ($method => $hdr{location}, %arg, recurse => $recurse - 1, $cb);
430 } elsif ($_[1]{Status} == 307 && $recurse && $method =~ /^(?:GET|HEAD)$/) { 599 } else {
431 http_request ($method => $_[1]{location}, %arg, recurse => $recurse - 1, $cb); 600 $cb->($_[0], $_[1]);
601 }
602 };
603
604 my $len = $hdr{"content-length"};
605
606 if (!$redirect && $arg{on_header} && !$arg{on_header}(\%hdr)) {
607 $finish->(undef, { Status => 598, Reason => "Request cancelled by on_header", URL => $url });
608 } elsif (
609 $hdr{Status} =~ /^(?:1..|[23]04)$/
610 or $method eq "HEAD"
611 or (defined $len && !$len)
612 ) {
613 # no body
614 $finish->("", \%hdr);
432 } else { 615 } else {
433 $cb->($_[0], $_[1]); 616 # body handling, four different code paths
617 # for want_body_handle, on_body (2x), normal (2x)
618 # we might read too much here, but it does not matter yet (no pers. connections)
619 if (!$redirect && $arg{want_body_handle}) {
620 $_[0]->on_eof (undef);
621 $_[0]->on_error (undef);
622 $_[0]->on_read (undef);
623
624 $finish->(delete $state{handle}, \%hdr);
625
626 } elsif ($arg{on_body}) {
627 $_[0]->on_error (sub { $finish->(undef, { Status => 599, Reason => $_[2], URL => $url }) });
628 if ($len) {
629 $_[0]->on_eof (undef);
630 $_[0]->on_read (sub {
631 $len -= length $_[0]{rbuf};
632
633 $arg{on_body}(delete $_[0]{rbuf}, \%hdr)
634 or $finish->(undef, { Status => 598, Reason => "Request cancelled by on_body", URL => $url });
635
636 $len > 0
637 or $finish->("", \%hdr);
638 });
639 } else {
640 $_[0]->on_eof (sub {
641 $finish->("", \%hdr);
642 });
643 $_[0]->on_read (sub {
644 $arg{on_body}(delete $_[0]{rbuf}, \%hdr)
645 or $finish->(undef, { Status => 598, Reason => "Request cancelled by on_body", URL => $url });
646 });
647 }
648 } else {
649 $_[0]->on_eof (undef);
650
651 if ($len) {
652 $_[0]->on_error (sub { $finish->(undef, { Status => 599, Reason => $_[2], URL => $url }) });
653 $_[0]->on_read (sub {
654 $finish->((substr delete $_[0]{rbuf}, 0, $len, ""), \%hdr)
655 if $len <= length $_[0]{rbuf};
656 });
657 } else {
658 $_[0]->on_error (sub {
659 $! == Errno::EPIPE
660 ? $finish->(delete $_[0]{rbuf}, \%hdr)
661 : $finish->(undef, { Status => 599, Reason => $_[2], URL => $url });
662 });
663 $_[0]->on_read (sub { });
664 }
665 }
434 } 666 }
435 }; 667 });
668 });
669 };
436 670
437 if ($hdr{Status} =~ /^(?:1..|204|304)$/ or $method eq "HEAD") { 671 # now handle proxy-CONNECT method
438 $finish->(undef, \%hdr); 672 if ($proxy && $uscheme eq "https") {
673 # oh dear, we have to wrap it into a connect request
674
675 # maybe re-use $uauthority with patched port?
676 $state{handle}->push_write ("CONNECT $uhost:$uport HTTP/1.0\015\012Host: $uhost\015\012\015\012");
677 $state{handle}->push_read (line => $qr_nlnl, sub {
678 $_[1] =~ /^HTTP\/([0-9\.]+) \s+ ([0-9]{3}) (?: \s+ ([^\015\012]*) )?/ix
679 or return (%state = (), $cb->(undef, { Status => 599, Reason => "Invalid proxy connect response ($_[1])", URL => $url }));
680
681 if ($2 == 200) {
682 $rpath = $upath;
683 &$handle_actual_request;
439 } else { 684 } else {
440 if (exists $hdr{"content-length"}) { 685 %state = ();
441 $_[0]->unshift_read (chunk => $hdr{"content-length"}, sub { 686 $cb->(undef, { Status => $2, Reason => $3, URL => $url });
442 # could cache persistent connection now
443 if ($hdr{connection} =~ /\bkeep-alive\b/i) {
444 # but we don't, due to misdesigns, this is annoyingly complex
445 };
446
447 $finish->($_[1], \%hdr);
448 });
449 } else {
450 # too bad, need to read until we get an error or EOF,
451 # no way to detect winged data.
452 $_[0]->on_error (sub {
453 $finish->($_[0]{rbuf}, \%hdr);
454 });
455 $_[0]->on_eof (undef);
456 $_[0]->on_read (sub { });
457 }
458 } 687 }
459 }); 688 });
689 } else {
690 &$handle_actual_request;
460 }); 691 }
692
461 }, sub { 693 }, sub {
462 $timeout 694 $timeout
463 }; 695 };
464 }; 696 };
465 697
… …
498The default value for the C<recurse> request parameter (default: C<10>). 730The default value for the C<recurse> request parameter (default: C<10>).
499 731
500=item $AnyEvent::HTTP::USERAGENT 732=item $AnyEvent::HTTP::USERAGENT
501 733
502The default value for the C<User-Agent> header (the default is 734The default value for the C<User-Agent> header (the default is
503C<Mozilla/5.0 (compatible; AnyEvent::HTTP/$VERSION; +http://software.schmorp.de/pkg/AnyEvent)>). 735C<Mozilla/5.0 (compatible; U; AnyEvent-HTTP/$VERSION; +http://software.schmorp.de/pkg/AnyEvent)>).
504 736
505=item $AnyEvent::HTTP::MAX_PERSISTENT 737=item $AnyEvent::HTTP::MAX_PERSISTENT
506 738
507The maximum number of persistent connections to keep open (default: 8). 739The maximum number of persistent connections to keep open (default: 8).
508 740
… …
538=head1 AUTHOR 770=head1 AUTHOR
539 771
540 Marc Lehmann <schmorp@schmorp.de> 772 Marc Lehmann <schmorp@schmorp.de>
541 http://home.schmorp.de/ 773 http://home.schmorp.de/
542 774
775With many thanks to Дмитрий Шалашов, who provided countless
776testcases and bugreports.
777
543=cut 778=cut
544 779
5451 7801
546 781

Diff Legend

– Removed lines
+ Added lines
< Changed lines
> Changed lines