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

Diff Legend

Removed lines
+ Added lines
< Changed lines
> Changed lines