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.99 by root, Fri Jan 28 01:17:25 2011 UTC vs.
Revision 1.131 by root, Thu Aug 30 17:04:28 2018 UTC

… …
46use AnyEvent::Util (); 46use AnyEvent::Util ();
47use AnyEvent::Handle (); 47use AnyEvent::Handle ();
48 48
49use base Exporter::; 49use base Exporter::;
50 50
51our $VERSION = '2.03'; 51our $VERSION = 2.24;
52 52
53our @EXPORT = qw(http_get http_post http_head http_request); 53our @EXPORT = qw(http_get http_post http_head http_request);
54 54
55our $USERAGENT = "Mozilla/5.0 (compatible; U; AnyEvent-HTTP/$VERSION; +http://software.schmorp.de/pkg/AnyEvent)"; 55our $USERAGENT = "Mozilla/5.0 (compatible; U; AnyEvent-HTTP/$VERSION; +http://software.schmorp.de/pkg/AnyEvent)";
56our $MAX_RECURSE = 10; 56our $MAX_RECURSE = 10;
… …
89C<http_request> returns a "cancellation guard" - you have to keep the 89C<http_request> returns a "cancellation guard" - you have to keep the
90object at least alive until the callback get called. If the object gets 90object at least alive until the callback get called. If the object gets
91destroyed before the callback is called, the request will be cancelled. 91destroyed before the callback is called, the request will be cancelled.
92 92
93The callback will be called with the response body data as first argument 93The callback will be called with the response body data as first argument
94(or C<undef> if an error occured), and a hash-ref with response headers 94(or C<undef> if an error occurred), and a hash-ref with response headers
95(and trailers) as second argument. 95(and trailers) as second argument.
96 96
97All the headers in that hash are lowercased. In addition to the response 97All the headers in that hash are lowercased. In addition to the response
98headers, the "pseudo-headers" (uppercase to avoid clashing with possible 98headers, the "pseudo-headers" (uppercase to avoid clashing with possible
99response headers) C<HTTPVersion>, C<Status> and C<Reason> contain the 99response headers) C<HTTPVersion>, C<Status> and C<Reason> contain the
… …
123C<590>-C<599> and the C<Reason> pseudo-header will contain an error 123C<590>-C<599> and the C<Reason> pseudo-header will contain an error
124message. Currently the following status codes are used: 124message. Currently the following status codes are used:
125 125
126=over 4 126=over 4
127 127
128=item 595 - errors during connection etsbalishment, proxy handshake. 128=item 595 - errors during connection establishment, proxy handshake.
129 129
130=item 596 - errors during TLS negotiation, request sending and header processing. 130=item 596 - errors during TLS negotiation, request sending and header processing.
131 131
132=item 597 - errors during body receiving or processing. 132=item 597 - errors during body receiving or processing.
133 133
… …
154 154
155=over 4 155=over 4
156 156
157=item recurse => $count (default: $MAX_RECURSE) 157=item recurse => $count (default: $MAX_RECURSE)
158 158
159Whether to recurse requests or not, e.g. on redirects, authentication 159Whether to recurse requests or not, e.g. on redirects, authentication and
160retries and so on, and how often to do so. 160other retries and so on, and how often to do so.
161
162Only redirects to http and https URLs are supported. While most common
163redirection forms are handled entirely within this module, some require
164the use of the optional L<URI> module. If it is required but missing, then
165the request will fail with an error.
161 166
162=item headers => hashref 167=item headers => hashref
163 168
164The request headers to use. Currently, C<http_request> may provide its own 169The request headers to use. Currently, C<http_request> may provide its own
165C<Host:>, C<Content-Length:>, C<Connection:> and C<Cookie:> headers and 170C<Host:>, C<Content-Length:>, C<Connection:> and C<Cookie:> headers and
… …
169 174
170You really should provide your own C<User-Agent:> header value that is 175You really should provide your own C<User-Agent:> header value that is
171appropriate for your program - I wouldn't be surprised if the default 176appropriate for your program - I wouldn't be surprised if the default
172AnyEvent string gets blocked by webservers sooner or later. 177AnyEvent string gets blocked by webservers sooner or later.
173 178
179Also, make sure that your headers names and values do not contain any
180embedded newlines.
181
174=item timeout => $seconds 182=item timeout => $seconds
175 183
176The time-out to use for various stages - each connect attempt will reset 184The time-out to use for various stages - each connect attempt will reset
177the timeout, as will read or write activity, i.e. this is not an overall 185the timeout, as will read or write activity, i.e. this is not an overall
178timeout. 186timeout.
179 187
180Default timeout is 5 minutes. 188Default timeout is 5 minutes.
181 189
182=item proxy => [$host, $port[, $scheme]] or undef 190=item proxy => [$host, $port[, $scheme]] or undef
183 191
184Use the given http proxy for all requests. If not specified, then the 192Use the given http proxy for all requests, or no proxy if C<undef> is
185default proxy (as specified by C<$ENV{http_proxy}>) is used. 193used.
186 194
187C<$scheme> must be either missing or must be C<http> for HTTP. 195C<$scheme> must be either missing or must be C<http> for HTTP.
196
197If not specified, then the default proxy is used (see
198C<AnyEvent::HTTP::set_proxy>).
199
200Currently, if your proxy requires authorization, you have to specify an
201appropriate "Proxy-Authorization" header in every request.
188 202
189=item body => $string 203=item body => $string
190 204
191The request body, usually empty. Will be sent as-is (future versions of 205The request body, usually empty. Will be sent as-is (future versions of
192this module might offer more options). 206this module might offer more options).
… …
236context) - only connections using the same unique ID will be reused. 250context) - only connections using the same unique ID will be reused.
237 251
238=item on_prepare => $callback->($fh) 252=item on_prepare => $callback->($fh)
239 253
240In rare cases you need to "tune" the socket before it is used to 254In rare cases you need to "tune" the socket before it is used to
241connect (for exmaple, to bind it on a given IP address). This parameter 255connect (for example, to bind it on a given IP address). This parameter
242overrides the prepare callback passed to C<AnyEvent::Socket::tcp_connect> 256overrides the prepare callback passed to C<AnyEvent::Socket::tcp_connect>
243and behaves exactly the same way (e.g. it has to provide a 257and behaves exactly the same way (e.g. it has to provide a
244timeout). See the description for the C<$prepare_cb> argument of 258timeout). See the description for the C<$prepare_cb> argument of
245C<AnyEvent::Socket::tcp_connect> for details. 259C<AnyEvent::Socket::tcp_connect> for details.
246 260
… …
378 392
379Example: do a HTTP HEAD request on https://www.google.com/, use a 393Example: do a HTTP HEAD request on https://www.google.com/, use a
380timeout of 30 seconds. 394timeout of 30 seconds.
381 395
382 http_request 396 http_request
383 GET => "https://www.google.com", 397 HEAD => "https://www.google.com",
384 headers => { "user-agent" => "MySearchClient 1.0" }, 398 headers => { "user-agent" => "MySearchClient 1.0" },
385 timeout => 30, 399 timeout => 30,
386 sub { 400 sub {
387 my ($body, $hdr) = @_; 401 my ($body, $hdr) = @_;
388 use Data::Dumper; 402 use Data::Dumper;
… …
440 454
441# expire cookies 455# expire cookies
442sub cookie_jar_expire($;$) { 456sub cookie_jar_expire($;$) {
443 my ($jar, $session_end) = @_; 457 my ($jar, $session_end) = @_;
444 458
445 %$jar = () if $jar->{version} != 1; 459 %$jar = () if $jar->{version} != 2;
446 460
447 my $anow = AE::now; 461 my $anow = AE::now;
448 462
449 while (my ($chost, $paths) = each %$jar) { 463 while (my ($chost, $paths) = each %$jar) {
450 next unless ref $paths; 464 next unless ref $paths;
… …
470 484
471# extract cookies from jar 485# extract cookies from jar
472sub cookie_jar_extract($$$$) { 486sub cookie_jar_extract($$$$) {
473 my ($jar, $scheme, $host, $path) = @_; 487 my ($jar, $scheme, $host, $path) = @_;
474 488
475 %$jar = () if $jar->{version} != 1; 489 %$jar = () if $jar->{version} != 2;
490
491 $host = AnyEvent::Util::idn_to_ascii $host
492 if $host =~ /[^\x00-\x7f]/;
476 493
477 my @cookies; 494 my @cookies;
478 495
479 while (my ($chost, $paths) = each %$jar) { 496 while (my ($chost, $paths) = each %$jar) {
480 next unless ref $paths; 497 next unless ref $paths;
481 498
482 if ($chost =~ /^\./) { 499 # exact match or suffix including . match
483 next unless $chost eq substr $host, -length $chost; 500 $chost eq $host or ".$chost" eq substr $host, -1 - length $chost
484 } elsif ($chost =~ /\./) {
485 next unless $chost eq $host;
486 } else {
487 next; 501 or next;
488 }
489 502
490 while (my ($cpath, $cookies) = each %$paths) { 503 while (my ($cpath, $cookies) = each %$paths) {
491 next unless $cpath eq substr $path, 0, length $cpath; 504 next unless $cpath eq substr $path, 0, length $cpath;
492 505
493 while (my ($cookie, $kv) = each %$cookies) { 506 while (my ($cookie, $kv) = each %$cookies) {
… …
514} 527}
515 528
516# parse set_cookie header into jar 529# parse set_cookie header into jar
517sub cookie_jar_set_cookie($$$$) { 530sub cookie_jar_set_cookie($$$$) {
518 my ($jar, $set_cookie, $host, $date) = @_; 531 my ($jar, $set_cookie, $host, $date) = @_;
532
533 %$jar = () if $jar->{version} != 2;
519 534
520 my $anow = int AE::now; 535 my $anow = int AE::now;
521 my $snow; # server-now 536 my $snow; # server-now
522 537
523 for ($set_cookie) { 538 for ($set_cookie) {
… …
529 while ( 544 while (
530 m{ 545 m{
531 \G\s* 546 \G\s*
532 (?: 547 (?:
533 expires \s*=\s* ([A-Z][a-z][a-z]+,\ [^,;]+) 548 expires \s*=\s* ([A-Z][a-z][a-z]+,\ [^,;]+)
534 | ([^=;,[:space:]]+) (?: \s*=\s* (?: "((?:[^\\"]+|\\.)*)" | ([^=;,[:space:]]*) ) )? 549 | ([^=;,[:space:]]+) (?: \s*=\s* (?: "((?:[^\\"]+|\\.)*)" | ([^;,[:space:]]*) ) )?
535 ) 550 )
536 }gcxsi 551 }gcxsi
537 ) { 552 ) {
538 my $name = $2; 553 my $name = $2;
539 my $value = $4; 554 my $value = $4;
… …
569 584
570 my $cdom; 585 my $cdom;
571 my $cpath = (delete $kv{path}) || "/"; 586 my $cpath = (delete $kv{path}) || "/";
572 587
573 if (exists $kv{domain}) { 588 if (exists $kv{domain}) {
574 $cdom = delete $kv{domain}; 589 $cdom = $kv{domain};
575 590
576 $cdom =~ s/^\.?/./; # make sure it starts with a "." 591 $cdom =~ s/^\.?/./; # make sure it starts with a "."
577 592
578 next if $cdom =~ /\.$/; 593 next if $cdom =~ /\.$/;
579 594
580 # this is not rfc-like and not netscape-like. go figure. 595 # this is not rfc-like and not netscape-like. go figure.
581 my $ndots = $cdom =~ y/.//; 596 my $ndots = $cdom =~ y/.//;
582 next if $ndots < ($cdom =~ /\.[^.][^.]\.[^.][^.]$/ ? 3 : 2); 597 next if $ndots < ($cdom =~ /\.[^.][^.]\.[^.][^.]$/ ? 3 : 2);
598
599 $cdom = substr $cdom, 1; # remove initial .
583 } else { 600 } else {
584 $cdom = $host; 601 $cdom = $host;
585 } 602 }
586 603
587 # store it 604 # store it
588 $jar->{version} = 1; 605 $jar->{version} = 2;
589 $jar->{lc $cdom}{$cpath}{$name} = \%kv; 606 $jar->{lc $cdom}{$cpath}{$name} = \%kv;
590 607
591 redo if /\G\s*,/gc; 608 redo if /\G\s*,/gc;
592 } 609 }
593} 610}
… …
683 700
684 $cb->(undef, $hdr); 701 $cb->(undef, $hdr);
685 () 702 ()
686} 703}
687 704
705our %IDEMPOTENT = (
706 DELETE => 1,
707 GET => 1,
708 HEAD => 1,
709 OPTIONS => 1,
710 PUT => 1,
711 TRACE => 1,
712
713 ACL => 1,
714 "BASELINE-CONTROL" => 1,
715 BIND => 1,
716 CHECKIN => 1,
717 CHECKOUT => 1,
718 COPY => 1,
719 LABEL => 1,
720 LINK => 1,
721 MERGE => 1,
722 MKACTIVITY => 1,
723 MKCALENDAR => 1,
724 MKCOL => 1,
725 MKREDIRECTREF => 1,
726 MKWORKSPACE => 1,
727 MOVE => 1,
728 ORDERPATCH => 1,
729 PROPFIND => 1,
730 PROPPATCH => 1,
731 REBIND => 1,
732 REPORT => 1,
733 SEARCH => 1,
734 UNBIND => 1,
735 UNCHECKOUT => 1,
736 UNLINK => 1,
737 UNLOCK => 1,
738 UPDATE => 1,
739 UPDATEREDIRECTREF => 1,
740 "VERSION-CONTROL" => 1,
741);
742
688sub http_request($$@) { 743sub http_request($$@) {
689 my $cb = pop; 744 my $cb = pop;
690 my ($method, $url, %arg) = @_; 745 my ($method, $url, %arg) = @_;
691 746
692 my %hdr; 747 my %hdr;
… …
709 my $recurse = exists $arg{recurse} ? delete $arg{recurse} : $MAX_RECURSE; 764 my $recurse = exists $arg{recurse} ? delete $arg{recurse} : $MAX_RECURSE;
710 765
711 return $cb->(undef, { @pseudo, Status => 599, Reason => "Too many redirections" }) 766 return $cb->(undef, { @pseudo, Status => 599, Reason => "Too many redirections" })
712 if $recurse < 0; 767 if $recurse < 0;
713 768
714 my $proxy = $arg{proxy} || $PROXY; 769 my $proxy = exists $arg{proxy} ? $arg{proxy} : $PROXY;
715 my $timeout = $arg{timeout} || $TIMEOUT; 770 my $timeout = $arg{timeout} || $TIMEOUT;
716 771
717 my ($uscheme, $uauthority, $upath, $query, undef) = # ignore fragment 772 my ($uscheme, $uauthority, $upath, $query, undef) = # ignore fragment
718 $url =~ m|^([^:/?#]+):(?://([^/?#]*))?([^?#]*)(?:(\?[^#]*))?(?:#(.*))?$|; 773 $url =~ m|^([^:]+):(?://([^/?#]*))?([^?#]*)(?:(\?[^#]*))?(?:#(.*))?$|;
719 774
720 $uscheme = lc $uscheme; 775 $uscheme = lc $uscheme;
721 776
722 my $uport = $uscheme eq "http" ? 80 777 my $uport = $uscheme eq "http" ? 80
723 : $uscheme eq "https" ? 443 778 : $uscheme eq "https" ? 443
724 : return $cb->(undef, { @pseudo, Status => 599, Reason => "Only http and https URL schemes supported" }); 779 : return $cb->(undef, { @pseudo, Status => 599, Reason => "Only http and https URL schemes supported" });
725 780
726 $uauthority =~ /^(?: .*\@ )? ([^\@:]+) (?: : (\d+) )?$/x 781 $uauthority =~ /^(?: .*\@ )? ([^\@]+?) (?: : (\d+) )?$/x
727 or return $cb->(undef, { @pseudo, Status => 599, Reason => "Unparsable URL" }); 782 or return $cb->(undef, { @pseudo, Status => 599, Reason => "Unparsable URL" });
728 783
729 my $uhost = lc $1; 784 my $uhost = lc $1;
730 $uport = $2 if defined $2; 785 $uport = $2 if defined $2;
731 786
… …
767 $hdr{"user-agent"} = $USERAGENT unless exists $hdr{"user-agent"}; 822 $hdr{"user-agent"} = $USERAGENT unless exists $hdr{"user-agent"};
768 823
769 $hdr{"content-length"} = length $arg{body} 824 $hdr{"content-length"} = length $arg{body}
770 if length $arg{body} || $method ne "GET"; 825 if length $arg{body} || $method ne "GET";
771 826
772 my $idempotent = $method =~ /^(?:GET|HEAD|PUT|DELETE|OPTIONS|TRACE)$/; 827 my $idempotent = $IDEMPOTENT{$method};
773 828
774 # default value for keepalive is true iff the request is for an idempotent method 829 # default value for keepalive is true iff the request is for an idempotent method
775 my $keepalive = exists $arg{keepalive} ? !!$arg{keepalive} : $idempotent; 830 my $persistent = exists $arg{persistent} ? !!$arg{persistent} : $idempotent;
776 my $keepalive10 = exists $arg{keepalive10} ? $arg{keepalive10} : !$proxy; 831 my $keepalive = exists $arg{keepalive} ? !!$arg{keepalive} : !$proxy;
777 my $keptalive; # true if this is actually a recycled connection 832 my $was_persistent; # true if this is actually a recycled connection
778 833
779 # the key to use in the keepalive cache 834 # the key to use in the keepalive cache
780 my $ka_key = "$uhost\x00$arg{sessionid}"; 835 my $ka_key = "$uscheme\x00$uhost\x00$uport\x00$arg{sessionid}";
781 836
782 $hdr{connection} = ($keepalive ? $keepalive10 ? "keep-alive " : "" : "close ") . "Te"; #1.1 837 $hdr{connection} = ($persistent ? $keepalive ? "keep-alive, " : "" : "close, ") . "Te"; #1.1
783 $hdr{te} = "trailers" unless exists $hdr{te}; #1.1 838 $hdr{te} = "trailers" unless exists $hdr{te}; #1.1
784 839
785 my %state = (connect_guard => 1); 840 my %state = (connect_guard => 1);
786 841
787 my $ae_error = 595; # connecting 842 my $ae_error = 595; # connecting
… …
797 # send request 852 # send request
798 $hdl->push_write ( 853 $hdl->push_write (
799 "$method $rpath HTTP/1.1\015\012" 854 "$method $rpath HTTP/1.1\015\012"
800 . (join "", map "\u$_: $hdr{$_}\015\012", grep defined $hdr{$_}, keys %hdr) 855 . (join "", map "\u$_: $hdr{$_}\015\012", grep defined $hdr{$_}, keys %hdr)
801 . "\015\012" 856 . "\015\012"
802 . (delete $arg{body}) 857 . $arg{body}
803 ); 858 );
804 859
805 # return if error occured during push_write() 860 # return if error occurred during push_write()
806 return unless %state; 861 return unless %state;
807 862
808 # reduce memory usage, save a kitten, also re-use it for the response headers. 863 # reduce memory usage, save a kitten, also re-use it for the response headers.
809 %hdr = (); 864 %hdr = ();
810 865
… …
837 892
838 %hdr = (%$hdr, @pseudo); 893 %hdr = (%$hdr, @pseudo);
839 } 894 }
840 895
841 # redirect handling 896 # redirect handling
842 # microsoft and other shitheads don't give a shit for following standards, 897 # relative uri handling forced by microsoft and other shitheads.
843 # try to support some common forms of broken Location headers. 898 # we give our best and fall back to URI if available.
844 if ($hdr{location} !~ /^(?: $ | [^:\/?\#]+ : )/x) { 899 if (exists $hdr{location}) {
900 my $loc = $hdr{location};
901
902 if ($loc =~ m%^//%) { # //
903 $loc = "$uscheme:$loc";
904
905 } elsif ($loc eq "") {
906 $loc = $url;
907
908 } elsif ($loc !~ /^(?: $ | [^:\/?\#]+ : )/x) { # anything "simple"
845 $hdr{location} =~ s/^\.\/+//; 909 $loc =~ s/^\.\/+//;
846 910
847 my $url = "$rscheme://$uhost:$uport"; 911 if ($loc !~ m%^[.?#]%) {
912 my $prefix = "$uscheme://$uauthority";
848 913
849 unless ($hdr{location} =~ s/^\///) { 914 unless ($loc =~ s/^\///) {
850 $url .= $upath; 915 $prefix .= $upath;
851 $url =~ s/\/[^\/]*$//; 916 $prefix =~ s/\/[^\/]*$//;
917 }
918
919 $loc = "$prefix/$loc";
920
921 } elsif (eval { require URI }) { # uri
922 $loc = URI->new_abs ($loc, $url)->as_string;
923
924 } else {
925 return _error %state, $cb, { @pseudo, Status => 599, Reason => "Cannot parse Location (URI module missing)" };
926 #$hdr{Status} = 599;
927 #$hdr{Reason} = "Unparsable Redirect (URI module missing)";
928 #$recurse = 0;
929 }
852 } 930 }
853 931
854 $hdr{location} = "$url/$hdr{location}"; 932 $hdr{location} = $loc;
855 } 933 }
856 934
857 my $redirect; 935 my $redirect;
858 936
859 if ($recurse) { 937 if ($recurse) {
… …
861 939
862 # industry standard is to redirect POST as GET for 940 # industry standard is to redirect POST as GET for
863 # 301, 302 and 303, in contrast to HTTP/1.0 and 1.1. 941 # 301, 302 and 303, in contrast to HTTP/1.0 and 1.1.
864 # also, the UA should ask the user for 301 and 307 and POST, 942 # also, the UA should ask the user for 301 and 307 and POST,
865 # industry standard seems to be to simply follow. 943 # industry standard seems to be to simply follow.
866 # we go with the industry standard. 944 # we go with the industry standard. 308 is defined
945 # by rfc7538
867 if ($status == 301 or $status == 302 or $status == 303) { 946 if ($status == 301 or $status == 302 or $status == 303) {
947 $redirect = 1;
868 # HTTP/1.1 is unclear on how to mutate the method 948 # HTTP/1.1 is unclear on how to mutate the method
869 $method = "GET" unless $method eq "HEAD"; 949 unless ($method eq "HEAD") {
870 $redirect = 1; 950 $method = "GET";
951 delete $arg{body};
952 }
871 } elsif ($status == 307) { 953 } elsif ($status == 307 or $status == 308) {
872 $redirect = 1; 954 $redirect = 1;
873 } 955 }
874 } 956 }
875 957
876 my $finish = sub { # ($data, $err_status, $err_reason[, $keepalive]) 958 my $finish = sub { # ($data, $err_status, $err_reason[, $persistent])
877 if ($state{handle}) { 959 if ($state{handle}) {
878 # handle keepalive 960 # handle keepalive
879 if ( 961 if (
880 $keepalive 962 $persistent
881 && $_[3] 963 && $_[3]
882 && ($hdr{HTTPVersion} < 1.1 964 && ($hdr{HTTPVersion} < 1.1
883 ? $hdr{connection} =~ /\bkeep-?alive\b/i 965 ? $hdr{connection} =~ /\bkeep-?alive\b/i
884 : $hdr{connection} !~ /\bclose\b/i) 966 : $hdr{connection} !~ /\bclose\b/i)
885 ) { 967 ) {
… …
904 986
905 if ($redirect && exists $hdr{location}) { 987 if ($redirect && exists $hdr{location}) {
906 # we ignore any errors, as it is very common to receive 988 # we ignore any errors, as it is very common to receive
907 # Content-Length != 0 but no actual body 989 # Content-Length != 0 but no actual body
908 # we also access %hdr, as $_[1] might be an erro 990 # we also access %hdr, as $_[1] might be an erro
991 $state{recurse} =
909 http_request ( 992 http_request (
910 $method => $hdr{location}, 993 $method => $hdr{location},
911 %arg, 994 %arg,
912 recurse => $recurse - 1, 995 recurse => $recurse - 1,
913 Redirect => [$_[0], \%hdr], 996 Redirect => [$_[0], \%hdr],
997 sub {
998 %state = ();
914 $cb 999 &$cb
1000 },
915 ); 1001 );
916 } else { 1002 } else {
917 $cb->($_[0], \%hdr); 1003 $cb->($_[0], \%hdr);
918 } 1004 }
919 }; 1005 };
920 1006
… …
948 $finish->(delete $state{handle}); 1034 $finish->(delete $state{handle});
949 1035
950 } elsif ($chunked) { 1036 } elsif ($chunked) {
951 my $cl = 0; 1037 my $cl = 0;
952 my $body = ""; 1038 my $body = "";
953 my $on_body = $arg{on_body} || sub { $body .= shift; 1 }; 1039 my $on_body = (!$redirect && $arg{on_body}) || sub { $body .= shift; 1 };
954 1040
955 $state{read_chunk} = sub { 1041 $state{read_chunk} = sub {
956 $_[1] =~ /^([0-9a-fA-F]+)/ 1042 $_[1] =~ /^([0-9a-fA-F]+)/
957 or $finish->(undef, $ae_error => "Garbled chunked transfer encoding"); 1043 or return $finish->(undef, $ae_error => "Garbled chunked transfer encoding");
958 1044
959 my $len = hex $1; 1045 my $len = hex $1;
960 1046
961 if ($len) { 1047 if ($len) {
962 $cl += $len; 1048 $cl += $len;
… …
991 } 1077 }
992 }; 1078 };
993 1079
994 $_[0]->push_read (line => $state{read_chunk}); 1080 $_[0]->push_read (line => $state{read_chunk});
995 1081
996 } elsif ($arg{on_body}) { 1082 } elsif (!$redirect && $arg{on_body}) {
997 if (defined $len) { 1083 if (defined $len) {
998 $_[0]->on_read (sub { 1084 $_[0]->on_read (sub {
999 $len -= length $_[0]{rbuf}; 1085 $len -= length $_[0]{rbuf};
1000 1086
1001 $arg{on_body}(delete $_[0]{rbuf}, \%hdr) 1087 $arg{on_body}(delete $_[0]{rbuf}, \%hdr)
… …
1032 } 1118 }
1033 }; 1119 };
1034 1120
1035 # if keepalive is enabled, then the server closing the connection 1121 # if keepalive is enabled, then the server closing the connection
1036 # before a response can happen legally - we retry on idempotent methods. 1122 # before a response can happen legally - we retry on idempotent methods.
1037 if ($keptalive && $idempotent) { 1123 if ($was_persistent && $idempotent) {
1038 my $old_eof = $hdl->{on_eof}; 1124 my $old_eof = $hdl->{on_eof};
1039 $hdl->{on_eof} = sub { 1125 $hdl->{on_eof} = sub {
1040 _destroy_state %state; 1126 _destroy_state %state;
1041 1127
1128 %state = ();
1129 $state{recurse} =
1042 http_request ( 1130 http_request (
1043 $method => $url, 1131 $method => $url,
1044 %arg, 1132 %arg,
1045 keepalive => 0, 1133 recurse => $recurse - 1,
1134 persistent => 0,
1135 sub {
1136 %state = ();
1046 $cb 1137 &$cb
1138 }
1047 ); 1139 );
1048 }; 1140 };
1049 $hdl->on_read (sub { 1141 $hdl->on_read (sub {
1050 return unless %state; 1142 return unless %state;
1051 1143
1052 # as soon as we receive something, a connection close 1144 # as soon as we receive something, a connection close
… …
1060 }; 1152 };
1061 1153
1062 my $prepare_handle = sub { 1154 my $prepare_handle = sub {
1063 my ($hdl) = $state{handle}; 1155 my ($hdl) = $state{handle};
1064 1156
1065 $hdl->timeout ($timeout);
1066 $hdl->on_error (sub { 1157 $hdl->on_error (sub {
1067 _error %state, $cb, { @pseudo, Status => $ae_error, Reason => $_[2] }; 1158 _error %state, $cb, { @pseudo, Status => $ae_error, Reason => $_[2] };
1068 }); 1159 });
1069 $hdl->on_eof (sub { 1160 $hdl->on_eof (sub {
1070 _error %state, $cb, { @pseudo, Status => $ae_error, Reason => "Unexpected end-of-file" }; 1161 _error %state, $cb, { @pseudo, Status => $ae_error, Reason => "Unexpected end-of-file" };
1071 }); 1162 });
1163 $hdl->timeout_reset;
1164 $hdl->timeout ($timeout);
1072 }; 1165 };
1073 1166
1074 # connected to proxy (or origin server) 1167 # connected to proxy (or origin server)
1075 my $connect_cb = sub { 1168 my $connect_cb = sub {
1076 my $fh = shift 1169 my $fh = shift
… …
1092 1185
1093 # now handle proxy-CONNECT method 1186 # now handle proxy-CONNECT method
1094 if ($proxy && $uscheme eq "https") { 1187 if ($proxy && $uscheme eq "https") {
1095 # oh dear, we have to wrap it into a connect request 1188 # oh dear, we have to wrap it into a connect request
1096 1189
1190 my $auth = exists $hdr{"proxy-authorization"}
1191 ? "proxy-authorization: " . (delete $hdr{"proxy-authorization"}) . "\015\012"
1192 : "";
1193
1097 # maybe re-use $uauthority with patched port? 1194 # maybe re-use $uauthority with patched port?
1098 $state{handle}->push_write ("CONNECT $uhost:$uport HTTP/1.0\015\012\015\012"); 1195 $state{handle}->push_write ("CONNECT $uhost:$uport HTTP/1.0\015\012$auth\015\012");
1099 $state{handle}->push_read (line => $qr_nlnl, sub { 1196 $state{handle}->push_read (line => $qr_nlnl, sub {
1100 $_[1] =~ /^HTTP\/([0-9\.]+) \s+ ([0-9]{3}) (?: \s+ ([^\015\012]*) )?/ix 1197 $_[1] =~ /^HTTP\/([0-9\.]+) \s+ ([0-9]{3}) (?: \s+ ([^\015\012]*) )?/ix
1101 or return _error %state, $cb, { @pseudo, Status => 599, Reason => "Invalid proxy connect response ($_[1])" }; 1198 or return _error %state, $cb, { @pseudo, Status => 599, Reason => "Invalid proxy connect response ($_[1])" };
1102 1199
1103 if ($2 == 200) { 1200 if ($2 == 200) {
… …
1106 } else { 1203 } else {
1107 _error %state, $cb, { @pseudo, Status => $2, Reason => $3 }; 1204 _error %state, $cb, { @pseudo, Status => $2, Reason => $3 };
1108 } 1205 }
1109 }); 1206 });
1110 } else { 1207 } else {
1208 delete $hdr{"proxy-authorization"} unless $proxy;
1209
1111 $handle_actual_request->(); 1210 $handle_actual_request->();
1112 } 1211 }
1113 }; 1212 };
1114 1213
1115 _get_slot $uhost, sub { 1214 _get_slot $uhost, sub {
… …
1117 1216
1118 return unless $state{connect_guard}; 1217 return unless $state{connect_guard};
1119 1218
1120 # try to use an existing keepalive connection, but only if we, ourselves, plan 1219 # try to use an existing keepalive connection, but only if we, ourselves, plan
1121 # on a keepalive request (in theory, this should be a separate config option). 1220 # on a keepalive request (in theory, this should be a separate config option).
1122 if ($keepalive && $KA_CACHE{$ka_key}) { 1221 if ($persistent && $KA_CACHE{$ka_key}) {
1123 $keptalive = 1; 1222 $was_persistent = 1;
1223
1124 $state{handle} = ka_fetch $ka_key; 1224 $state{handle} = ka_fetch $ka_key;
1225# $state{handle}->destroyed
1226# and die "AnyEvent::HTTP: unexpectedly got a destructed handle (1), please report.";#d#
1125 $prepare_handle->(); 1227 $prepare_handle->();
1228# $state{handle}->destroyed
1229# and die "AnyEvent::HTTP: unexpectedly got a destructed handle (2), please report.";#d#
1126 $handle_actual_request->(); 1230 $handle_actual_request->();
1127 1231
1128 } else { 1232 } else {
1129 my $tcp_connect = $arg{tcp_connect} 1233 my $tcp_connect = $arg{tcp_connect}
1130 || do { require AnyEvent::Socket; \&AnyEvent::Socket::tcp_connect }; 1234 || do { require AnyEvent::Socket; \&AnyEvent::Socket::tcp_connect };
… …
1172Sets the default proxy server to use. The proxy-url must begin with a 1276Sets the default proxy server to use. The proxy-url must begin with a
1173string of the form C<http://host:port>, croaks otherwise. 1277string of the form C<http://host:port>, croaks otherwise.
1174 1278
1175To clear an already-set proxy, use C<undef>. 1279To clear an already-set proxy, use C<undef>.
1176 1280
1281When AnyEvent::HTTP is loaded for the first time it will query the
1282default proxy from the operating system, currently by looking at
1283C<$ENV{http_proxy>}.
1284
1177=item AnyEvent::HTTP::cookie_jar_expire $jar[, $session_end] 1285=item AnyEvent::HTTP::cookie_jar_expire $jar[, $session_end]
1178 1286
1179Remove all cookies from the cookie jar that have been expired. If 1287Remove all cookies from the cookie jar that have been expired. If
1180C<$session_end> is given and true, then additionally remove all session 1288C<$session_end> is given and true, then additionally remove all session
1181cookies. 1289cookies.
1182 1290
1183You should call this function (with a true C<$session_end>) before you 1291You should call this function (with a true C<$session_end>) before you
1184save cookies to disk, and you should call this function after loading them 1292save cookies to disk, and you should call this function after loading them
1185again. If you have a long-running program you can additonally call this 1293again. If you have a long-running program you can additionally call this
1186function from time to time. 1294function from time to time.
1187 1295
1188A cookie jar is initially an empty hash-reference that is managed by this 1296A cookie jar is initially an empty hash-reference that is managed by this
1189module. It's format is subject to change, but currently it is like this: 1297module. Its format is subject to change, but currently it is as follows:
1190 1298
1191The key C<version> has to contain C<1>, otherwise the hash gets 1299The key C<version> has to contain C<2>, otherwise the hash gets
1192emptied. All other keys are hostnames or IP addresses pointing to 1300cleared. All other keys are hostnames or IP addresses pointing to
1193hash-references. The key for these inner hash references is the 1301hash-references. The key for these inner hash references is the
1194server path for which this cookie is meant, and the values are again 1302server path for which this cookie is meant, and the values are again
1195hash-references. The keys of those hash-references is the cookie name, and 1303hash-references. Each key of those hash-references is a cookie name, and
1196the value, you guessed it, is another hash-reference, this time with the 1304the value, you guessed it, is another hash-reference, this time with the
1197key-value pairs from the cookie, except for C<expires> and C<max-age>, 1305key-value pairs from the cookie, except for C<expires> and C<max-age>,
1198which have been replaced by a C<_expires> key that contains the cookie 1306which have been replaced by a C<_expires> key that contains the cookie
1199expiry timestamp. 1307expiry timestamp. Session cookies are indicated by not having an
1308C<_expires> key.
1200 1309
1201Here is an example of a cookie jar with a single cookie, so you have a 1310Here is an example of a cookie jar with a single cookie, so you have a
1202chance of understanding the above paragraph: 1311chance of understanding the above paragraph:
1203 1312
1204 { 1313 {
… …
1228 1337
1229The default value for the C<recurse> request parameter (default: C<10>). 1338The default value for the C<recurse> request parameter (default: C<10>).
1230 1339
1231=item $AnyEvent::HTTP::TIMEOUT 1340=item $AnyEvent::HTTP::TIMEOUT
1232 1341
1233The default timeout for conenction operations (default: C<300>). 1342The default timeout for connection operations (default: C<300>).
1234 1343
1235=item $AnyEvent::HTTP::USERAGENT 1344=item $AnyEvent::HTTP::USERAGENT
1236 1345
1237The default value for the C<User-Agent> header (the default is 1346The default value for the C<User-Agent> header (the default is
1238C<Mozilla/5.0 (compatible; U; AnyEvent-HTTP/$VERSION; +http://software.schmorp.de/pkg/AnyEvent)>). 1347C<Mozilla/5.0 (compatible; U; AnyEvent-HTTP/$VERSION; +http://software.schmorp.de/pkg/AnyEvent)>).
1239 1348
1240=item $AnyEvent::HTTP::MAX_PER_HOST 1349=item $AnyEvent::HTTP::MAX_PER_HOST
1241 1350
1242The maximum number of concurrent connections to the same host (identified 1351The maximum number of concurrent connections to the same host (identified
1243by the hostname). If the limit is exceeded, then the additional requests 1352by the hostname). If the limit is exceeded, then additional requests
1244are queued until previous connections are closed. Both persistent and 1353are queued until previous connections are closed. Both persistent and
1245non-persistent connections are counted in this limit. 1354non-persistent connections are counted in this limit.
1246 1355
1247The default value for this is C<4>, and it is highly advisable to not 1356The default value for this is C<4>, and it is highly advisable to not
1248increase it much. 1357increase it much.
1249 1358
1250For comparison: the RFC's recommend 4 non-persistent or 2 persistent 1359For comparison: the RFC's recommend 4 non-persistent or 2 persistent
1251connections, older browsers used 2, newers (such as firefox 3) typically 1360connections, older browsers used 2, newer ones (such as firefox 3)
1252use 6, and Opera uses 8 because like, they have the fastest browser and 1361typically use 6, and Opera uses 8 because like, they have the fastest
1253give a shit for everybody else on the planet. 1362browser and give a shit for everybody else on the planet.
1254 1363
1255=item $AnyEvent::HTTP::PERSISTENT_TIMEOUT 1364=item $AnyEvent::HTTP::PERSISTENT_TIMEOUT
1256 1365
1257The time after which idle persistent conenctions get closed by 1366The time after which idle persistent connections get closed by
1258AnyEvent::HTTP (default: C<3>). 1367AnyEvent::HTTP (default: C<3>).
1259 1368
1260=item $AnyEvent::HTTP::ACTIVE 1369=item $AnyEvent::HTTP::ACTIVE
1261 1370
1262The number of active connections. This is not the number of currently 1371The number of active connections. This is not the number of currently
… …
1303 # other formats fail in the loop below 1412 # other formats fail in the loop below
1304 1413
1305 for (0..11) { 1414 for (0..11) {
1306 if ($m eq $month[$_]) { 1415 if ($m eq $month[$_]) {
1307 require Time::Local; 1416 require Time::Local;
1308 return Time::Local::timegm ($S, $M, $H, $d, $_, $y); 1417 return eval { Time::Local::timegm ($S, $M, $H, $d, $_, $y) };
1309 } 1418 }
1310 } 1419 }
1311 1420
1312 undef 1421 undef
1313} 1422}
… …
1327 set_proxy $ENV{http_proxy}; 1436 set_proxy $ENV{http_proxy};
1328}; 1437};
1329 1438
1330=head2 SHOWCASE 1439=head2 SHOWCASE
1331 1440
1332This section contaisn some more elaborate "real-world" examples or code 1441This section contains some more elaborate "real-world" examples or code
1333snippets. 1442snippets.
1334 1443
1335=head2 HTTP/1.1 FILE DOWNLOAD 1444=head2 HTTP/1.1 FILE DOWNLOAD
1336 1445
1337Downloading files with HTTP can be quite tricky, especially when something 1446Downloading files with HTTP can be quite tricky, especially when something
… …
1341last modified time to check for file content changes, and works with many 1450last modified time to check for file content changes, and works with many
1342HTTP/1.0 servers as well, and usually falls back to a complete re-download 1451HTTP/1.0 servers as well, and usually falls back to a complete re-download
1343on older servers. 1452on older servers.
1344 1453
1345It calls the completion callback with either C<undef>, which means a 1454It calls the completion callback with either C<undef>, which means a
1346nonretryable error occured, C<0> when the download was partial and should 1455nonretryable error occurred, C<0> when the download was partial and should
1347be retried, and C<1> if it was successful. 1456be retried, and C<1> if it was successful.
1348 1457
1349 use AnyEvent::HTTP; 1458 use AnyEvent::HTTP;
1350 1459
1351 sub download($$$) { 1460 sub download($$$) {
… …
1355 or die "$file: $!"; 1464 or die "$file: $!";
1356 1465
1357 my %hdr; 1466 my %hdr;
1358 my $ofs = 0; 1467 my $ofs = 0;
1359 1468
1360 warn stat $fh;
1361 warn -s _;
1362 if (stat $fh and -s _) { 1469 if (stat $fh and -s _) {
1363 $ofs = -s _; 1470 $ofs = -s _;
1364 warn "-s is ", $ofs;#d# 1471 warn "-s is ", $ofs;
1365 $hdr{"if-unmodified-since"} = AnyEvent::HTTP::format_date +(stat _)[9]; 1472 $hdr{"if-unmodified-since"} = AnyEvent::HTTP::format_date +(stat _)[9];
1366 $hdr{"range"} = "bytes=$ofs-"; 1473 $hdr{"range"} = "bytes=$ofs-";
1367 } 1474 }
1368 1475
1369 http_get $url, 1476 http_get $url,
… …
1394 my (undef, $hdr) = @_; 1501 my (undef, $hdr) = @_;
1395 1502
1396 my $status = $hdr->{Status}; 1503 my $status = $hdr->{Status};
1397 1504
1398 if (my $time = AnyEvent::HTTP::parse_date $hdr->{"last-modified"}) { 1505 if (my $time = AnyEvent::HTTP::parse_date $hdr->{"last-modified"}) {
1399 utime $fh, $time, $time; 1506 utime $time, $time, $fh;
1400 } 1507 }
1401 1508
1402 if ($status == 200 || $status == 206 || $status == 416) { 1509 if ($status == 200 || $status == 206 || $status == 416) {
1403 # download ok || resume ok || file already fully downloaded 1510 # download ok || resume ok || file already fully downloaded
1404 $cb->(1, $hdr); 1511 $cb->(1, $hdr);

Diff Legend

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