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.67 by root, Fri Dec 31 06:18:54 2010 UTC vs.
Revision 1.71 by root, Fri Dec 31 20:50:58 2010 UTC

… …
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 at least for C<TE:>, C<Referer:> and C<User-Agent:>
158suppressed by using C<undef> for these headers in which case they won't be 158(this can be suppressed by using C<undef> for these headers in which case
159sent at all). 159they won't be 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
185based on the original netscape specification. 185based on the original netscape specification.
186 186
187The C<$hash_ref> must be an (initially empty) hash reference which will 187The C<$hash_ref> must be an (initially empty) hash reference which will
188get updated automatically. It is possible to save the cookie_jar to 188get updated automatically. It is possible to save the cookie jar to
189persistent storage with something like JSON or Storable, but this is not 189persistent storage with something like JSON or Storable, but this is not
190recommended, as expiry times are currently being ignored. 190recommended, as session-only cookies might survive longer than expected.
191 191
192Note that this cookie implementation is not of very high quality, nor 192Note that this cookie implementation is not meant to be complete. If
193meant to be complete. If you want complete cookie management you have to 193you want complete cookie management you have to do that on your
194do that on your own. C<cookie_jar> is meant as a quick fix to get some 194own. C<cookie_jar> is meant as a quick fix to get some cookie-using sites
195cookie-using sites working. Cookies are a privacy disaster, do not use 195working. Cookies are a privacy disaster, do not use them unless required
196them unless required to. 196to.
197
198When cookie processing is enabled, the C<Cookie:> and C<Set-Cookie:>
199headers will be set and handled by this module, otherwise they will be
200left untouched.
197 201
198=item tls_ctx => $scheme | $tls_ctx 202=item tls_ctx => $scheme | $tls_ctx
199 203
200Specifies the AnyEvent::TLS context to be used for https connections. This 204Specifies the AnyEvent::TLS context to be used for https connections. This
201parameter follows the same rules as the C<tls_ctx> parameter to 205parameter follows the same rules as the C<tls_ctx> parameter to
… …
240 244
241This callback is useful, among other things, to quickly reject unwanted 245This callback is useful, among other things, to quickly reject unwanted
242content, which, if it is supposed to be rare, can be faster than first 246content, which, if it is supposed to be rare, can be faster than first
243doing a C<HEAD> request. 247doing a C<HEAD> request.
244 248
249The downside is that cancelling the request makes it impossible to re-use
250the connection. Also, the C<on_header> callback will not receive any
251trailer (headers sent after the response body).
252
245Example: cancel the request unless the content-type is "text/html". 253Example: cancel the request unless the content-type is "text/html".
246 254
247 on_header => sub { 255 on_header => sub {
248 $_[0]{"content-type"} =~ /^text\/html\s*(?:;|$)/ 256 $_[0]{"content-type"} =~ /^text\/html\s*(?:;|$)/
249 }, 257 },
… …
255string instead of the body data. 263string instead of the body data.
256 264
257It has to return either true (in which case AnyEvent::HTTP will continue), 265It 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 266or false, in which case AnyEvent::HTTP will cancel the download (and call
259the completion callback with an error code of C<598>). 267the completion callback with an error code of C<598>).
268
269The downside to cancelling the request is that it makes it impossible to
270re-use the connection.
260 271
261This callback is useful when the data is too large to be held in memory 272This 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 273(so the callback writes it to a file) or when only some information should
263be extracted, or when the body should be processed incrementally. 274be extracted, or when the body should be processed incrementally.
264 275
… …
290If you think you need this, first have a look at C<on_body>, to see if 301If 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. 302that doesn't solve your problem in a better way.
292 303
293=back 304=back
294 305
295Example: make a simple HTTP GET request for http://www.nethype.de/ 306Example: do a simple HTTP GET request for http://www.nethype.de/ and print
307the response body.
296 308
297 http_request GET => "http://www.nethype.de/", sub { 309 http_request GET => "http://www.nethype.de/", sub {
298 my ($body, $hdr) = @_; 310 my ($body, $hdr) = @_;
299 print "$body\n"; 311 print "$body\n";
300 }; 312 };
301 313
302Example: make a HTTP HEAD request on https://www.google.com/, use a 314Example: do a HTTP HEAD request on https://www.google.com/, use a
303timeout of 30 seconds. 315timeout of 30 seconds.
304 316
305 http_request 317 http_request
306 GET => "https://www.google.com", 318 GET => "https://www.google.com",
307 timeout => 30, 319 timeout => 30,
… …
310 use Data::Dumper; 322 use Data::Dumper;
311 print Dumper $hdr; 323 print Dumper $hdr;
312 } 324 }
313 ; 325 ;
314 326
315Example: make another simple HTTP GET request, but immediately try to 327Example: do another simple HTTP GET request, but immediately try to
316cancel it. 328cancel it.
317 329
318 my $request = http_request GET => "http://www.nethype.de/", sub { 330 my $request = http_request GET => "http://www.nethype.de/", sub {
319 my ($body, $hdr) = @_; 331 my ($body, $hdr) = @_;
320 print "$body\n"; 332 print "$body\n";
… …
352 push @{ $CO_SLOT{$_[0]}[1] }, $_[1]; 364 push @{ $CO_SLOT{$_[0]}[1] }, $_[1];
353 365
354 _slot_schedule $_[0]; 366 _slot_schedule $_[0];
355} 367}
356 368
369sub cookie_jar_extract($$$$) {
370 my ($jar, $uscheme, $uhost, $upath) = @_;
371
372 %$jar = () if $jar->{version} != 1;
373
374 my @cookies;
375
376 while (my ($chost, $paths) = each %$jar) {
377 next unless ref $paths;
378
379 if ($chost =~ /^\./) {
380 next unless $chost eq substr $uhost, -length $chost;
381 } elsif ($chost =~ /\./) {
382 next unless $chost eq $uhost;
383 } else {
384 next;
385 }
386
387 while (my ($cpath, $cookies) = each %$paths) {
388 next unless $cpath eq substr $upath, 0, length $cpath;
389
390 while (my ($cookie, $kv) = each %$cookies) {
391 next if $uscheme ne "https" && exists $kv->{secure};
392
393 if (exists $kv->{expires}) {
394 if (AE::now > parse_date ($kv->{expires})) {
395 delete $cookies->{$cookie};
396 next;
397 }
398 }
399
400 my $value = $kv->{value};
401
402 if ($value =~ /[=;,[:space:]]/) {
403 $value =~ s/([\\"])/\\$1/g;
404 $value = "\"$value\"";
405 }
406
407 push @cookies, "$cookie=$value";
408 }
409 }
410 }
411
412 \@cookies
413}
414
357# continue to parse $_ for headers and place them into the arg 415# continue to parse $_ for headers and place them into the arg
358sub parse_hdr() { 416sub parse_hdr() {
359 my %hdr; 417 my %hdr;
360 418
361 # things seen, not parsed: 419 # things seen, not parsed:
… …
436 494
437 $upath =~ s%^/?%/%; 495 $upath =~ s%^/?%/%;
438 496
439 # cookie processing 497 # cookie processing
440 if (my $jar = $arg{cookie_jar}) { 498 if (my $jar = $arg{cookie_jar}) {
441 %$jar = () if $jar->{version} != 1; 499 my $cookies = cookie_jar_extract $jar, $uscheme, $uhost, $upath;
442 500
443 my @cookie;
444
445 while (my ($chost, $v) = each %$jar) {
446 if ($chost =~ /^\./) {
447 next unless $chost eq substr $uhost, -length $chost;
448 } elsif ($chost =~ /\./) {
449 next unless $chost eq $uhost;
450 } else {
451 next;
452 }
453
454 while (my ($cpath, $v) = each %$v) {
455 next unless $cpath eq substr $upath, 0, length $cpath;
456
457 while (my ($k, $v) = each %$v) {
458 next if $uscheme ne "https" && exists $v->{secure};
459 my $value = $v->{value};
460 $value =~ s/([\\"])/\\$1/g;
461 push @cookie, "$k=\"$value\"";
462 }
463 }
464 }
465
466 $hdr{cookie} = join "; ", @cookie 501 $hdr{cookie} = join "; ", @$cookies
467 if @cookie; 502 if @$cookies;
468 } 503 }
469 504
470 my ($rhost, $rport, $rscheme, $rpath); # request host, port, path 505 my ($rhost, $rport, $rscheme, $rpath); # request host, port, path
471 506
472 if ($proxy) { 507 if ($proxy) {
… …
486 $hdr{"user-agent"} = $USERAGENT unless exists $hdr{"user-agent"}; 521 $hdr{"user-agent"} = $USERAGENT unless exists $hdr{"user-agent"};
487 522
488 $hdr{"content-length"} = length $arg{body} 523 $hdr{"content-length"} = length $arg{body}
489 if length $arg{body} || $method ne "GET"; 524 if length $arg{body} || $method ne "GET";
490 525
491 $hdr{connection} = "close TE"; 526 $hdr{connection} = "close TE"; #1.1
492 $hdr{te} = "trailers" unless exists $hdr{te}; 527 $hdr{te} = "trailers" unless exists $hdr{te}; #1.1
493 528
494 my %state = (connect_guard => 1); 529 my %state = (connect_guard => 1);
495 530
496 _get_slot $uhost, sub { 531 _get_slot $uhost, sub {
497 $state{slot_guard} = shift; 532 $state{slot_guard} = shift;
… …
533# ++$KA_COUNT{$_[1]}; 568# ++$KA_COUNT{$_[1]};
534# $state{handle}{ka_count_guard} = AnyEvent::Util::guard { 569# $state{handle}{ka_count_guard} = AnyEvent::Util::guard {
535# --$KA_COUNT{$_[1]} 570# --$KA_COUNT{$_[1]}
536# }; 571# };
537# $hdr{connection} = "keep-alive"; 572# $hdr{connection} = "keep-alive";
538# } else {
539# delete $hdr{connection};
540# } 573# }
541 574
542 $state{handle}->starttls ("connect") if $rscheme eq "https"; 575 $state{handle}->starttls ("connect") if $rscheme eq "https";
543 576
544 # handle actual, non-tunneled, request 577 # handle actual, non-tunneled, request
… …
557 return unless %state; 590 return unless %state;
558 591
559 %hdr = (); # reduce memory usage, save a kitten, also make it possible to re-use 592 %hdr = (); # reduce memory usage, save a kitten, also make it possible to re-use
560 593
561 # status line and headers 594 # status line and headers
562 $state{handle}->push_read (line => $qr_nlnl, sub { 595 $state{read_response} = sub {
563 my $keepalive = pop;
564
565 for ("$_[1]") { 596 for ("$_[1]") {
566 y/\015//d; # weed out any \015, as they show up in the weirdest of places. 597 y/\015//d; # weed out any \015, as they show up in the weirdest of places.
567 598
568 /^HTTP\/([0-9\.]+) \s+ ([0-9]{3}) (?: \s+ ([^\012]*) )? \012/igxc 599 /^HTTP\/([0-9\.]+) \s+ ([0-9]{3}) (?: \s+ ([^\012]*) )? \012/igxc
569 or return (%state = (), $cb->(undef, { @pseudo, Status => 599, Reason => "Invalid server response" })); 600 or return (%state = (), $cb->(undef, { @pseudo, Status => 599, Reason => "Invalid server response" }));
601
602 # 100 Continue handling
603 # should not happen as we don't send expect: 100-continue,
604 # but we handle it just in case.
605 # since we send the request body regardless, if we get an error
606 # we are out of-sync, which we currently do NOT handle correctly.
607 return $state{handle}->push_read (line => $qr_nlnl, $state{read_response})
608 if $2 eq 100;
570 609
571 push @pseudo, 610 push @pseudo,
572 HTTPVersion => $1, 611 HTTPVersion => $1,
573 Status => $2, 612 Status => $2,
574 Reason => $3, 613 Reason => $3,
… …
614 $redirect = 1; 653 $redirect = 1;
615 } 654 }
616 } 655 }
617 656
618 my $finish = sub { # ($data, $err_status, $err_reason[, $keepalive]) 657 my $finish = sub { # ($data, $err_status, $err_reason[, $keepalive])
658 my $keepalive = pop;
659
619 $state{handle}->destroy if $state{handle}; 660 $state{handle}->destroy if $state{handle};
620 %state = (); 661 %state = ();
621 662
622 if (defined $_[1]) { 663 if (defined $_[1]) {
623 $hdr{OrigStatus} = $hdr{Status}; $hdr{Status} = $_[1]; 664 $hdr{OrigStatus} = $hdr{Status}; $hdr{Status} = $_[1];
… …
628 if ($arg{cookie_jar}) { 669 if ($arg{cookie_jar}) {
629 for ($hdr{"set-cookie"}) { 670 for ($hdr{"set-cookie"}) {
630 # parse NAME=VALUE 671 # parse NAME=VALUE
631 my @kv; 672 my @kv;
632 673
674 while (
675 m{
676 \G\s*
677 (?:
678 expires \s*=\s* ([A-Z][a-z][a-z],\ [^,;]+)
633 while (/\G\s* ([^=;,[:space:]]+) \s*=\s* (?: "((?:[^\\"]+|\\.)*)" | ([^=;,[:space:]]*) )/gcxs) { 679 | ([^=;,[:space:]]+) \s*=\s* (?: "((?:[^\\"]+|\\.)*)" | ([^=;,[:space:]]*) )
680 )
681 }gcxsi
682 ) {
634 my $name = $1; 683 my $name = $2;
635 my $value = $3; 684 my $value = $4;
636 685
637 unless ($value) { 686 unless (defined $name) {
687 # expires
688 $name = "expires";
638 $value = $2; 689 $value = $1;
690 } elsif (!defined $value) {
691 # quoted
692 $value = $3;
639 $value =~ s/\\(.)/$1/gs; 693 $value =~ s/\\(.)/$1/gs;
640 } 694 }
641 695
642 push @kv, $name => $value; 696 push @kv, lc $name, $value;
643 697
644 last unless /\G\s*;/gc; 698 last unless /\G\s*;/gc;
645 } 699 }
646 700
647 last unless @kv; 701 last unless @kv;
648 702
649 my $name = shift @kv; 703 my $name = shift @kv;
650 my %kv = (value => shift @kv, @kv); 704 my %kv = (value => shift @kv, @kv);
705
706 $kv{expires} ||= format_date (AE::now + $kv{"max-age"})
707 if exists $kv{"max-age"};
651 708
652 my $cdom; 709 my $cdom;
653 my $cpath = (delete $kv{path}) || "/"; 710 my $cpath = (delete $kv{path}) || "/";
654 711
655 if (exists $kv{domain}) { 712 if (exists $kv{domain}) {
… …
712 $_[0]->on_error (undef); 769 $_[0]->on_error (undef);
713 $_[0]->on_read (undef); 770 $_[0]->on_read (undef);
714 771
715 $finish->(delete $state{handle}); 772 $finish->(delete $state{handle});
716 773
717 } elsif ($hdr{"transfer-encoding"} =~ /chunked/) { 774 } elsif ($hdr{"transfer-encoding"} =~ /\bchunked\b/i) {
775 my $cl = 0;
718 my $body = undef; 776 my $body = undef;
719 my $on_body = $arg{on_body} || sub { $body .= shift; 1 }; 777 my $on_body = $arg{on_body} || sub { $body .= shift; 1 };
720 778
721 $_[0]->on_error (sub { $finish->(undef, 599 => $_[2]) }); 779 $_[0]->on_error (sub { $finish->(undef, 599 => $_[2]) });
722 780
… …
725 or $finish->(undef, 599 => "Garbled chunked transfer encoding"); 783 or $finish->(undef, 599 => "Garbled chunked transfer encoding");
726 784
727 my $len = hex $1; 785 my $len = hex $1;
728 786
729 if ($len) { 787 if ($len) {
788 $cl += $len;
789
730 $_[0]->push_read (chunk => hex $1, sub { 790 $_[0]->push_read (chunk => $len, sub {
731 $on_body->($_[1], \%hdr) 791 $on_body->($_[1], \%hdr)
732 or return $finish->(undef, 598 => "Request cancelled by on_body"); 792 or return $finish->(undef, 598 => "Request cancelled by on_body");
733 793
734 $_[0]->push_read (line => sub { 794 $_[0]->push_read (line => sub {
735 length $_[1] 795 length $_[1]
736 and return $finish->(undef, 599 => "Garbled chunked transfer encoding"); 796 and return $finish->(undef, 599 => "Garbled chunked transfer encoding");
737 $_[0]->push_read (line => $read_chunk); 797 $_[0]->push_read (line => $read_chunk);
738 }); 798 });
739 }); 799 });
740 } else { 800 } else {
801 $hdr{"content-length"} ||= $cl;
802
741 $_[0]->push_read (line => $qr_nlnl, sub { 803 $_[0]->push_read (line => $qr_nlnl, sub {
742 if (length $_[1]) { 804 if (length $_[1]) {
743 for ("$_[1]") { 805 for ("$_[1]") {
744 y/\015//d; # weed out any \015, as they show up in the weirdest of places. 806 y/\015//d; # weed out any \015, as they show up in the weirdest of places.
745 807
… …
796 }); 858 });
797 $_[0]->on_read (sub { }); 859 $_[0]->on_read (sub { });
798 } 860 }
799 } 861 }
800 } 862 }
801 }); 863 };
864
865 $state{handle}->push_read (line => $qr_nlnl, $state{read_response});
802 }; 866 };
803 867
804 # now handle proxy-CONNECT method 868 # now handle proxy-CONNECT method
805 if ($proxy && $uscheme eq "https") { 869 if ($proxy && $uscheme eq "https") {
806 # oh dear, we have to wrap it into a connect request 870 # oh dear, we have to wrap it into a connect request
… …
878Takes a POSIX timestamp (seconds since the epoch) and formats it as a HTTP 942Takes a POSIX timestamp (seconds since the epoch) and formats it as a HTTP
879Date (RFC 2616). 943Date (RFC 2616).
880 944
881=item $timestamp = AnyEvent::HTTP::parse_date $date 945=item $timestamp = AnyEvent::HTTP::parse_date $date
882 946
883Takes a HTTP Date (RFC 2616) and returns the corresponding POSIX 947Takes a HTTP Date (RFC 2616) or a Cookie date (netscape cookie spec) and
884timestamp, or C<undef> if the date cannot be parsed. 948returns the corresponding POSIX timestamp, or C<undef> if the date cannot
949be parsed.
885 950
886=item $AnyEvent::HTTP::MAX_RECURSE 951=item $AnyEvent::HTTP::MAX_RECURSE
887 952
888The default value for the C<recurse> request parameter (default: C<10>). 953The default value for the C<recurse> request parameter (default: C<10>).
889 954
… …
928sub parse_date($) { 993sub parse_date($) {
929 my ($date) = @_; 994 my ($date) = @_;
930 995
931 my ($d, $m, $y, $H, $M, $S); 996 my ($d, $m, $y, $H, $M, $S);
932 997
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$/) { 998 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 999 # RFC 822/1123, required by RFC 2616 (with " ")
1000 # cookie dates (with "-")
1001
935 ($d, $m, $y, $H, $M, $S) = ($1, $2, $3, $4, $5, $6); 1002 ($d, $m, $y, $H, $M, $S) = ($1, $2, $3, $4, $5, $6);
936 1003
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$/) { 1004 } 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 1005 # RFC 850
939 ($d, $m, $y, $H, $M, $S) = ($1, $2, $3 < 69 ? $3 + 2000 : $3 + 1900, $4, $5, $6); 1006 ($d, $m, $y, $H, $M, $S) = ($1, $2, $3 < 69 ? $3 + 2000 : $3 + 1900, $4, $5, $6);

Diff Legend

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