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.95 by root, Wed Jan 12 03:30:05 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.02'; 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
169 178
170You really should provide your own C<User-Agent:> header value that is 179You really should provide your own C<User-Agent:> header value that is
171appropriate for your program - I wouldn't be surprised if the default 180appropriate for your program - I wouldn't be surprised if the default
172AnyEvent string gets blocked by webservers sooner or later. 181AnyEvent string gets blocked by webservers sooner or later.
173 182
183Also, make sure that your headers names and values do not contain any
184embedded newlines.
185
174=item timeout => $seconds 186=item timeout => $seconds
175 187
176The time-out to use for various stages - each connect attempt will reset 188The 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 189the timeout, as will read or write activity, i.e. this is not an overall
178timeout. 190timeout.
179 191
180Default timeout is 5 minutes. 192Default timeout is 5 minutes.
181 193
182=item proxy => [$host, $port[, $scheme]] or undef 194=item proxy => [$host, $port[, $scheme]] or undef
183 195
184Use the given http proxy for all requests. If not specified, then the 196Use 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. 197used.
186 198
187C<$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.
200
201If not specified, then the default proxy is used (see
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>.
188 211
189=item body => $string 212=item body => $string
190 213
191The 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
192this module might offer more options). 215this module might offer more options).
225The 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
226me the page, no matter what". 249me the page, no matter what".
227 250
228See also the C<sessionid> parameter. 251See also the C<sessionid> parameter.
229 252
230=item session => $string 253=item sessionid => $string
231 254
232The module might reuse connections to the same host internally. Sometimes 255The module might reuse connections to the same host internally (regardless
233(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
234sessions. This can be achieved by setting this parameter to some unique 258from other sessions. This can be achieved by setting this parameter to
235ID (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
236context) - 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.
237 262
238=item on_prepare => $callback->($fh) 263=item on_prepare => $callback->($fh)
239 264
240In 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
241connect (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
242overrides the prepare callback passed to C<AnyEvent::Socket::tcp_connect> 267overrides the prepare callback passed to C<AnyEvent::Socket::tcp_connect>
243and 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
244timeout). See the description for the C<$prepare_cb> argument of 269timeout). See the description for the C<$prepare_cb> argument of
245C<AnyEvent::Socket::tcp_connect> for details. 270C<AnyEvent::Socket::tcp_connect> for details.
246 271
249In even rarer cases you want total control over how AnyEvent::HTTP 274In even rarer cases you want total control over how AnyEvent::HTTP
250establishes connections. Normally it uses L<AnyEvent::Socket::tcp_connect> 275establishes connections. Normally it uses L<AnyEvent::Socket::tcp_connect>
251to 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 -
252obviously, it has to follow the same calling conventions, except that it 277obviously, it has to follow the same calling conventions, except that it
253may 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.
254 285
255There are probably lots of weird uses for this function, starting from 286There are probably lots of weird uses for this function, starting from
256tracing the hosts C<http_request> actually tries to connect, to (inexact 287tracing the hosts C<http_request> actually tries to connect, to (inexact
257but fast) host => IP address caching or even socks protocol support. 288but fast) host => IP address caching or even socks protocol support.
258 289
328=item persistent => $boolean 359=item persistent => $boolean
329 360
330Try to create/reuse a persistent connection. When this flag is set 361Try to create/reuse a persistent connection. When this flag is set
331(default: true for idempotent requests, false for all others), then 362(default: true for idempotent requests, false for all others), then
332C<http_request> tries to re-use an existing (previously-created) 363C<http_request> tries to re-use an existing (previously-created)
333persistent connection to the host and, failing that, tries to create a new 364persistent connection to same host (i.e. identical URL scheme, hostname,
334one. 365port and sessionid) and, failing that, tries to create a new one.
335 366
336Requests failing in certain ways will be automatically retried once, which 367Requests failing in certain ways will be automatically retried once, which
337is 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
338for 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
339made it impossible to distinguish between a fatal error and a normal 370made it impossible to distinguish between a fatal error and a normal
340connection timeout, so you never know whether there was a problem with 371connection timeout, so you never know whether there was a problem with
341your request or not. 372your request or not.
342 373
343When reusing an existent connection, many parameters (such as TLS context) 374When reusing an existent connection, many parameters (such as TLS context)
344will be ignored. See the C<session> parameter for a workaround. 375will be ignored. See the C<sessionid> parameter for a workaround.
345 376
346=item keepalive => $boolean 377=item keepalive => $boolean
347 378
348Only used when C<persistent> is also true. This parameter decides whether 379Only used when C<persistent> is also true. This parameter decides whether
349C<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
378 409
379Example: 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
380timeout of 30 seconds. 411timeout of 30 seconds.
381 412
382 http_request 413 http_request
383 GET => "https://www.google.com", 414 HEAD => "https://www.google.com",
384 headers => { "user-agent" => "MySearchClient 1.0" }, 415 headers => { "user-agent" => "MySearchClient 1.0" },
385 timeout => 30, 416 timeout => 30,
386 sub { 417 sub {
387 my ($body, $hdr) = @_; 418 my ($body, $hdr) = @_;
388 use Data::Dumper; 419 use Data::Dumper;
440 471
441# expire cookies 472# expire cookies
442sub cookie_jar_expire($;$) { 473sub cookie_jar_expire($;$) {
443 my ($jar, $session_end) = @_; 474 my ($jar, $session_end) = @_;
444 475
445 %$jar = () if $jar->{version} != 1; 476 %$jar = () if $jar->{version} != 2;
446 477
447 my $anow = AE::now; 478 my $anow = AE::now;
448 479
449 while (my ($chost, $paths) = each %$jar) { 480 while (my ($chost, $paths) = each %$jar) {
450 next unless ref $paths; 481 next unless ref $paths;
470 501
471# extract cookies from jar 502# extract cookies from jar
472sub cookie_jar_extract($$$$) { 503sub cookie_jar_extract($$$$) {
473 my ($jar, $scheme, $host, $path) = @_; 504 my ($jar, $scheme, $host, $path) = @_;
474 505
475 %$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]/;
476 510
477 my @cookies; 511 my @cookies;
478 512
479 while (my ($chost, $paths) = each %$jar) { 513 while (my ($chost, $paths) = each %$jar) {
480 next unless ref $paths; 514 next unless ref $paths;
481 515
482 if ($chost =~ /^\./) { 516 # exact match or suffix including . match
483 next unless $chost eq substr $host, -length $chost; 517 $chost eq $host or ".$chost" eq substr $host, -1 - length $chost
484 } elsif ($chost =~ /\./) {
485 next unless $chost eq $host;
486 } else {
487 next; 518 or next;
488 }
489 519
490 while (my ($cpath, $cookies) = each %$paths) { 520 while (my ($cpath, $cookies) = each %$paths) {
491 next unless $cpath eq substr $path, 0, length $cpath; 521 next unless $cpath eq substr $path, 0, length $cpath;
492 522
493 while (my ($cookie, $kv) = each %$cookies) { 523 while (my ($cookie, $kv) = each %$cookies) {
514} 544}
515 545
516# parse set_cookie header into jar 546# parse set_cookie header into jar
517sub cookie_jar_set_cookie($$$$) { 547sub cookie_jar_set_cookie($$$$) {
518 my ($jar, $set_cookie, $host, $date) = @_; 548 my ($jar, $set_cookie, $host, $date) = @_;
549
550 %$jar = () if $jar->{version} != 2;
519 551
520 my $anow = int AE::now; 552 my $anow = int AE::now;
521 my $snow; # server-now 553 my $snow; # server-now
522 554
523 for ($set_cookie) { 555 for ($set_cookie) {
529 while ( 561 while (
530 m{ 562 m{
531 \G\s* 563 \G\s*
532 (?: 564 (?:
533 expires \s*=\s* ([A-Z][a-z][a-z]+,\ [^,;]+) 565 expires \s*=\s* ([A-Z][a-z][a-z]+,\ [^,;]+)
534 | ([^=;,[:space:]]+) (?: \s*=\s* (?: "((?:[^\\"]+|\\.)*)" | ([^=;,[:space:]]*) ) )? 566 | ([^=;,[:space:]]+) (?: \s*=\s* (?: "((?:[^\\"]+|\\.)*)" | ([^;,[:space:]]*) ) )?
535 ) 567 )
536 }gcxsi 568 }gcxsi
537 ) { 569 ) {
538 my $name = $2; 570 my $name = $2;
539 my $value = $4; 571 my $value = $4;
569 601
570 my $cdom; 602 my $cdom;
571 my $cpath = (delete $kv{path}) || "/"; 603 my $cpath = (delete $kv{path}) || "/";
572 604
573 if (exists $kv{domain}) { 605 if (exists $kv{domain}) {
574 $cdom = delete $kv{domain}; 606 $cdom = $kv{domain};
575 607
576 $cdom =~ s/^\.?/./; # make sure it starts with a "." 608 $cdom =~ s/^\.?/./; # make sure it starts with a "."
577 609
578 next if $cdom =~ /\.$/; 610 next if $cdom =~ /\.$/;
579 611
580 # this is not rfc-like and not netscape-like. go figure. 612 # this is not rfc-like and not netscape-like. go figure.
581 my $ndots = $cdom =~ y/.//; 613 my $ndots = $cdom =~ y/.//;
582 next if $ndots < ($cdom =~ /\.[^.][^.]\.[^.][^.]$/ ? 3 : 2); 614 next if $ndots < ($cdom =~ /\.[^.][^.]\.[^.][^.]$/ ? 3 : 2);
615
616 $cdom = substr $cdom, 1; # remove initial .
583 } else { 617 } else {
584 $cdom = $host; 618 $cdom = $host;
585 } 619 }
586 620
587 # store it 621 # store it
588 $jar->{version} = 1; 622 $jar->{version} = 2;
589 $jar->{lc $cdom}{$cpath}{$name} = \%kv; 623 $jar->{lc $cdom}{$cpath}{$name} = \%kv;
590 624
591 redo if /\G\s*,/gc; 625 redo if /\G\s*,/gc;
592 } 626 }
593} 627}
683 717
684 $cb->(undef, $hdr); 718 $cb->(undef, $hdr);
685 () 719 ()
686} 720}
687 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
688sub http_request($$@) { 762sub http_request($$@) {
689 my $cb = pop; 763 my $cb = pop;
690 my ($method, $url, %arg) = @_; 764 my ($method, $url, %arg) = @_;
691 765
692 my %hdr; 766 my %hdr;
709 my $recurse = exists $arg{recurse} ? delete $arg{recurse} : $MAX_RECURSE; 783 my $recurse = exists $arg{recurse} ? delete $arg{recurse} : $MAX_RECURSE;
710 784
711 return $cb->(undef, { @pseudo, Status => 599, Reason => "Too many redirections" }) 785 return $cb->(undef, { @pseudo, Status => 599, Reason => "Too many redirections" })
712 if $recurse < 0; 786 if $recurse < 0;
713 787
714 my $proxy = $arg{proxy} || $PROXY; 788 my $proxy = exists $arg{proxy} ? $arg{proxy} : $PROXY;
715 my $timeout = $arg{timeout} || $TIMEOUT; 789 my $timeout = $arg{timeout} || $TIMEOUT;
716 790
717 my ($uscheme, $uauthority, $upath, $query, undef) = # ignore fragment 791 my ($uscheme, $uauthority, $upath, $query, undef) = # ignore fragment
718 $url =~ m|(?:([^:/?#]+):)?(?://([^/?#]*))?([^?#]*)(?:(\?[^#]*))?(?:#(.*))?|; 792 $url =~ m|^([^:]+):(?://([^/?#]*))?([^?#]*)(?:(\?[^#]*))?(?:#(.*))?$|;
719 793
720 $uscheme = lc $uscheme; 794 $uscheme = lc $uscheme;
721 795
722 my $uport = $uscheme eq "http" ? 80 796 my $uport = $uscheme eq "http" ? 80
723 : $uscheme eq "https" ? 443 797 : $uscheme eq "https" ? 443
724 : 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" });
725 799
726 $uauthority =~ /^(?: .*\@ )? ([^\@:]+) (?: : (\d+) )?$/x 800 $uauthority =~ /^(?: .*\@ )? ([^\@]+?) (?: : (\d+) )?$/x
727 or return $cb->(undef, { @pseudo, Status => 599, Reason => "Unparsable URL" }); 801 or return $cb->(undef, { @pseudo, Status => 599, Reason => "Unparsable URL" });
728 802
729 my $uhost = lc $1; 803 my $uhost = lc $1;
730 $uport = $2 if defined $2; 804 $uport = $2 if defined $2;
731 805
767 $hdr{"user-agent"} = $USERAGENT unless exists $hdr{"user-agent"}; 841 $hdr{"user-agent"} = $USERAGENT unless exists $hdr{"user-agent"};
768 842
769 $hdr{"content-length"} = length $arg{body} 843 $hdr{"content-length"} = length $arg{body}
770 if length $arg{body} || $method ne "GET"; 844 if length $arg{body} || $method ne "GET";
771 845
772 my $idempotent = $method =~ /^(?:GET|HEAD|PUT|DELETE|OPTIONS|TRACE)$/; 846 my $idempotent = $IDEMPOTENT{$method};
773 847
774 # 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
775 my $keepalive = exists $arg{keepalive} ? !!$arg{keepalive} : $idempotent; 849 my $persistent = exists $arg{persistent} ? !!$arg{persistent} : $idempotent;
776 my $keepalive10 = exists $arg{keepalive10} ? $arg{keepalive10} : !$proxy; 850 my $keepalive = exists $arg{keepalive} ? !!$arg{keepalive} : !$proxy;
777 my $keptalive; # true if this is actually a recycled connection 851 my $was_persistent; # true if this is actually a recycled connection
778 852
779 # the key to use in the keepalive cache 853 # the key to use in the keepalive cache
780 my $ka_key = "$uhost\x00$arg{sessionid}"; 854 my $ka_key = "$uscheme\x00$uhost\x00$uport\x00$arg{sessionid}";
781 855
782 $hdr{connection} = ($keepalive ? $keepalive10 ? "keep-alive " : "" : "close ") . "Te"; #1.1 856 $hdr{connection} = ($persistent ? $keepalive ? "keep-alive, " : "" : "close, ") . "Te"; #1.1
783 $hdr{te} = "trailers" unless exists $hdr{te}; #1.1 857 $hdr{te} = "trailers" unless exists $hdr{te}; #1.1
784 858
785 my %state = (connect_guard => 1); 859 my %state = (connect_guard => 1);
786 860
787 my $ae_error = 595; # connecting 861 my $ae_error = 595; # connecting
797 # send request 871 # send request
798 $hdl->push_write ( 872 $hdl->push_write (
799 "$method $rpath HTTP/1.1\015\012" 873 "$method $rpath HTTP/1.1\015\012"
800 . (join "", map "\u$_: $hdr{$_}\015\012", grep defined $hdr{$_}, keys %hdr) 874 . (join "", map "\u$_: $hdr{$_}\015\012", grep defined $hdr{$_}, keys %hdr)
801 . "\015\012" 875 . "\015\012"
802 . (delete $arg{body}) 876 . $arg{body}
803 ); 877 );
804 878
805 # return if error occured during push_write() 879 # return if error occurred during push_write()
806 return unless %state; 880 return unless %state;
807 881
808 # 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.
809 %hdr = (); 883 %hdr = ();
810 884
837 911
838 %hdr = (%$hdr, @pseudo); 912 %hdr = (%$hdr, @pseudo);
839 } 913 }
840 914
841 # redirect handling 915 # redirect handling
842 # microsoft and other shitheads don't give a shit for following standards, 916 # relative uri handling forced by microsoft and other shitheads.
843 # try to support some common forms of broken Location headers. 917 # we give our best and fall back to URI if available.
844 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"
845 $hdr{location} =~ s/^\.\/+//; 928 $loc =~ s/^\.\/+//;
846 929
847 my $url = "$rscheme://$uhost:$uport"; 930 if ($loc !~ m%^[.?#]%) {
931 my $prefix = "$uscheme://$uauthority";
848 932
849 unless ($hdr{location} =~ s/^\///) { 933 unless ($loc =~ s/^\///) {
850 $url .= $upath; 934 $prefix .= $upath;
851 $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 }
852 } 949 }
853 950
854 $hdr{location} = "$url/$hdr{location}"; 951 $hdr{location} = $loc;
855 } 952 }
856 953
857 my $redirect; 954 my $redirect;
858 955
859 if ($recurse) { 956 if ($recurse) {
861 958
862 # industry standard is to redirect POST as GET for 959 # industry standard is to redirect POST as GET for
863 # 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.
864 # 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,
865 # industry standard seems to be to simply follow. 962 # industry standard seems to be to simply follow.
866 # we go with the industry standard. 963 # we go with the industry standard. 308 is defined
964 # by rfc7538
867 if ($status == 301 or $status == 302 or $status == 303) { 965 if ($status == 301 or $status == 302 or $status == 303) {
966 $redirect = 1;
868 # HTTP/1.1 is unclear on how to mutate the method 967 # HTTP/1.1 is unclear on how to mutate the method
869 $method = "GET" unless $method eq "HEAD"; 968 unless ($method eq "HEAD") {
870 $redirect = 1; 969 $method = "GET";
970 delete $arg{body};
971 }
871 } elsif ($status == 307) { 972 } elsif ($status == 307 or $status == 308) {
872 $redirect = 1; 973 $redirect = 1;
873 } 974 }
874 } 975 }
875 976
876 my $finish = sub { # ($data, $err_status, $err_reason[, $keepalive]) 977 my $finish = sub { # ($data, $err_status, $err_reason[, $persistent])
877 if ($state{handle}) { 978 if ($state{handle}) {
878 # handle keepalive 979 # handle keepalive
879 if ( 980 if (
880 $keepalive 981 $persistent
881 && $_[3] 982 && $_[3]
882 && ($hdr{HTTPVersion} < 1.1 983 && ($hdr{HTTPVersion} < 1.1
883 ? $hdr{connection} =~ /\bkeep-?alive\b/i 984 ? $hdr{connection} =~ /\bkeep-?alive\b/i
884 : $hdr{connection} !~ /\bclose\b/i) 985 : $hdr{connection} !~ /\bclose\b/i)
885 ) { 986 ) {
904 1005
905 if ($redirect && exists $hdr{location}) { 1006 if ($redirect && exists $hdr{location}) {
906 # we ignore any errors, as it is very common to receive 1007 # we ignore any errors, as it is very common to receive
907 # Content-Length != 0 but no actual body 1008 # Content-Length != 0 but no actual body
908 # we also access %hdr, as $_[1] might be an erro 1009 # we also access %hdr, as $_[1] might be an erro
1010 $state{recurse} =
909 http_request ( 1011 http_request (
910 $method => $hdr{location}, 1012 $method => $hdr{location},
911 %arg, 1013 %arg,
912 recurse => $recurse - 1, 1014 recurse => $recurse - 1,
913 Redirect => [$_[0], \%hdr], 1015 Redirect => [$_[0], \%hdr],
1016 sub {
1017 %state = ();
914 $cb 1018 &$cb
1019 },
915 ); 1020 );
916 } else { 1021 } else {
917 $cb->($_[0], \%hdr); 1022 $cb->($_[0], \%hdr);
918 } 1023 }
919 }; 1024 };
920 1025
948 $finish->(delete $state{handle}); 1053 $finish->(delete $state{handle});
949 1054
950 } elsif ($chunked) { 1055 } elsif ($chunked) {
951 my $cl = 0; 1056 my $cl = 0;
952 my $body = ""; 1057 my $body = "";
953 my $on_body = $arg{on_body} || sub { $body .= shift; 1 }; 1058 my $on_body = (!$redirect && $arg{on_body}) || sub { $body .= shift; 1 };
954 1059
955 $state{read_chunk} = sub { 1060 $state{read_chunk} = sub {
956 $_[1] =~ /^([0-9a-fA-F]+)/ 1061 $_[1] =~ /^([0-9a-fA-F]+)/
957 or $finish->(undef, $ae_error => "Garbled chunked transfer encoding"); 1062 or return $finish->(undef, $ae_error => "Garbled chunked transfer encoding");
958 1063
959 my $len = hex $1; 1064 my $len = hex $1;
960 1065
961 if ($len) { 1066 if ($len) {
962 $cl += $len; 1067 $cl += $len;
991 } 1096 }
992 }; 1097 };
993 1098
994 $_[0]->push_read (line => $state{read_chunk}); 1099 $_[0]->push_read (line => $state{read_chunk});
995 1100
996 } elsif ($arg{on_body}) { 1101 } elsif (!$redirect && $arg{on_body}) {
997 if (defined $len) { 1102 if (defined $len) {
998 $_[0]->on_read (sub { 1103 $_[0]->on_read (sub {
999 $len -= length $_[0]{rbuf}; 1104 $len -= length $_[0]{rbuf};
1000 1105
1001 $arg{on_body}(delete $_[0]{rbuf}, \%hdr) 1106 $arg{on_body}(delete $_[0]{rbuf}, \%hdr)
1032 } 1137 }
1033 }; 1138 };
1034 1139
1035 # if keepalive is enabled, then the server closing the connection 1140 # if keepalive is enabled, then the server closing the connection
1036 # before a response can happen legally - we retry on idempotent methods. 1141 # before a response can happen legally - we retry on idempotent methods.
1037 if ($keptalive && $idempotent) { 1142 if ($was_persistent && $idempotent) {
1038 my $old_eof = $hdl->{on_eof}; 1143 my $old_eof = $hdl->{on_eof};
1039 $hdl->{on_eof} = sub { 1144 $hdl->{on_eof} = sub {
1040 _destroy_state %state; 1145 _destroy_state %state;
1041 1146
1147 %state = ();
1148 $state{recurse} =
1042 http_request ( 1149 http_request (
1043 $method => $url, 1150 $method => $url,
1044 %arg, 1151 %arg,
1045 keepalive => 0, 1152 recurse => $recurse - 1,
1153 persistent => 0,
1154 sub {
1155 %state = ();
1046 $cb 1156 &$cb
1157 }
1047 ); 1158 );
1048 }; 1159 };
1049 $hdl->on_read (sub { 1160 $hdl->on_read (sub {
1050 return unless %state; 1161 return unless %state;
1051 1162
1052 # as soon as we receive something, a connection close 1163 # as soon as we receive something, a connection close
1060 }; 1171 };
1061 1172
1062 my $prepare_handle = sub { 1173 my $prepare_handle = sub {
1063 my ($hdl) = $state{handle}; 1174 my ($hdl) = $state{handle};
1064 1175
1065 $hdl->timeout ($timeout);
1066 $hdl->on_error (sub { 1176 $hdl->on_error (sub {
1067 _error %state, $cb, { @pseudo, Status => $ae_error, Reason => $_[2] }; 1177 _error %state, $cb, { @pseudo, Status => $ae_error, Reason => $_[2] };
1068 }); 1178 });
1069 $hdl->on_eof (sub { 1179 $hdl->on_eof (sub {
1070 _error %state, $cb, { @pseudo, Status => $ae_error, Reason => "Unexpected end-of-file" }; 1180 _error %state, $cb, { @pseudo, Status => $ae_error, Reason => "Unexpected end-of-file" };
1071 }); 1181 });
1182 $hdl->timeout_reset;
1183 $hdl->timeout ($timeout);
1072 }; 1184 };
1073 1185
1074 # connected to proxy (or origin server) 1186 # connected to proxy (or origin server)
1075 my $connect_cb = sub { 1187 my $connect_cb = sub {
1076 my $fh = shift 1188 my $fh = shift
1092 1204
1093 # now handle proxy-CONNECT method 1205 # now handle proxy-CONNECT method
1094 if ($proxy && $uscheme eq "https") { 1206 if ($proxy && $uscheme eq "https") {
1095 # oh dear, we have to wrap it into a connect request 1207 # oh dear, we have to wrap it into a connect request
1096 1208
1209 my $auth = exists $hdr{"proxy-authorization"}
1210 ? "proxy-authorization: " . (delete $hdr{"proxy-authorization"}) . "\015\012"
1211 : "";
1212
1097 # maybe re-use $uauthority with patched port? 1213 # maybe re-use $uauthority with patched port?
1098 $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");
1099 $state{handle}->push_read (line => $qr_nlnl, sub { 1215 $state{handle}->push_read (line => $qr_nlnl, sub {
1100 $_[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
1101 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])" };
1102 1218
1103 if ($2 == 200) { 1219 if ($2 == 200) {
1106 } else { 1222 } else {
1107 _error %state, $cb, { @pseudo, Status => $2, Reason => $3 }; 1223 _error %state, $cb, { @pseudo, Status => $2, Reason => $3 };
1108 } 1224 }
1109 }); 1225 });
1110 } else { 1226 } else {
1227 delete $hdr{"proxy-authorization"} unless $proxy;
1228
1111 $handle_actual_request->(); 1229 $handle_actual_request->();
1112 } 1230 }
1113 }; 1231 };
1114 1232
1115 _get_slot $uhost, sub { 1233 _get_slot $uhost, sub {
1117 1235
1118 return unless $state{connect_guard}; 1236 return unless $state{connect_guard};
1119 1237
1120 # try to use an existing keepalive connection, but only if we, ourselves, plan 1238 # 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). 1239 # on a keepalive request (in theory, this should be a separate config option).
1122 if ($keepalive && $KA_CACHE{$ka_key}) { 1240 if ($persistent && $KA_CACHE{$ka_key}) {
1123 $keptalive = 1; 1241 $was_persistent = 1;
1242
1124 $state{handle} = ka_fetch $ka_key; 1243 $state{handle} = ka_fetch $ka_key;
1244# $state{handle}->destroyed
1245# and die "AnyEvent::HTTP: unexpectedly got a destructed handle (1), please report.";#d#
1125 $prepare_handle->(); 1246 $prepare_handle->();
1247# $state{handle}->destroyed
1248# and die "AnyEvent::HTTP: unexpectedly got a destructed handle (2), please report.";#d#
1249 $rpath = $upath;
1126 $handle_actual_request->(); 1250 $handle_actual_request->();
1127 1251
1128 } else { 1252 } else {
1129 my $tcp_connect = $arg{tcp_connect} 1253 my $tcp_connect = $arg{tcp_connect}
1130 || do { require AnyEvent::Socket; \&AnyEvent::Socket::tcp_connect }; 1254 || do { require AnyEvent::Socket; \&AnyEvent::Socket::tcp_connect };
1172Sets 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
1173string of the form C<http://host:port>, croaks otherwise. 1297string of the form C<http://host:port>, croaks otherwise.
1174 1298
1175To clear an already-set proxy, use C<undef>. 1299To clear an already-set proxy, use C<undef>.
1176 1300
1301When AnyEvent::HTTP is loaded for the first time it will query the
1302default proxy from the operating system, currently by looking at
1303C<$ENV{http_proxy>}.
1304
1177=item AnyEvent::HTTP::cookie_jar_expire $jar[, $session_end] 1305=item AnyEvent::HTTP::cookie_jar_expire $jar[, $session_end]
1178 1306
1179Remove all cookies from the cookie jar that have been expired. If 1307Remove all cookies from the cookie jar that have been expired. If
1180C<$session_end> is given and true, then additionally remove all session 1308C<$session_end> is given and true, then additionally remove all session
1181cookies. 1309cookies.
1182 1310
1183You 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
1184save 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
1185again. 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
1186function from time to time. 1314function from time to time.
1187 1315
1188A 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
1189module. 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:
1190 1318
1191The 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
1192emptied. All other keys are hostnames or IP addresses pointing to 1320cleared. All other keys are hostnames or IP addresses pointing to
1193hash-references. The key for these inner hash references is the 1321hash-references. The key for these inner hash references is the
1194server 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
1195hash-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
1196the 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
1197key-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>,
1198which 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
1199expiry timestamp. 1327expiry timestamp. Session cookies are indicated by not having an
1328C<_expires> key.
1200 1329
1201Here 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
1202chance of understanding the above paragraph: 1331chance of understanding the above paragraph:
1203 1332
1204 { 1333 {
1205 version => 1, 1334 version => 2,
1206 "10.0.0.1" => { 1335 "10.0.0.1" => {
1207 "/" => { 1336 "/" => {
1208 "mythweb_id" => { 1337 "mythweb_id" => {
1209 _expires => 1293917923, 1338 _expires => 1293917923,
1210 value => "ooRung9dThee3ooyXooM1Ohm", 1339 value => "ooRung9dThee3ooyXooM1Ohm",
1228 1357
1229The default value for the C<recurse> request parameter (default: C<10>). 1358The default value for the C<recurse> request parameter (default: C<10>).
1230 1359
1231=item $AnyEvent::HTTP::TIMEOUT 1360=item $AnyEvent::HTTP::TIMEOUT
1232 1361
1233The default timeout for conenction operations (default: C<300>). 1362The default timeout for connection operations (default: C<300>).
1234 1363
1235=item $AnyEvent::HTTP::USERAGENT 1364=item $AnyEvent::HTTP::USERAGENT
1236 1365
1237The default value for the C<User-Agent> header (the default is 1366The 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)>). 1367C<Mozilla/5.0 (compatible; U; AnyEvent-HTTP/$VERSION; +http://software.schmorp.de/pkg/AnyEvent)>).
1239 1368
1240=item $AnyEvent::HTTP::MAX_PER_HOST 1369=item $AnyEvent::HTTP::MAX_PER_HOST
1241 1370
1242The maximum number of concurrent connections to the same host (identified 1371The maximum number of concurrent connections to the same host (identified
1243by the hostname). If the limit is exceeded, then the additional requests 1372by the hostname). If the limit is exceeded, then additional requests
1244are queued until previous connections are closed. Both persistent and 1373are queued until previous connections are closed. Both persistent and
1245non-persistent connections are counted in this limit. 1374non-persistent connections are counted in this limit.
1246 1375
1247The 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
1248increase it much. 1377increase it much.
1249 1378
1250For comparison: the RFC's recommend 4 non-persistent or 2 persistent 1379For comparison: the RFC's recommend 4 non-persistent or 2 persistent
1251connections, older browsers used 2, newers (such as firefox 3) typically 1380connections, older browsers used 2, newer ones (such as firefox 3)
1252use 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
1253give a shit for everybody else on the planet. 1382browser and give a shit for everybody else on the planet.
1254 1383
1255=item $AnyEvent::HTTP::PERSISTENT_TIMEOUT 1384=item $AnyEvent::HTTP::PERSISTENT_TIMEOUT
1256 1385
1257The time after which idle persistent conenctions get closed by 1386The time after which idle persistent connections get closed by
1258AnyEvent::HTTP (default: C<3>). 1387AnyEvent::HTTP (default: C<3>).
1259 1388
1260=item $AnyEvent::HTTP::ACTIVE 1389=item $AnyEvent::HTTP::ACTIVE
1261 1390
1262The number of active connections. This is not the number of currently 1391The number of active connections. This is not the number of currently
1303 # other formats fail in the loop below 1432 # other formats fail in the loop below
1304 1433
1305 for (0..11) { 1434 for (0..11) {
1306 if ($m eq $month[$_]) { 1435 if ($m eq $month[$_]) {
1307 require Time::Local; 1436 require Time::Local;
1308 return Time::Local::timegm ($S, $M, $H, $d, $_, $y); 1437 return eval { Time::Local::timegm ($S, $M, $H, $d, $_, $y) };
1309 } 1438 }
1310 } 1439 }
1311 1440
1312 undef 1441 undef
1313} 1442}
1327 set_proxy $ENV{http_proxy}; 1456 set_proxy $ENV{http_proxy};
1328}; 1457};
1329 1458
1330=head2 SHOWCASE 1459=head2 SHOWCASE
1331 1460
1332This section contaisn some more elaborate "real-world" examples or code 1461This section contains some more elaborate "real-world" examples or code
1333snippets. 1462snippets.
1334 1463
1335=head2 HTTP/1.1 FILE DOWNLOAD 1464=head2 HTTP/1.1 FILE DOWNLOAD
1336 1465
1337Downloading files with HTTP cna be quite tricky, especially when something 1466Downloading files with HTTP can be quite tricky, especially when something
1338goes wrong and you want tor esume. 1467goes wrong and you want to resume.
1339 1468
1340Here is a function that initiates and resumes a download. It uses the 1469Here is a function that initiates and resumes a download. It uses the
1341last 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
1342HTTP/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
1343on older servers. 1472on older servers.
1344 1473
1345It calls the completion callback with either C<undef>, which means a 1474It calls the completion callback with either C<undef>, which means a
1346nonretryable error occured, C<0> when the download was partial and should 1475nonretryable error occurred, C<0> when the download was partial and should
1347be retried, and C<1> if it was successful. 1476be retried, and C<1> if it was successful.
1348 1477
1349 use AnyEvent::HTTP; 1478 use AnyEvent::HTTP;
1350 1479
1351 sub download($$$) { 1480 sub download($$$) {
1355 or die "$file: $!"; 1484 or die "$file: $!";
1356 1485
1357 my %hdr; 1486 my %hdr;
1358 my $ofs = 0; 1487 my $ofs = 0;
1359 1488
1360 warn stat $fh;
1361 warn -s _;
1362 if (stat $fh and -s _) { 1489 if (stat $fh and -s _) {
1363 $ofs = -s _; 1490 $ofs = -s _;
1364 warn "-s is ", $ofs;#d# 1491 warn "-s is ", $ofs;
1365 $hdr{"if-unmodified-since"} = AnyEvent::HTTP::format_date +(stat _)[9]; 1492 $hdr{"if-unmodified-since"} = AnyEvent::HTTP::format_date +(stat _)[9];
1366 $hdr{"range"} = "bytes=$ofs-"; 1493 $hdr{"range"} = "bytes=$ofs-";
1367 } 1494 }
1368 1495
1369 http_get $url, 1496 http_get $url,
1394 my (undef, $hdr) = @_; 1521 my (undef, $hdr) = @_;
1395 1522
1396 my $status = $hdr->{Status}; 1523 my $status = $hdr->{Status};
1397 1524
1398 if (my $time = AnyEvent::HTTP::parse_date $hdr->{"last-modified"}) { 1525 if (my $time = AnyEvent::HTTP::parse_date $hdr->{"last-modified"}) {
1399 utime $fh, $time, $time; 1526 utime $time, $time, $fh;
1400 } 1527 }
1401 1528
1402 if ($status == 200 || $status == 206 || $status == 416) { 1529 if ($status == 200 || $status == 206 || $status == 416) {
1403 # download ok || resume ok || file already fully downloaded 1530 # download ok || resume ok || file already fully downloaded
1404 $cb->(1, $hdr); 1531 $cb->(1, $hdr);

Diff Legend

Removed lines
+ Added lines
< Changed lines
> Changed lines