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.102 by root, Sat Feb 19 06:46:14 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.04'; 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.
… …
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.
188 196
189If not specified, then the default proxy is used (see 197If not specified, then the default proxy is used (see
190C<AnyEvent::HTTP::set_proxy>). 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>.
191 207
192=item body => $string 208=item body => $string
193 209
194The 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
195this module might offer more options). 211this module might offer more options).
… …
228The 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
229me the page, no matter what". 245me the page, no matter what".
230 246
231See also the C<sessionid> parameter. 247See also the C<sessionid> parameter.
232 248
233=item session => $string 249=item sessionid => $string
234 250
235The module might reuse connections to the same host internally. Sometimes 251The module might reuse connections to the same host internally (regardless
236(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
237sessions. This can be achieved by setting this parameter to some unique 254from other sessions. This can be achieved by setting this parameter to
238ID (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
239context) - 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.
240 258
241=item on_prepare => $callback->($fh) 259=item on_prepare => $callback->($fh)
242 260
243In 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
244connect (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
245overrides the prepare callback passed to C<AnyEvent::Socket::tcp_connect> 263overrides the prepare callback passed to C<AnyEvent::Socket::tcp_connect>
246and 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
247timeout). See the description for the C<$prepare_cb> argument of 265timeout). See the description for the C<$prepare_cb> argument of
248C<AnyEvent::Socket::tcp_connect> for details. 266C<AnyEvent::Socket::tcp_connect> for details.
249 267
… …
252In even rarer cases you want total control over how AnyEvent::HTTP 270In even rarer cases you want total control over how AnyEvent::HTTP
253establishes connections. Normally it uses L<AnyEvent::Socket::tcp_connect> 271establishes connections. Normally it uses L<AnyEvent::Socket::tcp_connect>
254to 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 -
255obviously, it has to follow the same calling conventions, except that it 273obviously, it has to follow the same calling conventions, except that it
256may 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.
257 281
258There are probably lots of weird uses for this function, starting from 282There are probably lots of weird uses for this function, starting from
259tracing the hosts C<http_request> actually tries to connect, to (inexact 283tracing the hosts C<http_request> actually tries to connect, to (inexact
260but fast) host => IP address caching or even socks protocol support. 284but fast) host => IP address caching or even socks protocol support.
261 285
… …
331=item persistent => $boolean 355=item persistent => $boolean
332 356
333Try to create/reuse a persistent connection. When this flag is set 357Try to create/reuse a persistent connection. When this flag is set
334(default: true for idempotent requests, false for all others), then 358(default: true for idempotent requests, false for all others), then
335C<http_request> tries to re-use an existing (previously-created) 359C<http_request> tries to re-use an existing (previously-created)
336persistent connection to the host and, failing that, tries to create a new 360persistent connection to same host (i.e. identical URL scheme, hostname,
337one. 361port and sessionid) and, failing that, tries to create a new one.
338 362
339Requests failing in certain ways will be automatically retried once, which 363Requests failing in certain ways will be automatically retried once, which
340is 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
341for 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
342made it impossible to distinguish between a fatal error and a normal 366made it impossible to distinguish between a fatal error and a normal
343connection timeout, so you never know whether there was a problem with 367connection timeout, so you never know whether there was a problem with
344your request or not. 368your request or not.
345 369
346When reusing an existent connection, many parameters (such as TLS context) 370When reusing an existent connection, many parameters (such as TLS context)
347will be ignored. See the C<session> parameter for a workaround. 371will be ignored. See the C<sessionid> parameter for a workaround.
348 372
349=item keepalive => $boolean 373=item keepalive => $boolean
350 374
351Only used when C<persistent> is also true. This parameter decides whether 375Only used when C<persistent> is also true. This parameter decides whether
352C<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
… …
381 405
382Example: 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
383timeout of 30 seconds. 407timeout of 30 seconds.
384 408
385 http_request 409 http_request
386 GET => "https://www.google.com", 410 HEAD => "https://www.google.com",
387 headers => { "user-agent" => "MySearchClient 1.0" }, 411 headers => { "user-agent" => "MySearchClient 1.0" },
388 timeout => 30, 412 timeout => 30,
389 sub { 413 sub {
390 my ($body, $hdr) = @_; 414 my ($body, $hdr) = @_;
391 use Data::Dumper; 415 use Data::Dumper;
… …
443 467
444# expire cookies 468# expire cookies
445sub cookie_jar_expire($;$) { 469sub cookie_jar_expire($;$) {
446 my ($jar, $session_end) = @_; 470 my ($jar, $session_end) = @_;
447 471
448 %$jar = () if $jar->{version} != 1; 472 %$jar = () if $jar->{version} != 2;
449 473
450 my $anow = AE::now; 474 my $anow = AE::now;
451 475
452 while (my ($chost, $paths) = each %$jar) { 476 while (my ($chost, $paths) = each %$jar) {
453 next unless ref $paths; 477 next unless ref $paths;
… …
473 497
474# extract cookies from jar 498# extract cookies from jar
475sub cookie_jar_extract($$$$) { 499sub cookie_jar_extract($$$$) {
476 my ($jar, $scheme, $host, $path) = @_; 500 my ($jar, $scheme, $host, $path) = @_;
477 501
478 %$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]/;
479 506
480 my @cookies; 507 my @cookies;
481 508
482 while (my ($chost, $paths) = each %$jar) { 509 while (my ($chost, $paths) = each %$jar) {
483 next unless ref $paths; 510 next unless ref $paths;
484 511
485 if ($chost =~ /^\./) { 512 # exact match or suffix including . match
486 next unless $chost eq substr $host, -length $chost; 513 $chost eq $host or ".$chost" eq substr $host, -1 - length $chost
487 } elsif ($chost =~ /\./) {
488 next unless $chost eq $host;
489 } else {
490 next; 514 or next;
491 }
492 515
493 while (my ($cpath, $cookies) = each %$paths) { 516 while (my ($cpath, $cookies) = each %$paths) {
494 next unless $cpath eq substr $path, 0, length $cpath; 517 next unless $cpath eq substr $path, 0, length $cpath;
495 518
496 while (my ($cookie, $kv) = each %$cookies) { 519 while (my ($cookie, $kv) = each %$cookies) {
… …
517} 540}
518 541
519# parse set_cookie header into jar 542# parse set_cookie header into jar
520sub cookie_jar_set_cookie($$$$) { 543sub cookie_jar_set_cookie($$$$) {
521 my ($jar, $set_cookie, $host, $date) = @_; 544 my ($jar, $set_cookie, $host, $date) = @_;
545
546 %$jar = () if $jar->{version} != 2;
522 547
523 my $anow = int AE::now; 548 my $anow = int AE::now;
524 my $snow; # server-now 549 my $snow; # server-now
525 550
526 for ($set_cookie) { 551 for ($set_cookie) {
… …
572 597
573 my $cdom; 598 my $cdom;
574 my $cpath = (delete $kv{path}) || "/"; 599 my $cpath = (delete $kv{path}) || "/";
575 600
576 if (exists $kv{domain}) { 601 if (exists $kv{domain}) {
577 $cdom = delete $kv{domain}; 602 $cdom = $kv{domain};
578 603
579 $cdom =~ s/^\.?/./; # make sure it starts with a "." 604 $cdom =~ s/^\.?/./; # make sure it starts with a "."
580 605
581 next if $cdom =~ /\.$/; 606 next if $cdom =~ /\.$/;
582 607
583 # this is not rfc-like and not netscape-like. go figure. 608 # this is not rfc-like and not netscape-like. go figure.
584 my $ndots = $cdom =~ y/.//; 609 my $ndots = $cdom =~ y/.//;
585 next if $ndots < ($cdom =~ /\.[^.][^.]\.[^.][^.]$/ ? 3 : 2); 610 next if $ndots < ($cdom =~ /\.[^.][^.]\.[^.][^.]$/ ? 3 : 2);
611
612 $cdom = substr $cdom, 1; # remove initial .
586 } else { 613 } else {
587 $cdom = $host; 614 $cdom = $host;
588 } 615 }
589 616
590 # store it 617 # store it
591 $jar->{version} = 1; 618 $jar->{version} = 2;
592 $jar->{lc $cdom}{$cpath}{$name} = \%kv; 619 $jar->{lc $cdom}{$cpath}{$name} = \%kv;
593 620
594 redo if /\G\s*,/gc; 621 redo if /\G\s*,/gc;
595 } 622 }
596} 623}
… …
686 713
687 $cb->(undef, $hdr); 714 $cb->(undef, $hdr);
688 () 715 ()
689} 716}
690 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
691sub http_request($$@) { 756sub http_request($$@) {
692 my $cb = pop; 757 my $cb = pop;
693 my ($method, $url, %arg) = @_; 758 my ($method, $url, %arg) = @_;
694 759
695 my %hdr; 760 my %hdr;
… …
724 789
725 my $uport = $uscheme eq "http" ? 80 790 my $uport = $uscheme eq "http" ? 80
726 : $uscheme eq "https" ? 443 791 : $uscheme eq "https" ? 443
727 : 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" });
728 793
729 $uauthority =~ /^(?: .*\@ )? ([^\@:]+) (?: : (\d+) )?$/x 794 $uauthority =~ /^(?: .*\@ )? ([^\@]+?) (?: : (\d+) )?$/x
730 or return $cb->(undef, { @pseudo, Status => 599, Reason => "Unparsable URL" }); 795 or return $cb->(undef, { @pseudo, Status => 599, Reason => "Unparsable URL" });
731 796
732 my $uhost = lc $1; 797 my $uhost = lc $1;
733 $uport = $2 if defined $2; 798 $uport = $2 if defined $2;
734 799
… …
770 $hdr{"user-agent"} = $USERAGENT unless exists $hdr{"user-agent"}; 835 $hdr{"user-agent"} = $USERAGENT unless exists $hdr{"user-agent"};
771 836
772 $hdr{"content-length"} = length $arg{body} 837 $hdr{"content-length"} = length $arg{body}
773 if length $arg{body} || $method ne "GET"; 838 if length $arg{body} || $method ne "GET";
774 839
775 my $idempotent = $method =~ /^(?:GET|HEAD|PUT|DELETE|OPTIONS|TRACE)$/; 840 my $idempotent = $IDEMPOTENT{$method};
776 841
777 # 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
778 my $keepalive = exists $arg{keepalive} ? !!$arg{keepalive} : $idempotent; 843 my $persistent = exists $arg{persistent} ? !!$arg{persistent} : $idempotent;
779 my $keepalive10 = exists $arg{keepalive10} ? $arg{keepalive10} : !$proxy; 844 my $keepalive = exists $arg{keepalive} ? !!$arg{keepalive} : !$proxy;
780 my $keptalive; # true if this is actually a recycled connection 845 my $was_persistent; # true if this is actually a recycled connection
781 846
782 # the key to use in the keepalive cache 847 # the key to use in the keepalive cache
783 my $ka_key = "$uhost\x00$arg{sessionid}"; 848 my $ka_key = "$uscheme\x00$uhost\x00$uport\x00$arg{sessionid}";
784 849
785 $hdr{connection} = ($keepalive ? $keepalive10 ? "keep-alive " : "" : "close ") . "Te"; #1.1 850 $hdr{connection} = ($persistent ? $keepalive ? "keep-alive, " : "" : "close, ") . "Te"; #1.1
786 $hdr{te} = "trailers" unless exists $hdr{te}; #1.1 851 $hdr{te} = "trailers" unless exists $hdr{te}; #1.1
787 852
788 my %state = (connect_guard => 1); 853 my %state = (connect_guard => 1);
789 854
790 my $ae_error = 595; # connecting 855 my $ae_error = 595; # connecting
… …
800 # send request 865 # send request
801 $hdl->push_write ( 866 $hdl->push_write (
802 "$method $rpath HTTP/1.1\015\012" 867 "$method $rpath HTTP/1.1\015\012"
803 . (join "", map "\u$_: $hdr{$_}\015\012", grep defined $hdr{$_}, keys %hdr) 868 . (join "", map "\u$_: $hdr{$_}\015\012", grep defined $hdr{$_}, keys %hdr)
804 . "\015\012" 869 . "\015\012"
805 . (delete $arg{body}) 870 . $arg{body}
806 ); 871 );
807 872
808 # return if error occured during push_write() 873 # return if error occurred during push_write()
809 return unless %state; 874 return unless %state;
810 875
811 # 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.
812 %hdr = (); 877 %hdr = ();
813 878
… …
840 905
841 %hdr = (%$hdr, @pseudo); 906 %hdr = (%$hdr, @pseudo);
842 } 907 }
843 908
844 # redirect handling 909 # redirect handling
845 # microsoft and other shitheads don't give a shit for following standards, 910 # relative uri handling forced by microsoft and other shitheads.
846 # try to support some common forms of broken Location headers. 911 # we give our best and fall back to URI if available.
847 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"
848 $hdr{location} =~ s/^\.\/+//; 922 $loc =~ s/^\.\/+//;
849 923
850 my $url = "$rscheme://$uhost:$uport"; 924 if ($loc !~ m%^[.?#]%) {
925 my $prefix = "$uscheme://$uauthority";
851 926
852 unless ($hdr{location} =~ s/^\///) { 927 unless ($loc =~ s/^\///) {
853 $url .= $upath; 928 $prefix .= $upath;
854 $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 }
855 } 943 }
856 944
857 $hdr{location} = "$url/$hdr{location}"; 945 $hdr{location} = $loc;
858 } 946 }
859 947
860 my $redirect; 948 my $redirect;
861 949
862 if ($recurse) { 950 if ($recurse) {
… …
864 952
865 # industry standard is to redirect POST as GET for 953 # industry standard is to redirect POST as GET for
866 # 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.
867 # 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,
868 # industry standard seems to be to simply follow. 956 # industry standard seems to be to simply follow.
869 # we go with the industry standard. 957 # we go with the industry standard. 308 is defined
958 # by rfc7538
870 if ($status == 301 or $status == 302 or $status == 303) { 959 if ($status == 301 or $status == 302 or $status == 303) {
960 $redirect = 1;
871 # HTTP/1.1 is unclear on how to mutate the method 961 # HTTP/1.1 is unclear on how to mutate the method
872 $method = "GET" unless $method eq "HEAD"; 962 unless ($method eq "HEAD") {
873 $redirect = 1; 963 $method = "GET";
964 delete $arg{body};
965 }
874 } elsif ($status == 307) { 966 } elsif ($status == 307 or $status == 308) {
875 $redirect = 1; 967 $redirect = 1;
876 } 968 }
877 } 969 }
878 970
879 my $finish = sub { # ($data, $err_status, $err_reason[, $keepalive]) 971 my $finish = sub { # ($data, $err_status, $err_reason[, $persistent])
880 if ($state{handle}) { 972 if ($state{handle}) {
881 # handle keepalive 973 # handle keepalive
882 if ( 974 if (
883 $keepalive 975 $persistent
884 && $_[3] 976 && $_[3]
885 && ($hdr{HTTPVersion} < 1.1 977 && ($hdr{HTTPVersion} < 1.1
886 ? $hdr{connection} =~ /\bkeep-?alive\b/i 978 ? $hdr{connection} =~ /\bkeep-?alive\b/i
887 : $hdr{connection} !~ /\bclose\b/i) 979 : $hdr{connection} !~ /\bclose\b/i)
888 ) { 980 ) {
… …
907 999
908 if ($redirect && exists $hdr{location}) { 1000 if ($redirect && exists $hdr{location}) {
909 # we ignore any errors, as it is very common to receive 1001 # we ignore any errors, as it is very common to receive
910 # Content-Length != 0 but no actual body 1002 # Content-Length != 0 but no actual body
911 # we also access %hdr, as $_[1] might be an erro 1003 # we also access %hdr, as $_[1] might be an erro
1004 $state{recurse} =
912 http_request ( 1005 http_request (
913 $method => $hdr{location}, 1006 $method => $hdr{location},
914 %arg, 1007 %arg,
915 recurse => $recurse - 1, 1008 recurse => $recurse - 1,
916 Redirect => [$_[0], \%hdr], 1009 Redirect => [$_[0], \%hdr],
1010 sub {
1011 %state = ();
917 $cb 1012 &$cb
1013 },
918 ); 1014 );
919 } else { 1015 } else {
920 $cb->($_[0], \%hdr); 1016 $cb->($_[0], \%hdr);
921 } 1017 }
922 }; 1018 };
923 1019
… …
951 $finish->(delete $state{handle}); 1047 $finish->(delete $state{handle});
952 1048
953 } elsif ($chunked) { 1049 } elsif ($chunked) {
954 my $cl = 0; 1050 my $cl = 0;
955 my $body = ""; 1051 my $body = "";
956 my $on_body = $arg{on_body} || sub { $body .= shift; 1 }; 1052 my $on_body = (!$redirect && $arg{on_body}) || sub { $body .= shift; 1 };
957 1053
958 $state{read_chunk} = sub { 1054 $state{read_chunk} = sub {
959 $_[1] =~ /^([0-9a-fA-F]+)/ 1055 $_[1] =~ /^([0-9a-fA-F]+)/
960 or $finish->(undef, $ae_error => "Garbled chunked transfer encoding"); 1056 or return $finish->(undef, $ae_error => "Garbled chunked transfer encoding");
961 1057
962 my $len = hex $1; 1058 my $len = hex $1;
963 1059
964 if ($len) { 1060 if ($len) {
965 $cl += $len; 1061 $cl += $len;
… …
994 } 1090 }
995 }; 1091 };
996 1092
997 $_[0]->push_read (line => $state{read_chunk}); 1093 $_[0]->push_read (line => $state{read_chunk});
998 1094
999 } elsif ($arg{on_body}) { 1095 } elsif (!$redirect && $arg{on_body}) {
1000 if (defined $len) { 1096 if (defined $len) {
1001 $_[0]->on_read (sub { 1097 $_[0]->on_read (sub {
1002 $len -= length $_[0]{rbuf}; 1098 $len -= length $_[0]{rbuf};
1003 1099
1004 $arg{on_body}(delete $_[0]{rbuf}, \%hdr) 1100 $arg{on_body}(delete $_[0]{rbuf}, \%hdr)
… …
1035 } 1131 }
1036 }; 1132 };
1037 1133
1038 # if keepalive is enabled, then the server closing the connection 1134 # if keepalive is enabled, then the server closing the connection
1039 # before a response can happen legally - we retry on idempotent methods. 1135 # before a response can happen legally - we retry on idempotent methods.
1040 if ($keptalive && $idempotent) { 1136 if ($was_persistent && $idempotent) {
1041 my $old_eof = $hdl->{on_eof}; 1137 my $old_eof = $hdl->{on_eof};
1042 $hdl->{on_eof} = sub { 1138 $hdl->{on_eof} = sub {
1043 _destroy_state %state; 1139 _destroy_state %state;
1044 1140
1141 %state = ();
1142 $state{recurse} =
1045 http_request ( 1143 http_request (
1046 $method => $url, 1144 $method => $url,
1047 %arg, 1145 %arg,
1048 keepalive => 0, 1146 recurse => $recurse - 1,
1147 persistent => 0,
1148 sub {
1149 %state = ();
1049 $cb 1150 &$cb
1151 }
1050 ); 1152 );
1051 }; 1153 };
1052 $hdl->on_read (sub { 1154 $hdl->on_read (sub {
1053 return unless %state; 1155 return unless %state;
1054 1156
1055 # as soon as we receive something, a connection close 1157 # as soon as we receive something, a connection close
… …
1063 }; 1165 };
1064 1166
1065 my $prepare_handle = sub { 1167 my $prepare_handle = sub {
1066 my ($hdl) = $state{handle}; 1168 my ($hdl) = $state{handle};
1067 1169
1068 $hdl->timeout ($timeout);
1069 $hdl->on_error (sub { 1170 $hdl->on_error (sub {
1070 _error %state, $cb, { @pseudo, Status => $ae_error, Reason => $_[2] }; 1171 _error %state, $cb, { @pseudo, Status => $ae_error, Reason => $_[2] };
1071 }); 1172 });
1072 $hdl->on_eof (sub { 1173 $hdl->on_eof (sub {
1073 _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" };
1074 }); 1175 });
1176 $hdl->timeout_reset;
1177 $hdl->timeout ($timeout);
1075 }; 1178 };
1076 1179
1077 # connected to proxy (or origin server) 1180 # connected to proxy (or origin server)
1078 my $connect_cb = sub { 1181 my $connect_cb = sub {
1079 my $fh = shift 1182 my $fh = shift
… …
1095 1198
1096 # now handle proxy-CONNECT method 1199 # now handle proxy-CONNECT method
1097 if ($proxy && $uscheme eq "https") { 1200 if ($proxy && $uscheme eq "https") {
1098 # oh dear, we have to wrap it into a connect request 1201 # oh dear, we have to wrap it into a connect request
1099 1202
1203 my $auth = exists $hdr{"proxy-authorization"}
1204 ? "proxy-authorization: " . (delete $hdr{"proxy-authorization"}) . "\015\012"
1205 : "";
1206
1100 # maybe re-use $uauthority with patched port? 1207 # maybe re-use $uauthority with patched port?
1101 $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");
1102 $state{handle}->push_read (line => $qr_nlnl, sub { 1209 $state{handle}->push_read (line => $qr_nlnl, sub {
1103 $_[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
1104 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])" };
1105 1212
1106 if ($2 == 200) { 1213 if ($2 == 200) {
… …
1109 } else { 1216 } else {
1110 _error %state, $cb, { @pseudo, Status => $2, Reason => $3 }; 1217 _error %state, $cb, { @pseudo, Status => $2, Reason => $3 };
1111 } 1218 }
1112 }); 1219 });
1113 } else { 1220 } else {
1221 delete $hdr{"proxy-authorization"} unless $proxy;
1222
1114 $handle_actual_request->(); 1223 $handle_actual_request->();
1115 } 1224 }
1116 }; 1225 };
1117 1226
1118 _get_slot $uhost, sub { 1227 _get_slot $uhost, sub {
… …
1120 1229
1121 return unless $state{connect_guard}; 1230 return unless $state{connect_guard};
1122 1231
1123 # 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
1124 # 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).
1125 if ($keepalive && $KA_CACHE{$ka_key}) { 1234 if ($persistent && $KA_CACHE{$ka_key}) {
1126 $keptalive = 1; 1235 $was_persistent = 1;
1236
1127 $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#
1128 $prepare_handle->(); 1240 $prepare_handle->();
1241# $state{handle}->destroyed
1242# and die "AnyEvent::HTTP: unexpectedly got a destructed handle (2), please report.";#d#
1129 $handle_actual_request->(); 1243 $handle_actual_request->();
1130 1244
1131 } else { 1245 } else {
1132 my $tcp_connect = $arg{tcp_connect} 1246 my $tcp_connect = $arg{tcp_connect}
1133 || do { require AnyEvent::Socket; \&AnyEvent::Socket::tcp_connect }; 1247 || do { require AnyEvent::Socket; \&AnyEvent::Socket::tcp_connect };
… …
1175Sets 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
1176string of the form C<http://host:port>, croaks otherwise. 1290string of the form C<http://host:port>, croaks otherwise.
1177 1291
1178To clear an already-set proxy, use C<undef>. 1292To clear an already-set proxy, use C<undef>.
1179 1293
1180When AnyEvent::HTTP is laoded for the first time it will query the 1294When AnyEvent::HTTP is loaded for the first time it will query the
1181default proxy from the operating system, currently by looking at 1295default proxy from the operating system, currently by looking at
1182C<$ENV{http_proxy>}. 1296C<$ENV{http_proxy>}.
1183 1297
1184=item AnyEvent::HTTP::cookie_jar_expire $jar[, $session_end] 1298=item AnyEvent::HTTP::cookie_jar_expire $jar[, $session_end]
1185 1299
… …
1187C<$session_end> is given and true, then additionally remove all session 1301C<$session_end> is given and true, then additionally remove all session
1188cookies. 1302cookies.
1189 1303
1190You 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
1191save 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
1192again. 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
1193function from time to time. 1307function from time to time.
1194 1308
1195A 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
1196module. 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:
1197 1311
1198The 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
1199emptied. All other keys are hostnames or IP addresses pointing to 1313cleared. All other keys are hostnames or IP addresses pointing to
1200hash-references. The key for these inner hash references is the 1314hash-references. The key for these inner hash references is the
1201server 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
1202hash-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
1203the 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
1204key-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>,
1205which 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
1206expiry timestamp. 1320expiry timestamp. Session cookies are indicated by not having an
1321C<_expires> key.
1207 1322
1208Here 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
1209chance of understanding the above paragraph: 1324chance of understanding the above paragraph:
1210 1325
1211 { 1326 {
1212 version => 1, 1327 version => 2,
1213 "10.0.0.1" => { 1328 "10.0.0.1" => {
1214 "/" => { 1329 "/" => {
1215 "mythweb_id" => { 1330 "mythweb_id" => {
1216 _expires => 1293917923, 1331 _expires => 1293917923,
1217 value => "ooRung9dThee3ooyXooM1Ohm", 1332 value => "ooRung9dThee3ooyXooM1Ohm",
… …
1235 1350
1236The default value for the C<recurse> request parameter (default: C<10>). 1351The default value for the C<recurse> request parameter (default: C<10>).
1237 1352
1238=item $AnyEvent::HTTP::TIMEOUT 1353=item $AnyEvent::HTTP::TIMEOUT
1239 1354
1240The default timeout for conenction operations (default: C<300>). 1355The default timeout for connection operations (default: C<300>).
1241 1356
1242=item $AnyEvent::HTTP::USERAGENT 1357=item $AnyEvent::HTTP::USERAGENT
1243 1358
1244The default value for the C<User-Agent> header (the default is 1359The default value for the C<User-Agent> header (the default is
1245C<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)>).
1246 1361
1247=item $AnyEvent::HTTP::MAX_PER_HOST 1362=item $AnyEvent::HTTP::MAX_PER_HOST
1248 1363
1249The maximum number of concurrent connections to the same host (identified 1364The maximum number of concurrent connections to the same host (identified
1250by the hostname). If the limit is exceeded, then the additional requests 1365by the hostname). If the limit is exceeded, then additional requests
1251are queued until previous connections are closed. Both persistent and 1366are queued until previous connections are closed. Both persistent and
1252non-persistent connections are counted in this limit. 1367non-persistent connections are counted in this limit.
1253 1368
1254The 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
1255increase it much. 1370increase it much.
1256 1371
1257For comparison: the RFC's recommend 4 non-persistent or 2 persistent 1372For comparison: the RFC's recommend 4 non-persistent or 2 persistent
1258connections, older browsers used 2, newers (such as firefox 3) typically 1373connections, older browsers used 2, newer ones (such as firefox 3)
1259use 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
1260give a shit for everybody else on the planet. 1375browser and give a shit for everybody else on the planet.
1261 1376
1262=item $AnyEvent::HTTP::PERSISTENT_TIMEOUT 1377=item $AnyEvent::HTTP::PERSISTENT_TIMEOUT
1263 1378
1264The time after which idle persistent conenctions get closed by 1379The time after which idle persistent connections get closed by
1265AnyEvent::HTTP (default: C<3>). 1380AnyEvent::HTTP (default: C<3>).
1266 1381
1267=item $AnyEvent::HTTP::ACTIVE 1382=item $AnyEvent::HTTP::ACTIVE
1268 1383
1269The number of active connections. This is not the number of currently 1384The number of active connections. This is not the number of currently
… …
1310 # other formats fail in the loop below 1425 # other formats fail in the loop below
1311 1426
1312 for (0..11) { 1427 for (0..11) {
1313 if ($m eq $month[$_]) { 1428 if ($m eq $month[$_]) {
1314 require Time::Local; 1429 require Time::Local;
1315 return Time::Local::timegm ($S, $M, $H, $d, $_, $y); 1430 return eval { Time::Local::timegm ($S, $M, $H, $d, $_, $y) };
1316 } 1431 }
1317 } 1432 }
1318 1433
1319 undef 1434 undef
1320} 1435}
… …
1334 set_proxy $ENV{http_proxy}; 1449 set_proxy $ENV{http_proxy};
1335}; 1450};
1336 1451
1337=head2 SHOWCASE 1452=head2 SHOWCASE
1338 1453
1339This section contaisn some more elaborate "real-world" examples or code 1454This section contains some more elaborate "real-world" examples or code
1340snippets. 1455snippets.
1341 1456
1342=head2 HTTP/1.1 FILE DOWNLOAD 1457=head2 HTTP/1.1 FILE DOWNLOAD
1343 1458
1344Downloading files with HTTP can be quite tricky, especially when something 1459Downloading files with HTTP can be quite tricky, especially when something
… …
1348last 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
1349HTTP/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
1350on older servers. 1465on older servers.
1351 1466
1352It calls the completion callback with either C<undef>, which means a 1467It calls the completion callback with either C<undef>, which means a
1353nonretryable error occured, C<0> when the download was partial and should 1468nonretryable error occurred, C<0> when the download was partial and should
1354be retried, and C<1> if it was successful. 1469be retried, and C<1> if it was successful.
1355 1470
1356 use AnyEvent::HTTP; 1471 use AnyEvent::HTTP;
1357 1472
1358 sub download($$$) { 1473 sub download($$$) {
… …
1362 or die "$file: $!"; 1477 or die "$file: $!";
1363 1478
1364 my %hdr; 1479 my %hdr;
1365 my $ofs = 0; 1480 my $ofs = 0;
1366 1481
1367 warn stat $fh;
1368 warn -s _;
1369 if (stat $fh and -s _) { 1482 if (stat $fh and -s _) {
1370 $ofs = -s _; 1483 $ofs = -s _;
1371 warn "-s is ", $ofs;#d# 1484 warn "-s is ", $ofs;
1372 $hdr{"if-unmodified-since"} = AnyEvent::HTTP::format_date +(stat _)[9]; 1485 $hdr{"if-unmodified-since"} = AnyEvent::HTTP::format_date +(stat _)[9];
1373 $hdr{"range"} = "bytes=$ofs-"; 1486 $hdr{"range"} = "bytes=$ofs-";
1374 } 1487 }
1375 1488
1376 http_get $url, 1489 http_get $url,
… …
1401 my (undef, $hdr) = @_; 1514 my (undef, $hdr) = @_;
1402 1515
1403 my $status = $hdr->{Status}; 1516 my $status = $hdr->{Status};
1404 1517
1405 if (my $time = AnyEvent::HTTP::parse_date $hdr->{"last-modified"}) { 1518 if (my $time = AnyEvent::HTTP::parse_date $hdr->{"last-modified"}) {
1406 utime $fh, $time, $time; 1519 utime $time, $time, $fh;
1407 } 1520 }
1408 1521
1409 if ($status == 200 || $status == 206 || $status == 416) { 1522 if ($status == 200 || $status == 206 || $status == 416) {
1410 # download ok || resume ok || file already fully downloaded 1523 # download ok || resume ok || file already fully downloaded
1411 $cb->(1, $hdr); 1524 $cb->(1, $hdr);

Diff Legend

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