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.12 by root, Thu Jun 5 16:33:02 2008 UTC vs.
Revision 1.40 by root, Sun Jul 5 01:45:01 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.
… …
37use strict; 41use strict;
38no warnings; 42no warnings;
39 43
40use Carp; 44use Carp;
41 45
42use AnyEvent (); 46use AnyEvent 4.452 ();
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.0'; 53our $VERSION = '1.12';
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 = 2;
61our $MAX_PER_HOST = 4; 65our $MAX_PER_HOST = 4;
62 66
63our $PROXY; 67our $PROXY;
68our $ACTIVE = 0;
64 69
65my %KA_COUNT; # number of open keep-alive connections per host 70my %KA_COUNT; # number of open keep-alive connections per host
66my %CO_SLOT; # number of open connections, and wait queue, per host 71my %CO_SLOT; # number of open connections, and wait queue, per host
67 72
68=item http_get $url, key => value..., $cb->($data, $headers) 73=item http_get $url, key => value..., $cb->($data, $headers)
69 74
70Executes 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
71additional parameters. 76additional parameters and the return value.
72 77
73=item http_head $url, key => value..., $cb->($data, $headers) 78=item http_head $url, key => value..., $cb->($data, $headers)
74 79
75Executes an HTTP-HEAD request. See the http_request function for details on 80Executes an HTTP-HEAD request. See the http_request function for details
76additional parameters. 81on additional parameters and the return value.
77 82
78=item http_post $url, $body, key => value..., $cb->($data, $headers) 83=item http_post $url, $body, key => value..., $cb->($data, $headers)
79 84
80Executes 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
81http_request function for details on additional parameters. 86http_request function for details on additional parameters and the return
87value.
82 88
83=item http_request $method => $url, key => value..., $cb->($data, $headers) 89=item http_request $method => $url, key => value..., $cb->($data, $headers)
84 90
85Executes 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
86must be an absolute http or https URL. 92must be an absolute http or https URL.
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.
87 98
88The callback will be called with the response data as first argument 99The callback will be called with the response data as first argument
89(or C<undef> if it wasn't available due to errors), and a hash-ref with 100(or C<undef> if it wasn't available due to errors), and a hash-ref with
90response headers as second argument. 101response headers as second argument.
91 102
92All 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
93headers, the three "pseudo-headers" C<HTTPVersion>, C<Status> and 104headers, the "pseudo-headers" C<HTTPVersion>, C<Status> and C<Reason>
94C<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
95name. If the server sends a header multiple lines, then their contents 109If the server sends a header multiple times, then their contents will be
96will be joined together with C<\x00>. 110joined together with a comma (C<,>), as per the HTTP spec.
97 111
98If 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,
99then 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<599>
100and the C<Reason> pseudo-header will contain an error message. 114and the C<Reason> pseudo-header will contain an error message.
101 115
… …
151based on the original netscape specification. 165based on the original netscape specification.
152 166
153The C<$hash_ref> must be an (initially empty) hash reference which will 167The C<$hash_ref> must be an (initially empty) hash reference which will
154get updated automatically. It is possible to save the cookie_jar to 168get updated automatically. It is possible to save the cookie_jar to
155persistent storage with something like JSON or Storable, but this is not 169persistent storage with something like JSON or Storable, but this is not
156recommended, as expire times are currently being ignored. 170recommended, as expiry times are currently being ignored.
157 171
158Note that this cookie implementation is not of very high quality, nor 172Note that this cookie implementation is not of very high quality, nor
159meant to be complete. If you want complete cookie management you have to 173meant to be complete. If you want complete cookie management you have to
160do that on your own. C<cookie_jar> is meant as a quick fix to get some 174do that on your own. C<cookie_jar> is meant as a quick fix to get some
161cookie-using sites working. Cookies are a privacy disaster, do not use 175cookie-using sites working. Cookies are a privacy disaster, do not use
162them unless required to. 176them unless required to.
177
178=item tls_ctx => $scheme | $tls_ctx
179
180Specifies the AnyEvent::TLS context to be used for https connections. This
181parameter follows the same rules as the C<tls_ctx> parameter to
182L<AnyEvent::Handle>, but additionally, the two strings C<low> or
183C<high> can be specified, which give you a predefined low-security (no
184verification, highest compatibility) and high-security (CA and common-name
185verification) TLS context.
186
187The default for this option is C<low>, which could be interpreted as "give
188me the page, no matter what".
163 189
164=back 190=back
165 191
166Example: make a simple HTTP GET request for http://www.nethype.de/ 192Example: make a simple HTTP GET request for http://www.nethype.de/
167 193
… …
181 use Data::Dumper; 207 use Data::Dumper;
182 print Dumper $hdr; 208 print Dumper $hdr;
183 } 209 }
184 ; 210 ;
185 211
212Example: make another simple HTTP GET request, but immediately try to
213cancel it.
214
215 my $request = http_request GET => "http://www.nethype.de/", sub {
216 my ($body, $hdr) = @_;
217 print "$body\n";
218 };
219
220 undef $request;
221
186=cut 222=cut
187 223
188sub _slot_schedule; 224sub _slot_schedule;
189sub _slot_schedule($) { 225sub _slot_schedule($) {
190 my $host = shift; 226 my $host = shift;
191 227
192 while ($CO_SLOT{$host}[0] < $MAX_PER_HOST) { 228 while ($CO_SLOT{$host}[0] < $MAX_PER_HOST) {
193 if (my $cb = shift @{ $CO_SLOT{$host}[1] }) { 229 if (my $cb = shift @{ $CO_SLOT{$host}[1] }) {
194 # somebody wants that slot 230 # somebody wants that slot
195 ++$CO_SLOT{$host}[0]; 231 ++$CO_SLOT{$host}[0];
232 ++$ACTIVE;
196 233
197 $cb->(AnyEvent::Util::guard { 234 $cb->(AnyEvent::Util::guard {
235 --$ACTIVE;
198 --$CO_SLOT{$host}[0]; 236 --$CO_SLOT{$host}[0];
199 _slot_schedule $host; 237 _slot_schedule $host;
200 }); 238 });
201 } else { 239 } else {
202 # nobody wants the slot, maybe we can forget about it 240 # nobody wants the slot, maybe we can forget about it
… …
211 push @{ $CO_SLOT{$_[0]}[1] }, $_[1]; 249 push @{ $CO_SLOT{$_[0]}[1] }, $_[1];
212 250
213 _slot_schedule $_[0]; 251 _slot_schedule $_[0];
214} 252}
215 253
254our $qr_nl = qr<\015?\012>;
255our $qr_nlnl = qr<\015?\012\015?\012>;
256
257our $TLS_CTX_LOW = { cache => 1, dh => undef, sslv2 => 1 };
258our $TLS_CTX_HIGH = { cache => 1, verify => 1, verify_cn => "https", dh => "skip4096" };
259
216sub http_request($$$;@) { 260sub http_request($$@) {
217 my $cb = pop; 261 my $cb = pop;
218 my ($method, $url, %arg) = @_; 262 my ($method, $url, %arg) = @_;
219 263
220 my %hdr; 264 my %hdr;
265
266 $arg{tls_ctx} = $TLS_CTX_LOW if $arg{tls_ctx} eq "low" || !exists $arg{tls_ctx};
267 $arg{tls_ctx} = $TLS_CTX_HIGH if $arg{tls_ctx} eq "high";
221 268
222 $method = uc $method; 269 $method = uc $method;
223 270
224 if (my $hdr = $arg{headers}) { 271 if (my $hdr = $arg{headers}) {
225 while (my ($k, $v) = each %$hdr) { 272 while (my ($k, $v) = each %$hdr) {
226 $hdr{lc $k} = $v; 273 $hdr{lc $k} = $v;
227 } 274 }
228 } 275 }
229 276
230 my $recurse = exists $arg{recurse} ? $arg{recurse} : $MAX_RECURSE; 277 my $recurse = exists $arg{recurse} ? delete $arg{recurse} : $MAX_RECURSE;
231 278
232 return $cb->(undef, { Status => 599, Reason => "recursion limit reached" }) 279 return $cb->(undef, { Status => 599, Reason => "Too many redirections", URL => $url })
233 if $recurse < 0; 280 if $recurse < 0;
234 281
235 my $proxy = $arg{proxy} || $PROXY; 282 my $proxy = $arg{proxy} || $PROXY;
236 my $timeout = $arg{timeout} || $TIMEOUT; 283 my $timeout = $arg{timeout} || $TIMEOUT;
237 284
238 $hdr{"user-agent"} ||= $USERAGENT; 285 $hdr{"user-agent"} ||= $USERAGENT;
239 286
240 my ($scheme, $authority, $upath, $query, $fragment) = 287 my ($uscheme, $uauthority, $upath, $query, $fragment) =
241 $url =~ m|(?:([^:/?#]+):)?(?://([^/?#]*))?([^?#]*)(?:\?([^#]*))?(?:#(.*))?|; 288 $url =~ m|(?:([^:/?#]+):)?(?://([^/?#]*))?([^?#]*)(?:\?([^#]*))?(?:#(.*))?|;
242 289
243 $scheme = lc $scheme; 290 $uscheme = lc $uscheme;
244 291
245 my $uport = $scheme eq "http" ? 80 292 my $uport = $uscheme eq "http" ? 80
246 : $scheme eq "https" ? 443 293 : $uscheme eq "https" ? 443
247 : return $cb->(undef, { Status => 599, Reason => "only http and https URL schemes supported" }); 294 : return $cb->(undef, { Status => 599, Reason => "Only http and https URL schemes supported (not '$uscheme')", URL => $url });
248 295
296 $hdr{referer} ||= "$uscheme://$uauthority$upath"; # leave out fragment and query string, just a heuristic
297
249 $authority =~ /^(?: .*\@ )? ([^\@:]+) (?: : (\d+) )?$/x 298 $uauthority =~ /^(?: .*\@ )? ([^\@:]+) (?: : (\d+) )?$/x
250 or return $cb->(undef, { Status => 599, Reason => "unparsable URL" }); 299 or return $cb->(undef, { Status => 599, Reason => "Unparsable URL", URL => $url });
251 300
252 my $uhost = $1; 301 my $uhost = $1;
253 $uport = $2 if defined $2; 302 $uport = $2 if defined $2;
254 303
255 $uhost =~ s/^\[(.*)\]$/$1/; 304 $uhost =~ s/^\[(.*)\]$/$1/;
256 $upath .= "?$query" if length $query; 305 $upath .= "?$query" if length $query;
257 306
258 $upath =~ s%^/?%/%; 307 $upath =~ s%^/?%/%;
259 308
260 $hdr{referer} ||= "$scheme://$authority$upath";
261
262 # cookie processing 309 # cookie processing
263 if (my $jar = $arg{cookie_jar}) { 310 if (my $jar = $arg{cookie_jar}) {
264 %$jar = () if $jar->{version} < 1; 311 %$jar = () if $jar->{version} != 1;
265 312
266 my @cookie; 313 my @cookie;
267 314
268 while (my ($chost, $v) = each %$jar) { 315 while (my ($chost, $v) = each %$jar) {
316 if ($chost =~ /^\./) {
269 next unless $chost eq substr $uhost, -length $chost; 317 next unless $chost eq substr $uhost, -length $chost;
270 next unless $chost =~ /^\./; 318 } elsif ($chost =~ /\./) {
319 next unless $chost eq $uhost;
320 } else {
321 next;
322 }
271 323
272 while (my ($cpath, $v) = each %$v) { 324 while (my ($cpath, $v) = each %$v) {
273 next unless $cpath eq substr $upath, 0, length $cpath; 325 next unless $cpath eq substr $upath, 0, length $cpath;
274 326
275 while (my ($k, $v) = each %$v) { 327 while (my ($k, $v) = each %$v) {
276 next if $scheme ne "https" && exists $v->{secure}; 328 next if $uscheme ne "https" && exists $v->{secure};
329 my $value = $v->{value};
330 $value =~ s/([\\"])/\\$1/g;
277 push @cookie, "$k=$v->{value}"; 331 push @cookie, "$k=\"$value\"";
278 } 332 }
279 } 333 }
280 } 334 }
281 335
282 $hdr{cookie} = join "; ", @cookie 336 $hdr{cookie} = join "; ", @cookie
283 if @cookie; 337 if @cookie;
284 } 338 }
285 339
286 my ($rhost, $rport, $rpath); # request host, port, path 340 my ($rhost, $rport, $rscheme, $rpath); # request host, port, path
287 341
288 if ($proxy) { 342 if ($proxy) {
289 ($rhost, $rport, $scheme) = @$proxy; 343 ($rpath, $rhost, $rport, $rscheme) = ($url, @$proxy);
290 $rpath = $url; 344
345 # don't support https requests over https-proxy transport,
346 # can't be done with tls as spec'ed, unless you double-encrypt.
347 $rscheme = "http" if $uscheme eq "https" && $rscheme eq "https";
291 } else { 348 } else {
292 ($rhost, $rport, $rpath) = ($uhost, $uport, $upath); 349 ($rhost, $rport, $rscheme, $rpath) = ($uhost, $uport, $uscheme, $upath);
293 $hdr{host} = $uhost;
294 } 350 }
295 351
352 $hdr{host} = $uhost;
296 $hdr{"content-length"} = length $arg{body}; 353 $hdr{"content-length"} = length $arg{body};
297 354
298 my %state = (connect_guard => 1); 355 my %state = (connect_guard => 1);
299 356
300 _get_slot $uhost, sub { 357 _get_slot $uhost, sub {
… …
302 359
303 return unless $state{connect_guard}; 360 return unless $state{connect_guard};
304 361
305 $state{connect_guard} = AnyEvent::Socket::tcp_connect $rhost, $rport, sub { 362 $state{connect_guard} = AnyEvent::Socket::tcp_connect $rhost, $rport, sub {
306 $state{fh} = shift 363 $state{fh} = shift
307 or return $cb->(undef, { Status => 599, Reason => "$!" }); 364 or return (%state = (), $cb->(undef, { Status => 599, Reason => "$!", URL => $url }));
365 pop; # free memory, save a tree
308 366
309 delete $state{connect_guard}; # reduce memory usage, save a tree 367 return unless delete $state{connect_guard};
310 368
311 # get handle 369 # get handle
312 $state{handle} = new AnyEvent::Handle 370 $state{handle} = new AnyEvent::Handle
313 fh => $state{fh}, 371 fh => $state{fh},
314 ($scheme eq "https" ? (tls => "connect") : ()); 372 timeout => $timeout,
373 peername => $rhost,
374 tls_ctx => $arg{tls_ctx};
315 375
316 # limit the number of persistent connections 376 # limit the number of persistent connections
377 # keepalive not yet supported
317 if ($KA_COUNT{$_[1]} < $MAX_PERSISTENT_PER_HOST) { 378 if ($KA_COUNT{$_[1]} < $MAX_PERSISTENT_PER_HOST) {
318 ++$KA_COUNT{$_[1]}; 379 ++$KA_COUNT{$_[1]};
319 $state{handle}{ka_count_guard} = AnyEvent::Util::guard { --$KA_COUNT{$_[1]} }; 380 $state{handle}{ka_count_guard} = AnyEvent::Util::guard {
381 --$KA_COUNT{$_[1]}
382 };
320 $hdr{connection} = "keep-alive"; 383 $hdr{connection} = "keep-alive";
321 delete $hdr{connection}; # keep-alive not yet supported
322 } else { 384 } else {
323 delete $hdr{connection}; 385 delete $hdr{connection};
324 } 386 }
325 387
326 # (re-)configure handle 388 # (re-)configure handle
327 $state{handle}->timeout ($timeout);
328 $state{handle}->on_error (sub { 389 $state{handle}->on_error (sub {
329 %state = (); 390 %state = ();
330 $cb->(undef, { Status => 599, Reason => "$!" }); 391 $cb->(undef, { Status => 599, Reason => $_[2], URL => $url });
331 }); 392 });
332 $state{handle}->on_eof (sub { 393 $state{handle}->on_eof (sub {
333 %state = (); 394 %state = ();
334 $cb->(undef, { Status => 599, Reason => "unexpected end-of-file" }); 395 $cb->(undef, { Status => 599, Reason => "Unexpected end-of-file", URL => $url });
335 }); 396 });
336 397
398 $state{handle}->starttls ("connect") if $rscheme eq "https";
399
400 # handle actual, non-tunneled, request
401 my $handle_actual_request = sub {
402 $state{handle}->starttls ("connect") if $uscheme eq "https" && !exists $state{handle}{tls};
403
337 # send request 404 # send request
338 $state{handle}->push_write ( 405 $state{handle}->push_write (
339 "$method $rpath HTTP/1.0\015\012" 406 "$method $rpath HTTP/1.0\015\012"
340 . (join "", map "$_: $hdr{$_}\015\012", keys %hdr) 407 . (join "", map "\u$_: $hdr{$_}\015\012", keys %hdr)
341 . "\015\012" 408 . "\015\012"
342 . (delete $arg{body}) 409 . (delete $arg{body})
343 );
344
345 %hdr = (); # reduce memory usage, save a kitten
346
347 # status line
348 $state{handle}->push_read (line => qr/\015?\012/, sub {
349 $_[1] =~ /^HTTP\/([0-9\.]+) \s+ ([0-9]{3}) \s+ ([^\015\012]+)/ix
350 or return (%state = (), $cb->(undef, { Status => 599, Reason => "invalid server response ($_[1])" }));
351
352 my %hdr = ( # response headers
353 HTTPVersion => "\x00$1",
354 Status => "\x00$2",
355 Reason => "\x00$3",
356 ); 410 );
357 411
412 %hdr = (); # reduce memory usage, save a kitten
413
414 # status line
415 $state{handle}->push_read (line => $qr_nl, sub {
416 $_[1] =~ /^HTTP\/([0-9\.]+) \s+ ([0-9]{3}) (?: \s+ ([^\015\012]*) )?/ix
417 or return (%state = (), $cb->(undef, { Status => 599, Reason => "Invalid server response ($_[1])", URL => $url }));
418
419 my %hdr = ( # response headers
420 HTTPVersion => ",$1",
421 Status => ",$2",
422 Reason => ",$3",
423 URL => ",$url"
424 );
425
358 # headers, could be optimized a bit 426 # headers, could be optimized a bit
359 $state{handle}->unshift_read (line => qr/\015?\012\015?\012/, sub { 427 $state{handle}->unshift_read (line => $qr_nlnl, sub {
360 for ("$_[1]\012") { 428 for ("$_[1]\012") {
361 # we support spaces in field names, as lotus domino 429 y/\015//d; # weed out any \015, as they show up in the weirdest of places.
362 # creates them. 430
431 # things seen, not parsed:
432 # p3pP="NON CUR OTPi OUR NOR UNI"
433
363 $hdr{lc $1} .= "\x00$2" 434 $hdr{lc $1} .= ",$2"
364 while /\G 435 while /\G
365 ([^:\000-\037]+): 436 ([^:\000-\037]+):
366 [\011\040]* 437 [\011\040]*
367 ((?: [^\015\012]+ | \015?\012[\011\040] )*) 438 ((?: [^\012]+ | \012[\011\040] )*)
368 \015?\012 439 \012
369 /gxc; 440 /gxc;
370 441
371 /\G$/ 442 /\G$/
372 or return (%state = (), $cb->(undef, { Status => 599, Reason => "garbled response headers" })); 443 or return (%state = (), $cb->(undef, { Status => 599, Reason => "Garbled response headers", URL => $url }));
373 } 444 }
374 445
375 substr $_, 0, 1, "" 446 substr $_, 0, 1, ""
376 for values %hdr; 447 for values %hdr;
377 448
378 my $finish = sub { 449 my $finish = sub {
450 $state{handle}->destroy;
379 %state = (); 451 %state = ();
380 452
381 # set-cookie processing 453 # set-cookie processing
382 if ($arg{cookie_jar} && exists $hdr{"set-cookie"}) { 454 if ($arg{cookie_jar}) {
383 for (split /\x00/, $hdr{"set-cookie"}) { 455 for ($hdr{"set-cookie"}) {
384 my ($cookie, @arg) = split /;\s*/; 456 # parse NAME=VALUE
385 my ($name, $value) = split /=/, $cookie, 2; 457 my @kv;
386 my %kv = (value => $value, map { split /=/, $_, 2 } @arg); 458
387 459 while (/\G\s* ([^=;,[:space:]]+) \s*=\s* (?: "((?:[^\\"]+|\\.)*)" | ([^=;,[:space:]]*) )/gcxs) {
388 my $cdom = (delete $kv{domain}) || $uhost; 460 my $name = $1;
461 my $value = $3;
462
463 unless ($value) {
464 $value = $2;
465 $value =~ s/\\(.)/$1/gs;
466 }
467
468 push @kv, $name => $value;
469
470 last unless /\G\s*;/gc;
471 }
472
473 last unless @kv;
474
475 my $name = shift @kv;
476 my %kv = (value => shift @kv, @kv);
477
478 my $cdom;
389 my $cpath = (delete $kv{path}) || "/"; 479 my $cpath = (delete $kv{path}) || "/";
390 480
481 if (exists $kv{domain}) {
482 $cdom = delete $kv{domain};
483
391 $cdom =~ s/^.?/./; # make sure it starts with a "." 484 $cdom =~ s/^\.?/./; # make sure it starts with a "."
392 485
393 next if $cdom =~ /\.$/; 486 next if $cdom =~ /\.$/;
394 487
395 # this is not rfc-like and not netscape-like. go figure. 488 # this is not rfc-like and not netscape-like. go figure.
396 my $ndots = $cdom =~ y/.//; 489 my $ndots = $cdom =~ y/.//;
397 next if $ndots < ($cdom =~ /\.[^.][^.]\.[^.][^.]$/ ? 3 : 2); 490 next if $ndots < ($cdom =~ /\.[^.][^.]\.[^.][^.]$/ ? 3 : 2);
398 491 } else {
492 $cdom = $uhost;
493 }
494
399 # store it 495 # store it
400 $arg{cookie_jar}{version} = 1; 496 $arg{cookie_jar}{version} = 1;
401 $arg{cookie_jar}{$cdom}{$cpath}{$name} = \%kv; 497 $arg{cookie_jar}{$cdom}{$cpath}{$name} = \%kv;
498
499 redo if /\G\s*,/gc;
500 }
501 }
502
503 # microsoft and other shitheads don't give a shit for following standards,
504 # try to support some common forms of broken Location headers.
505 if ($_[1]{location} !~ /^(?: $ | [^:\/?\#]+ : )/x) {
506 $_[1]{location} =~ s/^\.\/+//;
507
508 my $url = "$rscheme://$uhost:$uport";
509
510 unless ($_[1]{location} =~ s/^\///) {
511 $url .= $upath;
512 $url =~ s/\/[^\/]*$//;
513 }
514
515 $_[1]{location} = "$url/$_[1]{location}";
516 }
517
518 if ($_[1]{Status} =~ /^30[12]$/ && $recurse && $method ne "POST") {
519 # apparently, mozilla et al. just change POST to GET here
520 # more research is needed before we do the same
521 http_request ($method => $_[1]{location}, %arg, recurse => $recurse - 1, $cb);
522 } elsif ($_[1]{Status} == 303 && $recurse) {
523 # even http/1.1 is unclear on how to mutate the method
524 $method = "GET" unless $method eq "HEAD";
525 http_request ($method => $_[1]{location}, %arg, recurse => $recurse - 1, $cb);
526 } elsif ($_[1]{Status} == 307 && $recurse && $method =~ /^(?:GET|HEAD)$/) {
527 http_request ($method => $_[1]{location}, %arg, recurse => $recurse - 1, $cb);
528 } else {
529 $cb->($_[0], $_[1]);
530 }
531 };
532
533 if ($hdr{Status} =~ /^(?:1..|204|304)$/ or $method eq "HEAD") {
534 $finish->(undef, \%hdr);
535 } else {
536 if (exists $hdr{"content-length"}) {
537 $_[0]->unshift_read (chunk => $hdr{"content-length"}, sub {
538 # could cache persistent connection now
539 if ($hdr{connection} =~ /\bkeep-alive\b/i) {
540 # but we don't, due to misdesigns, this is annoyingly complex
541 };
542
543 $finish->($_[1], \%hdr);
544 });
545 } else {
546 # too bad, need to read until we get an error or EOF,
547 # no way to detect winged data.
548 $_[0]->on_error (sub {
549 # delete ought to be more efficient, as we would have to make
550 # a copy otherwise as $_[0] gets destroyed.
551 $finish->(delete $_[0]{rbuf}, \%hdr);
552 });
553 $_[0]->on_eof (undef);
554 $_[0]->on_read (sub { });
402 } 555 }
403 } 556 }
404
405 if ($_[1]{Status} =~ /^x30[12]$/ && $recurse) {
406 # microsoft and other assholes don't give a shit for following standards,
407 # try to support a common form of broken Location header.
408 $_[1]{location} =~ s%^/%$scheme://$uhost:$uport/%;
409
410 http_request ($method, $_[1]{location}, %arg, recurse => $recurse - 1, $cb);
411 } else {
412 $cb->($_[0], $_[1]);
413 }
414 }; 557 });
558 });
559 };
415 560
416 if ($hdr{Status} =~ /^(?:1..|204|304)$/ or $method eq "HEAD") { 561 # now handle proxy-CONNECT method
417 $finish->(undef, \%hdr); 562 if ($proxy && $uscheme eq "https") {
563 # oh dear, we have to wrap it into a connect request
564
565 # maybe re-use $uauthority with patched port?
566 $state{handle}->push_write ("CONNECT $uhost:$uport HTTP/1.0\015\012Host: $uhost\015\012\015\012");
567 $state{handle}->push_read (line => $qr_nlnl, sub {
568 $_[1] =~ /^HTTP\/([0-9\.]+) \s+ ([0-9]{3}) (?: \s+ ([^\015\012]*) )?/ix
569 or return (%state = (), $cb->(undef, { Status => 599, Reason => "Invalid proxy connect response ($_[1])", URL => $url }));
570
571 if ($2 == 200) {
572 $rpath = $upath;
573 &$handle_actual_request;
418 } else { 574 } else {
419 if (exists $hdr{"content-length"}) { 575 %state = ();
420 $_[0]->unshift_read (chunk => $hdr{"content-length"}, sub { 576 $cb->(undef, { Status => $2, Reason => $3, URL => $url });
421 # could cache persistent connection now
422 if ($hdr{connection} =~ /\bkeep-alive\b/i) {
423 # but we don't, due to misdesigns, this is annoyingly complex
424 };
425
426 $finish->($_[1], \%hdr);
427 });
428 } else {
429 # too bad, need to read until we get an error or EOF,
430 # no way to detect winged data.
431 $_[0]->on_error (sub {
432 $finish->($_[0]{rbuf}, \%hdr);
433 });
434 $_[0]->on_eof (undef);
435 $_[0]->on_read (sub { });
436 }
437 } 577 }
438 }); 578 });
579 } else {
580 &$handle_actual_request;
439 }); 581 }
582
440 }, sub { 583 }, sub {
441 $timeout 584 $timeout
442 }; 585 };
443 }; 586 };
444 587
445 defined wantarray && AnyEvent::Util::guard { %state = () } 588 defined wantarray && AnyEvent::Util::guard { %state = () }
446} 589}
447 590
448sub http_get($$;@) { 591sub http_get($@) {
449 unshift @_, "GET"; 592 unshift @_, "GET";
450 &http_request 593 &http_request
451} 594}
452 595
453sub http_head($$;@) { 596sub http_head($@) {
454 unshift @_, "HEAD"; 597 unshift @_, "HEAD";
455 &http_request 598 &http_request
456} 599}
457 600
458sub http_post($$$;@) { 601sub http_post($$@) {
602 my $url = shift;
459 unshift @_, "POST", "body"; 603 unshift @_, "POST", $url, "body";
460 &http_request 604 &http_request
461} 605}
462 606
463=back 607=back
464 608
… …
476The default value for the C<recurse> request parameter (default: C<10>). 620The default value for the C<recurse> request parameter (default: C<10>).
477 621
478=item $AnyEvent::HTTP::USERAGENT 622=item $AnyEvent::HTTP::USERAGENT
479 623
480The default value for the C<User-Agent> header (the default is 624The default value for the C<User-Agent> header (the default is
481C<Mozilla/5.0 (compatible; AnyEvent::HTTP/$VERSION; +http://software.schmorp.de/pkg/AnyEvent)>). 625C<Mozilla/5.0 (compatible; U; AnyEvent-HTTP/$VERSION; +http://software.schmorp.de/pkg/AnyEvent)>).
482 626
483=item $AnyEvent::HTTP::MAX_PERSISTENT 627=item $AnyEvent::HTTP::MAX_PERSISTENT
484 628
485The maximum number of persistent connections to keep open (default: 8). 629The maximum number of persistent connections to keep open (default: 8).
486 630
… …
489=item $AnyEvent::HTTP::PERSISTENT_TIMEOUT 633=item $AnyEvent::HTTP::PERSISTENT_TIMEOUT
490 634
491The maximum time to cache a persistent connection, in seconds (default: 2). 635The maximum time to cache a persistent connection, in seconds (default: 2).
492 636
493Not implemented currently. 637Not implemented currently.
638
639=item $AnyEvent::HTTP::ACTIVE
640
641The number of active connections. This is not the number of currently
642running requests, but the number of currently open and non-idle TCP
643connections. This number of can be useful for load-leveling.
494 644
495=back 645=back
496 646
497=cut 647=cut
498 648
… …
507 657
508L<AnyEvent>. 658L<AnyEvent>.
509 659
510=head1 AUTHOR 660=head1 AUTHOR
511 661
512 Marc Lehmann <schmorp@schmorp.de> 662 Marc Lehmann <schmorp@schmorp.de>
513 http://home.schmorp.de/ 663 http://home.schmorp.de/
664
665With many thanks to Дмитрий Шалашов, who provided countless
666testcases and bugreports.
514 667
515=cut 668=cut
516 669
5171 6701
518 671

Diff Legend

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