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.56 by root, Mon Sep 6 05:30:54 2010 UTC vs.
Revision 1.66 by root, Fri Dec 31 06:18:30 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.45'; 52our $VERSION = '1.5';
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" (uppercase to avoid clashing with possible 103headers, the "pseudo-headers" (uppercase to avoid clashing with possible
105response headers) C<HTTPVersion>, C<Status> and C<Reason> contain the 104response headers) C<HTTPVersion>, C<Status> and C<Reason> contain the
106three parts of the HTTP Status-Line of the same name. 105three parts of the HTTP Status-Line of the same name. If an error occurs
106during the body phase of a request, then the original C<Status> and
107C<Reason> values from the header are available as C<OrigStatus> and
108C<OrigReason>.
107 109
108The pseudo-header C<URL> contains the actual URL (which can differ from 110The pseudo-header C<URL> contains the actual URL (which can differ from
109the requested URL when following redirects - for example, you might get 111the requested URL when following redirects - for example, you might get
110an error that your URL scheme is not supported even though your URL is a 112an error that your URL scheme is not supported even though your URL is a
111valid http URL because it redirected to an ftp URL, in which case you can 113valid http URL because it redirected to an ftp URL, in which case you can
… …
211connect (for exmaple, to bind it on a given IP address). This parameter 213connect (for exmaple, to bind it on a given IP address). This parameter
212overrides the prepare callback passed to C<AnyEvent::Socket::tcp_connect> 214overrides the prepare callback passed to C<AnyEvent::Socket::tcp_connect>
213and behaves exactly the same way (e.g. it has to provide a 215and behaves exactly the same way (e.g. it has to provide a
214timeout). See the description for the C<$prepare_cb> argument of 216timeout). See the description for the C<$prepare_cb> argument of
215C<AnyEvent::Socket::tcp_connect> for details. 217C<AnyEvent::Socket::tcp_connect> for details.
218
219=item tcp_connect => $callback->($host, $service, $connect_cb, $prepare_cb)
220
221In even rarer cases you want total control over how AnyEvent::HTTP
222establishes connections. Normally it uses L<AnyEvent::Socket::tcp_connect>
223to do this, but you can provide your own C<tcp_connect> function -
224obviously, it has to follow the same calling conventions, except that it
225may always return a connection guard object.
226
227There are probably lots of weird uses for this function, starting from
228tracing the hosts C<http_request> actually tries to connect, to (inexact
229but fast) host => IP address caching or even socks protocol support.
216 230
217=item on_header => $callback->($headers) 231=item on_header => $callback->($headers)
218 232
219When specified, this callback will be called with the header hash as soon 233When specified, this callback will be called with the header hash as soon
220as headers have been successfully received from the remote server (not on 234as headers have been successfully received from the remote server (not on
… …
338 push @{ $CO_SLOT{$_[0]}[1] }, $_[1]; 352 push @{ $CO_SLOT{$_[0]}[1] }, $_[1];
339 353
340 _slot_schedule $_[0]; 354 _slot_schedule $_[0];
341} 355}
342 356
343our $qr_nl = qr{\015?\012}; 357# continue to parse $_ for headers and place them into the arg
358sub parse_hdr() {
359 my %hdr;
360
361 # things seen, not parsed:
362 # p3pP="NON CUR OTPi OUR NOR UNI"
363
364 $hdr{lc $1} .= ",$2"
365 while /\G
366 ([^:\000-\037]*):
367 [\011\040]*
368 ((?: [^\012]+ | \012[\011\040] )*)
369 \012
370 /gxc;
371
372 /\G$/
373 or return;
374
375 # remove the "," prefix we added to all headers above
376 substr $_, 0, 1, ""
377 for values %hdr;
378
379 \%hdr
380}
381
344our $qr_nlnl = qr{(?<![^\012])\015?\012}; 382our $qr_nlnl = qr{(?<![^\012])\015?\012};
345 383
346our $TLS_CTX_LOW = { cache => 1, sslv2 => 1 }; 384our $TLS_CTX_LOW = { cache => 1, sslv2 => 1 };
347our $TLS_CTX_HIGH = { cache => 1, verify => 1, verify_peername => "https" }; 385our $TLS_CTX_HIGH = { cache => 1, verify => 1, verify_peername => "https" };
348 386
… …
367 my @pseudo = (URL => $url); 405 my @pseudo = (URL => $url);
368 push @pseudo, Redirect => delete $arg{Redirect} if exists $arg{Redirect}; 406 push @pseudo, Redirect => delete $arg{Redirect} if exists $arg{Redirect};
369 407
370 my $recurse = exists $arg{recurse} ? delete $arg{recurse} : $MAX_RECURSE; 408 my $recurse = exists $arg{recurse} ? delete $arg{recurse} : $MAX_RECURSE;
371 409
372 return $cb->(undef, { Status => 599, Reason => "Too many redirections", @pseudo }) 410 return $cb->(undef, { @pseudo, Status => 599, Reason => "Too many redirections" })
373 if $recurse < 0; 411 if $recurse < 0;
374 412
375 my $proxy = $arg{proxy} || $PROXY; 413 my $proxy = $arg{proxy} || $PROXY;
376 my $timeout = $arg{timeout} || $TIMEOUT; 414 my $timeout = $arg{timeout} || $TIMEOUT;
377 415
… …
380 418
381 $uscheme = lc $uscheme; 419 $uscheme = lc $uscheme;
382 420
383 my $uport = $uscheme eq "http" ? 80 421 my $uport = $uscheme eq "http" ? 80
384 : $uscheme eq "https" ? 443 422 : $uscheme eq "https" ? 443
385 : return $cb->(undef, { Status => 599, Reason => "Only http and https URL schemes supported", @pseudo }); 423 : return $cb->(undef, { @pseudo, Status => 599, Reason => "Only http and https URL schemes supported" });
386 424
387 $uauthority =~ /^(?: .*\@ )? ([^\@:]+) (?: : (\d+) )?$/x 425 $uauthority =~ /^(?: .*\@ )? ([^\@:]+) (?: : (\d+) )?$/x
388 or return $cb->(undef, { Status => 599, Reason => "Unparsable URL", @pseudo }); 426 or return $cb->(undef, { @pseudo, Status => 599, Reason => "Unparsable URL" });
389 427
390 my $uhost = $1; 428 my $uhost = $1;
391 $uport = $2 if defined $2; 429 $uport = $2 if defined $2;
392 430
393 $hdr{host} = defined $2 ? "$uhost:$2" : "$uhost" 431 $hdr{host} = defined $2 ? "$uhost:$2" : "$uhost"
… …
442 } else { 480 } else {
443 ($rhost, $rport, $rscheme, $rpath) = ($uhost, $uport, $uscheme, $upath); 481 ($rhost, $rport, $rscheme, $rpath) = ($uhost, $uport, $uscheme, $upath);
444 } 482 }
445 483
446 # leave out fragment and query string, just a heuristic 484 # leave out fragment and query string, just a heuristic
447 $hdr{referer} ||= "$uscheme://$uauthority$upath" unless exists $hdr{referer}; 485 $hdr{referer} = "$uscheme://$uauthority$upath" unless exists $hdr{referer};
448 $hdr{"user-agent"} ||= $USERAGENT unless exists $hdr{"user-agent"}; 486 $hdr{"user-agent"} = $USERAGENT unless exists $hdr{"user-agent"};
449 487
450 $hdr{"content-length"} = length $arg{body} 488 $hdr{"content-length"} = length $arg{body}
451 if length $arg{body} || $method ne "GET"; 489 if length $arg{body} || $method ne "GET";
452 490
491 $hdr{connection} = "close TE";
492 $hdr{te} = "trailers" unless exists $hdr{te};
493
453 my %state = (connect_guard => 1); 494 my %state = (connect_guard => 1);
454 495
455 _get_slot $uhost, sub { 496 _get_slot $uhost, sub {
456 $state{slot_guard} = shift; 497 $state{slot_guard} = shift;
457 498
458 return unless $state{connect_guard}; 499 return unless $state{connect_guard};
459 500
460 $state{connect_guard} = AnyEvent::Socket::tcp_connect $rhost, $rport, sub { 501 my $connect_cb = sub {
461 $state{fh} = shift 502 $state{fh} = shift
462 or do { 503 or do {
463 my $err = "$!"; 504 my $err = "$!";
464 %state = (); 505 %state = ();
465 return $cb->(undef, { Status => 599, Reason => $err, @pseudo }); 506 return $cb->(undef, { @pseudo, Status => 599, Reason => $err });
466 }; 507 };
467 508
468 pop; # free memory, save a tree 509 pop; # free memory, save a tree
469 510
470 return unless delete $state{connect_guard}; 511 return unless delete $state{connect_guard};
… …
476 tls_ctx => $arg{tls_ctx}, 517 tls_ctx => $arg{tls_ctx},
477 # these need to be reconfigured on keepalive handles 518 # these need to be reconfigured on keepalive handles
478 timeout => $timeout, 519 timeout => $timeout,
479 on_error => sub { 520 on_error => sub {
480 %state = (); 521 %state = ();
481 $cb->(undef, { Status => 599, Reason => $_[2], @pseudo }); 522 $cb->(undef, { @pseudo, Status => 599, Reason => $_[2] });
482 }, 523 },
483 on_eof => sub { 524 on_eof => sub {
484 %state = (); 525 %state = ();
485 $cb->(undef, { Status => 599, Reason => "Unexpected end-of-file", @pseudo }); 526 $cb->(undef, { @pseudo, Status => 599, Reason => "Unexpected end-of-file" });
486 }, 527 },
487 ; 528 ;
488 529
489 # limit the number of persistent connections 530 # limit the number of persistent connections
490 # keepalive not yet supported 531 # keepalive not yet supported
… …
493# $state{handle}{ka_count_guard} = AnyEvent::Util::guard { 534# $state{handle}{ka_count_guard} = AnyEvent::Util::guard {
494# --$KA_COUNT{$_[1]} 535# --$KA_COUNT{$_[1]}
495# }; 536# };
496# $hdr{connection} = "keep-alive"; 537# $hdr{connection} = "keep-alive";
497# } else { 538# } else {
498 delete $hdr{connection}; 539# delete $hdr{connection};
499# } 540# }
500 541
501 $state{handle}->starttls ("connect") if $rscheme eq "https"; 542 $state{handle}->starttls ("connect") if $rscheme eq "https";
502 543
503 # handle actual, non-tunneled, request 544 # handle actual, non-tunneled, request
504 my $handle_actual_request = sub { 545 my $handle_actual_request = sub {
505 $state{handle}->starttls ("connect") if $uscheme eq "https" && !exists $state{handle}{tls}; 546 $state{handle}->starttls ("connect") if $uscheme eq "https" && !exists $state{handle}{tls};
506 547
507 # send request 548 # send request
508 $state{handle}->push_write ( 549 $state{handle}->push_write (
509 "$method $rpath HTTP/1.0\015\012" 550 "$method $rpath HTTP/1.1\015\012"
510 . (join "", map "\u$_: $hdr{$_}\015\012", grep defined $hdr{$_}, keys %hdr) 551 . (join "", map "\u$_: $hdr{$_}\015\012", grep defined $hdr{$_}, keys %hdr)
511 . "\015\012" 552 . "\015\012"
512 . (delete $arg{body}) 553 . (delete $arg{body})
513 ); 554 );
514 555
515 # return if error occured during push_write() 556 # return if error occured during push_write()
516 return unless %state; 557 return unless %state;
517 558
518 %hdr = (); # reduce memory usage, save a kitten, also make it possible to re-use 559 %hdr = (); # reduce memory usage, save a kitten, also make it possible to re-use
519 560
520 # status line 561 # status line and headers
521 $state{handle}->push_read (line => $qr_nl, sub { 562 $state{handle}->push_read (line => $qr_nlnl, sub {
522 $_[1] =~ /^HTTP\/([0-9\.]+) \s+ ([0-9]{3}) (?: \s+ ([^\015\012]*) )?/ix 563 my $keepalive = pop;
523 or return (%state = (), $cb->(undef, { Status => 599, Reason => "Invalid server response ($_[1])", @pseudo }));
524 564
525 push @pseudo,
526 HTTPVersion => $1,
527 Status => $2,
528 Reason => $3,
529 ;
530
531 # headers, could be optimized a bit
532 $state{handle}->unshift_read (line => $qr_nlnl, sub {
533 for ("$_[1]") { 565 for ("$_[1]") {
534 y/\015//d; # weed out any \015, as they show up in the weirdest of places. 566 y/\015//d; # weed out any \015, as they show up in the weirdest of places.
535 567
536 # things seen, not parsed: 568 /^HTTP\/([0-9\.]+) \s+ ([0-9]{3}) (?: \s+ ([^\012]*) )? \012/igxc
537 # p3pP="NON CUR OTPi OUR NOR UNI" 569 or return (%state = (), $cb->(undef, { @pseudo, Status => 599, Reason => "Invalid server response" }));
538 570
539 $hdr{lc $1} .= ",$2" 571 push @pseudo,
540 while /\G 572 HTTPVersion => $1,
541 ([^:\000-\037]*): 573 Status => $2,
542 [\011\040]* 574 Reason => $3,
543 ((?: [^\012]+ | \012[\011\040] )*)
544 \012
545 /gxc;
546
547 /\G$/ 575 ;
576
577 my $hdr = parse_hdr
548 or return (%state = (), $cb->(undef, { Status => 599, Reason => "Garbled response headers", @pseudo })); 578 or return (%state = (), $cb->(undef, { @pseudo, Status => 599, Reason => "Garbled response headers" }));
579
580 %hdr = (%$hdr, @pseudo);
581 }
582
583 # redirect handling
584 # microsoft and other shitheads don't give a shit for following standards,
585 # try to support some common forms of broken Location headers.
586 if ($hdr{location} !~ /^(?: $ | [^:\/?\#]+ : )/x) {
587 $hdr{location} =~ s/^\.\/+//;
588
589 my $url = "$rscheme://$uhost:$uport";
590
591 unless ($hdr{location} =~ s/^\///) {
592 $url .= $upath;
593 $url =~ s/\/[^\/]*$//;
549 } 594 }
550 595
551 # remove the "," prefix we added to all headers above
552 substr $_, 0, 1, ""
553 for values %hdr;
554
555 # patch in all pseudo headers
556 %hdr = (%hdr, @pseudo);
557
558 # redirect handling
559 # microsoft and other shitheads don't give a shit for following standards,
560 # try to support some common forms of broken Location headers.
561 if ($hdr{location} !~ /^(?: $ | [^:\/?\#]+ : )/x) {
562 $hdr{location} =~ s/^\.\/+//;
563
564 my $url = "$rscheme://$uhost:$uport";
565
566 unless ($hdr{location} =~ s/^\///) {
567 $url .= $upath;
568 $url =~ s/\/[^\/]*$//;
569 }
570
571 $hdr{location} = "$url/$hdr{location}"; 596 $hdr{location} = "$url/$hdr{location}";
597 }
598
599 my $redirect;
600
601 if ($recurse) {
602 my $status = $hdr{Status};
603
604 # industry standard is to redirect POST as GET for
605 # 301, 302 and 303, in contrast to http/1.0 and 1.1.
606 # also, the UA should ask the user for 301 and 307 and POST,
607 # industry standard seems to be to simply follow.
608 # we go with the industry standard.
609 if ($status == 301 or $status == 302 or $status == 303) {
610 # HTTP/1.1 is unclear on how to mutate the method
611 $method = "GET" unless $method eq "HEAD";
612 $redirect = 1;
613 } elsif ($status == 307) {
614 $redirect = 1;
572 } 615 }
616 }
573 617
574 my $redirect; 618 my $finish = sub { # ($data, $err_status, $err_reason[, $keepalive])
619 $state{handle}->destroy if $state{handle};
620 %state = ();
575 621
622 if (defined $_[1]) {
623 $hdr{OrigStatus} = $hdr{Status}; $hdr{Status} = $_[1];
624 $hdr{OrigReason} = $hdr{Reason}; $hdr{Reason} = $_[2];
625 }
626
627 # set-cookie processing
576 if ($recurse) { 628 if ($arg{cookie_jar}) {
577 my $status = $hdr{Status}; 629 for ($hdr{"set-cookie"}) {
630 # parse NAME=VALUE
631 my @kv;
578 632
579 if (($status == 301 || $status == 302) && $method ne "POST") { 633 while (/\G\s* ([^=;,[:space:]]+) \s*=\s* (?: "((?:[^\\"]+|\\.)*)" | ([^=;,[:space:]]*) )/gcxs) {
580 # apparently, mozilla et al. just change POST to GET here
581 # more research is needed before we do the same
582 $redirect = 1; 634 my $name = $1;
583 } elsif ($status == 303) { 635 my $value = $3;
584 # even http/1.1 is unclear on how to mutate the method 636
585 $method = "GET" unless $method eq "HEAD"; 637 unless ($value) {
638 $value = $2;
639 $value =~ s/\\(.)/$1/gs;
640 }
641
642 push @kv, $name => $value;
643
644 last unless /\G\s*;/gc;
645 }
646
647 last unless @kv;
648
649 my $name = shift @kv;
650 my %kv = (value => shift @kv, @kv);
651
652 my $cdom;
653 my $cpath = (delete $kv{path}) || "/";
654
655 if (exists $kv{domain}) {
656 $cdom = delete $kv{domain};
657
658 $cdom =~ s/^\.?/./; # make sure it starts with a "."
659
660 next if $cdom =~ /\.$/;
661
662 # this is not rfc-like and not netscape-like. go figure.
663 my $ndots = $cdom =~ y/.//;
664 next if $ndots < ($cdom =~ /\.[^.][^.]\.[^.][^.]$/ ? 3 : 2);
665 } else {
666 $cdom = $uhost;
667 }
668
586 $redirect = 1; 669 # store it
587 } elsif ($status == 307 && $method =~ /^(?:GET|HEAD)$/) { 670 $arg{cookie_jar}{version} = 1;
588 $redirect = 1; 671 $arg{cookie_jar}{$cdom}{$cpath}{$name} = \%kv;
672
673 redo if /\G\s*,/gc;
589 } 674 }
590 } 675 }
591 676
592 my $finish = sub {
593 $state{handle}->destroy if $state{handle};
594 %state = ();
595
596 # set-cookie processing
597 if ($arg{cookie_jar}) {
598 for ($_[1]{"set-cookie"}) {
599 # parse NAME=VALUE
600 my @kv;
601
602 while (/\G\s* ([^=;,[:space:]]+) \s*=\s* (?: "((?:[^\\"]+|\\.)*)" | ([^=;,[:space:]]*) )/gcxs) {
603 my $name = $1;
604 my $value = $3;
605
606 unless ($value) {
607 $value = $2;
608 $value =~ s/\\(.)/$1/gs;
609 }
610
611 push @kv, $name => $value;
612
613 last unless /\G\s*;/gc;
614 }
615
616 last unless @kv;
617
618 my $name = shift @kv;
619 my %kv = (value => shift @kv, @kv);
620
621 my $cdom;
622 my $cpath = (delete $kv{path}) || "/";
623
624 if (exists $kv{domain}) {
625 $cdom = delete $kv{domain};
626
627 $cdom =~ s/^\.?/./; # make sure it starts with a "."
628
629 next if $cdom =~ /\.$/;
630
631 # this is not rfc-like and not netscape-like. go figure.
632 my $ndots = $cdom =~ y/.//;
633 next if $ndots < ($cdom =~ /\.[^.][^.]\.[^.][^.]$/ ? 3 : 2);
634 } else {
635 $cdom = $uhost;
636 }
637
638 # store it
639 $arg{cookie_jar}{version} = 1;
640 $arg{cookie_jar}{$cdom}{$cpath}{$name} = \%kv;
641
642 redo if /\G\s*,/gc;
643 }
644 }
645
646 if ($redirect && exists $hdr{location}) { 677 if ($redirect && exists $hdr{location}) {
647 # we ignore any errors, as it is very common to receive 678 # we ignore any errors, as it is very common to receive
648 # Content-Length != 0 but no actual body 679 # Content-Length != 0 but no actual body
649 # we also access %hdr, as $_[1] might be an erro 680 # we also access %hdr, as $_[1] might be an erro
650 http_request ( 681 http_request (
651 $method => $hdr{location}, 682 $method => $hdr{location},
652 %arg, 683 %arg,
653 recurse => $recurse - 1, 684 recurse => $recurse - 1,
654 Redirect => \@_, 685 Redirect => [$_[0], \%hdr],
655 $cb); 686 $cb);
656 } else {
657 $cb->($_[0], $_[1]);
658 }
659 };
660
661 my $len = $hdr{"content-length"};
662
663 if (!$redirect && $arg{on_header} && !$arg{on_header}(\%hdr)) {
664 $finish->(undef, { Status => 598, Reason => "Request cancelled by on_header", @pseudo });
665 } elsif (
666 $hdr{Status} =~ /^(?:1..|[23]04)$/
667 or $method eq "HEAD"
668 or (defined $len && !$len)
669 ) {
670 # no body
671 $finish->("", \%hdr);
672 } else { 687 } else {
688 $cb->($_[0], \%hdr);
689 }
690 };
691
692 my $len = $hdr{"content-length"};
693
694 if (!$redirect && $arg{on_header} && !$arg{on_header}(\%hdr)) {
695 $finish->(undef, 598 => "Request cancelled by on_header");
696 } elsif (
697 $hdr{Status} =~ /^(?:1..|204|205|304)$/
698 or $method eq "HEAD"
699 or (defined $len && !$len)
700 ) {
701 # no body
702 $finish->("", undef, undef, 1);
703 } else {
673 # body handling, four different code paths 704 # body handling, many different code paths
674 # for want_body_handle, on_body (2x), normal (2x) 705 # - no body expected
675 # we might read too much here, but it does not matter yet (no pers. connections) 706 # - want_body_handle
707 # - te chunked
708 # - 2x length known (with or without on_body)
709 # - 2x length not known (with or without on_body)
676 if (!$redirect && $arg{want_body_handle}) { 710 if (!$redirect && $arg{want_body_handle}) {
677 $_[0]->on_eof (undef); 711 $_[0]->on_eof (undef);
678 $_[0]->on_error (undef); 712 $_[0]->on_error (undef);
679 $_[0]->on_read (undef); 713 $_[0]->on_read (undef);
680 714
681 $finish->(delete $state{handle}, \%hdr); 715 $finish->(delete $state{handle});
682 716
683 } elsif ($arg{on_body}) { 717 } elsif ($hdr{"transfer-encoding"} =~ /chunked/) {
718 my $body = undef;
719 my $on_body = $arg{on_body} || sub { $body .= shift; 1 };
720
684 $_[0]->on_error (sub { $finish->(undef, { Status => 599, Reason => $_[2], @pseudo }) }); 721 $_[0]->on_error (sub { $finish->(undef, 599 => $_[2]) });
722
723 my $read_chunk; $read_chunk = sub {
724 warn $_[1];#d#
725 $_[1] =~ /^([0-9a-fA-F]+)/
726 or $finish->(undef, 599 => "Garbled chunked transfer encoding");
727
728 my $len = hex $1;
729
685 if ($len) { 730 if ($len) {
686 $_[0]->on_eof (undef); 731 $_[0]->push_read (chunk => hex $1, sub {
732 $on_body->($_[1], \%hdr)
733 or return $finish->(undef, 598 => "Request cancelled by on_body");
734
687 $_[0]->on_read (sub { 735 $_[0]->push_read (line => sub {
688 $len -= length $_[0]{rbuf}; 736 length $_[1]
689 737 and return $finish->(undef, 599 => "Garbled chunked transfer encoding");
690 $arg{on_body}(delete $_[0]{rbuf}, \%hdr) 738 $_[0]->push_read (line => $read_chunk);
691 or $finish->(undef, { Status => 598, Reason => "Request cancelled by on_body", @pseudo });
692
693 $len > 0 739 });
694 or $finish->("", \%hdr);
695 }); 740 });
696 } else { 741 } else {
697 $_[0]->on_eof (sub { 742 $_[0]->push_read (line => $qr_nlnl, sub {
698 $finish->("", \%hdr); 743 if (length $_[1]) {
744 for ("$_[1]") {
745 y/\015//d; # weed out any \015, as they show up in the weirdest of places.
746
747 my $hdr = parse_hdr
748 or return $finish->(undef, 599 => "Garbled response trailers");
749
750 %hdr = (%hdr, %$hdr);
751 }
699 }); 752 }
700 $_[0]->on_read (sub { 753
701 $arg{on_body}(delete $_[0]{rbuf}, \%hdr) 754 $finish->($body, undef, undef, 1);
702 or $finish->(undef, { Status => 598, Reason => "Request cancelled by on_body", @pseudo });
703 }); 755 });
704 } 756 }
757 };
758
759 $_[0]->push_read (line => $read_chunk);
760
761 } elsif ($arg{on_body}) {
762 $_[0]->on_error (sub { $finish->(undef, 599 => $_[2]) });
763
764 if ($len) {
765 $_[0]->on_read (sub {
766 $len -= length $_[0]{rbuf};
767
768 $arg{on_body}(delete $_[0]{rbuf}, \%hdr)
769 or return $finish->(undef, 598 => "Request cancelled by on_body");
770
771 $len > 0
772 or $finish->("", undef, undef, 1);
773 });
705 } else { 774 } else {
706 $_[0]->on_eof (undef); 775 $_[0]->on_eof (sub {
707 776 $finish->("");
708 if ($len) { 777 });
709 $_[0]->on_error (sub { $finish->(undef, { Status => 599, Reason => $_[2], @pseudo }) });
710 $_[0]->on_read (sub { 778 $_[0]->on_read (sub {
779 $arg{on_body}(delete $_[0]{rbuf}, \%hdr)
780 or $finish->(undef, 598 => "Request cancelled by on_body");
781 });
782 }
783 } else {
784 $_[0]->on_eof (undef);
785
786 if ($len) {
787 $_[0]->on_error (sub { $finish->(undef, 599 => $_[2]) });
788 $_[0]->on_read (sub {
711 $finish->((substr delete $_[0]{rbuf}, 0, $len, ""), \%hdr) 789 $finish->((substr delete $_[0]{rbuf}, 0, $len, ""), undef, undef, 1)
712 if $len <= length $_[0]{rbuf}; 790 if $len <= length $_[0]{rbuf};
713 }); 791 });
714 } else { 792 } else {
715 $_[0]->on_error (sub { 793 $_[0]->on_error (sub {
716 $! == Errno::EPIPE || !$! 794 ($! == Errno::EPIPE || !$!)
717 ? $finish->(delete $_[0]{rbuf}, \%hdr) 795 ? $finish->(delete $_[0]{rbuf})
718 : $finish->(undef, { Status => 599, Reason => $_[2], @pseudo }); 796 : $finish->(undef, 599 => $_[2]);
719 }); 797 });
720 $_[0]->on_read (sub { }); 798 $_[0]->on_read (sub { });
721 }
722 } 799 }
723 } 800 }
724 }); 801 }
725 }); 802 });
726 }; 803 };
727 804
728 # now handle proxy-CONNECT method 805 # now handle proxy-CONNECT method
729 if ($proxy && $uscheme eq "https") { 806 if ($proxy && $uscheme eq "https") {
… …
731 808
732 # maybe re-use $uauthority with patched port? 809 # maybe re-use $uauthority with patched port?
733 $state{handle}->push_write ("CONNECT $uhost:$uport HTTP/1.0\015\012Host: $uhost\015\012\015\012"); 810 $state{handle}->push_write ("CONNECT $uhost:$uport HTTP/1.0\015\012Host: $uhost\015\012\015\012");
734 $state{handle}->push_read (line => $qr_nlnl, sub { 811 $state{handle}->push_read (line => $qr_nlnl, sub {
735 $_[1] =~ /^HTTP\/([0-9\.]+) \s+ ([0-9]{3}) (?: \s+ ([^\015\012]*) )?/ix 812 $_[1] =~ /^HTTP\/([0-9\.]+) \s+ ([0-9]{3}) (?: \s+ ([^\015\012]*) )?/ix
736 or return (%state = (), $cb->(undef, { Status => 599, Reason => "Invalid proxy connect response ($_[1])", @pseudo })); 813 or return (%state = (), $cb->(undef, { @pseudo, Status => 599, Reason => "Invalid proxy connect response ($_[1])" }));
737 814
738 if ($2 == 200) { 815 if ($2 == 200) {
739 $rpath = $upath; 816 $rpath = $upath;
740 &$handle_actual_request; 817 &$handle_actual_request;
741 } else { 818 } else {
742 %state = (); 819 %state = ();
743 $cb->(undef, { Status => $2, Reason => $3, @pseudo }); 820 $cb->(undef, { @pseudo, Status => $2, Reason => $3 });
744 } 821 }
745 }); 822 });
746 } else { 823 } else {
747 &$handle_actual_request; 824 &$handle_actual_request;
748 } 825 }
826 };
749 827
750 }, $arg{on_prepare} || sub { $timeout }; 828 my $tcp_connect = $arg{tcp_connect}
829 || do { require AnyEvent::Socket; \&AnyEvent::Socket::tcp_connect };
830
831 $state{connect_guard} = $tcp_connect->($rhost, $rport, $connect_cb, $arg{on_prepare} || sub { $timeout });
832
751 }; 833 };
752 834
753 defined wantarray && AnyEvent::Util::guard { %state = () } 835 defined wantarray && AnyEvent::Util::guard { %state = () }
754} 836}
755 837
… …
790string of the form C<http://host:port> (optionally C<https:...>), croaks 872string of the form C<http://host:port> (optionally C<https:...>), croaks
791otherwise. 873otherwise.
792 874
793To clear an already-set proxy, use C<undef>. 875To clear an already-set proxy, use C<undef>.
794 876
877=item $date = AnyEvent::HTTP::format_date $timestamp
878
879Takes a POSIX timestamp (seconds since the epoch) and formats it as a HTTP
880Date (RFC 2616).
881
882=item $timestamp = AnyEvent::HTTP::parse_date $date
883
884Takes a HTTP Date (RFC 2616) and returns the corresponding POSIX
885timestamp, or C<undef> if the date cannot be parsed.
886
795=item $AnyEvent::HTTP::MAX_RECURSE 887=item $AnyEvent::HTTP::MAX_RECURSE
796 888
797The default value for the C<recurse> request parameter (default: C<10>). 889The default value for the C<recurse> request parameter (default: C<10>).
798 890
799=item $AnyEvent::HTTP::USERAGENT 891=item $AnyEvent::HTTP::USERAGENT
… …
817connections. This number of can be useful for load-leveling. 909connections. This number of can be useful for load-leveling.
818 910
819=back 911=back
820 912
821=cut 913=cut
914
915our @month = qw(Jan Feb Mar Apr May Jun Jul Aug Sep Oct Nov Dec);
916our @weekday = qw(Sun Mon Tue Wed Thu Fri Sat);
917
918sub format_date($) {
919 my ($time) = @_;
920
921 # RFC 822/1123 format
922 my ($S, $M, $H, $mday, $mon, $year, $wday, $yday, undef) = gmtime $time;
923
924 sprintf "%s, %02d %s %04d %02d:%02d:%02d GMT",
925 $weekday[$wday], $mday, $month[$mon], $year + 1900,
926 $H, $M, $S;
927}
928
929sub parse_date($) {
930 my ($date) = @_;
931
932 my ($d, $m, $y, $H, $M, $S);
933
934 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$/) {
935 # RFC 822/1123, required by RFC 2616
936 ($d, $m, $y, $H, $M, $S) = ($1, $2, $3, $4, $5, $6);
937
938 } 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$/) {
939 # RFC 850
940 ($d, $m, $y, $H, $M, $S) = ($1, $2, $3 < 69 ? $3 + 2000 : $3 + 1900, $4, $5, $6);
941
942 } 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])$/) {
943 # ISO C's asctime
944 ($d, $m, $y, $H, $M, $S) = ($2, $1, $6, $3, $4, $5);
945 }
946 # other formats fail in the loop below
947
948 for (0..11) {
949 if ($m eq $month[$_]) {
950 require Time::Local;
951 return Time::Local::timegm ($S, $M, $H, $d, $_, $y);
952 }
953 }
954
955 undef
956}
822 957
823sub set_proxy($) { 958sub set_proxy($) {
824 if (length $_[0]) { 959 if (length $_[0]) {
825 $_[0] =~ m%^(https?):// ([^:/]+) (?: : (\d*) )?%ix 960 $_[0] =~ m%^(https?):// ([^:/]+) (?: : (\d*) )?%ix
826 or Carp::croak "$_[0]: invalid proxy URL"; 961 or Carp::croak "$_[0]: invalid proxy URL";
… …
833# initialise proxy from environment 968# initialise proxy from environment
834eval { 969eval {
835 set_proxy $ENV{http_proxy}; 970 set_proxy $ENV{http_proxy};
836}; 971};
837 972
973=head2 SOCKS PROXIES
974
975Socks proxies are not directly supported by AnyEvent::HTTP. You can
976compile your perl to support socks, or use an external program such as
977F<socksify> (dante) or F<tsocks> to make your program use a socks proxy
978transparently.
979
980Alternatively, for AnyEvent::HTTP only, you can use your own
981C<tcp_connect> function that does the proxy handshake - here is an example
982that works with socks4a proxies:
983
984 use Errno;
985 use AnyEvent::Util;
986 use AnyEvent::Socket;
987 use AnyEvent::Handle;
988
989 # host, port and username of/for your socks4a proxy
990 my $socks_host = "10.0.0.23";
991 my $socks_port = 9050;
992 my $socks_user = "";
993
994 sub socks4a_connect {
995 my ($host, $port, $connect_cb, $prepare_cb) = @_;
996
997 my $hdl = new AnyEvent::Handle
998 connect => [$socks_host, $socks_port],
999 on_prepare => sub { $prepare_cb->($_[0]{fh}) },
1000 on_error => sub { $connect_cb->() },
1001 ;
1002
1003 $hdl->push_write (pack "CCnNZ*Z*", 4, 1, $port, 1, $socks_user, $host);
1004
1005 $hdl->push_read (chunk => 8, sub {
1006 my ($hdl, $chunk) = @_;
1007 my ($status, $port, $ipn) = unpack "xCna4", $chunk;
1008
1009 if ($status == 0x5a) {
1010 $connect_cb->($hdl->{fh}, (format_address $ipn) . ":$port");
1011 } else {
1012 $! = Errno::ENXIO; $connect_cb->();
1013 }
1014 });
1015
1016 $hdl
1017 }
1018
1019Use C<socks4a_connect> instead of C<tcp_connect> when doing C<http_request>s,
1020possibly after switching off other proxy types:
1021
1022 AnyEvent::HTTP::set_proxy undef; # usually you do not want other proxies
1023
1024 http_get 'http://www.google.com', tcp_connect => \&socks4a_connect, sub {
1025 my ($data, $headers) = @_;
1026 ...
1027 };
1028
838=head1 SEE ALSO 1029=head1 SEE ALSO
839 1030
840L<AnyEvent>. 1031L<AnyEvent>.
841 1032
842=head1 AUTHOR 1033=head1 AUTHOR

Diff Legend

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