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.10 by root, Thu Jun 5 13:06:43 2008 UTC vs.
Revision 1.65 by root, Fri Dec 31 03:47:32 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
57=item http_head $url, key => value..., $cb->($data, $headers) 77=item http_head $url, key => value..., $cb->($data, $headers)
58 78
59Executes an HTTP-HEAD request. See the http_request function for details on 79Executes an HTTP-HEAD request. See the http_request function for details
60additional parameters. 80on additional parameters and the return value.
61 81
62=item http_post $url, $body, key => value..., $cb->($data, $headers) 82=item http_post $url, $body, key => value..., $cb->($data, $headers)
63 83
64Executes an HTTP-POST request with a request body of C<$bod>. See the 84Executes an HTTP-POST request with a request body of C<$body>. See the
65http_request function for details on additional parameters. 85http_request function for details on additional parameters and the return
86value.
66 87
67=item http_request $method => $url, key => value..., $cb->($data, $headers) 88=item http_request $method => $url, key => value..., $cb->($data, $headers)
68 89
69Executes 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
70must be an absolute http or https URL. 91must be an absolute http or https URL.
71 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
72The callback will be called with the response data as first argument 98The callback will be called with the response body data as first argument
73(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
74response headers as second argument. 100second argument.
75 101
76All 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
77headers, the three "pseudo-headers" C<HTTPVersion>, C<Status> and 103headers, the "pseudo-headers" (uppercase to avoid clashing with possible
78C<Reason> contain the three parts of the HTTP Status-Line of the same 104response headers) C<HTTPVersion>, C<Status> and C<Reason> contain 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
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
79name. If the server sends a header multiple lines, then their contents 123If the server sends a header multiple times, then their contents will be
80will be joined together with C<\x00>. 124joined together with a comma (C<,>), as per the HTTP spec.
81 125
82If 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,
83then 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>
84and 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.
85 130
86A typical callback might look like this: 131A typical callback might look like this:
87 132
88 sub { 133 sub {
89 my ($body, $hdr) = @_; 134 my ($body, $hdr) = @_;
105Whether to recurse requests or not, e.g. on redirects, authentication 150Whether to recurse requests or not, e.g. on redirects, authentication
106retries and so on, and how often to do so. 151retries and so on, and how often to do so.
107 152
108=item headers => hashref 153=item headers => hashref
109 154
110The 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).
111 160
112=item timeout => $seconds 161=item timeout => $seconds
113 162
114The 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
115the 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.
116 168
117=item proxy => [$host, $port[, $scheme]] or undef 169=item proxy => [$host, $port[, $scheme]] or undef
118 170
119Use 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
120default proxy (as specified by C<$ENV{http_proxy}>) is used. 172default proxy (as specified by C<$ENV{http_proxy}>) is used.
121 173
122C<$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
123HTTPS. 175HTTPS.
124 176
125=item body => $string 177=item body => $string
126 178
127The 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
133based on the original netscape specification. 185based on the original netscape specification.
134 186
135The 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
136get updated automatically. It is possible to save the cookie_jar to 188get updated automatically. It is possible to save the cookie_jar to
137persistent storage with something like JSON or Storable, but this is not 189persistent storage with something like JSON or Storable, but this is not
138recommended, as expire times are currently being ignored. 190recommended, as expiry times are currently being ignored.
139 191
140Note that this cookie implementation is not of very high quality, nor 192Note that this cookie implementation is not of very high quality, nor
141meant 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
142do 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
143cookie-using sites working. Cookies are a privacy disaster, do not use 195cookie-using sites working. Cookies are a privacy disaster, do not use
144them 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.
145 292
146=back 293=back
147 294
148Example: make a simple HTTP GET request for http://www.nethype.de/ 295Example: make a simple HTTP GET request for http://www.nethype.de/
149 296
163 use Data::Dumper; 310 use Data::Dumper;
164 print Dumper $hdr; 311 print Dumper $hdr;
165 } 312 }
166 ; 313 ;
167 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;
324
168=cut 325=cut
169 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
357our $qr_nlnl = qr{(?<![^\012])\015?\012};
358
359our $TLS_CTX_LOW = { cache => 1, sslv2 => 1 };
360our $TLS_CTX_HIGH = { cache => 1, verify => 1, verify_peername => "https" };
361
170sub http_request($$$;@) { 362sub http_request($$@) {
171 my $cb = pop; 363 my $cb = pop;
172 my ($method, $url, %arg) = @_; 364 my ($method, $url, %arg) = @_;
173 365
174 my %hdr; 366 my %hdr;
367
368 $arg{tls_ctx} = $TLS_CTX_LOW if $arg{tls_ctx} eq "low" || !exists $arg{tls_ctx};
369 $arg{tls_ctx} = $TLS_CTX_HIGH if $arg{tls_ctx} eq "high";
175 370
176 $method = uc $method; 371 $method = uc $method;
177 372
178 if (my $hdr = $arg{headers}) { 373 if (my $hdr = $arg{headers}) {
179 while (my ($k, $v) = each %$hdr) { 374 while (my ($k, $v) = each %$hdr) {
180 $hdr{lc $k} = $v; 375 $hdr{lc $k} = $v;
181 } 376 }
182 } 377 }
183 378
379 # pseudo headers for all subsequent responses
380 my @pseudo = (URL => $url);
381 push @pseudo, Redirect => delete $arg{Redirect} if exists $arg{Redirect};
382
184 my $recurse = exists $arg{recurse} ? $arg{recurse} : $MAX_RECURSE; 383 my $recurse = exists $arg{recurse} ? delete $arg{recurse} : $MAX_RECURSE;
185 384
186 return $cb->(undef, { Status => 599, Reason => "recursion limit reached" }) 385 return $cb->(undef, { @pseudo, Status => 599, Reason => "Too many redirections" })
187 if $recurse < 0; 386 if $recurse < 0;
188 387
189 my $proxy = $arg{proxy} || $PROXY; 388 my $proxy = $arg{proxy} || $PROXY;
190 my $timeout = $arg{timeout} || $TIMEOUT; 389 my $timeout = $arg{timeout} || $TIMEOUT;
191 390
192 $hdr{"user-agent"} ||= $USERAGENT;
193
194 my ($scheme, $authority, $upath, $query, $fragment) = 391 my ($uscheme, $uauthority, $upath, $query, $fragment) =
195 $url =~ m|(?:([^:/?#]+):)?(?://([^/?#]*))?([^?#]*)(?:\?([^#]*))?(?:#(.*))?|; 392 $url =~ m|(?:([^:/?#]+):)?(?://([^/?#]*))?([^?#]*)(?:(\?[^#]*))?(?:#(.*))?|;
196 393
197 $scheme = lc $scheme; 394 $uscheme = lc $uscheme;
198 395
199 my $uport = $scheme eq "http" ? 80 396 my $uport = $uscheme eq "http" ? 80
200 : $scheme eq "https" ? 443 397 : $uscheme eq "https" ? 443
201 : return $cb->(undef, { Status => 599, Reason => "only http and https URL schemes supported" }); 398 : return $cb->(undef, { @pseudo, Status => 599, Reason => "Only http and https URL schemes supported" });
202 399
203 $authority =~ /^(?: .*\@ )? ([^\@:]+) (?: : (\d+) )?$/x 400 $uauthority =~ /^(?: .*\@ )? ([^\@:]+) (?: : (\d+) )?$/x
204 or return $cb->(undef, { Status => 599, Reason => "unparsable URL" }); 401 or return $cb->(undef, { @pseudo, Status => 599, Reason => "Unparsable URL" });
205 402
206 my $uhost = $1; 403 my $uhost = $1;
207 $uport = $2 if defined $2; 404 $uport = $2 if defined $2;
208 405
406 $hdr{host} = defined $2 ? "$uhost:$2" : "$uhost"
407 unless exists $hdr{host};
408
209 $uhost =~ s/^\[(.*)\]$/$1/; 409 $uhost =~ s/^\[(.*)\]$/$1/;
210 $upath .= "?$query" if length $query; 410 $upath .= $query if length $query;
211 411
212 $upath =~ s%^/?%/%; 412 $upath =~ s%^/?%/%;
213 413
214 # cookie processing 414 # cookie processing
215 if (my $jar = $arg{cookie_jar}) { 415 if (my $jar = $arg{cookie_jar}) {
216 %$jar = () if $jar->{version} < 1; 416 %$jar = () if $jar->{version} != 1;
217 417
218 my @cookie; 418 my @cookie;
219 419
220 while (my ($chost, $v) = each %$jar) { 420 while (my ($chost, $v) = each %$jar) {
421 if ($chost =~ /^\./) {
221 next unless $chost eq substr $uhost, -length $chost; 422 next unless $chost eq substr $uhost, -length $chost;
222 next unless $chost =~ /^\./; 423 } elsif ($chost =~ /\./) {
424 next unless $chost eq $uhost;
425 } else {
426 next;
427 }
223 428
224 while (my ($cpath, $v) = each %$v) { 429 while (my ($cpath, $v) = each %$v) {
225 next unless $cpath eq substr $upath, 0, length $cpath; 430 next unless $cpath eq substr $upath, 0, length $cpath;
226 431
227 while (my ($k, $v) = each %$v) { 432 while (my ($k, $v) = each %$v) {
228 next if $scheme ne "https" && exists $v->{secure}; 433 next if $uscheme ne "https" && exists $v->{secure};
434 my $value = $v->{value};
435 $value =~ s/([\\"])/\\$1/g;
229 push @cookie, "$k=$v->{value}"; 436 push @cookie, "$k=\"$value\"";
230 } 437 }
231 } 438 }
232 } 439 }
233 440
234 $hdr{cookie} = join "; ", @cookie 441 $hdr{cookie} = join "; ", @cookie
235 if @cookie; 442 if @cookie;
236 } 443 }
237 444
238 my ($rhost, $rport, $rpath); # request host, port, path 445 my ($rhost, $rport, $rscheme, $rpath); # request host, port, path
239 446
240 if ($proxy) { 447 if ($proxy) {
241 ($rhost, $rport, $scheme) = @$proxy; 448 ($rpath, $rhost, $rport, $rscheme) = ($url, @$proxy);
242 $rpath = $url; 449
450 $rscheme = "http" unless defined $rscheme;
451
452 # don't support https requests over https-proxy transport,
453 # can't be done with tls as spec'ed, unless you double-encrypt.
454 $rscheme = "http" if $uscheme eq "https" && $rscheme eq "https";
243 } else { 455 } else {
244 ($rhost, $rport, $rpath) = ($uhost, $uport, $upath); 456 ($rhost, $rport, $rscheme, $rpath) = ($uhost, $uport, $uscheme, $upath);
245 $hdr{host} = $uhost;
246 } 457 }
247 458
459 # leave out fragment and query string, just a heuristic
460 $hdr{referer} ||= "$uscheme://$uauthority$upath" unless exists $hdr{referer};
461 $hdr{"user-agent"} ||= $USERAGENT unless exists $hdr{"user-agent"};
462
248 $hdr{"content-length"} = length $arg{body}; 463 $hdr{"content-length"} = length $arg{body}
464 if length $arg{body} || $method ne "GET";
249 465
250 my %state; 466 my %state = (connect_guard => 1);
251 467
252 $state{connect_guard} = AnyEvent::Socket::tcp_connect $rhost, $rport, sub { 468 _get_slot $uhost, sub {
469 $state{slot_guard} = shift;
470
471 return unless $state{connect_guard};
472
473 my $connect_cb = sub {
253 $state{fh} = shift 474 $state{fh} = shift
254 or return $cb->(undef, { Status => 599, Reason => "$!" });
255
256 delete $state{connect_guard}; # reduce memory usage, save a tree
257
258 # get handle
259 $state{handle} = new AnyEvent::Handle
260 fh => $state{fh},
261 ($scheme eq "https" ? (tls => "connect") : ());
262
263 # limit the number of persistent connections
264 if ($KA_COUNT{$_[1]} < $MAX_PERSISTENT_PER_HOST) {
265 ++$KA_COUNT{$_[1]};
266 $state{handle}{ka_count_guard} = AnyEvent::Util::guard { --$KA_COUNT{$_[1]} };
267 $hdr{connection} = "keep-alive";
268 delete $hdr{connection}; # keep-alive not yet supported
269 } else {
270 delete $hdr{connection};
271 }
272
273 # (re-)configure handle
274 $state{handle}->timeout ($timeout);
275 $state{handle}->on_error (sub {
276 %state = ();
277 $cb->(undef, { Status => 599, Reason => "$!" });
278 });
279 $state{handle}->on_eof (sub {
280 %state = ();
281 $cb->(undef, { Status => 599, Reason => "unexpected end-of-file" });
282 });
283
284 # send request
285 $state{handle}->push_write (
286 "$method $rpath HTTP/1.0\015\012"
287 . (join "", map "$_: $hdr{$_}\015\012", keys %hdr)
288 . "\015\012"
289 . (delete $arg{body})
290 );
291
292 %hdr = (); # reduce memory usage, save a kitten
293
294 # status line
295 $state{handle}->push_read (line => qr/\015?\012/, sub {
296 $_[1] =~ /^HTTP\/([0-9\.]+) \s+ ([0-9]{3}) \s+ ([^\015\012]+)/ix
297 or return (%state = (), $cb->(undef, { Status => 599, Reason => "invalid server response ($_[1])" }));
298
299 my %hdr = ( # response headers
300 HTTPVersion => "\x00$1",
301 Status => "\x00$2",
302 Reason => "\x00$3",
303 );
304
305 # headers, could be optimized a bit
306 $state{handle}->unshift_read (line => qr/\015?\012\015?\012/, sub {
307 for ("$_[1]\012") {
308 # we support spaces in field names, as lotus domino
309 # creates them.
310 $hdr{lc $1} .= "\x00$2"
311 while /\G
312 ([^:\000-\037]+):
313 [\011\040]*
314 ((?: [^\015\012]+ | \015?\012[\011\040] )*)
315 \015?\012
316 /gxc;
317
318 /\G$/
319 or return (%state = (), $cb->(undef, { Status => 599, Reason => "garbled response headers" }));
320 } 475 or do {
321 476 my $err = "$!";
322 substr $_, 0, 1, ""
323 for values %hdr;
324
325 my $finish = sub {
326 %state = (); 477 %state = ();
478 return $cb->(undef, { @pseudo, Status => 599, Reason => $err });
479 };
327 480
328 # set-cookie processing 481 pop; # free memory, save a tree
329 if ($arg{cookie_jar} && exists $hdr{"set-cookie"}) { 482
330 for (split /\x00/, $hdr{"set-cookie"}) { 483 return unless delete $state{connect_guard};
331 my ($cookie, @arg) = split /;\s*/; 484
332 my ($name, $value) = split /=/, $cookie, 2; 485 # get handle
333 my %kv = (value => $value, map { split /=/, $_, 2 } @arg); 486 $state{handle} = new AnyEvent::Handle
334 487 fh => $state{fh},
335 my $cdom = (delete $kv{domain}) || $uhost; 488 peername => $rhost,
336 my $cpath = (delete $kv{path}) || "/"; 489 tls_ctx => $arg{tls_ctx},
337 490 # these need to be reconfigured on keepalive handles
338 $cdom =~ s/^.?/./; # make sure it starts with a "." 491 timeout => $timeout,
339 492 on_error => sub {
340 my $ndots = $cdom =~ y/.//; 493 %state = ();
341 next if $ndots < ($cdom =~ /[^.]{3}$/ ? 2 : 3); 494 $cb->(undef, { @pseudo, Status => 599, Reason => $_[2] });
342 495 },
496 on_eof => sub {
497 %state = ();
498 $cb->(undef, { @pseudo, Status => 599, Reason => "Unexpected end-of-file" });
499 },
500 ;
501
502 # limit the number of persistent connections
503 # keepalive not yet supported
504# if ($KA_COUNT{$_[1]} < $MAX_PERSISTENT_PER_HOST) {
505# ++$KA_COUNT{$_[1]};
506# $state{handle}{ka_count_guard} = AnyEvent::Util::guard {
507# --$KA_COUNT{$_[1]}
508# };
509# $hdr{connection} = "keep-alive";
510# } else {
511 delete $hdr{connection};
512# }
513
514 $state{handle}->starttls ("connect") if $rscheme eq "https";
515
516 # handle actual, non-tunneled, request
517 my $handle_actual_request = sub {
518 $state{handle}->starttls ("connect") if $uscheme eq "https" && !exists $state{handle}{tls};
519
520 # send request
521 $state{handle}->push_write (
522 "$method $rpath HTTP/1.0\015\012"
523 . (join "", map "\u$_: $hdr{$_}\015\012", grep defined $hdr{$_}, keys %hdr)
524 . "\015\012"
525 . (delete $arg{body})
526 );
527
528 # return if error occured during push_write()
529 return unless %state;
530
531 %hdr = (); # reduce memory usage, save a kitten, also make it possible to re-use
532
533 # status line and headers
534 $state{handle}->push_read (line => $qr_nlnl, sub {
535 my $keepalive = pop;
536
537 for ("$_[1]") {
538 y/\015//d; # weed out any \015, as they show up in the weirdest of places.
539
540 /^HTTP\/([0-9\.]+) \s+ ([0-9]{3}) (?: \s+ ([^\015\012]*) )? \015?\012/igxc
541 or return (%state = (), $cb->(undef, { @pseudo, Status => 599, Reason => "Invalid server response" }));
542
543 push @pseudo,
544 HTTPVersion => $1,
545 Status => $2,
546 Reason => $3,
547 ;
548
549 # things seen, not parsed:
550 # p3pP="NON CUR OTPi OUR NOR UNI"
551
552 $hdr{lc $1} .= ",$2"
553 while /\G
554 ([^:\000-\037]*):
555 [\011\040]*
556 ((?: [^\012]+ | \012[\011\040] )*)
557 \012
558 /gxc;
559
560 /\G$/
561 or return (%state = (), $cb->(undef, { @pseudo, Status => 599, Reason => "Garbled response headers" }));
562 }
563
564 # remove the "," prefix we added to all headers above
565 substr $_, 0, 1, ""
566 for values %hdr;
567
568 # patch in all pseudo headers
569 %hdr = (%hdr, @pseudo);
570
571 # redirect handling
572 # microsoft and other shitheads don't give a shit for following standards,
573 # try to support some common forms of broken Location headers.
574 if ($hdr{location} !~ /^(?: $ | [^:\/?\#]+ : )/x) {
575 $hdr{location} =~ s/^\.\/+//;
576
577 my $url = "$rscheme://$uhost:$uport";
578
579 unless ($hdr{location} =~ s/^\///) {
580 $url .= $upath;
581 $url =~ s/\/[^\/]*$//;
582 }
583
584 $hdr{location} = "$url/$hdr{location}";
585 }
586
587 my $redirect;
588
589 if ($recurse) {
590 my $status = $hdr{Status};
591
592 # industry standard is to redirect POST as GET for
593 # 301, 302 and 303, in contrast to http/1.0 and 1.1.
594 # also, the UA should ask the user for 301 and 307 and POST,
595 # industry standard seems to be to simply follow.
596 # we go with the industry standard.
597 if ($status == 301 or $status == 302 or $status == 303) {
598 # HTTP/1.1 is unclear on how to mutate the method
599 $method = "GET" unless $method eq "HEAD";
343 # store it 600 $redirect = 1;
344 $arg{cookie_jar}{version} = 1; 601 } elsif ($status == 307) {
345 $arg{cookie_jar}{$cdom}{$cpath}{$name} = \%kv; 602 $redirect = 1;
346 } 603 }
347 } 604 }
348 605
349 if ($_[1]{Status} =~ /^x30[12]$/ && $recurse) { 606 my $finish = sub { # ($data, $err_status, $err_reason[, $keepalive])
350 # microsoft and other assholes don't give a shit for following standards, 607 $state{handle}->destroy if $state{handle};
351 # try to support a common form of broken Location header. 608 %state = ();
352 $_[1]{location} =~ s%^/%$scheme://$uhost:$uport/%;
353 609
354 http_request ($method, $_[1]{location}, %arg, recurse => $recurse - 1, $cb); 610 if (defined $_[1]) {
611 $hdr{OrigStatus} = $hdr{Status}; $hdr{Status} = $_[1];
612 $hdr{OrigReason} = $hdr{Reason}; $hdr{Reason} = $_[2];
613 }
614
615 # set-cookie processing
616 if ($arg{cookie_jar}) {
617 for ($hdr{"set-cookie"}) {
618 # parse NAME=VALUE
619 my @kv;
620
621 while (/\G\s* ([^=;,[:space:]]+) \s*=\s* (?: "((?:[^\\"]+|\\.)*)" | ([^=;,[:space:]]*) )/gcxs) {
622 my $name = $1;
623 my $value = $3;
624
625 unless ($value) {
626 $value = $2;
627 $value =~ s/\\(.)/$1/gs;
628 }
629
630 push @kv, $name => $value;
631
632 last unless /\G\s*;/gc;
633 }
634
635 last unless @kv;
636
637 my $name = shift @kv;
638 my %kv = (value => shift @kv, @kv);
639
640 my $cdom;
641 my $cpath = (delete $kv{path}) || "/";
642
643 if (exists $kv{domain}) {
644 $cdom = delete $kv{domain};
645
646 $cdom =~ s/^\.?/./; # make sure it starts with a "."
647
648 next if $cdom =~ /\.$/;
649
650 # this is not rfc-like and not netscape-like. go figure.
651 my $ndots = $cdom =~ y/.//;
652 next if $ndots < ($cdom =~ /\.[^.][^.]\.[^.][^.]$/ ? 3 : 2);
653 } else {
654 $cdom = $uhost;
655 }
656
657 # store it
658 $arg{cookie_jar}{version} = 1;
659 $arg{cookie_jar}{$cdom}{$cpath}{$name} = \%kv;
660
661 redo if /\G\s*,/gc;
662 }
663 }
664
665 if ($redirect && exists $hdr{location}) {
666 # we ignore any errors, as it is very common to receive
667 # Content-Length != 0 but no actual body
668 # we also access %hdr, as $_[1] might be an erro
669 http_request (
670 $method => $hdr{location},
671 %arg,
672 recurse => $recurse - 1,
673 Redirect => [$_[0], \%hdr],
674 $cb);
675 } else {
676 $cb->($_[0], \%hdr);
677 }
678 };
679
680 my $len = $hdr{"content-length"};
681
682 if (!$redirect && $arg{on_header} && !$arg{on_header}(\%hdr)) {
683 $finish->(undef, 598 => "Request cancelled by on_header");
684 } elsif (
685 $hdr{Status} =~ /^(?:1..|204|205|304)$/
686 or $method eq "HEAD"
687 or (defined $len && !$len)
688 ) {
689 # no body
690 $finish->("", undef, undef, 1);
355 } else { 691 } else {
356 $cb->($_[0], $_[1]); 692 # body handling, four different code paths
693 # for want_body_handle, on_body (2x), normal (2x)
694 # we might read too much here, but it does not matter yet (no pipelining)
695 if (!$redirect && $arg{want_body_handle}) {
696 $_[0]->on_eof (undef);
697 $_[0]->on_error (undef);
698 $_[0]->on_read (undef);
699
700 $finish->(delete $state{handle});
701
702 } elsif ($arg{on_body}) {
703 $_[0]->on_error (sub { $finish->(undef, 599 => $_[2]) });
704 if ($len) {
705 $_[0]->on_read (sub {
706 $len -= length $_[0]{rbuf};
707
708 $arg{on_body}(delete $_[0]{rbuf}, \%hdr)
709 or $finish->(undef, 598 => "Request cancelled by on_body");
710
711 $len > 0
712 or $finish->("", undef, undef, 1);
713 });
714 } else {
715 $_[0]->on_eof (sub {
716 $finish->("");
717 });
718 $_[0]->on_read (sub {
719 $arg{on_body}(delete $_[0]{rbuf}, \%hdr)
720 or $finish->(undef, 598 => "Request cancelled by on_body");
721 });
722 }
723 } else {
724 $_[0]->on_eof (undef);
725
726 if ($len) {
727 $_[0]->on_error (sub { $finish->(undef, 599 => $_[2]) });
728 $_[0]->on_read (sub {
729 $finish->((substr delete $_[0]{rbuf}, 0, $len, ""), undef, undef, 1)
730 if $len <= length $_[0]{rbuf};
731 });
732 } else {
733 $_[0]->on_error (sub {
734 ($! == Errno::EPIPE || !$!)
735 ? $finish->(delete $_[0]{rbuf})
736 : $finish->(undef, 599 => $_[2]);
737 });
738 $_[0]->on_read (sub { });
739 }
740 }
357 } 741 }
358 }; 742 });
743 };
359 744
360 if ($hdr{Status} =~ /^(?:1..|204|304)$/ or $method eq "HEAD") { 745 # now handle proxy-CONNECT method
361 $finish->(undef, \%hdr); 746 if ($proxy && $uscheme eq "https") {
362 } else { 747 # oh dear, we have to wrap it into a connect request
363 if (exists $hdr{"content-length"}) {
364 $_[0]->unshift_read (chunk => $hdr{"content-length"}, sub {
365 # could cache persistent connection now
366 if ($hdr{connection} =~ /\bkeep-alive\b/i) {
367 # but we don't, due to misdesigns, this is annoyingly complex
368 };
369 748
370 $finish->($_[1], \%hdr); 749 # maybe re-use $uauthority with patched port?
371 }); 750 $state{handle}->push_write ("CONNECT $uhost:$uport HTTP/1.0\015\012Host: $uhost\015\012\015\012");
751 $state{handle}->push_read (line => $qr_nlnl, sub {
752 $_[1] =~ /^HTTP\/([0-9\.]+) \s+ ([0-9]{3}) (?: \s+ ([^\015\012]*) )?/ix
753 or return (%state = (), $cb->(undef, { @pseudo, Status => 599, Reason => "Invalid proxy connect response ($_[1])" }));
754
755 if ($2 == 200) {
756 $rpath = $upath;
757 &$handle_actual_request;
372 } else { 758 } else {
373 # too bad, need to read until we get an error or EOF,
374 # no way to detect winged data.
375 $_[0]->on_error (sub {
376 $finish->($_[0]{rbuf}, \%hdr);
377 }); 759 %state = ();
378 $_[0]->on_eof (undef); 760 $cb->(undef, { @pseudo, Status => $2, Reason => $3 });
379 $_[0]->on_read (sub { });
380 } 761 }
381 } 762 });
763 } else {
764 &$handle_actual_request;
382 }); 765 }
383 }); 766 };
384 }, sub { 767
385 $timeout 768 my $tcp_connect = $arg{tcp_connect}
769 || do { require AnyEvent::Socket; \&AnyEvent::Socket::tcp_connect };
770
771 $state{connect_guard} = $tcp_connect->($rhost, $rport, $connect_cb, $arg{on_prepare} || sub { $timeout });
772
386 }; 773 };
387 774
388 defined wantarray && AnyEvent::Util::guard { %state = () } 775 defined wantarray && AnyEvent::Util::guard { %state = () }
389} 776}
390 777
391sub http_get($$;@) { 778sub http_get($@) {
392 unshift @_, "GET"; 779 unshift @_, "GET";
393 &http_request 780 &http_request
394} 781}
395 782
396sub http_head($$;@) { 783sub http_head($@) {
397 unshift @_, "HEAD"; 784 unshift @_, "HEAD";
398 &http_request 785 &http_request
399} 786}
400 787
401sub http_post($$$;@) { 788sub http_post($$@) {
789 my $url = shift;
402 unshift @_, "POST", "body"; 790 unshift @_, "POST", $url, "body";
403 &http_request 791 &http_request
404} 792}
405 793
406=back 794=back
407 795
796=head2 DNS CACHING
797
798AnyEvent::HTTP uses the AnyEvent::Socket::tcp_connect function for
799the actual connection, which in turn uses AnyEvent::DNS to resolve
800hostnames. The latter is a simple stub resolver and does no caching
801on its own. If you want DNS caching, you currently have to provide
802your own default resolver (by storing a suitable resolver object in
803C<$AnyEvent::DNS::RESOLVER>).
804
408=head2 GLOBAL FUNCTIONS AND VARIABLES 805=head2 GLOBAL FUNCTIONS AND VARIABLES
409 806
410=over 4 807=over 4
411 808
412=item AnyEvent::HTTP::set_proxy "proxy-url" 809=item AnyEvent::HTTP::set_proxy "proxy-url"
413 810
414Sets the default proxy server to use. The proxy-url must begin with a 811Sets the default proxy server to use. The proxy-url must begin with a
415string of the form C<http://host:port> (optionally C<https:...>). 812string of the form C<http://host:port> (optionally C<https:...>), croaks
813otherwise.
814
815To clear an already-set proxy, use C<undef>.
816
817=item $date = AnyEvent::HTTP::format_date $timestamp
818
819Takes a POSIX timestamp (seconds since the epoch) and formats it as a HTTP
820Date (RFC 2616).
821
822=item $timestamp = AnyEvent::HTTP::parse_date $date
823
824Takes a HTTP Date (RFC 2616) and returns the corresponding POSIX
825timestamp, or C<undef> if the date cannot be parsed.
416 826
417=item $AnyEvent::HTTP::MAX_RECURSE 827=item $AnyEvent::HTTP::MAX_RECURSE
418 828
419The default value for the C<recurse> request parameter (default: C<10>). 829The default value for the C<recurse> request parameter (default: C<10>).
420 830
421=item $AnyEvent::HTTP::USERAGENT 831=item $AnyEvent::HTTP::USERAGENT
422 832
423The default value for the C<User-Agent> header (the default is 833The default value for the C<User-Agent> header (the default is
424C<Mozilla/5.0 (compatible; AnyEvent::HTTP/$VERSION; +http://software.schmorp.de/pkg/AnyEvent)>). 834C<Mozilla/5.0 (compatible; U; AnyEvent-HTTP/$VERSION; +http://software.schmorp.de/pkg/AnyEvent)>).
425 835
426=item $AnyEvent::HTTP::MAX_PERSISTENT 836=item $AnyEvent::HTTP::MAX_PER_HOST
427 837
428The maximum number of persistent connections to keep open (default: 8). 838The maximum number of concurrent connections to the same host (identified
839by the hostname). If the limit is exceeded, then the additional requests
840are queued until previous connections are closed.
429 841
430Not implemented currently. 842The default value for this is C<4>, and it is highly advisable to not
843increase it.
431 844
432=item $AnyEvent::HTTP::PERSISTENT_TIMEOUT 845=item $AnyEvent::HTTP::ACTIVE
433 846
434The maximum time to cache a persistent connection, in seconds (default: 2). 847The number of active connections. This is not the number of currently
435 848running requests, but the number of currently open and non-idle TCP
436Not implemented currently. 849connections. This number of can be useful for load-leveling.
437 850
438=back 851=back
439 852
440=cut 853=cut
441 854
855our @month = qw(Jan Feb Mar Apr May Jun Jul Aug Sep Oct Nov Dec);
856our @weekday = qw(Sun Mon Tue Wed Thu Fri Sat);
857
858sub format_date($) {
859 my ($time) = @_;
860
861 # RFC 822/1123 format
862 my ($S, $M, $H, $mday, $mon, $year, $wday, $yday, undef) = gmtime $time;
863
864 sprintf "%s, %02d %s %04d %02d:%02d:%02d GMT",
865 $weekday[$wday], $mday, $month[$mon], $year + 1900,
866 $H, $M, $S;
867}
868
869sub parse_date($) {
870 my ($date) = @_;
871
872 my ($d, $m, $y, $H, $M, $S);
873
874 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$/) {
875 # RFC 822/1123, required by RFC 2616
876 ($d, $m, $y, $H, $M, $S) = ($1, $2, $3, $4, $5, $6);
877
878 } 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$/) {
879 # RFC 850
880 ($d, $m, $y, $H, $M, $S) = ($1, $2, $3 < 69 ? $3 + 2000 : $3 + 1900, $4, $5, $6);
881
882 } 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])$/) {
883 # ISO C's asctime
884 ($d, $m, $y, $H, $M, $S) = ($2, $1, $6, $3, $4, $5);
885 }
886 # other formats fail in the loop below
887
888 for (0..11) {
889 if ($m eq $month[$_]) {
890 require Time::Local;
891 return Time::Local::timegm ($S, $M, $H, $d, $_, $y);
892 }
893 }
894
895 undef
896}
897
442sub set_proxy($) { 898sub set_proxy($) {
899 if (length $_[0]) {
443 $PROXY = [$2, $3 || 3128, $1] if $_[0] =~ m%^(https?):// ([^:/]+) (?: : (\d*) )?%ix; 900 $_[0] =~ m%^(https?):// ([^:/]+) (?: : (\d*) )?%ix
901 or Carp::croak "$_[0]: invalid proxy URL";
902 $PROXY = [$2, $3 || 3128, $1]
903 } else {
904 undef $PROXY;
905 }
444} 906}
445 907
446# initialise proxy from environment 908# initialise proxy from environment
909eval {
447set_proxy $ENV{http_proxy}; 910 set_proxy $ENV{http_proxy};
911};
912
913=head2 SOCKS PROXIES
914
915Socks proxies are not directly supported by AnyEvent::HTTP. You can
916compile your perl to support socks, or use an external program such as
917F<socksify> (dante) or F<tsocks> to make your program use a socks proxy
918transparently.
919
920Alternatively, for AnyEvent::HTTP only, you can use your own
921C<tcp_connect> function that does the proxy handshake - here is an example
922that works with socks4a proxies:
923
924 use Errno;
925 use AnyEvent::Util;
926 use AnyEvent::Socket;
927 use AnyEvent::Handle;
928
929 # host, port and username of/for your socks4a proxy
930 my $socks_host = "10.0.0.23";
931 my $socks_port = 9050;
932 my $socks_user = "";
933
934 sub socks4a_connect {
935 my ($host, $port, $connect_cb, $prepare_cb) = @_;
936
937 my $hdl = new AnyEvent::Handle
938 connect => [$socks_host, $socks_port],
939 on_prepare => sub { $prepare_cb->($_[0]{fh}) },
940 on_error => sub { $connect_cb->() },
941 ;
942
943 $hdl->push_write (pack "CCnNZ*Z*", 4, 1, $port, 1, $socks_user, $host);
944
945 $hdl->push_read (chunk => 8, sub {
946 my ($hdl, $chunk) = @_;
947 my ($status, $port, $ipn) = unpack "xCna4", $chunk;
948
949 if ($status == 0x5a) {
950 $connect_cb->($hdl->{fh}, (format_address $ipn) . ":$port");
951 } else {
952 $! = Errno::ENXIO; $connect_cb->();
953 }
954 });
955
956 $hdl
957 }
958
959Use C<socks4a_connect> instead of C<tcp_connect> when doing C<http_request>s,
960possibly after switching off other proxy types:
961
962 AnyEvent::HTTP::set_proxy undef; # usually you do not want other proxies
963
964 http_get 'http://www.google.com', tcp_connect => \&socks4a_connect, sub {
965 my ($data, $headers) = @_;
966 ...
967 };
448 968
449=head1 SEE ALSO 969=head1 SEE ALSO
450 970
451L<AnyEvent>. 971L<AnyEvent>.
452 972
453=head1 AUTHOR 973=head1 AUTHOR
454 974
455 Marc Lehmann <schmorp@schmorp.de> 975 Marc Lehmann <schmorp@schmorp.de>
456 http://home.schmorp.de/ 976 http://home.schmorp.de/
977
978With many thanks to Дмитрий Шалашов, who provided countless
979testcases and bugreports.
457 980
458=cut 981=cut
459 982
4601 9831
461 984

Diff Legend

Removed lines
+ Added lines
< Changed lines
> Changed lines