ViewVC Help
View File | Revision Log | Show Annotations | Download File
/cvs/AnyEvent-HTTP/HTTP.pm
(Generate patch)

Comparing AnyEvent-HTTP/HTTP.pm (file contents):
Revision 1.99 by root, Fri Jan 28 01:17:25 2011 UTC vs.
Revision 1.138 by root, Fri Aug 5 20:45:09 2022 UTC

46use AnyEvent::Util (); 46use AnyEvent::Util ();
47use AnyEvent::Handle (); 47use AnyEvent::Handle ();
48 48
49use base Exporter::; 49use base Exporter::;
50 50
51our $VERSION = '2.03'; 51our $VERSION = 2.25;
52 52
53our @EXPORT = qw(http_get http_post http_head http_request); 53our @EXPORT = qw(http_get http_post http_head http_request);
54 54
55our $USERAGENT = "Mozilla/5.0 (compatible; U; AnyEvent-HTTP/$VERSION; +http://software.schmorp.de/pkg/AnyEvent)"; 55our $USERAGENT = "Mozilla/5.0 (compatible; U; AnyEvent-HTTP/$VERSION; +http://software.schmorp.de/pkg/AnyEvent)";
56our $MAX_RECURSE = 10; 56our $MAX_RECURSE = 10;
89C<http_request> returns a "cancellation guard" - you have to keep the 89C<http_request> returns a "cancellation guard" - you have to keep the
90object at least alive until the callback get called. If the object gets 90object at least alive until the callback get called. If the object gets
91destroyed before the callback is called, the request will be cancelled. 91destroyed before the callback is called, the request will be cancelled.
92 92
93The callback will be called with the response body data as first argument 93The callback will be called with the response body data as first argument
94(or C<undef> if an error occured), and a hash-ref with response headers 94(or C<undef> if an error occurred), and a hash-ref with response headers
95(and trailers) as second argument. 95(and trailers) as second argument.
96 96
97All the headers in that hash are lowercased. In addition to the response 97All the headers in that hash are lowercased. In addition to the response
98headers, the "pseudo-headers" (uppercase to avoid clashing with possible 98headers, the "pseudo-headers" (uppercase to avoid clashing with possible
99response headers) C<HTTPVersion>, C<Status> and C<Reason> contain the 99response headers) C<HTTPVersion>, C<Status> and C<Reason> contain the
123C<590>-C<599> and the C<Reason> pseudo-header will contain an error 123C<590>-C<599> and the C<Reason> pseudo-header will contain an error
124message. Currently the following status codes are used: 124message. Currently the following status codes are used:
125 125
126=over 4 126=over 4
127 127
128=item 595 - errors during connection etsbalishment, proxy handshake. 128=item 595 - errors during connection establishment, proxy handshake.
129 129
130=item 596 - errors during TLS negotiation, request sending and header processing. 130=item 596 - errors during TLS negotiation, request sending and header processing.
131 131
132=item 597 - errors during body receiving or processing. 132=item 597 - errors during body receiving or processing.
133 133
154 154
155=over 4 155=over 4
156 156
157=item recurse => $count (default: $MAX_RECURSE) 157=item recurse => $count (default: $MAX_RECURSE)
158 158
159Whether to recurse requests or not, e.g. on redirects, authentication 159Whether to recurse requests or not, e.g. on redirects, authentication and
160retries and so on, and how often to do so. 160other retries and so on, and how often to do so.
161
162Only redirects to http and https URLs are supported. While most common
163redirection forms are handled entirely within this module, some require
164the use of the optional L<URI> module. If it is required but missing, then
165the request will fail with an error.
161 166
162=item headers => hashref 167=item headers => hashref
163 168
164The request headers to use. Currently, C<http_request> may provide its own 169The request headers to use. Currently, C<http_request> may provide its own
165C<Host:>, C<Content-Length:>, C<Connection:> and C<Cookie:> headers and 170C<Host:>, C<Content-Length:>, C<Connection:> and C<Cookie:> headers and
169 174
170You really should provide your own C<User-Agent:> header value that is 175You really should provide your own C<User-Agent:> header value that is
171appropriate for your program - I wouldn't be surprised if the default 176appropriate for your program - I wouldn't be surprised if the default
172AnyEvent string gets blocked by webservers sooner or later. 177AnyEvent string gets blocked by webservers sooner or later.
173 178
179Also, make sure that your headers names and values do not contain any
180embedded newlines.
181
174=item timeout => $seconds 182=item timeout => $seconds
175 183
176The time-out to use for various stages - each connect attempt will reset 184The time-out to use for various stages - each connect attempt will reset
177the timeout, as will read or write activity, i.e. this is not an overall 185the timeout, as will read or write activity, i.e. this is not an overall
178timeout. 186timeout.
179 187
180Default timeout is 5 minutes. 188Default timeout is 5 minutes.
181 189
182=item proxy => [$host, $port[, $scheme]] or undef 190=item proxy => [$host, $port[, $scheme]] or undef
183 191
184Use the given http proxy for all requests. If not specified, then the 192Use the given http proxy for all requests, or no proxy if C<undef> is
185default proxy (as specified by C<$ENV{http_proxy}>) is used. 193used.
186 194
187C<$scheme> must be either missing or must be C<http> for HTTP. 195C<$scheme> must be either missing or must be C<http> for HTTP.
196
197If not specified, then the default proxy is used (see
198C<AnyEvent::HTTP::set_proxy>).
199
200Currently, if your proxy requires authorization, you have to specify an
201appropriate "Proxy-Authorization" header in every request.
202
203Note that this module will prefer an existing persistent connection,
204even if that connection was made using another proxy. If you need to
205ensure that a new connection is made in this case, you can either force
206C<persistent> to false or e.g. use the proxy address in your C<sessionid>.
188 207
189=item body => $string 208=item body => $string
190 209
191The request body, usually empty. Will be sent as-is (future versions of 210The request body, usually empty. Will be sent as-is (future versions of
192this module might offer more options). 211this module might offer more options).
225The default for this option is C<low>, which could be interpreted as "give 244The default for this option is C<low>, which could be interpreted as "give
226me the page, no matter what". 245me the page, no matter what".
227 246
228See also the C<sessionid> parameter. 247See also the C<sessionid> parameter.
229 248
230=item session => $string 249=item sessionid => $string
231 250
232The module might reuse connections to the same host internally. Sometimes 251The 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 252of other settings, such as C<tcp_connect> or C<proxy>). Sometimes (e.g.
253when 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 254from 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 255some unique ID (such as the address of an object storing your state data
236context) - only connections using the same unique ID will be reused. 256or the TLS context, or the proxy IP) - only connections using the same
257unique ID will be reused.
237 258
238=item on_prepare => $callback->($fh) 259=item on_prepare => $callback->($fh)
239 260
240In rare cases you need to "tune" the socket before it is used to 261In 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 262connect (for example, to bind it on a given IP address). This parameter
242overrides the prepare callback passed to C<AnyEvent::Socket::tcp_connect> 263overrides the prepare callback passed to C<AnyEvent::Socket::tcp_connect>
243and behaves exactly the same way (e.g. it has to provide a 264and behaves exactly the same way (e.g. it has to provide a
244timeout). See the description for the C<$prepare_cb> argument of 265timeout). See the description for the C<$prepare_cb> argument of
245C<AnyEvent::Socket::tcp_connect> for details. 266C<AnyEvent::Socket::tcp_connect> for details.
246 267
249In even rarer cases you want total control over how AnyEvent::HTTP 270In even rarer cases you want total control over how AnyEvent::HTTP
250establishes connections. Normally it uses L<AnyEvent::Socket::tcp_connect> 271establishes connections. Normally it uses L<AnyEvent::Socket::tcp_connect>
251to do this, but you can provide your own C<tcp_connect> function - 272to do this, but you can provide your own C<tcp_connect> function -
252obviously, it has to follow the same calling conventions, except that it 273obviously, it has to follow the same calling conventions, except that it
253may always return a connection guard object. 274may always return a connection guard object.
275
276The connections made by this hook will be treated as equivalent to
277connections made the built-in way, specifically, they will be put into
278and taken from the persistent connection cache. If your C<$tcp_connect>
279function is incompatible with this kind of re-use, consider switching off
280C<persistent> connections and/or providing a C<sessionid> identifier.
254 281
255There are probably lots of weird uses for this function, starting from 282There are probably lots of weird uses for this function, starting from
256tracing the hosts C<http_request> actually tries to connect, to (inexact 283tracing the hosts C<http_request> actually tries to connect, to (inexact
257but fast) host => IP address caching or even socks protocol support. 284but fast) host => IP address caching or even socks protocol support.
258 285
328=item persistent => $boolean 355=item persistent => $boolean
329 356
330Try to create/reuse a persistent connection. When this flag is set 357Try to create/reuse a persistent connection. When this flag is set
331(default: true for idempotent requests, false for all others), then 358(default: true for idempotent requests, false for all others), then
332C<http_request> tries to re-use an existing (previously-created) 359C<http_request> tries to re-use an existing (previously-created)
333persistent connection to the host and, failing that, tries to create a new 360persistent connection to same host (i.e. identical URL scheme, hostname,
334one. 361port and sessionid) and, failing that, tries to create a new one.
335 362
336Requests failing in certain ways will be automatically retried once, which 363Requests failing in certain ways will be automatically retried once, which
337is dangerous for non-idempotent requests, which is why it defaults to off 364is 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 365for 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 366made it impossible to distinguish between a fatal error and a normal
340connection timeout, so you never know whether there was a problem with 367connection timeout, so you never know whether there was a problem with
341your request or not. 368your request or not.
342 369
343When reusing an existent connection, many parameters (such as TLS context) 370When reusing an existent connection, many parameters (such as TLS context)
344will be ignored. See the C<session> parameter for a workaround. 371will be ignored. See the C<sessionid> parameter for a workaround.
345 372
346=item keepalive => $boolean 373=item keepalive => $boolean
347 374
348Only used when C<persistent> is also true. This parameter decides whether 375Only 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 376C<http_request> tries to handshake a HTTP/1.0-style keep-alive connection
378 405
379Example: do a HTTP HEAD request on https://www.google.com/, use a 406Example: do a HTTP HEAD request on https://www.google.com/, use a
380timeout of 30 seconds. 407timeout of 30 seconds.
381 408
382 http_request 409 http_request
383 GET => "https://www.google.com", 410 HEAD => "https://www.google.com",
384 headers => { "user-agent" => "MySearchClient 1.0" }, 411 headers => { "user-agent" => "MySearchClient 1.0" },
385 timeout => 30, 412 timeout => 30,
386 sub { 413 sub {
387 my ($body, $hdr) = @_; 414 my ($body, $hdr) = @_;
388 use Data::Dumper; 415 use Data::Dumper;
440 467
441# expire cookies 468# expire cookies
442sub cookie_jar_expire($;$) { 469sub cookie_jar_expire($;$) {
443 my ($jar, $session_end) = @_; 470 my ($jar, $session_end) = @_;
444 471
445 %$jar = () if $jar->{version} != 1; 472 %$jar = () if $jar->{version} != 2;
446 473
447 my $anow = AE::now; 474 my $anow = AE::now;
448 475
449 while (my ($chost, $paths) = each %$jar) { 476 while (my ($chost, $paths) = each %$jar) {
450 next unless ref $paths; 477 next unless ref $paths;
470 497
471# extract cookies from jar 498# extract cookies from jar
472sub cookie_jar_extract($$$$) { 499sub cookie_jar_extract($$$$) {
473 my ($jar, $scheme, $host, $path) = @_; 500 my ($jar, $scheme, $host, $path) = @_;
474 501
475 %$jar = () if $jar->{version} != 1; 502 %$jar = () if $jar->{version} != 2;
503
504 $host = AnyEvent::Util::idn_to_ascii $host
505 if $host =~ /[^\x00-\x7f]/;
476 506
477 my @cookies; 507 my @cookies;
478 508
479 while (my ($chost, $paths) = each %$jar) { 509 while (my ($chost, $paths) = each %$jar) {
480 next unless ref $paths; 510 next unless ref $paths;
481 511
482 if ($chost =~ /^\./) { 512 # exact match or suffix including . match
483 next unless $chost eq substr $host, -length $chost; 513 $chost eq $host or ".$chost" eq substr $host, -1 - length $chost
484 } elsif ($chost =~ /\./) {
485 next unless $chost eq $host;
486 } else {
487 next; 514 or next;
488 }
489 515
490 while (my ($cpath, $cookies) = each %$paths) { 516 while (my ($cpath, $cookies) = each %$paths) {
491 next unless $cpath eq substr $path, 0, length $cpath; 517 next unless $cpath eq substr $path, 0, length $cpath;
492 518
493 while (my ($cookie, $kv) = each %$cookies) { 519 while (my ($cookie, $kv) = each %$cookies) {
514} 540}
515 541
516# parse set_cookie header into jar 542# parse set_cookie header into jar
517sub cookie_jar_set_cookie($$$$) { 543sub cookie_jar_set_cookie($$$$) {
518 my ($jar, $set_cookie, $host, $date) = @_; 544 my ($jar, $set_cookie, $host, $date) = @_;
545
546 %$jar = () if $jar->{version} != 2;
519 547
520 my $anow = int AE::now; 548 my $anow = int AE::now;
521 my $snow; # server-now 549 my $snow; # server-now
522 550
523 for ($set_cookie) { 551 for ($set_cookie) {
529 while ( 557 while (
530 m{ 558 m{
531 \G\s* 559 \G\s*
532 (?: 560 (?:
533 expires \s*=\s* ([A-Z][a-z][a-z]+,\ [^,;]+) 561 expires \s*=\s* ([A-Z][a-z][a-z]+,\ [^,;]+)
534 | ([^=;,[:space:]]+) (?: \s*=\s* (?: "((?:[^\\"]+|\\.)*)" | ([^=;,[:space:]]*) ) )? 562 | ([^=;,[:space:]]+) (?: \s*=\s* (?: "((?:[^\\"]+|\\.)*)" | ([^;,[:space:]]*) ) )?
535 ) 563 )
536 }gcxsi 564 }gcxsi
537 ) { 565 ) {
538 my $name = $2; 566 my $name = $2;
539 my $value = $4; 567 my $value = $4;
569 597
570 my $cdom; 598 my $cdom;
571 my $cpath = (delete $kv{path}) || "/"; 599 my $cpath = (delete $kv{path}) || "/";
572 600
573 if (exists $kv{domain}) { 601 if (exists $kv{domain}) {
574 $cdom = delete $kv{domain}; 602 $cdom = $kv{domain};
575 603
576 $cdom =~ s/^\.?/./; # make sure it starts with a "." 604 $cdom =~ s/^\.?/./; # make sure it starts with a "."
577 605
578 next if $cdom =~ /\.$/; 606 next if $cdom =~ /\.$/;
579 607
580 # this is not rfc-like and not netscape-like. go figure. 608 # this is not rfc-like and not netscape-like. go figure.
581 my $ndots = $cdom =~ y/.//; 609 my $ndots = $cdom =~ y/.//;
582 next if $ndots < ($cdom =~ /\.[^.][^.]\.[^.][^.]$/ ? 3 : 2); 610 next if $ndots < ($cdom =~ /\.[^.][^.]\.[^.][^.]$/ ? 3 : 2);
611
612 $cdom = substr $cdom, 1; # remove initial .
583 } else { 613 } else {
584 $cdom = $host; 614 $cdom = $host;
585 } 615 }
586 616
587 # store it 617 # store it
588 $jar->{version} = 1; 618 $jar->{version} = 2;
589 $jar->{lc $cdom}{$cpath}{$name} = \%kv; 619 $jar->{lc $cdom}{$cpath}{$name} = \%kv;
590 620
591 redo if /\G\s*,/gc; 621 redo if /\G\s*,/gc;
592 } 622 }
593} 623}
683 713
684 $cb->(undef, $hdr); 714 $cb->(undef, $hdr);
685 () 715 ()
686} 716}
687 717
718our %IDEMPOTENT = (
719 DELETE => 1,
720 GET => 1,
721 QUERY => 1,
722 HEAD => 1,
723 OPTIONS => 1,
724 PUT => 1,
725 TRACE => 1,
726
727 ACL => 1,
728 "BASELINE-CONTROL" => 1,
729 BIND => 1,
730 CHECKIN => 1,
731 CHECKOUT => 1,
732 COPY => 1,
733 LABEL => 1,
734 LINK => 1,
735 MERGE => 1,
736 MKACTIVITY => 1,
737 MKCALENDAR => 1,
738 MKCOL => 1,
739 MKREDIRECTREF => 1,
740 MKWORKSPACE => 1,
741 MOVE => 1,
742 ORDERPATCH => 1,
743 PROPFIND => 1,
744 PROPPATCH => 1,
745 REBIND => 1,
746 REPORT => 1,
747 SEARCH => 1,
748 UNBIND => 1,
749 UNCHECKOUT => 1,
750 UNLINK => 1,
751 UNLOCK => 1,
752 UPDATE => 1,
753 UPDATEREDIRECTREF => 1,
754 "VERSION-CONTROL" => 1,
755);
756
688sub http_request($$@) { 757sub http_request($$@) {
689 my $cb = pop; 758 my $cb = pop;
690 my ($method, $url, %arg) = @_; 759 my ($method, $url, %arg) = @_;
691 760
692 my %hdr; 761 my %hdr;
709 my $recurse = exists $arg{recurse} ? delete $arg{recurse} : $MAX_RECURSE; 778 my $recurse = exists $arg{recurse} ? delete $arg{recurse} : $MAX_RECURSE;
710 779
711 return $cb->(undef, { @pseudo, Status => 599, Reason => "Too many redirections" }) 780 return $cb->(undef, { @pseudo, Status => 599, Reason => "Too many redirections" })
712 if $recurse < 0; 781 if $recurse < 0;
713 782
714 my $proxy = $arg{proxy} || $PROXY; 783 my $proxy = exists $arg{proxy} ? $arg{proxy} : $PROXY;
715 my $timeout = $arg{timeout} || $TIMEOUT; 784 my $timeout = $arg{timeout} || $TIMEOUT;
716 785
717 my ($uscheme, $uauthority, $upath, $query, undef) = # ignore fragment 786 my ($uscheme, $uauthority, $upath, $query, undef) = # ignore fragment
718 $url =~ m|^([^:/?#]+):(?://([^/?#]*))?([^?#]*)(?:(\?[^#]*))?(?:#(.*))?$|; 787 $url =~ m|^([^:]+):(?://([^/?#]*))?([^?#]*)(?:(\?[^#]*))?(?:#(.*))?$|;
719 788
720 $uscheme = lc $uscheme; 789 $uscheme = lc $uscheme;
721 790
722 my $uport = $uscheme eq "http" ? 80 791 my $uport = $uscheme eq "http" ? 80
723 : $uscheme eq "https" ? 443 792 : $uscheme eq "https" ? 443
724 : return $cb->(undef, { @pseudo, Status => 599, Reason => "Only http and https URL schemes supported" }); 793 : return $cb->(undef, { @pseudo, Status => 599, Reason => "Only http and https URL schemes supported" });
725 794
726 $uauthority =~ /^(?: .*\@ )? ([^\@:]+) (?: : (\d+) )?$/x 795 $uauthority =~ /^(?: .*\@ )? ([^\@]+?) (?: : (\d+) )?$/x
727 or return $cb->(undef, { @pseudo, Status => 599, Reason => "Unparsable URL" }); 796 or return $cb->(undef, { @pseudo, Status => 599, Reason => "Unparsable URL" });
728 797
729 my $uhost = lc $1; 798 my $uhost = lc $1;
730 $uport = $2 if defined $2; 799 $uport = $2 if defined $2;
731 800
767 $hdr{"user-agent"} = $USERAGENT unless exists $hdr{"user-agent"}; 836 $hdr{"user-agent"} = $USERAGENT unless exists $hdr{"user-agent"};
768 837
769 $hdr{"content-length"} = length $arg{body} 838 $hdr{"content-length"} = length $arg{body}
770 if length $arg{body} || $method ne "GET"; 839 if length $arg{body} || $method ne "GET";
771 840
772 my $idempotent = $method =~ /^(?:GET|HEAD|PUT|DELETE|OPTIONS|TRACE)$/; 841 my $idempotent = $IDEMPOTENT{$method};
773 842
774 # default value for keepalive is true iff the request is for an idempotent method 843 # default value for keepalive is true iff the request is for an idempotent method
775 my $keepalive = exists $arg{keepalive} ? !!$arg{keepalive} : $idempotent; 844 my $persistent = exists $arg{persistent} ? !!$arg{persistent} : $idempotent;
776 my $keepalive10 = exists $arg{keepalive10} ? $arg{keepalive10} : !$proxy; 845 my $keepalive = exists $arg{keepalive} ? !!$arg{keepalive} : !$proxy;
777 my $keptalive; # true if this is actually a recycled connection 846 my $was_persistent; # true if this is actually a recycled connection
778 847
779 # the key to use in the keepalive cache 848 # the key to use in the keepalive cache
780 my $ka_key = "$uhost\x00$arg{sessionid}"; 849 my $ka_key = "$uscheme\x00$uhost\x00$uport\x00$arg{sessionid}";
781 850
782 $hdr{connection} = ($keepalive ? $keepalive10 ? "keep-alive " : "" : "close ") . "Te"; #1.1 851 $hdr{connection} = ($persistent ? $keepalive ? "keep-alive, " : "" : "close, ") . "Te"; #1.1
783 $hdr{te} = "trailers" unless exists $hdr{te}; #1.1 852 $hdr{te} = "trailers" unless exists $hdr{te}; #1.1
784 853
785 my %state = (connect_guard => 1); 854 my %state = (connect_guard => 1);
786 855
787 my $ae_error = 595; # connecting 856 my $ae_error = 595; # connecting
797 # send request 866 # send request
798 $hdl->push_write ( 867 $hdl->push_write (
799 "$method $rpath HTTP/1.1\015\012" 868 "$method $rpath HTTP/1.1\015\012"
800 . (join "", map "\u$_: $hdr{$_}\015\012", grep defined $hdr{$_}, keys %hdr) 869 . (join "", map "\u$_: $hdr{$_}\015\012", grep defined $hdr{$_}, keys %hdr)
801 . "\015\012" 870 . "\015\012"
802 . (delete $arg{body}) 871 . $arg{body}
803 ); 872 );
804 873
805 # return if error occured during push_write() 874 # return if error occurred during push_write()
806 return unless %state; 875 return unless %state;
807 876
808 # reduce memory usage, save a kitten, also re-use it for the response headers. 877 # reduce memory usage, save a kitten, also re-use it for the response headers.
809 %hdr = (); 878 %hdr = ();
810 879
837 906
838 %hdr = (%$hdr, @pseudo); 907 %hdr = (%$hdr, @pseudo);
839 } 908 }
840 909
841 # redirect handling 910 # redirect handling
842 # microsoft and other shitheads don't give a shit for following standards, 911 # relative uri handling forced by microsoft and other shitheads.
843 # try to support some common forms of broken Location headers. 912 # we give our best and fall back to URI if available.
844 if ($hdr{location} !~ /^(?: $ | [^:\/?\#]+ : )/x) { 913 if (exists $hdr{location}) {
914 my $loc = $hdr{location};
915
916 if ($loc =~ m%^//%) { # //
917 $loc = "$uscheme:$loc";
918
919 } elsif ($loc eq "") {
920 $loc = $url;
921
922 } elsif ($loc !~ /^(?: $ | [^:\/?\#]+ : )/x) { # anything "simple"
845 $hdr{location} =~ s/^\.\/+//; 923 $loc =~ s/^\.\/+//;
846 924
847 my $url = "$rscheme://$uhost:$uport"; 925 if ($loc !~ m%^[.?#]%) {
926 my $prefix = "$uscheme://$uauthority";
848 927
849 unless ($hdr{location} =~ s/^\///) { 928 unless ($loc =~ s/^\///) {
850 $url .= $upath; 929 $prefix .= $upath;
851 $url =~ s/\/[^\/]*$//; 930 $prefix =~ s/\/[^\/]*$//;
931 }
932
933 $loc = "$prefix/$loc";
934
935 } elsif (eval { require URI }) { # uri
936 $loc = URI->new_abs ($loc, $url)->as_string;
937
938 } else {
939 return _error %state, $cb, { @pseudo, Status => 599, Reason => "Cannot parse Location (URI module missing)" };
940 #$hdr{Status} = 599;
941 #$hdr{Reason} = "Unparsable Redirect (URI module missing)";
942 #$recurse = 0;
943 }
852 } 944 }
853 945
854 $hdr{location} = "$url/$hdr{location}"; 946 $hdr{location} = $loc;
855 } 947 }
856 948
857 my $redirect; 949 my $redirect;
858 950
859 if ($recurse) { 951 if ($recurse) {
861 953
862 # industry standard is to redirect POST as GET for 954 # industry standard is to redirect POST as GET for
863 # 301, 302 and 303, in contrast to HTTP/1.0 and 1.1. 955 # 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, 956 # also, the UA should ask the user for 301 and 307 and POST,
865 # industry standard seems to be to simply follow. 957 # industry standard seems to be to simply follow.
866 # we go with the industry standard. 958 # we go with the industry standard. 308 is defined
959 # by rfc7538
867 if ($status == 301 or $status == 302 or $status == 303) { 960 if ($status == 301 or $status == 302 or $status == 303) {
961 $redirect = 1;
868 # HTTP/1.1 is unclear on how to mutate the method 962 # HTTP/1.1 is unclear on how to mutate the method
869 $method = "GET" unless $method eq "HEAD"; 963 unless ($method eq "HEAD") {
870 $redirect = 1; 964 $method = "GET";
965 delete $arg{body};
966 }
871 } elsif ($status == 307) { 967 } elsif ($status == 307 or $status == 308) {
872 $redirect = 1; 968 $redirect = 1;
873 } 969 }
874 } 970 }
875 971
876 my $finish = sub { # ($data, $err_status, $err_reason[, $keepalive]) 972 my $finish = sub { # ($data, $err_status, $err_reason[, $persistent])
877 if ($state{handle}) { 973 if ($state{handle}) {
878 # handle keepalive 974 # handle keepalive
879 if ( 975 if (
880 $keepalive 976 $persistent
881 && $_[3] 977 && $_[3]
882 && ($hdr{HTTPVersion} < 1.1 978 && ($hdr{HTTPVersion} < 1.1
883 ? $hdr{connection} =~ /\bkeep-?alive\b/i 979 ? $hdr{connection} =~ /\bkeep-?alive\b/i
884 : $hdr{connection} !~ /\bclose\b/i) 980 : $hdr{connection} !~ /\bclose\b/i)
885 ) { 981 ) {
904 1000
905 if ($redirect && exists $hdr{location}) { 1001 if ($redirect && exists $hdr{location}) {
906 # we ignore any errors, as it is very common to receive 1002 # we ignore any errors, as it is very common to receive
907 # Content-Length != 0 but no actual body 1003 # Content-Length != 0 but no actual body
908 # we also access %hdr, as $_[1] might be an erro 1004 # we also access %hdr, as $_[1] might be an erro
1005 $state{recurse} =
909 http_request ( 1006 http_request (
910 $method => $hdr{location}, 1007 $method => $hdr{location},
911 %arg, 1008 %arg,
912 recurse => $recurse - 1, 1009 recurse => $recurse - 1,
913 Redirect => [$_[0], \%hdr], 1010 Redirect => [$_[0], \%hdr],
1011 sub {
1012 %state = ();
914 $cb 1013 &$cb
1014 },
915 ); 1015 );
916 } else { 1016 } else {
917 $cb->($_[0], \%hdr); 1017 $cb->($_[0], \%hdr);
918 } 1018 }
919 }; 1019 };
920 1020
948 $finish->(delete $state{handle}); 1048 $finish->(delete $state{handle});
949 1049
950 } elsif ($chunked) { 1050 } elsif ($chunked) {
951 my $cl = 0; 1051 my $cl = 0;
952 my $body = ""; 1052 my $body = "";
953 my $on_body = $arg{on_body} || sub { $body .= shift; 1 }; 1053 my $on_body = (!$redirect && $arg{on_body}) || sub { $body .= shift; 1 };
954 1054
955 $state{read_chunk} = sub { 1055 $state{read_chunk} = sub {
956 $_[1] =~ /^([0-9a-fA-F]+)/ 1056 $_[1] =~ /^([0-9a-fA-F]+)/
957 or $finish->(undef, $ae_error => "Garbled chunked transfer encoding"); 1057 or return $finish->(undef, $ae_error => "Garbled chunked transfer encoding");
958 1058
959 my $len = hex $1; 1059 my $len = hex $1;
960 1060
961 if ($len) { 1061 if ($len) {
962 $cl += $len; 1062 $cl += $len;
991 } 1091 }
992 }; 1092 };
993 1093
994 $_[0]->push_read (line => $state{read_chunk}); 1094 $_[0]->push_read (line => $state{read_chunk});
995 1095
996 } elsif ($arg{on_body}) { 1096 } elsif (!$redirect && $arg{on_body}) {
997 if (defined $len) { 1097 if (defined $len) {
998 $_[0]->on_read (sub { 1098 $_[0]->on_read (sub {
999 $len -= length $_[0]{rbuf}; 1099 $len -= length $_[0]{rbuf};
1000 1100
1001 $arg{on_body}(delete $_[0]{rbuf}, \%hdr) 1101 $arg{on_body}(delete $_[0]{rbuf}, \%hdr)
1032 } 1132 }
1033 }; 1133 };
1034 1134
1035 # if keepalive is enabled, then the server closing the connection 1135 # if keepalive is enabled, then the server closing the connection
1036 # before a response can happen legally - we retry on idempotent methods. 1136 # before a response can happen legally - we retry on idempotent methods.
1037 if ($keptalive && $idempotent) { 1137 if ($was_persistent && $idempotent) {
1038 my $old_eof = $hdl->{on_eof}; 1138 my $old_eof = $hdl->{on_eof};
1039 $hdl->{on_eof} = sub { 1139 $hdl->{on_eof} = sub {
1040 _destroy_state %state; 1140 _destroy_state %state;
1041 1141
1142 %state = ();
1143 $state{recurse} =
1042 http_request ( 1144 http_request (
1043 $method => $url, 1145 $method => $url,
1044 %arg, 1146 %arg,
1045 keepalive => 0, 1147 recurse => $recurse - 1,
1148 persistent => 0,
1149 sub {
1150 %state = ();
1046 $cb 1151 &$cb
1152 }
1047 ); 1153 );
1048 }; 1154 };
1049 $hdl->on_read (sub { 1155 $hdl->on_read (sub {
1050 return unless %state; 1156 return unless %state;
1051 1157
1052 # as soon as we receive something, a connection close 1158 # as soon as we receive something, a connection close
1060 }; 1166 };
1061 1167
1062 my $prepare_handle = sub { 1168 my $prepare_handle = sub {
1063 my ($hdl) = $state{handle}; 1169 my ($hdl) = $state{handle};
1064 1170
1065 $hdl->timeout ($timeout);
1066 $hdl->on_error (sub { 1171 $hdl->on_error (sub {
1067 _error %state, $cb, { @pseudo, Status => $ae_error, Reason => $_[2] }; 1172 _error %state, $cb, { @pseudo, Status => $ae_error, Reason => $_[2] };
1068 }); 1173 });
1069 $hdl->on_eof (sub { 1174 $hdl->on_eof (sub {
1070 _error %state, $cb, { @pseudo, Status => $ae_error, Reason => "Unexpected end-of-file" }; 1175 _error %state, $cb, { @pseudo, Status => $ae_error, Reason => "Unexpected end-of-file" };
1071 }); 1176 });
1177 $hdl->timeout_reset;
1178 $hdl->timeout ($timeout);
1072 }; 1179 };
1073 1180
1074 # connected to proxy (or origin server) 1181 # connected to proxy (or origin server)
1075 my $connect_cb = sub { 1182 my $connect_cb = sub {
1076 my $fh = shift 1183 my $fh = shift
1092 1199
1093 # now handle proxy-CONNECT method 1200 # now handle proxy-CONNECT method
1094 if ($proxy && $uscheme eq "https") { 1201 if ($proxy && $uscheme eq "https") {
1095 # oh dear, we have to wrap it into a connect request 1202 # oh dear, we have to wrap it into a connect request
1096 1203
1204 my $auth = exists $hdr{"proxy-authorization"}
1205 ? "proxy-authorization: " . (delete $hdr{"proxy-authorization"}) . "\015\012"
1206 : "";
1207
1097 # maybe re-use $uauthority with patched port? 1208 # maybe re-use $uauthority with patched port?
1098 $state{handle}->push_write ("CONNECT $uhost:$uport HTTP/1.0\015\012\015\012"); 1209 $state{handle}->push_write ("CONNECT $uhost:$uport HTTP/1.0\015\012$auth\015\012");
1099 $state{handle}->push_read (line => $qr_nlnl, sub { 1210 $state{handle}->push_read (line => $qr_nlnl, sub {
1100 $_[1] =~ /^HTTP\/([0-9\.]+) \s+ ([0-9]{3}) (?: \s+ ([^\015\012]*) )?/ix 1211 $_[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])" }; 1212 or return _error %state, $cb, { @pseudo, Status => 599, Reason => "Invalid proxy connect response ($_[1])" };
1102 1213
1103 if ($2 == 200) { 1214 if ($2 == 200) {
1106 } else { 1217 } else {
1107 _error %state, $cb, { @pseudo, Status => $2, Reason => $3 }; 1218 _error %state, $cb, { @pseudo, Status => $2, Reason => $3 };
1108 } 1219 }
1109 }); 1220 });
1110 } else { 1221 } else {
1222 delete $hdr{"proxy-authorization"} unless $proxy;
1223
1111 $handle_actual_request->(); 1224 $handle_actual_request->();
1112 } 1225 }
1113 }; 1226 };
1114 1227
1115 _get_slot $uhost, sub { 1228 _get_slot $uhost, sub {
1117 1230
1118 return unless $state{connect_guard}; 1231 return unless $state{connect_guard};
1119 1232
1120 # try to use an existing keepalive connection, but only if we, ourselves, plan 1233 # 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). 1234 # on a keepalive request (in theory, this should be a separate config option).
1122 if ($keepalive && $KA_CACHE{$ka_key}) { 1235 if ($persistent && $KA_CACHE{$ka_key}) {
1123 $keptalive = 1; 1236 $was_persistent = 1;
1237
1124 $state{handle} = ka_fetch $ka_key; 1238 $state{handle} = ka_fetch $ka_key;
1239# $state{handle}->destroyed
1240# and die "AnyEvent::HTTP: unexpectedly got a destructed handle (1), please report.";#d#
1125 $prepare_handle->(); 1241 $prepare_handle->();
1242# $state{handle}->destroyed
1243# and die "AnyEvent::HTTP: unexpectedly got a destructed handle (2), please report.";#d#
1244 $rpath = $upath;
1126 $handle_actual_request->(); 1245 $handle_actual_request->();
1127 1246
1128 } else { 1247 } else {
1129 my $tcp_connect = $arg{tcp_connect} 1248 my $tcp_connect = $arg{tcp_connect}
1130 || do { require AnyEvent::Socket; \&AnyEvent::Socket::tcp_connect }; 1249 || do { require AnyEvent::Socket; \&AnyEvent::Socket::tcp_connect };
1172Sets the default proxy server to use. The proxy-url must begin with a 1291Sets the default proxy server to use. The proxy-url must begin with a
1173string of the form C<http://host:port>, croaks otherwise. 1292string of the form C<http://host:port>, croaks otherwise.
1174 1293
1175To clear an already-set proxy, use C<undef>. 1294To clear an already-set proxy, use C<undef>.
1176 1295
1296When AnyEvent::HTTP is loaded for the first time it will query the
1297default proxy from the operating system, currently by looking at
1298C<$ENV{http_proxy>}.
1299
1177=item AnyEvent::HTTP::cookie_jar_expire $jar[, $session_end] 1300=item AnyEvent::HTTP::cookie_jar_expire $jar[, $session_end]
1178 1301
1179Remove all cookies from the cookie jar that have been expired. If 1302Remove all cookies from the cookie jar that have been expired. If
1180C<$session_end> is given and true, then additionally remove all session 1303C<$session_end> is given and true, then additionally remove all session
1181cookies. 1304cookies.
1182 1305
1183You should call this function (with a true C<$session_end>) before you 1306You 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 1307save 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 1308again. If you have a long-running program you can additionally call this
1186function from time to time. 1309function from time to time.
1187 1310
1188A cookie jar is initially an empty hash-reference that is managed by this 1311A 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: 1312module. Its format is subject to change, but currently it is as follows:
1190 1313
1191The key C<version> has to contain C<1>, otherwise the hash gets 1314The key C<version> has to contain C<2>, otherwise the hash gets
1192emptied. All other keys are hostnames or IP addresses pointing to 1315cleared. All other keys are hostnames or IP addresses pointing to
1193hash-references. The key for these inner hash references is the 1316hash-references. The key for these inner hash references is the
1194server path for which this cookie is meant, and the values are again 1317server 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 1318hash-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 1319the 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>, 1320key-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 1321which have been replaced by a C<_expires> key that contains the cookie
1199expiry timestamp. 1322expiry timestamp. Session cookies are indicated by not having an
1323C<_expires> key.
1200 1324
1201Here is an example of a cookie jar with a single cookie, so you have a 1325Here is an example of a cookie jar with a single cookie, so you have a
1202chance of understanding the above paragraph: 1326chance of understanding the above paragraph:
1203 1327
1204 { 1328 {
1205 version => 1, 1329 version => 2,
1206 "10.0.0.1" => { 1330 "10.0.0.1" => {
1207 "/" => { 1331 "/" => {
1208 "mythweb_id" => { 1332 "mythweb_id" => {
1209 _expires => 1293917923, 1333 _expires => 1293917923,
1210 value => "ooRung9dThee3ooyXooM1Ohm", 1334 value => "ooRung9dThee3ooyXooM1Ohm",
1228 1352
1229The default value for the C<recurse> request parameter (default: C<10>). 1353The default value for the C<recurse> request parameter (default: C<10>).
1230 1354
1231=item $AnyEvent::HTTP::TIMEOUT 1355=item $AnyEvent::HTTP::TIMEOUT
1232 1356
1233The default timeout for conenction operations (default: C<300>). 1357The default timeout for connection operations (default: C<300>).
1234 1358
1235=item $AnyEvent::HTTP::USERAGENT 1359=item $AnyEvent::HTTP::USERAGENT
1236 1360
1237The default value for the C<User-Agent> header (the default is 1361The 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)>). 1362C<Mozilla/5.0 (compatible; U; AnyEvent-HTTP/$VERSION; +http://software.schmorp.de/pkg/AnyEvent)>).
1239 1363
1240=item $AnyEvent::HTTP::MAX_PER_HOST 1364=item $AnyEvent::HTTP::MAX_PER_HOST
1241 1365
1242The maximum number of concurrent connections to the same host (identified 1366The maximum number of concurrent connections to the same host (identified
1243by the hostname). If the limit is exceeded, then the additional requests 1367by the hostname). If the limit is exceeded, then additional requests
1244are queued until previous connections are closed. Both persistent and 1368are queued until previous connections are closed. Both persistent and
1245non-persistent connections are counted in this limit. 1369non-persistent connections are counted in this limit.
1246 1370
1247The default value for this is C<4>, and it is highly advisable to not 1371The default value for this is C<4>, and it is highly advisable to not
1248increase it much. 1372increase it much.
1249 1373
1250For comparison: the RFC's recommend 4 non-persistent or 2 persistent 1374For comparison: the RFC's recommend 4 non-persistent or 2 persistent
1251connections, older browsers used 2, newers (such as firefox 3) typically 1375connections, older browsers used 2, newer ones (such as firefox 3)
1252use 6, and Opera uses 8 because like, they have the fastest browser and 1376typically use 6, and Opera uses 8 because like, they have the fastest
1253give a shit for everybody else on the planet. 1377browser and give a shit for everybody else on the planet.
1254 1378
1255=item $AnyEvent::HTTP::PERSISTENT_TIMEOUT 1379=item $AnyEvent::HTTP::PERSISTENT_TIMEOUT
1256 1380
1257The time after which idle persistent conenctions get closed by 1381The time after which idle persistent connections get closed by
1258AnyEvent::HTTP (default: C<3>). 1382AnyEvent::HTTP (default: C<3>).
1259 1383
1260=item $AnyEvent::HTTP::ACTIVE 1384=item $AnyEvent::HTTP::ACTIVE
1261 1385
1262The number of active connections. This is not the number of currently 1386The number of active connections. This is not the number of currently
1303 # other formats fail in the loop below 1427 # other formats fail in the loop below
1304 1428
1305 for (0..11) { 1429 for (0..11) {
1306 if ($m eq $month[$_]) { 1430 if ($m eq $month[$_]) {
1307 require Time::Local; 1431 require Time::Local;
1308 return Time::Local::timegm ($S, $M, $H, $d, $_, $y); 1432 return eval { Time::Local::timegm ($S, $M, $H, $d, $_, $y) };
1309 } 1433 }
1310 } 1434 }
1311 1435
1312 undef 1436 undef
1313} 1437}
1327 set_proxy $ENV{http_proxy}; 1451 set_proxy $ENV{http_proxy};
1328}; 1452};
1329 1453
1330=head2 SHOWCASE 1454=head2 SHOWCASE
1331 1455
1332This section contaisn some more elaborate "real-world" examples or code 1456This section contains some more elaborate "real-world" examples or code
1333snippets. 1457snippets.
1334 1458
1335=head2 HTTP/1.1 FILE DOWNLOAD 1459=head2 HTTP/1.1 FILE DOWNLOAD
1336 1460
1337Downloading files with HTTP can be quite tricky, especially when something 1461Downloading files with HTTP can be quite tricky, especially when something
1341last modified time to check for file content changes, and works with many 1465last 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 1466HTTP/1.0 servers as well, and usually falls back to a complete re-download
1343on older servers. 1467on older servers.
1344 1468
1345It calls the completion callback with either C<undef>, which means a 1469It calls the completion callback with either C<undef>, which means a
1346nonretryable error occured, C<0> when the download was partial and should 1470nonretryable error occurred, C<0> when the download was partial and should
1347be retried, and C<1> if it was successful. 1471be retried, and C<1> if it was successful.
1348 1472
1349 use AnyEvent::HTTP; 1473 use AnyEvent::HTTP;
1350 1474
1351 sub download($$$) { 1475 sub download($$$) {
1355 or die "$file: $!"; 1479 or die "$file: $!";
1356 1480
1357 my %hdr; 1481 my %hdr;
1358 my $ofs = 0; 1482 my $ofs = 0;
1359 1483
1360 warn stat $fh;
1361 warn -s _;
1362 if (stat $fh and -s _) { 1484 if (stat $fh and -s _) {
1363 $ofs = -s _; 1485 $ofs = -s _;
1364 warn "-s is ", $ofs;#d# 1486 warn "-s is ", $ofs;
1365 $hdr{"if-unmodified-since"} = AnyEvent::HTTP::format_date +(stat _)[9]; 1487 $hdr{"if-unmodified-since"} = AnyEvent::HTTP::format_date +(stat _)[9];
1366 $hdr{"range"} = "bytes=$ofs-"; 1488 $hdr{"range"} = "bytes=$ofs-";
1367 } 1489 }
1368 1490
1369 http_get $url, 1491 http_get $url,
1394 my (undef, $hdr) = @_; 1516 my (undef, $hdr) = @_;
1395 1517
1396 my $status = $hdr->{Status}; 1518 my $status = $hdr->{Status};
1397 1519
1398 if (my $time = AnyEvent::HTTP::parse_date $hdr->{"last-modified"}) { 1520 if (my $time = AnyEvent::HTTP::parse_date $hdr->{"last-modified"}) {
1399 utime $fh, $time, $time; 1521 utime $time, $time, $fh;
1400 } 1522 }
1401 1523
1402 if ($status == 200 || $status == 206 || $status == 416) { 1524 if ($status == 200 || $status == 206 || $status == 416) {
1403 # download ok || resume ok || file already fully downloaded 1525 # download ok || resume ok || file already fully downloaded
1404 $cb->(1, $hdr); 1526 $cb->(1, $hdr);

Diff Legend

Removed lines
+ Added lines
< Changed lines
> Changed lines