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

Diff Legend

– Removed lines
+ Added lines
< Changed lines
> Changed lines