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.64 by root, Fri Dec 31 02:53:29 2010 UTC vs.
Revision 1.68 by root, Fri Dec 31 19:22:18 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;
… …
94C<http_request> returns a "cancellation guard" - you have to keep the 94C<http_request> returns a "cancellation guard" - you have to keep the
95object 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
96destroyed before the callback is called, the request will be cancelled. 96destroyed before the callback is called, the request will be cancelled.
97 97
98The 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
99(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
100second argument. 100(and trailers) as second 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. If an error occurs 105three parts of the HTTP Status-Line of the same name. If an error occurs
… …
150Whether to recurse requests or not, e.g. on redirects, authentication 150Whether to recurse requests or not, e.g. on redirects, authentication
151retries and so on, and how often to do so. 151retries and so on, and how often to do so.
152 152
153=item headers => hashref 153=item headers => hashref
154 154
155The request headers to use. Currently, C<http_request> may provide its 155The request headers to use. Currently, C<http_request> may provide its own
156own C<Host:>, C<Content-Length:>, C<Connection:> and C<Cookie:> headers 156C<Host:>, C<Content-Length:>, C<Connection:> and C<Cookie:> headers and
157and will provide defaults for C<User-Agent:> and C<Referer:> (this can be 157will provide defaults for C<TE:>, C<Referer:> and C<User-Agent:> (this can
158suppressed by using C<undef> for these headers in which case they won't be 158be suppressed by using C<undef> for these headers in which case they won't
159sent at all). 159be sent at all).
160 160
161=item timeout => $seconds 161=item timeout => $seconds
162 162
163The time-out to use for various stages - each connect attempt will reset 163The time-out to use for various stages - each connect attempt will reset
164the timeout, as will read or write activity, i.e. this is not an overall 164the timeout, as will read or write activity, i.e. this is not an overall
… …
174C<$scheme> must be either missing, C<http> for HTTP or C<https> for 174C<$scheme> must be either missing, C<http> for HTTP or C<https> for
175HTTPS. 175HTTPS.
176 176
177=item body => $string 177=item body => $string
178 178
179The request body, usually empty. Will be-sent as-is (future versions of 179The request body, usually empty. Will be sent as-is (future versions of
180this module might offer more options). 180this module might offer more options).
181 181
182=item cookie_jar => $hash_ref 182=item cookie_jar => $hash_ref
183 183
184Passing this parameter enables (simplified) cookie-processing, loosely 184Passing this parameter enables (simplified) cookie-processing, loosely
… …
240 240
241This callback is useful, among other things, to quickly reject unwanted 241This callback is useful, among other things, to quickly reject unwanted
242content, which, if it is supposed to be rare, can be faster than first 242content, which, if it is supposed to be rare, can be faster than first
243doing a C<HEAD> request. 243doing a C<HEAD> request.
244 244
245The downside is that cancelling the request makes it impossible to re-use
246the connection. Also, the C<on_header> callback will not receive any
247trailer (headers sent after the response body).
248
245Example: cancel the request unless the content-type is "text/html". 249Example: cancel the request unless the content-type is "text/html".
246 250
247 on_header => sub { 251 on_header => sub {
248 $_[0]{"content-type"} =~ /^text\/html\s*(?:;|$)/ 252 $_[0]{"content-type"} =~ /^text\/html\s*(?:;|$)/
249 }, 253 },
… …
255string instead of the body data. 259string instead of the body data.
256 260
257It has to return either true (in which case AnyEvent::HTTP will continue), 261It has to return either true (in which case AnyEvent::HTTP will continue),
258or false, in which case AnyEvent::HTTP will cancel the download (and call 262or false, in which case AnyEvent::HTTP will cancel the download (and call
259the completion callback with an error code of C<598>). 263the completion callback with an error code of C<598>).
264
265The downside to cancelling the request is that it makes it impossible to
266re-use the connection.
260 267
261This callback is useful when the data is too large to be held in memory 268This callback is useful when the data is too large to be held in memory
262(so the callback writes it to a file) or when only some information should 269(so the callback writes it to a file) or when only some information should
263be extracted, or when the body should be processed incrementally. 270be extracted, or when the body should be processed incrementally.
264 271
… …
290If you think you need this, first have a look at C<on_body>, to see if 297If you think you need this, first have a look at C<on_body>, to see if
291that doesn't solve your problem in a better way. 298that doesn't solve your problem in a better way.
292 299
293=back 300=back
294 301
295Example: make a simple HTTP GET request for http://www.nethype.de/ 302Example: do a simple HTTP GET request for http://www.nethype.de/ and print
303the response body.
296 304
297 http_request GET => "http://www.nethype.de/", sub { 305 http_request GET => "http://www.nethype.de/", sub {
298 my ($body, $hdr) = @_; 306 my ($body, $hdr) = @_;
299 print "$body\n"; 307 print "$body\n";
300 }; 308 };
301 309
302Example: make a HTTP HEAD request on https://www.google.com/, use a 310Example: do a HTTP HEAD request on https://www.google.com/, use a
303timeout of 30 seconds. 311timeout of 30 seconds.
304 312
305 http_request 313 http_request
306 GET => "https://www.google.com", 314 GET => "https://www.google.com",
307 timeout => 30, 315 timeout => 30,
… …
310 use Data::Dumper; 318 use Data::Dumper;
311 print Dumper $hdr; 319 print Dumper $hdr;
312 } 320 }
313 ; 321 ;
314 322
315Example: make another simple HTTP GET request, but immediately try to 323Example: do another simple HTTP GET request, but immediately try to
316cancel it. 324cancel it.
317 325
318 my $request = http_request GET => "http://www.nethype.de/", sub { 326 my $request = http_request GET => "http://www.nethype.de/", sub {
319 my ($body, $hdr) = @_; 327 my ($body, $hdr) = @_;
320 print "$body\n"; 328 print "$body\n";
… …
350# wait for a free slot on host, call callback 358# wait for a free slot on host, call callback
351sub _get_slot($$) { 359sub _get_slot($$) {
352 push @{ $CO_SLOT{$_[0]}[1] }, $_[1]; 360 push @{ $CO_SLOT{$_[0]}[1] }, $_[1];
353 361
354 _slot_schedule $_[0]; 362 _slot_schedule $_[0];
363}
364
365# continue to parse $_ for headers and place them into the arg
366sub parse_hdr() {
367 my %hdr;
368
369 # things seen, not parsed:
370 # p3pP="NON CUR OTPi OUR NOR UNI"
371
372 $hdr{lc $1} .= ",$2"
373 while /\G
374 ([^:\000-\037]*):
375 [\011\040]*
376 ((?: [^\012]+ | \012[\011\040] )*)
377 \012
378 /gxc;
379
380 /\G$/
381 or return;
382
383 # remove the "," prefix we added to all headers above
384 substr $_, 0, 1, ""
385 for values %hdr;
386
387 \%hdr
355} 388}
356 389
357our $qr_nlnl = qr{(?<![^\012])\015?\012}; 390our $qr_nlnl = qr{(?<![^\012])\015?\012};
358 391
359our $TLS_CTX_LOW = { cache => 1, sslv2 => 1 }; 392our $TLS_CTX_LOW = { cache => 1, sslv2 => 1 };
… …
455 } else { 488 } else {
456 ($rhost, $rport, $rscheme, $rpath) = ($uhost, $uport, $uscheme, $upath); 489 ($rhost, $rport, $rscheme, $rpath) = ($uhost, $uport, $uscheme, $upath);
457 } 490 }
458 491
459 # leave out fragment and query string, just a heuristic 492 # leave out fragment and query string, just a heuristic
460 $hdr{referer} ||= "$uscheme://$uauthority$upath" unless exists $hdr{referer}; 493 $hdr{referer} = "$uscheme://$uauthority$upath" unless exists $hdr{referer};
461 $hdr{"user-agent"} ||= $USERAGENT unless exists $hdr{"user-agent"}; 494 $hdr{"user-agent"} = $USERAGENT unless exists $hdr{"user-agent"};
462 495
463 $hdr{"content-length"} = length $arg{body} 496 $hdr{"content-length"} = length $arg{body}
464 if length $arg{body} || $method ne "GET"; 497 if length $arg{body} || $method ne "GET";
498
499 $hdr{connection} = "close TE"; #1.1
500 $hdr{te} = "trailers" unless exists $hdr{te}; #1.1
465 501
466 my %state = (connect_guard => 1); 502 my %state = (connect_guard => 1);
467 503
468 _get_slot $uhost, sub { 504 _get_slot $uhost, sub {
469 $state{slot_guard} = shift; 505 $state{slot_guard} = shift;
… …
505# ++$KA_COUNT{$_[1]}; 541# ++$KA_COUNT{$_[1]};
506# $state{handle}{ka_count_guard} = AnyEvent::Util::guard { 542# $state{handle}{ka_count_guard} = AnyEvent::Util::guard {
507# --$KA_COUNT{$_[1]} 543# --$KA_COUNT{$_[1]}
508# }; 544# };
509# $hdr{connection} = "keep-alive"; 545# $hdr{connection} = "keep-alive";
510# } else {
511 delete $hdr{connection};
512# } 546# }
513 547
514 $state{handle}->starttls ("connect") if $rscheme eq "https"; 548 $state{handle}->starttls ("connect") if $rscheme eq "https";
515 549
516 # handle actual, non-tunneled, request 550 # handle actual, non-tunneled, request
517 my $handle_actual_request = sub { 551 my $handle_actual_request = sub {
518 $state{handle}->starttls ("connect") if $uscheme eq "https" && !exists $state{handle}{tls}; 552 $state{handle}->starttls ("connect") if $uscheme eq "https" && !exists $state{handle}{tls};
519 553
520 # send request 554 # send request
521 $state{handle}->push_write ( 555 $state{handle}->push_write (
522 "$method $rpath HTTP/1.0\015\012" 556 "$method $rpath HTTP/1.1\015\012"
523 . (join "", map "\u$_: $hdr{$_}\015\012", grep defined $hdr{$_}, keys %hdr) 557 . (join "", map "\u$_: $hdr{$_}\015\012", grep defined $hdr{$_}, keys %hdr)
524 . "\015\012" 558 . "\015\012"
525 . (delete $arg{body}) 559 . (delete $arg{body})
526 ); 560 );
527 561
… …
529 return unless %state; 563 return unless %state;
530 564
531 %hdr = (); # reduce memory usage, save a kitten, also make it possible to re-use 565 %hdr = (); # reduce memory usage, save a kitten, also make it possible to re-use
532 566
533 # status line and headers 567 # status line and headers
534 $state{handle}->push_read (line => $qr_nlnl, sub { 568 $state{read_response} = sub {
535 my $keepalive = pop;
536
537 for ("$_[1]") { 569 for ("$_[1]") {
538 y/\015//d; # weed out any \015, as they show up in the weirdest of places. 570 y/\015//d; # weed out any \015, as they show up in the weirdest of places.
539 571
540 /^HTTP\/([0-9\.]+) \s+ ([0-9]{3}) (?: \s+ ([^\015\012]*) )? \015?\012/igxc 572 /^HTTP\/([0-9\.]+) \s+ ([0-9]{3}) (?: \s+ ([^\012]*) )? \012/igxc
541 or return (%state = (), $cb->(undef, { @pseudo, Status => 599, Reason => "Invalid server response" })); 573 or return (%state = (), $cb->(undef, { @pseudo, Status => 599, Reason => "Invalid server response" }));
574
575 # 100 Continue handling
576 # should not happen as we don't send expect: 100-continue,
577 # but we handle it just in case.
578 # since we send the request body regardless, if we get an error
579 # we are out of-sync, which we currently do NOT handle correctly.
580 return $state{handle}->push_read (line => $qr_nlnl, $state{read_response})
581 if $2 eq 100;
542 582
543 push @pseudo, 583 push @pseudo,
544 HTTPVersion => $1, 584 HTTPVersion => $1,
545 Status => $2, 585 Status => $2,
546 Reason => $3, 586 Reason => $3,
547 ; 587 ;
548 588
549 # things seen, not parsed: 589 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, { @pseudo, Status => 599, Reason => "Garbled response headers" })); 590 or return (%state = (), $cb->(undef, { @pseudo, Status => 599, Reason => "Garbled response headers" }));
591
592 %hdr = (%$hdr, @pseudo);
562 } 593 }
563
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 594
571 # redirect handling 595 # redirect handling
572 # microsoft and other shitheads don't give a shit for following standards, 596 # microsoft and other shitheads don't give a shit for following standards,
573 # try to support some common forms of broken Location headers. 597 # try to support some common forms of broken Location headers.
574 if ($hdr{location} !~ /^(?: $ | [^:\/?\#]+ : )/x) { 598 if ($hdr{location} !~ /^(?: $ | [^:\/?\#]+ : )/x) {
… …
602 $redirect = 1; 626 $redirect = 1;
603 } 627 }
604 } 628 }
605 629
606 my $finish = sub { # ($data, $err_status, $err_reason[, $keepalive]) 630 my $finish = sub { # ($data, $err_status, $err_reason[, $keepalive])
631 my $keepalive = pop;
632
607 $state{handle}->destroy if $state{handle}; 633 $state{handle}->destroy if $state{handle};
608 %state = (); 634 %state = ();
609 635
610 if (defined $_[1]) { 636 if (defined $_[1]) {
611 $hdr{OrigStatus} = $hdr{Status}; $hdr{Status} = $_[1]; 637 $hdr{OrigStatus} = $hdr{Status}; $hdr{Status} = $_[1];
… …
687 or (defined $len && !$len) 713 or (defined $len && !$len)
688 ) { 714 ) {
689 # no body 715 # no body
690 $finish->("", undef, undef, 1); 716 $finish->("", undef, undef, 1);
691 } else { 717 } else {
692 # body handling, four different code paths 718 # body handling, many different code paths
693 # for want_body_handle, on_body (2x), normal (2x) 719 # - no body expected
694 # we might read too much here, but it does not matter yet (no pipelining) 720 # - want_body_handle
721 # - te chunked
722 # - 2x length known (with or without on_body)
723 # - 2x length not known (with or without on_body)
695 if (!$redirect && $arg{want_body_handle}) { 724 if (!$redirect && $arg{want_body_handle}) {
696 $_[0]->on_eof (undef); 725 $_[0]->on_eof (undef);
697 $_[0]->on_error (undef); 726 $_[0]->on_error (undef);
698 $_[0]->on_read (undef); 727 $_[0]->on_read (undef);
699 728
700 $finish->(delete $state{handle}); 729 $finish->(delete $state{handle});
701 730
731 } elsif ($hdr{"transfer-encoding"} =~ /\bchunked\b/i) {
732 my $cl = 0;
733 my $body = undef;
734 my $on_body = $arg{on_body} || sub { $body .= shift; 1 };
735
736 $_[0]->on_error (sub { $finish->(undef, 599 => $_[2]) });
737
738 my $read_chunk; $read_chunk = sub {
739 $_[1] =~ /^([0-9a-fA-F]+)/
740 or $finish->(undef, 599 => "Garbled chunked transfer encoding");
741
742 my $len = hex $1;
743
744 if ($len) {
745 $cl += $len;
746
747 $_[0]->push_read (chunk => $len, sub {
748 $on_body->($_[1], \%hdr)
749 or return $finish->(undef, 598 => "Request cancelled by on_body");
750
751 $_[0]->push_read (line => sub {
752 length $_[1]
753 and return $finish->(undef, 599 => "Garbled chunked transfer encoding");
754 $_[0]->push_read (line => $read_chunk);
755 });
756 });
757 } else {
758 $hdr{"content-length"} ||= $cl;
759
760 $_[0]->push_read (line => $qr_nlnl, sub {
761 if (length $_[1]) {
762 for ("$_[1]") {
763 y/\015//d; # weed out any \015, as they show up in the weirdest of places.
764
765 my $hdr = parse_hdr
766 or return $finish->(undef, 599 => "Garbled response trailers");
767
768 %hdr = (%hdr, %$hdr);
769 }
770 }
771
772 $finish->($body, undef, undef, 1);
773 });
774 }
775 };
776
777 $_[0]->push_read (line => $read_chunk);
778
702 } elsif ($arg{on_body}) { 779 } elsif ($arg{on_body}) {
703 $_[0]->on_error (sub { $finish->(undef, 599 => $_[2]) }); 780 $_[0]->on_error (sub { $finish->(undef, 599 => $_[2]) });
781
704 if ($len) { 782 if ($len) {
705 $_[0]->on_read (sub { 783 $_[0]->on_read (sub {
706 $len -= length $_[0]{rbuf}; 784 $len -= length $_[0]{rbuf};
707 785
708 $arg{on_body}(delete $_[0]{rbuf}, \%hdr) 786 $arg{on_body}(delete $_[0]{rbuf}, \%hdr)
709 or $finish->(undef, 598 => "Request cancelled by on_body"); 787 or return $finish->(undef, 598 => "Request cancelled by on_body");
710 788
711 $len > 0 789 $len > 0
712 or $finish->("", undef, undef, 1); 790 or $finish->("", undef, undef, 1);
713 }); 791 });
714 } else { 792 } else {
… …
737 }); 815 });
738 $_[0]->on_read (sub { }); 816 $_[0]->on_read (sub { });
739 } 817 }
740 } 818 }
741 } 819 }
742 }); 820 };
821
822 $state{handle}->push_read (line => $qr_nlnl, $state{read_response});
743 }; 823 };
744 824
745 # now handle proxy-CONNECT method 825 # now handle proxy-CONNECT method
746 if ($proxy && $uscheme eq "https") { 826 if ($proxy && $uscheme eq "https") {
747 # oh dear, we have to wrap it into a connect request 827 # oh dear, we have to wrap it into a connect request

Diff Legend

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