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.62 by root, Thu Dec 30 04:30:24 2010 UTC vs.
Revision 1.70 by root, Fri Dec 31 20:31:47 2010 UTC

… …
47use AnyEvent::Util (); 47use AnyEvent::Util ();
48use AnyEvent::Handle (); 48use AnyEvent::Handle ();
49 49
50use base Exporter::; 50use base Exporter::;
51 51
52our $VERSION = '1.46'; 52our $VERSION = '1.5';
53 53
54our @EXPORT = qw(http_get http_post http_head http_request); 54our @EXPORT = qw(http_get http_post http_head http_request);
55 55
56our $USERAGENT = "Mozilla/5.0 (compatible; U; AnyEvent-HTTP/$VERSION; +http://software.schmorp.de/pkg/AnyEvent)"; 56our $USERAGENT = "Mozilla/5.0 (compatible; U; AnyEvent-HTTP/$VERSION; +http://software.schmorp.de/pkg/AnyEvent)";
57our $MAX_RECURSE = 10; 57our $MAX_RECURSE = 10;
… …
94C<http_request> returns a "cancellation guard" - you have to keep the 94C<http_request> returns a "cancellation guard" - you have to keep the
95object at least alive until the callback get called. If the object gets 95object at least alive until the callback get called. If the object gets
96destroyed before the callback is called, the request will be cancelled. 96destroyed before the callback is called, the request will be cancelled.
97 97
98The callback will be called with the response body data as first argument 98The callback will be called with the response body data as first argument
99(or C<undef> if an error occured), and a hash-ref with response headers as 99(or C<undef> if an error occured), and a hash-ref with response headers
100second argument. 100(and trailers) as second argument.
101 101
102All the headers in that hash are lowercased. In addition to the response 102All the headers in that hash are lowercased. In addition to the response
103headers, the "pseudo-headers" (uppercase to avoid clashing with possible 103headers, the "pseudo-headers" (uppercase to avoid clashing with possible
104response headers) C<HTTPVersion>, C<Status> and C<Reason> contain the 104response headers) C<HTTPVersion>, C<Status> and C<Reason> contain the
105three parts of the HTTP Status-Line of the same name. 105three parts of the HTTP Status-Line of the same name. If an error occurs
106during the body phase of a request, then the original C<Status> and
107C<Reason> values from the header are available as C<OrigStatus> and
108C<OrigReason>.
106 109
107The pseudo-header C<URL> contains the actual URL (which can differ from 110The pseudo-header C<URL> contains the actual URL (which can differ from
108the requested URL when following redirects - for example, you might get 111the requested URL when following redirects - for example, you might get
109an error that your URL scheme is not supported even though your URL is a 112an error that your URL scheme is not supported even though your URL is a
110valid http URL because it redirected to an ftp URL, in which case you can 113valid http URL because it redirected to an ftp URL, in which case you can
… …
147Whether to recurse requests or not, e.g. on redirects, authentication 150Whether to recurse requests or not, e.g. on redirects, authentication
148retries and so on, and how often to do so. 151retries and so on, and how often to do so.
149 152
150=item headers => hashref 153=item headers => hashref
151 154
152The request headers to use, with the header name (I<MUST be in lowercase>) 155The request headers to use. Currently, C<http_request> may provide its own
153as key and header value as hash value. 156C<Host:>, C<Content-Length:>, C<Connection:> and C<Cookie:> headers and
154 157will provide defaults at least for C<TE:>, C<Referer:> and C<User-Agent:>
155Currently, http_request> may provide its own C<host>, C<content-length>, 158(this can be suppressed by using C<undef> for these headers in which case
156C<connection> and C<cookie> headers and will provide defaults for 159they won't be sent at all).
157C<user-agent> and C<referer> (this can be suppressed by using a value of
158C<undef> for these headers in which case they won't be sent at all).
159 160
160=item timeout => $seconds 161=item timeout => $seconds
161 162
162The time-out to use for various stages - each connect attempt will reset 163The time-out to use for various stages - each connect attempt will reset
163the timeout, as will read or write activity, i.e. this is not an overall 164the timeout, as will read or write activity, i.e. this is not an overall
… …
173C<$scheme> must be either missing, C<http> for HTTP or C<https> for 174C<$scheme> must be either missing, C<http> for HTTP or C<https> for
174HTTPS. 175HTTPS.
175 176
176=item body => $string 177=item body => $string
177 178
178The request body, usually empty. Will be-sent as-is (future versions of 179The request body, usually empty. Will be sent as-is (future versions of
179this module might offer more options). 180this module might offer more options).
180 181
181=item cookie_jar => $hash_ref 182=item cookie_jar => $hash_ref
182 183
183Passing this parameter enables (simplified) cookie-processing, loosely 184Passing this parameter enables (simplified) cookie-processing, loosely
184based on the original netscape specification. 185based on the original netscape specification.
185 186
186The C<$hash_ref> must be an (initially empty) hash reference which will 187The C<$hash_ref> must be an (initially empty) hash reference which will
187get updated automatically. It is possible to save the cookie_jar to 188get updated automatically. It is possible to save the cookie jar to
188persistent storage with something like JSON or Storable, but this is not 189persistent storage with something like JSON or Storable, but this is not
189recommended, as expiry times are currently being ignored. 190recommended, as session-only cookies might survive longer than expected.
190 191
191Note that this cookie implementation is not of very high quality, nor 192Note that this cookie implementation is not meant to be complete. If
192meant to be complete. If you want complete cookie management you have to 193you want complete cookie management you have to do that on your
193do that on your own. C<cookie_jar> is meant as a quick fix to get some 194own. C<cookie_jar> is meant as a quick fix to get some cookie-using sites
194cookie-using sites working. Cookies are a privacy disaster, do not use 195working. Cookies are a privacy disaster, do not use them unless required
195them unless required to. 196to.
197
198When cookie processing is enabled, the C<Cookie:> and C<Set-Cookie:>
199headers will be set and handled by this module, otherwise they will be
200left untouched.
196 201
197=item tls_ctx => $scheme | $tls_ctx 202=item tls_ctx => $scheme | $tls_ctx
198 203
199Specifies the AnyEvent::TLS context to be used for https connections. This 204Specifies the AnyEvent::TLS context to be used for https connections. This
200parameter follows the same rules as the C<tls_ctx> parameter to 205parameter follows the same rules as the C<tls_ctx> parameter to
… …
239 244
240This callback is useful, among other things, to quickly reject unwanted 245This callback is useful, among other things, to quickly reject unwanted
241content, which, if it is supposed to be rare, can be faster than first 246content, which, if it is supposed to be rare, can be faster than first
242doing a C<HEAD> request. 247doing a C<HEAD> request.
243 248
249The downside is that cancelling the request makes it impossible to re-use
250the connection. Also, the C<on_header> callback will not receive any
251trailer (headers sent after the response body).
252
244Example: cancel the request unless the content-type is "text/html". 253Example: cancel the request unless the content-type is "text/html".
245 254
246 on_header => sub { 255 on_header => sub {
247 $_[0]{"content-type"} =~ /^text\/html\s*(?:;|$)/ 256 $_[0]{"content-type"} =~ /^text\/html\s*(?:;|$)/
248 }, 257 },
… …
254string instead of the body data. 263string instead of the body data.
255 264
256It has to return either true (in which case AnyEvent::HTTP will continue), 265It has to return either true (in which case AnyEvent::HTTP will continue),
257or false, in which case AnyEvent::HTTP will cancel the download (and call 266or false, in which case AnyEvent::HTTP will cancel the download (and call
258the completion callback with an error code of C<598>). 267the completion callback with an error code of C<598>).
268
269The downside to cancelling the request is that it makes it impossible to
270re-use the connection.
259 271
260This callback is useful when the data is too large to be held in memory 272This callback is useful when the data is too large to be held in memory
261(so the callback writes it to a file) or when only some information should 273(so the callback writes it to a file) or when only some information should
262be extracted, or when the body should be processed incrementally. 274be extracted, or when the body should be processed incrementally.
263 275
… …
289If you think you need this, first have a look at C<on_body>, to see if 301If you think you need this, first have a look at C<on_body>, to see if
290that doesn't solve your problem in a better way. 302that doesn't solve your problem in a better way.
291 303
292=back 304=back
293 305
294Example: make a simple HTTP GET request for http://www.nethype.de/ 306Example: do a simple HTTP GET request for http://www.nethype.de/ and print
307the response body.
295 308
296 http_request GET => "http://www.nethype.de/", sub { 309 http_request GET => "http://www.nethype.de/", sub {
297 my ($body, $hdr) = @_; 310 my ($body, $hdr) = @_;
298 print "$body\n"; 311 print "$body\n";
299 }; 312 };
300 313
301Example: make a HTTP HEAD request on https://www.google.com/, use a 314Example: do a HTTP HEAD request on https://www.google.com/, use a
302timeout of 30 seconds. 315timeout of 30 seconds.
303 316
304 http_request 317 http_request
305 GET => "https://www.google.com", 318 GET => "https://www.google.com",
306 timeout => 30, 319 timeout => 30,
… …
309 use Data::Dumper; 322 use Data::Dumper;
310 print Dumper $hdr; 323 print Dumper $hdr;
311 } 324 }
312 ; 325 ;
313 326
314Example: make another simple HTTP GET request, but immediately try to 327Example: do another simple HTTP GET request, but immediately try to
315cancel it. 328cancel it.
316 329
317 my $request = http_request GET => "http://www.nethype.de/", sub { 330 my $request = http_request GET => "http://www.nethype.de/", sub {
318 my ($body, $hdr) = @_; 331 my ($body, $hdr) = @_;
319 print "$body\n"; 332 print "$body\n";
… …
351 push @{ $CO_SLOT{$_[0]}[1] }, $_[1]; 364 push @{ $CO_SLOT{$_[0]}[1] }, $_[1];
352 365
353 _slot_schedule $_[0]; 366 _slot_schedule $_[0];
354} 367}
355 368
369# continue to parse $_ for headers and place them into the arg
370sub parse_hdr() {
371 my %hdr;
372
373 # things seen, not parsed:
374 # p3pP="NON CUR OTPi OUR NOR UNI"
375
376 $hdr{lc $1} .= ",$2"
377 while /\G
378 ([^:\000-\037]*):
379 [\011\040]*
380 ((?: [^\012]+ | \012[\011\040] )*)
381 \012
382 /gxc;
383
384 /\G$/
385 or return;
386
387 # remove the "," prefix we added to all headers above
388 substr $_, 0, 1, ""
389 for values %hdr;
390
391 \%hdr
392}
393
356our $qr_nlnl = qr{(?<![^\012])\015?\012}; 394our $qr_nlnl = qr{(?<![^\012])\015?\012};
357 395
358our $TLS_CTX_LOW = { cache => 1, sslv2 => 1 }; 396our $TLS_CTX_LOW = { cache => 1, sslv2 => 1 };
359our $TLS_CTX_HIGH = { cache => 1, verify => 1, verify_peername => "https" }; 397our $TLS_CTX_HIGH = { cache => 1, verify => 1, verify_peername => "https" };
360 398
… …
379 my @pseudo = (URL => $url); 417 my @pseudo = (URL => $url);
380 push @pseudo, Redirect => delete $arg{Redirect} if exists $arg{Redirect}; 418 push @pseudo, Redirect => delete $arg{Redirect} if exists $arg{Redirect};
381 419
382 my $recurse = exists $arg{recurse} ? delete $arg{recurse} : $MAX_RECURSE; 420 my $recurse = exists $arg{recurse} ? delete $arg{recurse} : $MAX_RECURSE;
383 421
384 return $cb->(undef, { Status => 599, Reason => "Too many redirections", @pseudo }) 422 return $cb->(undef, { @pseudo, Status => 599, Reason => "Too many redirections" })
385 if $recurse < 0; 423 if $recurse < 0;
386 424
387 my $proxy = $arg{proxy} || $PROXY; 425 my $proxy = $arg{proxy} || $PROXY;
388 my $timeout = $arg{timeout} || $TIMEOUT; 426 my $timeout = $arg{timeout} || $TIMEOUT;
389 427
… …
392 430
393 $uscheme = lc $uscheme; 431 $uscheme = lc $uscheme;
394 432
395 my $uport = $uscheme eq "http" ? 80 433 my $uport = $uscheme eq "http" ? 80
396 : $uscheme eq "https" ? 443 434 : $uscheme eq "https" ? 443
397 : return $cb->(undef, { Status => 599, Reason => "Only http and https URL schemes supported", @pseudo }); 435 : return $cb->(undef, { @pseudo, Status => 599, Reason => "Only http and https URL schemes supported" });
398 436
399 $uauthority =~ /^(?: .*\@ )? ([^\@:]+) (?: : (\d+) )?$/x 437 $uauthority =~ /^(?: .*\@ )? ([^\@:]+) (?: : (\d+) )?$/x
400 or return $cb->(undef, { Status => 599, Reason => "Unparsable URL", @pseudo }); 438 or return $cb->(undef, { @pseudo, Status => 599, Reason => "Unparsable URL" });
401 439
402 my $uhost = $1; 440 my $uhost = $1;
403 $uport = $2 if defined $2; 441 $uport = $2 if defined $2;
404 442
405 $hdr{host} = defined $2 ? "$uhost:$2" : "$uhost" 443 $hdr{host} = defined $2 ? "$uhost:$2" : "$uhost"
… …
414 if (my $jar = $arg{cookie_jar}) { 452 if (my $jar = $arg{cookie_jar}) {
415 %$jar = () if $jar->{version} != 1; 453 %$jar = () if $jar->{version} != 1;
416 454
417 my @cookie; 455 my @cookie;
418 456
419 while (my ($chost, $v) = each %$jar) { 457 while (my ($chost, $paths) = each %$jar) {
420 if ($chost =~ /^\./) { 458 if ($chost =~ /^\./) {
421 next unless $chost eq substr $uhost, -length $chost; 459 next unless $chost eq substr $uhost, -length $chost;
422 } elsif ($chost =~ /\./) { 460 } elsif ($chost =~ /\./) {
423 next unless $chost eq $uhost; 461 next unless $chost eq $uhost;
424 } else { 462 } else {
425 next; 463 next;
426 } 464 }
427 465
428 while (my ($cpath, $v) = each %$v) { 466 while (my ($cpath, $cookies) = each %$paths) {
429 next unless $cpath eq substr $upath, 0, length $cpath; 467 next unless $cpath eq substr $upath, 0, length $cpath;
430 468
431 while (my ($k, $v) = each %$v) { 469 while (my ($cookie, $kv) = each %$cookies) {
432 next if $uscheme ne "https" && exists $v->{secure}; 470 next if $uscheme ne "https" && exists $kv->{secure};
471
472 if (exists $kv->{expires}) {
473 if (AE::now > parse_date ($kv->{expires})) {
474 delete $cookies->{$cookie};
475 next;
476 }
477 }
478
433 my $value = $v->{value}; 479 my $value = $kv->{value};
434 $value =~ s/([\\"])/\\$1/g; 480 $value =~ s/([\\"])/\\$1/g;
435 push @cookie, "$k=\"$value\""; 481 push @cookie, "$cookie=\"$value\"";
436 } 482 }
437 } 483 }
438 } 484 }
439 485
440 $hdr{cookie} = join "; ", @cookie 486 $hdr{cookie} = join "; ", @cookie
… …
454 } else { 500 } else {
455 ($rhost, $rport, $rscheme, $rpath) = ($uhost, $uport, $uscheme, $upath); 501 ($rhost, $rport, $rscheme, $rpath) = ($uhost, $uport, $uscheme, $upath);
456 } 502 }
457 503
458 # leave out fragment and query string, just a heuristic 504 # leave out fragment and query string, just a heuristic
459 $hdr{referer} ||= "$uscheme://$uauthority$upath" unless exists $hdr{referer}; 505 $hdr{referer} = "$uscheme://$uauthority$upath" unless exists $hdr{referer};
460 $hdr{"user-agent"} ||= $USERAGENT unless exists $hdr{"user-agent"}; 506 $hdr{"user-agent"} = $USERAGENT unless exists $hdr{"user-agent"};
461 507
462 $hdr{"content-length"} = length $arg{body} 508 $hdr{"content-length"} = length $arg{body}
463 if length $arg{body} || $method ne "GET"; 509 if length $arg{body} || $method ne "GET";
464 510
511 $hdr{connection} = "close TE"; #1.1
512 $hdr{te} = "trailers" unless exists $hdr{te}; #1.1
513
465 my %state = (connect_guard => 1); 514 my %state = (connect_guard => 1);
466 515
467 _get_slot $uhost, sub { 516 _get_slot $uhost, sub {
468 $state{slot_guard} = shift; 517 $state{slot_guard} = shift;
469 518
470 return unless $state{connect_guard}; 519 return unless $state{connect_guard};
471 520
472 my $tcp_connect = $arg{tcp_connect} 521 my $connect_cb = sub {
473 || do { require AnyEvent::Socket; \&AnyEvent::Socket::tcp_connect };
474
475 $state{connect_guard} = $tcp_connect->(
476 $rhost,
477 $rport,
478 sub {
479 $state{fh} = shift 522 $state{fh} = shift
480 or do { 523 or do {
481 my $err = "$!"; 524 my $err = "$!";
482 %state = (); 525 %state = ();
483 return $cb->(undef, { Status => 599, Reason => $err, @pseudo }); 526 return $cb->(undef, { @pseudo, Status => 599, Reason => $err });
484 }; 527 };
485 528
486 pop; # free memory, save a tree 529 pop; # free memory, save a tree
487 530
488 return unless delete $state{connect_guard}; 531 return unless delete $state{connect_guard};
489 532
490 # get handle 533 # get handle
491 $state{handle} = new AnyEvent::Handle 534 $state{handle} = new AnyEvent::Handle
492 fh => $state{fh}, 535 fh => $state{fh},
493 peername => $rhost, 536 peername => $rhost,
494 tls_ctx => $arg{tls_ctx}, 537 tls_ctx => $arg{tls_ctx},
495 # these need to be reconfigured on keepalive handles 538 # these need to be reconfigured on keepalive handles
496 timeout => $timeout, 539 timeout => $timeout,
497 on_error => sub { 540 on_error => sub {
498 %state = (); 541 %state = ();
499 $cb->(undef, { Status => 599, Reason => $_[2], @pseudo }); 542 $cb->(undef, { @pseudo, Status => 599, Reason => $_[2] });
500 }, 543 },
501 on_eof => sub { 544 on_eof => sub {
502 %state = (); 545 %state = ();
503 $cb->(undef, { Status => 599, Reason => "Unexpected end-of-file", @pseudo }); 546 $cb->(undef, { @pseudo, Status => 599, Reason => "Unexpected end-of-file" });
504 }, 547 },
505 ; 548 ;
506 549
507 # limit the number of persistent connections 550 # limit the number of persistent connections
508 # keepalive not yet supported 551 # keepalive not yet supported
509# if ($KA_COUNT{$_[1]} < $MAX_PERSISTENT_PER_HOST) { 552# if ($KA_COUNT{$_[1]} < $MAX_PERSISTENT_PER_HOST) {
510# ++$KA_COUNT{$_[1]}; 553# ++$KA_COUNT{$_[1]};
511# $state{handle}{ka_count_guard} = AnyEvent::Util::guard { 554# $state{handle}{ka_count_guard} = AnyEvent::Util::guard {
512# --$KA_COUNT{$_[1]} 555# --$KA_COUNT{$_[1]}
513# }; 556# };
514# $hdr{connection} = "keep-alive"; 557# $hdr{connection} = "keep-alive";
515# } else {
516 delete $hdr{connection};
517# } 558# }
518 559
519 $state{handle}->starttls ("connect") if $rscheme eq "https"; 560 $state{handle}->starttls ("connect") if $rscheme eq "https";
520 561
521 # handle actual, non-tunneled, request 562 # handle actual, non-tunneled, request
522 my $handle_actual_request = sub { 563 my $handle_actual_request = sub {
523 $state{handle}->starttls ("connect") if $uscheme eq "https" && !exists $state{handle}{tls}; 564 $state{handle}->starttls ("connect") if $uscheme eq "https" && !exists $state{handle}{tls};
524 565
525 # send request 566 # send request
526 $state{handle}->push_write ( 567 $state{handle}->push_write (
527 "$method $rpath HTTP/1.0\015\012" 568 "$method $rpath HTTP/1.1\015\012"
528 . (join "", map "\u$_: $hdr{$_}\015\012", grep defined $hdr{$_}, keys %hdr) 569 . (join "", map "\u$_: $hdr{$_}\015\012", grep defined $hdr{$_}, keys %hdr)
529 . "\015\012" 570 . "\015\012"
530 . (delete $arg{body}) 571 . (delete $arg{body})
531 ); 572 );
532 573
533 # return if error occured during push_write() 574 # return if error occured during push_write()
534 return unless %state; 575 return unless %state;
535 576
536 %hdr = (); # reduce memory usage, save a kitten, also make it possible to re-use 577 %hdr = (); # reduce memory usage, save a kitten, also make it possible to re-use
537 578
538 # status line and headers 579 # status line and headers
539 $state{handle}->push_read (line => $qr_nlnl, sub { 580 $state{read_response} = sub {
540 for ("$_[1]") { 581 for ("$_[1]") {
541 y/\015//d; # weed out any \015, as they show up in the weirdest of places. 582 y/\015//d; # weed out any \015, as they show up in the weirdest of places.
542 583
543 /^HTTP\/([0-9\.]+) \s+ ([0-9]{3}) (?: \s+ ([^\015\012]*) )? \015?\012/igxc 584 /^HTTP\/([0-9\.]+) \s+ ([0-9]{3}) (?: \s+ ([^\012]*) )? \012/igxc
544 or return (%state = (), $cb->(undef, { Status => 599, Reason => "Invalid server response", @pseudo })); 585 or return (%state = (), $cb->(undef, { @pseudo, Status => 599, Reason => "Invalid server response" }));
545 586
587 # 100 Continue handling
588 # should not happen as we don't send expect: 100-continue,
589 # but we handle it just in case.
590 # since we send the request body regardless, if we get an error
591 # we are out of-sync, which we currently do NOT handle correctly.
592 return $state{handle}->push_read (line => $qr_nlnl, $state{read_response})
593 if $2 eq 100;
594
546 push @pseudo, 595 push @pseudo,
547 HTTPVersion => $1, 596 HTTPVersion => $1,
548 Status => $2, 597 Status => $2,
549 Reason => $3, 598 Reason => $3,
550 ; 599 ;
551 600
552 # things seen, not parsed: 601 my $hdr = parse_hdr
553 # p3pP="NON CUR OTPi OUR NOR UNI"
554
555 $hdr{lc $1} .= ",$2"
556 while /\G
557 ([^:\000-\037]*):
558 [\011\040]*
559 ((?: [^\012]+ | \012[\011\040] )*)
560 \012
561 /gxc;
562
563 /\G$/
564 or return (%state = (), $cb->(undef, { Status => 599, Reason => "Garbled response headers", @pseudo })); 602 or return (%state = (), $cb->(undef, { @pseudo, Status => 599, Reason => "Garbled response headers" }));
603
604 %hdr = (%$hdr, @pseudo);
605 }
606
607 # redirect handling
608 # microsoft and other shitheads don't give a shit for following standards,
609 # try to support some common forms of broken Location headers.
610 if ($hdr{location} !~ /^(?: $ | [^:\/?\#]+ : )/x) {
611 $hdr{location} =~ s/^\.\/+//;
612
613 my $url = "$rscheme://$uhost:$uport";
614
615 unless ($hdr{location} =~ s/^\///) {
616 $url .= $upath;
617 $url =~ s/\/[^\/]*$//;
565 } 618 }
566 619
567 # remove the "," prefix we added to all headers above
568 substr $_, 0, 1, ""
569 for values %hdr;
570
571 # patch in all pseudo headers
572 %hdr = (%hdr, @pseudo);
573
574 # redirect handling
575 # microsoft and other shitheads don't give a shit for following standards,
576 # try to support some common forms of broken Location headers.
577 if ($hdr{location} !~ /^(?: $ | [^:\/?\#]+ : )/x) {
578 $hdr{location} =~ s/^\.\/+//;
579
580 my $url = "$rscheme://$uhost:$uport";
581
582 unless ($hdr{location} =~ s/^\///) {
583 $url .= $upath;
584 $url =~ s/\/[^\/]*$//;
585 }
586
587 $hdr{location} = "$url/$hdr{location}"; 620 $hdr{location} = "$url/$hdr{location}";
621 }
622
623 my $redirect;
624
625 if ($recurse) {
626 my $status = $hdr{Status};
627
628 # industry standard is to redirect POST as GET for
629 # 301, 302 and 303, in contrast to http/1.0 and 1.1.
630 # also, the UA should ask the user for 301 and 307 and POST,
631 # industry standard seems to be to simply follow.
632 # we go with the industry standard.
633 if ($status == 301 or $status == 302 or $status == 303) {
634 # HTTP/1.1 is unclear on how to mutate the method
635 $method = "GET" unless $method eq "HEAD";
636 $redirect = 1;
637 } elsif ($status == 307) {
638 $redirect = 1;
588 } 639 }
640 }
589 641
642 my $finish = sub { # ($data, $err_status, $err_reason[, $keepalive])
590 my $redirect; 643 my $keepalive = pop;
591 644
645 $state{handle}->destroy if $state{handle};
646 %state = ();
647
648 if (defined $_[1]) {
649 $hdr{OrigStatus} = $hdr{Status}; $hdr{Status} = $_[1];
650 $hdr{OrigReason} = $hdr{Reason}; $hdr{Reason} = $_[2];
651 }
652
653 # set-cookie processing
592 if ($recurse) { 654 if ($arg{cookie_jar}) {
593 my $status = $hdr{Status}; 655 for ($hdr{"set-cookie"}) {
656 # parse NAME=VALUE
657 my @kv;
594 658
595 # industry standard is to redirect POST as GET for 659 while (
596 # 301, 302 and 303, in contrast to http/1.0 and 1.1. 660 m{
597 # also, the UA should ask the user for 301 and 307 and POST, 661 \G\s*
598 # industry standard seems to be to simply follow. 662 (?:
599 # we go with the industry standard. 663 expires \s*=\s* ([A-Z][a-z][a-z],\ [^,;]+)
600 if ($status == 301 or $status == 302 or $status == 303) { 664 | ([^=;,[:space:]]+) \s*=\s* (?: "((?:[^\\"]+|\\.)*)" | ([^=;,[:space:]]*) )
601 # HTTP/1.1 is unclear on how to mutate the method 665 )
602 $method = "GET" unless $method eq "HEAD"; 666 }gcxsi
667 ) {
668 my $name = $2;
669 my $value = $4;
670
671 unless (defined $name) {
672 # expires
673 $name = "expires";
674 $value = $1;
675 } elsif (!defined $value) {
676 # quoted
677 $value = $3;
678 $value =~ s/\\(.)/$1/gs;
679 }
680
681 push @kv, lc $name, $value;
682
683 last unless /\G\s*;/gc;
684 }
685
686 last unless @kv;
687
688 my $name = shift @kv;
689 my %kv = (value => shift @kv, @kv);
690
691 $kv{expires} ||= format_date (AE::now + $kv{"max-age"})
692 if exists $kv{"max-age"};
693
694 my $cdom;
695 my $cpath = (delete $kv{path}) || "/";
696
697 if (exists $kv{domain}) {
698 $cdom = delete $kv{domain};
699
700 $cdom =~ s/^\.?/./; # make sure it starts with a "."
701
702 next if $cdom =~ /\.$/;
703
704 # this is not rfc-like and not netscape-like. go figure.
705 my $ndots = $cdom =~ y/.//;
706 next if $ndots < ($cdom =~ /\.[^.][^.]\.[^.][^.]$/ ? 3 : 2);
707 } else {
708 $cdom = $uhost;
709 }
710
603 $redirect = 1; 711 # store it
604 } elsif ($status == 307) { 712 $arg{cookie_jar}{version} = 1;
605 $redirect = 1; 713 $arg{cookie_jar}{$cdom}{$cpath}{$name} = \%kv;
714
715 redo if /\G\s*,/gc;
606 } 716 }
607 } 717 }
608 718
609 my $finish = sub {
610 $state{handle}->destroy if $state{handle};
611 %state = ();
612
613 # set-cookie processing
614 if ($arg{cookie_jar}) {
615 for ($_[1]{"set-cookie"}) {
616 # parse NAME=VALUE
617 my @kv;
618
619 while (/\G\s* ([^=;,[:space:]]+) \s*=\s* (?: "((?:[^\\"]+|\\.)*)" | ([^=;,[:space:]]*) )/gcxs) {
620 my $name = $1;
621 my $value = $3;
622
623 unless ($value) {
624 $value = $2;
625 $value =~ s/\\(.)/$1/gs;
626 }
627
628 push @kv, $name => $value;
629
630 last unless /\G\s*;/gc;
631 }
632
633 last unless @kv;
634
635 my $name = shift @kv;
636 my %kv = (value => shift @kv, @kv);
637
638 my $cdom;
639 my $cpath = (delete $kv{path}) || "/";
640
641 if (exists $kv{domain}) {
642 $cdom = delete $kv{domain};
643
644 $cdom =~ s/^\.?/./; # make sure it starts with a "."
645
646 next if $cdom =~ /\.$/;
647
648 # this is not rfc-like and not netscape-like. go figure.
649 my $ndots = $cdom =~ y/.//;
650 next if $ndots < ($cdom =~ /\.[^.][^.]\.[^.][^.]$/ ? 3 : 2);
651 } else {
652 $cdom = $uhost;
653 }
654
655 # store it
656 $arg{cookie_jar}{version} = 1;
657 $arg{cookie_jar}{$cdom}{$cpath}{$name} = \%kv;
658
659 redo if /\G\s*,/gc;
660 }
661 }
662
663 if ($redirect && exists $hdr{location}) { 719 if ($redirect && exists $hdr{location}) {
664 # we ignore any errors, as it is very common to receive 720 # we ignore any errors, as it is very common to receive
665 # Content-Length != 0 but no actual body 721 # Content-Length != 0 but no actual body
666 # we also access %hdr, as $_[1] might be an erro 722 # we also access %hdr, as $_[1] might be an erro
667 http_request ( 723 http_request (
668 $method => $hdr{location}, 724 $method => $hdr{location},
669 %arg, 725 %arg,
670 recurse => $recurse - 1, 726 recurse => $recurse - 1,
671 Redirect => \@_, 727 Redirect => [$_[0], \%hdr],
672 $cb); 728 $cb);
673 } else {
674 $cb->($_[0], $_[1]);
675 }
676 };
677
678 my $len = $hdr{"content-length"};
679
680 if (!$redirect && $arg{on_header} && !$arg{on_header}(\%hdr)) {
681 $finish->(undef, { Status => 598, Reason => "Request cancelled by on_header", @pseudo });
682 } elsif (
683 $hdr{Status} =~ /^(?:1..|[23]04)$/
684 or $method eq "HEAD"
685 or (defined $len && !$len)
686 ) {
687 # no body
688 $finish->("", \%hdr);
689 } else { 729 } else {
730 $cb->($_[0], \%hdr);
731 }
732 };
733
734 my $len = $hdr{"content-length"};
735
736 if (!$redirect && $arg{on_header} && !$arg{on_header}(\%hdr)) {
737 $finish->(undef, 598 => "Request cancelled by on_header");
738 } elsif (
739 $hdr{Status} =~ /^(?:1..|204|205|304)$/
740 or $method eq "HEAD"
741 or (defined $len && !$len)
742 ) {
743 # no body
744 $finish->("", undef, undef, 1);
745 } else {
690 # body handling, four different code paths 746 # body handling, many different code paths
691 # for want_body_handle, on_body (2x), normal (2x) 747 # - no body expected
692 # we might read too much here, but it does not matter yet (no pers. connections) 748 # - want_body_handle
749 # - te chunked
750 # - 2x length known (with or without on_body)
751 # - 2x length not known (with or without on_body)
693 if (!$redirect && $arg{want_body_handle}) { 752 if (!$redirect && $arg{want_body_handle}) {
694 $_[0]->on_eof (undef); 753 $_[0]->on_eof (undef);
695 $_[0]->on_error (undef); 754 $_[0]->on_error (undef);
696 $_[0]->on_read (undef); 755 $_[0]->on_read (undef);
697 756
698 $finish->(delete $state{handle}, \%hdr); 757 $finish->(delete $state{handle});
699 758
700 } elsif ($arg{on_body}) { 759 } elsif ($hdr{"transfer-encoding"} =~ /\bchunked\b/i) {
760 my $cl = 0;
761 my $body = undef;
762 my $on_body = $arg{on_body} || sub { $body .= shift; 1 };
763
701 $_[0]->on_error (sub { $finish->(undef, { Status => 599, Reason => $_[2], @pseudo }) }); 764 $_[0]->on_error (sub { $finish->(undef, 599 => $_[2]) });
765
766 my $read_chunk; $read_chunk = sub {
767 $_[1] =~ /^([0-9a-fA-F]+)/
768 or $finish->(undef, 599 => "Garbled chunked transfer encoding");
769
770 my $len = hex $1;
771
702 if ($len) { 772 if ($len) {
703 $_[0]->on_eof (undef); 773 $cl += $len;
774
775 $_[0]->push_read (chunk => $len, sub {
776 $on_body->($_[1], \%hdr)
777 or return $finish->(undef, 598 => "Request cancelled by on_body");
778
704 $_[0]->on_read (sub { 779 $_[0]->push_read (line => sub {
705 $len -= length $_[0]{rbuf}; 780 length $_[1]
706 781 and return $finish->(undef, 599 => "Garbled chunked transfer encoding");
707 $arg{on_body}(delete $_[0]{rbuf}, \%hdr) 782 $_[0]->push_read (line => $read_chunk);
708 or $finish->(undef, { Status => 598, Reason => "Request cancelled by on_body", @pseudo });
709
710 $len > 0 783 });
711 or $finish->("", \%hdr);
712 }); 784 });
713 } else { 785 } else {
714 $_[0]->on_eof (sub { 786 $hdr{"content-length"} ||= $cl;
715 $finish->("", \%hdr); 787
788 $_[0]->push_read (line => $qr_nlnl, sub {
789 if (length $_[1]) {
790 for ("$_[1]") {
791 y/\015//d; # weed out any \015, as they show up in the weirdest of places.
792
793 my $hdr = parse_hdr
794 or return $finish->(undef, 599 => "Garbled response trailers");
795
796 %hdr = (%hdr, %$hdr);
797 }
716 }); 798 }
717 $_[0]->on_read (sub { 799
718 $arg{on_body}(delete $_[0]{rbuf}, \%hdr) 800 $finish->($body, undef, undef, 1);
719 or $finish->(undef, { Status => 598, Reason => "Request cancelled by on_body", @pseudo });
720 }); 801 });
721 } 802 }
803 };
804
805 $_[0]->push_read (line => $read_chunk);
806
807 } elsif ($arg{on_body}) {
808 $_[0]->on_error (sub { $finish->(undef, 599 => $_[2]) });
809
810 if ($len) {
811 $_[0]->on_read (sub {
812 $len -= length $_[0]{rbuf};
813
814 $arg{on_body}(delete $_[0]{rbuf}, \%hdr)
815 or return $finish->(undef, 598 => "Request cancelled by on_body");
816
817 $len > 0
818 or $finish->("", undef, undef, 1);
819 });
722 } else { 820 } else {
723 $_[0]->on_eof (undef); 821 $_[0]->on_eof (sub {
724 822 $finish->("");
725 if ($len) { 823 });
726 $_[0]->on_error (sub { $finish->(undef, { Status => 599, Reason => $_[2], @pseudo }) });
727 $_[0]->on_read (sub { 824 $_[0]->on_read (sub {
825 $arg{on_body}(delete $_[0]{rbuf}, \%hdr)
826 or $finish->(undef, 598 => "Request cancelled by on_body");
827 });
828 }
829 } else {
830 $_[0]->on_eof (undef);
831
832 if ($len) {
833 $_[0]->on_error (sub { $finish->(undef, 599 => $_[2]) });
834 $_[0]->on_read (sub {
728 $finish->((substr delete $_[0]{rbuf}, 0, $len, ""), \%hdr) 835 $finish->((substr delete $_[0]{rbuf}, 0, $len, ""), undef, undef, 1)
729 if $len <= length $_[0]{rbuf}; 836 if $len <= length $_[0]{rbuf};
730 }); 837 });
731 } else { 838 } else {
732 $_[0]->on_error (sub { 839 $_[0]->on_error (sub {
733 ($! == Errno::EPIPE || !$!) 840 ($! == Errno::EPIPE || !$!)
734 ? $finish->(delete $_[0]{rbuf}, \%hdr) 841 ? $finish->(delete $_[0]{rbuf})
735 : $finish->(undef, { Status => 599, Reason => $_[2], @pseudo }); 842 : $finish->(undef, 599 => $_[2]);
736 }); 843 });
737 $_[0]->on_read (sub { }); 844 $_[0]->on_read (sub { });
738 }
739 } 845 }
740 } 846 }
741 }); 847 }
742 }; 848 };
743 849
850 $state{handle}->push_read (line => $qr_nlnl, $state{read_response});
851 };
852
744 # now handle proxy-CONNECT method 853 # now handle proxy-CONNECT method
745 if ($proxy && $uscheme eq "https") { 854 if ($proxy && $uscheme eq "https") {
746 # oh dear, we have to wrap it into a connect request 855 # oh dear, we have to wrap it into a connect request
747 856
748 # maybe re-use $uauthority with patched port? 857 # maybe re-use $uauthority with patched port?
749 $state{handle}->push_write ("CONNECT $uhost:$uport HTTP/1.0\015\012Host: $uhost\015\012\015\012"); 858 $state{handle}->push_write ("CONNECT $uhost:$uport HTTP/1.0\015\012Host: $uhost\015\012\015\012");
750 $state{handle}->push_read (line => $qr_nlnl, sub { 859 $state{handle}->push_read (line => $qr_nlnl, sub {
751 $_[1] =~ /^HTTP\/([0-9\.]+) \s+ ([0-9]{3}) (?: \s+ ([^\015\012]*) )?/ix 860 $_[1] =~ /^HTTP\/([0-9\.]+) \s+ ([0-9]{3}) (?: \s+ ([^\015\012]*) )?/ix
752 or return (%state = (), $cb->(undef, { Status => 599, Reason => "Invalid proxy connect response ($_[1])", @pseudo })); 861 or return (%state = (), $cb->(undef, { @pseudo, Status => 599, Reason => "Invalid proxy connect response ($_[1])" }));
753 862
754 if ($2 == 200) { 863 if ($2 == 200) {
755 $rpath = $upath; 864 $rpath = $upath;
756 &$handle_actual_request; 865 &$handle_actual_request;
757 } else { 866 } else {
758 %state = (); 867 %state = ();
759 $cb->(undef, { Status => $2, Reason => $3, @pseudo }); 868 $cb->(undef, { @pseudo, Status => $2, Reason => $3 });
760 }
761 }); 869 }
870 });
762 } else { 871 } else {
763 &$handle_actual_request; 872 &$handle_actual_request;
764 }
765
766 }, 873 }
767 $arg{on_prepare} || sub { $timeout }
768 ); 874 };
875
876 my $tcp_connect = $arg{tcp_connect}
877 || do { require AnyEvent::Socket; \&AnyEvent::Socket::tcp_connect };
878
879 $state{connect_guard} = $tcp_connect->($rhost, $rport, $connect_cb, $arg{on_prepare} || sub { $timeout });
880
769 }; 881 };
770 882
771 defined wantarray && AnyEvent::Util::guard { %state = () } 883 defined wantarray && AnyEvent::Util::guard { %state = () }
772} 884}
773 885
… …
815Takes a POSIX timestamp (seconds since the epoch) and formats it as a HTTP 927Takes a POSIX timestamp (seconds since the epoch) and formats it as a HTTP
816Date (RFC 2616). 928Date (RFC 2616).
817 929
818=item $timestamp = AnyEvent::HTTP::parse_date $date 930=item $timestamp = AnyEvent::HTTP::parse_date $date
819 931
820Takes a HTTP Date (RFC 2616) and returns the corresponding POSIX 932Takes a HTTP Date (RFC 2616) or a Cookie date (netscape cookie spec) and
821timestamp, or C<undef> if the date cannot be parsed. 933returns the corresponding POSIX timestamp, or C<undef> if the date cannot
934be parsed.
822 935
823=item $AnyEvent::HTTP::MAX_RECURSE 936=item $AnyEvent::HTTP::MAX_RECURSE
824 937
825The default value for the C<recurse> request parameter (default: C<10>). 938The default value for the C<recurse> request parameter (default: C<10>).
826 939
… …
865sub parse_date($) { 978sub parse_date($) {
866 my ($date) = @_; 979 my ($date) = @_;
867 980
868 my ($d, $m, $y, $H, $M, $S); 981 my ($d, $m, $y, $H, $M, $S);
869 982
870 if ($date =~ /^[A-Z][a-z][a-z], ([0-9][0-9]) ([A-Z][a-z][a-z]) ([0-9][0-9][0-9][0-9]) ([0-9][0-9]):([0-9][0-9]):([0-9][0-9]) GMT$/) { 983 if ($date =~ /^[A-Z][a-z][a-z], ([0-9][0-9])[\- ]([A-Z][a-z][a-z])[\- ]([0-9][0-9][0-9][0-9]) ([0-9][0-9]):([0-9][0-9]):([0-9][0-9]) GMT$/) {
871 # RFC 822/1123, required by RFC 2616 984 # RFC 822/1123, required by RFC 2616 (with " ")
985 # cookie dates (with "-")
986
872 ($d, $m, $y, $H, $M, $S) = ($1, $2, $3, $4, $5, $6); 987 ($d, $m, $y, $H, $M, $S) = ($1, $2, $3, $4, $5, $6);
873 988
874 } elsif ($date =~ /^[A-Z][a-z]+, ([0-9][0-9])-([A-Z][a-z][a-z])-([0-9][0-9]) ([0-9][0-9]):([0-9][0-9]):([0-9][0-9]) GMT$/) { 989 } elsif ($date =~ /^[A-Z][a-z]+, ([0-9][0-9])-([A-Z][a-z][a-z])-([0-9][0-9]) ([0-9][0-9]):([0-9][0-9]):([0-9][0-9]) GMT$/) {
875 # RFC 850 990 # RFC 850
876 ($d, $m, $y, $H, $M, $S) = ($1, $2, $3 < 69 ? $3 + 2000 : $3 + 1900, $4, $5, $6); 991 ($d, $m, $y, $H, $M, $S) = ($1, $2, $3 < 69 ? $3 + 2000 : $3 + 1900, $4, $5, $6);

Diff Legend

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