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.45 by root, Fri Jul 17 16:56:36 2009 UTC vs.
Revision 1.68 by root, Fri Dec 31 19:22:18 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.5';
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
101second argument. 100(and trailers) as second 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,
136Whether to recurse requests or not, e.g. on redirects, authentication 150Whether to recurse requests or not, e.g. on redirects, authentication
137retries and so on, and how often to do so. 151retries and so on, and how often to do so.
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 own
142own C<Host:>, C<Content-Length:>, C<Connection:> and C<Cookie:> headers 156C<Host:>, C<Content-Length:>, C<Connection:> and C<Cookie:> headers and
143and will provide defaults for C<User-Agent:> and C<Referer:>. 157will provide defaults for C<TE:>, C<Referer:> and C<User-Agent:> (this can
158be suppressed by using C<undef> for these headers in which case they won't
159be sent 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
161this module might offer more options). 180this module might offer more options).
162 181
163=item cookie_jar => $hash_ref 182=item cookie_jar => $hash_ref
164 183
165Passing this parameter enables (simplified) cookie-processing, loosely 184Passing this parameter enables (simplified) cookie-processing, loosely
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".
190 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.
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
195locally-generated errors). 235locally-generated errors).
200 240
201This callback is useful, among other things, to quickly reject unwanted 241This callback is useful, among other things, to quickly reject unwanted
202content, 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
203doing a C<HEAD> request. 243doing a C<HEAD> request.
204 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
205Example: cancel the request unless the content-type is "text/html". 249Example: cancel the request unless the content-type is "text/html".
206 250
207 on_header => sub { 251 on_header => sub {
208 $_[0]{"content-type"} =~ /^text\/html\s*(?:;|$)/ 252 $_[0]{"content-type"} =~ /^text\/html\s*(?:;|$)/
209 }, 253 },
215string instead of the body data. 259string instead of the body data.
216 260
217It 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),
218or 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
219the 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.
220 267
221This 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
222(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
223be extracted, or when the body should be processed incrementally. 270be extracted, or when the body should be processed incrementally.
224 271
250If 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
251that doesn't solve your problem in a better way. 298that doesn't solve your problem in a better way.
252 299
253=back 300=back
254 301
255Example: 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.
256 304
257 http_request GET => "http://www.nethype.de/", sub { 305 http_request GET => "http://www.nethype.de/", sub {
258 my ($body, $hdr) = @_; 306 my ($body, $hdr) = @_;
259 print "$body\n"; 307 print "$body\n";
260 }; 308 };
261 309
262Example: 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
263timeout of 30 seconds. 311timeout of 30 seconds.
264 312
265 http_request 313 http_request
266 GET => "https://www.google.com", 314 GET => "https://www.google.com",
267 timeout => 30, 315 timeout => 30,
270 use Data::Dumper; 318 use Data::Dumper;
271 print Dumper $hdr; 319 print Dumper $hdr;
272 } 320 }
273 ; 321 ;
274 322
275Example: make another simple HTTP GET request, but immediately try to 323Example: do another simple HTTP GET request, but immediately try to
276cancel it. 324cancel it.
277 325
278 my $request = http_request GET => "http://www.nethype.de/", sub { 326 my $request = http_request GET => "http://www.nethype.de/", sub {
279 my ($body, $hdr) = @_; 327 my ($body, $hdr) = @_;
280 print "$body\n"; 328 print "$body\n";
312 push @{ $CO_SLOT{$_[0]}[1] }, $_[1]; 360 push @{ $CO_SLOT{$_[0]}[1] }, $_[1];
313 361
314 _slot_schedule $_[0]; 362 _slot_schedule $_[0];
315} 363}
316 364
317our $qr_nl = qr<\015?\012>; 365# continue to parse $_ for headers and place them into the arg
318our $qr_nlnl = qr<\015?\012\015?\012>; 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
388}
389
390our $qr_nlnl = qr{(?<![^\012])\015?\012};
319 391
320our $TLS_CTX_LOW = { cache => 1, sslv2 => 1 }; 392our $TLS_CTX_LOW = { cache => 1, sslv2 => 1 };
321our $TLS_CTX_HIGH = { cache => 1, verify => 1, verify_peername => "https" }; 393our $TLS_CTX_HIGH = { cache => 1, verify => 1, verify_peername => "https" };
322 394
323sub http_request($$@) { 395sub http_request($$@) {
335 while (my ($k, $v) = each %$hdr) { 407 while (my ($k, $v) = each %$hdr) {
336 $hdr{lc $k} = $v; 408 $hdr{lc $k} = $v;
337 } 409 }
338 } 410 }
339 411
412 # pseudo headers for all subsequent responses
413 my @pseudo = (URL => $url);
414 push @pseudo, Redirect => delete $arg{Redirect} if exists $arg{Redirect};
415
340 my $recurse = exists $arg{recurse} ? delete $arg{recurse} : $MAX_RECURSE; 416 my $recurse = exists $arg{recurse} ? delete $arg{recurse} : $MAX_RECURSE;
341 417
342 return $cb->(undef, { Status => 599, Reason => "Too many redirections", URL => $url }) 418 return $cb->(undef, { @pseudo, Status => 599, Reason => "Too many redirections" })
343 if $recurse < 0; 419 if $recurse < 0;
344 420
345 my $proxy = $arg{proxy} || $PROXY; 421 my $proxy = $arg{proxy} || $PROXY;
346 my $timeout = $arg{timeout} || $TIMEOUT; 422 my $timeout = $arg{timeout} || $TIMEOUT;
347 423
348 my ($uscheme, $uauthority, $upath, $query, $fragment) = 424 my ($uscheme, $uauthority, $upath, $query, $fragment) =
349 $url =~ m|(?:([^:/?#]+):)?(?://([^/?#]*))?([^?#]*)(?:\?([^#]*))?(?:#(.*))?|; 425 $url =~ m|(?:([^:/?#]+):)?(?://([^/?#]*))?([^?#]*)(?:(\?[^#]*))?(?:#(.*))?|;
350 426
351 $uscheme = lc $uscheme; 427 $uscheme = lc $uscheme;
352 428
353 my $uport = $uscheme eq "http" ? 80 429 my $uport = $uscheme eq "http" ? 80
354 : $uscheme eq "https" ? 443 430 : $uscheme eq "https" ? 443
355 : return $cb->(undef, { Status => 599, Reason => "Only http and https URL schemes supported", URL => $url }); 431 : return $cb->(undef, { @pseudo, Status => 599, Reason => "Only http and https URL schemes supported" });
356 432
357 $uauthority =~ /^(?: .*\@ )? ([^\@:]+) (?: : (\d+) )?$/x 433 $uauthority =~ /^(?: .*\@ )? ([^\@:]+) (?: : (\d+) )?$/x
358 or return $cb->(undef, { Status => 599, Reason => "Unparsable URL", URL => $url }); 434 or return $cb->(undef, { @pseudo, Status => 599, Reason => "Unparsable URL" });
359 435
360 my $uhost = $1; 436 my $uhost = $1;
361 $uport = $2 if defined $2; 437 $uport = $2 if defined $2;
362 438
363 $hdr{host} = defined $2 ? "$uhost:$2" : "$uhost"; 439 $hdr{host} = defined $2 ? "$uhost:$2" : "$uhost"
440 unless exists $hdr{host};
364 441
365 $uhost =~ s/^\[(.*)\]$/$1/; 442 $uhost =~ s/^\[(.*)\]$/$1/;
366 $upath .= "?$query" if length $query; 443 $upath .= $query if length $query;
367 444
368 $upath =~ s%^/?%/%; 445 $upath =~ s%^/?%/%;
369 446
370 # cookie processing 447 # cookie processing
371 if (my $jar = $arg{cookie_jar}) { 448 if (my $jar = $arg{cookie_jar}) {
401 my ($rhost, $rport, $rscheme, $rpath); # request host, port, path 478 my ($rhost, $rport, $rscheme, $rpath); # request host, port, path
402 479
403 if ($proxy) { 480 if ($proxy) {
404 ($rpath, $rhost, $rport, $rscheme) = ($url, @$proxy); 481 ($rpath, $rhost, $rport, $rscheme) = ($url, @$proxy);
405 482
483 $rscheme = "http" unless defined $rscheme;
484
406 # don't support https requests over https-proxy transport, 485 # don't support https requests over https-proxy transport,
407 # can't be done with tls as spec'ed, unless you double-encrypt. 486 # can't be done with tls as spec'ed, unless you double-encrypt.
408 $rscheme = "http" if $uscheme eq "https" && $rscheme eq "https"; 487 $rscheme = "http" if $uscheme eq "https" && $rscheme eq "https";
409 } else { 488 } else {
410 ($rhost, $rport, $rscheme, $rpath) = ($uhost, $uport, $uscheme, $upath); 489 ($rhost, $rport, $rscheme, $rpath) = ($uhost, $uport, $uscheme, $upath);
411 } 490 }
412 491
413 $hdr{"user-agent"} ||= $USERAGENT; 492 # leave out fragment and query string, just a heuristic
414 $hdr{referer} ||= "$uscheme://$uauthority$upath"; # leave out fragment and query string, just a heuristic 493 $hdr{referer} = "$uscheme://$uauthority$upath" unless exists $hdr{referer};
494 $hdr{"user-agent"} = $USERAGENT unless exists $hdr{"user-agent"};
415 495
416 $hdr{"content-length"} = length $arg{body}; 496 $hdr{"content-length"} = length $arg{body}
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
417 501
418 my %state = (connect_guard => 1); 502 my %state = (connect_guard => 1);
419 503
420 _get_slot $uhost, sub { 504 _get_slot $uhost, sub {
421 $state{slot_guard} = shift; 505 $state{slot_guard} = shift;
422 506
423 return unless $state{connect_guard}; 507 return unless $state{connect_guard};
424 508
425 $state{connect_guard} = AnyEvent::Socket::tcp_connect $rhost, $rport, sub { 509 my $connect_cb = sub {
426 $state{fh} = shift 510 $state{fh} = shift
427 or do { 511 or do {
428 my $err = "$!"; 512 my $err = "$!";
429 %state = (); 513 %state = ();
430 return $cb->(undef, { Status => 599, Reason => $err, URL => $url }); 514 return $cb->(undef, { @pseudo, Status => 599, Reason => $err });
431 }; 515 };
432 516
433 pop; # free memory, save a tree 517 pop; # free memory, save a tree
434 518
435 return unless delete $state{connect_guard}; 519 return unless delete $state{connect_guard};
436 520
437 # get handle 521 # get handle
438 $state{handle} = new AnyEvent::Handle 522 $state{handle} = new AnyEvent::Handle
439 fh => $state{fh}, 523 fh => $state{fh},
524 peername => $rhost,
525 tls_ctx => $arg{tls_ctx},
526 # these need to be reconfigured on keepalive handles
440 timeout => $timeout, 527 timeout => $timeout,
441 peername => $rhost, 528 on_error => sub {
442 tls_ctx => $arg{tls_ctx}; 529 %state = ();
530 $cb->(undef, { @pseudo, Status => 599, Reason => $_[2] });
531 },
532 on_eof => sub {
533 %state = ();
534 $cb->(undef, { @pseudo, Status => 599, Reason => "Unexpected end-of-file" });
535 },
536 ;
443 537
444 # limit the number of persistent connections 538 # limit the number of persistent connections
445 # keepalive not yet supported 539 # keepalive not yet supported
446 if ($KA_COUNT{$_[1]} < $MAX_PERSISTENT_PER_HOST) { 540# if ($KA_COUNT{$_[1]} < $MAX_PERSISTENT_PER_HOST) {
447 ++$KA_COUNT{$_[1]}; 541# ++$KA_COUNT{$_[1]};
448 $state{handle}{ka_count_guard} = AnyEvent::Util::guard { 542# $state{handle}{ka_count_guard} = AnyEvent::Util::guard {
449 --$KA_COUNT{$_[1]} 543# --$KA_COUNT{$_[1]}
450 }; 544# };
451 $hdr{connection} = "keep-alive"; 545# $hdr{connection} = "keep-alive";
452 } else {
453 delete $hdr{connection};
454 } 546# }
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 547
466 $state{handle}->starttls ("connect") if $rscheme eq "https"; 548 $state{handle}->starttls ("connect") if $rscheme eq "https";
467 549
468 # handle actual, non-tunneled, request 550 # handle actual, non-tunneled, request
469 my $handle_actual_request = sub { 551 my $handle_actual_request = sub {
470 $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};
471 553
472 # send request 554 # send request
473 $state{handle}->push_write ( 555 $state{handle}->push_write (
474 "$method $rpath HTTP/1.0\015\012" 556 "$method $rpath HTTP/1.1\015\012"
475 . (join "", map "\u$_: $hdr{$_}\015\012", keys %hdr) 557 . (join "", map "\u$_: $hdr{$_}\015\012", grep defined $hdr{$_}, keys %hdr)
476 . "\015\012" 558 . "\015\012"
477 . (delete $arg{body}) 559 . (delete $arg{body})
478 ); 560 );
479 561
562 # return if error occured during push_write()
563 return unless %state;
564
480 %hdr = (); # reduce memory usage, save a kitten 565 %hdr = (); # reduce memory usage, save a kitten, also make it possible to re-use
481 566
482 # status line 567 # status line and headers
483 $state{handle}->push_read (line => $qr_nl, sub { 568 $state{read_response} = sub {
484 $_[1] =~ /^HTTP\/([0-9\.]+) \s+ ([0-9]{3}) (?: \s+ ([^\015\012]*) )?/ix
485 or return (%state = (), $cb->(undef, { Status => 599, Reason => "Invalid server response ($_[1])", URL => $url }));
486
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]\012") { 569 for ("$_[1]") {
497 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.
498 571
499 # things seen, not parsed: 572 /^HTTP\/([0-9\.]+) \s+ ([0-9]{3}) (?: \s+ ([^\012]*) )? \012/igxc
500 # p3pP="NON CUR OTPi OUR NOR UNI" 573 or return (%state = (), $cb->(undef, { @pseudo, Status => 599, Reason => "Invalid server response" }));
501 574
502 $hdr{lc $1} .= ",$2" 575 # 100 Continue handling
503 while /\G 576 # should not happen as we don't send expect: 100-continue,
504 ([^:\000-\037]*): 577 # but we handle it just in case.
505 [\011\040]* 578 # since we send the request body regardless, if we get an error
506 ((?: [^\012]+ | \012[\011\040] )*) 579 # we are out of-sync, which we currently do NOT handle correctly.
507 \012 580 return $state{handle}->push_read (line => $qr_nlnl, $state{read_response})
508 /gxc; 581 if $2 eq 100;
509 582
583 push @pseudo,
584 HTTPVersion => $1,
585 Status => $2,
586 Reason => $3,
510 /\G$/ 587 ;
588
589 my $hdr = parse_hdr
511 or return (%state = (), $cb->(undef, { Status => 599, Reason => "Garbled response headers", URL => $url })); 590 or return (%state = (), $cb->(undef, { @pseudo, Status => 599, Reason => "Garbled response headers" }));
591
592 %hdr = (%$hdr, @pseudo);
593 }
594
595 # redirect handling
596 # microsoft and other shitheads don't give a shit for following standards,
597 # try to support some common forms of broken Location headers.
598 if ($hdr{location} !~ /^(?: $ | [^:\/?\#]+ : )/x) {
599 $hdr{location} =~ s/^\.\/+//;
600
601 my $url = "$rscheme://$uhost:$uport";
602
603 unless ($hdr{location} =~ s/^\///) {
604 $url .= $upath;
605 $url =~ s/\/[^\/]*$//;
512 } 606 }
513 607
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}"; 608 $hdr{location} = "$url/$hdr{location}";
609 }
610
611 my $redirect;
612
613 if ($recurse) {
614 my $status = $hdr{Status};
615
616 # industry standard is to redirect POST as GET for
617 # 301, 302 and 303, in contrast to http/1.0 and 1.1.
618 # also, the UA should ask the user for 301 and 307 and POST,
619 # industry standard seems to be to simply follow.
620 # we go with the industry standard.
621 if ($status == 301 or $status == 302 or $status == 303) {
622 # HTTP/1.1 is unclear on how to mutate the method
623 $method = "GET" unless $method eq "HEAD";
624 $redirect = 1;
625 } elsif ($status == 307) {
626 $redirect = 1;
531 } 627 }
628 }
532 629
630 my $finish = sub { # ($data, $err_status, $err_reason[, $keepalive])
533 my $redirect; 631 my $keepalive = pop;
534 632
633 $state{handle}->destroy if $state{handle};
634 %state = ();
635
636 if (defined $_[1]) {
637 $hdr{OrigStatus} = $hdr{Status}; $hdr{Status} = $_[1];
638 $hdr{OrigReason} = $hdr{Reason}; $hdr{Reason} = $_[2];
639 }
640
641 # set-cookie processing
535 if ($recurse) { 642 if ($arg{cookie_jar}) {
536 if ($hdr{Status} =~ /^30[12]$/ && $method ne "POST") { 643 for ($hdr{"set-cookie"}) {
537 # apparently, mozilla et al. just change POST to GET here 644 # parse NAME=VALUE
538 # more research is needed before we do the same 645 my @kv;
646
647 while (/\G\s* ([^=;,[:space:]]+) \s*=\s* (?: "((?:[^\\"]+|\\.)*)" | ([^=;,[:space:]]*) )/gcxs) {
539 $redirect = 1; 648 my $name = $1;
540 } elsif ($hdr{Status} == 303) { 649 my $value = $3;
541 # even http/1.1 is unclear on how to mutate the method 650
542 $method = "GET" unless $method eq "HEAD"; 651 unless ($value) {
652 $value = $2;
653 $value =~ s/\\(.)/$1/gs;
654 }
655
656 push @kv, $name => $value;
657
658 last unless /\G\s*;/gc;
659 }
660
661 last unless @kv;
662
663 my $name = shift @kv;
664 my %kv = (value => shift @kv, @kv);
665
666 my $cdom;
667 my $cpath = (delete $kv{path}) || "/";
668
669 if (exists $kv{domain}) {
670 $cdom = delete $kv{domain};
671
672 $cdom =~ s/^\.?/./; # make sure it starts with a "."
673
674 next if $cdom =~ /\.$/;
675
676 # this is not rfc-like and not netscape-like. go figure.
677 my $ndots = $cdom =~ y/.//;
678 next if $ndots < ($cdom =~ /\.[^.][^.]\.[^.][^.]$/ ? 3 : 2);
679 } else {
680 $cdom = $uhost;
681 }
682
543 $redirect = 1; 683 # store it
544 } elsif ($hdr{Status} == 307 && $method =~ /^(?:GET|HEAD)$/) { 684 $arg{cookie_jar}{version} = 1;
545 $redirect = 1; 685 $arg{cookie_jar}{$cdom}{$cpath}{$name} = \%kv;
686
687 redo if /\G\s*,/gc;
546 } 688 }
547 } 689 }
548 690
549 my $finish = sub { 691 if ($redirect && exists $hdr{location}) {
550 $state{handle}->destroy if $state{handle};
551 %state = ();
552
553 # set-cookie processing
554 if ($arg{cookie_jar}) {
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 }
567
568 push @kv, $name => $value;
569
570 last unless /\G\s*;/gc;
571 }
572
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 }
601 }
602
603 if ($redirect) {
604 # we ignore any errors, as it is very common to receive 692 # we ignore any errors, as it is very common to receive
605 # Content-Length != 0 but no actual body 693 # Content-Length != 0 but no actual body
606 # we also access %hdr, as $_[1] might be an erro 694 # we also access %hdr, as $_[1] might be an erro
607 http_request ($method => $hdr{location}, %arg, recurse => $recurse - 1, $cb); 695 http_request (
608 } else { 696 $method => $hdr{location},
609 $cb->($_[0], $_[1]);
610 } 697 %arg,
698 recurse => $recurse - 1,
699 Redirect => [$_[0], \%hdr],
611 }; 700 $cb);
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 { 701 } else {
702 $cb->($_[0], \%hdr);
703 }
704 };
705
706 my $len = $hdr{"content-length"};
707
708 if (!$redirect && $arg{on_header} && !$arg{on_header}(\%hdr)) {
709 $finish->(undef, 598 => "Request cancelled by on_header");
710 } elsif (
711 $hdr{Status} =~ /^(?:1..|204|205|304)$/
712 or $method eq "HEAD"
713 or (defined $len && !$len)
714 ) {
715 # no body
716 $finish->("", undef, undef, 1);
717 } else {
625 # body handling, four different code paths 718 # body handling, many different code paths
626 # for want_body_handle, on_body (2x), normal (2x) 719 # - no body expected
627 # we might read too much here, but it does not matter yet (no pers. connections) 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)
628 if (!$redirect && $arg{want_body_handle}) { 724 if (!$redirect && $arg{want_body_handle}) {
629 $_[0]->on_eof (undef); 725 $_[0]->on_eof (undef);
630 $_[0]->on_error (undef); 726 $_[0]->on_error (undef);
631 $_[0]->on_read (undef); 727 $_[0]->on_read (undef);
632 728
633 $finish->(delete $state{handle}, \%hdr); 729 $finish->(delete $state{handle});
634 730
635 } elsif ($arg{on_body}) { 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
636 $_[0]->on_error (sub { $finish->(undef, { Status => 599, Reason => $_[2], URL => $url }) }); 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
637 if ($len) { 744 if ($len) {
638 $_[0]->on_eof (undef); 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
639 $_[0]->on_read (sub { 751 $_[0]->push_read (line => sub {
640 $len -= length $_[0]{rbuf}; 752 length $_[1]
641 753 and return $finish->(undef, 599 => "Garbled chunked transfer encoding");
642 $arg{on_body}(delete $_[0]{rbuf}, \%hdr) 754 $_[0]->push_read (line => $read_chunk);
643 or $finish->(undef, { Status => 598, Reason => "Request cancelled by on_body", URL => $url });
644
645 $len > 0 755 });
646 or $finish->("", \%hdr);
647 }); 756 });
648 } else { 757 } else {
649 $_[0]->on_eof (sub { 758 $hdr{"content-length"} ||= $cl;
650 $finish->("", \%hdr); 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 }
651 }); 770 }
652 $_[0]->on_read (sub { 771
653 $arg{on_body}(delete $_[0]{rbuf}, \%hdr) 772 $finish->($body, undef, undef, 1);
654 or $finish->(undef, { Status => 598, Reason => "Request cancelled by on_body", URL => $url });
655 }); 773 });
656 } 774 }
775 };
776
777 $_[0]->push_read (line => $read_chunk);
778
779 } elsif ($arg{on_body}) {
780 $_[0]->on_error (sub { $finish->(undef, 599 => $_[2]) });
781
782 if ($len) {
783 $_[0]->on_read (sub {
784 $len -= length $_[0]{rbuf};
785
786 $arg{on_body}(delete $_[0]{rbuf}, \%hdr)
787 or return $finish->(undef, 598 => "Request cancelled by on_body");
788
789 $len > 0
790 or $finish->("", undef, undef, 1);
791 });
657 } else { 792 } else {
658 $_[0]->on_eof (undef); 793 $_[0]->on_eof (sub {
659 794 $finish->("");
660 if ($len) { 795 });
661 $_[0]->on_error (sub { $finish->(undef, { Status => 599, Reason => $_[2], URL => $url }) });
662 $_[0]->on_read (sub { 796 $_[0]->on_read (sub {
797 $arg{on_body}(delete $_[0]{rbuf}, \%hdr)
798 or $finish->(undef, 598 => "Request cancelled by on_body");
799 });
800 }
801 } else {
802 $_[0]->on_eof (undef);
803
804 if ($len) {
805 $_[0]->on_error (sub { $finish->(undef, 599 => $_[2]) });
806 $_[0]->on_read (sub {
663 $finish->((substr delete $_[0]{rbuf}, 0, $len, ""), \%hdr) 807 $finish->((substr delete $_[0]{rbuf}, 0, $len, ""), undef, undef, 1)
664 if $len <= length $_[0]{rbuf}; 808 if $len <= length $_[0]{rbuf};
665 }); 809 });
666 } else { 810 } else {
667 $_[0]->on_error (sub { 811 $_[0]->on_error (sub {
668 $! == Errno::EPIPE || !$! 812 ($! == Errno::EPIPE || !$!)
669 ? $finish->(delete $_[0]{rbuf}, \%hdr) 813 ? $finish->(delete $_[0]{rbuf})
670 : $finish->(undef, { Status => 599, Reason => $_[2], URL => $url }); 814 : $finish->(undef, 599 => $_[2]);
671 }); 815 });
672 $_[0]->on_read (sub { }); 816 $_[0]->on_read (sub { });
673 }
674 } 817 }
675 } 818 }
676 }); 819 }
677 }); 820 };
821
822 $state{handle}->push_read (line => $qr_nlnl, $state{read_response});
678 }; 823 };
679 824
680 # now handle proxy-CONNECT method 825 # now handle proxy-CONNECT method
681 if ($proxy && $uscheme eq "https") { 826 if ($proxy && $uscheme eq "https") {
682 # oh dear, we have to wrap it into a connect request 827 # oh dear, we have to wrap it into a connect request
683 828
684 # maybe re-use $uauthority with patched port? 829 # 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"); 830 $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 { 831 $state{handle}->push_read (line => $qr_nlnl, sub {
687 $_[1] =~ /^HTTP\/([0-9\.]+) \s+ ([0-9]{3}) (?: \s+ ([^\015\012]*) )?/ix 832 $_[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 })); 833 or return (%state = (), $cb->(undef, { @pseudo, Status => 599, Reason => "Invalid proxy connect response ($_[1])" }));
689 834
690 if ($2 == 200) { 835 if ($2 == 200) {
691 $rpath = $upath; 836 $rpath = $upath;
692 &$handle_actual_request; 837 &$handle_actual_request;
693 } else { 838 } else {
694 %state = (); 839 %state = ();
695 $cb->(undef, { Status => $2, Reason => $3, URL => $url }); 840 $cb->(undef, { @pseudo, Status => $2, Reason => $3 });
696 } 841 }
697 }); 842 });
698 } else { 843 } else {
699 &$handle_actual_request; 844 &$handle_actual_request;
700 } 845 }
701
702 }, sub {
703 $timeout
704 }; 846 };
847
848 my $tcp_connect = $arg{tcp_connect}
849 || do { require AnyEvent::Socket; \&AnyEvent::Socket::tcp_connect };
850
851 $state{connect_guard} = $tcp_connect->($rhost, $rport, $connect_cb, $arg{on_prepare} || sub { $timeout });
852
705 }; 853 };
706 854
707 defined wantarray && AnyEvent::Util::guard { %state = () } 855 defined wantarray && AnyEvent::Util::guard { %state = () }
708} 856}
709 857
723 &http_request 871 &http_request
724} 872}
725 873
726=back 874=back
727 875
876=head2 DNS CACHING
877
878AnyEvent::HTTP uses the AnyEvent::Socket::tcp_connect function for
879the actual connection, which in turn uses AnyEvent::DNS to resolve
880hostnames. The latter is a simple stub resolver and does no caching
881on its own. If you want DNS caching, you currently have to provide
882your own default resolver (by storing a suitable resolver object in
883C<$AnyEvent::DNS::RESOLVER>).
884
728=head2 GLOBAL FUNCTIONS AND VARIABLES 885=head2 GLOBAL FUNCTIONS AND VARIABLES
729 886
730=over 4 887=over 4
731 888
732=item AnyEvent::HTTP::set_proxy "proxy-url" 889=item AnyEvent::HTTP::set_proxy "proxy-url"
733 890
734Sets the default proxy server to use. The proxy-url must begin with a 891Sets the default proxy server to use. The proxy-url must begin with a
735string of the form C<http://host:port> (optionally C<https:...>). 892string of the form C<http://host:port> (optionally C<https:...>), croaks
893otherwise.
894
895To clear an already-set proxy, use C<undef>.
896
897=item $date = AnyEvent::HTTP::format_date $timestamp
898
899Takes a POSIX timestamp (seconds since the epoch) and formats it as a HTTP
900Date (RFC 2616).
901
902=item $timestamp = AnyEvent::HTTP::parse_date $date
903
904Takes a HTTP Date (RFC 2616) and returns the corresponding POSIX
905timestamp, or C<undef> if the date cannot be parsed.
736 906
737=item $AnyEvent::HTTP::MAX_RECURSE 907=item $AnyEvent::HTTP::MAX_RECURSE
738 908
739The default value for the C<recurse> request parameter (default: C<10>). 909The default value for the C<recurse> request parameter (default: C<10>).
740 910
743The default value for the C<User-Agent> header (the default is 913The 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)>). 914C<Mozilla/5.0 (compatible; U; AnyEvent-HTTP/$VERSION; +http://software.schmorp.de/pkg/AnyEvent)>).
745 915
746=item $AnyEvent::HTTP::MAX_PER_HOST 916=item $AnyEvent::HTTP::MAX_PER_HOST
747 917
748The maximum number of concurrent conenctions to the same host (identified 918The maximum number of concurrent connections to the same host (identified
749by the hostname). If the limit is exceeded, then the additional requests 919by the hostname). If the limit is exceeded, then the additional requests
750are queued until previous connections are closed. 920are queued until previous connections are closed.
751 921
752The default value for this is C<4>, and it is highly advisable to not 922The default value for this is C<4>, and it is highly advisable to not
753increase it. 923increase it.
760 930
761=back 931=back
762 932
763=cut 933=cut
764 934
935our @month = qw(Jan Feb Mar Apr May Jun Jul Aug Sep Oct Nov Dec);
936our @weekday = qw(Sun Mon Tue Wed Thu Fri Sat);
937
938sub format_date($) {
939 my ($time) = @_;
940
941 # RFC 822/1123 format
942 my ($S, $M, $H, $mday, $mon, $year, $wday, $yday, undef) = gmtime $time;
943
944 sprintf "%s, %02d %s %04d %02d:%02d:%02d GMT",
945 $weekday[$wday], $mday, $month[$mon], $year + 1900,
946 $H, $M, $S;
947}
948
949sub parse_date($) {
950 my ($date) = @_;
951
952 my ($d, $m, $y, $H, $M, $S);
953
954 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$/) {
955 # RFC 822/1123, required by RFC 2616
956 ($d, $m, $y, $H, $M, $S) = ($1, $2, $3, $4, $5, $6);
957
958 } 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$/) {
959 # RFC 850
960 ($d, $m, $y, $H, $M, $S) = ($1, $2, $3 < 69 ? $3 + 2000 : $3 + 1900, $4, $5, $6);
961
962 } 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])$/) {
963 # ISO C's asctime
964 ($d, $m, $y, $H, $M, $S) = ($2, $1, $6, $3, $4, $5);
965 }
966 # other formats fail in the loop below
967
968 for (0..11) {
969 if ($m eq $month[$_]) {
970 require Time::Local;
971 return Time::Local::timegm ($S, $M, $H, $d, $_, $y);
972 }
973 }
974
975 undef
976}
977
765sub set_proxy($) { 978sub set_proxy($) {
979 if (length $_[0]) {
766 $PROXY = [$2, $3 || 3128, $1] if $_[0] =~ m%^(https?):// ([^:/]+) (?: : (\d*) )?%ix; 980 $_[0] =~ m%^(https?):// ([^:/]+) (?: : (\d*) )?%ix
981 or Carp::croak "$_[0]: invalid proxy URL";
982 $PROXY = [$2, $3 || 3128, $1]
983 } else {
984 undef $PROXY;
985 }
767} 986}
768 987
769# initialise proxy from environment 988# initialise proxy from environment
989eval {
770set_proxy $ENV{http_proxy}; 990 set_proxy $ENV{http_proxy};
991};
992
993=head2 SOCKS PROXIES
994
995Socks proxies are not directly supported by AnyEvent::HTTP. You can
996compile your perl to support socks, or use an external program such as
997F<socksify> (dante) or F<tsocks> to make your program use a socks proxy
998transparently.
999
1000Alternatively, for AnyEvent::HTTP only, you can use your own
1001C<tcp_connect> function that does the proxy handshake - here is an example
1002that works with socks4a proxies:
1003
1004 use Errno;
1005 use AnyEvent::Util;
1006 use AnyEvent::Socket;
1007 use AnyEvent::Handle;
1008
1009 # host, port and username of/for your socks4a proxy
1010 my $socks_host = "10.0.0.23";
1011 my $socks_port = 9050;
1012 my $socks_user = "";
1013
1014 sub socks4a_connect {
1015 my ($host, $port, $connect_cb, $prepare_cb) = @_;
1016
1017 my $hdl = new AnyEvent::Handle
1018 connect => [$socks_host, $socks_port],
1019 on_prepare => sub { $prepare_cb->($_[0]{fh}) },
1020 on_error => sub { $connect_cb->() },
1021 ;
1022
1023 $hdl->push_write (pack "CCnNZ*Z*", 4, 1, $port, 1, $socks_user, $host);
1024
1025 $hdl->push_read (chunk => 8, sub {
1026 my ($hdl, $chunk) = @_;
1027 my ($status, $port, $ipn) = unpack "xCna4", $chunk;
1028
1029 if ($status == 0x5a) {
1030 $connect_cb->($hdl->{fh}, (format_address $ipn) . ":$port");
1031 } else {
1032 $! = Errno::ENXIO; $connect_cb->();
1033 }
1034 });
1035
1036 $hdl
1037 }
1038
1039Use C<socks4a_connect> instead of C<tcp_connect> when doing C<http_request>s,
1040possibly after switching off other proxy types:
1041
1042 AnyEvent::HTTP::set_proxy undef; # usually you do not want other proxies
1043
1044 http_get 'http://www.google.com', tcp_connect => \&socks4a_connect, sub {
1045 my ($data, $headers) = @_;
1046 ...
1047 };
771 1048
772=head1 SEE ALSO 1049=head1 SEE ALSO
773 1050
774L<AnyEvent>. 1051L<AnyEvent>.
775 1052

Diff Legend

Removed lines
+ Added lines
< Changed lines
> Changed lines