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.59 by root, Wed Dec 29 23:59:36 2010 UTC vs.
Revision 1.67 by root, Fri Dec 31 06:18:54 2010 UTC

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

Diff Legend

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