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.40 by root, Sun Jul 5 01:45:01 2009 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
… …
22use strict; 41use strict;
23no warnings; 42no warnings;
24 43
25use Carp; 44use Carp;
26 45
27use AnyEvent (); 46use AnyEvent 4.452 ();
28use AnyEvent::Util (); 47use AnyEvent::Util ();
29use AnyEvent::Socket (); 48use AnyEvent::Socket ();
30use AnyEvent::Handle (); 49use AnyEvent::Handle ();
31 50
32use base Exporter::; 51use base Exporter::;
33 52
34our $VERSION = '1.0'; 53our $VERSION = '1.12';
35 54
36our @EXPORT = qw(http_get http_request); 55our @EXPORT = qw(http_get http_post http_head http_request);
37 56
38our $USERAGENT = "Mozilla/5.0 (compatible; AnyEvent::HTTP/$VERSION; +http://software.schmorp.de/pkg/AnyEvent)"; 57our $USERAGENT = "Mozilla/5.0 (compatible; U; AnyEvent-HTTP/$VERSION; +http://software.schmorp.de/pkg/AnyEvent)";
39our $MAX_RECURSE = 10; 58our $MAX_RECURSE = 10;
40our $MAX_PERSISTENT = 8; 59our $MAX_PERSISTENT = 8;
41our $PERSISTENT_TIMEOUT = 2; 60our $PERSISTENT_TIMEOUT = 2;
42our $TIMEOUT = 300; 61our $TIMEOUT = 300;
43 62
44# changing these is evil 63# changing these is evil
45our $MAX_PERSISTENT_PER_HOST = 2; 64our $MAX_PERSISTENT_PER_HOST = 2;
46our $MAX_PER_HOST = 4; # not respected yet :( 65our $MAX_PER_HOST = 4;
47 66
48our $PROXY; 67our $PROXY;
68our $ACTIVE = 0;
49 69
50my %KA_COUNT; # number of open keep-alive connections per host 70my %KA_COUNT; # number of open keep-alive connections per host
71my %CO_SLOT; # number of open connections, and wait queue, per host
51 72
52=item http_get $url, key => value..., $cb->($data, $headers) 73=item http_get $url, key => value..., $cb->($data, $headers)
53 74
54Executes an HTTP-GET request. See the http_request function for details on 75Executes an HTTP-GET request. See the http_request function for details on
55additional parameters. 76additional parameters and the return value.
56 77
57=item http_head $url, key => value..., $cb->($data, $headers) 78=item http_head $url, key => value..., $cb->($data, $headers)
58 79
59Executes an HTTP-HEAD request. See the http_request function for details on 80Executes an HTTP-HEAD request. See the http_request function for details
60additional parameters. 81on additional parameters and the return value.
61 82
62=item http_post $url, $body, key => value..., $cb->($data, $headers) 83=item http_post $url, $body, key => value..., $cb->($data, $headers)
63 84
64Executes an HTTP-POST request with a request body of C<$bod>. See the 85Executes an HTTP-POST request with a request body of C<$body>. See the
65http_request function for details on additional parameters. 86http_request function for details on additional parameters and the return
87value.
66 88
67=item http_request $method => $url, key => value..., $cb->($data, $headers) 89=item http_request $method => $url, key => value..., $cb->($data, $headers)
68 90
69Executes a HTTP request of type C<$method> (e.g. C<GET>, C<POST>). The URL 91Executes a HTTP request of type C<$method> (e.g. C<GET>, C<POST>). The URL
70must be an absolute http or https URL. 92must be an absolute http or https URL.
93
94When called in void context, nothing is returned. In other contexts,
95C<http_request> returns a "cancellation guard" - you have to keep the
96object at least alive until the callback get called. If the object gets
97destroyed before the callbakc is called, the request will be cancelled.
71 98
72The callback will be called with the response data as first argument 99The callback will be called with the response data as first argument
73(or C<undef> if it wasn't available due to errors), and a hash-ref with 100(or C<undef> if it wasn't available due to errors), and a hash-ref with
74response headers as second argument. 101response headers as second argument.
75 102
76All the headers in that hash are lowercased. In addition to the response 103All the headers in that hash are lowercased. In addition to the response
77headers, the three "pseudo-headers" C<HTTPVersion>, C<Status> and 104headers, the "pseudo-headers" C<HTTPVersion>, C<Status> and C<Reason>
78C<Reason> contain the three parts of the HTTP Status-Line of the same 105contain the three parts of the HTTP Status-Line of the same name. The
106pseudo-header C<URL> contains the original URL (which can differ from the
107requested URL when following redirects).
108
79name. If the server sends a header multiple lines, then their contents 109If the server sends a header multiple times, then their contents will be
80will be joined together with C<\x00>. 110joined together with a comma (C<,>), as per the HTTP spec.
81 111
82If an internal error occurs, such as not being able to resolve a hostname, 112If 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> 113then C<$data> will be C<undef>, C<< $headers->{Status} >> will be C<599>
84and the C<Reason> pseudo-header will contain an error message. 114and the C<Reason> pseudo-header will contain an error message.
85 115
… …
105Whether to recurse requests or not, e.g. on redirects, authentication 135Whether to recurse requests or not, e.g. on redirects, authentication
106retries and so on, and how often to do so. 136retries and so on, and how often to do so.
107 137
108=item headers => hashref 138=item headers => hashref
109 139
110The request headers to use. 140The request headers to use. Currently, C<http_request> may provide its
141own C<Host:>, C<Content-Length:>, C<Connection:> and C<Cookie:> headers
142and will provide defaults for C<User-Agent:> and C<Referer:>.
111 143
112=item timeout => $seconds 144=item timeout => $seconds
113 145
114The time-out to use for various stages - each connect attempt will reset 146The 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. 147the timeout, as will read or write activity. Default timeout is 5 minutes.
… …
133based on the original netscape specification. 165based on the original netscape specification.
134 166
135The C<$hash_ref> must be an (initially empty) hash reference which will 167The C<$hash_ref> must be an (initially empty) hash reference which will
136get updated automatically. It is possible to save the cookie_jar to 168get updated automatically. It is possible to save the cookie_jar to
137persistent storage with something like JSON or Storable, but this is not 169persistent storage with something like JSON or Storable, but this is not
138recommended, as expire times are currently being ignored. 170recommended, as expiry times are currently being ignored.
139 171
140Note that this cookie implementation is not of very high quality, nor 172Note that this cookie implementation is not of very high quality, nor
141meant to be complete. If you want complete cookie management you have to 173meant 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 174do 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 175cookie-using sites working. Cookies are a privacy disaster, do not use
144them unless required to. 176them unless required to.
177
178=item tls_ctx => $scheme | $tls_ctx
179
180Specifies the AnyEvent::TLS context to be used for https connections. This
181parameter follows the same rules as the C<tls_ctx> parameter to
182L<AnyEvent::Handle>, but additionally, the two strings C<low> or
183C<high> can be specified, which give you a predefined low-security (no
184verification, highest compatibility) and high-security (CA and common-name
185verification) TLS context.
186
187The default for this option is C<low>, which could be interpreted as "give
188me the page, no matter what".
145 189
146=back 190=back
147 191
148Example: make a simple HTTP GET request for http://www.nethype.de/ 192Example: make a simple HTTP GET request for http://www.nethype.de/
149 193
… …
163 use Data::Dumper; 207 use Data::Dumper;
164 print Dumper $hdr; 208 print Dumper $hdr;
165 } 209 }
166 ; 210 ;
167 211
212Example: make another simple HTTP GET request, but immediately try to
213cancel it.
214
215 my $request = http_request GET => "http://www.nethype.de/", sub {
216 my ($body, $hdr) = @_;
217 print "$body\n";
218 };
219
220 undef $request;
221
168=cut 222=cut
169 223
224sub _slot_schedule;
225sub _slot_schedule($) {
226 my $host = shift;
227
228 while ($CO_SLOT{$host}[0] < $MAX_PER_HOST) {
229 if (my $cb = shift @{ $CO_SLOT{$host}[1] }) {
230 # somebody wants that slot
231 ++$CO_SLOT{$host}[0];
232 ++$ACTIVE;
233
234 $cb->(AnyEvent::Util::guard {
235 --$ACTIVE;
236 --$CO_SLOT{$host}[0];
237 _slot_schedule $host;
238 });
239 } else {
240 # nobody wants the slot, maybe we can forget about it
241 delete $CO_SLOT{$host} unless $CO_SLOT{$host}[0];
242 last;
243 }
244 }
245}
246
247# wait for a free slot on host, call callback
248sub _get_slot($$) {
249 push @{ $CO_SLOT{$_[0]}[1] }, $_[1];
250
251 _slot_schedule $_[0];
252}
253
254our $qr_nl = qr<\015?\012>;
255our $qr_nlnl = qr<\015?\012\015?\012>;
256
257our $TLS_CTX_LOW = { cache => 1, dh => undef, sslv2 => 1 };
258our $TLS_CTX_HIGH = { cache => 1, verify => 1, verify_cn => "https", dh => "skip4096" };
259
170sub http_request($$$;@) { 260sub http_request($$@) {
171 my $cb = pop; 261 my $cb = pop;
172 my ($method, $url, %arg) = @_; 262 my ($method, $url, %arg) = @_;
173 263
174 my %hdr; 264 my %hdr;
265
266 $arg{tls_ctx} = $TLS_CTX_LOW if $arg{tls_ctx} eq "low" || !exists $arg{tls_ctx};
267 $arg{tls_ctx} = $TLS_CTX_HIGH if $arg{tls_ctx} eq "high";
175 268
176 $method = uc $method; 269 $method = uc $method;
177 270
178 if (my $hdr = $arg{headers}) { 271 if (my $hdr = $arg{headers}) {
179 while (my ($k, $v) = each %$hdr) { 272 while (my ($k, $v) = each %$hdr) {
180 $hdr{lc $k} = $v; 273 $hdr{lc $k} = $v;
181 } 274 }
182 } 275 }
183 276
184 my $recurse = exists $arg{recurse} ? $arg{recurse} : $MAX_RECURSE; 277 my $recurse = exists $arg{recurse} ? delete $arg{recurse} : $MAX_RECURSE;
185 278
186 return $cb->(undef, { Status => 599, Reason => "recursion limit reached" }) 279 return $cb->(undef, { Status => 599, Reason => "Too many redirections", URL => $url })
187 if $recurse < 0; 280 if $recurse < 0;
188 281
189 my $proxy = $arg{proxy} || $PROXY; 282 my $proxy = $arg{proxy} || $PROXY;
190 my $timeout = $arg{timeout} || $TIMEOUT; 283 my $timeout = $arg{timeout} || $TIMEOUT;
191 284
192 $hdr{"user-agent"} ||= $USERAGENT; 285 $hdr{"user-agent"} ||= $USERAGENT;
193 286
194 my ($scheme, $authority, $upath, $query, $fragment) = 287 my ($uscheme, $uauthority, $upath, $query, $fragment) =
195 $url =~ m|(?:([^:/?#]+):)?(?://([^/?#]*))?([^?#]*)(?:\?([^#]*))?(?:#(.*))?|; 288 $url =~ m|(?:([^:/?#]+):)?(?://([^/?#]*))?([^?#]*)(?:\?([^#]*))?(?:#(.*))?|;
196 289
197 $scheme = lc $scheme; 290 $uscheme = lc $uscheme;
198 291
199 my $uport = $scheme eq "http" ? 80 292 my $uport = $uscheme eq "http" ? 80
200 : $scheme eq "https" ? 443 293 : $uscheme eq "https" ? 443
201 : return $cb->(undef, { Status => 599, Reason => "only http and https URL schemes supported" }); 294 : return $cb->(undef, { Status => 599, Reason => "Only http and https URL schemes supported (not '$uscheme')", URL => $url });
202 295
296 $hdr{referer} ||= "$uscheme://$uauthority$upath"; # leave out fragment and query string, just a heuristic
297
203 $authority =~ /^(?: .*\@ )? ([^\@:]+) (?: : (\d+) )?$/x 298 $uauthority =~ /^(?: .*\@ )? ([^\@:]+) (?: : (\d+) )?$/x
204 or return $cb->(undef, { Status => 599, Reason => "unparsable URL" }); 299 or return $cb->(undef, { Status => 599, Reason => "Unparsable URL", URL => $url });
205 300
206 my $uhost = $1; 301 my $uhost = $1;
207 $uport = $2 if defined $2; 302 $uport = $2 if defined $2;
208 303
209 $uhost =~ s/^\[(.*)\]$/$1/; 304 $uhost =~ s/^\[(.*)\]$/$1/;
… …
211 306
212 $upath =~ s%^/?%/%; 307 $upath =~ s%^/?%/%;
213 308
214 # cookie processing 309 # cookie processing
215 if (my $jar = $arg{cookie_jar}) { 310 if (my $jar = $arg{cookie_jar}) {
216 %$jar = () if $jar->{version} < 1; 311 %$jar = () if $jar->{version} != 1;
217 312
218 my @cookie; 313 my @cookie;
219 314
220 while (my ($chost, $v) = each %$jar) { 315 while (my ($chost, $v) = each %$jar) {
316 if ($chost =~ /^\./) {
221 next unless $chost eq substr $uhost, -length $chost; 317 next unless $chost eq substr $uhost, -length $chost;
222 next unless $chost =~ /^\./; 318 } elsif ($chost =~ /\./) {
319 next unless $chost eq $uhost;
320 } else {
321 next;
322 }
223 323
224 while (my ($cpath, $v) = each %$v) { 324 while (my ($cpath, $v) = each %$v) {
225 next unless $cpath eq substr $upath, 0, length $cpath; 325 next unless $cpath eq substr $upath, 0, length $cpath;
226 326
227 while (my ($k, $v) = each %$v) { 327 while (my ($k, $v) = each %$v) {
228 next if $scheme ne "https" && exists $v->{secure}; 328 next if $uscheme ne "https" && exists $v->{secure};
329 my $value = $v->{value};
330 $value =~ s/([\\"])/\\$1/g;
229 push @cookie, "$k=$v->{value}"; 331 push @cookie, "$k=\"$value\"";
230 } 332 }
231 } 333 }
232 } 334 }
233 335
234 $hdr{cookie} = join "; ", @cookie 336 $hdr{cookie} = join "; ", @cookie
235 if @cookie; 337 if @cookie;
236 } 338 }
237 339
238 my ($rhost, $rport, $rpath); # request host, port, path 340 my ($rhost, $rport, $rscheme, $rpath); # request host, port, path
239 341
240 if ($proxy) { 342 if ($proxy) {
241 ($rhost, $rport, $scheme) = @$proxy; 343 ($rpath, $rhost, $rport, $rscheme) = ($url, @$proxy);
242 $rpath = $url; 344
345 # don't support https requests over https-proxy transport,
346 # can't be done with tls as spec'ed, unless you double-encrypt.
347 $rscheme = "http" if $uscheme eq "https" && $rscheme eq "https";
243 } else { 348 } else {
244 ($rhost, $rport, $rpath) = ($uhost, $uport, $upath); 349 ($rhost, $rport, $rscheme, $rpath) = ($uhost, $uport, $uscheme, $upath);
245 $hdr{host} = $uhost;
246 } 350 }
247 351
352 $hdr{host} = $uhost;
248 $hdr{"content-length"} = length $arg{body}; 353 $hdr{"content-length"} = length $arg{body};
249 354
250 my %state; 355 my %state = (connect_guard => 1);
251 356
357 _get_slot $uhost, sub {
358 $state{slot_guard} = shift;
359
360 return unless $state{connect_guard};
361
252 $state{connect_guard} = AnyEvent::Socket::tcp_connect $rhost, $rport, sub { 362 $state{connect_guard} = AnyEvent::Socket::tcp_connect $rhost, $rport, sub {
253 $state{fh} = shift 363 $state{fh} = shift
254 or return $cb->(undef, { Status => 599, Reason => "$!" }); 364 or return (%state = (), $cb->(undef, { Status => 599, Reason => "$!", URL => $url }));
365 pop; # free memory, save a tree
255 366
256 delete $state{connect_guard}; # reduce memory usage, save a tree 367 return unless delete $state{connect_guard};
257 368
258 # get handle 369 # get handle
259 $state{handle} = new AnyEvent::Handle 370 $state{handle} = new AnyEvent::Handle
260 fh => $state{fh}, 371 fh => $state{fh},
261 ($scheme eq "https" ? (tls => "connect") : ()); 372 timeout => $timeout,
373 peername => $rhost,
374 tls_ctx => $arg{tls_ctx};
262 375
263 # limit the number of persistent connections 376 # limit the number of persistent connections
377 # keepalive not yet supported
264 if ($KA_COUNT{$_[1]} < $MAX_PERSISTENT_PER_HOST) { 378 if ($KA_COUNT{$_[1]} < $MAX_PERSISTENT_PER_HOST) {
265 ++$KA_COUNT{$_[1]}; 379 ++$KA_COUNT{$_[1]};
266 $state{handle}{ka_count_guard} = AnyEvent::Util::guard { --$KA_COUNT{$_[1]} }; 380 $state{handle}{ka_count_guard} = AnyEvent::Util::guard {
381 --$KA_COUNT{$_[1]}
382 };
267 $hdr{connection} = "keep-alive"; 383 $hdr{connection} = "keep-alive";
268 delete $hdr{connection}; # keep-alive not yet supported
269 } else { 384 } else {
270 delete $hdr{connection}; 385 delete $hdr{connection};
271 } 386 }
272 387
273 # (re-)configure handle 388 # (re-)configure handle
274 $state{handle}->timeout ($timeout);
275 $state{handle}->on_error (sub { 389 $state{handle}->on_error (sub {
276 %state = (); 390 %state = ();
277 $cb->(undef, { Status => 599, Reason => "$!" }); 391 $cb->(undef, { Status => 599, Reason => $_[2], URL => $url });
278 }); 392 });
279 $state{handle}->on_eof (sub { 393 $state{handle}->on_eof (sub {
280 %state = (); 394 %state = ();
281 $cb->(undef, { Status => 599, Reason => "unexpected end-of-file" }); 395 $cb->(undef, { Status => 599, Reason => "Unexpected end-of-file", URL => $url });
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 ); 396 });
304 397
398 $state{handle}->starttls ("connect") if $rscheme eq "https";
399
400 # handle actual, non-tunneled, request
401 my $handle_actual_request = sub {
402 $state{handle}->starttls ("connect") if $uscheme eq "https" && !exists $state{handle}{tls};
403
404 # send request
405 $state{handle}->push_write (
406 "$method $rpath HTTP/1.0\015\012"
407 . (join "", map "\u$_: $hdr{$_}\015\012", keys %hdr)
408 . "\015\012"
409 . (delete $arg{body})
410 );
411
412 %hdr = (); # reduce memory usage, save a kitten
413
414 # status line
415 $state{handle}->push_read (line => $qr_nl, sub {
416 $_[1] =~ /^HTTP\/([0-9\.]+) \s+ ([0-9]{3}) (?: \s+ ([^\015\012]*) )?/ix
417 or return (%state = (), $cb->(undef, { Status => 599, Reason => "Invalid server response ($_[1])", URL => $url }));
418
419 my %hdr = ( # response headers
420 HTTPVersion => ",$1",
421 Status => ",$2",
422 Reason => ",$3",
423 URL => ",$url"
424 );
425
305 # headers, could be optimized a bit 426 # headers, could be optimized a bit
306 $state{handle}->unshift_read (line => qr/\015?\012\015?\012/, sub { 427 $state{handle}->unshift_read (line => $qr_nlnl, sub {
307 for ("$_[1]\012") { 428 for ("$_[1]\012") {
308 # we support spaces in field names, as lotus domino 429 y/\015//d; # weed out any \015, as they show up in the weirdest of places.
309 # creates them. 430
431 # things seen, not parsed:
432 # p3pP="NON CUR OTPi OUR NOR UNI"
433
310 $hdr{lc $1} .= "\x00$2" 434 $hdr{lc $1} .= ",$2"
311 while /\G 435 while /\G
312 ([^:\000-\037]+): 436 ([^:\000-\037]+):
313 [\011\040]* 437 [\011\040]*
314 ((?: [^\015\012]+ | \015?\012[\011\040] )*) 438 ((?: [^\012]+ | \012[\011\040] )*)
315 \015?\012 439 \012
316 /gxc; 440 /gxc;
317 441
318 /\G$/ 442 /\G$/
319 or return (%state = (), $cb->(undef, { Status => 599, Reason => "garbled response headers" })); 443 or return (%state = (), $cb->(undef, { Status => 599, Reason => "Garbled response headers", URL => $url }));
320 }
321
322 substr $_, 0, 1, ""
323 for values %hdr;
324
325 my $finish = sub {
326 %state = ();
327
328 # set-cookie processing
329 if ($arg{cookie_jar} && exists $hdr{"set-cookie"}) {
330 for (split /\x00/, $hdr{"set-cookie"}) {
331 my ($cookie, @arg) = split /;\s*/;
332 my ($name, $value) = split /=/, $cookie, 2;
333 my %kv = (value => $value, map { split /=/, $_, 2 } @arg);
334
335 my $cdom = (delete $kv{domain}) || $uhost;
336 my $cpath = (delete $kv{path}) || "/";
337
338 $cdom =~ s/^.?/./; # make sure it starts with a "."
339
340 my $ndots = $cdom =~ y/.//;
341 next if $ndots < ($cdom =~ /[^.]{3}$/ ? 2 : 3);
342
343 # store it
344 $arg{cookie_jar}{version} = 1;
345 $arg{cookie_jar}{$cdom}{$cpath}{$name} = \%kv;
346 } 444 }
445
446 substr $_, 0, 1, ""
447 for values %hdr;
448
449 my $finish = sub {
450 $state{handle}->destroy;
451 %state = ();
452
453 # set-cookie processing
454 if ($arg{cookie_jar}) {
455 for ($hdr{"set-cookie"}) {
456 # parse NAME=VALUE
457 my @kv;
458
459 while (/\G\s* ([^=;,[:space:]]+) \s*=\s* (?: "((?:[^\\"]+|\\.)*)" | ([^=;,[:space:]]*) )/gcxs) {
460 my $name = $1;
461 my $value = $3;
462
463 unless ($value) {
464 $value = $2;
465 $value =~ s/\\(.)/$1/gs;
466 }
467
468 push @kv, $name => $value;
469
470 last unless /\G\s*;/gc;
471 }
472
473 last unless @kv;
474
475 my $name = shift @kv;
476 my %kv = (value => shift @kv, @kv);
477
478 my $cdom;
479 my $cpath = (delete $kv{path}) || "/";
480
481 if (exists $kv{domain}) {
482 $cdom = delete $kv{domain};
483
484 $cdom =~ s/^\.?/./; # make sure it starts with a "."
485
486 next if $cdom =~ /\.$/;
487
488 # this is not rfc-like and not netscape-like. go figure.
489 my $ndots = $cdom =~ y/.//;
490 next if $ndots < ($cdom =~ /\.[^.][^.]\.[^.][^.]$/ ? 3 : 2);
491 } else {
492 $cdom = $uhost;
493 }
494
495 # store it
496 $arg{cookie_jar}{version} = 1;
497 $arg{cookie_jar}{$cdom}{$cpath}{$name} = \%kv;
498
499 redo if /\G\s*,/gc;
500 }
501 }
502
503 # microsoft and other shitheads don't give a shit for following standards,
504 # try to support some common forms of broken Location headers.
505 if ($_[1]{location} !~ /^(?: $ | [^:\/?\#]+ : )/x) {
506 $_[1]{location} =~ s/^\.\/+//;
507
508 my $url = "$rscheme://$uhost:$uport";
509
510 unless ($_[1]{location} =~ s/^\///) {
511 $url .= $upath;
512 $url =~ s/\/[^\/]*$//;
513 }
514
515 $_[1]{location} = "$url/$_[1]{location}";
516 }
517
518 if ($_[1]{Status} =~ /^30[12]$/ && $recurse && $method ne "POST") {
519 # apparently, mozilla et al. just change POST to GET here
520 # more research is needed before we do the same
521 http_request ($method => $_[1]{location}, %arg, recurse => $recurse - 1, $cb);
522 } elsif ($_[1]{Status} == 303 && $recurse) {
523 # even http/1.1 is unclear on how to mutate the method
524 $method = "GET" unless $method eq "HEAD";
525 http_request ($method => $_[1]{location}, %arg, recurse => $recurse - 1, $cb);
526 } elsif ($_[1]{Status} == 307 && $recurse && $method =~ /^(?:GET|HEAD)$/) {
527 http_request ($method => $_[1]{location}, %arg, recurse => $recurse - 1, $cb);
528 } else {
529 $cb->($_[0], $_[1]);
530 }
531 };
532
533 if ($hdr{Status} =~ /^(?:1..|204|304)$/ or $method eq "HEAD") {
534 $finish->(undef, \%hdr);
535 } else {
536 if (exists $hdr{"content-length"}) {
537 $_[0]->unshift_read (chunk => $hdr{"content-length"}, sub {
538 # could cache persistent connection now
539 if ($hdr{connection} =~ /\bkeep-alive\b/i) {
540 # but we don't, due to misdesigns, this is annoyingly complex
541 };
542
543 $finish->($_[1], \%hdr);
544 });
545 } else {
546 # too bad, need to read until we get an error or EOF,
547 # no way to detect winged data.
548 $_[0]->on_error (sub {
549 # delete ought to be more efficient, as we would have to make
550 # a copy otherwise as $_[0] gets destroyed.
551 $finish->(delete $_[0]{rbuf}, \%hdr);
552 });
553 $_[0]->on_eof (undef);
554 $_[0]->on_read (sub { });
555 }
556 }
557 });
558 });
559 };
560
561 # now handle proxy-CONNECT method
562 if ($proxy && $uscheme eq "https") {
563 # oh dear, we have to wrap it into a connect request
564
565 # maybe re-use $uauthority with patched port?
566 $state{handle}->push_write ("CONNECT $uhost:$uport HTTP/1.0\015\012Host: $uhost\015\012\015\012");
567 $state{handle}->push_read (line => $qr_nlnl, sub {
568 $_[1] =~ /^HTTP\/([0-9\.]+) \s+ ([0-9]{3}) (?: \s+ ([^\015\012]*) )?/ix
569 or return (%state = (), $cb->(undef, { Status => 599, Reason => "Invalid proxy connect response ($_[1])", URL => $url }));
570
571 if ($2 == 200) {
572 $rpath = $upath;
573 &$handle_actual_request;
574 } else {
575 %state = ();
576 $cb->(undef, { Status => $2, Reason => $3, URL => $url });
347 } 577 }
348
349 if ($_[1]{Status} =~ /^x30[12]$/ && $recurse) {
350 # microsoft and other assholes don't give a shit for following standards,
351 # try to support a common form of broken Location header.
352 $_[1]{location} =~ s%^/%$scheme://$uhost:$uport/%;
353
354 http_request ($method, $_[1]{location}, %arg, recurse => $recurse - 1, $cb);
355 } else {
356 $cb->($_[0], $_[1]);
357 }
358 }; 578 });
359
360 if ($hdr{Status} =~ /^(?:1..|204|304)$/ or $method eq "HEAD") {
361 $finish->(undef, \%hdr);
362 } else { 579 } else {
363 if (exists $hdr{"content-length"}) { 580 &$handle_actual_request;
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
370 $finish->($_[1], \%hdr);
371 });
372 } 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 });
378 $_[0]->on_eof (undef);
379 $_[0]->on_read (sub { });
380 }
381 }
382 }); 581 }
582
583 }, sub {
584 $timeout
383 }); 585 };
384 }, sub {
385 $timeout
386 }; 586 };
387 587
388 defined wantarray && AnyEvent::Util::guard { %state = () } 588 defined wantarray && AnyEvent::Util::guard { %state = () }
389} 589}
390 590
391sub http_get($$;@) { 591sub http_get($@) {
392 unshift @_, "GET"; 592 unshift @_, "GET";
393 &http_request 593 &http_request
394} 594}
395 595
396sub http_head($$;@) { 596sub http_head($@) {
397 unshift @_, "HEAD"; 597 unshift @_, "HEAD";
398 &http_request 598 &http_request
399} 599}
400 600
401sub http_post($$$;@) { 601sub http_post($$@) {
602 my $url = shift;
402 unshift @_, "POST", "body"; 603 unshift @_, "POST", $url, "body";
403 &http_request 604 &http_request
404} 605}
405 606
406=back 607=back
407 608
… …
419The default value for the C<recurse> request parameter (default: C<10>). 620The default value for the C<recurse> request parameter (default: C<10>).
420 621
421=item $AnyEvent::HTTP::USERAGENT 622=item $AnyEvent::HTTP::USERAGENT
422 623
423The default value for the C<User-Agent> header (the default is 624The 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)>). 625C<Mozilla/5.0 (compatible; U; AnyEvent-HTTP/$VERSION; +http://software.schmorp.de/pkg/AnyEvent)>).
425 626
426=item $AnyEvent::HTTP::MAX_PERSISTENT 627=item $AnyEvent::HTTP::MAX_PERSISTENT
427 628
428The maximum number of persistent connections to keep open (default: 8). 629The maximum number of persistent connections to keep open (default: 8).
429 630
… …
432=item $AnyEvent::HTTP::PERSISTENT_TIMEOUT 633=item $AnyEvent::HTTP::PERSISTENT_TIMEOUT
433 634
434The maximum time to cache a persistent connection, in seconds (default: 2). 635The maximum time to cache a persistent connection, in seconds (default: 2).
435 636
436Not implemented currently. 637Not implemented currently.
638
639=item $AnyEvent::HTTP::ACTIVE
640
641The number of active connections. This is not the number of currently
642running requests, but the number of currently open and non-idle TCP
643connections. This number of can be useful for load-leveling.
437 644
438=back 645=back
439 646
440=cut 647=cut
441 648
… …
450 657
451L<AnyEvent>. 658L<AnyEvent>.
452 659
453=head1 AUTHOR 660=head1 AUTHOR
454 661
455 Marc Lehmann <schmorp@schmorp.de> 662 Marc Lehmann <schmorp@schmorp.de>
456 http://home.schmorp.de/ 663 http://home.schmorp.de/
664
665With many thanks to Дмитрий Шалашов, who provided countless
666testcases and bugreports.
457 667
458=cut 668=cut
459 669
4601 6701
461 671

Diff Legend

– Removed lines
+ Added lines
< Changed lines
> Changed lines