ViewVC Help
View File | Revision Log | Show Annotations | Download File
/cvs/AnyEvent-HTTP/HTTP.pm
Revision: 1.28
Committed: Mon Sep 29 13:50:39 2008 UTC (16 years, 2 months ago) by root
Branch: MAIN
CVS Tags: rel-1_05
Changes since 1.27: +2 -2 lines
Log Message:
1.05

File Contents

# Content
1 =head1 NAME
2
3 AnyEvent::HTTP - simple but non-blocking HTTP/HTTPS client
4
5 =head1 SYNOPSIS
6
7 use AnyEvent::HTTP;
8
9 http_get "http://www.nethype.de/", sub { print $_[1] };
10
11 # ... do something else here
12
13 =head1 DESCRIPTION
14
15 This module is an L<AnyEvent> user, you need to make sure that you use and
16 run a supported event loop.
17
18 This module implements a simple, stateless and non-blocking HTTP
19 client. It supports GET, POST and other request methods, cookies and more,
20 all on a very low level. It can follow redirects supports proxies and
21 automatically limits the number of connections to the values specified in
22 the RFC.
23
24 It should generally be a "good client" that is enough for most HTTP
25 tasks. Simple tasks should be simple, but complex tasks should still be
26 possible as the user retains control over request and response headers.
27
28 The caller is responsible for authentication management, cookies (if
29 the simplistic implementation in this module doesn't suffice), referer
30 and other high-level protocol details for which this module offers only
31 limited support.
32
33 =head2 METHODS
34
35 =over 4
36
37 =cut
38
39 package AnyEvent::HTTP;
40
41 use strict;
42 no warnings;
43
44 use Carp;
45
46 use AnyEvent ();
47 use AnyEvent::Util ();
48 use AnyEvent::Socket ();
49 use AnyEvent::Handle ();
50
51 use base Exporter::;
52
53 our $VERSION = '1.05';
54
55 our @EXPORT = qw(http_get http_post http_head http_request);
56
57 our $USERAGENT = "Mozilla/5.0 (compatible; AnyEvent::HTTP/$VERSION; +http://software.schmorp.de/pkg/AnyEvent)";
58 our $MAX_RECURSE = 10;
59 our $MAX_PERSISTENT = 8;
60 our $PERSISTENT_TIMEOUT = 2;
61 our $TIMEOUT = 300;
62
63 # changing these is evil
64 our $MAX_PERSISTENT_PER_HOST = 2;
65 our $MAX_PER_HOST = 4;
66
67 our $PROXY;
68 our $ACTIVE = 0;
69
70 my %KA_COUNT; # number of open keep-alive connections per host
71 my %CO_SLOT; # number of open connections, and wait queue, per host
72
73 =item http_get $url, key => value..., $cb->($data, $headers)
74
75 Executes an HTTP-GET request. See the http_request function for details on
76 additional parameters.
77
78 =item http_head $url, key => value..., $cb->($data, $headers)
79
80 Executes an HTTP-HEAD request. See the http_request function for details on
81 additional parameters.
82
83 =item http_post $url, $body, key => value..., $cb->($data, $headers)
84
85 Executes an HTTP-POST request with a request body of C<$body>. See the
86 http_request function for details on additional parameters.
87
88 =item http_request $method => $url, key => value..., $cb->($data, $headers)
89
90 Executes a HTTP request of type C<$method> (e.g. C<GET>, C<POST>). The URL
91 must be an absolute http or https URL.
92
93 The callback will be called with the response data as first argument
94 (or C<undef> if it wasn't available due to errors), and a hash-ref with
95 response headers as second argument.
96
97 All the headers in that hash are lowercased. In addition to the response
98 headers, the "pseudo-headers" C<HTTPVersion>, C<Status> and C<Reason>
99 contain the three parts of the HTTP Status-Line of the same name. The
100 pseudo-header C<URL> contains the original URL (which can differ from the
101 requested URL when following redirects).
102
103 If the server sends a header multiple lines, then their contents will be
104 joined together with C<\x00>.
105
106 If an internal error occurs, such as not being able to resolve a hostname,
107 then C<$data> will be C<undef>, C<< $headers->{Status} >> will be C<599>
108 and the C<Reason> pseudo-header will contain an error message.
109
110 A typical callback might look like this:
111
112 sub {
113 my ($body, $hdr) = @_;
114
115 if ($hdr->{Status} =~ /^2/) {
116 ... everything should be ok
117 } else {
118 print "error, $hdr->{Status} $hdr->{Reason}\n";
119 }
120 }
121
122 Additional parameters are key-value pairs, and are fully optional. They
123 include:
124
125 =over 4
126
127 =item recurse => $count (default: $MAX_RECURSE)
128
129 Whether to recurse requests or not, e.g. on redirects, authentication
130 retries and so on, and how often to do so.
131
132 =item headers => hashref
133
134 The request headers to use. Currently, C<http_request> may provide its
135 own C<Host:>, C<Content-Length:>, C<Connection:> and C<Cookie:> headers
136 and will provide defaults for C<User-Agent:> and C<Referer:>.
137
138 =item timeout => $seconds
139
140 The time-out to use for various stages - each connect attempt will reset
141 the timeout, as will read or write activity. Default timeout is 5 minutes.
142
143 =item proxy => [$host, $port[, $scheme]] or undef
144
145 Use the given http proxy for all requests. If not specified, then the
146 default proxy (as specified by C<$ENV{http_proxy}>) is used.
147
148 C<$scheme> must be either missing or C<http> for HTTP, or C<https> for
149 HTTPS.
150
151 =item body => $string
152
153 The request body, usually empty. Will be-sent as-is (future versions of
154 this module might offer more options).
155
156 =item cookie_jar => $hash_ref
157
158 Passing this parameter enables (simplified) cookie-processing, loosely
159 based on the original netscape specification.
160
161 The C<$hash_ref> must be an (initially empty) hash reference which will
162 get updated automatically. It is possible to save the cookie_jar to
163 persistent storage with something like JSON or Storable, but this is not
164 recommended, as expire times are currently being ignored.
165
166 Note that this cookie implementation is not of very high quality, nor
167 meant to be complete. If you want complete cookie management you have to
168 do that on your own. C<cookie_jar> is meant as a quick fix to get some
169 cookie-using sites working. Cookies are a privacy disaster, do not use
170 them unless required to.
171
172 =back
173
174 Example: make a simple HTTP GET request for http://www.nethype.de/
175
176 http_request GET => "http://www.nethype.de/", sub {
177 my ($body, $hdr) = @_;
178 print "$body\n";
179 };
180
181 Example: make a HTTP HEAD request on https://www.google.com/, use a
182 timeout of 30 seconds.
183
184 http_request
185 GET => "https://www.google.com",
186 timeout => 30,
187 sub {
188 my ($body, $hdr) = @_;
189 use Data::Dumper;
190 print Dumper $hdr;
191 }
192 ;
193
194 =cut
195
196 sub _slot_schedule;
197 sub _slot_schedule($) {
198 my $host = shift;
199
200 while ($CO_SLOT{$host}[0] < $MAX_PER_HOST) {
201 if (my $cb = shift @{ $CO_SLOT{$host}[1] }) {
202 # somebody wants that slot
203 ++$CO_SLOT{$host}[0];
204 ++$ACTIVE;
205
206 $cb->(AnyEvent::Util::guard {
207 --$ACTIVE;
208 --$CO_SLOT{$host}[0];
209 _slot_schedule $host;
210 });
211 } else {
212 # nobody wants the slot, maybe we can forget about it
213 delete $CO_SLOT{$host} unless $CO_SLOT{$host}[0];
214 last;
215 }
216 }
217 }
218
219 # wait for a free slot on host, call callback
220 sub _get_slot($$) {
221 push @{ $CO_SLOT{$_[0]}[1] }, $_[1];
222
223 _slot_schedule $_[0];
224 }
225
226 sub http_request($$@) {
227 my $cb = pop;
228 my ($method, $url, %arg) = @_;
229
230 my %hdr;
231
232 $method = uc $method;
233
234 if (my $hdr = $arg{headers}) {
235 while (my ($k, $v) = each %$hdr) {
236 $hdr{lc $k} = $v;
237 }
238 }
239
240 my $recurse = exists $arg{recurse} ? delete $arg{recurse} : $MAX_RECURSE;
241
242 return $cb->(undef, { Status => 599, Reason => "recursion limit reached", URL => $url })
243 if $recurse < 0;
244
245 my $proxy = $arg{proxy} || $PROXY;
246 my $timeout = $arg{timeout} || $TIMEOUT;
247
248 $hdr{"user-agent"} ||= $USERAGENT;
249
250 my ($scheme, $authority, $upath, $query, $fragment) =
251 $url =~ m|(?:([^:/?#]+):)?(?://([^/?#]*))?([^?#]*)(?:\?([^#]*))?(?:#(.*))?|;
252
253 $scheme = lc $scheme;
254
255 my $uport = $scheme eq "http" ? 80
256 : $scheme eq "https" ? 443
257 : return $cb->(undef, { Status => 599, Reason => "only http and https URL schemes supported", URL => $url });
258
259 $hdr{referer} ||= "$scheme://$authority$upath"; # leave out fragment and query string, just a heuristic
260
261 $authority =~ /^(?: .*\@ )? ([^\@:]+) (?: : (\d+) )?$/x
262 or return $cb->(undef, { Status => 599, Reason => "unparsable URL", URL => $url });
263
264 my $uhost = $1;
265 $uport = $2 if defined $2;
266
267 $uhost =~ s/^\[(.*)\]$/$1/;
268 $upath .= "?$query" if length $query;
269
270 $upath =~ s%^/?%/%;
271
272 # cookie processing
273 if (my $jar = $arg{cookie_jar}) {
274 %$jar = () if $jar->{version} < 1;
275
276 my @cookie;
277
278 while (my ($chost, $v) = each %$jar) {
279 next unless $chost eq substr $uhost, -length $chost;
280 next unless $chost =~ /^\./;
281
282 while (my ($cpath, $v) = each %$v) {
283 next unless $cpath eq substr $upath, 0, length $cpath;
284
285 while (my ($k, $v) = each %$v) {
286 next if $scheme ne "https" && exists $v->{secure};
287 push @cookie, "$k=$v->{value}";
288 }
289 }
290 }
291
292 $hdr{cookie} = join "; ", @cookie
293 if @cookie;
294 }
295
296 my ($rhost, $rport, $rpath); # request host, port, path
297
298 if ($proxy) {
299 ($rhost, $rport, $scheme) = @$proxy;
300 $rpath = $url;
301 } else {
302 ($rhost, $rport, $rpath) = ($uhost, $uport, $upath);
303 $hdr{host} = $uhost;
304 }
305
306 $hdr{"content-length"} = length $arg{body};
307
308 my %state = (connect_guard => 1);
309
310 _get_slot $uhost, sub {
311 $state{slot_guard} = shift;
312
313 return unless $state{connect_guard};
314
315 $state{connect_guard} = AnyEvent::Socket::tcp_connect $rhost, $rport, sub {
316 $state{fh} = shift
317 or return $cb->(undef, { Status => 599, Reason => "$!", URL => $url });
318
319 delete $state{connect_guard}; # reduce memory usage, save a tree
320
321 # get handle
322 $state{handle} = new AnyEvent::Handle
323 fh => $state{fh},
324 ($scheme eq "https" ? (tls => "connect") : ());
325
326 # limit the number of persistent connections
327 if ($KA_COUNT{$_[1]} < $MAX_PERSISTENT_PER_HOST) {
328 ++$KA_COUNT{$_[1]};
329 $state{handle}{ka_count_guard} = AnyEvent::Util::guard { --$KA_COUNT{$_[1]} };
330 $hdr{connection} = "keep-alive";
331 delete $hdr{connection}; # keep-alive not yet supported
332 } else {
333 delete $hdr{connection};
334 }
335
336 # (re-)configure handle
337 $state{handle}->timeout ($timeout);
338 $state{handle}->on_error (sub {
339 my $errno = "$!";
340 %state = ();
341 $cb->(undef, { Status => 599, Reason => $errno, URL => $url });
342 });
343 $state{handle}->on_eof (sub {
344 %state = ();
345 $cb->(undef, { Status => 599, Reason => "unexpected end-of-file", URL => $url });
346 });
347
348 # send request
349 $state{handle}->push_write (
350 "$method $rpath HTTP/1.0\015\012"
351 . (join "", map "$_: $hdr{$_}\015\012", keys %hdr)
352 . "\015\012"
353 . (delete $arg{body})
354 );
355
356 %hdr = (); # reduce memory usage, save a kitten
357
358 # status line
359 $state{handle}->push_read (line => qr/\015?\012/, sub {
360 $_[1] =~ /^HTTP\/([0-9\.]+) \s+ ([0-9]{3}) (?: \s+ ([^\015\012]*) )?/ix
361 or return (%state = (), $cb->(undef, { Status => 599, Reason => "invalid server response ($_[1])", URL => $url }));
362
363 my %hdr = ( # response headers
364 HTTPVersion => "\x00$1",
365 Status => "\x00$2",
366 Reason => "\x00$3",
367 URL => "\x00$url"
368 );
369
370 # headers, could be optimized a bit
371 $state{handle}->unshift_read (line => qr/\015?\012\015?\012/, sub {
372 for ("$_[1]\012") {
373 # we support spaces in field names, as lotus domino
374 # creates them.
375 $hdr{lc $1} .= "\x00$2"
376 while /\G
377 ([^:\000-\037]+):
378 [\011\040]*
379 ((?: [^\015\012]+ | \015?\012[\011\040] )*)
380 \015?\012
381 /gxc;
382
383 /\G$/
384 or return (%state = (), $cb->(undef, { Status => 599, Reason => "garbled response headers", URL => $url }));
385 }
386
387 substr $_, 0, 1, ""
388 for values %hdr;
389
390 my $finish = sub {
391 %state = ();
392
393 # set-cookie processing
394 if ($arg{cookie_jar} && exists $hdr{"set-cookie"}) {
395 for (split /\x00/, $hdr{"set-cookie"}) {
396 my ($cookie, @arg) = split /;\s*/;
397 my ($name, $value) = split /=/, $cookie, 2;
398 my %kv = (value => $value, map { split /=/, $_, 2 } @arg);
399
400 my $cdom = (delete $kv{domain}) || $uhost;
401 my $cpath = (delete $kv{path}) || "/";
402
403 $cdom =~ s/^\.?/./; # make sure it starts with a "."
404
405 next if $cdom =~ /\.$/;
406
407 # this is not rfc-like and not netscape-like. go figure.
408 my $ndots = $cdom =~ y/.//;
409 next if $ndots < ($cdom =~ /\.[^.][^.]\.[^.][^.]$/ ? 3 : 2);
410
411 # store it
412 $arg{cookie_jar}{version} = 1;
413 $arg{cookie_jar}{$cdom}{$cpath}{$name} = \%kv;
414 }
415 }
416
417 # microsoft and other shitheads don't give a shit for following standards,
418 # try to support some common forms of broken Location headers.
419 if ($_[1]{location} !~ /^(?: $ | [^:\/?\#]+ : )/x) {
420 $_[1]{location} =~ s/^\.\/+//;
421
422 my $url = "$scheme://$uhost:$uport";
423
424 unless ($_[1]{location} =~ s/^\///) {
425 $url .= $upath;
426 $url =~ s/\/[^\/]*$//;
427 }
428
429 $_[1]{location} = "$url/$_[1]{location}";
430 }
431
432 if ($_[1]{Status} =~ /^30[12]$/ && $recurse && $method ne "POST") {
433 # apparently, mozilla et al. just change POST to GET here
434 # more research is needed before we do the same
435 http_request ($method, $_[1]{location}, %arg, recurse => $recurse - 1, $cb);
436 } elsif ($_[1]{Status} == 303 && $recurse) {
437 # even http/1.1 is unlear on how to mutate the method
438 $method = "GET" unless $method eq "HEAD";
439 http_request ($method => $_[1]{location}, %arg, recurse => $recurse - 1, $cb);
440 } elsif ($_[1]{Status} == 307 && $recurse && $method =~ /^(?:GET|HEAD)$/) {
441 http_request ($method => $_[1]{location}, %arg, recurse => $recurse - 1, $cb);
442 } else {
443 $cb->($_[0], $_[1]);
444 }
445 };
446
447 if ($hdr{Status} =~ /^(?:1..|204|304)$/ or $method eq "HEAD") {
448 $finish->(undef, \%hdr);
449 } else {
450 if (exists $hdr{"content-length"}) {
451 $_[0]->unshift_read (chunk => $hdr{"content-length"}, sub {
452 # could cache persistent connection now
453 if ($hdr{connection} =~ /\bkeep-alive\b/i) {
454 # but we don't, due to misdesigns, this is annoyingly complex
455 };
456
457 $finish->($_[1], \%hdr);
458 });
459 } else {
460 # too bad, need to read until we get an error or EOF,
461 # no way to detect winged data.
462 $_[0]->on_error (sub {
463 $finish->($_[0]{rbuf}, \%hdr);
464 });
465 $_[0]->on_eof (undef);
466 $_[0]->on_read (sub { });
467 }
468 }
469 });
470 });
471 }, sub {
472 $timeout
473 };
474 };
475
476 defined wantarray && AnyEvent::Util::guard { %state = () }
477 }
478
479 sub http_get($@) {
480 unshift @_, "GET";
481 &http_request
482 }
483
484 sub http_head($@) {
485 unshift @_, "HEAD";
486 &http_request
487 }
488
489 sub http_post($$@) {
490 my $url = shift;
491 unshift @_, "POST", $url, "body";
492 &http_request
493 }
494
495 =back
496
497 =head2 GLOBAL FUNCTIONS AND VARIABLES
498
499 =over 4
500
501 =item AnyEvent::HTTP::set_proxy "proxy-url"
502
503 Sets the default proxy server to use. The proxy-url must begin with a
504 string of the form C<http://host:port> (optionally C<https:...>).
505
506 =item $AnyEvent::HTTP::MAX_RECURSE
507
508 The default value for the C<recurse> request parameter (default: C<10>).
509
510 =item $AnyEvent::HTTP::USERAGENT
511
512 The default value for the C<User-Agent> header (the default is
513 C<Mozilla/5.0 (compatible; AnyEvent::HTTP/$VERSION; +http://software.schmorp.de/pkg/AnyEvent)>).
514
515 =item $AnyEvent::HTTP::MAX_PERSISTENT
516
517 The maximum number of persistent connections to keep open (default: 8).
518
519 Not implemented currently.
520
521 =item $AnyEvent::HTTP::PERSISTENT_TIMEOUT
522
523 The maximum time to cache a persistent connection, in seconds (default: 2).
524
525 Not implemented currently.
526
527 =item $AnyEvent::HTTP::ACTIVE
528
529 The number of active connections. This is not the number of currently
530 running requests, but the number of currently open and non-idle TCP
531 connections. This number of can be useful for load-leveling.
532
533 =back
534
535 =cut
536
537 sub set_proxy($) {
538 $PROXY = [$2, $3 || 3128, $1] if $_[0] =~ m%^(https?):// ([^:/]+) (?: : (\d*) )?%ix;
539 }
540
541 # initialise proxy from environment
542 set_proxy $ENV{http_proxy};
543
544 =head1 SEE ALSO
545
546 L<AnyEvent>.
547
548 =head1 AUTHOR
549
550 Marc Lehmann <schmorp@schmorp.de>
551 http://home.schmorp.de/
552
553 =cut
554
555 1
556