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.70 by root, Fri Dec 31 20:31:47 2010 UTC vs.
Revision 1.79 by root, Sat Jan 1 20:01:07 2011 UTC

122 122
123If the server sends a header multiple times, then their contents will be 123If the server sends a header multiple times, then their contents will be
124joined together with a comma (C<,>), as per the HTTP spec. 124joined together with a comma (C<,>), as per the HTTP spec.
125 125
126If an internal error occurs, such as not being able to resolve a hostname, 126If an internal error occurs, such as not being able to resolve a hostname,
127then C<$data> will be C<undef>, C<< $headers->{Status} >> will be C<59x> 127then C<$data> will be C<undef>, C<< $headers->{Status} >> will be
128(usually C<599>) and the C<Reason> pseudo-header will contain an error 128C<590>-C<599> and the C<Reason> pseudo-header will contain an error
129message. 129message. Currently the following status codes are used:
130
131=over 4
132
133=item 595 - errors during connection etsbalishment, proxy handshake.
134
135=item 596 - errors during TLS negotiation, request sending and header processing.
136
137=item 597 - errors during body receiving or processing.
138
139=item 598 - user aborted request via C<on_header> or C<on_body>.
140
141=item 599 - other, usually nonretryable, errors (garbled URL etc.).
142
143=back
130 144
131A typical callback might look like this: 145A typical callback might look like this:
132 146
133 sub { 147 sub {
134 my ($body, $hdr) = @_; 148 my ($body, $hdr) = @_;
364 push @{ $CO_SLOT{$_[0]}[1] }, $_[1]; 378 push @{ $CO_SLOT{$_[0]}[1] }, $_[1];
365 379
366 _slot_schedule $_[0]; 380 _slot_schedule $_[0];
367} 381}
368 382
383# extract cookies from jar
384sub cookie_jar_extract($$$$) {
385 my ($jar, $uscheme, $uhost, $upath) = @_;
386
387 %$jar = () if $jar->{version} != 1;
388
389 my @cookies;
390
391 while (my ($chost, $paths) = each %$jar) {
392 next unless ref $paths;
393
394 if ($chost =~ /^\./) {
395 next unless $chost eq substr $uhost, -length $chost;
396 } elsif ($chost =~ /\./) {
397 next unless $chost eq $uhost;
398 } else {
399 next;
400 }
401
402 while (my ($cpath, $cookies) = each %$paths) {
403 next unless $cpath eq substr $upath, 0, length $cpath;
404
405 while (my ($cookie, $kv) = each %$cookies) {
406 next if $uscheme ne "https" && exists $kv->{secure};
407
408 if (exists $kv->{expires}) {
409 if (AE::now > parse_date ($kv->{expires})) {
410 delete $cookies->{$cookie};
411 next;
412 }
413 }
414
415 my $value = $kv->{value};
416
417 if ($value =~ /[=;,[:space:]]/) {
418 $value =~ s/([\\"])/\\$1/g;
419 $value = "\"$value\"";
420 }
421
422 push @cookies, "$cookie=$value";
423 }
424 }
425 }
426
427 \@cookies
428}
429
430# parse set_cookie header into jar
431sub cookie_jar_set_cookie($$$) {
432 my ($jar, $set_cookie, $uhost) = @_;
433
434 for ($set_cookie) {
435 # parse NAME=VALUE
436 my @kv;
437
438 # expires is not http-compliant in the original cookie-spec,
439 # we support the official date format and some extensions
440 while (
441 m{
442 \G\s*
443 (?:
444 expires \s*=\s* ([A-Z][a-z][a-z]+,\ [^,;]+)
445 | ([^=;,[:space:]]+) \s*=\s* (?: "((?:[^\\"]+|\\.)*)" | ([^=;,[:space:]]*) )
446 )
447 }gcxsi
448 ) {
449 my $name = $2;
450 my $value = $4;
451
452 unless (defined $name) {
453 # expires
454 $name = "expires";
455 $value = $1;
456 } elsif (!defined $value) {
457 # quoted
458 $value = $3;
459 $value =~ s/\\(.)/$1/gs;
460 }
461
462 push @kv, lc $name, $value;
463
464 last unless /\G\s*;/gc;
465 }
466
467 last unless @kv;
468
469 my $name = shift @kv;
470 my %kv = (value => shift @kv, @kv);
471
472 $kv{expires} ||= format_date (AE::now + $kv{"max-age"})
473 if exists $kv{"max-age"};
474
475 my $cdom;
476 my $cpath = (delete $kv{path}) || "/";
477
478 if (exists $kv{domain}) {
479 $cdom = delete $kv{domain};
480
481 $cdom =~ s/^\.?/./; # make sure it starts with a "."
482
483 next if $cdom =~ /\.$/;
484
485 # this is not rfc-like and not netscape-like. go figure.
486 my $ndots = $cdom =~ y/.//;
487 next if $ndots < ($cdom =~ /\.[^.][^.]\.[^.][^.]$/ ? 3 : 2);
488 } else {
489 $cdom = $uhost;
490 }
491
492 # store it
493 $jar->{version} = 1;
494 $jar->{$cdom}{$cpath}{$name} = \%kv;
495
496 redo if /\G\s*,/gc;
497 }
498}
499
369# continue to parse $_ for headers and place them into the arg 500# continue to parse $_ for headers and place them into the arg
370sub parse_hdr() { 501sub parse_hdr() {
371 my %hdr; 502 my %hdr;
372 503
373 # things seen, not parsed: 504 # things seen, not parsed:
448 579
449 $upath =~ s%^/?%/%; 580 $upath =~ s%^/?%/%;
450 581
451 # cookie processing 582 # cookie processing
452 if (my $jar = $arg{cookie_jar}) { 583 if (my $jar = $arg{cookie_jar}) {
453 %$jar = () if $jar->{version} != 1; 584 my $cookies = cookie_jar_extract $jar, $uscheme, $uhost, $upath;
454
455 my @cookie;
456
457 while (my ($chost, $paths) = each %$jar) {
458 if ($chost =~ /^\./) {
459 next unless $chost eq substr $uhost, -length $chost;
460 } elsif ($chost =~ /\./) {
461 next unless $chost eq $uhost;
462 } else {
463 next;
464 }
465 585
466 while (my ($cpath, $cookies) = each %$paths) {
467 next unless $cpath eq substr $upath, 0, length $cpath;
468
469 while (my ($cookie, $kv) = each %$cookies) {
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
479 my $value = $kv->{value};
480 $value =~ s/([\\"])/\\$1/g;
481 push @cookie, "$cookie=\"$value\"";
482 }
483 }
484 }
485
486 $hdr{cookie} = join "; ", @cookie 586 $hdr{cookie} = join "; ", @$cookies
487 if @cookie; 587 if @$cookies;
488 } 588 }
489 589
490 my ($rhost, $rport, $rscheme, $rpath); # request host, port, path 590 my ($rhost, $rport, $rscheme, $rpath); # request host, port, path
491 591
492 if ($proxy) { 592 if ($proxy) {
516 _get_slot $uhost, sub { 616 _get_slot $uhost, sub {
517 $state{slot_guard} = shift; 617 $state{slot_guard} = shift;
518 618
519 return unless $state{connect_guard}; 619 return unless $state{connect_guard};
520 620
621 my $ae_error = 595; # connecting
622
521 my $connect_cb = sub { 623 my $connect_cb = sub {
522 $state{fh} = shift 624 $state{fh} = shift
523 or do { 625 or do {
524 my $err = "$!"; 626 my $err = "$!";
525 %state = (); 627 %state = ();
526 return $cb->(undef, { @pseudo, Status => 599, Reason => $err }); 628 return $cb->(undef, { @pseudo, Status => $ae_error, Reason => $err });
527 }; 629 };
528
529 pop; # free memory, save a tree
530 630
531 return unless delete $state{connect_guard}; 631 return unless delete $state{connect_guard};
532 632
533 # get handle 633 # get handle
534 $state{handle} = new AnyEvent::Handle 634 $state{handle} = new AnyEvent::Handle
537 tls_ctx => $arg{tls_ctx}, 637 tls_ctx => $arg{tls_ctx},
538 # these need to be reconfigured on keepalive handles 638 # these need to be reconfigured on keepalive handles
539 timeout => $timeout, 639 timeout => $timeout,
540 on_error => sub { 640 on_error => sub {
541 %state = (); 641 %state = ();
542 $cb->(undef, { @pseudo, Status => 599, Reason => $_[2] }); 642 $cb->(undef, { @pseudo, Status => $ae_error, Reason => $_[2] });
543 }, 643 },
544 on_eof => sub { 644 on_eof => sub {
545 %state = (); 645 %state = ();
546 $cb->(undef, { @pseudo, Status => 599, Reason => "Unexpected end-of-file" }); 646 $cb->(undef, { @pseudo, Status => $ae_error, Reason => "Unexpected end-of-file" });
547 }, 647 },
548 ; 648 ;
549 649
550 # limit the number of persistent connections 650 # limit the number of persistent connections
551 # keepalive not yet supported 651 # keepalive not yet supported
559 659
560 $state{handle}->starttls ("connect") if $rscheme eq "https"; 660 $state{handle}->starttls ("connect") if $rscheme eq "https";
561 661
562 # handle actual, non-tunneled, request 662 # handle actual, non-tunneled, request
563 my $handle_actual_request = sub { 663 my $handle_actual_request = sub {
664 $ae_error = 596; # request phase
665
564 $state{handle}->starttls ("connect") if $uscheme eq "https" && !exists $state{handle}{tls}; 666 $state{handle}->starttls ("connect") if $uscheme eq "https" && !exists $state{handle}{tls};
565 667
566 # send request 668 # send request
567 $state{handle}->push_write ( 669 $state{handle}->push_write (
568 "$method $rpath HTTP/1.1\015\012" 670 "$method $rpath HTTP/1.1\015\012"
579 # status line and headers 681 # status line and headers
580 $state{read_response} = sub { 682 $state{read_response} = sub {
581 for ("$_[1]") { 683 for ("$_[1]") {
582 y/\015//d; # weed out any \015, as they show up in the weirdest of places. 684 y/\015//d; # weed out any \015, as they show up in the weirdest of places.
583 685
584 /^HTTP\/([0-9\.]+) \s+ ([0-9]{3}) (?: \s+ ([^\012]*) )? \012/igxc 686 /^HTTP\/0*([0-9\.]+) \s+ ([0-9]{3}) (?: \s+ ([^\012]*) )? \012/gxci
585 or return (%state = (), $cb->(undef, { @pseudo, Status => 599, Reason => "Invalid server response" })); 687 or return (%state = (), $cb->(undef, { @pseudo, Status => 599, Reason => "Invalid server response" }));
586 688
587 # 100 Continue handling 689 # 100 Continue handling
588 # should not happen as we don't send expect: 100-continue, 690 # should not happen as we don't send expect: 100-continue,
589 # but we handle it just in case. 691 # but we handle it just in case.
624 726
625 if ($recurse) { 727 if ($recurse) {
626 my $status = $hdr{Status}; 728 my $status = $hdr{Status};
627 729
628 # industry standard is to redirect POST as GET for 730 # industry standard is to redirect POST as GET for
629 # 301, 302 and 303, in contrast to http/1.0 and 1.1. 731 # 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, 732 # also, the UA should ask the user for 301 and 307 and POST,
631 # industry standard seems to be to simply follow. 733 # industry standard seems to be to simply follow.
632 # we go with the industry standard. 734 # we go with the industry standard.
633 if ($status == 301 or $status == 302 or $status == 303) { 735 if ($status == 301 or $status == 302 or $status == 303) {
634 # HTTP/1.1 is unclear on how to mutate the method 736 # HTTP/1.1 is unclear on how to mutate the method
638 $redirect = 1; 740 $redirect = 1;
639 } 741 }
640 } 742 }
641 743
642 my $finish = sub { # ($data, $err_status, $err_reason[, $keepalive]) 744 my $finish = sub { # ($data, $err_status, $err_reason[, $keepalive])
643 my $keepalive = pop; 745 my $may_keep_alive = $_[3];
644 746
645 $state{handle}->destroy if $state{handle}; 747 $state{handle}->destroy if $state{handle};
646 %state = (); 748 %state = ();
647 749
648 if (defined $_[1]) { 750 if (defined $_[1]) {
650 $hdr{OrigReason} = $hdr{Reason}; $hdr{Reason} = $_[2]; 752 $hdr{OrigReason} = $hdr{Reason}; $hdr{Reason} = $_[2];
651 } 753 }
652 754
653 # set-cookie processing 755 # set-cookie processing
654 if ($arg{cookie_jar}) { 756 if ($arg{cookie_jar}) {
655 for ($hdr{"set-cookie"}) { 757 cookie_jar_set_cookie $arg{cookie_jar}, $hdr{"set-cookie"}, $uhost;
656 # parse NAME=VALUE
657 my @kv;
658
659 while (
660 m{
661 \G\s*
662 (?:
663 expires \s*=\s* ([A-Z][a-z][a-z],\ [^,;]+)
664 | ([^=;,[:space:]]+) \s*=\s* (?: "((?:[^\\"]+|\\.)*)" | ([^=;,[:space:]]*) )
665 )
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
711 # store it
712 $arg{cookie_jar}{version} = 1;
713 $arg{cookie_jar}{$cdom}{$cpath}{$name} = \%kv;
714
715 redo if /\G\s*,/gc;
716 }
717 } 758 }
718 759
719 if ($redirect && exists $hdr{location}) { 760 if ($redirect && exists $hdr{location}) {
720 # we ignore any errors, as it is very common to receive 761 # we ignore any errors, as it is very common to receive
721 # Content-Length != 0 but no actual body 762 # Content-Length != 0 but no actual body
728 $cb); 769 $cb);
729 } else { 770 } else {
730 $cb->($_[0], \%hdr); 771 $cb->($_[0], \%hdr);
731 } 772 }
732 }; 773 };
774
775 $ae_error = 597; # body phase
733 776
734 my $len = $hdr{"content-length"}; 777 my $len = $hdr{"content-length"};
735 778
736 if (!$redirect && $arg{on_header} && !$arg{on_header}(\%hdr)) { 779 if (!$redirect && $arg{on_header} && !$arg{on_header}(\%hdr)) {
737 $finish->(undef, 598 => "Request cancelled by on_header"); 780 $finish->(undef, 598 => "Request cancelled by on_header");
759 } elsif ($hdr{"transfer-encoding"} =~ /\bchunked\b/i) { 802 } elsif ($hdr{"transfer-encoding"} =~ /\bchunked\b/i) {
760 my $cl = 0; 803 my $cl = 0;
761 my $body = undef; 804 my $body = undef;
762 my $on_body = $arg{on_body} || sub { $body .= shift; 1 }; 805 my $on_body = $arg{on_body} || sub { $body .= shift; 1 };
763 806
764 $_[0]->on_error (sub { $finish->(undef, 599 => $_[2]) });
765
766 my $read_chunk; $read_chunk = sub { 807 my $read_chunk; $read_chunk = sub {
767 $_[1] =~ /^([0-9a-fA-F]+)/ 808 $_[1] =~ /^([0-9a-fA-F]+)/
768 or $finish->(undef, 599 => "Garbled chunked transfer encoding"); 809 or $finish->(undef, $ae_error => "Garbled chunked transfer encoding");
769 810
770 my $len = hex $1; 811 my $len = hex $1;
771 812
772 if ($len) { 813 if ($len) {
773 $cl += $len; 814 $cl += $len;
776 $on_body->($_[1], \%hdr) 817 $on_body->($_[1], \%hdr)
777 or return $finish->(undef, 598 => "Request cancelled by on_body"); 818 or return $finish->(undef, 598 => "Request cancelled by on_body");
778 819
779 $_[0]->push_read (line => sub { 820 $_[0]->push_read (line => sub {
780 length $_[1] 821 length $_[1]
781 and return $finish->(undef, 599 => "Garbled chunked transfer encoding"); 822 and return $finish->(undef, $ae_error => "Garbled chunked transfer encoding");
782 $_[0]->push_read (line => $read_chunk); 823 $_[0]->push_read (line => $read_chunk);
783 }); 824 });
784 }); 825 });
785 } else { 826 } else {
786 $hdr{"content-length"} ||= $cl; 827 $hdr{"content-length"} ||= $cl;
789 if (length $_[1]) { 830 if (length $_[1]) {
790 for ("$_[1]") { 831 for ("$_[1]") {
791 y/\015//d; # weed out any \015, as they show up in the weirdest of places. 832 y/\015//d; # weed out any \015, as they show up in the weirdest of places.
792 833
793 my $hdr = parse_hdr 834 my $hdr = parse_hdr
794 or return $finish->(undef, 599 => "Garbled response trailers"); 835 or return $finish->(undef, $ae_error => "Garbled response trailers");
795 836
796 %hdr = (%hdr, %$hdr); 837 %hdr = (%hdr, %$hdr);
797 } 838 }
798 } 839 }
799 840
803 }; 844 };
804 845
805 $_[0]->push_read (line => $read_chunk); 846 $_[0]->push_read (line => $read_chunk);
806 847
807 } elsif ($arg{on_body}) { 848 } elsif ($arg{on_body}) {
808 $_[0]->on_error (sub { $finish->(undef, 599 => $_[2]) });
809
810 if ($len) { 849 if ($len) {
811 $_[0]->on_read (sub { 850 $_[0]->on_read (sub {
812 $len -= length $_[0]{rbuf}; 851 $len -= length $_[0]{rbuf};
813 852
814 $arg{on_body}(delete $_[0]{rbuf}, \%hdr) 853 $arg{on_body}(delete $_[0]{rbuf}, \%hdr)
828 } 867 }
829 } else { 868 } else {
830 $_[0]->on_eof (undef); 869 $_[0]->on_eof (undef);
831 870
832 if ($len) { 871 if ($len) {
833 $_[0]->on_error (sub { $finish->(undef, 599 => $_[2]) });
834 $_[0]->on_read (sub { 872 $_[0]->on_read (sub {
835 $finish->((substr delete $_[0]{rbuf}, 0, $len, ""), undef, undef, 1) 873 $finish->((substr delete $_[0]{rbuf}, 0, $len, ""), undef, undef, 1)
836 if $len <= length $_[0]{rbuf}; 874 if $len <= length $_[0]{rbuf};
837 }); 875 });
838 } else { 876 } else {
839 $_[0]->on_error (sub { 877 $_[0]->on_error (sub {
840 ($! == Errno::EPIPE || !$!) 878 ($! == Errno::EPIPE || !$!)
841 ? $finish->(delete $_[0]{rbuf}) 879 ? $finish->(delete $_[0]{rbuf})
842 : $finish->(undef, 599 => $_[2]); 880 : $finish->(undef, $ae_error => $_[2]);
843 }); 881 });
844 $_[0]->on_read (sub { }); 882 $_[0]->on_read (sub { });
845 } 883 }
846 } 884 }
847 } 885 }
927Takes a POSIX timestamp (seconds since the epoch) and formats it as a HTTP 965Takes a POSIX timestamp (seconds since the epoch) and formats it as a HTTP
928Date (RFC 2616). 966Date (RFC 2616).
929 967
930=item $timestamp = AnyEvent::HTTP::parse_date $date 968=item $timestamp = AnyEvent::HTTP::parse_date $date
931 969
932Takes a HTTP Date (RFC 2616) or a Cookie date (netscape cookie spec) and 970Takes a HTTP Date (RFC 2616) or a Cookie date (netscape cookie spec) or a
933returns the corresponding POSIX timestamp, or C<undef> if the date cannot 971bunch of minor variations of those, and returns the corresponding POSIX
934be parsed. 972timestamp, or C<undef> if the date cannot be parsed.
935 973
936=item $AnyEvent::HTTP::MAX_RECURSE 974=item $AnyEvent::HTTP::MAX_RECURSE
937 975
938The default value for the C<recurse> request parameter (default: C<10>). 976The default value for the C<recurse> request parameter (default: C<10>).
939 977
978sub parse_date($) { 1016sub parse_date($) {
979 my ($date) = @_; 1017 my ($date) = @_;
980 1018
981 my ($d, $m, $y, $H, $M, $S); 1019 my ($d, $m, $y, $H, $M, $S);
982 1020
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$/) { 1021 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$/) {
984 # RFC 822/1123, required by RFC 2616 (with " ") 1022 # RFC 822/1123, required by RFC 2616 (with " ")
985 # cookie dates (with "-") 1023 # cookie dates (with "-")
986 1024
987 ($d, $m, $y, $H, $M, $S) = ($1, $2, $3, $4, $5, $6); 1025 ($d, $m, $y, $H, $M, $S) = ($1, $2, $3, $4, $5, $6);
988 1026
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$/) { 1027 } elsif ($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]?) GMT$/) {
990 # RFC 850 1028 # RFC 850
991 ($d, $m, $y, $H, $M, $S) = ($1, $2, $3 < 69 ? $3 + 2000 : $3 + 1900, $4, $5, $6); 1029 ($d, $m, $y, $H, $M, $S) = ($1, $2, $3 < 69 ? $3 + 2000 : $3 + 1900, $4, $5, $6);
992 1030
993 } elsif ($date =~ /^[A-Z][a-z][a-z] ([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][0-9][0-9])$/) { 1031 } elsif ($date =~ /^[A-Z][a-z][a-z]+ ([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][0-9][0-9])$/) {
994 # ISO C's asctime 1032 # ISO C's asctime
995 ($d, $m, $y, $H, $M, $S) = ($2, $1, $6, $3, $4, $5); 1033 ($d, $m, $y, $H, $M, $S) = ($2, $1, $6, $3, $4, $5);
996 } 1034 }
997 # other formats fail in the loop below 1035 # other formats fail in the loop below
998 1036

Diff Legend

Removed lines
+ Added lines
< Changed lines
> Changed lines