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.4 by root, Wed Jun 4 11:59:22 2008 UTC vs.
Revision 1.66 by root, Fri Dec 31 06:18:30 2010 UTC

3AnyEvent::HTTP - simple but non-blocking HTTP/HTTPS client 3AnyEvent::HTTP - simple but non-blocking HTTP/HTTPS client
4 4
5=head1 SYNOPSIS 5=head1 SYNOPSIS
6 6
7 use AnyEvent::HTTP; 7 use AnyEvent::HTTP;
8
9 http_get "http://www.nethype.de/", sub { print $_[1] };
10
11 # ... do something else here
8 12
9=head1 DESCRIPTION 13=head1 DESCRIPTION
10 14
11This module is an L<AnyEvent> user, you need to make sure that you use and 15This module is an L<AnyEvent> user, you need to make sure that you use and
12run a supported event loop. 16run a supported event loop.
13 17
18This module implements a simple, stateless and non-blocking HTTP
19client. It supports GET, POST and other request methods, cookies and more,
20all on a very low level. It can follow redirects supports proxies and
21automatically limits the number of connections to the values specified in
22the RFC.
23
24It should generally be a "good client" that is enough for most HTTP
25tasks. Simple tasks should be simple, but complex tasks should still be
26possible as the user retains control over request and response headers.
27
28The caller is responsible for authentication management, cookies (if
29the simplistic implementation in this module doesn't suffice), referer
30and other high-level protocol details for which this module offers only
31limited support.
32
14=head2 METHODS 33=head2 METHODS
15 34
16=over 4 35=over 4
17 36
18=cut 37=cut
20package AnyEvent::HTTP; 39package AnyEvent::HTTP;
21 40
22use strict; 41use strict;
23no warnings; 42no warnings;
24 43
25use Carp; 44use Errno ();
26 45
27use AnyEvent (); 46use AnyEvent 5.0 ();
28use AnyEvent::Util (); 47use AnyEvent::Util ();
29use AnyEvent::Socket ();
30use AnyEvent::Handle (); 48use AnyEvent::Handle ();
31 49
32use base Exporter::; 50use base Exporter::;
33 51
34our $VERSION = '1.0'; 52our $VERSION = '1.5';
35 53
36our @EXPORT = qw(http_get http_request); 54our @EXPORT = qw(http_get http_post http_head http_request);
37 55
38our $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)";
39our $MAX_RECURSE = 10; 57our $MAX_RECURSE = 10;
40our $MAX_PERSISTENT = 8; 58our $MAX_PERSISTENT = 8;
41our $PERSISTENT_TIMEOUT = 2; 59our $PERSISTENT_TIMEOUT = 2;
42our $TIMEOUT = 300; 60our $TIMEOUT = 300;
43 61
44# changing these is evil 62# changing these is evil
45our $MAX_PERSISTENT_PER_HOST = 2; 63our $MAX_PERSISTENT_PER_HOST = 0;
46our $MAX_PER_HOST = 4; # not respected yet :( 64our $MAX_PER_HOST = 4;
47 65
48our $PROXY; 66our $PROXY;
67our $ACTIVE = 0;
49 68
50my %KA_COUNT; # number of open keep-alive connections per host 69my %KA_COUNT; # number of open keep-alive connections per host
70my %CO_SLOT; # number of open connections, and wait queue, per host
51 71
52=item http_get $url, key => value..., $cb->($data, $headers) 72=item http_get $url, key => value..., $cb->($data, $headers)
53 73
54Executes an HTTP-GET request. See the http_request function for details on 74Executes an HTTP-GET request. See the http_request function for details on
55additional parameters. 75additional parameters and the return value.
56 76
77=item http_head $url, key => value..., $cb->($data, $headers)
78
79Executes an HTTP-HEAD request. See the http_request function for details
80on additional parameters and the return value.
81
57=item http_get $url, $body, key => value..., $cb->($data, $headers) 82=item http_post $url, $body, key => value..., $cb->($data, $headers)
58 83
59Executes an HTTP-POST request with a requets body of C<$bod>. See the 84Executes an HTTP-POST request with a request body of C<$body>. See the
60http_request function for details on additional parameters. 85http_request function for details on additional parameters and the return
86value.
61 87
62=item http_request $method => $url, key => value..., $cb->($data, $headers) 88=item http_request $method => $url, key => value..., $cb->($data, $headers)
63 89
64Executes a HTTP request of type C<$method> (e.g. C<GET>, C<POST>). The URL 90Executes a HTTP request of type C<$method> (e.g. C<GET>, C<POST>). The URL
65must be an absolute http or https URL. 91must be an absolute http or https URL.
66 92
93When called in void context, nothing is returned. In other contexts,
94C<http_request> returns a "cancellation guard" - you have to keep the
95object at least alive until the callback get called. If the object gets
96destroyed before the callback is called, the request will be cancelled.
97
67The callback will be called with the response data as first argument 98The callback will be called with the response body data as first argument
68(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
69response headers as second argument. 100second argument.
70 101
71All the headers in that has are lowercased. In addition to the response 102All the headers in that hash are lowercased. In addition to the response
72headers, the three "pseudo-headers" C<HTTPVersion>, C<Status> and 103headers, the "pseudo-headers" (uppercase to avoid clashing with possible
73C<Reason> contain the three parts of the HTTP Status-Line of the same 104response headers) C<HTTPVersion>, C<Status> and C<Reason> contain the
74name. 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
110The pseudo-header C<URL> contains the actual URL (which can differ from
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.
122
123If the server sends a header multiple times, then their contents will be
124joined together with a comma (C<,>), as per the HTTP spec.
75 125
76If 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,
77then 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>
78and 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.
130
131A typical callback might look like this:
132
133 sub {
134 my ($body, $hdr) = @_;
135
136 if ($hdr->{Status} =~ /^2/) {
137 ... everything should be ok
138 } else {
139 print "error, $hdr->{Status} $hdr->{Reason}\n";
140 }
141 }
79 142
80Additional parameters are key-value pairs, and are fully optional. They 143Additional parameters are key-value pairs, and are fully optional. They
81include: 144include:
82 145
83=over 4 146=over 4
87Whether to recurse requests or not, e.g. on redirects, authentication 150Whether to recurse requests or not, e.g. on redirects, authentication
88retries and so on, and how often to do so. 151retries and so on, and how often to do so.
89 152
90=item headers => hashref 153=item headers => hashref
91 154
92The request headers to use. 155The request headers to use. Currently, C<http_request> may provide its
156own C<Host:>, C<Content-Length:>, C<Connection:> and C<Cookie:> headers
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).
93 160
94=item timeout => $seconds 161=item timeout => $seconds
95 162
96The 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
97the 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.
98 168
99=item proxy => [$host, $port[, $scheme]] or undef 169=item proxy => [$host, $port[, $scheme]] or undef
100 170
101Use 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
102default proxy (as specified by C<$ENV{http_proxy}>) is used. 172default proxy (as specified by C<$ENV{http_proxy}>) is used.
103 173
104C<$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
105HTTPS. 175HTTPS.
106 176
107=item body => $string 177=item body => $string
108 178
109The 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
110this module might offer more options). 180this module might offer more options).
111 181
182=item cookie_jar => $hash_ref
183
184Passing this parameter enables (simplified) cookie-processing, loosely
185based on the original netscape specification.
186
187The C<$hash_ref> must be an (initially empty) hash reference which will
188get updated automatically. It is possible to save the cookie_jar to
189persistent storage with something like JSON or Storable, but this is not
190recommended, as expiry times are currently being ignored.
191
192Note that this cookie implementation is not of very high quality, nor
193meant to be complete. If you want complete cookie management you have to
194do that on your own. C<cookie_jar> is meant as a quick fix to get some
195cookie-using sites working. Cookies are a privacy disaster, do not use
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.
292
112=back 293=back
113 294
114=back 295Example: make a simple HTTP GET request for http://www.nethype.de/
296
297 http_request GET => "http://www.nethype.de/", sub {
298 my ($body, $hdr) = @_;
299 print "$body\n";
300 };
301
302Example: make a HTTP HEAD request on https://www.google.com/, use a
303timeout of 30 seconds.
304
305 http_request
306 GET => "https://www.google.com",
307 timeout => 30,
308 sub {
309 my ($body, $hdr) = @_;
310 use Data::Dumper;
311 print Dumper $hdr;
312 }
313 ;
314
315Example: make another simple HTTP GET request, but immediately try to
316cancel it.
317
318 my $request = http_request GET => "http://www.nethype.de/", sub {
319 my ($body, $hdr) = @_;
320 print "$body\n";
321 };
322
323 undef $request;
115 324
116=cut 325=cut
117 326
327sub _slot_schedule;
328sub _slot_schedule($) {
329 my $host = shift;
330
331 while ($CO_SLOT{$host}[0] < $MAX_PER_HOST) {
332 if (my $cb = shift @{ $CO_SLOT{$host}[1] }) {
333 # somebody wants that slot
334 ++$CO_SLOT{$host}[0];
335 ++$ACTIVE;
336
337 $cb->(AnyEvent::Util::guard {
338 --$ACTIVE;
339 --$CO_SLOT{$host}[0];
340 _slot_schedule $host;
341 });
342 } else {
343 # nobody wants the slot, maybe we can forget about it
344 delete $CO_SLOT{$host} unless $CO_SLOT{$host}[0];
345 last;
346 }
347 }
348}
349
350# wait for a free slot on host, call callback
351sub _get_slot($$) {
352 push @{ $CO_SLOT{$_[0]}[1] }, $_[1];
353
354 _slot_schedule $_[0];
355}
356
357# continue to parse $_ for headers and place them into the arg
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" };
386
118sub http_request($$$;@) { 387sub http_request($$@) {
119 my $cb = pop; 388 my $cb = pop;
120 my ($method, $url, %arg) = @_; 389 my ($method, $url, %arg) = @_;
121 390
122 my %hdr; 391 my %hdr;
123 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";
395
124 $method = uc $method; 396 $method = uc $method;
125 397
126 if (my $hdr = delete $arg{headers}) { 398 if (my $hdr = $arg{headers}) {
127 while (my ($k, $v) = each %$hdr) { 399 while (my ($k, $v) = each %$hdr) {
128 $hdr{lc $k} = $v; 400 $hdr{lc $k} = $v;
129 } 401 }
130 } 402 }
131 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
408 my $recurse = exists $arg{recurse} ? delete $arg{recurse} : $MAX_RECURSE;
409
410 return $cb->(undef, { @pseudo, Status => 599, Reason => "Too many redirections" })
411 if $recurse < 0;
412
132 my $proxy = $arg{proxy} || $PROXY; 413 my $proxy = $arg{proxy} || $PROXY;
133 my $timeout = $arg{timeout} || $TIMEOUT; 414 my $timeout = $arg{timeout} || $TIMEOUT;
134 my $recurse = exists $arg{recurse} ? $arg{recurse} : $MAX_RECURSE;
135 415
136 $hdr{"user-agent"} ||= $USERAGENT; 416 my ($uscheme, $uauthority, $upath, $query, $fragment) =
417 $url =~ m|(?:([^:/?#]+):)?(?://([^/?#]*))?([^?#]*)(?:(\?[^#]*))?(?:#(.*))?|;
137 418
138 my ($host, $port, $path, $scheme); 419 $uscheme = lc $uscheme;
420
421 my $uport = $uscheme eq "http" ? 80
422 : $uscheme eq "https" ? 443
423 : return $cb->(undef, { @pseudo, Status => 599, Reason => "Only http and https URL schemes supported" });
424
425 $uauthority =~ /^(?: .*\@ )? ([^\@:]+) (?: : (\d+) )?$/x
426 or return $cb->(undef, { @pseudo, Status => 599, Reason => "Unparsable URL" });
427
428 my $uhost = $1;
429 $uport = $2 if defined $2;
430
431 $hdr{host} = defined $2 ? "$uhost:$2" : "$uhost"
432 unless exists $hdr{host};
433
434 $uhost =~ s/^\[(.*)\]$/$1/;
435 $upath .= $query if length $query;
436
437 $upath =~ s%^/?%/%;
438
439 # cookie processing
440 if (my $jar = $arg{cookie_jar}) {
441 %$jar = () if $jar->{version} != 1;
442
443 my @cookie;
444
445 while (my ($chost, $v) = each %$jar) {
446 if ($chost =~ /^\./) {
447 next unless $chost eq substr $uhost, -length $chost;
448 } elsif ($chost =~ /\./) {
449 next unless $chost eq $uhost;
450 } else {
451 next;
452 }
453
454 while (my ($cpath, $v) = each %$v) {
455 next unless $cpath eq substr $upath, 0, length $cpath;
456
457 while (my ($k, $v) = each %$v) {
458 next if $uscheme ne "https" && exists $v->{secure};
459 my $value = $v->{value};
460 $value =~ s/([\\"])/\\$1/g;
461 push @cookie, "$k=\"$value\"";
462 }
463 }
464 }
465
466 $hdr{cookie} = join "; ", @cookie
467 if @cookie;
468 }
469
470 my ($rhost, $rport, $rscheme, $rpath); # request host, port, path
139 471
140 if ($proxy) { 472 if ($proxy) {
141 ($host, $port, $scheme) = @$proxy; 473 ($rpath, $rhost, $rport, $rscheme) = ($url, @$proxy);
142 $path = $url; 474
475 $rscheme = "http" unless defined $rscheme;
476
477 # don't support https requests over https-proxy transport,
478 # can't be done with tls as spec'ed, unless you double-encrypt.
479 $rscheme = "http" if $uscheme eq "https" && $rscheme eq "https";
143 } else { 480 } else {
144 ($scheme, my $authority, $path, my $query, my $fragment) = 481 ($rhost, $rport, $rscheme, $rpath) = ($uhost, $uport, $uscheme, $upath);
145 $url =~ m|(?:([^:/?#]+):)?(?://([^/?#]*))?([^?#]*)(?:\?([^#]*))?(?:#(.*))?|;
146
147 $port = $scheme eq "http" ? 80
148 : $scheme eq "https" ? 443
149 : croak "$url: only http and https URLs supported";
150
151 $authority =~ /^(?: .*\@ )? ([^\@:]+) (?: : (\d+) )?$/x
152 or croak "$authority: unparsable URL";
153
154 $host = $1;
155 $port = $2 if defined $2;
156
157 $host =~ s/^\[(.*)\]$/$1/;
158 $path .= "?$query" if length $query;
159
160 $path = "/" unless $path;
161
162 $hdr{host} = $host = lc $host;
163 } 482 }
164 483
165 $scheme = lc $scheme; 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"};
166 487
167 my %state;
168
169 $state{body} = delete $arg{body};
170
171 $hdr{"content-length"} = length $state{body}; 488 $hdr{"content-length"} = length $arg{body}
489 if length $arg{body} || $method ne "GET";
172 490
173 $state{connect_guard} = AnyEvent::Socket::tcp_connect $host, $port, sub { 491 $hdr{connection} = "close TE";
492 $hdr{te} = "trailers" unless exists $hdr{te};
493
494 my %state = (connect_guard => 1);
495
496 _get_slot $uhost, sub {
497 $state{slot_guard} = shift;
498
499 return unless $state{connect_guard};
500
501 my $connect_cb = sub {
174 $state{fh} = shift 502 $state{fh} = shift
175 or return $cb->(undef, { Status => 599, Reason => "$!" });
176
177 delete $state{connect_guard}; # reduce memory usage, save a tree
178
179 # get handle
180 $state{handle} = new AnyEvent::Handle
181 fh => $state{fh},
182 ($scheme eq "https" ? (tls => "connect") : ());
183
184 # limit the number of persistent connections
185 if ($KA_COUNT{$_[1]} < $MAX_PERSISTENT_PER_HOST) {
186 ++$KA_COUNT{$_[1]};
187 $state{handle}{ka_count_guard} = AnyEvent::Util::guard { --$KA_COUNT{$_[1]} };
188 $hdr{connection} = "keep-alive";
189 delete $hdr{connection}; # keep-alive not yet supported
190 } else {
191 delete $hdr{connection};
192 }
193
194 # (re-)configure handle
195 $state{handle}->timeout ($timeout);
196 $state{handle}->on_error (sub {
197 %state = ();
198 $cb->(undef, { Status => 599, Reason => "$!" });
199 });
200 $state{handle}->on_eof (sub {
201 %state = ();
202 $cb->(undef, { Status => 599, Reason => "unexpected end-of-file" });
203 });
204
205 # send request
206 $state{handle}->push_write (
207 "$method $path HTTP/1.0\015\012"
208 . (join "", map "$_: $hdr{$_}\015\012", keys %hdr)
209 . "\015\012"
210 . (delete $state{body})
211 );
212
213 %hdr = (); # reduce memory usage, save a kitten
214
215 # status line
216 $state{handle}->push_read (line => qr/\015?\012/, sub {
217 $_[1] =~ /^HTTP\/([0-9\.]+) \s+ ([0-9]{3}) \s+ ([^\015\012]+)/ix
218 or return (%state = (), $cb->(undef, { Status => 599, Reason => "invalid server response ($_[1])" }));
219
220 my %hdr = ( # response headers
221 HTTPVersion => ",$1",
222 Status => ",$2",
223 Reason => ",$3",
224 );
225
226 # headers, could be optimized a bit
227 $state{handle}->unshift_read (line => qr/\015?\012\015?\012/, sub {
228 for ("$_[1]\012") {
229 # we support spaces in field names, as lotus domino
230 # creates them.
231 $hdr{lc $1} .= ",$2"
232 while /\G
233 ([^:\000-\037]+):
234 [\011\040]*
235 ((?: [^\015\012]+ | \015?\012[\011\040] )*)
236 \015?\012
237 /gxc;
238
239 /\G$/
240 or return $cb->(undef, { Status => 599, Reason => "garbled response headers" });
241 } 503 or do {
242 504 my $err = "$!";
243 substr $_, 0, 1, ""
244 for values %hdr;
245
246 if ($method eq "HEAD") {
247 %state = (); 505 %state = ();
506 return $cb->(undef, { @pseudo, Status => 599, Reason => $err });
507 };
508
509 pop; # free memory, save a tree
510
511 return unless delete $state{connect_guard};
512
513 # get handle
514 $state{handle} = new AnyEvent::Handle
515 fh => $state{fh},
516 peername => $rhost,
517 tls_ctx => $arg{tls_ctx},
518 # these need to be reconfigured on keepalive handles
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 ;
529
530 # limit the number of persistent connections
531 # keepalive not yet supported
532# if ($KA_COUNT{$_[1]} < $MAX_PERSISTENT_PER_HOST) {
533# ++$KA_COUNT{$_[1]};
534# $state{handle}{ka_count_guard} = AnyEvent::Util::guard {
535# --$KA_COUNT{$_[1]}
536# };
537# $hdr{connection} = "keep-alive";
538# } else {
539# delete $hdr{connection};
540# }
541
542 $state{handle}->starttls ("connect") if $rscheme eq "https";
543
544 # handle actual, non-tunneled, request
545 my $handle_actual_request = sub {
546 $state{handle}->starttls ("connect") if $uscheme eq "https" && !exists $state{handle}{tls};
547
548 # send request
549 $state{handle}->push_write (
550 "$method $rpath HTTP/1.1\015\012"
551 . (join "", map "\u$_: $hdr{$_}\015\012", grep defined $hdr{$_}, keys %hdr)
552 . "\015\012"
553 . (delete $arg{body})
554 );
555
556 # return if error occured during push_write()
557 return unless %state;
558
559 %hdr = (); # reduce memory usage, save a kitten, also make it possible to re-use
560
561 # status line and headers
562 $state{handle}->push_read (line => $qr_nlnl, sub {
563 my $keepalive = pop;
564
565 for ("$_[1]") {
566 y/\015//d; # weed out any \015, as they show up in the weirdest of places.
567
568 /^HTTP\/([0-9\.]+) \s+ ([0-9]{3}) (?: \s+ ([^\012]*) )? \012/igxc
569 or return (%state = (), $cb->(undef, { @pseudo, Status => 599, Reason => "Invalid server response" }));
570
571 push @pseudo,
572 HTTPVersion => $1,
573 Status => $2,
574 Reason => $3,
575 ;
576
577 my $hdr = parse_hdr
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/\/[^\/]*$//;
594 }
595
596 $hdr{location} = "$url/$hdr{location}";
597 }
598
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])
619 $state{handle}->destroy if $state{handle};
620 %state = ();
621
622 if (defined $_[1]) {
623 $hdr{OrigStatus} = $hdr{Status}; $hdr{Status} = $_[1];
624 $hdr{OrigReason} = $hdr{Reason}; $hdr{Reason} = $_[2];
625 }
626
627 # set-cookie processing
628 if ($arg{cookie_jar}) {
629 for ($hdr{"set-cookie"}) {
630 # parse NAME=VALUE
631 my @kv;
632
633 while (/\G\s* ([^=;,[:space:]]+) \s*=\s* (?: "((?:[^\\"]+|\\.)*)" | ([^=;,[:space:]]*) )/gcxs) {
634 my $name = $1;
635 my $value = $3;
636
637 unless ($value) {
638 $value = $2;
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 {
248 $cb->(undef, \%hdr); 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);
249 } else { 703 } else {
250 if (exists $hdr{"content-length"}) { 704 # body handling, many different code paths
251 $_[0]->unshift_read (chunk => $hdr{"content-length"}, sub { 705 # - no body expected
252 # could cache persistent connection now 706 # - want_body_handle
253 if ($hdr{connection} =~ /\bkeep-alive\b/i) { 707 # - te chunked
254 # but we don't, due to misdesigns, this is annoyingly complex 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 warn $_[1];#d#
725 $_[1] =~ /^([0-9a-fA-F]+)/
726 or $finish->(undef, 599 => "Garbled chunked transfer encoding");
727
728 my $len = hex $1;
729
730 if ($len) {
731 $_[0]->push_read (chunk => hex $1, sub {
732 $on_body->($_[1], \%hdr)
733 or return $finish->(undef, 598 => "Request cancelled by on_body");
734
735 $_[0]->push_read (line => sub {
736 length $_[1]
737 and return $finish->(undef, 599 => "Garbled chunked transfer encoding");
738 $_[0]->push_read (line => $read_chunk);
739 });
740 });
741 } else {
742 $_[0]->push_read (line => $qr_nlnl, sub {
743 if (length $_[1]) {
744 for ("$_[1]") {
745 y/\015//d; # weed out any \015, as they show up in the weirdest of places.
746
747 my $hdr = parse_hdr
748 or return $finish->(undef, 599 => "Garbled response trailers");
749
750 %hdr = (%hdr, %$hdr);
751 }
752 }
753
754 $finish->($body, undef, undef, 1);
755 });
756 }
255 }; 757 };
256 758
759 $_[0]->push_read (line => $read_chunk);
760
761 } elsif ($arg{on_body}) {
762 $_[0]->on_error (sub { $finish->(undef, 599 => $_[2]) });
763
764 if ($len) {
765 $_[0]->on_read (sub {
766 $len -= length $_[0]{rbuf};
767
768 $arg{on_body}(delete $_[0]{rbuf}, \%hdr)
769 or return $finish->(undef, 598 => "Request cancelled by on_body");
770
771 $len > 0
772 or $finish->("", undef, undef, 1);
773 });
257 %state = (); 774 } else {
258 $cb->($_[1], \%hdr); 775 $_[0]->on_eof (sub {
776 $finish->("");
777 });
778 $_[0]->on_read (sub {
779 $arg{on_body}(delete $_[0]{rbuf}, \%hdr)
780 or $finish->(undef, 598 => "Request cancelled by on_body");
781 });
782 }
783 } else {
784 $_[0]->on_eof (undef);
785
786 if ($len) {
787 $_[0]->on_error (sub { $finish->(undef, 599 => $_[2]) });
788 $_[0]->on_read (sub {
789 $finish->((substr delete $_[0]{rbuf}, 0, $len, ""), undef, undef, 1)
790 if $len <= length $_[0]{rbuf};
791 });
792 } else {
793 $_[0]->on_error (sub {
794 ($! == Errno::EPIPE || !$!)
795 ? $finish->(delete $_[0]{rbuf})
796 : $finish->(undef, 599 => $_[2]);
797 });
798 $_[0]->on_read (sub { });
799 }
259 }); 800 }
801 }
802 });
803 };
804
805 # now handle proxy-CONNECT method
806 if ($proxy && $uscheme eq "https") {
807 # oh dear, we have to wrap it into a connect request
808
809 # maybe re-use $uauthority with patched port?
810 $state{handle}->push_write ("CONNECT $uhost:$uport HTTP/1.0\015\012Host: $uhost\015\012\015\012");
811 $state{handle}->push_read (line => $qr_nlnl, sub {
812 $_[1] =~ /^HTTP\/([0-9\.]+) \s+ ([0-9]{3}) (?: \s+ ([^\015\012]*) )?/ix
813 or return (%state = (), $cb->(undef, { @pseudo, Status => 599, Reason => "Invalid proxy connect response ($_[1])" }));
814
815 if ($2 == 200) {
816 $rpath = $upath;
817 &$handle_actual_request;
260 } else { 818 } else {
261 # too bad, need to read until we get an error or EOF,
262 # no way to detect winged data.
263 $_[0]->on_error (sub {
264 %state = (); 819 %state = ();
265 $cb->($_[0]{rbuf}, \%hdr); 820 $cb->(undef, { @pseudo, Status => $2, Reason => $3 });
266 });
267 $_[0]->on_eof (undef);
268 $_[0]->on_read (sub { });
269 } 821 }
270 } 822 });
823 } else {
824 &$handle_actual_request;
271 }); 825 }
272 }); 826 };
273 }, sub { 827
274 $timeout 828 my $tcp_connect = $arg{tcp_connect}
829 || do { require AnyEvent::Socket; \&AnyEvent::Socket::tcp_connect };
830
831 $state{connect_guard} = $tcp_connect->($rhost, $rport, $connect_cb, $arg{on_prepare} || sub { $timeout });
832
275 }; 833 };
276 834
277 defined wantarray && AnyEvent::Util::guard { %state = () } 835 defined wantarray && AnyEvent::Util::guard { %state = () }
278} 836}
279 837
280sub http_get($$;@) { 838sub http_get($@) {
281 unshift @_, "GET"; 839 unshift @_, "GET";
282 &http_request 840 &http_request
283} 841}
284 842
285sub http_head($$;@) { 843sub http_head($@) {
286 unshift @_, "HEAD"; 844 unshift @_, "HEAD";
287 &http_request 845 &http_request
288} 846}
289 847
290sub http_post($$$;@) { 848sub http_post($$@) {
849 my $url = shift;
291 unshift @_, "POST", "body"; 850 unshift @_, "POST", $url, "body";
292 &http_request 851 &http_request
293} 852}
294 853
854=back
855
856=head2 DNS CACHING
857
858AnyEvent::HTTP uses the AnyEvent::Socket::tcp_connect function for
859the actual connection, which in turn uses AnyEvent::DNS to resolve
860hostnames. The latter is a simple stub resolver and does no caching
861on its own. If you want DNS caching, you currently have to provide
862your own default resolver (by storing a suitable resolver object in
863C<$AnyEvent::DNS::RESOLVER>).
864
295=head2 GLOBAL FUNCTIONS AND VARIABLES 865=head2 GLOBAL FUNCTIONS AND VARIABLES
296 866
297=over 4 867=over 4
298 868
299=item AnyEvent::HTTP::set_proxy "proxy-url" 869=item AnyEvent::HTTP::set_proxy "proxy-url"
300 870
301Sets the default proxy server to use. The proxy-url must begin with a 871Sets the default proxy server to use. The proxy-url must begin with a
302string of the form C<http://host:port> (optionally C<https:...>). 872string of the form C<http://host:port> (optionally C<https:...>), croaks
873otherwise.
874
875To clear an already-set proxy, use C<undef>.
876
877=item $date = AnyEvent::HTTP::format_date $timestamp
878
879Takes a POSIX timestamp (seconds since the epoch) and formats it as a HTTP
880Date (RFC 2616).
881
882=item $timestamp = AnyEvent::HTTP::parse_date $date
883
884Takes a HTTP Date (RFC 2616) and returns the corresponding POSIX
885timestamp, or C<undef> if the date cannot be parsed.
303 886
304=item $AnyEvent::HTTP::MAX_RECURSE 887=item $AnyEvent::HTTP::MAX_RECURSE
305 888
306The default value for the C<recurse> request parameter (default: C<10>). 889The default value for the C<recurse> request parameter (default: C<10>).
307 890
308=item $AnyEvent::HTTP::USERAGENT 891=item $AnyEvent::HTTP::USERAGENT
309 892
310The default value for the C<User-Agent> header (the default is 893The default value for the C<User-Agent> header (the default is
311C<Mozilla/5.0 (compatible; AnyEvent::HTTP/$VERSION; +http://software.schmorp.de/pkg/AnyEvent)>). 894C<Mozilla/5.0 (compatible; U; AnyEvent-HTTP/$VERSION; +http://software.schmorp.de/pkg/AnyEvent)>).
312 895
313=item $AnyEvent::HTTP::MAX_PERSISTENT 896=item $AnyEvent::HTTP::MAX_PER_HOST
314 897
315The maximum number of persistent connections to keep open (default: 8). 898The maximum number of concurrent connections to the same host (identified
899by the hostname). If the limit is exceeded, then the additional requests
900are queued until previous connections are closed.
316 901
317Not implemented currently. 902The default value for this is C<4>, and it is highly advisable to not
903increase it.
318 904
319=item $AnyEvent::HTTP::PERSISTENT_TIMEOUT 905=item $AnyEvent::HTTP::ACTIVE
320 906
321The maximum time to cache a persistent connection, in seconds (default: 2). 907The number of active connections. This is not the number of currently
322 908running requests, but the number of currently open and non-idle TCP
323Not implemented currently. 909connections. This number of can be useful for load-leveling.
324 910
325=back 911=back
326 912
327=cut 913=cut
328 914
915our @month = qw(Jan Feb Mar Apr May Jun Jul Aug Sep Oct Nov Dec);
916our @weekday = qw(Sun Mon Tue Wed Thu Fri Sat);
917
918sub format_date($) {
919 my ($time) = @_;
920
921 # RFC 822/1123 format
922 my ($S, $M, $H, $mday, $mon, $year, $wday, $yday, undef) = gmtime $time;
923
924 sprintf "%s, %02d %s %04d %02d:%02d:%02d GMT",
925 $weekday[$wday], $mday, $month[$mon], $year + 1900,
926 $H, $M, $S;
927}
928
929sub parse_date($) {
930 my ($date) = @_;
931
932 my ($d, $m, $y, $H, $M, $S);
933
934 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$/) {
935 # RFC 822/1123, required by RFC 2616
936 ($d, $m, $y, $H, $M, $S) = ($1, $2, $3, $4, $5, $6);
937
938 } 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$/) {
939 # RFC 850
940 ($d, $m, $y, $H, $M, $S) = ($1, $2, $3 < 69 ? $3 + 2000 : $3 + 1900, $4, $5, $6);
941
942 } 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])$/) {
943 # ISO C's asctime
944 ($d, $m, $y, $H, $M, $S) = ($2, $1, $6, $3, $4, $5);
945 }
946 # other formats fail in the loop below
947
948 for (0..11) {
949 if ($m eq $month[$_]) {
950 require Time::Local;
951 return Time::Local::timegm ($S, $M, $H, $d, $_, $y);
952 }
953 }
954
955 undef
956}
957
329sub set_proxy($) { 958sub set_proxy($) {
959 if (length $_[0]) {
330 $PROXY = [$2, $3 || 3128, $1] if $_[0] =~ m%^(https?):// ([^:/]+) (?: : (\d*) )?%ix; 960 $_[0] =~ m%^(https?):// ([^:/]+) (?: : (\d*) )?%ix
961 or Carp::croak "$_[0]: invalid proxy URL";
962 $PROXY = [$2, $3 || 3128, $1]
963 } else {
964 undef $PROXY;
965 }
331} 966}
332 967
333# initialise proxy from environment 968# initialise proxy from environment
969eval {
334set_proxy $ENV{http_proxy}; 970 set_proxy $ENV{http_proxy};
971};
972
973=head2 SOCKS PROXIES
974
975Socks proxies are not directly supported by AnyEvent::HTTP. You can
976compile your perl to support socks, or use an external program such as
977F<socksify> (dante) or F<tsocks> to make your program use a socks proxy
978transparently.
979
980Alternatively, for AnyEvent::HTTP only, you can use your own
981C<tcp_connect> function that does the proxy handshake - here is an example
982that works with socks4a proxies:
983
984 use Errno;
985 use AnyEvent::Util;
986 use AnyEvent::Socket;
987 use AnyEvent::Handle;
988
989 # host, port and username of/for your socks4a proxy
990 my $socks_host = "10.0.0.23";
991 my $socks_port = 9050;
992 my $socks_user = "";
993
994 sub socks4a_connect {
995 my ($host, $port, $connect_cb, $prepare_cb) = @_;
996
997 my $hdl = new AnyEvent::Handle
998 connect => [$socks_host, $socks_port],
999 on_prepare => sub { $prepare_cb->($_[0]{fh}) },
1000 on_error => sub { $connect_cb->() },
1001 ;
1002
1003 $hdl->push_write (pack "CCnNZ*Z*", 4, 1, $port, 1, $socks_user, $host);
1004
1005 $hdl->push_read (chunk => 8, sub {
1006 my ($hdl, $chunk) = @_;
1007 my ($status, $port, $ipn) = unpack "xCna4", $chunk;
1008
1009 if ($status == 0x5a) {
1010 $connect_cb->($hdl->{fh}, (format_address $ipn) . ":$port");
1011 } else {
1012 $! = Errno::ENXIO; $connect_cb->();
1013 }
1014 });
1015
1016 $hdl
1017 }
1018
1019Use C<socks4a_connect> instead of C<tcp_connect> when doing C<http_request>s,
1020possibly after switching off other proxy types:
1021
1022 AnyEvent::HTTP::set_proxy undef; # usually you do not want other proxies
1023
1024 http_get 'http://www.google.com', tcp_connect => \&socks4a_connect, sub {
1025 my ($data, $headers) = @_;
1026 ...
1027 };
335 1028
336=head1 SEE ALSO 1029=head1 SEE ALSO
337 1030
338L<AnyEvent>. 1031L<AnyEvent>.
339 1032
340=head1 AUTHOR 1033=head1 AUTHOR
341 1034
342 Marc Lehmann <schmorp@schmorp.de> 1035 Marc Lehmann <schmorp@schmorp.de>
343 http://home.schmorp.de/ 1036 http://home.schmorp.de/
1037
1038With many thanks to Дмитрий Шалашов, who provided countless
1039testcases and bugreports.
344 1040
345=cut 1041=cut
346 1042
3471 10431
348 1044

Diff Legend

Removed lines
+ Added lines
< Changed lines
> Changed lines