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.46 by root, Sat Jul 25 01:29:09 2009 UTC vs.
Revision 1.64 by root, Fri Dec 31 02:53:29 2010 UTC

… …
41use strict; 41use strict;
42no warnings; 42no warnings;
43 43
44use Errno (); 44use Errno ();
45 45
46use AnyEvent 4.8 (); 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.41'; 52our $VERSION = '1.46';
54 53
55our @EXPORT = qw(http_get http_post http_head http_request); 54our @EXPORT = qw(http_get http_post http_head http_request);
56 55
57our $USERAGENT = "Mozilla/5.0 (compatible; U; AnyEvent-HTTP/$VERSION; +http://software.schmorp.de/pkg/AnyEvent)"; 56our $USERAGENT = "Mozilla/5.0 (compatible; U; AnyEvent-HTTP/$VERSION; +http://software.schmorp.de/pkg/AnyEvent)";
58our $MAX_RECURSE = 10; 57our $MAX_RECURSE = 10;
… …
92must be an absolute http or https URL. 91must be an absolute http or https URL.
93 92
94When called in void context, nothing is returned. In other contexts, 93When called in void context, nothing is returned. In other contexts,
95C<http_request> returns a "cancellation guard" - you have to keep the 94C<http_request> returns a "cancellation guard" - you have to keep the
96object at least alive until the callback get called. If the object gets 95object at least alive until the callback get called. If the object gets
97destroyed before the callbakc is called, the request will be cancelled. 96destroyed before the callback is called, the request will be cancelled.
98 97
99The callback will be called with the response body data as first argument 98The callback will be called with the response body data as first argument
100(or C<undef> if an error occured), and a hash-ref with response headers as 99(or C<undef> if an error occured), and a hash-ref with response headers as
101second argument. 100second argument.
102 101
103All the headers in that hash are lowercased. In addition to the response 102All the headers in that hash are lowercased. In addition to the response
104headers, the "pseudo-headers" C<HTTPVersion>, C<Status> and C<Reason> 103headers, the "pseudo-headers" (uppercase to avoid clashing with possible
104response headers) C<HTTPVersion>, C<Status> and C<Reason> contain the
105contain the three parts of the HTTP Status-Line of the same name. The 105three parts of the HTTP Status-Line of the same name. 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>.
109
106pseudo-header C<URL> contains the original URL (which can differ from the 110The pseudo-header C<URL> contains the actual URL (which can differ from
107requested URL when following redirects). 111the requested URL when following redirects - for example, you might get
112an error that your URL scheme is not supported even though your URL is a
113valid http URL because it redirected to an ftp URL, in which case you can
114look at the URL pseudo header).
115
116The pseudo-header C<Redirect> only exists when the request was a result
117of an internal redirect. In that case it is an array reference with
118the C<($data, $headers)> from the redirect response. Note that this
119response could in turn be the result of a redirect itself, and C<<
120$headers->{Redirect}[1]{Redirect} >> will then contain the original
121response, and so on.
108 122
109If the server sends a header multiple times, then their contents will be 123If the server sends a header multiple times, then their contents will be
110joined together with a comma (C<,>), as per the HTTP spec. 124joined together with a comma (C<,>), as per the HTTP spec.
111 125
112If an internal error occurs, such as not being able to resolve a hostname, 126If an internal error occurs, such as not being able to resolve a hostname,
… …
138 152
139=item headers => hashref 153=item headers => hashref
140 154
141The request headers to use. Currently, C<http_request> may provide its 155The request headers to use. Currently, C<http_request> may provide its
142own C<Host:>, C<Content-Length:>, C<Connection:> and C<Cookie:> headers 156own C<Host:>, C<Content-Length:>, C<Connection:> and C<Cookie:> headers
143and will provide defaults for C<User-Agent:> and C<Referer:>. 157and will provide defaults for C<User-Agent:> and C<Referer:> (this can be
158suppressed by using C<undef> for these headers in which case they won't be
159sent at all).
144 160
145=item timeout => $seconds 161=item timeout => $seconds
146 162
147The 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
148the timeout, as will read or write activity. Default timeout is 5 minutes. 164the timeout, as will read or write activity, i.e. this is not an overall
165timeout.
166
167Default timeout is 5 minutes.
149 168
150=item proxy => [$host, $port[, $scheme]] or undef 169=item proxy => [$host, $port[, $scheme]] or undef
151 170
152Use the given http proxy for all requests. If not specified, then the 171Use the given http proxy for all requests. If not specified, then the
153default proxy (as specified by C<$ENV{http_proxy}>) is used. 172default proxy (as specified by C<$ENV{http_proxy}>) is used.
154 173
155C<$scheme> must be either missing or C<http> for HTTP, or C<https> for 174C<$scheme> must be either missing, C<http> for HTTP or C<https> for
156HTTPS. 175HTTPS.
157 176
158=item body => $string 177=item body => $string
159 178
160The 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
… …
185verification, highest compatibility) and high-security (CA and common-name 204verification, highest compatibility) and high-security (CA and common-name
186verification) TLS context. 205verification) TLS context.
187 206
188The default for this option is C<low>, which could be interpreted as "give 207The default for this option is C<low>, which could be interpreted as "give
189me the page, no matter what". 208me the page, no matter what".
209
210=item on_prepare => $callback->($fh)
211
212In rare cases you need to "tune" the socket before it is used to
213connect (for exmaple, to bind it on a given IP address). This parameter
214overrides the prepare callback passed to C<AnyEvent::Socket::tcp_connect>
215and behaves exactly the same way (e.g. it has to provide a
216timeout). See the description for the C<$prepare_cb> argument of
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.
190 230
191=item on_header => $callback->($headers) 231=item on_header => $callback->($headers)
192 232
193When 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
194as headers have been successfully received from the remote server (not on 234as headers have been successfully received from the remote server (not on
… …
312 push @{ $CO_SLOT{$_[0]}[1] }, $_[1]; 352 push @{ $CO_SLOT{$_[0]}[1] }, $_[1];
313 353
314 _slot_schedule $_[0]; 354 _slot_schedule $_[0];
315} 355}
316 356
317our $qr_nl = qr{\015?\012};
318our $qr_nlnl = qr{(?<![^\012])\015?\012}; 357our $qr_nlnl = qr{(?<![^\012])\015?\012};
319 358
320our $TLS_CTX_LOW = { cache => 1, sslv2 => 1 }; 359our $TLS_CTX_LOW = { cache => 1, sslv2 => 1 };
321our $TLS_CTX_HIGH = { cache => 1, verify => 1, verify_peername => "https" }; 360our $TLS_CTX_HIGH = { cache => 1, verify => 1, verify_peername => "https" };
322 361
… …
335 while (my ($k, $v) = each %$hdr) { 374 while (my ($k, $v) = each %$hdr) {
336 $hdr{lc $k} = $v; 375 $hdr{lc $k} = $v;
337 } 376 }
338 } 377 }
339 378
379 # pseudo headers for all subsequent responses
380 my @pseudo = (URL => $url);
381 push @pseudo, Redirect => delete $arg{Redirect} if exists $arg{Redirect};
382
340 my $recurse = exists $arg{recurse} ? delete $arg{recurse} : $MAX_RECURSE; 383 my $recurse = exists $arg{recurse} ? delete $arg{recurse} : $MAX_RECURSE;
341 384
342 return $cb->(undef, { Status => 599, Reason => "Too many redirections", URL => $url }) 385 return $cb->(undef, { @pseudo, Status => 599, Reason => "Too many redirections" })
343 if $recurse < 0; 386 if $recurse < 0;
344 387
345 my $proxy = $arg{proxy} || $PROXY; 388 my $proxy = $arg{proxy} || $PROXY;
346 my $timeout = $arg{timeout} || $TIMEOUT; 389 my $timeout = $arg{timeout} || $TIMEOUT;
347 390
348 my ($uscheme, $uauthority, $upath, $query, $fragment) = 391 my ($uscheme, $uauthority, $upath, $query, $fragment) =
349 $url =~ m|(?:([^:/?#]+):)?(?://([^/?#]*))?([^?#]*)(?:\?([^#]*))?(?:#(.*))?|; 392 $url =~ m|(?:([^:/?#]+):)?(?://([^/?#]*))?([^?#]*)(?:(\?[^#]*))?(?:#(.*))?|;
350 393
351 $uscheme = lc $uscheme; 394 $uscheme = lc $uscheme;
352 395
353 my $uport = $uscheme eq "http" ? 80 396 my $uport = $uscheme eq "http" ? 80
354 : $uscheme eq "https" ? 443 397 : $uscheme eq "https" ? 443
355 : return $cb->(undef, { Status => 599, Reason => "Only http and https URL schemes supported", URL => $url }); 398 : return $cb->(undef, { @pseudo, Status => 599, Reason => "Only http and https URL schemes supported" });
356 399
357 $uauthority =~ /^(?: .*\@ )? ([^\@:]+) (?: : (\d+) )?$/x 400 $uauthority =~ /^(?: .*\@ )? ([^\@:]+) (?: : (\d+) )?$/x
358 or return $cb->(undef, { Status => 599, Reason => "Unparsable URL", URL => $url }); 401 or return $cb->(undef, { @pseudo, Status => 599, Reason => "Unparsable URL" });
359 402
360 my $uhost = $1; 403 my $uhost = $1;
361 $uport = $2 if defined $2; 404 $uport = $2 if defined $2;
362 405
363 $hdr{host} = defined $2 ? "$uhost:$2" : "$uhost"; 406 $hdr{host} = defined $2 ? "$uhost:$2" : "$uhost"
407 unless exists $hdr{host};
364 408
365 $uhost =~ s/^\[(.*)\]$/$1/; 409 $uhost =~ s/^\[(.*)\]$/$1/;
366 $upath .= "?$query" if length $query; 410 $upath .= $query if length $query;
367 411
368 $upath =~ s%^/?%/%; 412 $upath =~ s%^/?%/%;
369 413
370 # cookie processing 414 # cookie processing
371 if (my $jar = $arg{cookie_jar}) { 415 if (my $jar = $arg{cookie_jar}) {
… …
401 my ($rhost, $rport, $rscheme, $rpath); # request host, port, path 445 my ($rhost, $rport, $rscheme, $rpath); # request host, port, path
402 446
403 if ($proxy) { 447 if ($proxy) {
404 ($rpath, $rhost, $rport, $rscheme) = ($url, @$proxy); 448 ($rpath, $rhost, $rport, $rscheme) = ($url, @$proxy);
405 449
450 $rscheme = "http" unless defined $rscheme;
451
406 # don't support https requests over https-proxy transport, 452 # don't support https requests over https-proxy transport,
407 # can't be done with tls as spec'ed, unless you double-encrypt. 453 # can't be done with tls as spec'ed, unless you double-encrypt.
408 $rscheme = "http" if $uscheme eq "https" && $rscheme eq "https"; 454 $rscheme = "http" if $uscheme eq "https" && $rscheme eq "https";
409 } else { 455 } else {
410 ($rhost, $rport, $rscheme, $rpath) = ($uhost, $uport, $uscheme, $upath); 456 ($rhost, $rport, $rscheme, $rpath) = ($uhost, $uport, $uscheme, $upath);
411 } 457 }
412 458
413 $hdr{"user-agent"} ||= $USERAGENT; 459 # leave out fragment and query string, just a heuristic
414 $hdr{referer} ||= "$uscheme://$uauthority$upath"; # leave out fragment and query string, just a heuristic 460 $hdr{referer} ||= "$uscheme://$uauthority$upath" unless exists $hdr{referer};
461 $hdr{"user-agent"} ||= $USERAGENT unless exists $hdr{"user-agent"};
415 462
416 $hdr{"content-length"} = length $arg{body}; 463 $hdr{"content-length"} = length $arg{body}
464 if length $arg{body} || $method ne "GET";
417 465
418 my %state = (connect_guard => 1); 466 my %state = (connect_guard => 1);
419 467
420 _get_slot $uhost, sub { 468 _get_slot $uhost, sub {
421 $state{slot_guard} = shift; 469 $state{slot_guard} = shift;
422 470
423 return unless $state{connect_guard}; 471 return unless $state{connect_guard};
424 472
425 $state{connect_guard} = AnyEvent::Socket::tcp_connect $rhost, $rport, sub { 473 my $connect_cb = sub {
426 $state{fh} = shift 474 $state{fh} = shift
427 or do { 475 or do {
428 my $err = "$!"; 476 my $err = "$!";
429 %state = (); 477 %state = ();
430 return $cb->(undef, { Status => 599, Reason => $err, URL => $url }); 478 return $cb->(undef, { @pseudo, Status => 599, Reason => $err });
431 }; 479 };
432 480
433 pop; # free memory, save a tree 481 pop; # free memory, save a tree
434 482
435 return unless delete $state{connect_guard}; 483 return unless delete $state{connect_guard};
436 484
437 # get handle 485 # get handle
438 $state{handle} = new AnyEvent::Handle 486 $state{handle} = new AnyEvent::Handle
439 fh => $state{fh}, 487 fh => $state{fh},
488 peername => $rhost,
489 tls_ctx => $arg{tls_ctx},
490 # these need to be reconfigured on keepalive handles
440 timeout => $timeout, 491 timeout => $timeout,
441 peername => $rhost, 492 on_error => sub {
442 tls_ctx => $arg{tls_ctx}; 493 %state = ();
494 $cb->(undef, { @pseudo, Status => 599, Reason => $_[2] });
495 },
496 on_eof => sub {
497 %state = ();
498 $cb->(undef, { @pseudo, Status => 599, Reason => "Unexpected end-of-file" });
499 },
500 ;
443 501
444 # limit the number of persistent connections 502 # limit the number of persistent connections
445 # keepalive not yet supported 503 # keepalive not yet supported
446 if ($KA_COUNT{$_[1]} < $MAX_PERSISTENT_PER_HOST) { 504# if ($KA_COUNT{$_[1]} < $MAX_PERSISTENT_PER_HOST) {
447 ++$KA_COUNT{$_[1]}; 505# ++$KA_COUNT{$_[1]};
448 $state{handle}{ka_count_guard} = AnyEvent::Util::guard { 506# $state{handle}{ka_count_guard} = AnyEvent::Util::guard {
449 --$KA_COUNT{$_[1]} 507# --$KA_COUNT{$_[1]}
450 }; 508# };
451 $hdr{connection} = "keep-alive"; 509# $hdr{connection} = "keep-alive";
452 } else { 510# } else {
453 delete $hdr{connection}; 511 delete $hdr{connection};
454 } 512# }
455
456 # (re-)configure handle
457 $state{handle}->on_error (sub {
458 %state = ();
459 $cb->(undef, { Status => 599, Reason => $_[2], URL => $url });
460 });
461 $state{handle}->on_eof (sub {
462 %state = ();
463 $cb->(undef, { Status => 599, Reason => "Unexpected end-of-file", URL => $url });
464 });
465 513
466 $state{handle}->starttls ("connect") if $rscheme eq "https"; 514 $state{handle}->starttls ("connect") if $rscheme eq "https";
467 515
468 # handle actual, non-tunneled, request 516 # handle actual, non-tunneled, request
469 my $handle_actual_request = sub { 517 my $handle_actual_request = sub {
470 $state{handle}->starttls ("connect") if $uscheme eq "https" && !exists $state{handle}{tls}; 518 $state{handle}->starttls ("connect") if $uscheme eq "https" && !exists $state{handle}{tls};
471 519
472 # send request 520 # send request
473 $state{handle}->push_write ( 521 $state{handle}->push_write (
474 "$method $rpath HTTP/1.0\015\012" 522 "$method $rpath HTTP/1.0\015\012"
475 . (join "", map "\u$_: $hdr{$_}\015\012", keys %hdr) 523 . (join "", map "\u$_: $hdr{$_}\015\012", grep defined $hdr{$_}, keys %hdr)
476 . "\015\012" 524 . "\015\012"
477 . (delete $arg{body}) 525 . (delete $arg{body})
478 ); 526 );
479 527
528 # return if error occured during push_write()
529 return unless %state;
530
480 %hdr = (); # reduce memory usage, save a kitten 531 %hdr = (); # reduce memory usage, save a kitten, also make it possible to re-use
481 532
482 # status line 533 # status line and headers
483 $state{handle}->push_read (line => $qr_nl, sub { 534 $state{handle}->push_read (line => $qr_nlnl, sub {
484 $_[1] =~ /^HTTP\/([0-9\.]+) \s+ ([0-9]{3}) (?: \s+ ([^\015\012]*) )?/ix 535 my $keepalive = pop;
485 or return (%state = (), $cb->(undef, { Status => 599, Reason => "Invalid server response ($_[1])", URL => $url }));
486 536
487 my %hdr = ( # response headers
488 HTTPVersion => ",$1",
489 Status => ",$2",
490 Reason => ",$3",
491 URL => ",$url"
492 );
493
494 # headers, could be optimized a bit
495 $state{handle}->unshift_read (line => $qr_nlnl, sub {
496 for ("$_[1]") { 537 for ("$_[1]") {
497 y/\015//d; # weed out any \015, as they show up in the weirdest of places. 538 y/\015//d; # weed out any \015, as they show up in the weirdest of places.
498 539
540 /^HTTP\/([0-9\.]+) \s+ ([0-9]{3}) (?: \s+ ([^\015\012]*) )? \015?\012/igxc
541 or return (%state = (), $cb->(undef, { @pseudo, Status => 599, Reason => "Invalid server response" }));
542
543 push @pseudo,
544 HTTPVersion => $1,
545 Status => $2,
546 Reason => $3,
547 ;
548
499 # things seen, not parsed: 549 # things seen, not parsed:
500 # p3pP="NON CUR OTPi OUR NOR UNI" 550 # p3pP="NON CUR OTPi OUR NOR UNI"
501 551
502 $hdr{lc $1} .= ",$2" 552 $hdr{lc $1} .= ",$2"
503 while /\G 553 while /\G
504 ([^:\000-\037]*): 554 ([^:\000-\037]*):
505 [\011\040]* 555 [\011\040]*
506 ((?: [^\012]+ | \012[\011\040] )*) 556 ((?: [^\012]+ | \012[\011\040] )*)
507 \012 557 \012
508 /gxc; 558 /gxc;
509 559
510 /\G$/ 560 /\G$/
511 or return (%state = (), $cb->(undef, { Status => 599, Reason => "Garbled response headers", URL => $url })); 561 or return (%state = (), $cb->(undef, { @pseudo, Status => 599, Reason => "Garbled response headers" }));
562 }
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
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/\/[^\/]*$//;
512 } 582 }
513 583
514 substr $_, 0, 1, ""
515 for values %hdr;
516
517 # redirect handling
518 # microsoft and other shitheads don't give a shit for following standards,
519 # try to support some common forms of broken Location headers.
520 if ($hdr{location} !~ /^(?: $ | [^:\/?\#]+ : )/x) {
521 $hdr{location} =~ s/^\.\/+//;
522
523 my $url = "$rscheme://$uhost:$uport";
524
525 unless ($hdr{location} =~ s/^\///) {
526 $url .= $upath;
527 $url =~ s/\/[^\/]*$//;
528 }
529
530 $hdr{location} = "$url/$hdr{location}"; 584 $hdr{location} = "$url/$hdr{location}";
585 }
586
587 my $redirect;
588
589 if ($recurse) {
590 my $status = $hdr{Status};
591
592 # industry standard is to redirect POST as GET for
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;
601 } elsif ($status == 307) {
602 $redirect = 1;
531 } 603 }
604 }
532 605
533 my $redirect; 606 my $finish = sub { # ($data, $err_status, $err_reason[, $keepalive])
607 $state{handle}->destroy if $state{handle};
608 %state = ();
534 609
610 if (defined $_[1]) {
611 $hdr{OrigStatus} = $hdr{Status}; $hdr{Status} = $_[1];
612 $hdr{OrigReason} = $hdr{Reason}; $hdr{Reason} = $_[2];
613 }
614
615 # set-cookie processing
535 if ($recurse) { 616 if ($arg{cookie_jar}) {
536 if ($hdr{Status} =~ /^30[12]$/ && $method ne "POST") { 617 for ($hdr{"set-cookie"}) {
537 # apparently, mozilla et al. just change POST to GET here 618 # parse NAME=VALUE
538 # more research is needed before we do the same 619 my @kv;
620
621 while (/\G\s* ([^=;,[:space:]]+) \s*=\s* (?: "((?:[^\\"]+|\\.)*)" | ([^=;,[:space:]]*) )/gcxs) {
539 $redirect = 1; 622 my $name = $1;
540 } elsif ($hdr{Status} == 303) { 623 my $value = $3;
541 # even http/1.1 is unclear on how to mutate the method 624
542 $method = "GET" unless $method eq "HEAD"; 625 unless ($value) {
626 $value = $2;
627 $value =~ s/\\(.)/$1/gs;
628 }
629
630 push @kv, $name => $value;
631
632 last unless /\G\s*;/gc;
633 }
634
635 last unless @kv;
636
637 my $name = shift @kv;
638 my %kv = (value => shift @kv, @kv);
639
640 my $cdom;
641 my $cpath = (delete $kv{path}) || "/";
642
643 if (exists $kv{domain}) {
644 $cdom = delete $kv{domain};
645
646 $cdom =~ s/^\.?/./; # make sure it starts with a "."
647
648 next if $cdom =~ /\.$/;
649
650 # this is not rfc-like and not netscape-like. go figure.
651 my $ndots = $cdom =~ y/.//;
652 next if $ndots < ($cdom =~ /\.[^.][^.]\.[^.][^.]$/ ? 3 : 2);
653 } else {
654 $cdom = $uhost;
655 }
656
543 $redirect = 1; 657 # store it
544 } elsif ($hdr{Status} == 307 && $method =~ /^(?:GET|HEAD)$/) { 658 $arg{cookie_jar}{version} = 1;
545 $redirect = 1; 659 $arg{cookie_jar}{$cdom}{$cpath}{$name} = \%kv;
660
661 redo if /\G\s*,/gc;
546 } 662 }
547 } 663 }
548 664
549 my $finish = sub { 665 if ($redirect && exists $hdr{location}) {
550 $state{handle}->destroy if $state{handle}; 666 # we ignore any errors, as it is very common to receive
551 %state = (); 667 # Content-Length != 0 but no actual body
552 668 # we also access %hdr, as $_[1] might be an erro
553 # set-cookie processing 669 http_request (
554 if ($arg{cookie_jar}) { 670 $method => $hdr{location},
555 for ($_[1]{"set-cookie"}) {
556 # parse NAME=VALUE
557 my @kv;
558
559 while (/\G\s* ([^=;,[:space:]]+) \s*=\s* (?: "((?:[^\\"]+|\\.)*)" | ([^=;,[:space:]]*) )/gcxs) {
560 my $name = $1;
561 my $value = $3;
562
563 unless ($value) {
564 $value = $2;
565 $value =~ s/\\(.)/$1/gs;
566 } 671 %arg,
672 recurse => $recurse - 1,
673 Redirect => [$_[0], \%hdr],
674 $cb);
675 } else {
676 $cb->($_[0], \%hdr);
677 }
678 };
567 679
568 push @kv, $name => $value; 680 my $len = $hdr{"content-length"};
569 681
570 last unless /\G\s*;/gc; 682 if (!$redirect && $arg{on_header} && !$arg{on_header}(\%hdr)) {
683 $finish->(undef, 598 => "Request cancelled by on_header");
684 } elsif (
685 $hdr{Status} =~ /^(?:1..|204|205|304)$/
686 or $method eq "HEAD"
687 or (defined $len && !$len)
688 ) {
689 # no body
690 $finish->("", undef, undef, 1);
691 } else {
692 # body handling, four different code paths
693 # for want_body_handle, on_body (2x), normal (2x)
694 # we might read too much here, but it does not matter yet (no pipelining)
695 if (!$redirect && $arg{want_body_handle}) {
696 $_[0]->on_eof (undef);
697 $_[0]->on_error (undef);
698 $_[0]->on_read (undef);
699
700 $finish->(delete $state{handle});
701
702 } elsif ($arg{on_body}) {
703 $_[0]->on_error (sub { $finish->(undef, 599 => $_[2]) });
704 if ($len) {
705 $_[0]->on_read (sub {
706 $len -= length $_[0]{rbuf};
707
708 $arg{on_body}(delete $_[0]{rbuf}, \%hdr)
709 or $finish->(undef, 598 => "Request cancelled by on_body");
710
571 } 711 $len > 0
572 712 or $finish->("", undef, undef, 1);
573 last unless @kv;
574
575 my $name = shift @kv;
576 my %kv = (value => shift @kv, @kv);
577
578 my $cdom;
579 my $cpath = (delete $kv{path}) || "/";
580
581 if (exists $kv{domain}) {
582 $cdom = delete $kv{domain};
583
584 $cdom =~ s/^\.?/./; # make sure it starts with a "."
585
586 next if $cdom =~ /\.$/;
587
588 # this is not rfc-like and not netscape-like. go figure.
589 my $ndots = $cdom =~ y/.//;
590 next if $ndots < ($cdom =~ /\.[^.][^.]\.[^.][^.]$/ ? 3 : 2);
591 } else {
592 $cdom = $uhost;
593 }
594
595 # store it
596 $arg{cookie_jar}{version} = 1;
597 $arg{cookie_jar}{$cdom}{$cpath}{$name} = \%kv;
598
599 redo if /\G\s*,/gc;
600 } 713 });
714 } else {
715 $_[0]->on_eof (sub {
716 $finish->("");
717 });
718 $_[0]->on_read (sub {
719 $arg{on_body}(delete $_[0]{rbuf}, \%hdr)
720 or $finish->(undef, 598 => "Request cancelled by on_body");
721 });
601 } 722 }
723 } else {
724 $_[0]->on_eof (undef);
602 725
603 if ($redirect) { 726 if ($len) {
604 # we ignore any errors, as it is very common to receive 727 $_[0]->on_error (sub { $finish->(undef, 599 => $_[2]) });
605 # Content-Length != 0 but no actual body 728 $_[0]->on_read (sub {
606 # we also access %hdr, as $_[1] might be an erro 729 $finish->((substr delete $_[0]{rbuf}, 0, $len, ""), undef, undef, 1)
607 http_request ($method => $hdr{location}, %arg, recurse => $recurse - 1, $cb); 730 if $len <= length $_[0]{rbuf};
731 });
608 } else { 732 } else {
609 $cb->($_[0], $_[1]);
610 }
611 };
612
613 my $len = $hdr{"content-length"};
614
615 if (!$redirect && $arg{on_header} && !$arg{on_header}(\%hdr)) {
616 $finish->(undef, { Status => 598, Reason => "Request cancelled by on_header", URL => $url });
617 } elsif (
618 $hdr{Status} =~ /^(?:1..|[23]04)$/
619 or $method eq "HEAD"
620 or (defined $len && !$len)
621 ) {
622 # no body
623 $finish->("", \%hdr);
624 } else {
625 # body handling, four different code paths
626 # for want_body_handle, on_body (2x), normal (2x)
627 # we might read too much here, but it does not matter yet (no pers. connections)
628 if (!$redirect && $arg{want_body_handle}) {
629 $_[0]->on_eof (undef);
630 $_[0]->on_error (undef);
631 $_[0]->on_read (undef);
632
633 $finish->(delete $state{handle}, \%hdr);
634
635 } elsif ($arg{on_body}) {
636 $_[0]->on_error (sub { $finish->(undef, { Status => 599, Reason => $_[2], URL => $url }) });
637 if ($len) {
638 $_[0]->on_eof (undef);
639 $_[0]->on_read (sub {
640 $len -= length $_[0]{rbuf};
641
642 $arg{on_body}(delete $_[0]{rbuf}, \%hdr)
643 or $finish->(undef, { Status => 598, Reason => "Request cancelled by on_body", URL => $url });
644
645 $len > 0
646 or $finish->("", \%hdr);
647 });
648 } else {
649 $_[0]->on_eof (sub {
650 $finish->("", \%hdr);
651 });
652 $_[0]->on_read (sub {
653 $arg{on_body}(delete $_[0]{rbuf}, \%hdr)
654 or $finish->(undef, { Status => 598, Reason => "Request cancelled by on_body", URL => $url });
655 });
656 }
657 } else {
658 $_[0]->on_eof (undef);
659
660 if ($len) {
661 $_[0]->on_error (sub { $finish->(undef, { Status => 599, Reason => $_[2], URL => $url }) });
662 $_[0]->on_read (sub {
663 $finish->((substr delete $_[0]{rbuf}, 0, $len, ""), \%hdr)
664 if $len <= length $_[0]{rbuf};
665 });
666 } else {
667 $_[0]->on_error (sub { 733 $_[0]->on_error (sub {
668 $! == Errno::EPIPE || !$! 734 ($! == Errno::EPIPE || !$!)
669 ? $finish->(delete $_[0]{rbuf}, \%hdr) 735 ? $finish->(delete $_[0]{rbuf})
670 : $finish->(undef, { Status => 599, Reason => $_[2], URL => $url }); 736 : $finish->(undef, 599 => $_[2]);
671 }); 737 });
672 $_[0]->on_read (sub { }); 738 $_[0]->on_read (sub { });
673 }
674 } 739 }
675 } 740 }
676 }); 741 }
677 }); 742 });
678 }; 743 };
679 744
680 # now handle proxy-CONNECT method 745 # now handle proxy-CONNECT method
681 if ($proxy && $uscheme eq "https") { 746 if ($proxy && $uscheme eq "https") {
… …
683 748
684 # maybe re-use $uauthority with patched port? 749 # maybe re-use $uauthority with patched port?
685 $state{handle}->push_write ("CONNECT $uhost:$uport HTTP/1.0\015\012Host: $uhost\015\012\015\012"); 750 $state{handle}->push_write ("CONNECT $uhost:$uport HTTP/1.0\015\012Host: $uhost\015\012\015\012");
686 $state{handle}->push_read (line => $qr_nlnl, sub { 751 $state{handle}->push_read (line => $qr_nlnl, sub {
687 $_[1] =~ /^HTTP\/([0-9\.]+) \s+ ([0-9]{3}) (?: \s+ ([^\015\012]*) )?/ix 752 $_[1] =~ /^HTTP\/([0-9\.]+) \s+ ([0-9]{3}) (?: \s+ ([^\015\012]*) )?/ix
688 or return (%state = (), $cb->(undef, { Status => 599, Reason => "Invalid proxy connect response ($_[1])", URL => $url })); 753 or return (%state = (), $cb->(undef, { @pseudo, Status => 599, Reason => "Invalid proxy connect response ($_[1])" }));
689 754
690 if ($2 == 200) { 755 if ($2 == 200) {
691 $rpath = $upath; 756 $rpath = $upath;
692 &$handle_actual_request; 757 &$handle_actual_request;
693 } else { 758 } else {
694 %state = (); 759 %state = ();
695 $cb->(undef, { Status => $2, Reason => $3, URL => $url }); 760 $cb->(undef, { @pseudo, Status => $2, Reason => $3 });
696 } 761 }
697 }); 762 });
698 } else { 763 } else {
699 &$handle_actual_request; 764 &$handle_actual_request;
700 } 765 }
701
702 }, sub {
703 $timeout
704 }; 766 };
767
768 my $tcp_connect = $arg{tcp_connect}
769 || do { require AnyEvent::Socket; \&AnyEvent::Socket::tcp_connect };
770
771 $state{connect_guard} = $tcp_connect->($rhost, $rport, $connect_cb, $arg{on_prepare} || sub { $timeout });
772
705 }; 773 };
706 774
707 defined wantarray && AnyEvent::Util::guard { %state = () } 775 defined wantarray && AnyEvent::Util::guard { %state = () }
708} 776}
709 777
… …
723 &http_request 791 &http_request
724} 792}
725 793
726=back 794=back
727 795
796=head2 DNS CACHING
797
798AnyEvent::HTTP uses the AnyEvent::Socket::tcp_connect function for
799the actual connection, which in turn uses AnyEvent::DNS to resolve
800hostnames. The latter is a simple stub resolver and does no caching
801on its own. If you want DNS caching, you currently have to provide
802your own default resolver (by storing a suitable resolver object in
803C<$AnyEvent::DNS::RESOLVER>).
804
728=head2 GLOBAL FUNCTIONS AND VARIABLES 805=head2 GLOBAL FUNCTIONS AND VARIABLES
729 806
730=over 4 807=over 4
731 808
732=item AnyEvent::HTTP::set_proxy "proxy-url" 809=item AnyEvent::HTTP::set_proxy "proxy-url"
733 810
734Sets the default proxy server to use. The proxy-url must begin with a 811Sets the default proxy server to use. The proxy-url must begin with a
735string of the form C<http://host:port> (optionally C<https:...>). 812string of the form C<http://host:port> (optionally C<https:...>), croaks
813otherwise.
814
815To clear an already-set proxy, use C<undef>.
816
817=item $date = AnyEvent::HTTP::format_date $timestamp
818
819Takes a POSIX timestamp (seconds since the epoch) and formats it as a HTTP
820Date (RFC 2616).
821
822=item $timestamp = AnyEvent::HTTP::parse_date $date
823
824Takes a HTTP Date (RFC 2616) and returns the corresponding POSIX
825timestamp, or C<undef> if the date cannot be parsed.
736 826
737=item $AnyEvent::HTTP::MAX_RECURSE 827=item $AnyEvent::HTTP::MAX_RECURSE
738 828
739The default value for the C<recurse> request parameter (default: C<10>). 829The default value for the C<recurse> request parameter (default: C<10>).
740 830
… …
743The default value for the C<User-Agent> header (the default is 833The default value for the C<User-Agent> header (the default is
744C<Mozilla/5.0 (compatible; U; AnyEvent-HTTP/$VERSION; +http://software.schmorp.de/pkg/AnyEvent)>). 834C<Mozilla/5.0 (compatible; U; AnyEvent-HTTP/$VERSION; +http://software.schmorp.de/pkg/AnyEvent)>).
745 835
746=item $AnyEvent::HTTP::MAX_PER_HOST 836=item $AnyEvent::HTTP::MAX_PER_HOST
747 837
748The maximum number of concurrent conenctions to the same host (identified 838The maximum number of concurrent connections to the same host (identified
749by the hostname). If the limit is exceeded, then the additional requests 839by the hostname). If the limit is exceeded, then the additional requests
750are queued until previous connections are closed. 840are queued until previous connections are closed.
751 841
752The default value for this is C<4>, and it is highly advisable to not 842The default value for this is C<4>, and it is highly advisable to not
753increase it. 843increase it.
… …
760 850
761=back 851=back
762 852
763=cut 853=cut
764 854
855our @month = qw(Jan Feb Mar Apr May Jun Jul Aug Sep Oct Nov Dec);
856our @weekday = qw(Sun Mon Tue Wed Thu Fri Sat);
857
858sub format_date($) {
859 my ($time) = @_;
860
861 # RFC 822/1123 format
862 my ($S, $M, $H, $mday, $mon, $year, $wday, $yday, undef) = gmtime $time;
863
864 sprintf "%s, %02d %s %04d %02d:%02d:%02d GMT",
865 $weekday[$wday], $mday, $month[$mon], $year + 1900,
866 $H, $M, $S;
867}
868
869sub parse_date($) {
870 my ($date) = @_;
871
872 my ($d, $m, $y, $H, $M, $S);
873
874 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$/) {
875 # RFC 822/1123, required by RFC 2616
876 ($d, $m, $y, $H, $M, $S) = ($1, $2, $3, $4, $5, $6);
877
878 } 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$/) {
879 # RFC 850
880 ($d, $m, $y, $H, $M, $S) = ($1, $2, $3 < 69 ? $3 + 2000 : $3 + 1900, $4, $5, $6);
881
882 } 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])$/) {
883 # ISO C's asctime
884 ($d, $m, $y, $H, $M, $S) = ($2, $1, $6, $3, $4, $5);
885 }
886 # other formats fail in the loop below
887
888 for (0..11) {
889 if ($m eq $month[$_]) {
890 require Time::Local;
891 return Time::Local::timegm ($S, $M, $H, $d, $_, $y);
892 }
893 }
894
895 undef
896}
897
765sub set_proxy($) { 898sub set_proxy($) {
899 if (length $_[0]) {
766 $PROXY = [$2, $3 || 3128, $1] if $_[0] =~ m%^(https?):// ([^:/]+) (?: : (\d*) )?%ix; 900 $_[0] =~ m%^(https?):// ([^:/]+) (?: : (\d*) )?%ix
901 or Carp::croak "$_[0]: invalid proxy URL";
902 $PROXY = [$2, $3 || 3128, $1]
903 } else {
904 undef $PROXY;
905 }
767} 906}
768 907
769# initialise proxy from environment 908# initialise proxy from environment
909eval {
770set_proxy $ENV{http_proxy}; 910 set_proxy $ENV{http_proxy};
911};
912
913=head2 SOCKS PROXIES
914
915Socks proxies are not directly supported by AnyEvent::HTTP. You can
916compile your perl to support socks, or use an external program such as
917F<socksify> (dante) or F<tsocks> to make your program use a socks proxy
918transparently.
919
920Alternatively, for AnyEvent::HTTP only, you can use your own
921C<tcp_connect> function that does the proxy handshake - here is an example
922that works with socks4a proxies:
923
924 use Errno;
925 use AnyEvent::Util;
926 use AnyEvent::Socket;
927 use AnyEvent::Handle;
928
929 # host, port and username of/for your socks4a proxy
930 my $socks_host = "10.0.0.23";
931 my $socks_port = 9050;
932 my $socks_user = "";
933
934 sub socks4a_connect {
935 my ($host, $port, $connect_cb, $prepare_cb) = @_;
936
937 my $hdl = new AnyEvent::Handle
938 connect => [$socks_host, $socks_port],
939 on_prepare => sub { $prepare_cb->($_[0]{fh}) },
940 on_error => sub { $connect_cb->() },
941 ;
942
943 $hdl->push_write (pack "CCnNZ*Z*", 4, 1, $port, 1, $socks_user, $host);
944
945 $hdl->push_read (chunk => 8, sub {
946 my ($hdl, $chunk) = @_;
947 my ($status, $port, $ipn) = unpack "xCna4", $chunk;
948
949 if ($status == 0x5a) {
950 $connect_cb->($hdl->{fh}, (format_address $ipn) . ":$port");
951 } else {
952 $! = Errno::ENXIO; $connect_cb->();
953 }
954 });
955
956 $hdl
957 }
958
959Use C<socks4a_connect> instead of C<tcp_connect> when doing C<http_request>s,
960possibly after switching off other proxy types:
961
962 AnyEvent::HTTP::set_proxy undef; # usually you do not want other proxies
963
964 http_get 'http://www.google.com', tcp_connect => \&socks4a_connect, sub {
965 my ($data, $headers) = @_;
966 ...
967 };
771 968
772=head1 SEE ALSO 969=head1 SEE ALSO
773 970
774L<AnyEvent>. 971L<AnyEvent>.
775 972

Diff Legend

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