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

Diff Legend

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