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.105 by root, Tue May 10 12:33:51 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.11'; 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 "got a destructed habndle. pah\n";#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 "got a destructed habndle. pa2\n";#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 $state{handle}->destroyed
1149 and die "got a destructed habndle. pa3\n";#d#
1150 1251
1151 } else { 1252 } else {
1152 my $tcp_connect = $arg{tcp_connect} 1253 my $tcp_connect = $arg{tcp_connect}
1153 || do { require AnyEvent::Socket; \&AnyEvent::Socket::tcp_connect }; 1254 || do { require AnyEvent::Socket; \&AnyEvent::Socket::tcp_connect };
1154 1255
1195Sets 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
1196string of the form C<http://host:port>, croaks otherwise. 1297string of the form C<http://host:port>, croaks otherwise.
1197 1298
1198To clear an already-set proxy, use C<undef>. 1299To clear an already-set proxy, use C<undef>.
1199 1300
1200When 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
1201default proxy from the operating system, currently by looking at 1302default proxy from the operating system, currently by looking at
1202C<$ENV{http_proxy>}. 1303C<$ENV{http_proxy>}.
1203 1304
1204=item AnyEvent::HTTP::cookie_jar_expire $jar[, $session_end] 1305=item AnyEvent::HTTP::cookie_jar_expire $jar[, $session_end]
1205 1306
1207C<$session_end> is given and true, then additionally remove all session 1308C<$session_end> is given and true, then additionally remove all session
1208cookies. 1309cookies.
1209 1310
1210You 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
1211save 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
1212again. 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
1213function from time to time. 1314function from time to time.
1214 1315
1215A 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
1216module. 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:
1217 1318
1218The 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
1219emptied. All other keys are hostnames or IP addresses pointing to 1320cleared. All other keys are hostnames or IP addresses pointing to
1220hash-references. The key for these inner hash references is the 1321hash-references. The key for these inner hash references is the
1221server 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
1222hash-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
1223the 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
1224key-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>,
1225which 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
1226expiry timestamp. 1327expiry timestamp. Session cookies are indicated by not having an
1328C<_expires> key.
1227 1329
1228Here 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
1229chance of understanding the above paragraph: 1331chance of understanding the above paragraph:
1230 1332
1231 { 1333 {
1232 version => 1, 1334 version => 2,
1233 "10.0.0.1" => { 1335 "10.0.0.1" => {
1234 "/" => { 1336 "/" => {
1235 "mythweb_id" => { 1337 "mythweb_id" => {
1236 _expires => 1293917923, 1338 _expires => 1293917923,
1237 value => "ooRung9dThee3ooyXooM1Ohm", 1339 value => "ooRung9dThee3ooyXooM1Ohm",
1255 1357
1256The default value for the C<recurse> request parameter (default: C<10>). 1358The default value for the C<recurse> request parameter (default: C<10>).
1257 1359
1258=item $AnyEvent::HTTP::TIMEOUT 1360=item $AnyEvent::HTTP::TIMEOUT
1259 1361
1260The default timeout for conenction operations (default: C<300>). 1362The default timeout for connection operations (default: C<300>).
1261 1363
1262=item $AnyEvent::HTTP::USERAGENT 1364=item $AnyEvent::HTTP::USERAGENT
1263 1365
1264The default value for the C<User-Agent> header (the default is 1366The default value for the C<User-Agent> header (the default is
1265C<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)>).
1266 1368
1267=item $AnyEvent::HTTP::MAX_PER_HOST 1369=item $AnyEvent::HTTP::MAX_PER_HOST
1268 1370
1269The maximum number of concurrent connections to the same host (identified 1371The maximum number of concurrent connections to the same host (identified
1270by the hostname). If the limit is exceeded, then the additional requests 1372by the hostname). If the limit is exceeded, then additional requests
1271are queued until previous connections are closed. Both persistent and 1373are queued until previous connections are closed. Both persistent and
1272non-persistent connections are counted in this limit. 1374non-persistent connections are counted in this limit.
1273 1375
1274The 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
1275increase it much. 1377increase it much.
1276 1378
1277For comparison: the RFC's recommend 4 non-persistent or 2 persistent 1379For comparison: the RFC's recommend 4 non-persistent or 2 persistent
1278connections, older browsers used 2, newers (such as firefox 3) typically 1380connections, older browsers used 2, newer ones (such as firefox 3)
1279use 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
1280give a shit for everybody else on the planet. 1382browser and give a shit for everybody else on the planet.
1281 1383
1282=item $AnyEvent::HTTP::PERSISTENT_TIMEOUT 1384=item $AnyEvent::HTTP::PERSISTENT_TIMEOUT
1283 1385
1284The time after which idle persistent conenctions get closed by 1386The time after which idle persistent connections get closed by
1285AnyEvent::HTTP (default: C<3>). 1387AnyEvent::HTTP (default: C<3>).
1286 1388
1287=item $AnyEvent::HTTP::ACTIVE 1389=item $AnyEvent::HTTP::ACTIVE
1288 1390
1289The number of active connections. This is not the number of currently 1391The number of active connections. This is not the number of currently
1330 # other formats fail in the loop below 1432 # other formats fail in the loop below
1331 1433
1332 for (0..11) { 1434 for (0..11) {
1333 if ($m eq $month[$_]) { 1435 if ($m eq $month[$_]) {
1334 require Time::Local; 1436 require Time::Local;
1335 return Time::Local::timegm ($S, $M, $H, $d, $_, $y); 1437 return eval { Time::Local::timegm ($S, $M, $H, $d, $_, $y) };
1336 } 1438 }
1337 } 1439 }
1338 1440
1339 undef 1441 undef
1340} 1442}
1354 set_proxy $ENV{http_proxy}; 1456 set_proxy $ENV{http_proxy};
1355}; 1457};
1356 1458
1357=head2 SHOWCASE 1459=head2 SHOWCASE
1358 1460
1359This section contaisn some more elaborate "real-world" examples or code 1461This section contains some more elaborate "real-world" examples or code
1360snippets. 1462snippets.
1361 1463
1362=head2 HTTP/1.1 FILE DOWNLOAD 1464=head2 HTTP/1.1 FILE DOWNLOAD
1363 1465
1364Downloading files with HTTP can be quite tricky, especially when something 1466Downloading files with HTTP can be quite tricky, especially when something
1368last 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
1369HTTP/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
1370on older servers. 1472on older servers.
1371 1473
1372It calls the completion callback with either C<undef>, which means a 1474It calls the completion callback with either C<undef>, which means a
1373nonretryable error occured, C<0> when the download was partial and should 1475nonretryable error occurred, C<0> when the download was partial and should
1374be retried, and C<1> if it was successful. 1476be retried, and C<1> if it was successful.
1375 1477
1376 use AnyEvent::HTTP; 1478 use AnyEvent::HTTP;
1377 1479
1378 sub download($$$) { 1480 sub download($$$) {
1382 or die "$file: $!"; 1484 or die "$file: $!";
1383 1485
1384 my %hdr; 1486 my %hdr;
1385 my $ofs = 0; 1487 my $ofs = 0;
1386 1488
1387 warn stat $fh;
1388 warn -s _;
1389 if (stat $fh and -s _) { 1489 if (stat $fh and -s _) {
1390 $ofs = -s _; 1490 $ofs = -s _;
1391 warn "-s is ", $ofs;#d# 1491 warn "-s is ", $ofs;
1392 $hdr{"if-unmodified-since"} = AnyEvent::HTTP::format_date +(stat _)[9]; 1492 $hdr{"if-unmodified-since"} = AnyEvent::HTTP::format_date +(stat _)[9];
1393 $hdr{"range"} = "bytes=$ofs-"; 1493 $hdr{"range"} = "bytes=$ofs-";
1394 } 1494 }
1395 1495
1396 http_get $url, 1496 http_get $url,
1421 my (undef, $hdr) = @_; 1521 my (undef, $hdr) = @_;
1422 1522
1423 my $status = $hdr->{Status}; 1523 my $status = $hdr->{Status};
1424 1524
1425 if (my $time = AnyEvent::HTTP::parse_date $hdr->{"last-modified"}) { 1525 if (my $time = AnyEvent::HTTP::parse_date $hdr->{"last-modified"}) {
1426 utime $fh, $time, $time; 1526 utime $time, $time, $fh;
1427 } 1527 }
1428 1528
1429 if ($status == 200 || $status == 206 || $status == 416) { 1529 if ($status == 200 || $status == 206 || $status == 416) {
1430 # download ok || resume ok || file already fully downloaded 1530 # download ok || resume ok || file already fully downloaded
1431 $cb->(1, $hdr); 1531 $cb->(1, $hdr);

Diff Legend

Removed lines
+ Added lines
< Changed lines
> Changed lines