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.10 by root, Thu Jun 5 13:06:43 2008 UTC vs.
Revision 1.61 by root, Thu Dec 30 03:45:01 2010 UTC

3AnyEvent::HTTP - simple but non-blocking HTTP/HTTPS client 3AnyEvent::HTTP - simple but non-blocking HTTP/HTTPS client
4 4
5=head1 SYNOPSIS 5=head1 SYNOPSIS
6 6
7 use AnyEvent::HTTP; 7 use AnyEvent::HTTP;
8
9 http_get "http://www.nethype.de/", sub { print $_[1] };
10
11 # ... do something else here
8 12
9=head1 DESCRIPTION 13=head1 DESCRIPTION
10 14
11This module is an L<AnyEvent> user, you need to make sure that you use and 15This module is an L<AnyEvent> user, you need to make sure that you use and
12run a supported event loop. 16run a supported event loop.
13 17
18This module implements a simple, stateless and non-blocking HTTP
19client. It supports GET, POST and other request methods, cookies and more,
20all on a very low level. It can follow redirects supports proxies and
21automatically limits the number of connections to the values specified in
22the RFC.
23
24It should generally be a "good client" that is enough for most HTTP
25tasks. Simple tasks should be simple, but complex tasks should still be
26possible as the user retains control over request and response headers.
27
28The caller is responsible for authentication management, cookies (if
29the simplistic implementation in this module doesn't suffice), referer
30and other high-level protocol details for which this module offers only
31limited support.
32
14=head2 METHODS 33=head2 METHODS
15 34
16=over 4 35=over 4
17 36
18=cut 37=cut
20package AnyEvent::HTTP; 39package AnyEvent::HTTP;
21 40
22use strict; 41use strict;
23no warnings; 42no warnings;
24 43
25use Carp; 44use Errno ();
26 45
27use AnyEvent (); 46use AnyEvent 5.0 ();
28use AnyEvent::Util (); 47use AnyEvent::Util ();
29use AnyEvent::Socket ();
30use AnyEvent::Handle (); 48use AnyEvent::Handle ();
31 49
32use base Exporter::; 50use base Exporter::;
33 51
34our $VERSION = '1.0'; 52our $VERSION = '1.46';
35 53
36our @EXPORT = qw(http_get http_request); 54our @EXPORT = qw(http_get http_post http_head http_request);
37 55
38our $USERAGENT = "Mozilla/5.0 (compatible; AnyEvent::HTTP/$VERSION; +http://software.schmorp.de/pkg/AnyEvent)"; 56our $USERAGENT = "Mozilla/5.0 (compatible; U; AnyEvent-HTTP/$VERSION; +http://software.schmorp.de/pkg/AnyEvent)";
39our $MAX_RECURSE = 10; 57our $MAX_RECURSE = 10;
40our $MAX_PERSISTENT = 8; 58our $MAX_PERSISTENT = 8;
41our $PERSISTENT_TIMEOUT = 2; 59our $PERSISTENT_TIMEOUT = 2;
42our $TIMEOUT = 300; 60our $TIMEOUT = 300;
43 61
44# changing these is evil 62# changing these is evil
45our $MAX_PERSISTENT_PER_HOST = 2; 63our $MAX_PERSISTENT_PER_HOST = 0;
46our $MAX_PER_HOST = 4; # not respected yet :( 64our $MAX_PER_HOST = 4;
47 65
48our $PROXY; 66our $PROXY;
67our $ACTIVE = 0;
49 68
50my %KA_COUNT; # number of open keep-alive connections per host 69my %KA_COUNT; # number of open keep-alive connections per host
70my %CO_SLOT; # number of open connections, and wait queue, per host
51 71
52=item http_get $url, key => value..., $cb->($data, $headers) 72=item http_get $url, key => value..., $cb->($data, $headers)
53 73
54Executes an HTTP-GET request. See the http_request function for details on 74Executes an HTTP-GET request. See the http_request function for details on
55additional parameters. 75additional parameters and the return value.
56 76
57=item http_head $url, key => value..., $cb->($data, $headers) 77=item http_head $url, key => value..., $cb->($data, $headers)
58 78
59Executes an HTTP-HEAD request. See the http_request function for details on 79Executes an HTTP-HEAD request. See the http_request function for details
60additional parameters. 80on additional parameters and the return value.
61 81
62=item http_post $url, $body, key => value..., $cb->($data, $headers) 82=item http_post $url, $body, key => value..., $cb->($data, $headers)
63 83
64Executes an HTTP-POST request with a request body of C<$bod>. See the 84Executes an HTTP-POST request with a request body of C<$body>. See the
65http_request function for details on additional parameters. 85http_request function for details on additional parameters and the return
86value.
66 87
67=item http_request $method => $url, key => value..., $cb->($data, $headers) 88=item http_request $method => $url, key => value..., $cb->($data, $headers)
68 89
69Executes a HTTP request of type C<$method> (e.g. C<GET>, C<POST>). The URL 90Executes a HTTP request of type C<$method> (e.g. C<GET>, C<POST>). The URL
70must be an absolute http or https URL. 91must be an absolute http or https URL.
71 92
93When called in void context, nothing is returned. In other contexts,
94C<http_request> returns a "cancellation guard" - you have to keep the
95object at least alive until the callback get called. If the object gets
96destroyed before the callback is called, the request will be cancelled.
97
72The callback will be called with the response data as first argument 98The callback will be called with the response body data as first argument
73(or C<undef> if it wasn't available due to errors), and a hash-ref with 99(or C<undef> if an error occured), and a hash-ref with response headers as
74response headers as second argument. 100second argument.
75 101
76All the headers in that hash are lowercased. In addition to the response 102All the headers in that hash are lowercased. In addition to the response
77headers, the three "pseudo-headers" C<HTTPVersion>, C<Status> and 103headers, the "pseudo-headers" (uppercase to avoid clashing with possible
104response headers) C<HTTPVersion>, C<Status> and C<Reason> contain the
78C<Reason> contain the three parts of the HTTP Status-Line of the same 105three parts of the HTTP Status-Line of the same name.
106
107The pseudo-header C<URL> contains the actual URL (which can differ from
108the requested URL when following redirects - for example, you might get
109an error that your URL scheme is not supported even though your URL is a
110valid http URL because it redirected to an ftp URL, in which case you can
111look at the URL pseudo header).
112
113The pseudo-header C<Redirect> only exists when the request was a result
114of an internal redirect. In that case it is an array reference with
115the C<($data, $headers)> from the redirect response. Note that this
116response could in turn be the result of a redirect itself, and C<<
117$headers->{Redirect}[1]{Redirect} >> will then contain the original
118response, and so on.
119
79name. If the server sends a header multiple lines, then their contents 120If the server sends a header multiple times, then their contents will be
80will be joined together with C<\x00>. 121joined together with a comma (C<,>), as per the HTTP spec.
81 122
82If an internal error occurs, such as not being able to resolve a hostname, 123If an internal error occurs, such as not being able to resolve a hostname,
83then C<$data> will be C<undef>, C<< $headers->{Status} >> will be C<599> 124then C<$data> will be C<undef>, C<< $headers->{Status} >> will be C<59x>
84and the C<Reason> pseudo-header will contain an error message. 125(usually C<599>) and the C<Reason> pseudo-header will contain an error
126message.
85 127
86A typical callback might look like this: 128A typical callback might look like this:
87 129
88 sub { 130 sub {
89 my ($body, $hdr) = @_; 131 my ($body, $hdr) = @_;
105Whether to recurse requests or not, e.g. on redirects, authentication 147Whether to recurse requests or not, e.g. on redirects, authentication
106retries and so on, and how often to do so. 148retries and so on, and how often to do so.
107 149
108=item headers => hashref 150=item headers => hashref
109 151
110The request headers to use. 152The request headers to use. Currently, C<http_request> may provide its
153own C<Host:>, C<Content-Length:>, C<Connection:> and C<Cookie:> headers
154and will provide defaults for C<User-Agent:> and C<Referer:> (this can be
155suppressed by using C<undef> for these headers in which case they won't be
156sent at all).
111 157
112=item timeout => $seconds 158=item timeout => $seconds
113 159
114The time-out to use for various stages - each connect attempt will reset 160The time-out to use for various stages - each connect attempt will reset
115the timeout, as will read or write activity. Default timeout is 5 minutes. 161the timeout, as will read or write activity, i.e. this is not an overall
162timeout.
163
164Default timeout is 5 minutes.
116 165
117=item proxy => [$host, $port[, $scheme]] or undef 166=item proxy => [$host, $port[, $scheme]] or undef
118 167
119Use the given http proxy for all requests. If not specified, then the 168Use the given http proxy for all requests. If not specified, then the
120default proxy (as specified by C<$ENV{http_proxy}>) is used. 169default proxy (as specified by C<$ENV{http_proxy}>) is used.
121 170
122C<$scheme> must be either missing or C<http> for HTTP, or C<https> for 171C<$scheme> must be either missing, C<http> for HTTP or C<https> for
123HTTPS. 172HTTPS.
124 173
125=item body => $string 174=item body => $string
126 175
127The request body, usually empty. Will be-sent as-is (future versions of 176The request body, usually empty. Will be-sent as-is (future versions of
133based on the original netscape specification. 182based on the original netscape specification.
134 183
135The C<$hash_ref> must be an (initially empty) hash reference which will 184The C<$hash_ref> must be an (initially empty) hash reference which will
136get updated automatically. It is possible to save the cookie_jar to 185get updated automatically. It is possible to save the cookie_jar to
137persistent storage with something like JSON or Storable, but this is not 186persistent storage with something like JSON or Storable, but this is not
138recommended, as expire times are currently being ignored. 187recommended, as expiry times are currently being ignored.
139 188
140Note that this cookie implementation is not of very high quality, nor 189Note that this cookie implementation is not of very high quality, nor
141meant to be complete. If you want complete cookie management you have to 190meant to be complete. If you want complete cookie management you have to
142do that on your own. C<cookie_jar> is meant as a quick fix to get some 191do that on your own. C<cookie_jar> is meant as a quick fix to get some
143cookie-using sites working. Cookies are a privacy disaster, do not use 192cookie-using sites working. Cookies are a privacy disaster, do not use
144them unless required to. 193them unless required to.
194
195=item tls_ctx => $scheme | $tls_ctx
196
197Specifies the AnyEvent::TLS context to be used for https connections. This
198parameter follows the same rules as the C<tls_ctx> parameter to
199L<AnyEvent::Handle>, but additionally, the two strings C<low> or
200C<high> can be specified, which give you a predefined low-security (no
201verification, highest compatibility) and high-security (CA and common-name
202verification) TLS context.
203
204The default for this option is C<low>, which could be interpreted as "give
205me the page, no matter what".
206
207=item on_prepare => $callback->($fh)
208
209In rare cases you need to "tune" the socket before it is used to
210connect (for exmaple, to bind it on a given IP address). This parameter
211overrides the prepare callback passed to C<AnyEvent::Socket::tcp_connect>
212and behaves exactly the same way (e.g. it has to provide a
213timeout). See the description for the C<$prepare_cb> argument of
214C<AnyEvent::Socket::tcp_connect> for details.
215
216=item tcp_connect => $callback->($host, $service, $connect_cb, $prepare_cb)
217
218In even rarer cases you want total control over how AnyEvent::HTTP
219establishes connections. Normally it uses L<AnyEvent::Socket::tcp_connect>
220to do this, but you can provide your own C<tcp_connect> function -
221obviously, it has to follow the same calling conventions, except that it
222may always return a connection guard object.
223
224There are probably lots of weird uses for this function, starting from
225tracing the hosts C<http_request> actually tries to connect, to (inexact
226but fast) host => IP address caching or even socks protocol support.
227
228=item on_header => $callback->($headers)
229
230When specified, this callback will be called with the header hash as soon
231as headers have been successfully received from the remote server (not on
232locally-generated errors).
233
234It has to return either true (in which case AnyEvent::HTTP will continue),
235or false, in which case AnyEvent::HTTP will cancel the download (and call
236the finish callback with an error code of C<598>).
237
238This callback is useful, among other things, to quickly reject unwanted
239content, which, if it is supposed to be rare, can be faster than first
240doing a C<HEAD> request.
241
242Example: cancel the request unless the content-type is "text/html".
243
244 on_header => sub {
245 $_[0]{"content-type"} =~ /^text\/html\s*(?:;|$)/
246 },
247
248=item on_body => $callback->($partial_body, $headers)
249
250When specified, all body data will be passed to this callback instead of
251to the completion callback. The completion callback will get the empty
252string instead of the body data.
253
254It has to return either true (in which case AnyEvent::HTTP will continue),
255or false, in which case AnyEvent::HTTP will cancel the download (and call
256the completion callback with an error code of C<598>).
257
258This callback is useful when the data is too large to be held in memory
259(so the callback writes it to a file) or when only some information should
260be extracted, or when the body should be processed incrementally.
261
262It is usually preferred over doing your own body handling via
263C<want_body_handle>, but in case of streaming APIs, where HTTP is
264only used to create a connection, C<want_body_handle> is the better
265alternative, as it allows you to install your own event handler, reducing
266resource usage.
267
268=item want_body_handle => $enable
269
270When enabled (default is disabled), the behaviour of AnyEvent::HTTP
271changes considerably: after parsing the headers, and instead of
272downloading the body (if any), the completion callback will be
273called. Instead of the C<$body> argument containing the body data, the
274callback will receive the L<AnyEvent::Handle> object associated with the
275connection. In error cases, C<undef> will be passed. When there is no body
276(e.g. status C<304>), the empty string will be passed.
277
278The handle object might or might not be in TLS mode, might be connected to
279a proxy, be a persistent connection etc., and configured in unspecified
280ways. The user is responsible for this handle (it will not be used by this
281module anymore).
282
283This is useful with some push-type services, where, after the initial
284headers, an interactive protocol is used (typical example would be the
285push-style twitter API which starts a JSON/XML stream).
286
287If you think you need this, first have a look at C<on_body>, to see if
288that doesn't solve your problem in a better way.
145 289
146=back 290=back
147 291
148Example: make a simple HTTP GET request for http://www.nethype.de/ 292Example: make a simple HTTP GET request for http://www.nethype.de/
149 293
163 use Data::Dumper; 307 use Data::Dumper;
164 print Dumper $hdr; 308 print Dumper $hdr;
165 } 309 }
166 ; 310 ;
167 311
312Example: make another simple HTTP GET request, but immediately try to
313cancel it.
314
315 my $request = http_request GET => "http://www.nethype.de/", sub {
316 my ($body, $hdr) = @_;
317 print "$body\n";
318 };
319
320 undef $request;
321
168=cut 322=cut
169 323
324sub _slot_schedule;
325sub _slot_schedule($) {
326 my $host = shift;
327
328 while ($CO_SLOT{$host}[0] < $MAX_PER_HOST) {
329 if (my $cb = shift @{ $CO_SLOT{$host}[1] }) {
330 # somebody wants that slot
331 ++$CO_SLOT{$host}[0];
332 ++$ACTIVE;
333
334 $cb->(AnyEvent::Util::guard {
335 --$ACTIVE;
336 --$CO_SLOT{$host}[0];
337 _slot_schedule $host;
338 });
339 } else {
340 # nobody wants the slot, maybe we can forget about it
341 delete $CO_SLOT{$host} unless $CO_SLOT{$host}[0];
342 last;
343 }
344 }
345}
346
347# wait for a free slot on host, call callback
348sub _get_slot($$) {
349 push @{ $CO_SLOT{$_[0]}[1] }, $_[1];
350
351 _slot_schedule $_[0];
352}
353
354our $qr_nlnl = qr{(?<![^\012])\015?\012};
355
356our $TLS_CTX_LOW = { cache => 1, sslv2 => 1 };
357our $TLS_CTX_HIGH = { cache => 1, verify => 1, verify_peername => "https" };
358
170sub http_request($$$;@) { 359sub http_request($$@) {
171 my $cb = pop; 360 my $cb = pop;
172 my ($method, $url, %arg) = @_; 361 my ($method, $url, %arg) = @_;
173 362
174 my %hdr; 363 my %hdr;
364
365 $arg{tls_ctx} = $TLS_CTX_LOW if $arg{tls_ctx} eq "low" || !exists $arg{tls_ctx};
366 $arg{tls_ctx} = $TLS_CTX_HIGH if $arg{tls_ctx} eq "high";
175 367
176 $method = uc $method; 368 $method = uc $method;
177 369
178 if (my $hdr = $arg{headers}) { 370 if (my $hdr = $arg{headers}) {
179 while (my ($k, $v) = each %$hdr) { 371 while (my ($k, $v) = each %$hdr) {
180 $hdr{lc $k} = $v; 372 $hdr{lc $k} = $v;
181 } 373 }
182 } 374 }
183 375
376 # pseudo headers for all subsequent responses
377 my @pseudo = (URL => $url);
378 push @pseudo, Redirect => delete $arg{Redirect} if exists $arg{Redirect};
379
184 my $recurse = exists $arg{recurse} ? $arg{recurse} : $MAX_RECURSE; 380 my $recurse = exists $arg{recurse} ? delete $arg{recurse} : $MAX_RECURSE;
185 381
186 return $cb->(undef, { Status => 599, Reason => "recursion limit reached" }) 382 return $cb->(undef, { Status => 599, Reason => "Too many redirections", @pseudo })
187 if $recurse < 0; 383 if $recurse < 0;
188 384
189 my $proxy = $arg{proxy} || $PROXY; 385 my $proxy = $arg{proxy} || $PROXY;
190 my $timeout = $arg{timeout} || $TIMEOUT; 386 my $timeout = $arg{timeout} || $TIMEOUT;
191 387
192 $hdr{"user-agent"} ||= $USERAGENT;
193
194 my ($scheme, $authority, $upath, $query, $fragment) = 388 my ($uscheme, $uauthority, $upath, $query, $fragment) =
195 $url =~ m|(?:([^:/?#]+):)?(?://([^/?#]*))?([^?#]*)(?:\?([^#]*))?(?:#(.*))?|; 389 $url =~ m|(?:([^:/?#]+):)?(?://([^/?#]*))?([^?#]*)(?:(\?[^#]*))?(?:#(.*))?|;
196 390
197 $scheme = lc $scheme; 391 $uscheme = lc $uscheme;
198 392
199 my $uport = $scheme eq "http" ? 80 393 my $uport = $uscheme eq "http" ? 80
200 : $scheme eq "https" ? 443 394 : $uscheme eq "https" ? 443
201 : return $cb->(undef, { Status => 599, Reason => "only http and https URL schemes supported" }); 395 : return $cb->(undef, { Status => 599, Reason => "Only http and https URL schemes supported", @pseudo });
202 396
203 $authority =~ /^(?: .*\@ )? ([^\@:]+) (?: : (\d+) )?$/x 397 $uauthority =~ /^(?: .*\@ )? ([^\@:]+) (?: : (\d+) )?$/x
204 or return $cb->(undef, { Status => 599, Reason => "unparsable URL" }); 398 or return $cb->(undef, { Status => 599, Reason => "Unparsable URL", @pseudo });
205 399
206 my $uhost = $1; 400 my $uhost = $1;
207 $uport = $2 if defined $2; 401 $uport = $2 if defined $2;
208 402
403 $hdr{host} = defined $2 ? "$uhost:$2" : "$uhost"
404 unless exists $hdr{host};
405
209 $uhost =~ s/^\[(.*)\]$/$1/; 406 $uhost =~ s/^\[(.*)\]$/$1/;
210 $upath .= "?$query" if length $query; 407 $upath .= $query if length $query;
211 408
212 $upath =~ s%^/?%/%; 409 $upath =~ s%^/?%/%;
213 410
214 # cookie processing 411 # cookie processing
215 if (my $jar = $arg{cookie_jar}) { 412 if (my $jar = $arg{cookie_jar}) {
216 %$jar = () if $jar->{version} < 1; 413 %$jar = () if $jar->{version} != 1;
217 414
218 my @cookie; 415 my @cookie;
219 416
220 while (my ($chost, $v) = each %$jar) { 417 while (my ($chost, $v) = each %$jar) {
418 if ($chost =~ /^\./) {
221 next unless $chost eq substr $uhost, -length $chost; 419 next unless $chost eq substr $uhost, -length $chost;
222 next unless $chost =~ /^\./; 420 } elsif ($chost =~ /\./) {
421 next unless $chost eq $uhost;
422 } else {
423 next;
424 }
223 425
224 while (my ($cpath, $v) = each %$v) { 426 while (my ($cpath, $v) = each %$v) {
225 next unless $cpath eq substr $upath, 0, length $cpath; 427 next unless $cpath eq substr $upath, 0, length $cpath;
226 428
227 while (my ($k, $v) = each %$v) { 429 while (my ($k, $v) = each %$v) {
228 next if $scheme ne "https" && exists $v->{secure}; 430 next if $uscheme ne "https" && exists $v->{secure};
431 my $value = $v->{value};
432 $value =~ s/([\\"])/\\$1/g;
229 push @cookie, "$k=$v->{value}"; 433 push @cookie, "$k=\"$value\"";
230 } 434 }
231 } 435 }
232 } 436 }
233 437
234 $hdr{cookie} = join "; ", @cookie 438 $hdr{cookie} = join "; ", @cookie
235 if @cookie; 439 if @cookie;
236 } 440 }
237 441
238 my ($rhost, $rport, $rpath); # request host, port, path 442 my ($rhost, $rport, $rscheme, $rpath); # request host, port, path
239 443
240 if ($proxy) { 444 if ($proxy) {
241 ($rhost, $rport, $scheme) = @$proxy; 445 ($rpath, $rhost, $rport, $rscheme) = ($url, @$proxy);
242 $rpath = $url; 446
447 $rscheme = "http" unless defined $rscheme;
448
449 # don't support https requests over https-proxy transport,
450 # can't be done with tls as spec'ed, unless you double-encrypt.
451 $rscheme = "http" if $uscheme eq "https" && $rscheme eq "https";
243 } else { 452 } else {
244 ($rhost, $rport, $rpath) = ($uhost, $uport, $upath); 453 ($rhost, $rport, $rscheme, $rpath) = ($uhost, $uport, $uscheme, $upath);
245 $hdr{host} = $uhost;
246 } 454 }
247 455
456 # leave out fragment and query string, just a heuristic
457 $hdr{referer} ||= "$uscheme://$uauthority$upath" unless exists $hdr{referer};
458 $hdr{"user-agent"} ||= $USERAGENT unless exists $hdr{"user-agent"};
459
248 $hdr{"content-length"} = length $arg{body}; 460 $hdr{"content-length"} = length $arg{body}
461 if length $arg{body} || $method ne "GET";
249 462
250 my %state; 463 my %state = (connect_guard => 1);
251 464
252 $state{connect_guard} = AnyEvent::Socket::tcp_connect $rhost, $rport, sub { 465 _get_slot $uhost, sub {
466 $state{slot_guard} = shift;
467
468 return unless $state{connect_guard};
469
470 my $tcp_connect = $arg{tcp_connect}
471 || do { require AnyEvent::Socket; \&AnyEvent::Socket::tcp_connect };
472
473 $state{connect_guard} = $tcp_connect->(
474 $rhost,
475 $rport,
476 sub {
253 $state{fh} = shift 477 $state{fh} = shift
478 or do {
479 my $err = "$!";
480 %state = ();
254 or return $cb->(undef, { Status => 599, Reason => "$!" }); 481 return $cb->(undef, { Status => 599, Reason => $err, @pseudo });
482 };
255 483
256 delete $state{connect_guard}; # reduce memory usage, save a tree 484 pop; # free memory, save a tree
257 485
486 return unless delete $state{connect_guard};
487
258 # get handle 488 # get handle
259 $state{handle} = new AnyEvent::Handle 489 $state{handle} = new AnyEvent::Handle
260 fh => $state{fh}, 490 fh => $state{fh},
261 ($scheme eq "https" ? (tls => "connect") : ()); 491 peername => $rhost,
492 tls_ctx => $arg{tls_ctx},
493 # these need to be reconfigured on keepalive handles
494 timeout => $timeout,
495 on_error => sub {
496 %state = ();
497 $cb->(undef, { Status => 599, Reason => $_[2], @pseudo });
498 },
499 on_eof => sub {
500 %state = ();
501 $cb->(undef, { Status => 599, Reason => "Unexpected end-of-file", @pseudo });
502 },
503 ;
262 504
263 # limit the number of persistent connections 505 # limit the number of persistent connections
506 # keepalive not yet supported
264 if ($KA_COUNT{$_[1]} < $MAX_PERSISTENT_PER_HOST) { 507# if ($KA_COUNT{$_[1]} < $MAX_PERSISTENT_PER_HOST) {
265 ++$KA_COUNT{$_[1]}; 508# ++$KA_COUNT{$_[1]};
266 $state{handle}{ka_count_guard} = AnyEvent::Util::guard { --$KA_COUNT{$_[1]} }; 509# $state{handle}{ka_count_guard} = AnyEvent::Util::guard {
510# --$KA_COUNT{$_[1]}
511# };
267 $hdr{connection} = "keep-alive"; 512# $hdr{connection} = "keep-alive";
268 delete $hdr{connection}; # keep-alive not yet supported
269 } else { 513# } else {
270 delete $hdr{connection}; 514 delete $hdr{connection};
271 } 515# }
272 516
273 # (re-)configure handle 517 $state{handle}->starttls ("connect") if $rscheme eq "https";
274 $state{handle}->timeout ($timeout);
275 $state{handle}->on_error (sub {
276 %state = ();
277 $cb->(undef, { Status => 599, Reason => "$!" });
278 });
279 $state{handle}->on_eof (sub {
280 %state = ();
281 $cb->(undef, { Status => 599, Reason => "unexpected end-of-file" });
282 });
283 518
519 # handle actual, non-tunneled, request
520 my $handle_actual_request = sub {
521 $state{handle}->starttls ("connect") if $uscheme eq "https" && !exists $state{handle}{tls};
522
284 # send request 523 # send request
285 $state{handle}->push_write ( 524 $state{handle}->push_write (
286 "$method $rpath HTTP/1.0\015\012" 525 "$method $rpath HTTP/1.0\015\012"
287 . (join "", map "$_: $hdr{$_}\015\012", keys %hdr) 526 . (join "", map "\u$_: $hdr{$_}\015\012", grep defined $hdr{$_}, keys %hdr)
288 . "\015\012" 527 . "\015\012"
289 . (delete $arg{body}) 528 . (delete $arg{body})
529 );
530
531 # return if error occured during push_write()
532 return unless %state;
533
534 %hdr = (); # reduce memory usage, save a kitten, also make it possible to re-use
535
536 # status line and headers
537 $state{handle}->push_read (line => $qr_nlnl, sub {
538 for ("$_[1]") {
539 y/\015//d; # weed out any \015, as they show up in the weirdest of places.
540
541 /^HTTP\/([0-9\.]+) \s+ ([0-9]{3}) (?: \s+ ([^\015\012]*) )? \015?\012/igxc
542 or return (%state = (), $cb->(undef, { Status => 599, Reason => "Invalid server response", @pseudo }));
543
544 push @pseudo,
545 HTTPVersion => $1,
546 Status => $2,
547 Reason => $3,
548 ;
549
550 # things seen, not parsed:
551 # p3pP="NON CUR OTPi OUR NOR UNI"
552
553 $hdr{lc $1} .= ",$2"
554 while /\G
555 ([^:\000-\037]*):
556 [\011\040]*
557 ((?: [^\012]+ | \012[\011\040] )*)
558 \012
559 /gxc;
560
561 /\G$/
562 or return (%state = (), $cb->(undef, { Status => 599, Reason => "Garbled response headers", @pseudo }));
563 }
564
565 # remove the "," prefix we added to all headers above
566 substr $_, 0, 1, ""
567 for values %hdr;
568
569 # patch in all pseudo headers
570 %hdr = (%hdr, @pseudo);
571
572 # redirect handling
573 # microsoft and other shitheads don't give a shit for following standards,
574 # try to support some common forms of broken Location headers.
575 if ($hdr{location} !~ /^(?: $ | [^:\/?\#]+ : )/x) {
576 $hdr{location} =~ s/^\.\/+//;
577
578 my $url = "$rscheme://$uhost:$uport";
579
580 unless ($hdr{location} =~ s/^\///) {
581 $url .= $upath;
582 $url =~ s/\/[^\/]*$//;
583 }
584
585 $hdr{location} = "$url/$hdr{location}";
586 }
587
588 my $redirect;
589
590 if ($recurse) {
591 my $status = $hdr{Status};
592
593 # industry standard is to redirect POST as GET for
594 # 301, 302 and 303, in contrast to http/1.0 and 1.1.
595 # also, the UA should ask the user for 301 and 307 and POST,
596 # industry standard seems to be to simply follow.
597 # we go with the industry standard.
598 if ($status == 301 or $status == 302 or $status == 303) {
599 # HTTP/1.1 is unclear on how to mutate the method
600 $method = "GET" unless $method eq "HEAD";
601 $redirect = 1;
602 } elsif ($status == 307) {
603 $redirect = 1;
604 }
605 }
606
607 my $finish = sub {
608 $state{handle}->destroy if $state{handle};
609 %state = ();
610
611 # set-cookie processing
612 if ($arg{cookie_jar}) {
613 for ($_[1]{"set-cookie"}) {
614 # parse NAME=VALUE
615 my @kv;
616
617 while (/\G\s* ([^=;,[:space:]]+) \s*=\s* (?: "((?:[^\\"]+|\\.)*)" | ([^=;,[:space:]]*) )/gcxs) {
618 my $name = $1;
619 my $value = $3;
620
621 unless ($value) {
622 $value = $2;
623 $value =~ s/\\(.)/$1/gs;
624 }
625
626 push @kv, $name => $value;
627
628 last unless /\G\s*;/gc;
629 }
630
631 last unless @kv;
632
633 my $name = shift @kv;
634 my %kv = (value => shift @kv, @kv);
635
636 my $cdom;
637 my $cpath = (delete $kv{path}) || "/";
638
639 if (exists $kv{domain}) {
640 $cdom = delete $kv{domain};
641
642 $cdom =~ s/^\.?/./; # make sure it starts with a "."
643
644 next if $cdom =~ /\.$/;
645
646 # this is not rfc-like and not netscape-like. go figure.
647 my $ndots = $cdom =~ y/.//;
648 next if $ndots < ($cdom =~ /\.[^.][^.]\.[^.][^.]$/ ? 3 : 2);
649 } else {
650 $cdom = $uhost;
651 }
652
653 # store it
654 $arg{cookie_jar}{version} = 1;
655 $arg{cookie_jar}{$cdom}{$cpath}{$name} = \%kv;
656
657 redo if /\G\s*,/gc;
658 }
659 }
660
661 if ($redirect && exists $hdr{location}) {
662 # we ignore any errors, as it is very common to receive
663 # Content-Length != 0 but no actual body
664 # we also access %hdr, as $_[1] might be an erro
665 http_request (
666 $method => $hdr{location},
667 %arg,
668 recurse => $recurse - 1,
669 Redirect => \@_,
670 $cb);
671 } else {
672 $cb->($_[0], $_[1]);
673 }
674 };
675
676 my $len = $hdr{"content-length"};
677
678 if (!$redirect && $arg{on_header} && !$arg{on_header}(\%hdr)) {
679 $finish->(undef, { Status => 598, Reason => "Request cancelled by on_header", @pseudo });
680 } elsif (
681 $hdr{Status} =~ /^(?:1..|[23]04)$/
682 or $method eq "HEAD"
683 or (defined $len && !$len)
684 ) {
685 # no body
686 $finish->("", \%hdr);
687 } else {
688 # body handling, four different code paths
689 # for want_body_handle, on_body (2x), normal (2x)
690 # we might read too much here, but it does not matter yet (no pers. connections)
691 if (!$redirect && $arg{want_body_handle}) {
692 $_[0]->on_eof (undef);
693 $_[0]->on_error (undef);
694 $_[0]->on_read (undef);
695
696 $finish->(delete $state{handle}, \%hdr);
697
698 } elsif ($arg{on_body}) {
699 $_[0]->on_error (sub { $finish->(undef, { Status => 599, Reason => $_[2], @pseudo }) });
700 if ($len) {
701 $_[0]->on_eof (undef);
702 $_[0]->on_read (sub {
703 $len -= length $_[0]{rbuf};
704
705 $arg{on_body}(delete $_[0]{rbuf}, \%hdr)
706 or $finish->(undef, { Status => 598, Reason => "Request cancelled by on_body", @pseudo });
707
708 $len > 0
709 or $finish->("", \%hdr);
710 });
711 } else {
712 $_[0]->on_eof (sub {
713 $finish->("", \%hdr);
714 });
715 $_[0]->on_read (sub {
716 $arg{on_body}(delete $_[0]{rbuf}, \%hdr)
717 or $finish->(undef, { Status => 598, Reason => "Request cancelled by on_body", @pseudo });
718 });
719 }
720 } else {
721 $_[0]->on_eof (undef);
722
723 if ($len) {
724 $_[0]->on_error (sub { $finish->(undef, { Status => 599, Reason => $_[2], @pseudo }) });
725 $_[0]->on_read (sub {
726 $finish->((substr delete $_[0]{rbuf}, 0, $len, ""), \%hdr)
727 if $len <= length $_[0]{rbuf};
728 });
729 } else {
730 $_[0]->on_error (sub {
731 ($! == Errno::EPIPE || !$!)
732 ? $finish->(delete $_[0]{rbuf}, \%hdr)
733 : $finish->(undef, { Status => 599, Reason => $_[2], @pseudo });
734 });
735 $_[0]->on_read (sub { });
736 }
737 }
738 }
739 });
740 };
741
742 # now handle proxy-CONNECT method
743 if ($proxy && $uscheme eq "https") {
744 # oh dear, we have to wrap it into a connect request
745
746 # maybe re-use $uauthority with patched port?
747 $state{handle}->push_write ("CONNECT $uhost:$uport HTTP/1.0\015\012Host: $uhost\015\012\015\012");
748 $state{handle}->push_read (line => $qr_nlnl, sub {
749 $_[1] =~ /^HTTP\/([0-9\.]+) \s+ ([0-9]{3}) (?: \s+ ([^\015\012]*) )?/ix
750 or return (%state = (), $cb->(undef, { Status => 599, Reason => "Invalid proxy connect response ($_[1])", @pseudo }));
751
752 if ($2 == 200) {
753 $rpath = $upath;
754 &$handle_actual_request;
755 } else {
756 %state = ();
757 $cb->(undef, { Status => $2, Reason => $3, @pseudo });
758 }
759 });
760 } else {
761 &$handle_actual_request;
762 }
763
764 },
765 $arg{on_prepare} || sub { $timeout }
290 ); 766 );
291
292 %hdr = (); # reduce memory usage, save a kitten
293
294 # status line
295 $state{handle}->push_read (line => qr/\015?\012/, sub {
296 $_[1] =~ /^HTTP\/([0-9\.]+) \s+ ([0-9]{3}) \s+ ([^\015\012]+)/ix
297 or return (%state = (), $cb->(undef, { Status => 599, Reason => "invalid server response ($_[1])" }));
298
299 my %hdr = ( # response headers
300 HTTPVersion => "\x00$1",
301 Status => "\x00$2",
302 Reason => "\x00$3",
303 );
304
305 # headers, could be optimized a bit
306 $state{handle}->unshift_read (line => qr/\015?\012\015?\012/, sub {
307 for ("$_[1]\012") {
308 # we support spaces in field names, as lotus domino
309 # creates them.
310 $hdr{lc $1} .= "\x00$2"
311 while /\G
312 ([^:\000-\037]+):
313 [\011\040]*
314 ((?: [^\015\012]+ | \015?\012[\011\040] )*)
315 \015?\012
316 /gxc;
317
318 /\G$/
319 or return (%state = (), $cb->(undef, { Status => 599, Reason => "garbled response headers" }));
320 }
321
322 substr $_, 0, 1, ""
323 for values %hdr;
324
325 my $finish = sub {
326 %state = ();
327
328 # set-cookie processing
329 if ($arg{cookie_jar} && exists $hdr{"set-cookie"}) {
330 for (split /\x00/, $hdr{"set-cookie"}) {
331 my ($cookie, @arg) = split /;\s*/;
332 my ($name, $value) = split /=/, $cookie, 2;
333 my %kv = (value => $value, map { split /=/, $_, 2 } @arg);
334
335 my $cdom = (delete $kv{domain}) || $uhost;
336 my $cpath = (delete $kv{path}) || "/";
337
338 $cdom =~ s/^.?/./; # make sure it starts with a "."
339
340 my $ndots = $cdom =~ y/.//;
341 next if $ndots < ($cdom =~ /[^.]{3}$/ ? 2 : 3);
342
343 # store it
344 $arg{cookie_jar}{version} = 1;
345 $arg{cookie_jar}{$cdom}{$cpath}{$name} = \%kv;
346 }
347 }
348
349 if ($_[1]{Status} =~ /^x30[12]$/ && $recurse) {
350 # microsoft and other assholes don't give a shit for following standards,
351 # try to support a common form of broken Location header.
352 $_[1]{location} =~ s%^/%$scheme://$uhost:$uport/%;
353
354 http_request ($method, $_[1]{location}, %arg, recurse => $recurse - 1, $cb);
355 } else {
356 $cb->($_[0], $_[1]);
357 }
358 };
359
360 if ($hdr{Status} =~ /^(?:1..|204|304)$/ or $method eq "HEAD") {
361 $finish->(undef, \%hdr);
362 } else {
363 if (exists $hdr{"content-length"}) {
364 $_[0]->unshift_read (chunk => $hdr{"content-length"}, sub {
365 # could cache persistent connection now
366 if ($hdr{connection} =~ /\bkeep-alive\b/i) {
367 # but we don't, due to misdesigns, this is annoyingly complex
368 };
369
370 $finish->($_[1], \%hdr);
371 });
372 } else {
373 # too bad, need to read until we get an error or EOF,
374 # no way to detect winged data.
375 $_[0]->on_error (sub {
376 $finish->($_[0]{rbuf}, \%hdr);
377 });
378 $_[0]->on_eof (undef);
379 $_[0]->on_read (sub { });
380 }
381 }
382 });
383 });
384 }, sub {
385 $timeout
386 }; 767 };
387 768
388 defined wantarray && AnyEvent::Util::guard { %state = () } 769 defined wantarray && AnyEvent::Util::guard { %state = () }
389} 770}
390 771
391sub http_get($$;@) { 772sub http_get($@) {
392 unshift @_, "GET"; 773 unshift @_, "GET";
393 &http_request 774 &http_request
394} 775}
395 776
396sub http_head($$;@) { 777sub http_head($@) {
397 unshift @_, "HEAD"; 778 unshift @_, "HEAD";
398 &http_request 779 &http_request
399} 780}
400 781
401sub http_post($$$;@) { 782sub http_post($$@) {
783 my $url = shift;
402 unshift @_, "POST", "body"; 784 unshift @_, "POST", $url, "body";
403 &http_request 785 &http_request
404} 786}
405 787
406=back 788=back
407 789
790=head2 DNS CACHING
791
792AnyEvent::HTTP uses the AnyEvent::Socket::tcp_connect function for
793the actual connection, which in turn uses AnyEvent::DNS to resolve
794hostnames. The latter is a simple stub resolver and does no caching
795on its own. If you want DNS caching, you currently have to provide
796your own default resolver (by storing a suitable resolver object in
797C<$AnyEvent::DNS::RESOLVER>).
798
408=head2 GLOBAL FUNCTIONS AND VARIABLES 799=head2 GLOBAL FUNCTIONS AND VARIABLES
409 800
410=over 4 801=over 4
411 802
412=item AnyEvent::HTTP::set_proxy "proxy-url" 803=item AnyEvent::HTTP::set_proxy "proxy-url"
413 804
414Sets the default proxy server to use. The proxy-url must begin with a 805Sets the default proxy server to use. The proxy-url must begin with a
415string of the form C<http://host:port> (optionally C<https:...>). 806string of the form C<http://host:port> (optionally C<https:...>), croaks
807otherwise.
808
809To clear an already-set proxy, use C<undef>.
810
811=item $date = AnyEvent::HTTP::format_date $timestamp
812
813Takes a POSIX timestamp (seconds since the epoch) and formats it as a HTTP
814Date (RFC 2616).
815
816=item $timestamp = AnyEvent::HTTP::parse_date $date
817
818Takes a HTTP Date (RFC 2616) and returns the corresponding POSIX
819timestamp, or C<undef> if the date cannot be parsed.
416 820
417=item $AnyEvent::HTTP::MAX_RECURSE 821=item $AnyEvent::HTTP::MAX_RECURSE
418 822
419The default value for the C<recurse> request parameter (default: C<10>). 823The default value for the C<recurse> request parameter (default: C<10>).
420 824
421=item $AnyEvent::HTTP::USERAGENT 825=item $AnyEvent::HTTP::USERAGENT
422 826
423The default value for the C<User-Agent> header (the default is 827The default value for the C<User-Agent> header (the default is
424C<Mozilla/5.0 (compatible; AnyEvent::HTTP/$VERSION; +http://software.schmorp.de/pkg/AnyEvent)>). 828C<Mozilla/5.0 (compatible; U; AnyEvent-HTTP/$VERSION; +http://software.schmorp.de/pkg/AnyEvent)>).
425 829
426=item $AnyEvent::HTTP::MAX_PERSISTENT 830=item $AnyEvent::HTTP::MAX_PER_HOST
427 831
428The maximum number of persistent connections to keep open (default: 8). 832The maximum number of concurrent connections to the same host (identified
833by the hostname). If the limit is exceeded, then the additional requests
834are queued until previous connections are closed.
429 835
430Not implemented currently. 836The default value for this is C<4>, and it is highly advisable to not
837increase it.
431 838
432=item $AnyEvent::HTTP::PERSISTENT_TIMEOUT 839=item $AnyEvent::HTTP::ACTIVE
433 840
434The maximum time to cache a persistent connection, in seconds (default: 2). 841The number of active connections. This is not the number of currently
435 842running requests, but the number of currently open and non-idle TCP
436Not implemented currently. 843connections. This number of can be useful for load-leveling.
437 844
438=back 845=back
439 846
440=cut 847=cut
441 848
849our @month = qw(Jan Feb Mar Apr May Jun Jul Aug Sep Oct Nov Dec);
850our @weekday = qw(Sun Mon Tue Wed Thu Fri Sat);
851
852sub format_date($) {
853 my ($time) = @_;
854
855 # RFC 822/1123 format
856 my ($S, $M, $H, $mday, $mon, $year, $wday, $yday, undef) = gmtime $time;
857
858 sprintf "%s, %02d %s %04d %02d:%02d:%02d GMT",
859 $weekday[$wday], $mday, $month[$mon], $year + 1900,
860 $H, $M, $S;
861}
862
863sub parse_date($) {
864 my ($date) = @_;
865
866 my ($d, $m, $y, $H, $M, $S);
867
868 if ($date =~ /^[A-Z][a-z][a-z], ([0-9][0-9]) ([A-Z][a-z][a-z]) ([0-9][0-9][0-9][0-9]) ([0-9][0-9]):([0-9][0-9]):([0-9][0-9]) GMT$/) {
869 # RFC 822/1123, required by RFC 2616
870 ($d, $m, $y, $H, $M, $S) = ($1, $2, $3, $4, $5, $6);
871
872 } elsif ($date =~ /^[A-Z][a-z]+, ([0-9][0-9])-([A-Z][a-z][a-z])-([0-9][0-9]) ([0-9][0-9]):([0-9][0-9]):([0-9][0-9]) GMT$/) {
873 # RFC 850
874 ($d, $m, $y, $H, $M, $S) = ($1, $2, $3 < 69 ? $3 + 2000 : $3 + 1900, $4, $5, $6);
875
876 } elsif ($date =~ /^[A-Z][a-z][a-z] ([A-Z][a-z][a-z]) ([0-9 ][0-9]) ([0-9][0-9]):([0-9][0-9]):([0-9][0-9]) ([0-9][0-9][0-9][0-9])$/) {
877 # ISO C's asctime
878 ($d, $m, $y, $H, $M, $S) = ($2, $1, $6, $3, $4, $5);
879 }
880 # other formats fail in the loop below
881
882 for (0..11) {
883 if ($m eq $month[$_]) {
884 require Time::Local;
885 return Time::Local::timegm ($S, $M, $H, $d, $_, $y);
886 }
887 }
888
889 undef
890}
891
442sub set_proxy($) { 892sub set_proxy($) {
893 if (length $_[0]) {
443 $PROXY = [$2, $3 || 3128, $1] if $_[0] =~ m%^(https?):// ([^:/]+) (?: : (\d*) )?%ix; 894 $_[0] =~ m%^(https?):// ([^:/]+) (?: : (\d*) )?%ix
895 or Carp::croak "$_[0]: invalid proxy URL";
896 $PROXY = [$2, $3 || 3128, $1]
897 } else {
898 undef $PROXY;
899 }
444} 900}
445 901
446# initialise proxy from environment 902# initialise proxy from environment
903eval {
447set_proxy $ENV{http_proxy}; 904 set_proxy $ENV{http_proxy};
905};
906
907=head2 SOCKS PROXIES
908
909Socks proxies are not directly supported by AnyEvent::HTTP. You can
910compile your perl to support socks, or use an external program such as
911F<socksify> (dante) or F<tsocks> to make your program use a socks proxy
912transparently.
913
914Alternatively, for AnyEvent::HTTP only, you can use your own
915C<tcp_connect> function that does the proxy handshake - here is an example
916that works with socks4a proxies:
917
918 use Errno;
919 use AnyEvent::Util;
920 use AnyEvent::Socket;
921 use AnyEvent::Handle;
922
923 # host, port and username of/for your socks4a proxy
924 my $socks_host = "10.0.0.23";
925 my $socks_port = 9050;
926 my $socks_user = "";
927
928 sub socks4a_connect {
929 my ($host, $port, $connect_cb, $prepare_cb) = @_;
930
931 my $hdl = new AnyEvent::Handle
932 connect => [$socks_host, $socks_port],
933 on_prepare => sub { $prepare_cb->($_[0]{fh}) },
934 on_error => sub { $connect_cb->() },
935 ;
936
937 $hdl->push_write (pack "CCnNZ*Z*", 4, 1, $port, 1, $socks_user, $host);
938
939 $hdl->push_read (chunk => 8, sub {
940 my ($hdl, $chunk) = @_;
941 my ($status, $port, $ipn) = unpack "xCna4", $chunk;
942
943 if ($status == 0x5a) {
944 $connect_cb->($hdl->{fh}, (format_address $ipn) . ":$port");
945 } else {
946 $! = Errno::ENXIO; $connect_cb->();
947 }
948 });
949
950 $hdl
951 }
952
953Use C<socks4a_connect> instead of C<tcp_connect> when doing C<http_request>s,
954possibly after switching off other proxy types:
955
956 AnyEvent::HTTP::set_proxy undef; # usually you do not want other proxies
957
958 http_get 'http://www.google.com', tcp_connect => \&socks4a_connect, sub {
959 my ($data, $headers) = @_;
960 ...
961 };
448 962
449=head1 SEE ALSO 963=head1 SEE ALSO
450 964
451L<AnyEvent>. 965L<AnyEvent>.
452 966
453=head1 AUTHOR 967=head1 AUTHOR
454 968
455 Marc Lehmann <schmorp@schmorp.de> 969 Marc Lehmann <schmorp@schmorp.de>
456 http://home.schmorp.de/ 970 http://home.schmorp.de/
971
972With many thanks to Дмитрий Шалашов, who provided countless
973testcases and bugreports.
457 974
458=cut 975=cut
459 976
4601 9771
461 978

Diff Legend

Removed lines
+ Added lines
< Changed lines
> Changed lines