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.97 by root, Tue Jan 18 17:50:20 2011 UTC vs.
Revision 1.139 by root, Fri Aug 5 20:48:14 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 PRI => 1,
744 PROPFIND => 1,
745 PROPPATCH => 1,
746 REBIND => 1,
747 REPORT => 1,
748 SEARCH => 1,
749 UNBIND => 1,
750 UNCHECKOUT => 1,
751 UNLINK => 1,
752 UNLOCK => 1,
753 UPDATE => 1,
754 UPDATEREDIRECTREF => 1,
755 "VERSION-CONTROL" => 1,
756);
757
688sub http_request($$@) { 758sub http_request($$@) {
689 my $cb = pop; 759 my $cb = pop;
690 my ($method, $url, %arg) = @_; 760 my ($method, $url, %arg) = @_;
691 761
692 my %hdr; 762 my %hdr;
709 my $recurse = exists $arg{recurse} ? delete $arg{recurse} : $MAX_RECURSE; 779 my $recurse = exists $arg{recurse} ? delete $arg{recurse} : $MAX_RECURSE;
710 780
711 return $cb->(undef, { @pseudo, Status => 599, Reason => "Too many redirections" }) 781 return $cb->(undef, { @pseudo, Status => 599, Reason => "Too many redirections" })
712 if $recurse < 0; 782 if $recurse < 0;
713 783
714 my $proxy = $arg{proxy} || $PROXY; 784 my $proxy = exists $arg{proxy} ? $arg{proxy} : $PROXY;
715 my $timeout = $arg{timeout} || $TIMEOUT; 785 my $timeout = $arg{timeout} || $TIMEOUT;
716 786
717 my ($uscheme, $uauthority, $upath, $query, undef) = # ignore fragment 787 my ($uscheme, $uauthority, $upath, $query, undef) = # ignore fragment
718 $url =~ m|(?:([^:/?#]+):)?(?://([^/?#]*))?([^?#]*)(?:(\?[^#]*))?(?:#(.*))?|; 788 $url =~ m|^([^:]+):(?://([^/?#]*))?([^?#]*)(?:(\?[^#]*))?(?:#(.*))?$|;
719 789
720 $uscheme = lc $uscheme; 790 $uscheme = lc $uscheme;
721 791
722 my $uport = $uscheme eq "http" ? 80 792 my $uport = $uscheme eq "http" ? 80
723 : $uscheme eq "https" ? 443 793 : $uscheme eq "https" ? 443
724 : return $cb->(undef, { @pseudo, Status => 599, Reason => "Only http and https URL schemes supported" }); 794 : return $cb->(undef, { @pseudo, Status => 599, Reason => "Only http and https URL schemes supported" });
725 795
726 $uauthority =~ /^(?: .*\@ )? ([^\@:]+) (?: : (\d+) )?$/x 796 $uauthority =~ /^(?: .*\@ )? ([^\@]+?) (?: : (\d+) )?$/x
727 or return $cb->(undef, { @pseudo, Status => 599, Reason => "Unparsable URL" }); 797 or return $cb->(undef, { @pseudo, Status => 599, Reason => "Unparsable URL" });
728 798
729 my $uhost = lc $1; 799 my $uhost = lc $1;
730 $uport = $2 if defined $2; 800 $uport = $2 if defined $2;
731 801
767 $hdr{"user-agent"} = $USERAGENT unless exists $hdr{"user-agent"}; 837 $hdr{"user-agent"} = $USERAGENT unless exists $hdr{"user-agent"};
768 838
769 $hdr{"content-length"} = length $arg{body} 839 $hdr{"content-length"} = length $arg{body}
770 if length $arg{body} || $method ne "GET"; 840 if length $arg{body} || $method ne "GET";
771 841
772 my $idempotent = $method =~ /^(?:GET|HEAD|PUT|DELETE|OPTIONS|TRACE)$/; 842 my $idempotent = $IDEMPOTENT{$method};
773 843
774 # default value for keepalive is true iff the request is for an idempotent method 844 # default value for keepalive is true iff the request is for an idempotent method
775 my $keepalive = exists $arg{keepalive} ? !!$arg{keepalive} : $idempotent; 845 my $persistent = exists $arg{persistent} ? !!$arg{persistent} : $idempotent;
776 my $keepalive10 = exists $arg{keepalive10} ? $arg{keepalive10} : !$proxy; 846 my $keepalive = exists $arg{keepalive} ? !!$arg{keepalive} : !$proxy;
777 my $keptalive; # true if this is actually a recycled connection 847 my $was_persistent; # true if this is actually a recycled connection
778 848
779 # the key to use in the keepalive cache 849 # the key to use in the keepalive cache
780 my $ka_key = "$uhost\x00$arg{sessionid}"; 850 my $ka_key = "$uscheme\x00$uhost\x00$uport\x00$arg{sessionid}";
781 851
782 $hdr{connection} = ($keepalive ? $keepalive10 ? "keep-alive " : "" : "close ") . "Te"; #1.1 852 $hdr{connection} = ($persistent ? $keepalive ? "keep-alive, " : "" : "close, ") . "Te"; #1.1
783 $hdr{te} = "trailers" unless exists $hdr{te}; #1.1 853 $hdr{te} = "trailers" unless exists $hdr{te}; #1.1
784 854
785 my %state = (connect_guard => 1); 855 my %state = (connect_guard => 1);
786 856
787 my $ae_error = 595; # connecting 857 my $ae_error = 595; # connecting
797 # send request 867 # send request
798 $hdl->push_write ( 868 $hdl->push_write (
799 "$method $rpath HTTP/1.1\015\012" 869 "$method $rpath HTTP/1.1\015\012"
800 . (join "", map "\u$_: $hdr{$_}\015\012", grep defined $hdr{$_}, keys %hdr) 870 . (join "", map "\u$_: $hdr{$_}\015\012", grep defined $hdr{$_}, keys %hdr)
801 . "\015\012" 871 . "\015\012"
802 . (delete $arg{body}) 872 . $arg{body}
803 ); 873 );
804 874
805 # return if error occured during push_write() 875 # return if error occurred during push_write()
806 return unless %state; 876 return unless %state;
807 877
808 # reduce memory usage, save a kitten, also re-use it for the response headers. 878 # reduce memory usage, save a kitten, also re-use it for the response headers.
809 %hdr = (); 879 %hdr = ();
810 880
837 907
838 %hdr = (%$hdr, @pseudo); 908 %hdr = (%$hdr, @pseudo);
839 } 909 }
840 910
841 # redirect handling 911 # redirect handling
842 # microsoft and other shitheads don't give a shit for following standards, 912 # relative uri handling forced by microsoft and other shitheads.
843 # try to support some common forms of broken Location headers. 913 # we give our best and fall back to URI if available.
844 if ($hdr{location} !~ /^(?: $ | [^:\/?\#]+ : )/x) { 914 if (exists $hdr{location}) {
915 my $loc = $hdr{location};
916
917 if ($loc =~ m%^//%) { # //
918 $loc = "$uscheme:$loc";
919
920 } elsif ($loc eq "") {
921 $loc = $url;
922
923 } elsif ($loc !~ /^(?: $ | [^:\/?\#]+ : )/x) { # anything "simple"
845 $hdr{location} =~ s/^\.\/+//; 924 $loc =~ s/^\.\/+//;
846 925
847 my $url = "$rscheme://$uhost:$uport"; 926 if ($loc !~ m%^[.?#]%) {
927 my $prefix = "$uscheme://$uauthority";
848 928
849 unless ($hdr{location} =~ s/^\///) { 929 unless ($loc =~ s/^\///) {
850 $url .= $upath; 930 $prefix .= $upath;
851 $url =~ s/\/[^\/]*$//; 931 $prefix =~ s/\/[^\/]*$//;
932 }
933
934 $loc = "$prefix/$loc";
935
936 } elsif (eval { require URI }) { # uri
937 $loc = URI->new_abs ($loc, $url)->as_string;
938
939 } else {
940 return _error %state, $cb, { @pseudo, Status => 599, Reason => "Cannot parse Location (URI module missing)" };
941 #$hdr{Status} = 599;
942 #$hdr{Reason} = "Unparsable Redirect (URI module missing)";
943 #$recurse = 0;
944 }
852 } 945 }
853 946
854 $hdr{location} = "$url/$hdr{location}"; 947 $hdr{location} = $loc;
855 } 948 }
856 949
857 my $redirect; 950 my $redirect;
858 951
859 if ($recurse) { 952 if ($recurse) {
861 954
862 # industry standard is to redirect POST as GET for 955 # industry standard is to redirect POST as GET for
863 # 301, 302 and 303, in contrast to HTTP/1.0 and 1.1. 956 # 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, 957 # also, the UA should ask the user for 301 and 307 and POST,
865 # industry standard seems to be to simply follow. 958 # industry standard seems to be to simply follow.
866 # we go with the industry standard. 959 # we go with the industry standard. 308 is defined
960 # by rfc7538
867 if ($status == 301 or $status == 302 or $status == 303) { 961 if ($status == 301 or $status == 302 or $status == 303) {
962 $redirect = 1;
868 # HTTP/1.1 is unclear on how to mutate the method 963 # HTTP/1.1 is unclear on how to mutate the method
869 $method = "GET" unless $method eq "HEAD"; 964 unless ($method eq "HEAD") {
870 $redirect = 1; 965 $method = "GET";
966 delete $arg{body};
967 }
871 } elsif ($status == 307) { 968 } elsif ($status == 307 or $status == 308) {
872 $redirect = 1; 969 $redirect = 1;
873 } 970 }
874 } 971 }
875 972
876 my $finish = sub { # ($data, $err_status, $err_reason[, $keepalive]) 973 my $finish = sub { # ($data, $err_status, $err_reason[, $persistent])
877 if ($state{handle}) { 974 if ($state{handle}) {
878 # handle keepalive 975 # handle keepalive
879 if ( 976 if (
880 $keepalive 977 $persistent
881 && $_[3] 978 && $_[3]
882 && ($hdr{HTTPVersion} < 1.1 979 && ($hdr{HTTPVersion} < 1.1
883 ? $hdr{connection} =~ /\bkeep-?alive\b/i 980 ? $hdr{connection} =~ /\bkeep-?alive\b/i
884 : $hdr{connection} !~ /\bclose\b/i) 981 : $hdr{connection} !~ /\bclose\b/i)
885 ) { 982 ) {
904 1001
905 if ($redirect && exists $hdr{location}) { 1002 if ($redirect && exists $hdr{location}) {
906 # we ignore any errors, as it is very common to receive 1003 # we ignore any errors, as it is very common to receive
907 # Content-Length != 0 but no actual body 1004 # Content-Length != 0 but no actual body
908 # we also access %hdr, as $_[1] might be an erro 1005 # we also access %hdr, as $_[1] might be an erro
1006 $state{recurse} =
909 http_request ( 1007 http_request (
910 $method => $hdr{location}, 1008 $method => $hdr{location},
911 %arg, 1009 %arg,
912 recurse => $recurse - 1, 1010 recurse => $recurse - 1,
913 Redirect => [$_[0], \%hdr], 1011 Redirect => [$_[0], \%hdr],
1012 sub {
1013 %state = ();
914 $cb 1014 &$cb
1015 },
915 ); 1016 );
916 } else { 1017 } else {
917 $cb->($_[0], \%hdr); 1018 $cb->($_[0], \%hdr);
918 } 1019 }
919 }; 1020 };
920 1021
948 $finish->(delete $state{handle}); 1049 $finish->(delete $state{handle});
949 1050
950 } elsif ($chunked) { 1051 } elsif ($chunked) {
951 my $cl = 0; 1052 my $cl = 0;
952 my $body = ""; 1053 my $body = "";
953 my $on_body = $arg{on_body} || sub { $body .= shift; 1 }; 1054 my $on_body = (!$redirect && $arg{on_body}) || sub { $body .= shift; 1 };
954 1055
955 $state{read_chunk} = sub { 1056 $state{read_chunk} = sub {
956 $_[1] =~ /^([0-9a-fA-F]+)/ 1057 $_[1] =~ /^([0-9a-fA-F]+)/
957 or $finish->(undef, $ae_error => "Garbled chunked transfer encoding"); 1058 or return $finish->(undef, $ae_error => "Garbled chunked transfer encoding");
958 1059
959 my $len = hex $1; 1060 my $len = hex $1;
960 1061
961 if ($len) { 1062 if ($len) {
962 $cl += $len; 1063 $cl += $len;
991 } 1092 }
992 }; 1093 };
993 1094
994 $_[0]->push_read (line => $state{read_chunk}); 1095 $_[0]->push_read (line => $state{read_chunk});
995 1096
996 } elsif ($arg{on_body}) { 1097 } elsif (!$redirect && $arg{on_body}) {
997 if (defined $len) { 1098 if (defined $len) {
998 $_[0]->on_read (sub { 1099 $_[0]->on_read (sub {
999 $len -= length $_[0]{rbuf}; 1100 $len -= length $_[0]{rbuf};
1000 1101
1001 $arg{on_body}(delete $_[0]{rbuf}, \%hdr) 1102 $arg{on_body}(delete $_[0]{rbuf}, \%hdr)
1032 } 1133 }
1033 }; 1134 };
1034 1135
1035 # if keepalive is enabled, then the server closing the connection 1136 # if keepalive is enabled, then the server closing the connection
1036 # before a response can happen legally - we retry on idempotent methods. 1137 # before a response can happen legally - we retry on idempotent methods.
1037 if ($keptalive && $idempotent) { 1138 if ($was_persistent && $idempotent) {
1038 my $old_eof = $hdl->{on_eof}; 1139 my $old_eof = $hdl->{on_eof};
1039 $hdl->{on_eof} = sub { 1140 $hdl->{on_eof} = sub {
1040 _destroy_state %state; 1141 _destroy_state %state;
1041 1142
1143 %state = ();
1144 $state{recurse} =
1042 http_request ( 1145 http_request (
1043 $method => $url, 1146 $method => $url,
1044 %arg, 1147 %arg,
1045 keepalive => 0, 1148 recurse => $recurse - 1,
1149 persistent => 0,
1150 sub {
1151 %state = ();
1046 $cb 1152 &$cb
1153 }
1047 ); 1154 );
1048 }; 1155 };
1049 $hdl->on_read (sub { 1156 $hdl->on_read (sub {
1050 return unless %state; 1157 return unless %state;
1051 1158
1052 # as soon as we receive something, a connection close 1159 # as soon as we receive something, a connection close
1060 }; 1167 };
1061 1168
1062 my $prepare_handle = sub { 1169 my $prepare_handle = sub {
1063 my ($hdl) = $state{handle}; 1170 my ($hdl) = $state{handle};
1064 1171
1065 $hdl->timeout ($timeout);
1066 $hdl->on_error (sub { 1172 $hdl->on_error (sub {
1067 _error %state, $cb, { @pseudo, Status => $ae_error, Reason => $_[2] }; 1173 _error %state, $cb, { @pseudo, Status => $ae_error, Reason => $_[2] };
1068 }); 1174 });
1069 $hdl->on_eof (sub { 1175 $hdl->on_eof (sub {
1070 _error %state, $cb, { @pseudo, Status => $ae_error, Reason => "Unexpected end-of-file" }; 1176 _error %state, $cb, { @pseudo, Status => $ae_error, Reason => "Unexpected end-of-file" };
1071 }); 1177 });
1178 $hdl->timeout_reset;
1179 $hdl->timeout ($timeout);
1072 }; 1180 };
1073 1181
1074 # connected to proxy (or origin server) 1182 # connected to proxy (or origin server)
1075 my $connect_cb = sub { 1183 my $connect_cb = sub {
1076 my $fh = shift 1184 my $fh = shift
1092 1200
1093 # now handle proxy-CONNECT method 1201 # now handle proxy-CONNECT method
1094 if ($proxy && $uscheme eq "https") { 1202 if ($proxy && $uscheme eq "https") {
1095 # oh dear, we have to wrap it into a connect request 1203 # oh dear, we have to wrap it into a connect request
1096 1204
1205 my $auth = exists $hdr{"proxy-authorization"}
1206 ? "proxy-authorization: " . (delete $hdr{"proxy-authorization"}) . "\015\012"
1207 : "";
1208
1097 # maybe re-use $uauthority with patched port? 1209 # maybe re-use $uauthority with patched port?
1098 $state{handle}->push_write ("CONNECT $uhost:$uport HTTP/1.0\015\012\015\012"); 1210 $state{handle}->push_write ("CONNECT $uhost:$uport HTTP/1.0\015\012$auth\015\012");
1099 $state{handle}->push_read (line => $qr_nlnl, sub { 1211 $state{handle}->push_read (line => $qr_nlnl, sub {
1100 $_[1] =~ /^HTTP\/([0-9\.]+) \s+ ([0-9]{3}) (?: \s+ ([^\015\012]*) )?/ix 1212 $_[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])" }; 1213 or return _error %state, $cb, { @pseudo, Status => 599, Reason => "Invalid proxy connect response ($_[1])" };
1102 1214
1103 if ($2 == 200) { 1215 if ($2 == 200) {
1106 } else { 1218 } else {
1107 _error %state, $cb, { @pseudo, Status => $2, Reason => $3 }; 1219 _error %state, $cb, { @pseudo, Status => $2, Reason => $3 };
1108 } 1220 }
1109 }); 1221 });
1110 } else { 1222 } else {
1223 delete $hdr{"proxy-authorization"} unless $proxy;
1224
1111 $handle_actual_request->(); 1225 $handle_actual_request->();
1112 } 1226 }
1113 }; 1227 };
1114 1228
1115 _get_slot $uhost, sub { 1229 _get_slot $uhost, sub {
1117 1231
1118 return unless $state{connect_guard}; 1232 return unless $state{connect_guard};
1119 1233
1120 # try to use an existing keepalive connection, but only if we, ourselves, plan 1234 # 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). 1235 # on a keepalive request (in theory, this should be a separate config option).
1122 if ($keepalive && $KA_CACHE{$ka_key}) { 1236 if ($persistent && $KA_CACHE{$ka_key}) {
1123 $keptalive = 1; 1237 $was_persistent = 1;
1238
1124 $state{handle} = ka_fetch $ka_key; 1239 $state{handle} = ka_fetch $ka_key;
1240# $state{handle}->destroyed
1241# and die "AnyEvent::HTTP: unexpectedly got a destructed handle (1), please report.";#d#
1125 $prepare_handle->(); 1242 $prepare_handle->();
1243# $state{handle}->destroyed
1244# and die "AnyEvent::HTTP: unexpectedly got a destructed handle (2), please report.";#d#
1245 $rpath = $upath;
1126 $handle_actual_request->(); 1246 $handle_actual_request->();
1127 1247
1128 } else { 1248 } else {
1129 my $tcp_connect = $arg{tcp_connect} 1249 my $tcp_connect = $arg{tcp_connect}
1130 || do { require AnyEvent::Socket; \&AnyEvent::Socket::tcp_connect }; 1250 || do { require AnyEvent::Socket; \&AnyEvent::Socket::tcp_connect };
1172Sets the default proxy server to use. The proxy-url must begin with a 1292Sets the default proxy server to use. The proxy-url must begin with a
1173string of the form C<http://host:port>, croaks otherwise. 1293string of the form C<http://host:port>, croaks otherwise.
1174 1294
1175To clear an already-set proxy, use C<undef>. 1295To clear an already-set proxy, use C<undef>.
1176 1296
1297When AnyEvent::HTTP is loaded for the first time it will query the
1298default proxy from the operating system, currently by looking at
1299C<$ENV{http_proxy>}.
1300
1177=item AnyEvent::HTTP::cookie_jar_expire $jar[, $session_end] 1301=item AnyEvent::HTTP::cookie_jar_expire $jar[, $session_end]
1178 1302
1179Remove all cookies from the cookie jar that have been expired. If 1303Remove all cookies from the cookie jar that have been expired. If
1180C<$session_end> is given and true, then additionally remove all session 1304C<$session_end> is given and true, then additionally remove all session
1181cookies. 1305cookies.
1182 1306
1183You should call this function (with a true C<$session_end>) before you 1307You 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 1308save 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 1309again. If you have a long-running program you can additionally call this
1186function from time to time. 1310function from time to time.
1187 1311
1188A cookie jar is initially an empty hash-reference that is managed by this 1312A 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: 1313module. Its format is subject to change, but currently it is as follows:
1190 1314
1191The key C<version> has to contain C<1>, otherwise the hash gets 1315The key C<version> has to contain C<2>, otherwise the hash gets
1192emptied. All other keys are hostnames or IP addresses pointing to 1316cleared. All other keys are hostnames or IP addresses pointing to
1193hash-references. The key for these inner hash references is the 1317hash-references. The key for these inner hash references is the
1194server path for which this cookie is meant, and the values are again 1318server 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 1319hash-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 1320the 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>, 1321key-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 1322which have been replaced by a C<_expires> key that contains the cookie
1199expiry timestamp. 1323expiry timestamp. Session cookies are indicated by not having an
1324C<_expires> key.
1200 1325
1201Here is an example of a cookie jar with a single cookie, so you have a 1326Here is an example of a cookie jar with a single cookie, so you have a
1202chance of understanding the above paragraph: 1327chance of understanding the above paragraph:
1203 1328
1204 { 1329 {
1205 version => 1, 1330 version => 2,
1206 "10.0.0.1" => { 1331 "10.0.0.1" => {
1207 "/" => { 1332 "/" => {
1208 "mythweb_id" => { 1333 "mythweb_id" => {
1209 _expires => 1293917923, 1334 _expires => 1293917923,
1210 value => "ooRung9dThee3ooyXooM1Ohm", 1335 value => "ooRung9dThee3ooyXooM1Ohm",
1228 1353
1229The default value for the C<recurse> request parameter (default: C<10>). 1354The default value for the C<recurse> request parameter (default: C<10>).
1230 1355
1231=item $AnyEvent::HTTP::TIMEOUT 1356=item $AnyEvent::HTTP::TIMEOUT
1232 1357
1233The default timeout for conenction operations (default: C<300>). 1358The default timeout for connection operations (default: C<300>).
1234 1359
1235=item $AnyEvent::HTTP::USERAGENT 1360=item $AnyEvent::HTTP::USERAGENT
1236 1361
1237The default value for the C<User-Agent> header (the default is 1362The 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)>). 1363C<Mozilla/5.0 (compatible; U; AnyEvent-HTTP/$VERSION; +http://software.schmorp.de/pkg/AnyEvent)>).
1239 1364
1240=item $AnyEvent::HTTP::MAX_PER_HOST 1365=item $AnyEvent::HTTP::MAX_PER_HOST
1241 1366
1242The maximum number of concurrent connections to the same host (identified 1367The maximum number of concurrent connections to the same host (identified
1243by the hostname). If the limit is exceeded, then the additional requests 1368by the hostname). If the limit is exceeded, then additional requests
1244are queued until previous connections are closed. Both persistent and 1369are queued until previous connections are closed. Both persistent and
1245non-persistent connections are counted in this limit. 1370non-persistent connections are counted in this limit.
1246 1371
1247The default value for this is C<4>, and it is highly advisable to not 1372The default value for this is C<4>, and it is highly advisable to not
1248increase it much. 1373increase it much.
1249 1374
1250For comparison: the RFC's recommend 4 non-persistent or 2 persistent 1375For comparison: the RFC's recommend 4 non-persistent or 2 persistent
1251connections, older browsers used 2, newers (such as firefox 3) typically 1376connections, older browsers used 2, newer ones (such as firefox 3)
1252use 6, and Opera uses 8 because like, they have the fastest browser and 1377typically use 6, and Opera uses 8 because like, they have the fastest
1253give a shit for everybody else on the planet. 1378browser and give a shit for everybody else on the planet.
1254 1379
1255=item $AnyEvent::HTTP::PERSISTENT_TIMEOUT 1380=item $AnyEvent::HTTP::PERSISTENT_TIMEOUT
1256 1381
1257The time after which idle persistent conenctions get closed by 1382The time after which idle persistent connections get closed by
1258AnyEvent::HTTP (default: C<3>). 1383AnyEvent::HTTP (default: C<3>).
1259 1384
1260=item $AnyEvent::HTTP::ACTIVE 1385=item $AnyEvent::HTTP::ACTIVE
1261 1386
1262The number of active connections. This is not the number of currently 1387The number of active connections. This is not the number of currently
1303 # other formats fail in the loop below 1428 # other formats fail in the loop below
1304 1429
1305 for (0..11) { 1430 for (0..11) {
1306 if ($m eq $month[$_]) { 1431 if ($m eq $month[$_]) {
1307 require Time::Local; 1432 require Time::Local;
1308 return Time::Local::timegm ($S, $M, $H, $d, $_, $y); 1433 return eval { Time::Local::timegm ($S, $M, $H, $d, $_, $y) };
1309 } 1434 }
1310 } 1435 }
1311 1436
1312 undef 1437 undef
1313} 1438}
1327 set_proxy $ENV{http_proxy}; 1452 set_proxy $ENV{http_proxy};
1328}; 1453};
1329 1454
1330=head2 SHOWCASE 1455=head2 SHOWCASE
1331 1456
1332This section contaisn some more elaborate "real-world" examples or code 1457This section contains some more elaborate "real-world" examples or code
1333snippets. 1458snippets.
1334 1459
1335=head2 HTTP/1.1 FILE DOWNLOAD 1460=head2 HTTP/1.1 FILE DOWNLOAD
1336 1461
1337Downloading files with HTTP can be quite tricky, especially when something 1462Downloading files with HTTP can be quite tricky, especially when something
1338goes wrong and you want tor esume. 1463goes wrong and you want to resume.
1339 1464
1340Here is a function that initiates and resumes a download. It uses the 1465Here 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 1466last 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 1467HTTP/1.0 servers as well, and usually falls back to a complete re-download
1343on older servers. 1468on older servers.
1344 1469
1345It calls the completion callback with either C<undef>, which means a 1470It calls the completion callback with either C<undef>, which means a
1346nonretryable error occured, C<0> when the download was partial and should 1471nonretryable error occurred, C<0> when the download was partial and should
1347be retried, and C<1> if it was successful. 1472be retried, and C<1> if it was successful.
1348 1473
1349 use AnyEvent::HTTP; 1474 use AnyEvent::HTTP;
1350 1475
1351 sub download($$$) { 1476 sub download($$$) {
1355 or die "$file: $!"; 1480 or die "$file: $!";
1356 1481
1357 my %hdr; 1482 my %hdr;
1358 my $ofs = 0; 1483 my $ofs = 0;
1359 1484
1360 warn stat $fh;
1361 warn -s _;
1362 if (stat $fh and -s _) { 1485 if (stat $fh and -s _) {
1363 $ofs = -s _; 1486 $ofs = -s _;
1364 warn "-s is ", $ofs;#d# 1487 warn "-s is ", $ofs;
1365 $hdr{"if-unmodified-since"} = AnyEvent::HTTP::format_date +(stat _)[9]; 1488 $hdr{"if-unmodified-since"} = AnyEvent::HTTP::format_date +(stat _)[9];
1366 $hdr{"range"} = "bytes=$ofs-"; 1489 $hdr{"range"} = "bytes=$ofs-";
1367 } 1490 }
1368 1491
1369 http_get $url, 1492 http_get $url,
1394 my (undef, $hdr) = @_; 1517 my (undef, $hdr) = @_;
1395 1518
1396 my $status = $hdr->{Status}; 1519 my $status = $hdr->{Status};
1397 1520
1398 if (my $time = AnyEvent::HTTP::parse_date $hdr->{"last-modified"}) { 1521 if (my $time = AnyEvent::HTTP::parse_date $hdr->{"last-modified"}) {
1399 utime $fh, $time, $time; 1522 utime $time, $time, $fh;
1400 } 1523 }
1401 1524
1402 if ($status == 200 || $status == 206 || $status == 416) { 1525 if ($status == 200 || $status == 206 || $status == 416) {
1403 # download ok || resume ok || file already fully downloaded 1526 # download ok || resume ok || file already fully downloaded
1404 $cb->(1, $hdr); 1527 $cb->(1, $hdr);

Diff Legend

Removed lines
+ Added lines
< Changed lines
> Changed lines