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.47 by root, Wed Aug 5 16:07:48 2009 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 4.8 ();
43use AnyEvent::Util (); 47use AnyEvent::Util ();
44use AnyEvent::Socket (); 48use AnyEvent::Socket ();
45use AnyEvent::Handle (); 49use AnyEvent::Handle ();
46 50
47use base Exporter::; 51use base Exporter::;
48 52
49our $VERSION = '1.01'; 53our $VERSION = '1.41';
50 54
51our @EXPORT = qw(http_get http_request); 55our @EXPORT = qw(http_get http_post http_head http_request);
52 56
53our $USERAGENT = "Mozilla/5.0 (compatible; AnyEvent::HTTP/$VERSION; +http://software.schmorp.de/pkg/AnyEvent)"; 57our $USERAGENT = "Mozilla/5.0 (compatible; U; AnyEvent-HTTP/$VERSION; +http://software.schmorp.de/pkg/AnyEvent)";
54our $MAX_RECURSE = 10; 58our $MAX_RECURSE = 10;
55our $MAX_PERSISTENT = 8; 59our $MAX_PERSISTENT = 8;
56our $PERSISTENT_TIMEOUT = 2; 60our $PERSISTENT_TIMEOUT = 2;
57our $TIMEOUT = 300; 61our $TIMEOUT = 300;
58 62
59# changing these is evil 63# changing these is evil
60our $MAX_PERSISTENT_PER_HOST = 2; 64our $MAX_PERSISTENT_PER_HOST = 0;
61our $MAX_PER_HOST = 4; 65our $MAX_PER_HOST = 4;
62 66
63our $PROXY; 67our $PROXY;
64our $ACTIVE = 0; 68our $ACTIVE = 0;
65 69
67my %CO_SLOT; # number of open connections, and wait queue, per host 71my %CO_SLOT; # number of open connections, and wait queue, per host
68 72
69=item http_get $url, key => value..., $cb->($data, $headers) 73=item http_get $url, key => value..., $cb->($data, $headers)
70 74
71Executes an HTTP-GET request. See the http_request function for details on 75Executes an HTTP-GET request. See the http_request function for details on
72additional parameters. 76additional parameters and the return value.
73 77
74=item http_head $url, key => value..., $cb->($data, $headers) 78=item http_head $url, key => value..., $cb->($data, $headers)
75 79
76Executes an HTTP-HEAD request. See the http_request function for details on 80Executes an HTTP-HEAD request. See the http_request function for details
77additional parameters. 81on additional parameters and the return value.
78 82
79=item http_post $url, $body, key => value..., $cb->($data, $headers) 83=item http_post $url, $body, key => value..., $cb->($data, $headers)
80 84
81Executes an HTTP-POST request with a request body of C<$bod>. See the 85Executes an HTTP-POST request with a request body of C<$body>. See the
82http_request function for details on additional parameters. 86http_request function for details on additional parameters and the return
87value.
83 88
84=item http_request $method => $url, key => value..., $cb->($data, $headers) 89=item http_request $method => $url, key => value..., $cb->($data, $headers)
85 90
86Executes a HTTP request of type C<$method> (e.g. C<GET>, C<POST>). The URL 91Executes a HTTP request of type C<$method> (e.g. C<GET>, C<POST>). The URL
87must be an absolute http or https URL. 92must be an absolute http or https URL.
88 93
94When called in void context, nothing is returned. In other contexts,
95C<http_request> returns a "cancellation guard" - you have to keep the
96object at least alive until the callback get called. If the object gets
97destroyed before the callbakc is called, the request will be cancelled.
98
89The callback will be called with the response data as first argument 99The 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 100(or C<undef> if an error occured), and a hash-ref with response headers as
91response headers as second argument. 101second argument.
92 102
93All the headers in that hash are lowercased. In addition to the response 103All the headers in that hash are lowercased. In addition to the response
94headers, the three "pseudo-headers" C<HTTPVersion>, C<Status> and 104headers, the "pseudo-headers" C<HTTPVersion>, C<Status> and C<Reason>
95C<Reason> contain the three parts of the HTTP Status-Line of the same 105contain the three parts of the HTTP Status-Line of the same name. The
106pseudo-header C<URL> contains the original URL (which can differ from the
107requested URL when following redirects).
108
96name. If the server sends a header multiple lines, then their contents 109If the server sends a header multiple times, then their contents will be
97will be joined together with C<\x00>. 110joined together with a comma (C<,>), as per the HTTP spec.
98 111
99If an internal error occurs, such as not being able to resolve a hostname, 112If 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> 113then C<$data> will be C<undef>, C<< $headers->{Status} >> will be C<59x>
101and the C<Reason> pseudo-header will contain an error message. 114(usually C<599>) and the C<Reason> pseudo-header will contain an error
115message.
102 116
103A typical callback might look like this: 117A typical callback might look like this:
104 118
105 sub { 119 sub {
106 my ($body, $hdr) = @_; 120 my ($body, $hdr) = @_;
124 138
125=item headers => hashref 139=item headers => hashref
126 140
127The request headers to use. Currently, C<http_request> may provide its 141The request headers to use. Currently, C<http_request> may provide its
128own C<Host:>, C<Content-Length:>, C<Connection:> and C<Cookie:> headers 142own C<Host:>, C<Content-Length:>, C<Connection:> and C<Cookie:> headers
129and will provide defaults for C<User-Agent:> and C<Referer:>. 143and will provide defaults for C<User-Agent:> and C<Referer:> (this can be
144suppressed by using C<undef> for these headers in which case they won't be
145send at all).
130 146
131=item timeout => $seconds 147=item timeout => $seconds
132 148
133The time-out to use for various stages - each connect attempt will reset 149The 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. 150the timeout, as will read or write activity. Default timeout is 5 minutes.
136=item proxy => [$host, $port[, $scheme]] or undef 152=item proxy => [$host, $port[, $scheme]] or undef
137 153
138Use the given http proxy for all requests. If not specified, then the 154Use the given http proxy for all requests. If not specified, then the
139default proxy (as specified by C<$ENV{http_proxy}>) is used. 155default proxy (as specified by C<$ENV{http_proxy}>) is used.
140 156
141C<$scheme> must be either missing or C<http> for HTTP, or C<https> for 157C<$scheme> must be either missing, C<http> for HTTP or C<https> for
142HTTPS. 158HTTPS.
143 159
144=item body => $string 160=item body => $string
145 161
146The request body, usually empty. Will be-sent as-is (future versions of 162The request body, usually empty. Will be-sent as-is (future versions of
152based on the original netscape specification. 168based on the original netscape specification.
153 169
154The C<$hash_ref> must be an (initially empty) hash reference which will 170The C<$hash_ref> must be an (initially empty) hash reference which will
155get updated automatically. It is possible to save the cookie_jar to 171get updated automatically. It is possible to save the cookie_jar to
156persistent storage with something like JSON or Storable, but this is not 172persistent storage with something like JSON or Storable, but this is not
157recommended, as expire times are currently being ignored. 173recommended, as expiry times are currently being ignored.
158 174
159Note that this cookie implementation is not of very high quality, nor 175Note that this cookie implementation is not of very high quality, nor
160meant to be complete. If you want complete cookie management you have to 176meant 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 177do 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 178cookie-using sites working. Cookies are a privacy disaster, do not use
163them unless required to. 179them unless required to.
180
181=item tls_ctx => $scheme | $tls_ctx
182
183Specifies the AnyEvent::TLS context to be used for https connections. This
184parameter follows the same rules as the C<tls_ctx> parameter to
185L<AnyEvent::Handle>, but additionally, the two strings C<low> or
186C<high> can be specified, which give you a predefined low-security (no
187verification, highest compatibility) and high-security (CA and common-name
188verification) TLS context.
189
190The default for this option is C<low>, which could be interpreted as "give
191me the page, no matter what".
192
193=item on_header => $callback->($headers)
194
195When specified, this callback will be called with the header hash as soon
196as headers have been successfully received from the remote server (not on
197locally-generated errors).
198
199It has to return either true (in which case AnyEvent::HTTP will continue),
200or false, in which case AnyEvent::HTTP will cancel the download (and call
201the finish callback with an error code of C<598>).
202
203This callback is useful, among other things, to quickly reject unwanted
204content, which, if it is supposed to be rare, can be faster than first
205doing a C<HEAD> request.
206
207Example: cancel the request unless the content-type is "text/html".
208
209 on_header => sub {
210 $_[0]{"content-type"} =~ /^text\/html\s*(?:;|$)/
211 },
212
213=item on_body => $callback->($partial_body, $headers)
214
215When specified, all body data will be passed to this callback instead of
216to the completion callback. The completion callback will get the empty
217string instead of the body data.
218
219It has to return either true (in which case AnyEvent::HTTP will continue),
220or false, in which case AnyEvent::HTTP will cancel the download (and call
221the completion callback with an error code of C<598>).
222
223This callback is useful when the data is too large to be held in memory
224(so the callback writes it to a file) or when only some information should
225be extracted, or when the body should be processed incrementally.
226
227It is usually preferred over doing your own body handling via
228C<want_body_handle>, but in case of streaming APIs, where HTTP is
229only used to create a connection, C<want_body_handle> is the better
230alternative, as it allows you to install your own event handler, reducing
231resource usage.
232
233=item want_body_handle => $enable
234
235When enabled (default is disabled), the behaviour of AnyEvent::HTTP
236changes considerably: after parsing the headers, and instead of
237downloading the body (if any), the completion callback will be
238called. Instead of the C<$body> argument containing the body data, the
239callback will receive the L<AnyEvent::Handle> object associated with the
240connection. In error cases, C<undef> will be passed. When there is no body
241(e.g. status C<304>), the empty string will be passed.
242
243The handle object might or might not be in TLS mode, might be connected to
244a proxy, be a persistent connection etc., and configured in unspecified
245ways. The user is responsible for this handle (it will not be used by this
246module anymore).
247
248This is useful with some push-type services, where, after the initial
249headers, an interactive protocol is used (typical example would be the
250push-style twitter API which starts a JSON/XML stream).
251
252If you think you need this, first have a look at C<on_body>, to see if
253that doesn't solve your problem in a better way.
164 254
165=back 255=back
166 256
167Example: make a simple HTTP GET request for http://www.nethype.de/ 257Example: make a simple HTTP GET request for http://www.nethype.de/
168 258
181 my ($body, $hdr) = @_; 271 my ($body, $hdr) = @_;
182 use Data::Dumper; 272 use Data::Dumper;
183 print Dumper $hdr; 273 print Dumper $hdr;
184 } 274 }
185 ; 275 ;
276
277Example: make another simple HTTP GET request, but immediately try to
278cancel it.
279
280 my $request = http_request GET => "http://www.nethype.de/", sub {
281 my ($body, $hdr) = @_;
282 print "$body\n";
283 };
284
285 undef $request;
186 286
187=cut 287=cut
188 288
189sub _slot_schedule; 289sub _slot_schedule;
190sub _slot_schedule($) { 290sub _slot_schedule($) {
214 push @{ $CO_SLOT{$_[0]}[1] }, $_[1]; 314 push @{ $CO_SLOT{$_[0]}[1] }, $_[1];
215 315
216 _slot_schedule $_[0]; 316 _slot_schedule $_[0];
217} 317}
218 318
319our $qr_nl = qr{\015?\012};
320our $qr_nlnl = qr{(?<![^\012])\015?\012};
321
322our $TLS_CTX_LOW = { cache => 1, sslv2 => 1 };
323our $TLS_CTX_HIGH = { cache => 1, verify => 1, verify_peername => "https" };
324
219sub http_request($$@) { 325sub http_request($$@) {
220 my $cb = pop; 326 my $cb = pop;
221 my ($method, $url, %arg) = @_; 327 my ($method, $url, %arg) = @_;
222 328
223 my %hdr; 329 my %hdr;
330
331 $arg{tls_ctx} = $TLS_CTX_LOW if $arg{tls_ctx} eq "low" || !exists $arg{tls_ctx};
332 $arg{tls_ctx} = $TLS_CTX_HIGH if $arg{tls_ctx} eq "high";
224 333
225 $method = uc $method; 334 $method = uc $method;
226 335
227 if (my $hdr = $arg{headers}) { 336 if (my $hdr = $arg{headers}) {
228 while (my ($k, $v) = each %$hdr) { 337 while (my ($k, $v) = each %$hdr) {
229 $hdr{lc $k} = $v; 338 $hdr{lc $k} = $v;
230 } 339 }
231 } 340 }
232 341
233 my $recurse = exists $arg{recurse} ? $arg{recurse} : $MAX_RECURSE; 342 my $recurse = exists $arg{recurse} ? delete $arg{recurse} : $MAX_RECURSE;
234 343
235 return $cb->(undef, { Status => 599, Reason => "recursion limit reached" }) 344 return $cb->(undef, { Status => 599, Reason => "Too many redirections", URL => $url })
236 if $recurse < 0; 345 if $recurse < 0;
237 346
238 my $proxy = $arg{proxy} || $PROXY; 347 my $proxy = $arg{proxy} || $PROXY;
239 my $timeout = $arg{timeout} || $TIMEOUT; 348 my $timeout = $arg{timeout} || $TIMEOUT;
240 349
241 $hdr{"user-agent"} ||= $USERAGENT;
242
243 my ($scheme, $authority, $upath, $query, $fragment) = 350 my ($uscheme, $uauthority, $upath, $query, $fragment) =
244 $url =~ m|(?:([^:/?#]+):)?(?://([^/?#]*))?([^?#]*)(?:\?([^#]*))?(?:#(.*))?|; 351 $url =~ m|(?:([^:/?#]+):)?(?://([^/?#]*))?([^?#]*)(?:\?([^#]*))?(?:#(.*))?|;
245 352
246 $scheme = lc $scheme; 353 $uscheme = lc $uscheme;
247 354
248 my $uport = $scheme eq "http" ? 80 355 my $uport = $uscheme eq "http" ? 80
249 : $scheme eq "https" ? 443 356 : $uscheme eq "https" ? 443
250 : return $cb->(undef, { Status => 599, Reason => "only http and https URL schemes supported" }); 357 : return $cb->(undef, { Status => 599, Reason => "Only http and https URL schemes supported", URL => $url });
251 358
252 $hdr{referer} ||= "$scheme://$authority$upath"; # leave out fragment and query string, just a heuristic
253
254 $authority =~ /^(?: .*\@ )? ([^\@:]+) (?: : (\d+) )?$/x 359 $uauthority =~ /^(?: .*\@ )? ([^\@:]+) (?: : (\d+) )?$/x
255 or return $cb->(undef, { Status => 599, Reason => "unparsable URL" }); 360 or return $cb->(undef, { Status => 599, Reason => "Unparsable URL", URL => $url });
256 361
257 my $uhost = $1; 362 my $uhost = $1;
258 $uport = $2 if defined $2; 363 $uport = $2 if defined $2;
259 364
365 $hdr{host} = defined $2 ? "$uhost:$2" : "$uhost";
366
260 $uhost =~ s/^\[(.*)\]$/$1/; 367 $uhost =~ s/^\[(.*)\]$/$1/;
261 $upath .= "?$query" if length $query; 368 $upath .= "?$query" if length $query;
262 369
263 $upath =~ s%^/?%/%; 370 $upath =~ s%^/?%/%;
264 371
265 # cookie processing 372 # cookie processing
266 if (my $jar = $arg{cookie_jar}) { 373 if (my $jar = $arg{cookie_jar}) {
267 %$jar = () if $jar->{version} < 1; 374 %$jar = () if $jar->{version} != 1;
268 375
269 my @cookie; 376 my @cookie;
270 377
271 while (my ($chost, $v) = each %$jar) { 378 while (my ($chost, $v) = each %$jar) {
379 if ($chost =~ /^\./) {
272 next unless $chost eq substr $uhost, -length $chost; 380 next unless $chost eq substr $uhost, -length $chost;
273 next unless $chost =~ /^\./; 381 } elsif ($chost =~ /\./) {
382 next unless $chost eq $uhost;
383 } else {
384 next;
385 }
274 386
275 while (my ($cpath, $v) = each %$v) { 387 while (my ($cpath, $v) = each %$v) {
276 next unless $cpath eq substr $upath, 0, length $cpath; 388 next unless $cpath eq substr $upath, 0, length $cpath;
277 389
278 while (my ($k, $v) = each %$v) { 390 while (my ($k, $v) = each %$v) {
279 next if $scheme ne "https" && exists $v->{secure}; 391 next if $uscheme ne "https" && exists $v->{secure};
392 my $value = $v->{value};
393 $value =~ s/([\\"])/\\$1/g;
280 push @cookie, "$k=$v->{value}"; 394 push @cookie, "$k=\"$value\"";
281 } 395 }
282 } 396 }
283 } 397 }
284 398
285 $hdr{cookie} = join "; ", @cookie 399 $hdr{cookie} = join "; ", @cookie
286 if @cookie; 400 if @cookie;
287 } 401 }
288 402
289 my ($rhost, $rport, $rpath); # request host, port, path 403 my ($rhost, $rport, $rscheme, $rpath); # request host, port, path
290 404
291 if ($proxy) { 405 if ($proxy) {
292 ($rhost, $rport, $scheme) = @$proxy; 406 ($rpath, $rhost, $rport, $rscheme) = ($url, @$proxy);
293 $rpath = $url; 407
408 $rscheme = "http" unless defined $rscheme;
409
410 # don't support https requests over https-proxy transport,
411 # can't be done with tls as spec'ed, unless you double-encrypt.
412 $rscheme = "http" if $uscheme eq "https" && $rscheme eq "https";
294 } else { 413 } else {
295 ($rhost, $rport, $rpath) = ($uhost, $uport, $upath); 414 ($rhost, $rport, $rscheme, $rpath) = ($uhost, $uport, $uscheme, $upath);
296 $hdr{host} = $uhost;
297 } 415 }
416
417 # leave out fragment and query string, just a heuristic
418 $hdr{referer} ||= "$uscheme://$uauthority$upath" unless exists $hdr{referer};
419 $hdr{"user-agent"} ||= $USERAGENT unless exists $hdr{"user-agent"};
298 420
299 $hdr{"content-length"} = length $arg{body}; 421 $hdr{"content-length"} = length $arg{body};
300 422
301 my %state = (connect_guard => 1); 423 my %state = (connect_guard => 1);
302 424
305 427
306 return unless $state{connect_guard}; 428 return unless $state{connect_guard};
307 429
308 $state{connect_guard} = AnyEvent::Socket::tcp_connect $rhost, $rport, sub { 430 $state{connect_guard} = AnyEvent::Socket::tcp_connect $rhost, $rport, sub {
309 $state{fh} = shift 431 $state{fh} = shift
432 or do {
433 my $err = "$!";
434 %state = ();
310 or return $cb->(undef, { Status => 599, Reason => "$!" }); 435 return $cb->(undef, { Status => 599, Reason => $err, URL => $url });
436 };
311 437
312 delete $state{connect_guard}; # reduce memory usage, save a tree 438 pop; # free memory, save a tree
439
440 return unless delete $state{connect_guard};
313 441
314 # get handle 442 # get handle
315 $state{handle} = new AnyEvent::Handle 443 $state{handle} = new AnyEvent::Handle
316 fh => $state{fh}, 444 fh => $state{fh},
317 ($scheme eq "https" ? (tls => "connect") : ()); 445 timeout => $timeout,
446 peername => $rhost,
447 tls_ctx => $arg{tls_ctx};
318 448
319 # limit the number of persistent connections 449 # limit the number of persistent connections
450 # keepalive not yet supported
320 if ($KA_COUNT{$_[1]} < $MAX_PERSISTENT_PER_HOST) { 451 if ($KA_COUNT{$_[1]} < $MAX_PERSISTENT_PER_HOST) {
321 ++$KA_COUNT{$_[1]}; 452 ++$KA_COUNT{$_[1]};
322 $state{handle}{ka_count_guard} = AnyEvent::Util::guard { --$KA_COUNT{$_[1]} }; 453 $state{handle}{ka_count_guard} = AnyEvent::Util::guard {
454 --$KA_COUNT{$_[1]}
455 };
323 $hdr{connection} = "keep-alive"; 456 $hdr{connection} = "keep-alive";
324 delete $hdr{connection}; # keep-alive not yet supported
325 } else { 457 } else {
326 delete $hdr{connection}; 458 delete $hdr{connection};
327 } 459 }
328 460
329 # (re-)configure handle 461 # (re-)configure handle
330 $state{handle}->timeout ($timeout);
331 $state{handle}->on_error (sub { 462 $state{handle}->on_error (sub {
332 my $errno = "$!";
333 %state = (); 463 %state = ();
334 $cb->(undef, { Status => 599, Reason => $errno }); 464 $cb->(undef, { Status => 599, Reason => $_[2], URL => $url });
335 }); 465 });
336 $state{handle}->on_eof (sub { 466 $state{handle}->on_eof (sub {
337 %state = (); 467 %state = ();
338 $cb->(undef, { Status => 599, Reason => "unexpected end-of-file" }); 468 $cb->(undef, { Status => 599, Reason => "Unexpected end-of-file", URL => $url });
339 }); 469 });
340 470
471 $state{handle}->starttls ("connect") if $rscheme eq "https";
472
473 # handle actual, non-tunneled, request
474 my $handle_actual_request = sub {
475 $state{handle}->starttls ("connect") if $uscheme eq "https" && !exists $state{handle}{tls};
476
341 # send request 477 # send request
342 $state{handle}->push_write ( 478 $state{handle}->push_write (
343 "$method $rpath HTTP/1.0\015\012" 479 "$method $rpath HTTP/1.0\015\012"
344 . (join "", map "$_: $hdr{$_}\015\012", keys %hdr) 480 . (join "", map "\u$_: $hdr{$_}\015\012", grep defined $hdr{$_}, keys %hdr)
345 . "\015\012" 481 . "\015\012"
346 . (delete $arg{body}) 482 . (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 ); 483 );
361 484
485 %hdr = (); # reduce memory usage, save a kitten
486
487 # status line
488 $state{handle}->push_read (line => $qr_nl, sub {
489 $_[1] =~ /^HTTP\/([0-9\.]+) \s+ ([0-9]{3}) (?: \s+ ([^\015\012]*) )?/ix
490 or return (%state = (), $cb->(undef, { Status => 599, Reason => "Invalid server response ($_[1])", URL => $url }));
491
492 my %hdr = ( # response headers
493 HTTPVersion => ",$1",
494 Status => ",$2",
495 Reason => ",$3",
496 URL => ",$url"
497 );
498
362 # headers, could be optimized a bit 499 # headers, could be optimized a bit
363 $state{handle}->unshift_read (line => qr/\015?\012\015?\012/, sub { 500 $state{handle}->unshift_read (line => $qr_nlnl, sub {
364 for ("$_[1]\012") { 501 for ("$_[1]") {
365 # we support spaces in field names, as lotus domino 502 y/\015//d; # weed out any \015, as they show up in the weirdest of places.
366 # creates them. 503
504 # things seen, not parsed:
505 # p3pP="NON CUR OTPi OUR NOR UNI"
506
367 $hdr{lc $1} .= "\x00$2" 507 $hdr{lc $1} .= ",$2"
368 while /\G 508 while /\G
369 ([^:\000-\037]+): 509 ([^:\000-\037]*):
370 [\011\040]* 510 [\011\040]*
371 ((?: [^\015\012]+ | \015?\012[\011\040] )*) 511 ((?: [^\012]+ | \012[\011\040] )*)
372 \015?\012 512 \012
373 /gxc; 513 /gxc;
374 514
375 /\G$/ 515 /\G$/
376 or return (%state = (), $cb->(undef, { Status => 599, Reason => "garbled response headers" })); 516 or return (%state = (), $cb->(undef, { Status => 599, Reason => "Garbled response headers", URL => $url }));
377 } 517 }
378 518
379 substr $_, 0, 1, "" 519 substr $_, 0, 1, ""
380 for values %hdr; 520 for values %hdr;
381 521
382 my $finish = sub { 522 # redirect handling
383 %state = (); 523 # microsoft and other shitheads don't give a shit for following standards,
524 # try to support some common forms of broken Location headers.
525 if ($hdr{location} !~ /^(?: $ | [^:\/?\#]+ : )/x) {
526 $hdr{location} =~ s/^\.\/+//;
384 527
385 # set-cookie processing 528 my $url = "$rscheme://$uhost:$uport";
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 529
397 next if $cdom =~ /\.$/; 530 unless ($hdr{location} =~ s/^\///) {
398 531 $url .= $upath;
399 # this is not rfc-like and not netscape-like. go figure. 532 $url =~ s/\/[^\/]*$//;
400 my $ndots = $cdom =~ y/.//; 533 }
401 next if $ndots < ($cdom =~ /\.[^.][^.]\.[^.][^.]$/ ? 3 : 2); 534
402 535 $hdr{location} = "$url/$hdr{location}";
536 }
537
538 my $redirect;
539
540 if ($recurse) {
541 if ($hdr{Status} =~ /^30[12]$/ && $method ne "POST") {
542 # apparently, mozilla et al. just change POST to GET here
543 # more research is needed before we do the same
403 # store it 544 $redirect = 1;
404 $arg{cookie_jar}{version} = 1; 545 } elsif ($hdr{Status} == 303) {
405 $arg{cookie_jar}{$cdom}{$cpath}{$name} = \%kv; 546 # even http/1.1 is unclear on how to mutate the method
547 $method = "GET" unless $method eq "HEAD";
548 $redirect = 1;
549 } elsif ($hdr{Status} == 307 && $method =~ /^(?:GET|HEAD)$/) {
550 $redirect = 1;
406 } 551 }
407 } 552 }
408 553
409 if ($_[1]{Status} =~ /^30[12]$/ && $recurse) { 554 my $finish = sub {
410 # microsoft and other assholes don't give a shit for following standards, 555 $state{handle}->destroy if $state{handle};
411 # try to support a common form of broken Location header. 556 %state = ();
412 $_[1]{location} =~ s%^/%$scheme://$uhost:$uport/%;
413 557
558 # set-cookie processing
559 if ($arg{cookie_jar}) {
560 for ($_[1]{"set-cookie"}) {
561 # parse NAME=VALUE
562 my @kv;
563
564 while (/\G\s* ([^=;,[:space:]]+) \s*=\s* (?: "((?:[^\\"]+|\\.)*)" | ([^=;,[:space:]]*) )/gcxs) {
565 my $name = $1;
566 my $value = $3;
567
568 unless ($value) {
569 $value = $2;
570 $value =~ s/\\(.)/$1/gs;
571 }
572
573 push @kv, $name => $value;
574
575 last unless /\G\s*;/gc;
576 }
577
578 last unless @kv;
579
580 my $name = shift @kv;
581 my %kv = (value => shift @kv, @kv);
582
583 my $cdom;
584 my $cpath = (delete $kv{path}) || "/";
585
586 if (exists $kv{domain}) {
587 $cdom = delete $kv{domain};
588
589 $cdom =~ s/^\.?/./; # make sure it starts with a "."
590
591 next if $cdom =~ /\.$/;
592
593 # this is not rfc-like and not netscape-like. go figure.
594 my $ndots = $cdom =~ y/.//;
595 next if $ndots < ($cdom =~ /\.[^.][^.]\.[^.][^.]$/ ? 3 : 2);
596 } else {
597 $cdom = $uhost;
598 }
599
600 # store it
601 $arg{cookie_jar}{version} = 1;
602 $arg{cookie_jar}{$cdom}{$cpath}{$name} = \%kv;
603
604 redo if /\G\s*,/gc;
605 }
606 }
607
608 if ($redirect && exists $hdr{location}) {
609 # we ignore any errors, as it is very common to receive
610 # Content-Length != 0 but no actual body
611 # we also access %hdr, as $_[1] might be an erro
414 http_request ($method, $_[1]{location}, %arg, recurse => $recurse - 1, $cb); 612 http_request ($method => $hdr{location}, %arg, recurse => $recurse - 1, $cb);
613 } else {
614 $cb->($_[0], $_[1]);
615 }
616 };
617
618 my $len = $hdr{"content-length"};
619
620 if (!$redirect && $arg{on_header} && !$arg{on_header}(\%hdr)) {
621 $finish->(undef, { Status => 598, Reason => "Request cancelled by on_header", URL => $url });
622 } elsif (
623 $hdr{Status} =~ /^(?:1..|[23]04)$/
624 or $method eq "HEAD"
625 or (defined $len && !$len)
626 ) {
627 # no body
628 $finish->("", \%hdr);
415 } else { 629 } else {
416 $cb->($_[0], $_[1]); 630 # body handling, four different code paths
631 # for want_body_handle, on_body (2x), normal (2x)
632 # we might read too much here, but it does not matter yet (no pers. connections)
633 if (!$redirect && $arg{want_body_handle}) {
634 $_[0]->on_eof (undef);
635 $_[0]->on_error (undef);
636 $_[0]->on_read (undef);
637
638 $finish->(delete $state{handle}, \%hdr);
639
640 } elsif ($arg{on_body}) {
641 $_[0]->on_error (sub { $finish->(undef, { Status => 599, Reason => $_[2], URL => $url }) });
642 if ($len) {
643 $_[0]->on_eof (undef);
644 $_[0]->on_read (sub {
645 $len -= length $_[0]{rbuf};
646
647 $arg{on_body}(delete $_[0]{rbuf}, \%hdr)
648 or $finish->(undef, { Status => 598, Reason => "Request cancelled by on_body", URL => $url });
649
650 $len > 0
651 or $finish->("", \%hdr);
652 });
653 } else {
654 $_[0]->on_eof (sub {
655 $finish->("", \%hdr);
656 });
657 $_[0]->on_read (sub {
658 $arg{on_body}(delete $_[0]{rbuf}, \%hdr)
659 or $finish->(undef, { Status => 598, Reason => "Request cancelled by on_body", URL => $url });
660 });
661 }
662 } else {
663 $_[0]->on_eof (undef);
664
665 if ($len) {
666 $_[0]->on_error (sub { $finish->(undef, { Status => 599, Reason => $_[2], URL => $url }) });
667 $_[0]->on_read (sub {
668 $finish->((substr delete $_[0]{rbuf}, 0, $len, ""), \%hdr)
669 if $len <= length $_[0]{rbuf};
670 });
671 } else {
672 $_[0]->on_error (sub {
673 $! == Errno::EPIPE || !$!
674 ? $finish->(delete $_[0]{rbuf}, \%hdr)
675 : $finish->(undef, { Status => 599, Reason => $_[2], URL => $url });
676 });
677 $_[0]->on_read (sub { });
678 }
679 }
417 } 680 }
418 }; 681 });
682 });
683 };
419 684
420 if ($hdr{Status} =~ /^(?:1..|204|304)$/ or $method eq "HEAD") { 685 # now handle proxy-CONNECT method
421 $finish->(undef, \%hdr); 686 if ($proxy && $uscheme eq "https") {
687 # oh dear, we have to wrap it into a connect request
688
689 # maybe re-use $uauthority with patched port?
690 $state{handle}->push_write ("CONNECT $uhost:$uport HTTP/1.0\015\012Host: $uhost\015\012\015\012");
691 $state{handle}->push_read (line => $qr_nlnl, sub {
692 $_[1] =~ /^HTTP\/([0-9\.]+) \s+ ([0-9]{3}) (?: \s+ ([^\015\012]*) )?/ix
693 or return (%state = (), $cb->(undef, { Status => 599, Reason => "Invalid proxy connect response ($_[1])", URL => $url }));
694
695 if ($2 == 200) {
696 $rpath = $upath;
697 &$handle_actual_request;
422 } else { 698 } else {
423 if (exists $hdr{"content-length"}) { 699 %state = ();
424 $_[0]->unshift_read (chunk => $hdr{"content-length"}, sub { 700 $cb->(undef, { Status => $2, Reason => $3, URL => $url });
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
430 $finish->($_[1], \%hdr);
431 });
432 } 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 });
438 $_[0]->on_eof (undef);
439 $_[0]->on_read (sub { });
440 }
441 } 701 }
442 }); 702 });
703 } else {
704 &$handle_actual_request;
443 }); 705 }
706
444 }, sub { 707 }, sub {
445 $timeout 708 $timeout
446 }; 709 };
447 }; 710 };
448 711
458 unshift @_, "HEAD"; 721 unshift @_, "HEAD";
459 &http_request 722 &http_request
460} 723}
461 724
462sub http_post($$@) { 725sub http_post($$@) {
726 my $url = shift;
463 unshift @_, "POST", "body"; 727 unshift @_, "POST", $url, "body";
464 &http_request 728 &http_request
465} 729}
466 730
467=back 731=back
468 732
480The default value for the C<recurse> request parameter (default: C<10>). 744The default value for the C<recurse> request parameter (default: C<10>).
481 745
482=item $AnyEvent::HTTP::USERAGENT 746=item $AnyEvent::HTTP::USERAGENT
483 747
484The default value for the C<User-Agent> header (the default is 748The 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)>). 749C<Mozilla/5.0 (compatible; U; AnyEvent-HTTP/$VERSION; +http://software.schmorp.de/pkg/AnyEvent)>).
486 750
487=item $AnyEvent::HTTP::MAX_PERSISTENT 751=item $AnyEvent::HTTP::MAX_PER_HOST
488 752
489The maximum number of persistent connections to keep open (default: 8). 753The maximum number of concurrent connections to the same host (identified
754by the hostname). If the limit is exceeded, then the additional requests
755are queued until previous connections are closed.
490 756
491Not implemented currently. 757The default value for this is C<4>, and it is highly advisable to not
492 758increase 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 759
499=item $AnyEvent::HTTP::ACTIVE 760=item $AnyEvent::HTTP::ACTIVE
500 761
501The number of active connections. This is not the number of currently 762The number of active connections. This is not the number of currently
502running requests, but the number of currently open and non-idle TCP 763running requests, but the number of currently open and non-idle TCP
517 778
518L<AnyEvent>. 779L<AnyEvent>.
519 780
520=head1 AUTHOR 781=head1 AUTHOR
521 782
522 Marc Lehmann <schmorp@schmorp.de> 783 Marc Lehmann <schmorp@schmorp.de>
523 http://home.schmorp.de/ 784 http://home.schmorp.de/
785
786With many thanks to Дмитрий Шалашов, who provided countless
787testcases and bugreports.
524 788
525=cut 789=cut
526 790
5271 7911
528 792

Diff Legend

Removed lines
+ Added lines
< Changed lines
> Changed lines