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.73 by root, Fri Dec 31 21:00:36 2010 UTC vs.
Revision 1.77 by root, Sat Jan 1 19:13:41 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 receive or processing.
138
139=item 598 - user aborted request in 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) = @_;
600 _get_slot $uhost, sub { 614 _get_slot $uhost, sub {
601 $state{slot_guard} = shift; 615 $state{slot_guard} = shift;
602 616
603 return unless $state{connect_guard}; 617 return unless $state{connect_guard};
604 618
619 my $ae_error = 595; # connecting
620
605 my $connect_cb = sub { 621 my $connect_cb = sub {
606 $state{fh} = shift 622 $state{fh} = shift
607 or do { 623 or do {
608 my $err = "$!"; 624 my $err = "$!";
609 %state = (); 625 %state = ();
610 return $cb->(undef, { @pseudo, Status => 599, Reason => $err }); 626 return $cb->(undef, { @pseudo, Status => $ae_error, Reason => $err });
611 }; 627 };
612
613 pop; # free memory, save a tree
614 628
615 return unless delete $state{connect_guard}; 629 return unless delete $state{connect_guard};
616 630
617 # get handle 631 # get handle
618 $state{handle} = new AnyEvent::Handle 632 $state{handle} = new AnyEvent::Handle
621 tls_ctx => $arg{tls_ctx}, 635 tls_ctx => $arg{tls_ctx},
622 # these need to be reconfigured on keepalive handles 636 # these need to be reconfigured on keepalive handles
623 timeout => $timeout, 637 timeout => $timeout,
624 on_error => sub { 638 on_error => sub {
625 %state = (); 639 %state = ();
626 $cb->(undef, { @pseudo, Status => 599, Reason => $_[2] }); 640 $cb->(undef, { @pseudo, Status => $ae_error, Reason => $_[2] });
627 }, 641 },
628 on_eof => sub { 642 on_eof => sub {
629 %state = (); 643 %state = ();
630 $cb->(undef, { @pseudo, Status => 599, Reason => "Unexpected end-of-file" }); 644 $cb->(undef, { @pseudo, Status => $ae_error, Reason => "Unexpected end-of-file" });
631 }, 645 },
632 ; 646 ;
633 647
634 # limit the number of persistent connections 648 # limit the number of persistent connections
635 # keepalive not yet supported 649 # keepalive not yet supported
643 657
644 $state{handle}->starttls ("connect") if $rscheme eq "https"; 658 $state{handle}->starttls ("connect") if $rscheme eq "https";
645 659
646 # handle actual, non-tunneled, request 660 # handle actual, non-tunneled, request
647 my $handle_actual_request = sub { 661 my $handle_actual_request = sub {
662 $ae_error = 596; # request phase
663
648 $state{handle}->starttls ("connect") if $uscheme eq "https" && !exists $state{handle}{tls}; 664 $state{handle}->starttls ("connect") if $uscheme eq "https" && !exists $state{handle}{tls};
649 665
650 # send request 666 # send request
651 $state{handle}->push_write ( 667 $state{handle}->push_write (
652 "$method $rpath HTTP/1.1\015\012" 668 "$method $rpath HTTP/1.1\015\012"
663 # status line and headers 679 # status line and headers
664 $state{read_response} = sub { 680 $state{read_response} = sub {
665 for ("$_[1]") { 681 for ("$_[1]") {
666 y/\015//d; # weed out any \015, as they show up in the weirdest of places. 682 y/\015//d; # weed out any \015, as they show up in the weirdest of places.
667 683
668 /^HTTP\/([0-9\.]+) \s+ ([0-9]{3}) (?: \s+ ([^\012]*) )? \012/igxc 684 /^HTTP\/0*([0-9\.]+) \s+ ([0-9]{3}) (?: \s+ ([^\012]*) )? \012/gxci
669 or return (%state = (), $cb->(undef, { @pseudo, Status => 599, Reason => "Invalid server response" })); 685 or return (%state = (), $cb->(undef, { @pseudo, Status => 599, Reason => "Invalid server response" }));
670 686
671 # 100 Continue handling 687 # 100 Continue handling
672 # should not happen as we don't send expect: 100-continue, 688 # should not happen as we don't send expect: 100-continue,
673 # but we handle it just in case. 689 # but we handle it just in case.
708 724
709 if ($recurse) { 725 if ($recurse) {
710 my $status = $hdr{Status}; 726 my $status = $hdr{Status};
711 727
712 # industry standard is to redirect POST as GET for 728 # industry standard is to redirect POST as GET for
713 # 301, 302 and 303, in contrast to http/1.0 and 1.1. 729 # 301, 302 and 303, in contrast to HTTP/1.0 and 1.1.
714 # also, the UA should ask the user for 301 and 307 and POST, 730 # also, the UA should ask the user for 301 and 307 and POST,
715 # industry standard seems to be to simply follow. 731 # industry standard seems to be to simply follow.
716 # we go with the industry standard. 732 # we go with the industry standard.
717 if ($status == 301 or $status == 302 or $status == 303) { 733 if ($status == 301 or $status == 302 or $status == 303) {
718 # HTTP/1.1 is unclear on how to mutate the method 734 # HTTP/1.1 is unclear on how to mutate the method
722 $redirect = 1; 738 $redirect = 1;
723 } 739 }
724 } 740 }
725 741
726 my $finish = sub { # ($data, $err_status, $err_reason[, $keepalive]) 742 my $finish = sub { # ($data, $err_status, $err_reason[, $keepalive])
727 my $keepalive = pop; 743 my $may_keep_alive = $_[3];
728 744
729 $state{handle}->destroy if $state{handle}; 745 $state{handle}->destroy if $state{handle};
730 %state = (); 746 %state = ();
731 747
732 if (defined $_[1]) { 748 if (defined $_[1]) {
751 $cb); 767 $cb);
752 } else { 768 } else {
753 $cb->($_[0], \%hdr); 769 $cb->($_[0], \%hdr);
754 } 770 }
755 }; 771 };
772
773 $ae_error = 597; # body phase
756 774
757 my $len = $hdr{"content-length"}; 775 my $len = $hdr{"content-length"};
758 776
759 if (!$redirect && $arg{on_header} && !$arg{on_header}(\%hdr)) { 777 if (!$redirect && $arg{on_header} && !$arg{on_header}(\%hdr)) {
760 $finish->(undef, 598 => "Request cancelled by on_header"); 778 $finish->(undef, 598 => "Request cancelled by on_header");
782 } elsif ($hdr{"transfer-encoding"} =~ /\bchunked\b/i) { 800 } elsif ($hdr{"transfer-encoding"} =~ /\bchunked\b/i) {
783 my $cl = 0; 801 my $cl = 0;
784 my $body = undef; 802 my $body = undef;
785 my $on_body = $arg{on_body} || sub { $body .= shift; 1 }; 803 my $on_body = $arg{on_body} || sub { $body .= shift; 1 };
786 804
787 $_[0]->on_error (sub { $finish->(undef, 599 => $_[2]) });
788
789 my $read_chunk; $read_chunk = sub { 805 my $read_chunk; $read_chunk = sub {
790 $_[1] =~ /^([0-9a-fA-F]+)/ 806 $_[1] =~ /^([0-9a-fA-F]+)/
791 or $finish->(undef, 599 => "Garbled chunked transfer encoding"); 807 or $finish->(undef, $ae_error => "Garbled chunked transfer encoding");
792 808
793 my $len = hex $1; 809 my $len = hex $1;
794 810
795 if ($len) { 811 if ($len) {
796 $cl += $len; 812 $cl += $len;
799 $on_body->($_[1], \%hdr) 815 $on_body->($_[1], \%hdr)
800 or return $finish->(undef, 598 => "Request cancelled by on_body"); 816 or return $finish->(undef, 598 => "Request cancelled by on_body");
801 817
802 $_[0]->push_read (line => sub { 818 $_[0]->push_read (line => sub {
803 length $_[1] 819 length $_[1]
804 and return $finish->(undef, 599 => "Garbled chunked transfer encoding"); 820 and return $finish->(undef, $ae_error => "Garbled chunked transfer encoding");
805 $_[0]->push_read (line => $read_chunk); 821 $_[0]->push_read (line => $read_chunk);
806 }); 822 });
807 }); 823 });
808 } else { 824 } else {
809 $hdr{"content-length"} ||= $cl; 825 $hdr{"content-length"} ||= $cl;
812 if (length $_[1]) { 828 if (length $_[1]) {
813 for ("$_[1]") { 829 for ("$_[1]") {
814 y/\015//d; # weed out any \015, as they show up in the weirdest of places. 830 y/\015//d; # weed out any \015, as they show up in the weirdest of places.
815 831
816 my $hdr = parse_hdr 832 my $hdr = parse_hdr
817 or return $finish->(undef, 599 => "Garbled response trailers"); 833 or return $finish->(undef, $ae_error => "Garbled response trailers");
818 834
819 %hdr = (%hdr, %$hdr); 835 %hdr = (%hdr, %$hdr);
820 } 836 }
821 } 837 }
822 838
826 }; 842 };
827 843
828 $_[0]->push_read (line => $read_chunk); 844 $_[0]->push_read (line => $read_chunk);
829 845
830 } elsif ($arg{on_body}) { 846 } elsif ($arg{on_body}) {
831 $_[0]->on_error (sub { $finish->(undef, 599 => $_[2]) });
832
833 if ($len) { 847 if ($len) {
834 $_[0]->on_read (sub { 848 $_[0]->on_read (sub {
835 $len -= length $_[0]{rbuf}; 849 $len -= length $_[0]{rbuf};
836 850
837 $arg{on_body}(delete $_[0]{rbuf}, \%hdr) 851 $arg{on_body}(delete $_[0]{rbuf}, \%hdr)
851 } 865 }
852 } else { 866 } else {
853 $_[0]->on_eof (undef); 867 $_[0]->on_eof (undef);
854 868
855 if ($len) { 869 if ($len) {
856 $_[0]->on_error (sub { $finish->(undef, 599 => $_[2]) });
857 $_[0]->on_read (sub { 870 $_[0]->on_read (sub {
858 $finish->((substr delete $_[0]{rbuf}, 0, $len, ""), undef, undef, 1) 871 $finish->((substr delete $_[0]{rbuf}, 0, $len, ""), undef, undef, 1)
859 if $len <= length $_[0]{rbuf}; 872 if $len <= length $_[0]{rbuf};
860 }); 873 });
861 } else { 874 } else {
862 $_[0]->on_error (sub { 875 $_[0]->on_error (sub {
863 ($! == Errno::EPIPE || !$!) 876 ($! == Errno::EPIPE || !$!)
864 ? $finish->(delete $_[0]{rbuf}) 877 ? $finish->(delete $_[0]{rbuf})
865 : $finish->(undef, 599 => $_[2]); 878 : $finish->(undef, $ae_error => $_[2]);
866 }); 879 });
867 $_[0]->on_read (sub { }); 880 $_[0]->on_read (sub { });
868 } 881 }
869 } 882 }
870 } 883 }

Diff Legend

Removed lines
+ Added lines
< Changed lines
> Changed lines