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.52 by root, Sat Sep 26 10:13:12 2009 UTC vs.
Revision 1.61 by root, Thu Dec 30 03:45:01 2010 UTC

… …
43 43
44use Errno (); 44use Errno ();
45 45
46use AnyEvent 5.0 (); 46use AnyEvent 5.0 ();
47use AnyEvent::Util (); 47use AnyEvent::Util ();
48use AnyEvent::Socket ();
49use AnyEvent::Handle (); 48use AnyEvent::Handle ();
50 49
51use base Exporter::; 50use base Exporter::;
52 51
53our $VERSION = '1.43'; 52our $VERSION = '1.46';
54 53
55our @EXPORT = qw(http_get http_post http_head http_request); 54our @EXPORT = qw(http_get http_post http_head http_request);
56 55
57our $USERAGENT = "Mozilla/5.0 (compatible; U; 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)";
58our $MAX_RECURSE = 10; 57our $MAX_RECURSE = 10;
… …
92must be an absolute http or https URL. 91must be an absolute http or https URL.
93 92
94When called in void context, nothing is returned. In other contexts, 93When called in void context, nothing is returned. In other contexts,
95C<http_request> returns a "cancellation guard" - you have to keep the 94C<http_request> returns a "cancellation guard" - you have to keep the
96object at least alive until the callback get called. If the object gets 95object at least alive until the callback get called. If the object gets
97destroyed before the callbakc is called, the request will be cancelled. 96destroyed before the callback is called, the request will be cancelled.
98 97
99The callback will be called with the response body data as first argument 98The callback will be called with the response body data as first argument
100(or C<undef> if an error occured), and a hash-ref with response headers as 99(or C<undef> if an error occured), and a hash-ref with response headers as
101second argument. 100second argument.
102 101
103All 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
104headers, the "pseudo-headers" C<HTTPVersion>, C<Status> and C<Reason> 103headers, the "pseudo-headers" (uppercase to avoid clashing with possible
104response headers) C<HTTPVersion>, C<Status> and C<Reason> contain the
105contain the three parts of the HTTP Status-Line of the same name. The 105three parts of the HTTP Status-Line of the same name.
106
106pseudo-header C<URL> contains the original URL (which can differ from the 107The pseudo-header C<URL> contains the actual URL (which can differ from
107requested URL when following redirects). 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.
108 119
109If the server sends a header multiple times, then their contents will be 120If the server sends a header multiple times, then their contents will be
110joined together with a comma (C<,>), as per the HTTP spec. 121joined together with a comma (C<,>), as per the HTTP spec.
111 122
112If 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,
… …
199connect (for exmaple, to bind it on a given IP address). This parameter 210connect (for exmaple, to bind it on a given IP address). This parameter
200overrides the prepare callback passed to C<AnyEvent::Socket::tcp_connect> 211overrides the prepare callback passed to C<AnyEvent::Socket::tcp_connect>
201and behaves exactly the same way (e.g. it has to provide a 212and behaves exactly the same way (e.g. it has to provide a
202timeout). See the description for the C<$prepare_cb> argument of 213timeout). See the description for the C<$prepare_cb> argument of
203C<AnyEvent::Socket::tcp_connect> for details. 214C<AnyEvent::Socket::tcp_connect> for details.
215
216=item tcp_connect => $callback->($host, $service, $connect_cb, $prepare_cb)
217
218In even rarer cases you want total control over how AnyEvent::HTTP
219establishes connections. Normally it uses L<AnyEvent::Socket::tcp_connect>
220to do this, but you can provide your own C<tcp_connect> function -
221obviously, it has to follow the same calling conventions, except that it
222may always return a connection guard object.
223
224There are probably lots of weird uses for this function, starting from
225tracing the hosts C<http_request> actually tries to connect, to (inexact
226but fast) host => IP address caching or even socks protocol support.
204 227
205=item on_header => $callback->($headers) 228=item on_header => $callback->($headers)
206 229
207When specified, this callback will be called with the header hash as soon 230When specified, this callback will be called with the header hash as soon
208as headers have been successfully received from the remote server (not on 231as headers have been successfully received from the remote server (not on
… …
326 push @{ $CO_SLOT{$_[0]}[1] }, $_[1]; 349 push @{ $CO_SLOT{$_[0]}[1] }, $_[1];
327 350
328 _slot_schedule $_[0]; 351 _slot_schedule $_[0];
329} 352}
330 353
331our $qr_nl = qr{\015?\012};
332our $qr_nlnl = qr{(?<![^\012])\015?\012}; 354our $qr_nlnl = qr{(?<![^\012])\015?\012};
333 355
334our $TLS_CTX_LOW = { cache => 1, sslv2 => 1 }; 356our $TLS_CTX_LOW = { cache => 1, sslv2 => 1 };
335our $TLS_CTX_HIGH = { cache => 1, verify => 1, verify_peername => "https" }; 357our $TLS_CTX_HIGH = { cache => 1, verify => 1, verify_peername => "https" };
336 358
… …
349 while (my ($k, $v) = each %$hdr) { 371 while (my ($k, $v) = each %$hdr) {
350 $hdr{lc $k} = $v; 372 $hdr{lc $k} = $v;
351 } 373 }
352 } 374 }
353 375
376 # pseudo headers for all subsequent responses
377 my @pseudo = (URL => $url);
378 push @pseudo, Redirect => delete $arg{Redirect} if exists $arg{Redirect};
379
354 my $recurse = exists $arg{recurse} ? delete $arg{recurse} : $MAX_RECURSE; 380 my $recurse = exists $arg{recurse} ? delete $arg{recurse} : $MAX_RECURSE;
355 381
356 return $cb->(undef, { Status => 599, Reason => "Too many redirections", URL => $url }) 382 return $cb->(undef, { Status => 599, Reason => "Too many redirections", @pseudo })
357 if $recurse < 0; 383 if $recurse < 0;
358 384
359 my $proxy = $arg{proxy} || $PROXY; 385 my $proxy = $arg{proxy} || $PROXY;
360 my $timeout = $arg{timeout} || $TIMEOUT; 386 my $timeout = $arg{timeout} || $TIMEOUT;
361 387
362 my ($uscheme, $uauthority, $upath, $query, $fragment) = 388 my ($uscheme, $uauthority, $upath, $query, $fragment) =
363 $url =~ m|(?:([^:/?#]+):)?(?://([^/?#]*))?([^?#]*)(?:\?([^#]*))?(?:#(.*))?|; 389 $url =~ m|(?:([^:/?#]+):)?(?://([^/?#]*))?([^?#]*)(?:(\?[^#]*))?(?:#(.*))?|;
364 390
365 $uscheme = lc $uscheme; 391 $uscheme = lc $uscheme;
366 392
367 my $uport = $uscheme eq "http" ? 80 393 my $uport = $uscheme eq "http" ? 80
368 : $uscheme eq "https" ? 443 394 : $uscheme eq "https" ? 443
369 : return $cb->(undef, { Status => 599, Reason => "Only http and https URL schemes supported", URL => $url }); 395 : return $cb->(undef, { Status => 599, Reason => "Only http and https URL schemes supported", @pseudo });
370 396
371 $uauthority =~ /^(?: .*\@ )? ([^\@:]+) (?: : (\d+) )?$/x 397 $uauthority =~ /^(?: .*\@ )? ([^\@:]+) (?: : (\d+) )?$/x
372 or return $cb->(undef, { Status => 599, Reason => "Unparsable URL", URL => $url }); 398 or return $cb->(undef, { Status => 599, Reason => "Unparsable URL", @pseudo });
373 399
374 my $uhost = $1; 400 my $uhost = $1;
375 $uport = $2 if defined $2; 401 $uport = $2 if defined $2;
376 402
377 $hdr{host} = defined $2 ? "$uhost:$2" : "$uhost"; 403 $hdr{host} = defined $2 ? "$uhost:$2" : "$uhost"
404 unless exists $hdr{host};
378 405
379 $uhost =~ s/^\[(.*)\]$/$1/; 406 $uhost =~ s/^\[(.*)\]$/$1/;
380 $upath .= "?$query" if length $query; 407 $upath .= $query if length $query;
381 408
382 $upath =~ s%^/?%/%; 409 $upath =~ s%^/?%/%;
383 410
384 # cookie processing 411 # cookie processing
385 if (my $jar = $arg{cookie_jar}) { 412 if (my $jar = $arg{cookie_jar}) {
… …
428 455
429 # leave out fragment and query string, just a heuristic 456 # leave out fragment and query string, just a heuristic
430 $hdr{referer} ||= "$uscheme://$uauthority$upath" unless exists $hdr{referer}; 457 $hdr{referer} ||= "$uscheme://$uauthority$upath" unless exists $hdr{referer};
431 $hdr{"user-agent"} ||= $USERAGENT unless exists $hdr{"user-agent"}; 458 $hdr{"user-agent"} ||= $USERAGENT unless exists $hdr{"user-agent"};
432 459
433 $hdr{"content-length"} = length $arg{body}; 460 $hdr{"content-length"} = length $arg{body}
461 if length $arg{body} || $method ne "GET";
434 462
435 my %state = (connect_guard => 1); 463 my %state = (connect_guard => 1);
436 464
437 _get_slot $uhost, sub { 465 _get_slot $uhost, sub {
438 $state{slot_guard} = shift; 466 $state{slot_guard} = shift;
439 467
440 return unless $state{connect_guard}; 468 return unless $state{connect_guard};
441 469
442 $state{connect_guard} = AnyEvent::Socket::tcp_connect $rhost, $rport, sub { 470 my $tcp_connect = $arg{tcp_connect}
471 || do { require AnyEvent::Socket; \&AnyEvent::Socket::tcp_connect };
472
473 $state{connect_guard} = $tcp_connect->(
474 $rhost,
475 $rport,
476 sub {
443 $state{fh} = shift 477 $state{fh} = shift
444 or do { 478 or do {
445 my $err = "$!"; 479 my $err = "$!";
446 %state = (); 480 %state = ();
447 return $cb->(undef, { Status => 599, Reason => $err, URL => $url }); 481 return $cb->(undef, { Status => 599, Reason => $err, @pseudo });
448 }; 482 };
449 483
450 pop; # free memory, save a tree 484 pop; # free memory, save a tree
451 485
452 return unless delete $state{connect_guard}; 486 return unless delete $state{connect_guard};
453 487
454 # get handle 488 # get handle
455 $state{handle} = new AnyEvent::Handle 489 $state{handle} = new AnyEvent::Handle
456 fh => $state{fh}, 490 fh => $state{fh},
491 peername => $rhost,
492 tls_ctx => $arg{tls_ctx},
493 # these need to be reconfigured on keepalive handles
457 timeout => $timeout, 494 timeout => $timeout,
458 peername => $rhost, 495 on_error => sub {
459 tls_ctx => $arg{tls_ctx}; 496 %state = ();
497 $cb->(undef, { Status => 599, Reason => $_[2], @pseudo });
498 },
499 on_eof => sub {
500 %state = ();
501 $cb->(undef, { Status => 599, Reason => "Unexpected end-of-file", @pseudo });
502 },
503 ;
460 504
461 # limit the number of persistent connections 505 # limit the number of persistent connections
462 # keepalive not yet supported 506 # keepalive not yet supported
463 if ($KA_COUNT{$_[1]} < $MAX_PERSISTENT_PER_HOST) { 507# if ($KA_COUNT{$_[1]} < $MAX_PERSISTENT_PER_HOST) {
464 ++$KA_COUNT{$_[1]}; 508# ++$KA_COUNT{$_[1]};
465 $state{handle}{ka_count_guard} = AnyEvent::Util::guard { 509# $state{handle}{ka_count_guard} = AnyEvent::Util::guard {
466 --$KA_COUNT{$_[1]} 510# --$KA_COUNT{$_[1]}
467 }; 511# };
468 $hdr{connection} = "keep-alive"; 512# $hdr{connection} = "keep-alive";
469 } else { 513# } else {
470 delete $hdr{connection}; 514 delete $hdr{connection};
471 } 515# }
472 516
473 # (re-)configure handle
474 $state{handle}->on_error (sub {
475 %state = ();
476 $cb->(undef, { Status => 599, Reason => $_[2], URL => $url });
477 });
478 $state{handle}->on_eof (sub {
479 %state = ();
480 $cb->(undef, { Status => 599, Reason => "Unexpected end-of-file", URL => $url });
481 });
482
483 $state{handle}->starttls ("connect") if $rscheme eq "https"; 517 $state{handle}->starttls ("connect") if $rscheme eq "https";
484 518
485 # handle actual, non-tunneled, request 519 # handle actual, non-tunneled, request
486 my $handle_actual_request = sub { 520 my $handle_actual_request = sub {
487 $state{handle}->starttls ("connect") if $uscheme eq "https" && !exists $state{handle}{tls}; 521 $state{handle}->starttls ("connect") if $uscheme eq "https" && !exists $state{handle}{tls};
488 522
489 # send request 523 # send request
490 $state{handle}->push_write ( 524 $state{handle}->push_write (
491 "$method $rpath HTTP/1.0\015\012" 525 "$method $rpath HTTP/1.0\015\012"
492 . (join "", map "\u$_: $hdr{$_}\015\012", grep defined $hdr{$_}, keys %hdr) 526 . (join "", map "\u$_: $hdr{$_}\015\012", grep defined $hdr{$_}, keys %hdr)
493 . "\015\012" 527 . "\015\012"
494 . (delete $arg{body}) 528 . (delete $arg{body})
495 );
496
497 %hdr = (); # reduce memory usage, save a kitten
498
499 # status line
500 $state{handle}->push_read (line => $qr_nl, sub {
501 $_[1] =~ /^HTTP\/([0-9\.]+) \s+ ([0-9]{3}) (?: \s+ ([^\015\012]*) )?/ix
502 or return (%state = (), $cb->(undef, { Status => 599, Reason => "Invalid server response ($_[1])", URL => $url }));
503
504 my %hdr = ( # response headers
505 HTTPVersion => ",$1",
506 Status => ",$2",
507 Reason => ",$3",
508 URL => ",$url"
509 ); 529 );
510 530
511 # headers, could be optimized a bit 531 # return if error occured during push_write()
532 return unless %state;
533
534 %hdr = (); # reduce memory usage, save a kitten, also make it possible to re-use
535
536 # status line and headers
512 $state{handle}->unshift_read (line => $qr_nlnl, sub { 537 $state{handle}->push_read (line => $qr_nlnl, sub {
513 for ("$_[1]") { 538 for ("$_[1]") {
514 y/\015//d; # weed out any \015, as they show up in the weirdest of places. 539 y/\015//d; # weed out any \015, as they show up in the weirdest of places.
540
541 /^HTTP\/([0-9\.]+) \s+ ([0-9]{3}) (?: \s+ ([^\015\012]*) )? \015?\012/igxc
542 or return (%state = (), $cb->(undef, { Status => 599, Reason => "Invalid server response", @pseudo }));
543
544 push @pseudo,
545 HTTPVersion => $1,
546 Status => $2,
547 Reason => $3,
548 ;
515 549
516 # things seen, not parsed: 550 # things seen, not parsed:
517 # p3pP="NON CUR OTPi OUR NOR UNI" 551 # p3pP="NON CUR OTPi OUR NOR UNI"
518 552
519 $hdr{lc $1} .= ",$2" 553 $hdr{lc $1} .= ",$2"
… …
523 ((?: [^\012]+ | \012[\011\040] )*) 557 ((?: [^\012]+ | \012[\011\040] )*)
524 \012 558 \012
525 /gxc; 559 /gxc;
526 560
527 /\G$/ 561 /\G$/
528 or return (%state = (), $cb->(undef, { Status => 599, Reason => "Garbled response headers", URL => $url })); 562 or return (%state = (), $cb->(undef, { Status => 599, Reason => "Garbled response headers", @pseudo }));
529 } 563 }
530 564
565 # remove the "," prefix we added to all headers above
531 substr $_, 0, 1, "" 566 substr $_, 0, 1, ""
532 for values %hdr; 567 for values %hdr;
568
569 # patch in all pseudo headers
570 %hdr = (%hdr, @pseudo);
533 571
534 # redirect handling 572 # redirect handling
535 # microsoft and other shitheads don't give a shit for following standards, 573 # microsoft and other shitheads don't give a shit for following standards,
536 # try to support some common forms of broken Location headers. 574 # try to support some common forms of broken Location headers.
537 if ($hdr{location} !~ /^(?: $ | [^:\/?\#]+ : )/x) { 575 if ($hdr{location} !~ /^(?: $ | [^:\/?\#]+ : )/x) {
… …
548 } 586 }
549 587
550 my $redirect; 588 my $redirect;
551 589
552 if ($recurse) { 590 if ($recurse) {
553 if ($hdr{Status} =~ /^30[12]$/ && $method ne "POST") { 591 my $status = $hdr{Status};
554 # apparently, mozilla et al. just change POST to GET here 592
555 # more research is needed before we do the same 593 # industry standard is to redirect POST as GET for
556 $redirect = 1; 594 # 301, 302 and 303, in contrast to http/1.0 and 1.1.
557 } elsif ($hdr{Status} == 303) { 595 # also, the UA should ask the user for 301 and 307 and POST,
596 # industry standard seems to be to simply follow.
597 # we go with the industry standard.
598 if ($status == 301 or $status == 302 or $status == 303) {
558 # even http/1.1 is unclear on how to mutate the method 599 # HTTP/1.1 is unclear on how to mutate the method
559 $method = "GET" unless $method eq "HEAD"; 600 $method = "GET" unless $method eq "HEAD";
560 $redirect = 1; 601 $redirect = 1;
561 } elsif ($hdr{Status} == 307 && $method =~ /^(?:GET|HEAD)$/) { 602 } elsif ($status == 307) {
562 $redirect = 1; 603 $redirect = 1;
563 } 604 }
564 } 605 }
565 606
566 my $finish = sub { 607 my $finish = sub {
… …
619 660
620 if ($redirect && exists $hdr{location}) { 661 if ($redirect && exists $hdr{location}) {
621 # we ignore any errors, as it is very common to receive 662 # we ignore any errors, as it is very common to receive
622 # Content-Length != 0 but no actual body 663 # Content-Length != 0 but no actual body
623 # we also access %hdr, as $_[1] might be an erro 664 # we also access %hdr, as $_[1] might be an erro
624 http_request ($method => $hdr{location}, %arg, recurse => $recurse - 1, $cb); 665 http_request (
666 $method => $hdr{location},
667 %arg,
668 recurse => $recurse - 1,
669 Redirect => \@_,
670 $cb);
625 } else { 671 } else {
626 $cb->($_[0], $_[1]); 672 $cb->($_[0], $_[1]);
627 } 673 }
628 }; 674 };
629 675
630 my $len = $hdr{"content-length"}; 676 my $len = $hdr{"content-length"};
631 677
632 if (!$redirect && $arg{on_header} && !$arg{on_header}(\%hdr)) { 678 if (!$redirect && $arg{on_header} && !$arg{on_header}(\%hdr)) {
633 $finish->(undef, { Status => 598, Reason => "Request cancelled by on_header", URL => $url }); 679 $finish->(undef, { Status => 598, Reason => "Request cancelled by on_header", @pseudo });
634 } elsif ( 680 } elsif (
635 $hdr{Status} =~ /^(?:1..|[23]04)$/ 681 $hdr{Status} =~ /^(?:1..|[23]04)$/
636 or $method eq "HEAD" 682 or $method eq "HEAD"
637 or (defined $len && !$len) 683 or (defined $len && !$len)
638 ) { 684 ) {
… …
641 } else { 687 } else {
642 # body handling, four different code paths 688 # body handling, four different code paths
643 # for want_body_handle, on_body (2x), normal (2x) 689 # for want_body_handle, on_body (2x), normal (2x)
644 # we might read too much here, but it does not matter yet (no pers. connections) 690 # we might read too much here, but it does not matter yet (no pers. connections)
645 if (!$redirect && $arg{want_body_handle}) { 691 if (!$redirect && $arg{want_body_handle}) {
646 $_[0]->on_eof (undef); 692 $_[0]->on_eof (undef);
647 $_[0]->on_error (undef); 693 $_[0]->on_error (undef);
648 $_[0]->on_read (undef); 694 $_[0]->on_read (undef);
649 695
650 $finish->(delete $state{handle}, \%hdr); 696 $finish->(delete $state{handle}, \%hdr);
651 697
652 } elsif ($arg{on_body}) { 698 } elsif ($arg{on_body}) {
653 $_[0]->on_error (sub { $finish->(undef, { Status => 599, Reason => $_[2], URL => $url }) }); 699 $_[0]->on_error (sub { $finish->(undef, { Status => 599, Reason => $_[2], @pseudo }) });
654 if ($len) { 700 if ($len) {
655 $_[0]->on_eof (undef); 701 $_[0]->on_eof (undef);
656 $_[0]->on_read (sub { 702 $_[0]->on_read (sub {
657 $len -= length $_[0]{rbuf}; 703 $len -= length $_[0]{rbuf};
658 704
659 $arg{on_body}(delete $_[0]{rbuf}, \%hdr) 705 $arg{on_body}(delete $_[0]{rbuf}, \%hdr)
660 or $finish->(undef, { Status => 598, Reason => "Request cancelled by on_body", URL => $url }); 706 or $finish->(undef, { Status => 598, Reason => "Request cancelled by on_body", @pseudo });
661 707
662 $len > 0 708 $len > 0
663 or $finish->("", \%hdr); 709 or $finish->("", \%hdr);
664 }); 710 });
665 } else { 711 } else {
666 $_[0]->on_eof (sub { 712 $_[0]->on_eof (sub {
667 $finish->("", \%hdr); 713 $finish->("", \%hdr);
668 }); 714 });
669 $_[0]->on_read (sub { 715 $_[0]->on_read (sub {
670 $arg{on_body}(delete $_[0]{rbuf}, \%hdr) 716 $arg{on_body}(delete $_[0]{rbuf}, \%hdr)
671 or $finish->(undef, { Status => 598, Reason => "Request cancelled by on_body", URL => $url }); 717 or $finish->(undef, { Status => 598, Reason => "Request cancelled by on_body", @pseudo });
672 }); 718 });
673 } 719 }
674 } else { 720 } else {
675 $_[0]->on_eof (undef); 721 $_[0]->on_eof (undef);
676 722
677 if ($len) { 723 if ($len) {
678 $_[0]->on_error (sub { $finish->(undef, { Status => 599, Reason => $_[2], URL => $url }) }); 724 $_[0]->on_error (sub { $finish->(undef, { Status => 599, Reason => $_[2], @pseudo }) });
679 $_[0]->on_read (sub { 725 $_[0]->on_read (sub {
680 $finish->((substr delete $_[0]{rbuf}, 0, $len, ""), \%hdr) 726 $finish->((substr delete $_[0]{rbuf}, 0, $len, ""), \%hdr)
681 if $len <= length $_[0]{rbuf}; 727 if $len <= length $_[0]{rbuf};
682 }); 728 });
683 } else { 729 } else {
684 $_[0]->on_error (sub { 730 $_[0]->on_error (sub {
685 $! == Errno::EPIPE || !$! 731 ($! == Errno::EPIPE || !$!)
686 ? $finish->(delete $_[0]{rbuf}, \%hdr) 732 ? $finish->(delete $_[0]{rbuf}, \%hdr)
687 : $finish->(undef, { Status => 599, Reason => $_[2], URL => $url }); 733 : $finish->(undef, { Status => 599, Reason => $_[2], @pseudo });
688 }); 734 });
689 $_[0]->on_read (sub { }); 735 $_[0]->on_read (sub { });
690 } 736 }
691 } 737 }
692 } 738 }
693 }); 739 });
694 }); 740 };
695 };
696 741
697 # now handle proxy-CONNECT method 742 # now handle proxy-CONNECT method
698 if ($proxy && $uscheme eq "https") { 743 if ($proxy && $uscheme eq "https") {
699 # oh dear, we have to wrap it into a connect request 744 # oh dear, we have to wrap it into a connect request
700 745
701 # maybe re-use $uauthority with patched port? 746 # maybe re-use $uauthority with patched port?
702 $state{handle}->push_write ("CONNECT $uhost:$uport HTTP/1.0\015\012Host: $uhost\015\012\015\012"); 747 $state{handle}->push_write ("CONNECT $uhost:$uport HTTP/1.0\015\012Host: $uhost\015\012\015\012");
703 $state{handle}->push_read (line => $qr_nlnl, sub { 748 $state{handle}->push_read (line => $qr_nlnl, sub {
704 $_[1] =~ /^HTTP\/([0-9\.]+) \s+ ([0-9]{3}) (?: \s+ ([^\015\012]*) )?/ix 749 $_[1] =~ /^HTTP\/([0-9\.]+) \s+ ([0-9]{3}) (?: \s+ ([^\015\012]*) )?/ix
705 or return (%state = (), $cb->(undef, { Status => 599, Reason => "Invalid proxy connect response ($_[1])", URL => $url })); 750 or return (%state = (), $cb->(undef, { Status => 599, Reason => "Invalid proxy connect response ($_[1])", @pseudo }));
706 751
707 if ($2 == 200) { 752 if ($2 == 200) {
708 $rpath = $upath; 753 $rpath = $upath;
709 &$handle_actual_request; 754 &$handle_actual_request;
710 } else { 755 } else {
711 %state = (); 756 %state = ();
712 $cb->(undef, { Status => $2, Reason => $3, URL => $url }); 757 $cb->(undef, { Status => $2, Reason => $3, @pseudo });
758 }
713 } 759 });
714 });
715 } else { 760 } else {
716 &$handle_actual_request; 761 &$handle_actual_request;
762 }
763
717 } 764 },
718
719 }, $arg{on_prepare} || sub { $timeout }; 765 $arg{on_prepare} || sub { $timeout }
766 );
720 }; 767 };
721 768
722 defined wantarray && AnyEvent::Util::guard { %state = () } 769 defined wantarray && AnyEvent::Util::guard { %state = () }
723} 770}
724 771
… …
738 &http_request 785 &http_request
739} 786}
740 787
741=back 788=back
742 789
790=head2 DNS CACHING
791
792AnyEvent::HTTP uses the AnyEvent::Socket::tcp_connect function for
793the actual connection, which in turn uses AnyEvent::DNS to resolve
794hostnames. The latter is a simple stub resolver and does no caching
795on its own. If you want DNS caching, you currently have to provide
796your own default resolver (by storing a suitable resolver object in
797C<$AnyEvent::DNS::RESOLVER>).
798
743=head2 GLOBAL FUNCTIONS AND VARIABLES 799=head2 GLOBAL FUNCTIONS AND VARIABLES
744 800
745=over 4 801=over 4
746 802
747=item AnyEvent::HTTP::set_proxy "proxy-url" 803=item AnyEvent::HTTP::set_proxy "proxy-url"
… …
750string of the form C<http://host:port> (optionally C<https:...>), croaks 806string of the form C<http://host:port> (optionally C<https:...>), croaks
751otherwise. 807otherwise.
752 808
753To clear an already-set proxy, use C<undef>. 809To clear an already-set proxy, use C<undef>.
754 810
811=item $date = AnyEvent::HTTP::format_date $timestamp
812
813Takes a POSIX timestamp (seconds since the epoch) and formats it as a HTTP
814Date (RFC 2616).
815
816=item $timestamp = AnyEvent::HTTP::parse_date $date
817
818Takes a HTTP Date (RFC 2616) and returns the corresponding POSIX
819timestamp, or C<undef> if the date cannot be parsed.
820
755=item $AnyEvent::HTTP::MAX_RECURSE 821=item $AnyEvent::HTTP::MAX_RECURSE
756 822
757The default value for the C<recurse> request parameter (default: C<10>). 823The default value for the C<recurse> request parameter (default: C<10>).
758 824
759=item $AnyEvent::HTTP::USERAGENT 825=item $AnyEvent::HTTP::USERAGENT
… …
777connections. This number of can be useful for load-leveling. 843connections. This number of can be useful for load-leveling.
778 844
779=back 845=back
780 846
781=cut 847=cut
848
849our @month = qw(Jan Feb Mar Apr May Jun Jul Aug Sep Oct Nov Dec);
850our @weekday = qw(Sun Mon Tue Wed Thu Fri Sat);
851
852sub format_date($) {
853 my ($time) = @_;
854
855 # RFC 822/1123 format
856 my ($S, $M, $H, $mday, $mon, $year, $wday, $yday, undef) = gmtime $time;
857
858 sprintf "%s, %02d %s %04d %02d:%02d:%02d GMT",
859 $weekday[$wday], $mday, $month[$mon], $year + 1900,
860 $H, $M, $S;
861}
862
863sub parse_date($) {
864 my ($date) = @_;
865
866 my ($d, $m, $y, $H, $M, $S);
867
868 if ($date =~ /^[A-Z][a-z][a-z], ([0-9][0-9]) ([A-Z][a-z][a-z]) ([0-9][0-9][0-9][0-9]) ([0-9][0-9]):([0-9][0-9]):([0-9][0-9]) GMT$/) {
869 # RFC 822/1123, required by RFC 2616
870 ($d, $m, $y, $H, $M, $S) = ($1, $2, $3, $4, $5, $6);
871
872 } elsif ($date =~ /^[A-Z][a-z]+, ([0-9][0-9])-([A-Z][a-z][a-z])-([0-9][0-9]) ([0-9][0-9]):([0-9][0-9]):([0-9][0-9]) GMT$/) {
873 # RFC 850
874 ($d, $m, $y, $H, $M, $S) = ($1, $2, $3 < 69 ? $3 + 2000 : $3 + 1900, $4, $5, $6);
875
876 } elsif ($date =~ /^[A-Z][a-z][a-z] ([A-Z][a-z][a-z]) ([0-9 ][0-9]) ([0-9][0-9]):([0-9][0-9]):([0-9][0-9]) ([0-9][0-9][0-9][0-9])$/) {
877 # ISO C's asctime
878 ($d, $m, $y, $H, $M, $S) = ($2, $1, $6, $3, $4, $5);
879 }
880 # other formats fail in the loop below
881
882 for (0..11) {
883 if ($m eq $month[$_]) {
884 require Time::Local;
885 return Time::Local::timegm ($S, $M, $H, $d, $_, $y);
886 }
887 }
888
889 undef
890}
782 891
783sub set_proxy($) { 892sub set_proxy($) {
784 if (length $_[0]) { 893 if (length $_[0]) {
785 $_[0] =~ m%^(https?):// ([^:/]+) (?: : (\d*) )?%ix 894 $_[0] =~ m%^(https?):// ([^:/]+) (?: : (\d*) )?%ix
786 or Carp::croak "$_[0]: invalid proxy URL"; 895 or Carp::croak "$_[0]: invalid proxy URL";
… …
793# initialise proxy from environment 902# initialise proxy from environment
794eval { 903eval {
795 set_proxy $ENV{http_proxy}; 904 set_proxy $ENV{http_proxy};
796}; 905};
797 906
907=head2 SOCKS PROXIES
908
909Socks proxies are not directly supported by AnyEvent::HTTP. You can
910compile your perl to support socks, or use an external program such as
911F<socksify> (dante) or F<tsocks> to make your program use a socks proxy
912transparently.
913
914Alternatively, for AnyEvent::HTTP only, you can use your own
915C<tcp_connect> function that does the proxy handshake - here is an example
916that works with socks4a proxies:
917
918 use Errno;
919 use AnyEvent::Util;
920 use AnyEvent::Socket;
921 use AnyEvent::Handle;
922
923 # host, port and username of/for your socks4a proxy
924 my $socks_host = "10.0.0.23";
925 my $socks_port = 9050;
926 my $socks_user = "";
927
928 sub socks4a_connect {
929 my ($host, $port, $connect_cb, $prepare_cb) = @_;
930
931 my $hdl = new AnyEvent::Handle
932 connect => [$socks_host, $socks_port],
933 on_prepare => sub { $prepare_cb->($_[0]{fh}) },
934 on_error => sub { $connect_cb->() },
935 ;
936
937 $hdl->push_write (pack "CCnNZ*Z*", 4, 1, $port, 1, $socks_user, $host);
938
939 $hdl->push_read (chunk => 8, sub {
940 my ($hdl, $chunk) = @_;
941 my ($status, $port, $ipn) = unpack "xCna4", $chunk;
942
943 if ($status == 0x5a) {
944 $connect_cb->($hdl->{fh}, (format_address $ipn) . ":$port");
945 } else {
946 $! = Errno::ENXIO; $connect_cb->();
947 }
948 });
949
950 $hdl
951 }
952
953Use C<socks4a_connect> instead of C<tcp_connect> when doing C<http_request>s,
954possibly after switching off other proxy types:
955
956 AnyEvent::HTTP::set_proxy undef; # usually you do not want other proxies
957
958 http_get 'http://www.google.com', tcp_connect => \&socks4a_connect, sub {
959 my ($data, $headers) = @_;
960 ...
961 };
962
798=head1 SEE ALSO 963=head1 SEE ALSO
799 964
800L<AnyEvent>. 965L<AnyEvent>.
801 966
802=head1 AUTHOR 967=head1 AUTHOR

Diff Legend

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