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.35 by root, Thu Oct 30 03:47:01 2008 UTC vs.
Revision 1.67 by root, Fri Dec 31 06:18:54 2010 UTC

39package AnyEvent::HTTP; 39package AnyEvent::HTTP;
40 40
41use strict; 41use strict;
42no warnings; 42no warnings;
43 43
44use Carp; 44use Errno ();
45 45
46use AnyEvent (); 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.1'; 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; 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;
59our $MAX_PERSISTENT = 8; 58our $MAX_PERSISTENT = 8;
60our $PERSISTENT_TIMEOUT = 2; 59our $PERSISTENT_TIMEOUT = 2;
61our $TIMEOUT = 300; 60our $TIMEOUT = 300;
62 61
63# changing these is evil 62# changing these is evil
64our $MAX_PERSISTENT_PER_HOST = 2; 63our $MAX_PERSISTENT_PER_HOST = 0;
65our $MAX_PER_HOST = 4; 64our $MAX_PER_HOST = 4;
66 65
67our $PROXY; 66our $PROXY;
68our $ACTIVE = 0; 67our $ACTIVE = 0;
69 68
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 data as first argument 98The callback will be called with the response body data as first argument
100(or C<undef> if it wasn't available due to errors), and a hash-ref with 99(or C<undef> if an error occured), and a hash-ref with response headers as
101response headers as second 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,
113then C<$data> will be C<undef>, C<< $headers->{Status} >> will be C<599> 127then C<$data> will be C<undef>, C<< $headers->{Status} >> will be C<59x>
114and the C<Reason> pseudo-header will contain an error message. 128(usually C<599>) and the C<Reason> pseudo-header will contain an error
129message.
115 130
116A typical callback might look like this: 131A typical callback might look like this:
117 132
118 sub { 133 sub {
119 my ($body, $hdr) = @_; 134 my ($body, $hdr) = @_;
137 152
138=item headers => hashref 153=item headers => hashref
139 154
140The request headers to use. Currently, C<http_request> may provide its 155The request headers to use. Currently, C<http_request> may provide its
141own C<Host:>, C<Content-Length:>, C<Connection:> and C<Cookie:> headers 156own C<Host:>, C<Content-Length:>, C<Connection:> and C<Cookie:> headers
142and 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).
143 160
144=item timeout => $seconds 161=item timeout => $seconds
145 162
146The 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
147the 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.
148 168
149=item proxy => [$host, $port[, $scheme]] or undef 169=item proxy => [$host, $port[, $scheme]] or undef
150 170
151Use 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
152default proxy (as specified by C<$ENV{http_proxy}>) is used. 172default proxy (as specified by C<$ENV{http_proxy}>) is used.
153 173
154C<$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
155HTTPS. 175HTTPS.
156 176
157=item body => $string 177=item body => $string
158 178
159The 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
165based on the original netscape specification. 185based on the original netscape specification.
166 186
167The C<$hash_ref> must be an (initially empty) hash reference which will 187The C<$hash_ref> must be an (initially empty) hash reference which will
168get updated automatically. It is possible to save the cookie_jar to 188get updated automatically. It is possible to save the cookie_jar to
169persistent storage with something like JSON or Storable, but this is not 189persistent storage with something like JSON or Storable, but this is not
170recommended, as expire times are currently being ignored. 190recommended, as expiry times are currently being ignored.
171 191
172Note that this cookie implementation is not of very high quality, nor 192Note that this cookie implementation is not of very high quality, nor
173meant to be complete. If you want complete cookie management you have to 193meant to be complete. If you want complete cookie management you have to
174do that on your own. C<cookie_jar> is meant as a quick fix to get some 194do that on your own. C<cookie_jar> is meant as a quick fix to get some
175cookie-using sites working. Cookies are a privacy disaster, do not use 195cookie-using sites working. Cookies are a privacy disaster, do not use
176them unless required to. 196them unless required to.
197
198=item tls_ctx => $scheme | $tls_ctx
199
200Specifies the AnyEvent::TLS context to be used for https connections. This
201parameter follows the same rules as the C<tls_ctx> parameter to
202L<AnyEvent::Handle>, but additionally, the two strings C<low> or
203C<high> can be specified, which give you a predefined low-security (no
204verification, highest compatibility) and high-security (CA and common-name
205verification) TLS context.
206
207The default for this option is C<low>, which could be interpreted as "give
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.
230
231=item on_header => $callback->($headers)
232
233When specified, this callback will be called with the header hash as soon
234as headers have been successfully received from the remote server (not on
235locally-generated errors).
236
237It has to return either true (in which case AnyEvent::HTTP will continue),
238or false, in which case AnyEvent::HTTP will cancel the download (and call
239the finish callback with an error code of C<598>).
240
241This callback is useful, among other things, to quickly reject unwanted
242content, which, if it is supposed to be rare, can be faster than first
243doing a C<HEAD> request.
244
245Example: cancel the request unless the content-type is "text/html".
246
247 on_header => sub {
248 $_[0]{"content-type"} =~ /^text\/html\s*(?:;|$)/
249 },
250
251=item on_body => $callback->($partial_body, $headers)
252
253When specified, all body data will be passed to this callback instead of
254to the completion callback. The completion callback will get the empty
255string instead of the body data.
256
257It has to return either true (in which case AnyEvent::HTTP will continue),
258or false, in which case AnyEvent::HTTP will cancel the download (and call
259the completion callback with an error code of C<598>).
260
261This callback is useful when the data is too large to be held in memory
262(so the callback writes it to a file) or when only some information should
263be extracted, or when the body should be processed incrementally.
264
265It is usually preferred over doing your own body handling via
266C<want_body_handle>, but in case of streaming APIs, where HTTP is
267only used to create a connection, C<want_body_handle> is the better
268alternative, as it allows you to install your own event handler, reducing
269resource usage.
270
271=item want_body_handle => $enable
272
273When enabled (default is disabled), the behaviour of AnyEvent::HTTP
274changes considerably: after parsing the headers, and instead of
275downloading the body (if any), the completion callback will be
276called. Instead of the C<$body> argument containing the body data, the
277callback will receive the L<AnyEvent::Handle> object associated with the
278connection. In error cases, C<undef> will be passed. When there is no body
279(e.g. status C<304>), the empty string will be passed.
280
281The handle object might or might not be in TLS mode, might be connected to
282a proxy, be a persistent connection etc., and configured in unspecified
283ways. The user is responsible for this handle (it will not be used by this
284module anymore).
285
286This is useful with some push-type services, where, after the initial
287headers, an interactive protocol is used (typical example would be the
288push-style twitter API which starts a JSON/XML stream).
289
290If you think you need this, first have a look at C<on_body>, to see if
291that doesn't solve your problem in a better way.
177 292
178=back 293=back
179 294
180Example: make a simple HTTP GET request for http://www.nethype.de/ 295Example: make a simple HTTP GET request for http://www.nethype.de/
181 296
237 push @{ $CO_SLOT{$_[0]}[1] }, $_[1]; 352 push @{ $CO_SLOT{$_[0]}[1] }, $_[1];
238 353
239 _slot_schedule $_[0]; 354 _slot_schedule $_[0];
240} 355}
241 356
242our $qr_nl = qr<\015?\012>; 357# continue to parse $_ for headers and place them into the arg
243our $qr_nlnl = qr<\015?\012\015?\012>; 358sub parse_hdr() {
359 my %hdr;
360
361 # things seen, not parsed:
362 # p3pP="NON CUR OTPi OUR NOR UNI"
363
364 $hdr{lc $1} .= ",$2"
365 while /\G
366 ([^:\000-\037]*):
367 [\011\040]*
368 ((?: [^\012]+ | \012[\011\040] )*)
369 \012
370 /gxc;
371
372 /\G$/
373 or return;
374
375 # remove the "," prefix we added to all headers above
376 substr $_, 0, 1, ""
377 for values %hdr;
378
379 \%hdr
380}
381
382our $qr_nlnl = qr{(?<![^\012])\015?\012};
383
384our $TLS_CTX_LOW = { cache => 1, sslv2 => 1 };
385our $TLS_CTX_HIGH = { cache => 1, verify => 1, verify_peername => "https" };
244 386
245sub http_request($$@) { 387sub http_request($$@) {
246 my $cb = pop; 388 my $cb = pop;
247 my ($method, $url, %arg) = @_; 389 my ($method, $url, %arg) = @_;
248 390
249 my %hdr; 391 my %hdr;
392
393 $arg{tls_ctx} = $TLS_CTX_LOW if $arg{tls_ctx} eq "low" || !exists $arg{tls_ctx};
394 $arg{tls_ctx} = $TLS_CTX_HIGH if $arg{tls_ctx} eq "high";
250 395
251 $method = uc $method; 396 $method = uc $method;
252 397
253 if (my $hdr = $arg{headers}) { 398 if (my $hdr = $arg{headers}) {
254 while (my ($k, $v) = each %$hdr) { 399 while (my ($k, $v) = each %$hdr) {
255 $hdr{lc $k} = $v; 400 $hdr{lc $k} = $v;
256 } 401 }
257 } 402 }
258 403
404 # pseudo headers for all subsequent responses
405 my @pseudo = (URL => $url);
406 push @pseudo, Redirect => delete $arg{Redirect} if exists $arg{Redirect};
407
259 my $recurse = exists $arg{recurse} ? delete $arg{recurse} : $MAX_RECURSE; 408 my $recurse = exists $arg{recurse} ? delete $arg{recurse} : $MAX_RECURSE;
260 409
261 return $cb->(undef, { Status => 599, Reason => "recursion limit reached", URL => $url }) 410 return $cb->(undef, { @pseudo, Status => 599, Reason => "Too many redirections" })
262 if $recurse < 0; 411 if $recurse < 0;
263 412
264 my $proxy = $arg{proxy} || $PROXY; 413 my $proxy = $arg{proxy} || $PROXY;
265 my $timeout = $arg{timeout} || $TIMEOUT; 414 my $timeout = $arg{timeout} || $TIMEOUT;
266 415
267 $hdr{"user-agent"} ||= $USERAGENT;
268
269 my ($uscheme, $uauthority, $upath, $query, $fragment) = 416 my ($uscheme, $uauthority, $upath, $query, $fragment) =
270 $url =~ m|(?:([^:/?#]+):)?(?://([^/?#]*))?([^?#]*)(?:\?([^#]*))?(?:#(.*))?|; 417 $url =~ m|(?:([^:/?#]+):)?(?://([^/?#]*))?([^?#]*)(?:(\?[^#]*))?(?:#(.*))?|;
271 418
272 $uscheme = lc $uscheme; 419 $uscheme = lc $uscheme;
273 420
274 my $uport = $uscheme eq "http" ? 80 421 my $uport = $uscheme eq "http" ? 80
275 : $uscheme eq "https" ? 443 422 : $uscheme eq "https" ? 443
276 : return $cb->(undef, { Status => 599, Reason => "only http and https URL schemes supported", URL => $url }); 423 : return $cb->(undef, { @pseudo, Status => 599, Reason => "Only http and https URL schemes supported" });
277
278 $hdr{referer} ||= "$uscheme://$uauthority$upath"; # leave out fragment and query string, just a heuristic
279 424
280 $uauthority =~ /^(?: .*\@ )? ([^\@:]+) (?: : (\d+) )?$/x 425 $uauthority =~ /^(?: .*\@ )? ([^\@:]+) (?: : (\d+) )?$/x
281 or return $cb->(undef, { Status => 599, Reason => "unparsable URL", URL => $url }); 426 or return $cb->(undef, { @pseudo, Status => 599, Reason => "Unparsable URL" });
282 427
283 my $uhost = $1; 428 my $uhost = $1;
284 $uport = $2 if defined $2; 429 $uport = $2 if defined $2;
285 430
431 $hdr{host} = defined $2 ? "$uhost:$2" : "$uhost"
432 unless exists $hdr{host};
433
286 $uhost =~ s/^\[(.*)\]$/$1/; 434 $uhost =~ s/^\[(.*)\]$/$1/;
287 $upath .= "?$query" if length $query; 435 $upath .= $query if length $query;
288 436
289 $upath =~ s%^/?%/%; 437 $upath =~ s%^/?%/%;
290 438
291 # cookie processing 439 # cookie processing
292 if (my $jar = $arg{cookie_jar}) { 440 if (my $jar = $arg{cookie_jar}) {
320 } 468 }
321 469
322 my ($rhost, $rport, $rscheme, $rpath); # request host, port, path 470 my ($rhost, $rport, $rscheme, $rpath); # request host, port, path
323 471
324 if ($proxy) { 472 if ($proxy) {
325 ($rhost, $rport, $rscheme, $rpath) = (@$proxy, $url); 473 ($rpath, $rhost, $rport, $rscheme) = ($url, @$proxy);
474
475 $rscheme = "http" unless defined $rscheme;
326 476
327 # don't support https requests over https-proxy transport, 477 # don't support https requests over https-proxy transport,
328 # can't be done with tls as spec'ed. 478 # can't be done with tls as spec'ed, unless you double-encrypt.
329 $rscheme = "http" if $uscheme eq "https" && $rscheme eq "https"; 479 $rscheme = "http" if $uscheme eq "https" && $rscheme eq "https";
330 } else { 480 } else {
331 ($rhost, $rport, $rscheme, $rpath) = ($uhost, $uport, $uscheme, $upath); 481 ($rhost, $rport, $rscheme, $rpath) = ($uhost, $uport, $uscheme, $upath);
332 } 482 }
333 483
334 $hdr{host} = $uhost; 484 # leave out fragment and query string, just a heuristic
485 $hdr{referer} = "$uscheme://$uauthority$upath" unless exists $hdr{referer};
486 $hdr{"user-agent"} = $USERAGENT unless exists $hdr{"user-agent"};
487
335 $hdr{"content-length"} = length $arg{body}; 488 $hdr{"content-length"} = length $arg{body}
489 if length $arg{body} || $method ne "GET";
490
491 $hdr{connection} = "close TE";
492 $hdr{te} = "trailers" unless exists $hdr{te};
336 493
337 my %state = (connect_guard => 1); 494 my %state = (connect_guard => 1);
338 495
339 _get_slot $uhost, sub { 496 _get_slot $uhost, sub {
340 $state{slot_guard} = shift; 497 $state{slot_guard} = shift;
341 498
342 return unless $state{connect_guard}; 499 return unless $state{connect_guard};
343 500
344 $state{connect_guard} = AnyEvent::Socket::tcp_connect $rhost, $rport, sub { 501 my $connect_cb = sub {
345 $state{fh} = shift 502 $state{fh} = shift
503 or do {
504 my $err = "$!";
505 %state = ();
346 or return $cb->(undef, { Status => 599, Reason => "$!", URL => $url }); 506 return $cb->(undef, { @pseudo, Status => 599, Reason => $err });
507 };
508
347 pop; # free memory, save a tree 509 pop; # free memory, save a tree
348 510
349 return unless delete $state{connect_guard}; 511 return unless delete $state{connect_guard};
350 512
351 # get handle 513 # get handle
352 $state{handle} = new AnyEvent::Handle 514 $state{handle} = new AnyEvent::Handle
353 fh => $state{fh}, 515 fh => $state{fh},
516 peername => $rhost,
517 tls_ctx => $arg{tls_ctx},
518 # these need to be reconfigured on keepalive handles
354 timeout => $timeout; 519 timeout => $timeout,
520 on_error => sub {
521 %state = ();
522 $cb->(undef, { @pseudo, Status => 599, Reason => $_[2] });
523 },
524 on_eof => sub {
525 %state = ();
526 $cb->(undef, { @pseudo, Status => 599, Reason => "Unexpected end-of-file" });
527 },
528 ;
355 529
356 # limit the number of persistent connections 530 # limit the number of persistent connections
357 # keepalive not yet supported 531 # keepalive not yet supported
358 if ($KA_COUNT{$_[1]} < $MAX_PERSISTENT_PER_HOST) { 532# if ($KA_COUNT{$_[1]} < $MAX_PERSISTENT_PER_HOST) {
359 ++$KA_COUNT{$_[1]}; 533# ++$KA_COUNT{$_[1]};
360 $state{handle}{ka_count_guard} = AnyEvent::Util::guard { 534# $state{handle}{ka_count_guard} = AnyEvent::Util::guard {
361 --$KA_COUNT{$_[1]} 535# --$KA_COUNT{$_[1]}
362 }; 536# };
363 $hdr{connection} = "keep-alive"; 537# $hdr{connection} = "keep-alive";
364 } else { 538# } else {
365 delete $hdr{connection}; 539# delete $hdr{connection};
366 } 540# }
367
368 # (re-)configure handle
369 $state{handle}->on_error (sub {
370 my $errno = "$!";
371 %state = ();
372 $cb->(undef, { Status => 599, Reason => $errno, URL => $url });
373 });
374 $state{handle}->on_eof (sub {
375 %state = ();
376 $cb->(undef, { Status => 599, Reason => "unexpected end-of-file", URL => $url });
377 });
378 541
379 $state{handle}->starttls ("connect") if $rscheme eq "https"; 542 $state{handle}->starttls ("connect") if $rscheme eq "https";
380 543
381 # handle actual, non-tunneled, request 544 # handle actual, non-tunneled, request
382 my $handle_actual_request = sub { 545 my $handle_actual_request = sub {
383 $state{handle}->starttls ("connect") if $uscheme eq "https" && !exists $state{handle}{tls}; 546 $state{handle}->starttls ("connect") if $uscheme eq "https" && !exists $state{handle}{tls};
384 547
385 # send request 548 # send request
386 $state{handle}->push_write ( 549 $state{handle}->push_write (
387 "$method $rpath HTTP/1.0\015\012" 550 "$method $rpath HTTP/1.1\015\012"
388 . (join "", map "\u$_: $hdr{$_}\015\012", keys %hdr) 551 . (join "", map "\u$_: $hdr{$_}\015\012", grep defined $hdr{$_}, keys %hdr)
389 . "\015\012" 552 . "\015\012"
390 . (delete $arg{body}) 553 . (delete $arg{body})
391 ); 554 );
392 555
556 # return if error occured during push_write()
557 return unless %state;
558
393 %hdr = (); # reduce memory usage, save a kitten 559 %hdr = (); # reduce memory usage, save a kitten, also make it possible to re-use
394 560
395 # status line 561 # status line and headers
396 $state{handle}->push_read (line => $qr_nl, sub { 562 $state{handle}->push_read (line => $qr_nlnl, sub {
397 $_[1] =~ /^HTTP\/([0-9\.]+) \s+ ([0-9]{3}) (?: \s+ ([^\015\012]*) )?/ix 563 my $keepalive = pop;
398 or return (%state = (), $cb->(undef, { Status => 599, Reason => "invalid server response ($_[1])", URL => $url }));
399 564
400 my %hdr = ( # response headers
401 HTTPVersion => ",$1",
402 Status => ",$2",
403 Reason => ",$3",
404 URL => ",$url"
405 );
406
407 # headers, could be optimized a bit
408 $state{handle}->unshift_read (line => $qr_nlnl, sub {
409 for ("$_[1]\012") { 565 for ("$_[1]") {
410 y/\015//d; # weed out any \015, as they show up in the weirdest of places. 566 y/\015//d; # weed out any \015, as they show up in the weirdest of places.
411 567
412 # we support spaces in field names, as lotus domino 568 /^HTTP\/([0-9\.]+) \s+ ([0-9]{3}) (?: \s+ ([^\012]*) )? \012/igxc
413 # creates them (actually spaces around seperators 569 or return (%state = (), $cb->(undef, { @pseudo, Status => 599, Reason => "Invalid server response" }));
414 # are strictly allowed in http, they are a security issue).
415 $hdr{lc $1} .= ",$2"
416 while /\G
417 ([^:\000-\037]+):
418 [\011\040]*
419 ((?: [^\012]+ | \012[\011\040] )*)
420 \012
421 /gxc;
422 570
571 push @pseudo,
572 HTTPVersion => $1,
573 Status => $2,
574 Reason => $3,
423 /\G$/ 575 ;
576
577 my $hdr = parse_hdr
424 or return (%state = (), $cb->(undef, { Status => 599, Reason => "garbled response headers", URL => $url })); 578 or return (%state = (), $cb->(undef, { @pseudo, Status => 599, Reason => "Garbled response headers" }));
579
580 %hdr = (%$hdr, @pseudo);
581 }
582
583 # redirect handling
584 # microsoft and other shitheads don't give a shit for following standards,
585 # try to support some common forms of broken Location headers.
586 if ($hdr{location} !~ /^(?: $ | [^:\/?\#]+ : )/x) {
587 $hdr{location} =~ s/^\.\/+//;
588
589 my $url = "$rscheme://$uhost:$uport";
590
591 unless ($hdr{location} =~ s/^\///) {
592 $url .= $upath;
593 $url =~ s/\/[^\/]*$//;
425 } 594 }
426 595
427 substr $_, 0, 1, "" 596 $hdr{location} = "$url/$hdr{location}";
428 for values %hdr; 597 }
429 598
430 my $finish = sub { 599 my $redirect;
600
601 if ($recurse) {
602 my $status = $hdr{Status};
603
604 # industry standard is to redirect POST as GET for
605 # 301, 302 and 303, in contrast to http/1.0 and 1.1.
606 # also, the UA should ask the user for 301 and 307 and POST,
607 # industry standard seems to be to simply follow.
608 # we go with the industry standard.
609 if ($status == 301 or $status == 302 or $status == 303) {
610 # HTTP/1.1 is unclear on how to mutate the method
611 $method = "GET" unless $method eq "HEAD";
612 $redirect = 1;
613 } elsif ($status == 307) {
614 $redirect = 1;
615 }
616 }
617
618 my $finish = sub { # ($data, $err_status, $err_reason[, $keepalive])
431 $state{handle}->destroy; 619 $state{handle}->destroy if $state{handle};
432 %state = (); 620 %state = ();
433 621
622 if (defined $_[1]) {
623 $hdr{OrigStatus} = $hdr{Status}; $hdr{Status} = $_[1];
624 $hdr{OrigReason} = $hdr{Reason}; $hdr{Reason} = $_[2];
625 }
626
434 # set-cookie processing 627 # set-cookie processing
435 if ($arg{cookie_jar}) { 628 if ($arg{cookie_jar}) {
436 for ($hdr{"set-cookie"}) { 629 for ($hdr{"set-cookie"}) {
437 # parse NAME=VALUE 630 # parse NAME=VALUE
438 my @kv; 631 my @kv;
439 632
440 while (/\G\s* ([^=;,[:space:]]+) \s*=\s* (?: "((?:[^\\"]+|\\.)*)" | ([^=;,[:space:]]*) )/gcxs) { 633 while (/\G\s* ([^=;,[:space:]]+) \s*=\s* (?: "((?:[^\\"]+|\\.)*)" | ([^=;,[:space:]]*) )/gcxs) {
441 my $name = $1; 634 my $name = $1;
442 my $value = $3; 635 my $value = $3;
443 636
444 unless ($value) { 637 unless ($value) {
445 $value = $2; 638 $value = $2;
446 $value =~ s/\\(.)/$1/gs; 639 $value =~ s/\\(.)/$1/gs;
640 }
641
642 push @kv, $name => $value;
643
644 last unless /\G\s*;/gc;
645 }
646
647 last unless @kv;
648
649 my $name = shift @kv;
650 my %kv = (value => shift @kv, @kv);
651
652 my $cdom;
653 my $cpath = (delete $kv{path}) || "/";
654
655 if (exists $kv{domain}) {
656 $cdom = delete $kv{domain};
657
658 $cdom =~ s/^\.?/./; # make sure it starts with a "."
659
660 next if $cdom =~ /\.$/;
661
662 # this is not rfc-like and not netscape-like. go figure.
663 my $ndots = $cdom =~ y/.//;
664 next if $ndots < ($cdom =~ /\.[^.][^.]\.[^.][^.]$/ ? 3 : 2);
665 } else {
666 $cdom = $uhost;
667 }
668
669 # store it
670 $arg{cookie_jar}{version} = 1;
671 $arg{cookie_jar}{$cdom}{$cpath}{$name} = \%kv;
672
673 redo if /\G\s*,/gc;
674 }
675 }
676
677 if ($redirect && exists $hdr{location}) {
678 # we ignore any errors, as it is very common to receive
679 # Content-Length != 0 but no actual body
680 # we also access %hdr, as $_[1] might be an erro
681 http_request (
682 $method => $hdr{location},
683 %arg,
684 recurse => $recurse - 1,
685 Redirect => [$_[0], \%hdr],
686 $cb);
687 } else {
688 $cb->($_[0], \%hdr);
689 }
690 };
691
692 my $len = $hdr{"content-length"};
693
694 if (!$redirect && $arg{on_header} && !$arg{on_header}(\%hdr)) {
695 $finish->(undef, 598 => "Request cancelled by on_header");
696 } elsif (
697 $hdr{Status} =~ /^(?:1..|204|205|304)$/
698 or $method eq "HEAD"
699 or (defined $len && !$len)
700 ) {
701 # no body
702 $finish->("", undef, undef, 1);
703 } else {
704 # body handling, many different code paths
705 # - no body expected
706 # - want_body_handle
707 # - te chunked
708 # - 2x length known (with or without on_body)
709 # - 2x length not known (with or without on_body)
710 if (!$redirect && $arg{want_body_handle}) {
711 $_[0]->on_eof (undef);
712 $_[0]->on_error (undef);
713 $_[0]->on_read (undef);
714
715 $finish->(delete $state{handle});
716
717 } elsif ($hdr{"transfer-encoding"} =~ /chunked/) {
718 my $body = undef;
719 my $on_body = $arg{on_body} || sub { $body .= shift; 1 };
720
721 $_[0]->on_error (sub { $finish->(undef, 599 => $_[2]) });
722
723 my $read_chunk; $read_chunk = sub {
724 $_[1] =~ /^([0-9a-fA-F]+)/
725 or $finish->(undef, 599 => "Garbled chunked transfer encoding");
726
727 my $len = hex $1;
728
729 if ($len) {
730 $_[0]->push_read (chunk => hex $1, sub {
731 $on_body->($_[1], \%hdr)
732 or return $finish->(undef, 598 => "Request cancelled by on_body");
733
734 $_[0]->push_read (line => sub {
735 length $_[1]
736 and return $finish->(undef, 599 => "Garbled chunked transfer encoding");
737 $_[0]->push_read (line => $read_chunk);
738 });
739 });
740 } else {
741 $_[0]->push_read (line => $qr_nlnl, sub {
742 if (length $_[1]) {
743 for ("$_[1]") {
744 y/\015//d; # weed out any \015, as they show up in the weirdest of places.
745
746 my $hdr = parse_hdr
747 or return $finish->(undef, 599 => "Garbled response trailers");
748
749 %hdr = (%hdr, %$hdr);
750 }
447 } 751 }
448 752
449 push @kv, $name => $value; 753 $finish->($body, undef, undef, 1);
450
451 last unless /\G\s*;/gc;
452 } 754 });
453
454 last unless @kv;
455
456 my $name = shift @kv;
457 my %kv = (value => shift @kv, @kv);
458
459 my $cdom;
460 my $cpath = (delete $kv{path}) || "/";
461
462 if (exists $kv{domain}) {
463 $cdom = delete $kv{domain};
464
465 $cdom =~ s/^\.?/./; # make sure it starts with a "."
466
467 next if $cdom =~ /\.$/;
468
469 # this is not rfc-like and not netscape-like. go figure.
470 my $ndots = $cdom =~ y/.//;
471 next if $ndots < ($cdom =~ /\.[^.][^.]\.[^.][^.]$/ ? 3 : 2);
472 } else {
473 $cdom = $uhost;
474 }
475
476 # store it
477 $arg{cookie_jar}{version} = 1;
478 $arg{cookie_jar}{$cdom}{$cpath}{$name} = \%kv;
479
480 redo if /\G\s*,/gc;
481 } 755 }
482 } 756 };
483 757
484 # microsoft and other shitheads don't give a shit for following standards, 758 $_[0]->push_read (line => $read_chunk);
485 # try to support some common forms of broken Location headers.
486 if ($_[1]{location} !~ /^(?: $ | [^:\/?\#]+ : )/x) {
487 $_[1]{location} =~ s/^\.\/+//;
488 759
489 my $url = "$rscheme://$uhost:$uport"; 760 } elsif ($arg{on_body}) {
761 $_[0]->on_error (sub { $finish->(undef, 599 => $_[2]) });
490 762
491 unless ($_[1]{location} =~ s/^\///) {
492 $url .= $upath;
493 $url =~ s/\/[^\/]*$//;
494 }
495
496 $_[1]{location} = "$url/$_[1]{location}";
497 }
498
499 if ($_[1]{Status} =~ /^30[12]$/ && $recurse && $method ne "POST") {
500 # apparently, mozilla et al. just change POST to GET here
501 # more research is needed before we do the same
502 http_request ($method, $_[1]{location}, %arg, recurse => $recurse - 1, $cb);
503 } elsif ($_[1]{Status} == 303 && $recurse) {
504 # even http/1.1 is unclear on how to mutate the method
505 $method = "GET" unless $method eq "HEAD";
506 http_request ($method => $_[1]{location}, %arg, recurse => $recurse - 1, $cb);
507 } elsif ($_[1]{Status} == 307 && $recurse && $method =~ /^(?:GET|HEAD)$/) {
508 http_request ($method => $_[1]{location}, %arg, recurse => $recurse - 1, $cb);
509 } else { 763 if ($len) {
510 $cb->($_[0], $_[1]); 764 $_[0]->on_read (sub {
511 } 765 $len -= length $_[0]{rbuf};
512 };
513 766
514 if ($hdr{Status} =~ /^(?:1..|204|304)$/ or $method eq "HEAD") { 767 $arg{on_body}(delete $_[0]{rbuf}, \%hdr)
515 $finish->(undef, \%hdr); 768 or return $finish->(undef, 598 => "Request cancelled by on_body");
516 } else { 769
517 if (exists $hdr{"content-length"}) {
518 $_[0]->unshift_read (chunk => $hdr{"content-length"}, sub {
519 # could cache persistent connection now
520 if ($hdr{connection} =~ /\bkeep-alive\b/i) {
521 # but we don't, due to misdesigns, this is annoyingly complex
522 }; 770 $len > 0
523 771 or $finish->("", undef, undef, 1);
524 $finish->($_[1], \%hdr);
525 }); 772 });
526 } else { 773 } else {
527 # too bad, need to read until we get an error or EOF, 774 $_[0]->on_eof (sub {
528 # no way to detect winged data. 775 $finish->("");
776 });
777 $_[0]->on_read (sub {
778 $arg{on_body}(delete $_[0]{rbuf}, \%hdr)
779 or $finish->(undef, 598 => "Request cancelled by on_body");
780 });
781 }
782 } else {
783 $_[0]->on_eof (undef);
784
785 if ($len) {
786 $_[0]->on_error (sub { $finish->(undef, 599 => $_[2]) });
787 $_[0]->on_read (sub {
788 $finish->((substr delete $_[0]{rbuf}, 0, $len, ""), undef, undef, 1)
789 if $len <= length $_[0]{rbuf};
790 });
791 } else {
529 $_[0]->on_error (sub { 792 $_[0]->on_error (sub {
793 ($! == Errno::EPIPE || !$!)
530 $finish->($_[0]{rbuf}, \%hdr); 794 ? $finish->(delete $_[0]{rbuf})
795 : $finish->(undef, 599 => $_[2]);
531 }); 796 });
532 $_[0]->on_eof (undef);
533 $_[0]->on_read (sub { }); 797 $_[0]->on_read (sub { });
534 } 798 }
535 } 799 }
536 }); 800 }
537 }); 801 });
538 }; 802 };
539 803
540 # now handle proxy-CONNECT method 804 # now handle proxy-CONNECT method
541 if ($proxy && $uscheme eq "https") { 805 if ($proxy && $uscheme eq "https") {
543 807
544 # maybe re-use $uauthority with patched port? 808 # maybe re-use $uauthority with patched port?
545 $state{handle}->push_write ("CONNECT $uhost:$uport HTTP/1.0\015\012Host: $uhost\015\012\015\012"); 809 $state{handle}->push_write ("CONNECT $uhost:$uport HTTP/1.0\015\012Host: $uhost\015\012\015\012");
546 $state{handle}->push_read (line => $qr_nlnl, sub { 810 $state{handle}->push_read (line => $qr_nlnl, sub {
547 $_[1] =~ /^HTTP\/([0-9\.]+) \s+ ([0-9]{3}) (?: \s+ ([^\015\012]*) )?/ix 811 $_[1] =~ /^HTTP\/([0-9\.]+) \s+ ([0-9]{3}) (?: \s+ ([^\015\012]*) )?/ix
548 or return (%state = (), $cb->(undef, { Status => 599, Reason => "invalid proxy connect response ($_[1])", URL => $url })); 812 or return (%state = (), $cb->(undef, { @pseudo, Status => 599, Reason => "Invalid proxy connect response ($_[1])" }));
549 813
550 if ($2 == 200) { 814 if ($2 == 200) {
551 $rpath = $upath; 815 $rpath = $upath;
552 &$handle_actual_request; 816 &$handle_actual_request;
553 } else { 817 } else {
554 %state = (); 818 %state = ();
555 $cb->(undef, { Status => $2, Reason => $3, URL => $url }); 819 $cb->(undef, { @pseudo, Status => $2, Reason => $3 });
556 } 820 }
557 }); 821 });
558 } else { 822 } else {
559 &$handle_actual_request; 823 &$handle_actual_request;
560 } 824 }
561
562 }, sub {
563 $timeout
564 }; 825 };
826
827 my $tcp_connect = $arg{tcp_connect}
828 || do { require AnyEvent::Socket; \&AnyEvent::Socket::tcp_connect };
829
830 $state{connect_guard} = $tcp_connect->($rhost, $rport, $connect_cb, $arg{on_prepare} || sub { $timeout });
831
565 }; 832 };
566 833
567 defined wantarray && AnyEvent::Util::guard { %state = () } 834 defined wantarray && AnyEvent::Util::guard { %state = () }
568} 835}
569 836
583 &http_request 850 &http_request
584} 851}
585 852
586=back 853=back
587 854
855=head2 DNS CACHING
856
857AnyEvent::HTTP uses the AnyEvent::Socket::tcp_connect function for
858the actual connection, which in turn uses AnyEvent::DNS to resolve
859hostnames. The latter is a simple stub resolver and does no caching
860on its own. If you want DNS caching, you currently have to provide
861your own default resolver (by storing a suitable resolver object in
862C<$AnyEvent::DNS::RESOLVER>).
863
588=head2 GLOBAL FUNCTIONS AND VARIABLES 864=head2 GLOBAL FUNCTIONS AND VARIABLES
589 865
590=over 4 866=over 4
591 867
592=item AnyEvent::HTTP::set_proxy "proxy-url" 868=item AnyEvent::HTTP::set_proxy "proxy-url"
593 869
594Sets the default proxy server to use. The proxy-url must begin with a 870Sets the default proxy server to use. The proxy-url must begin with a
595string of the form C<http://host:port> (optionally C<https:...>). 871string of the form C<http://host:port> (optionally C<https:...>), croaks
872otherwise.
873
874To clear an already-set proxy, use C<undef>.
875
876=item $date = AnyEvent::HTTP::format_date $timestamp
877
878Takes a POSIX timestamp (seconds since the epoch) and formats it as a HTTP
879Date (RFC 2616).
880
881=item $timestamp = AnyEvent::HTTP::parse_date $date
882
883Takes a HTTP Date (RFC 2616) and returns the corresponding POSIX
884timestamp, or C<undef> if the date cannot be parsed.
596 885
597=item $AnyEvent::HTTP::MAX_RECURSE 886=item $AnyEvent::HTTP::MAX_RECURSE
598 887
599The default value for the C<recurse> request parameter (default: C<10>). 888The default value for the C<recurse> request parameter (default: C<10>).
600 889
601=item $AnyEvent::HTTP::USERAGENT 890=item $AnyEvent::HTTP::USERAGENT
602 891
603The default value for the C<User-Agent> header (the default is 892The default value for the C<User-Agent> header (the default is
604C<Mozilla/5.0 (compatible; AnyEvent::HTTP/$VERSION; +http://software.schmorp.de/pkg/AnyEvent)>). 893C<Mozilla/5.0 (compatible; U; AnyEvent-HTTP/$VERSION; +http://software.schmorp.de/pkg/AnyEvent)>).
605 894
606=item $AnyEvent::HTTP::MAX_PERSISTENT 895=item $AnyEvent::HTTP::MAX_PER_HOST
607 896
608The maximum number of persistent connections to keep open (default: 8). 897The maximum number of concurrent connections to the same host (identified
898by the hostname). If the limit is exceeded, then the additional requests
899are queued until previous connections are closed.
609 900
610Not implemented currently. 901The default value for this is C<4>, and it is highly advisable to not
611 902increase it.
612=item $AnyEvent::HTTP::PERSISTENT_TIMEOUT
613
614The maximum time to cache a persistent connection, in seconds (default: 2).
615
616Not implemented currently.
617 903
618=item $AnyEvent::HTTP::ACTIVE 904=item $AnyEvent::HTTP::ACTIVE
619 905
620The number of active connections. This is not the number of currently 906The number of active connections. This is not the number of currently
621running requests, but the number of currently open and non-idle TCP 907running requests, but the number of currently open and non-idle TCP
623 909
624=back 910=back
625 911
626=cut 912=cut
627 913
914our @month = qw(Jan Feb Mar Apr May Jun Jul Aug Sep Oct Nov Dec);
915our @weekday = qw(Sun Mon Tue Wed Thu Fri Sat);
916
917sub format_date($) {
918 my ($time) = @_;
919
920 # RFC 822/1123 format
921 my ($S, $M, $H, $mday, $mon, $year, $wday, $yday, undef) = gmtime $time;
922
923 sprintf "%s, %02d %s %04d %02d:%02d:%02d GMT",
924 $weekday[$wday], $mday, $month[$mon], $year + 1900,
925 $H, $M, $S;
926}
927
928sub parse_date($) {
929 my ($date) = @_;
930
931 my ($d, $m, $y, $H, $M, $S);
932
933 if ($date =~ /^[A-Z][a-z][a-z], ([0-9][0-9]) ([A-Z][a-z][a-z]) ([0-9][0-9][0-9][0-9]) ([0-9][0-9]):([0-9][0-9]):([0-9][0-9]) GMT$/) {
934 # RFC 822/1123, required by RFC 2616
935 ($d, $m, $y, $H, $M, $S) = ($1, $2, $3, $4, $5, $6);
936
937 } elsif ($date =~ /^[A-Z][a-z]+, ([0-9][0-9])-([A-Z][a-z][a-z])-([0-9][0-9]) ([0-9][0-9]):([0-9][0-9]):([0-9][0-9]) GMT$/) {
938 # RFC 850
939 ($d, $m, $y, $H, $M, $S) = ($1, $2, $3 < 69 ? $3 + 2000 : $3 + 1900, $4, $5, $6);
940
941 } 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])$/) {
942 # ISO C's asctime
943 ($d, $m, $y, $H, $M, $S) = ($2, $1, $6, $3, $4, $5);
944 }
945 # other formats fail in the loop below
946
947 for (0..11) {
948 if ($m eq $month[$_]) {
949 require Time::Local;
950 return Time::Local::timegm ($S, $M, $H, $d, $_, $y);
951 }
952 }
953
954 undef
955}
956
628sub set_proxy($) { 957sub set_proxy($) {
958 if (length $_[0]) {
629 $PROXY = [$2, $3 || 3128, $1] if $_[0] =~ m%^(https?):// ([^:/]+) (?: : (\d*) )?%ix; 959 $_[0] =~ m%^(https?):// ([^:/]+) (?: : (\d*) )?%ix
960 or Carp::croak "$_[0]: invalid proxy URL";
961 $PROXY = [$2, $3 || 3128, $1]
962 } else {
963 undef $PROXY;
964 }
630} 965}
631 966
632# initialise proxy from environment 967# initialise proxy from environment
968eval {
633set_proxy $ENV{http_proxy}; 969 set_proxy $ENV{http_proxy};
970};
971
972=head2 SOCKS PROXIES
973
974Socks proxies are not directly supported by AnyEvent::HTTP. You can
975compile your perl to support socks, or use an external program such as
976F<socksify> (dante) or F<tsocks> to make your program use a socks proxy
977transparently.
978
979Alternatively, for AnyEvent::HTTP only, you can use your own
980C<tcp_connect> function that does the proxy handshake - here is an example
981that works with socks4a proxies:
982
983 use Errno;
984 use AnyEvent::Util;
985 use AnyEvent::Socket;
986 use AnyEvent::Handle;
987
988 # host, port and username of/for your socks4a proxy
989 my $socks_host = "10.0.0.23";
990 my $socks_port = 9050;
991 my $socks_user = "";
992
993 sub socks4a_connect {
994 my ($host, $port, $connect_cb, $prepare_cb) = @_;
995
996 my $hdl = new AnyEvent::Handle
997 connect => [$socks_host, $socks_port],
998 on_prepare => sub { $prepare_cb->($_[0]{fh}) },
999 on_error => sub { $connect_cb->() },
1000 ;
1001
1002 $hdl->push_write (pack "CCnNZ*Z*", 4, 1, $port, 1, $socks_user, $host);
1003
1004 $hdl->push_read (chunk => 8, sub {
1005 my ($hdl, $chunk) = @_;
1006 my ($status, $port, $ipn) = unpack "xCna4", $chunk;
1007
1008 if ($status == 0x5a) {
1009 $connect_cb->($hdl->{fh}, (format_address $ipn) . ":$port");
1010 } else {
1011 $! = Errno::ENXIO; $connect_cb->();
1012 }
1013 });
1014
1015 $hdl
1016 }
1017
1018Use C<socks4a_connect> instead of C<tcp_connect> when doing C<http_request>s,
1019possibly after switching off other proxy types:
1020
1021 AnyEvent::HTTP::set_proxy undef; # usually you do not want other proxies
1022
1023 http_get 'http://www.google.com', tcp_connect => \&socks4a_connect, sub {
1024 my ($data, $headers) = @_;
1025 ...
1026 };
634 1027
635=head1 SEE ALSO 1028=head1 SEE ALSO
636 1029
637L<AnyEvent>. 1030L<AnyEvent>.
638 1031
639=head1 AUTHOR 1032=head1 AUTHOR
640 1033
641 Marc Lehmann <schmorp@schmorp.de> 1034 Marc Lehmann <schmorp@schmorp.de>
642 http://home.schmorp.de/ 1035 http://home.schmorp.de/
643 1036
1037With many thanks to Дмитрий Шалашов, who provided countless
1038testcases and bugreports.
1039
644=cut 1040=cut
645 1041
6461 10421
647 1043

Diff Legend

Removed lines
+ Added lines
< Changed lines
> Changed lines