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.107 by root, Tue Jun 14 05:23:12 2011 UTC vs.
Revision 1.140 by root, Wed Mar 6 19:29:18 2024 UTC

4 4
5=head1 SYNOPSIS 5=head1 SYNOPSIS
6 6
7 use AnyEvent::HTTP; 7 use AnyEvent::HTTP;
8 8
9 http_get "http://www.nethype.de/", sub { print $_[1] }; 9 http_get "http://www.nethype.de/", sub {
10 my ($body, $hdr) = @_;
11 print "$hdr->{URL} Status: $hdr->{Status}\n";
12 print $body;
13 };
10 14
11 # ... do something else here 15 # ... do something else here
12 16
13=head1 DESCRIPTION 17=head1 DESCRIPTION
14 18
46use AnyEvent::Util (); 50use AnyEvent::Util ();
47use AnyEvent::Handle (); 51use AnyEvent::Handle ();
48 52
49use base Exporter::; 53use base Exporter::;
50 54
51our $VERSION = '2.12'; 55our $VERSION = 2.25;
52 56
53our @EXPORT = qw(http_get http_post http_head http_request); 57our @EXPORT = qw(http_get http_post http_head http_request);
54 58
55our $USERAGENT = "Mozilla/5.0 (compatible; U; AnyEvent-HTTP/$VERSION; +http://software.schmorp.de/pkg/AnyEvent)"; 59our $USERAGENT = "Mozilla/5.0 (compatible; U; AnyEvent-HTTP/$VERSION; +http://software.schmorp.de/pkg/AnyEvent)";
56our $MAX_RECURSE = 10; 60our $MAX_RECURSE = 10;
89C<http_request> returns a "cancellation guard" - you have to keep the 93C<http_request> returns a "cancellation guard" - you have to keep the
90object at least alive until the callback get called. If the object gets 94object at least alive until the callback get called. If the object gets
91destroyed before the callback is called, the request will be cancelled. 95destroyed before the callback is called, the request will be cancelled.
92 96
93The callback will be called with the response body data as first argument 97The 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 98(or C<undef> if an error occurred), and a hash-ref with response headers
95(and trailers) as second argument. 99(and trailers) as second argument.
96 100
97All the headers in that hash are lowercased. In addition to the response 101All the headers in that hash are lowercased. In addition to the response
98headers, the "pseudo-headers" (uppercase to avoid clashing with possible 102headers, the "pseudo-headers" (uppercase to avoid clashing with possible
99response headers) C<HTTPVersion>, C<Status> and C<Reason> contain the 103response headers) C<HTTPVersion>, C<Status> and C<Reason> contain the
123C<590>-C<599> and the C<Reason> pseudo-header will contain an error 127C<590>-C<599> and the C<Reason> pseudo-header will contain an error
124message. Currently the following status codes are used: 128message. Currently the following status codes are used:
125 129
126=over 4 130=over 4
127 131
128=item 595 - errors during connection etsbalishment, proxy handshake. 132=item 595 - errors during connection establishment, proxy handshake.
129 133
130=item 596 - errors during TLS negotiation, request sending and header processing. 134=item 596 - errors during TLS negotiation, request sending and header processing.
131 135
132=item 597 - errors during body receiving or processing. 136=item 597 - errors during body receiving or processing.
133 137
154 158
155=over 4 159=over 4
156 160
157=item recurse => $count (default: $MAX_RECURSE) 161=item recurse => $count (default: $MAX_RECURSE)
158 162
159Whether to recurse requests or not, e.g. on redirects, authentication 163Whether to recurse requests or not, e.g. on redirects, authentication and
160retries and so on, and how often to do so. 164other retries and so on, and how often to do so.
165
166Only redirects to http and https URLs are supported. While most common
167redirection forms are handled entirely within this module, some require
168the use of the optional L<URI> module. If it is required but missing, then
169the request will fail with an error.
161 170
162=item headers => hashref 171=item headers => hashref
163 172
164The request headers to use. Currently, C<http_request> may provide its own 173The request headers to use. Currently, C<http_request> may provide its own
165C<Host:>, C<Content-Length:>, C<Connection:> and C<Cookie:> headers and 174C<Host:>, C<Content-Length:>, C<Connection:> and C<Cookie:> headers and
189 198
190C<$scheme> must be either missing or must be C<http> for HTTP. 199C<$scheme> must be either missing or must be C<http> for HTTP.
191 200
192If not specified, then the default proxy is used (see 201If not specified, then the default proxy is used (see
193C<AnyEvent::HTTP::set_proxy>). 202C<AnyEvent::HTTP::set_proxy>).
203
204Currently, if your proxy requires authorization, you have to specify an
205appropriate "Proxy-Authorization" header in every request.
206
207Note that this module will prefer an existing persistent connection,
208even if that connection was made using another proxy. If you need to
209ensure that a new connection is made in this case, you can either force
210C<persistent> to false or e.g. use the proxy address in your C<sessionid>.
194 211
195=item body => $string 212=item body => $string
196 213
197The request body, usually empty. Will be sent as-is (future versions of 214The request body, usually empty. Will be sent as-is (future versions of
198this module might offer more options). 215this module might offer more options).
231The default for this option is C<low>, which could be interpreted as "give 248The default for this option is C<low>, which could be interpreted as "give
232me the page, no matter what". 249me the page, no matter what".
233 250
234See also the C<sessionid> parameter. 251See also the C<sessionid> parameter.
235 252
236=item session => $string 253=item sessionid => $string
237 254
238The module might reuse connections to the same host internally. Sometimes 255The module might reuse connections to the same host internally (regardless
239(e.g. when using TLS), you do not want to reuse connections from other 256of other settings, such as C<tcp_connect> or C<proxy>). Sometimes (e.g.
257when using TLS or a specfic proxy), you do not want to reuse connections
240sessions. This can be achieved by setting this parameter to some unique 258from other sessions. This can be achieved by setting this parameter to
241ID (such as the address of an object storing your state data, or the TLS 259some unique ID (such as the address of an object storing your state data
242context) - only connections using the same unique ID will be reused. 260or the TLS context, or the proxy IP) - only connections using the same
261unique ID will be reused.
243 262
244=item on_prepare => $callback->($fh) 263=item on_prepare => $callback->($fh)
245 264
246In rare cases you need to "tune" the socket before it is used to 265In rare cases you need to "tune" the socket before it is used to
247connect (for exmaple, to bind it on a given IP address). This parameter 266connect (for example, to bind it on a given IP address). This parameter
248overrides the prepare callback passed to C<AnyEvent::Socket::tcp_connect> 267overrides the prepare callback passed to C<AnyEvent::Socket::tcp_connect>
249and behaves exactly the same way (e.g. it has to provide a 268and behaves exactly the same way (e.g. it has to provide a
250timeout). See the description for the C<$prepare_cb> argument of 269timeout). See the description for the C<$prepare_cb> argument of
251C<AnyEvent::Socket::tcp_connect> for details. 270C<AnyEvent::Socket::tcp_connect> for details.
252 271
255In even rarer cases you want total control over how AnyEvent::HTTP 274In even rarer cases you want total control over how AnyEvent::HTTP
256establishes connections. Normally it uses L<AnyEvent::Socket::tcp_connect> 275establishes connections. Normally it uses L<AnyEvent::Socket::tcp_connect>
257to do this, but you can provide your own C<tcp_connect> function - 276to do this, but you can provide your own C<tcp_connect> function -
258obviously, it has to follow the same calling conventions, except that it 277obviously, it has to follow the same calling conventions, except that it
259may always return a connection guard object. 278may always return a connection guard object.
279
280The connections made by this hook will be treated as equivalent to
281connections made the built-in way, specifically, they will be put into
282and taken from the persistent connection cache. If your C<$tcp_connect>
283function is incompatible with this kind of re-use, consider switching off
284C<persistent> connections and/or providing a C<sessionid> identifier.
260 285
261There are probably lots of weird uses for this function, starting from 286There are probably lots of weird uses for this function, starting from
262tracing the hosts C<http_request> actually tries to connect, to (inexact 287tracing the hosts C<http_request> actually tries to connect, to (inexact
263but fast) host => IP address caching or even socks protocol support. 288but fast) host => IP address caching or even socks protocol support.
264 289
334=item persistent => $boolean 359=item persistent => $boolean
335 360
336Try to create/reuse a persistent connection. When this flag is set 361Try to create/reuse a persistent connection. When this flag is set
337(default: true for idempotent requests, false for all others), then 362(default: true for idempotent requests, false for all others), then
338C<http_request> tries to re-use an existing (previously-created) 363C<http_request> tries to re-use an existing (previously-created)
339persistent connection to the host and, failing that, tries to create a new 364persistent connection to same host (i.e. identical URL scheme, hostname,
340one. 365port and sessionid) and, failing that, tries to create a new one.
341 366
342Requests failing in certain ways will be automatically retried once, which 367Requests failing in certain ways will be automatically retried once, which
343is dangerous for non-idempotent requests, which is why it defaults to off 368is dangerous for non-idempotent requests, which is why it defaults to off
344for them. The reason for this is because the bozos who designed HTTP/1.1 369for them. The reason for this is because the bozos who designed HTTP/1.1
345made it impossible to distinguish between a fatal error and a normal 370made it impossible to distinguish between a fatal error and a normal
346connection timeout, so you never know whether there was a problem with 371connection timeout, so you never know whether there was a problem with
347your request or not. 372your request or not.
348 373
349When reusing an existent connection, many parameters (such as TLS context) 374When reusing an existent connection, many parameters (such as TLS context)
350will be ignored. See the C<session> parameter for a workaround. 375will be ignored. See the C<sessionid> parameter for a workaround.
351 376
352=item keepalive => $boolean 377=item keepalive => $boolean
353 378
354Only used when C<persistent> is also true. This parameter decides whether 379Only used when C<persistent> is also true. This parameter decides whether
355C<http_request> tries to handshake a HTTP/1.0-style keep-alive connection 380C<http_request> tries to handshake a HTTP/1.0-style keep-alive connection
384 409
385Example: do a HTTP HEAD request on https://www.google.com/, use a 410Example: do a HTTP HEAD request on https://www.google.com/, use a
386timeout of 30 seconds. 411timeout of 30 seconds.
387 412
388 http_request 413 http_request
389 GET => "https://www.google.com", 414 HEAD => "https://www.google.com",
390 headers => { "user-agent" => "MySearchClient 1.0" }, 415 headers => { "user-agent" => "MySearchClient 1.0" },
391 timeout => 30, 416 timeout => 30,
392 sub { 417 sub {
393 my ($body, $hdr) = @_; 418 my ($body, $hdr) = @_;
394 use Data::Dumper; 419 use Data::Dumper;
446 471
447# expire cookies 472# expire cookies
448sub cookie_jar_expire($;$) { 473sub cookie_jar_expire($;$) {
449 my ($jar, $session_end) = @_; 474 my ($jar, $session_end) = @_;
450 475
451 %$jar = () if $jar->{version} != 1; 476 %$jar = () if $jar->{version} != 2;
452 477
453 my $anow = AE::now; 478 my $anow = AE::now;
454 479
455 while (my ($chost, $paths) = each %$jar) { 480 while (my ($chost, $paths) = each %$jar) {
456 next unless ref $paths; 481 next unless ref $paths;
476 501
477# extract cookies from jar 502# extract cookies from jar
478sub cookie_jar_extract($$$$) { 503sub cookie_jar_extract($$$$) {
479 my ($jar, $scheme, $host, $path) = @_; 504 my ($jar, $scheme, $host, $path) = @_;
480 505
481 %$jar = () if $jar->{version} != 1; 506 %$jar = () if $jar->{version} != 2;
507
508 $host = AnyEvent::Util::idn_to_ascii $host
509 if $host =~ /[^\x00-\x7f]/;
482 510
483 my @cookies; 511 my @cookies;
484 512
485 while (my ($chost, $paths) = each %$jar) { 513 while (my ($chost, $paths) = each %$jar) {
486 next unless ref $paths; 514 next unless ref $paths;
487 515
488 if ($chost =~ /^\./) { 516 # exact match or suffix including . match
489 next unless $chost eq substr $host, -length $chost; 517 $chost eq $host or ".$chost" eq substr $host, -1 - length $chost
490 } elsif ($chost =~ /\./) {
491 next unless $chost eq $host;
492 } else {
493 next; 518 or next;
494 }
495 519
496 while (my ($cpath, $cookies) = each %$paths) { 520 while (my ($cpath, $cookies) = each %$paths) {
497 next unless $cpath eq substr $path, 0, length $cpath; 521 next unless $cpath eq substr $path, 0, length $cpath;
498 522
499 while (my ($cookie, $kv) = each %$cookies) { 523 while (my ($cookie, $kv) = each %$cookies) {
520} 544}
521 545
522# parse set_cookie header into jar 546# parse set_cookie header into jar
523sub cookie_jar_set_cookie($$$$) { 547sub cookie_jar_set_cookie($$$$) {
524 my ($jar, $set_cookie, $host, $date) = @_; 548 my ($jar, $set_cookie, $host, $date) = @_;
549
550 %$jar = () if $jar->{version} != 2;
525 551
526 my $anow = int AE::now; 552 my $anow = int AE::now;
527 my $snow; # server-now 553 my $snow; # server-now
528 554
529 for ($set_cookie) { 555 for ($set_cookie) {
575 601
576 my $cdom; 602 my $cdom;
577 my $cpath = (delete $kv{path}) || "/"; 603 my $cpath = (delete $kv{path}) || "/";
578 604
579 if (exists $kv{domain}) { 605 if (exists $kv{domain}) {
580 $cdom = delete $kv{domain}; 606 $cdom = $kv{domain};
581 607
582 $cdom =~ s/^\.?/./; # make sure it starts with a "." 608 $cdom =~ s/^\.?/./; # make sure it starts with a "."
583 609
584 next if $cdom =~ /\.$/; 610 next if $cdom =~ /\.$/;
585 611
586 # this is not rfc-like and not netscape-like. go figure. 612 # this is not rfc-like and not netscape-like. go figure.
587 my $ndots = $cdom =~ y/.//; 613 my $ndots = $cdom =~ y/.//;
588 next if $ndots < ($cdom =~ /\.[^.][^.]\.[^.][^.]$/ ? 3 : 2); 614 next if $ndots < ($cdom =~ /\.[^.][^.]\.[^.][^.]$/ ? 3 : 2);
615
616 $cdom = substr $cdom, 1; # remove initial .
589 } else { 617 } else {
590 $cdom = $host; 618 $cdom = $host;
591 } 619 }
592 620
593 # store it 621 # store it
594 $jar->{version} = 1; 622 $jar->{version} = 2;
595 $jar->{lc $cdom}{$cpath}{$name} = \%kv; 623 $jar->{lc $cdom}{$cpath}{$name} = \%kv;
596 624
597 redo if /\G\s*,/gc; 625 redo if /\G\s*,/gc;
598 } 626 }
599} 627}
689 717
690 $cb->(undef, $hdr); 718 $cb->(undef, $hdr);
691 () 719 ()
692} 720}
693 721
722our %IDEMPOTENT = (
723 DELETE => 1,
724 GET => 1,
725 QUERY => 1,
726 HEAD => 1,
727 OPTIONS => 1,
728 PUT => 1,
729 TRACE => 1,
730
731 ACL => 1,
732 "BASELINE-CONTROL" => 1,
733 BIND => 1,
734 CHECKIN => 1,
735 CHECKOUT => 1,
736 COPY => 1,
737 LABEL => 1,
738 LINK => 1,
739 MERGE => 1,
740 MKACTIVITY => 1,
741 MKCALENDAR => 1,
742 MKCOL => 1,
743 MKREDIRECTREF => 1,
744 MKWORKSPACE => 1,
745 MOVE => 1,
746 ORDERPATCH => 1,
747 PRI => 1,
748 PROPFIND => 1,
749 PROPPATCH => 1,
750 REBIND => 1,
751 REPORT => 1,
752 SEARCH => 1,
753 UNBIND => 1,
754 UNCHECKOUT => 1,
755 UNLINK => 1,
756 UNLOCK => 1,
757 UPDATE => 1,
758 UPDATEREDIRECTREF => 1,
759 "VERSION-CONTROL" => 1,
760);
761
694sub http_request($$@) { 762sub http_request($$@) {
695 my $cb = pop; 763 my $cb = pop;
696 my ($method, $url, %arg) = @_; 764 my ($method, $url, %arg) = @_;
697 765
698 my %hdr; 766 my %hdr;
727 795
728 my $uport = $uscheme eq "http" ? 80 796 my $uport = $uscheme eq "http" ? 80
729 : $uscheme eq "https" ? 443 797 : $uscheme eq "https" ? 443
730 : return $cb->(undef, { @pseudo, Status => 599, Reason => "Only http and https URL schemes supported" }); 798 : return $cb->(undef, { @pseudo, Status => 599, Reason => "Only http and https URL schemes supported" });
731 799
732 $uauthority =~ /^(?: .*\@ )? ([^\@:]+) (?: : (\d+) )?$/x 800 $uauthority =~ /^(?: .*\@ )? ([^\@]+?) (?: : (\d+) )?$/x
733 or return $cb->(undef, { @pseudo, Status => 599, Reason => "Unparsable URL" }); 801 or return $cb->(undef, { @pseudo, Status => 599, Reason => "Unparsable URL" });
734 802
735 my $uhost = lc $1; 803 my $uhost = lc $1;
736 $uport = $2 if defined $2; 804 $uport = $2 if defined $2;
737 805
773 $hdr{"user-agent"} = $USERAGENT unless exists $hdr{"user-agent"}; 841 $hdr{"user-agent"} = $USERAGENT unless exists $hdr{"user-agent"};
774 842
775 $hdr{"content-length"} = length $arg{body} 843 $hdr{"content-length"} = length $arg{body}
776 if length $arg{body} || $method ne "GET"; 844 if length $arg{body} || $method ne "GET";
777 845
778 my $idempotent = $method =~ /^(?:GET|HEAD|PUT|DELETE|OPTIONS|TRACE)$/; 846 my $idempotent = $IDEMPOTENT{$method};
779 847
780 # default value for keepalive is true iff the request is for an idempotent method 848 # default value for keepalive is true iff the request is for an idempotent method
781 my $persistent = exists $arg{persistent} ? !!$arg{persistent} : $idempotent; 849 my $persistent = exists $arg{persistent} ? !!$arg{persistent} : $idempotent;
782 my $keepalive = exists $arg{keepalive} ? !!$arg{keepalive} : !$proxy; 850 my $keepalive = exists $arg{keepalive} ? !!$arg{keepalive} : !$proxy;
783 my $was_persistent; # true if this is actually a recycled connection 851 my $was_persistent; # true if this is actually a recycled connection
784 852
785 # the key to use in the keepalive cache 853 # the key to use in the keepalive cache
786 my $ka_key = "$uscheme\x00$uhost\x00$uport\x00$arg{sessionid}"; 854 my $ka_key = "$uscheme\x00$uhost\x00$uport\x00$arg{sessionid}";
787 855
788 $hdr{connection} = ($persistent ? $keepalive ? "keep-alive " : "" : "close ") . "Te"; #1.1 856 $hdr{connection} = ($persistent ? $keepalive ? "keep-alive, " : "" : "close, ") . "Te"; #1.1
789 $hdr{te} = "trailers" unless exists $hdr{te}; #1.1 857 $hdr{te} = "trailers" unless exists $hdr{te}; #1.1
790 858
791 my %state = (connect_guard => 1); 859 my %state = (connect_guard => 1);
792 860
793 my $ae_error = 595; # connecting 861 my $ae_error = 595; # connecting
803 # send request 871 # send request
804 $hdl->push_write ( 872 $hdl->push_write (
805 "$method $rpath HTTP/1.1\015\012" 873 "$method $rpath HTTP/1.1\015\012"
806 . (join "", map "\u$_: $hdr{$_}\015\012", grep defined $hdr{$_}, keys %hdr) 874 . (join "", map "\u$_: $hdr{$_}\015\012", grep defined $hdr{$_}, keys %hdr)
807 . "\015\012" 875 . "\015\012"
808 . (delete $arg{body}) 876 . $arg{body}
809 ); 877 );
810 878
811 # return if error occured during push_write() 879 # return if error occurred during push_write()
812 return unless %state; 880 return unless %state;
813 881
814 # reduce memory usage, save a kitten, also re-use it for the response headers. 882 # reduce memory usage, save a kitten, also re-use it for the response headers.
815 %hdr = (); 883 %hdr = ();
816 884
843 911
844 %hdr = (%$hdr, @pseudo); 912 %hdr = (%$hdr, @pseudo);
845 } 913 }
846 914
847 # redirect handling 915 # redirect handling
848 # microsoft and other shitheads don't give a shit for following standards, 916 # relative uri handling forced by microsoft and other shitheads.
849 # try to support some common forms of broken Location headers. 917 # we give our best and fall back to URI if available.
850 if ($hdr{location} !~ /^(?: $ | [^:\/?\#]+ : )/x) { 918 if (exists $hdr{location}) {
919 my $loc = $hdr{location};
920
921 if ($loc =~ m%^//%) { # //
922 $loc = "$uscheme:$loc";
923
924 } elsif ($loc eq "") {
925 $loc = $url;
926
927 } elsif ($loc !~ /^(?: $ | [^:\/?\#]+ : )/x) { # anything "simple"
851 $hdr{location} =~ s/^\.\/+//; 928 $loc =~ s/^\.\/+//;
852 929
853 my $url = "$rscheme://$uhost:$uport"; 930 if ($loc !~ m%^[.?#]%) {
931 my $prefix = "$uscheme://$uauthority";
854 932
855 unless ($hdr{location} =~ s/^\///) { 933 unless ($loc =~ s/^\///) {
856 $url .= $upath; 934 $prefix .= $upath;
857 $url =~ s/\/[^\/]*$//; 935 $prefix =~ s/\/[^\/]*$//;
936 }
937
938 $loc = "$prefix/$loc";
939
940 } elsif (eval { require URI }) { # uri
941 $loc = URI->new_abs ($loc, $url)->as_string;
942
943 } else {
944 return _error %state, $cb, { @pseudo, Status => 599, Reason => "Cannot parse Location (URI module missing)" };
945 #$hdr{Status} = 599;
946 #$hdr{Reason} = "Unparsable Redirect (URI module missing)";
947 #$recurse = 0;
948 }
858 } 949 }
859 950
860 $hdr{location} = "$url/$hdr{location}"; 951 $hdr{location} = $loc;
861 } 952 }
862 953
863 my $redirect; 954 my $redirect;
864 955
865 if ($recurse) { 956 if ($recurse) {
867 958
868 # industry standard is to redirect POST as GET for 959 # industry standard is to redirect POST as GET for
869 # 301, 302 and 303, in contrast to HTTP/1.0 and 1.1. 960 # 301, 302 and 303, in contrast to HTTP/1.0 and 1.1.
870 # also, the UA should ask the user for 301 and 307 and POST, 961 # also, the UA should ask the user for 301 and 307 and POST,
871 # industry standard seems to be to simply follow. 962 # industry standard seems to be to simply follow.
872 # we go with the industry standard. 963 # we go with the industry standard. 308 is defined
964 # by rfc7538
873 if ($status == 301 or $status == 302 or $status == 303) { 965 if ($status == 301 or $status == 302 or $status == 303) {
966 $redirect = 1;
874 # HTTP/1.1 is unclear on how to mutate the method 967 # HTTP/1.1 is unclear on how to mutate the method
875 $method = "GET" unless $method eq "HEAD"; 968 unless ($method eq "HEAD") {
876 $redirect = 1; 969 $method = "GET";
970 delete $arg{body};
971 }
877 } elsif ($status == 307) { 972 } elsif ($status == 307 or $status == 308) {
878 $redirect = 1; 973 $redirect = 1;
879 } 974 }
880 } 975 }
881 976
882 my $finish = sub { # ($data, $err_status, $err_reason[, $persistent]) 977 my $finish = sub { # ($data, $err_status, $err_reason[, $persistent])
958 $finish->(delete $state{handle}); 1053 $finish->(delete $state{handle});
959 1054
960 } elsif ($chunked) { 1055 } elsif ($chunked) {
961 my $cl = 0; 1056 my $cl = 0;
962 my $body = ""; 1057 my $body = "";
963 my $on_body = $arg{on_body} || sub { $body .= shift; 1 }; 1058 my $on_body = (!$redirect && $arg{on_body}) || sub { $body .= shift; 1 };
964 1059
965 $state{read_chunk} = sub { 1060 $state{read_chunk} = sub {
966 $_[1] =~ /^([0-9a-fA-F]+)/ 1061 $_[1] =~ /^([0-9a-fA-F]+)/
967 or $finish->(undef, $ae_error => "Garbled chunked transfer encoding"); 1062 or return $finish->(undef, $ae_error => "Garbled chunked transfer encoding");
968 1063
969 my $len = hex $1; 1064 my $len = hex $1;
970 1065
971 if ($len) { 1066 if ($len) {
972 $cl += $len; 1067 $cl += $len;
1001 } 1096 }
1002 }; 1097 };
1003 1098
1004 $_[0]->push_read (line => $state{read_chunk}); 1099 $_[0]->push_read (line => $state{read_chunk});
1005 1100
1006 } elsif ($arg{on_body}) { 1101 } elsif (!$redirect && $arg{on_body}) {
1007 if (defined $len) { 1102 if (defined $len) {
1008 $_[0]->on_read (sub { 1103 $_[0]->on_read (sub {
1009 $len -= length $_[0]{rbuf}; 1104 $len -= length $_[0]{rbuf};
1010 1105
1011 $arg{on_body}(delete $_[0]{rbuf}, \%hdr) 1106 $arg{on_body}(delete $_[0]{rbuf}, \%hdr)
1050 _destroy_state %state; 1145 _destroy_state %state;
1051 1146
1052 %state = (); 1147 %state = ();
1053 $state{recurse} = 1148 $state{recurse} =
1054 http_request ( 1149 http_request (
1055 $method => $url, 1150 $method => $url,
1056 %arg, 1151 %arg,
1152 recurse => $recurse - 1,
1057 keepalive => 0, 1153 persistent => 0,
1058 sub { 1154 sub {
1059 %state = (); 1155 %state = ();
1060 &$cb 1156 &$cb
1061 } 1157 }
1062 ); 1158 );
1108 1204
1109 # now handle proxy-CONNECT method 1205 # now handle proxy-CONNECT method
1110 if ($proxy && $uscheme eq "https") { 1206 if ($proxy && $uscheme eq "https") {
1111 # oh dear, we have to wrap it into a connect request 1207 # oh dear, we have to wrap it into a connect request
1112 1208
1209 my $auth = exists $hdr{"proxy-authorization"}
1210 ? "proxy-authorization: " . (delete $hdr{"proxy-authorization"}) . "\015\012"
1211 : "";
1212
1113 # maybe re-use $uauthority with patched port? 1213 # maybe re-use $uauthority with patched port?
1114 $state{handle}->push_write ("CONNECT $uhost:$uport HTTP/1.0\015\012\015\012"); 1214 $state{handle}->push_write ("CONNECT $uhost:$uport HTTP/1.0\015\012$auth\015\012");
1115 $state{handle}->push_read (line => $qr_nlnl, sub { 1215 $state{handle}->push_read (line => $qr_nlnl, sub {
1116 $_[1] =~ /^HTTP\/([0-9\.]+) \s+ ([0-9]{3}) (?: \s+ ([^\015\012]*) )?/ix 1216 $_[1] =~ /^HTTP\/([0-9\.]+) \s+ ([0-9]{3}) (?: \s+ ([^\015\012]*) )?/ix
1117 or return _error %state, $cb, { @pseudo, Status => 599, Reason => "Invalid proxy connect response ($_[1])" }; 1217 or return _error %state, $cb, { @pseudo, Status => 599, Reason => "Invalid proxy connect response ($_[1])" };
1118 1218
1119 if ($2 == 200) { 1219 if ($2 == 200) {
1122 } else { 1222 } else {
1123 _error %state, $cb, { @pseudo, Status => $2, Reason => $3 }; 1223 _error %state, $cb, { @pseudo, Status => $2, Reason => $3 };
1124 } 1224 }
1125 }); 1225 });
1126 } else { 1226 } else {
1227 delete $hdr{"proxy-authorization"} unless $proxy;
1228
1127 $handle_actual_request->(); 1229 $handle_actual_request->();
1128 } 1230 }
1129 }; 1231 };
1130 1232
1131 _get_slot $uhost, sub { 1233 _get_slot $uhost, sub {
1137 # on a keepalive request (in theory, this should be a separate config option). 1239 # on a keepalive request (in theory, this should be a separate config option).
1138 if ($persistent && $KA_CACHE{$ka_key}) { 1240 if ($persistent && $KA_CACHE{$ka_key}) {
1139 $was_persistent = 1; 1241 $was_persistent = 1;
1140 1242
1141 $state{handle} = ka_fetch $ka_key; 1243 $state{handle} = ka_fetch $ka_key;
1142 $state{handle}->destroyed 1244# $state{handle}->destroyed
1143 and die "AnyEvent::HTTP: unexpectedly got a destructed handle (1), please report.";#d# 1245# and die "AnyEvent::HTTP: unexpectedly got a destructed handle (1), please report.";#d#
1144 $prepare_handle->(); 1246 $prepare_handle->();
1145 $state{handle}->destroyed 1247# $state{handle}->destroyed
1146 and die "AnyEvent::HTTP: unexpectedly got a destructed handle (2), please report.";#d# 1248# and die "AnyEvent::HTTP: unexpectedly got a destructed handle (2), please report.";#d#
1249 $rpath = $upath;
1147 $handle_actual_request->(); 1250 $handle_actual_request->();
1148 1251
1149 } else { 1252 } else {
1150 my $tcp_connect = $arg{tcp_connect} 1253 my $tcp_connect = $arg{tcp_connect}
1151 || do { require AnyEvent::Socket; \&AnyEvent::Socket::tcp_connect }; 1254 || do { require AnyEvent::Socket; \&AnyEvent::Socket::tcp_connect };
1193Sets the default proxy server to use. The proxy-url must begin with a 1296Sets the default proxy server to use. The proxy-url must begin with a
1194string of the form C<http://host:port>, croaks otherwise. 1297string of the form C<http://host:port>, croaks otherwise.
1195 1298
1196To clear an already-set proxy, use C<undef>. 1299To clear an already-set proxy, use C<undef>.
1197 1300
1198When AnyEvent::HTTP is laoded for the first time it will query the 1301When AnyEvent::HTTP is loaded for the first time it will query the
1199default proxy from the operating system, currently by looking at 1302default proxy from the operating system, currently by looking at
1200C<$ENV{http_proxy>}. 1303C<$ENV{http_proxy>}.
1201 1304
1202=item AnyEvent::HTTP::cookie_jar_expire $jar[, $session_end] 1305=item AnyEvent::HTTP::cookie_jar_expire $jar[, $session_end]
1203 1306
1205C<$session_end> is given and true, then additionally remove all session 1308C<$session_end> is given and true, then additionally remove all session
1206cookies. 1309cookies.
1207 1310
1208You should call this function (with a true C<$session_end>) before you 1311You should call this function (with a true C<$session_end>) before you
1209save cookies to disk, and you should call this function after loading them 1312save cookies to disk, and you should call this function after loading them
1210again. If you have a long-running program you can additonally call this 1313again. If you have a long-running program you can additionally call this
1211function from time to time. 1314function from time to time.
1212 1315
1213A cookie jar is initially an empty hash-reference that is managed by this 1316A cookie jar is initially an empty hash-reference that is managed by this
1214module. It's format is subject to change, but currently it is like this: 1317module. Its format is subject to change, but currently it is as follows:
1215 1318
1216The key C<version> has to contain C<1>, otherwise the hash gets 1319The key C<version> has to contain C<2>, otherwise the hash gets
1217emptied. All other keys are hostnames or IP addresses pointing to 1320cleared. All other keys are hostnames or IP addresses pointing to
1218hash-references. The key for these inner hash references is the 1321hash-references. The key for these inner hash references is the
1219server path for which this cookie is meant, and the values are again 1322server path for which this cookie is meant, and the values are again
1220hash-references. The keys of those hash-references is the cookie name, and 1323hash-references. Each key of those hash-references is a cookie name, and
1221the value, you guessed it, is another hash-reference, this time with the 1324the value, you guessed it, is another hash-reference, this time with the
1222key-value pairs from the cookie, except for C<expires> and C<max-age>, 1325key-value pairs from the cookie, except for C<expires> and C<max-age>,
1223which have been replaced by a C<_expires> key that contains the cookie 1326which have been replaced by a C<_expires> key that contains the cookie
1224expiry timestamp. 1327expiry timestamp. Session cookies are indicated by not having an
1328C<_expires> key.
1225 1329
1226Here is an example of a cookie jar with a single cookie, so you have a 1330Here is an example of a cookie jar with a single cookie, so you have a
1227chance of understanding the above paragraph: 1331chance of understanding the above paragraph:
1228 1332
1229 { 1333 {
1230 version => 1, 1334 version => 2,
1231 "10.0.0.1" => { 1335 "10.0.0.1" => {
1232 "/" => { 1336 "/" => {
1233 "mythweb_id" => { 1337 "mythweb_id" => {
1234 _expires => 1293917923, 1338 _expires => 1293917923,
1235 value => "ooRung9dThee3ooyXooM1Ohm", 1339 value => "ooRung9dThee3ooyXooM1Ohm",
1253 1357
1254The default value for the C<recurse> request parameter (default: C<10>). 1358The default value for the C<recurse> request parameter (default: C<10>).
1255 1359
1256=item $AnyEvent::HTTP::TIMEOUT 1360=item $AnyEvent::HTTP::TIMEOUT
1257 1361
1258The default timeout for conenction operations (default: C<300>). 1362The default timeout for connection operations (default: C<300>).
1259 1363
1260=item $AnyEvent::HTTP::USERAGENT 1364=item $AnyEvent::HTTP::USERAGENT
1261 1365
1262The default value for the C<User-Agent> header (the default is 1366The default value for the C<User-Agent> header (the default is
1263C<Mozilla/5.0 (compatible; U; AnyEvent-HTTP/$VERSION; +http://software.schmorp.de/pkg/AnyEvent)>). 1367C<Mozilla/5.0 (compatible; U; AnyEvent-HTTP/$VERSION; +http://software.schmorp.de/pkg/AnyEvent)>).
1264 1368
1265=item $AnyEvent::HTTP::MAX_PER_HOST 1369=item $AnyEvent::HTTP::MAX_PER_HOST
1266 1370
1267The maximum number of concurrent connections to the same host (identified 1371The maximum number of concurrent connections to the same host (identified
1268by the hostname). If the limit is exceeded, then the additional requests 1372by the hostname). If the limit is exceeded, then additional requests
1269are queued until previous connections are closed. Both persistent and 1373are queued until previous connections are closed. Both persistent and
1270non-persistent connections are counted in this limit. 1374non-persistent connections are counted in this limit.
1271 1375
1272The default value for this is C<4>, and it is highly advisable to not 1376The default value for this is C<4>, and it is highly advisable to not
1273increase it much. 1377increase it much.
1274 1378
1275For comparison: the RFC's recommend 4 non-persistent or 2 persistent 1379For comparison: the RFC's recommend 4 non-persistent or 2 persistent
1276connections, older browsers used 2, newers (such as firefox 3) typically 1380connections, older browsers used 2, newer ones (such as firefox 3)
1277use 6, and Opera uses 8 because like, they have the fastest browser and 1381typically use 6, and Opera uses 8 because like, they have the fastest
1278give a shit for everybody else on the planet. 1382browser and give a shit for everybody else on the planet.
1279 1383
1280=item $AnyEvent::HTTP::PERSISTENT_TIMEOUT 1384=item $AnyEvent::HTTP::PERSISTENT_TIMEOUT
1281 1385
1282The time after which idle persistent conenctions get closed by 1386The time after which idle persistent connections get closed by
1283AnyEvent::HTTP (default: C<3>). 1387AnyEvent::HTTP (default: C<3>).
1284 1388
1285=item $AnyEvent::HTTP::ACTIVE 1389=item $AnyEvent::HTTP::ACTIVE
1286 1390
1287The number of active connections. This is not the number of currently 1391The number of active connections. This is not the number of currently
1328 # other formats fail in the loop below 1432 # other formats fail in the loop below
1329 1433
1330 for (0..11) { 1434 for (0..11) {
1331 if ($m eq $month[$_]) { 1435 if ($m eq $month[$_]) {
1332 require Time::Local; 1436 require Time::Local;
1333 return Time::Local::timegm ($S, $M, $H, $d, $_, $y); 1437 return eval { Time::Local::timegm ($S, $M, $H, $d, $_, $y) };
1334 } 1438 }
1335 } 1439 }
1336 1440
1337 undef 1441 undef
1338} 1442}
1352 set_proxy $ENV{http_proxy}; 1456 set_proxy $ENV{http_proxy};
1353}; 1457};
1354 1458
1355=head2 SHOWCASE 1459=head2 SHOWCASE
1356 1460
1357This section contaisn some more elaborate "real-world" examples or code 1461This section contains some more elaborate "real-world" examples or code
1358snippets. 1462snippets.
1359 1463
1360=head2 HTTP/1.1 FILE DOWNLOAD 1464=head2 HTTP/1.1 FILE DOWNLOAD
1361 1465
1362Downloading files with HTTP can be quite tricky, especially when something 1466Downloading files with HTTP can be quite tricky, especially when something
1366last modified time to check for file content changes, and works with many 1470last modified time to check for file content changes, and works with many
1367HTTP/1.0 servers as well, and usually falls back to a complete re-download 1471HTTP/1.0 servers as well, and usually falls back to a complete re-download
1368on older servers. 1472on older servers.
1369 1473
1370It calls the completion callback with either C<undef>, which means a 1474It calls the completion callback with either C<undef>, which means a
1371nonretryable error occured, C<0> when the download was partial and should 1475nonretryable error occurred, C<0> when the download was partial and should
1372be retried, and C<1> if it was successful. 1476be retried, and C<1> if it was successful.
1373 1477
1374 use AnyEvent::HTTP; 1478 use AnyEvent::HTTP;
1375 1479
1376 sub download($$$) { 1480 sub download($$$) {
1380 or die "$file: $!"; 1484 or die "$file: $!";
1381 1485
1382 my %hdr; 1486 my %hdr;
1383 my $ofs = 0; 1487 my $ofs = 0;
1384 1488
1385 warn stat $fh;
1386 warn -s _;
1387 if (stat $fh and -s _) { 1489 if (stat $fh and -s _) {
1388 $ofs = -s _; 1490 $ofs = -s _;
1389 warn "-s is ", $ofs; 1491 warn "-s is ", $ofs;
1390 $hdr{"if-unmodified-since"} = AnyEvent::HTTP::format_date +(stat _)[9]; 1492 $hdr{"if-unmodified-since"} = AnyEvent::HTTP::format_date +(stat _)[9];
1391 $hdr{"range"} = "bytes=$ofs-"; 1493 $hdr{"range"} = "bytes=$ofs-";
1419 my (undef, $hdr) = @_; 1521 my (undef, $hdr) = @_;
1420 1522
1421 my $status = $hdr->{Status}; 1523 my $status = $hdr->{Status};
1422 1524
1423 if (my $time = AnyEvent::HTTP::parse_date $hdr->{"last-modified"}) { 1525 if (my $time = AnyEvent::HTTP::parse_date $hdr->{"last-modified"}) {
1424 utime $fh, $time, $time; 1526 utime $time, $time, $fh;
1425 } 1527 }
1426 1528
1427 if ($status == 200 || $status == 206 || $status == 416) { 1529 if ($status == 200 || $status == 206 || $status == 416) {
1428 # download ok || resume ok || file already fully downloaded 1530 # download ok || resume ok || file already fully downloaded
1429 $cb->(1, $hdr); 1531 $cb->(1, $hdr);

Diff Legend

Removed lines
+ Added lines
< Changed lines
> Changed lines