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.30 by root, Thu Oct 23 02:46:20 2008 UTC vs.
Revision 1.40 by root, Sun Jul 5 01:45:01 2009 UTC

… …
41use strict; 41use strict;
42no warnings; 42no warnings;
43 43
44use Carp; 44use Carp;
45 45
46use AnyEvent (); 46use AnyEvent 4.452 ();
47use AnyEvent::Util (); 47use AnyEvent::Util ();
48use AnyEvent::Socket (); 48use AnyEvent::Socket ();
49use AnyEvent::Handle (); 49use AnyEvent::Handle ();
50 50
51use base Exporter::; 51use base Exporter::;
52 52
53our $VERSION = '1.05'; 53our $VERSION = '1.12';
54 54
55our @EXPORT = qw(http_get http_post http_head http_request); 55our @EXPORT = qw(http_get http_post http_head http_request);
56 56
57our $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)";
58our $MAX_RECURSE = 10; 58our $MAX_RECURSE = 10;
59our $MAX_PERSISTENT = 8; 59our $MAX_PERSISTENT = 8;
60our $PERSISTENT_TIMEOUT = 2; 60our $PERSISTENT_TIMEOUT = 2;
61our $TIMEOUT = 300; 61our $TIMEOUT = 300;
62 62
… …
104headers, the "pseudo-headers" C<HTTPVersion>, C<Status> and C<Reason> 104headers, the "pseudo-headers" C<HTTPVersion>, C<Status> and C<Reason>
105contain the three parts of the HTTP Status-Line of the same name. The 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 106pseudo-header C<URL> contains the original URL (which can differ from the
107requested URL when following redirects). 107requested URL when following redirects).
108 108
109If the server sends a header multiple lines, then their contents will be 109If the server sends a header multiple times, then their contents will be
110joined together with C<\x00>. 110joined together with a comma (C<,>), as per the HTTP spec.
111 111
112If 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,
113then 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>
114and the C<Reason> pseudo-header will contain an error message. 114and the C<Reason> pseudo-header will contain an error message.
115 115
… …
165based on the original netscape specification. 165based on the original netscape specification.
166 166
167The 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
168get updated automatically. It is possible to save the cookie_jar to 168get updated automatically. It is possible to save the cookie_jar to
169persistent storage with something like JSON or Storable, but this is not 169persistent storage with something like JSON or Storable, but this is not
170recommended, as expire times are currently being ignored. 170recommended, as expiry times are currently being ignored.
171 171
172Note that this cookie implementation is not of very high quality, nor 172Note that this cookie implementation is not of very high quality, nor
173meant 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
174do 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
175cookie-using sites working. Cookies are a privacy disaster, do not use 175cookie-using sites working. Cookies are a privacy disaster, do not use
176them 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".
177 189
178=back 190=back
179 191
180Example: make a simple HTTP GET request for http://www.nethype.de/ 192Example: make a simple HTTP GET request for http://www.nethype.de/
181 193
… …
237 push @{ $CO_SLOT{$_[0]}[1] }, $_[1]; 249 push @{ $CO_SLOT{$_[0]}[1] }, $_[1];
238 250
239 _slot_schedule $_[0]; 251 _slot_schedule $_[0];
240} 252}
241 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
242sub http_request($$@) { 260sub http_request($$@) {
243 my $cb = pop; 261 my $cb = pop;
244 my ($method, $url, %arg) = @_; 262 my ($method, $url, %arg) = @_;
245 263
246 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";
247 268
248 $method = uc $method; 269 $method = uc $method;
249 270
250 if (my $hdr = $arg{headers}) { 271 if (my $hdr = $arg{headers}) {
251 while (my ($k, $v) = each %$hdr) { 272 while (my ($k, $v) = each %$hdr) {
… …
253 } 274 }
254 } 275 }
255 276
256 my $recurse = exists $arg{recurse} ? delete $arg{recurse} : $MAX_RECURSE; 277 my $recurse = exists $arg{recurse} ? delete $arg{recurse} : $MAX_RECURSE;
257 278
258 return $cb->(undef, { Status => 599, Reason => "recursion limit reached", URL => $url }) 279 return $cb->(undef, { Status => 599, Reason => "Too many redirections", URL => $url })
259 if $recurse < 0; 280 if $recurse < 0;
260 281
261 my $proxy = $arg{proxy} || $PROXY; 282 my $proxy = $arg{proxy} || $PROXY;
262 my $timeout = $arg{timeout} || $TIMEOUT; 283 my $timeout = $arg{timeout} || $TIMEOUT;
263 284
264 $hdr{"user-agent"} ||= $USERAGENT; 285 $hdr{"user-agent"} ||= $USERAGENT;
265 286
266 my ($scheme, $authority, $upath, $query, $fragment) = 287 my ($uscheme, $uauthority, $upath, $query, $fragment) =
267 $url =~ m|(?:([^:/?#]+):)?(?://([^/?#]*))?([^?#]*)(?:\?([^#]*))?(?:#(.*))?|; 288 $url =~ m|(?:([^:/?#]+):)?(?://([^/?#]*))?([^?#]*)(?:\?([^#]*))?(?:#(.*))?|;
268 289
269 $scheme = lc $scheme; 290 $uscheme = lc $uscheme;
270 291
271 my $uport = $scheme eq "http" ? 80 292 my $uport = $uscheme eq "http" ? 80
272 : $scheme eq "https" ? 443 293 : $uscheme eq "https" ? 443
273 : return $cb->(undef, { Status => 599, Reason => "only http and https URL schemes supported", URL => $url }); 294 : return $cb->(undef, { Status => 599, Reason => "Only http and https URL schemes supported (not '$uscheme')", URL => $url });
274 295
275 $hdr{referer} ||= "$scheme://$authority$upath"; # leave out fragment and query string, just a heuristic 296 $hdr{referer} ||= "$uscheme://$uauthority$upath"; # leave out fragment and query string, just a heuristic
276 297
277 $authority =~ /^(?: .*\@ )? ([^\@:]+) (?: : (\d+) )?$/x 298 $uauthority =~ /^(?: .*\@ )? ([^\@:]+) (?: : (\d+) )?$/x
278 or return $cb->(undef, { Status => 599, Reason => "unparsable URL", URL => $url }); 299 or return $cb->(undef, { Status => 599, Reason => "Unparsable URL", URL => $url });
279 300
280 my $uhost = $1; 301 my $uhost = $1;
281 $uport = $2 if defined $2; 302 $uport = $2 if defined $2;
282 303
283 $uhost =~ s/^\[(.*)\]$/$1/; 304 $uhost =~ s/^\[(.*)\]$/$1/;
… …
285 306
286 $upath =~ s%^/?%/%; 307 $upath =~ s%^/?%/%;
287 308
288 # cookie processing 309 # cookie processing
289 if (my $jar = $arg{cookie_jar}) { 310 if (my $jar = $arg{cookie_jar}) {
290 %$jar = () if $jar->{version} < 1; 311 %$jar = () if $jar->{version} != 1;
291 312
292 my @cookie; 313 my @cookie;
293 314
294 while (my ($chost, $v) = each %$jar) { 315 while (my ($chost, $v) = each %$jar) {
295 if ($chost =~ /^\./) { 316 if ($chost =~ /^\./) {
… …
302 323
303 while (my ($cpath, $v) = each %$v) { 324 while (my ($cpath, $v) = each %$v) {
304 next unless $cpath eq substr $upath, 0, length $cpath; 325 next unless $cpath eq substr $upath, 0, length $cpath;
305 326
306 while (my ($k, $v) = each %$v) { 327 while (my ($k, $v) = each %$v) {
307 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;
308 push @cookie, "$k=$v->{value}"; 331 push @cookie, "$k=\"$value\"";
309 } 332 }
310 } 333 }
311 } 334 }
312 335
313 $hdr{cookie} = join "; ", @cookie 336 $hdr{cookie} = join "; ", @cookie
314 if @cookie; 337 if @cookie;
315 } 338 }
316 339
317 my ($rhost, $rport, $rpath); # request host, port, path 340 my ($rhost, $rport, $rscheme, $rpath); # request host, port, path
318 341
319 if ($proxy) { 342 if ($proxy) {
320 ($rhost, $rport, $scheme) = @$proxy; 343 ($rpath, $rhost, $rport, $rscheme) = ($url, @$proxy);
321 $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";
322 } else { 348 } else {
323 ($rhost, $rport, $rpath) = ($uhost, $uport, $upath); 349 ($rhost, $rport, $rscheme, $rpath) = ($uhost, $uport, $uscheme, $upath);
324 $hdr{host} = $uhost;
325 } 350 }
326 351
352 $hdr{host} = $uhost;
327 $hdr{"content-length"} = length $arg{body}; 353 $hdr{"content-length"} = length $arg{body};
328 354
329 my %state = (connect_guard => 1); 355 my %state = (connect_guard => 1);
330 356
331 _get_slot $uhost, sub { 357 _get_slot $uhost, sub {
… …
333 359
334 return unless $state{connect_guard}; 360 return unless $state{connect_guard};
335 361
336 $state{connect_guard} = AnyEvent::Socket::tcp_connect $rhost, $rport, sub { 362 $state{connect_guard} = AnyEvent::Socket::tcp_connect $rhost, $rport, sub {
337 $state{fh} = shift 363 $state{fh} = shift
338 or return $cb->(undef, { Status => 599, Reason => "$!", URL => $url }); 364 or return (%state = (), $cb->(undef, { Status => 599, Reason => "$!", URL => $url }));
365 pop; # free memory, save a tree
339 366
340 delete $state{connect_guard}; # reduce memory usage, save a tree 367 return unless delete $state{connect_guard};
341 368
342 # get handle 369 # get handle
343 $state{handle} = new AnyEvent::Handle 370 $state{handle} = new AnyEvent::Handle
344 fh => $state{fh}, 371 fh => $state{fh},
345 ($scheme eq "https" ? (tls => "connect") : ()); 372 timeout => $timeout,
373 peername => $rhost,
374 tls_ctx => $arg{tls_ctx};
346 375
347 # limit the number of persistent connections 376 # limit the number of persistent connections
377 # keepalive not yet supported
348 if ($KA_COUNT{$_[1]} < $MAX_PERSISTENT_PER_HOST) { 378 if ($KA_COUNT{$_[1]} < $MAX_PERSISTENT_PER_HOST) {
349 ++$KA_COUNT{$_[1]}; 379 ++$KA_COUNT{$_[1]};
350 $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 };
351 $hdr{connection} = "keep-alive"; 383 $hdr{connection} = "keep-alive";
352 delete $hdr{connection}; # keep-alive not yet supported
353 } else { 384 } else {
354 delete $hdr{connection}; 385 delete $hdr{connection};
355 } 386 }
356 387
357 # (re-)configure handle 388 # (re-)configure handle
358 $state{handle}->timeout ($timeout);
359 $state{handle}->on_error (sub { 389 $state{handle}->on_error (sub {
360 my $errno = "$!";
361 %state = (); 390 %state = ();
362 $cb->(undef, { Status => 599, Reason => $errno, URL => $url }); 391 $cb->(undef, { Status => 599, Reason => $_[2], URL => $url });
363 }); 392 });
364 $state{handle}->on_eof (sub { 393 $state{handle}->on_eof (sub {
365 %state = (); 394 %state = ();
366 $cb->(undef, { Status => 599, Reason => "unexpected end-of-file", URL => $url }); 395 $cb->(undef, { Status => 599, Reason => "Unexpected end-of-file", URL => $url });
367 }); 396 });
368 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
369 # send request 404 # send request
370 $state{handle}->push_write ( 405 $state{handle}->push_write (
371 "$method $rpath HTTP/1.0\015\012" 406 "$method $rpath HTTP/1.0\015\012"
372 . (join "", map "$_: $hdr{$_}\015\012", keys %hdr) 407 . (join "", map "\u$_: $hdr{$_}\015\012", keys %hdr)
373 . "\015\012" 408 . "\015\012"
374 . (delete $arg{body}) 409 . (delete $arg{body})
375 );
376
377 %hdr = (); # reduce memory usage, save a kitten
378
379 # status line
380 $state{handle}->push_read (line => qr/\015?\012/, sub {
381 $_[1] =~ /^HTTP\/([0-9\.]+) \s+ ([0-9]{3}) (?: \s+ ([^\015\012]*) )?/ix
382 or return (%state = (), $cb->(undef, { Status => 599, Reason => "invalid server response ($_[1])", URL => $url }));
383
384 my %hdr = ( # response headers
385 HTTPVersion => "\x00$1",
386 Status => "\x00$2",
387 Reason => "\x00$3",
388 URL => "\x00$url"
389 ); 410 );
390 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
391 # headers, could be optimized a bit 426 # headers, could be optimized a bit
392 $state{handle}->unshift_read (line => qr/\015?\012\015?\012/, sub { 427 $state{handle}->unshift_read (line => $qr_nlnl, sub {
393 for ("$_[1]\012") { 428 for ("$_[1]\012") {
394 # 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.
395 # creates them (actually spaces around seperators 430
396 # are strictly allowed in http, they are a security issue). 431 # things seen, not parsed:
432 # p3pP="NON CUR OTPi OUR NOR UNI"
433
397 $hdr{lc $1} .= "\x00$2" 434 $hdr{lc $1} .= ",$2"
398 while /\G 435 while /\G
399 ([^:\000-\037]+): 436 ([^:\000-\037]+):
400 [\011\040]* 437 [\011\040]*
401 ((?: [^\015\012]+ | \015?\012[\011\040] )*) 438 ((?: [^\012]+ | \012[\011\040] )*)
402 \015?\012 439 \012
403 /gxc; 440 /gxc;
404 441
405 /\G$/ 442 /\G$/
406 or return (%state = (), $cb->(undef, { Status => 599, Reason => "garbled response headers", URL => $url })); 443 or return (%state = (), $cb->(undef, { Status => 599, Reason => "Garbled response headers", URL => $url }));
407 } 444 }
408 445
409 substr $_, 0, 1, "" 446 substr $_, 0, 1, ""
410 for values %hdr; 447 for values %hdr;
411 448
412 my $finish = sub { 449 my $finish = sub {
413 # TODO: use destroy method, when/if available
414 #$state{handle}->destroy; 450 $state{handle}->destroy;
415 $state{handle}->on_eof (undef);
416 $state{handle}->on_error (undef);
417 %state = (); 451 %state = ();
418 452
419 # set-cookie processing 453 # set-cookie processing
420 if ($arg{cookie_jar} && exists $hdr{"set-cookie"}) { 454 if ($arg{cookie_jar}) {
421 for (split /\x00/, $hdr{"set-cookie"}) { 455 for ($hdr{"set-cookie"}) {
422 my ($cookie, @arg) = split /;\s*/; 456 # parse NAME=VALUE
423 my ($name, $value) = split /=/, $cookie, 2; 457 my @kv;
424 my %kv = (value => $value, map { split /=/, $_, 2 } @arg); 458
425 459 while (/\G\s* ([^=;,[:space:]]+) \s*=\s* (?: "((?:[^\\"]+|\\.)*)" | ([^=;,[:space:]]*) )/gcxs) {
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
426 my $cdom; 478 my $cdom;
427 my $cpath = (delete $kv{path}) || "/"; 479 my $cpath = (delete $kv{path}) || "/";
428 480
429 if (exists $kv{domain}) { 481 if (exists $kv{domain}) {
430 $cdom = delete $kv{domain}; 482 $cdom = delete $kv{domain};
431
432 $cdom =~ s/^\.?/./; # make sure it starts with a "."
433
434 next if $cdom =~ /\.$/;
435 483
484 $cdom =~ s/^\.?/./; # make sure it starts with a "."
485
486 next if $cdom =~ /\.$/;
487
436 # this is not rfc-like and not netscape-like. go figure. 488 # this is not rfc-like and not netscape-like. go figure.
437 my $ndots = $cdom =~ y/.//; 489 my $ndots = $cdom =~ y/.//;
438 next if $ndots < ($cdom =~ /\.[^.][^.]\.[^.][^.]$/ ? 3 : 2); 490 next if $ndots < ($cdom =~ /\.[^.][^.]\.[^.][^.]$/ ? 3 : 2);
439 } else { 491 } else {
440 $cdom = $uhost; 492 $cdom = $uhost;
493 }
494
495 # store it
496 $arg{cookie_jar}{version} = 1;
497 $arg{cookie_jar}{$cdom}{$cpath}{$name} = \%kv;
498
499 redo if /\G\s*,/gc;
441 } 500 }
442 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/\/[^\/]*$//;
443 # store it 513 }
444 $arg{cookie_jar}{version} = 1; 514
445 $arg{cookie_jar}{$cdom}{$cpath}{$name} = \%kv; 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 { });
446 } 555 }
447 } 556 }
448
449 # microsoft and other shitheads don't give a shit for following standards,
450 # try to support some common forms of broken Location headers.
451 if ($_[1]{location} !~ /^(?: $ | [^:\/?\#]+ : )/x) {
452 $_[1]{location} =~ s/^\.\/+//;
453
454 my $url = "$scheme://$uhost:$uport";
455
456 unless ($_[1]{location} =~ s/^\///) {
457 $url .= $upath;
458 $url =~ s/\/[^\/]*$//;
459 }
460
461 $_[1]{location} = "$url/$_[1]{location}";
462 }
463
464 if ($_[1]{Status} =~ /^30[12]$/ && $recurse && $method ne "POST") {
465 # apparently, mozilla et al. just change POST to GET here
466 # more research is needed before we do the same
467 http_request ($method, $_[1]{location}, %arg, recurse => $recurse - 1, $cb);
468 } elsif ($_[1]{Status} == 303 && $recurse) {
469 # even http/1.1 is unclear on how to mutate the method
470 $method = "GET" unless $method eq "HEAD";
471 http_request ($method => $_[1]{location}, %arg, recurse => $recurse - 1, $cb);
472 } elsif ($_[1]{Status} == 307 && $recurse && $method =~ /^(?:GET|HEAD)$/) {
473 http_request ($method => $_[1]{location}, %arg, recurse => $recurse - 1, $cb);
474 } else {
475 $cb->($_[0], $_[1]);
476 }
477 }; 557 });
558 });
559 };
478 560
479 if ($hdr{Status} =~ /^(?:1..|204|304)$/ or $method eq "HEAD") { 561 # now handle proxy-CONNECT method
480 $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;
481 } else { 574 } else {
482 if (exists $hdr{"content-length"}) { 575 %state = ();
483 $_[0]->unshift_read (chunk => $hdr{"content-length"}, sub { 576 $cb->(undef, { Status => $2, Reason => $3, URL => $url });
484 # could cache persistent connection now
485 if ($hdr{connection} =~ /\bkeep-alive\b/i) {
486 # but we don't, due to misdesigns, this is annoyingly complex
487 };
488
489 $finish->($_[1], \%hdr);
490 });
491 } else {
492 # too bad, need to read until we get an error or EOF,
493 # no way to detect winged data.
494 $_[0]->on_error (sub {
495 $finish->($_[0]{rbuf}, \%hdr);
496 });
497 $_[0]->on_eof (undef);
498 $_[0]->on_read (sub { });
499 }
500 } 577 }
501 }); 578 });
579 } else {
580 &$handle_actual_request;
502 }); 581 }
582
503 }, sub { 583 }, sub {
504 $timeout 584 $timeout
505 }; 585 };
506 }; 586 };
507 587
… …
540The default value for the C<recurse> request parameter (default: C<10>). 620The default value for the C<recurse> request parameter (default: C<10>).
541 621
542=item $AnyEvent::HTTP::USERAGENT 622=item $AnyEvent::HTTP::USERAGENT
543 623
544The default value for the C<User-Agent> header (the default is 624The default value for the C<User-Agent> header (the default is
545C<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)>).
546 626
547=item $AnyEvent::HTTP::MAX_PERSISTENT 627=item $AnyEvent::HTTP::MAX_PERSISTENT
548 628
549The maximum number of persistent connections to keep open (default: 8). 629The maximum number of persistent connections to keep open (default: 8).
550 630
… …
580=head1 AUTHOR 660=head1 AUTHOR
581 661
582 Marc Lehmann <schmorp@schmorp.de> 662 Marc Lehmann <schmorp@schmorp.de>
583 http://home.schmorp.de/ 663 http://home.schmorp.de/
584 664
665With many thanks to Дмитрий Шалашов, who provided countless
666testcases and bugreports.
667
585=cut 668=cut
586 669
5871 6701
588 671

Diff Legend

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