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.11 by root, Thu Jun 5 15:34:00 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.
… …
37use strict; 41use strict;
38no warnings; 42no warnings;
39 43
40use Carp; 44use Carp;
41 45
42use AnyEvent (); 46use AnyEvent 4.452 ();
43use AnyEvent::Util (); 47use AnyEvent::Util ();
44use AnyEvent::Socket (); 48use AnyEvent::Socket ();
45use AnyEvent::Handle (); 49use AnyEvent::Handle ();
46 50
47use base Exporter::; 51use base Exporter::;
48 52
49our $VERSION = '1.0'; 53our $VERSION = '1.12';
50 54
51our @EXPORT = qw(http_get http_request); 55our @EXPORT = qw(http_get http_post http_head http_request);
52 56
53our $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)";
54our $MAX_RECURSE = 10; 58our $MAX_RECURSE = 10;
55our $MAX_PERSISTENT = 8; 59our $MAX_PERSISTENT = 8;
56our $PERSISTENT_TIMEOUT = 2; 60our $PERSISTENT_TIMEOUT = 2;
57our $TIMEOUT = 300; 61our $TIMEOUT = 300;
58 62
59# changing these is evil 63# changing these is evil
60our $MAX_PERSISTENT_PER_HOST = 2; 64our $MAX_PERSISTENT_PER_HOST = 2;
61our $MAX_PER_HOST = 4; 65our $MAX_PER_HOST = 4;
62 66
63our $PROXY; 67our $PROXY;
68our $ACTIVE = 0;
64 69
65my %KA_COUNT; # number of open keep-alive connections per host 70my %KA_COUNT; # number of open keep-alive connections per host
66my %CO_SLOT; # number of open connections, and wait queue, per host 71my %CO_SLOT; # number of open connections, and wait queue, per host
67 72
68=item http_get $url, key => value..., $cb->($data, $headers) 73=item http_get $url, key => value..., $cb->($data, $headers)
69 74
70Executes 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
71additional parameters. 76additional parameters and the return value.
72 77
73=item http_head $url, key => value..., $cb->($data, $headers) 78=item http_head $url, key => value..., $cb->($data, $headers)
74 79
75Executes an HTTP-HEAD request. See the http_request function for details on 80Executes an HTTP-HEAD request. See the http_request function for details
76additional parameters. 81on additional parameters and the return value.
77 82
78=item http_post $url, $body, key => value..., $cb->($data, $headers) 83=item http_post $url, $body, key => value..., $cb->($data, $headers)
79 84
80Executes 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
81http_request function for details on additional parameters. 86http_request function for details on additional parameters and the return
87value.
82 88
83=item http_request $method => $url, key => value..., $cb->($data, $headers) 89=item http_request $method => $url, key => value..., $cb->($data, $headers)
84 90
85Executes 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
86must 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.
87 98
88The callback will be called with the response data as first argument 99The callback will be called with the response data as first argument
89(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
90response headers as second argument. 101response headers as second argument.
91 102
92All 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
93headers, the three "pseudo-headers" C<HTTPVersion>, C<Status> and 104headers, the "pseudo-headers" C<HTTPVersion>, C<Status> and C<Reason>
94C<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
95name. If the server sends a header multiple lines, then their contents 109If the server sends a header multiple times, then their contents will be
96will be joined together with C<\x00>. 110joined together with a comma (C<,>), as per the HTTP spec.
97 111
98If 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,
99then 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>
100and the C<Reason> pseudo-header will contain an error message. 114and the C<Reason> pseudo-header will contain an error message.
101 115
… …
121Whether to recurse requests or not, e.g. on redirects, authentication 135Whether to recurse requests or not, e.g. on redirects, authentication
122retries and so on, and how often to do so. 136retries and so on, and how often to do so.
123 137
124=item headers => hashref 138=item headers => hashref
125 139
126The 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:>.
127 143
128=item timeout => $seconds 144=item timeout => $seconds
129 145
130The 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
131the 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.
… …
149based on the original netscape specification. 165based on the original netscape specification.
150 166
151The 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
152get updated automatically. It is possible to save the cookie_jar to 168get updated automatically. It is possible to save the cookie_jar to
153persistent storage with something like JSON or Storable, but this is not 169persistent storage with something like JSON or Storable, but this is not
154recommended, as expire times are currently being ignored. 170recommended, as expiry times are currently being ignored.
155 171
156Note that this cookie implementation is not of very high quality, nor 172Note that this cookie implementation is not of very high quality, nor
157meant 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
158do 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
159cookie-using sites working. Cookies are a privacy disaster, do not use 175cookie-using sites working. Cookies are a privacy disaster, do not use
160them 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".
161 189
162=back 190=back
163 191
164Example: make a simple HTTP GET request for http://www.nethype.de/ 192Example: make a simple HTTP GET request for http://www.nethype.de/
165 193
… …
179 use Data::Dumper; 207 use Data::Dumper;
180 print Dumper $hdr; 208 print Dumper $hdr;
181 } 209 }
182 ; 210 ;
183 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
184=cut 222=cut
185 223
224sub _slot_schedule;
186sub _slot_schedule($) { 225sub _slot_schedule($) {
187 my $host = shift; 226 my $host = shift;
188 227
189 while ($CO_SLOT{$host}[0] < $MAX_PER_HOST) { 228 while ($CO_SLOT{$host}[0] < $MAX_PER_HOST) {
190 if (my $cb = shift @{ $CO_SLOT{$host}[1] }) { 229 if (my $cb = shift @{ $CO_SLOT{$host}[1] }) {
191 # somebody wnats that slot 230 # somebody wants that slot
192 ++$CO_SLOT{$host}[0]; 231 ++$CO_SLOT{$host}[0];
232 ++$ACTIVE;
193 233
194 $cb->(AnyEvent::Util::guard { 234 $cb->(AnyEvent::Util::guard {
235 --$ACTIVE;
195 --$CO_SLOT{$host}[0]; 236 --$CO_SLOT{$host}[0];
196 _slot_schedule $host; 237 _slot_schedule $host;
197 }); 238 });
198 } else { 239 } else {
199 # nobody wants the slot, maybe we can forget about it 240 # nobody wants the slot, maybe we can forget about it
200 delete $CO_SLOT{$host} unless $CO_SLOT{$host}[0]; 241 delete $CO_SLOT{$host} unless $CO_SLOT{$host}[0];
201 warn "$host deleted" unless $CO_SLOT{$host}[0];#d#
202 last; 242 last;
203 } 243 }
204 } 244 }
205} 245}
206 246
… …
209 push @{ $CO_SLOT{$_[0]}[1] }, $_[1]; 249 push @{ $CO_SLOT{$_[0]}[1] }, $_[1];
210 250
211 _slot_schedule $_[0]; 251 _slot_schedule $_[0];
212} 252}
213 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
214sub http_request($$$;@) { 260sub http_request($$@) {
215 my $cb = pop; 261 my $cb = pop;
216 my ($method, $url, %arg) = @_; 262 my ($method, $url, %arg) = @_;
217 263
218 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";
219 268
220 $method = uc $method; 269 $method = uc $method;
221 270
222 if (my $hdr = $arg{headers}) { 271 if (my $hdr = $arg{headers}) {
223 while (my ($k, $v) = each %$hdr) { 272 while (my ($k, $v) = each %$hdr) {
224 $hdr{lc $k} = $v; 273 $hdr{lc $k} = $v;
225 } 274 }
226 } 275 }
227 276
228 my $recurse = exists $arg{recurse} ? $arg{recurse} : $MAX_RECURSE; 277 my $recurse = exists $arg{recurse} ? delete $arg{recurse} : $MAX_RECURSE;
229 278
230 return $cb->(undef, { Status => 599, Reason => "recursion limit reached" }) 279 return $cb->(undef, { Status => 599, Reason => "Too many redirections", URL => $url })
231 if $recurse < 0; 280 if $recurse < 0;
232 281
233 my $proxy = $arg{proxy} || $PROXY; 282 my $proxy = $arg{proxy} || $PROXY;
234 my $timeout = $arg{timeout} || $TIMEOUT; 283 my $timeout = $arg{timeout} || $TIMEOUT;
235 284
236 $hdr{"user-agent"} ||= $USERAGENT; 285 $hdr{"user-agent"} ||= $USERAGENT;
237 286
238 my ($scheme, $authority, $upath, $query, $fragment) = 287 my ($uscheme, $uauthority, $upath, $query, $fragment) =
239 $url =~ m|(?:([^:/?#]+):)?(?://([^/?#]*))?([^?#]*)(?:\?([^#]*))?(?:#(.*))?|; 288 $url =~ m|(?:([^:/?#]+):)?(?://([^/?#]*))?([^?#]*)(?:\?([^#]*))?(?:#(.*))?|;
240 289
241 $scheme = lc $scheme; 290 $uscheme = lc $uscheme;
242 291
243 my $uport = $scheme eq "http" ? 80 292 my $uport = $uscheme eq "http" ? 80
244 : $scheme eq "https" ? 443 293 : $uscheme eq "https" ? 443
245 : 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 });
246 295
296 $hdr{referer} ||= "$uscheme://$uauthority$upath"; # leave out fragment and query string, just a heuristic
297
247 $authority =~ /^(?: .*\@ )? ([^\@:]+) (?: : (\d+) )?$/x 298 $uauthority =~ /^(?: .*\@ )? ([^\@:]+) (?: : (\d+) )?$/x
248 or return $cb->(undef, { Status => 599, Reason => "unparsable URL" }); 299 or return $cb->(undef, { Status => 599, Reason => "Unparsable URL", URL => $url });
249 300
250 my $uhost = $1; 301 my $uhost = $1;
251 $uport = $2 if defined $2; 302 $uport = $2 if defined $2;
252 303
253 $uhost =~ s/^\[(.*)\]$/$1/; 304 $uhost =~ s/^\[(.*)\]$/$1/;
… …
255 306
256 $upath =~ s%^/?%/%; 307 $upath =~ s%^/?%/%;
257 308
258 # cookie processing 309 # cookie processing
259 if (my $jar = $arg{cookie_jar}) { 310 if (my $jar = $arg{cookie_jar}) {
260 %$jar = () if $jar->{version} < 1; 311 %$jar = () if $jar->{version} != 1;
261 312
262 my @cookie; 313 my @cookie;
263 314
264 while (my ($chost, $v) = each %$jar) { 315 while (my ($chost, $v) = each %$jar) {
316 if ($chost =~ /^\./) {
265 next unless $chost eq substr $uhost, -length $chost; 317 next unless $chost eq substr $uhost, -length $chost;
266 next unless $chost =~ /^\./; 318 } elsif ($chost =~ /\./) {
319 next unless $chost eq $uhost;
320 } else {
321 next;
322 }
267 323
268 while (my ($cpath, $v) = each %$v) { 324 while (my ($cpath, $v) = each %$v) {
269 next unless $cpath eq substr $upath, 0, length $cpath; 325 next unless $cpath eq substr $upath, 0, length $cpath;
270 326
271 while (my ($k, $v) = each %$v) { 327 while (my ($k, $v) = each %$v) {
272 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;
273 push @cookie, "$k=$v->{value}"; 331 push @cookie, "$k=\"$value\"";
274 } 332 }
275 } 333 }
276 } 334 }
277 335
278 $hdr{cookie} = join "; ", @cookie 336 $hdr{cookie} = join "; ", @cookie
279 if @cookie; 337 if @cookie;
280 } 338 }
281 339
282 my ($rhost, $rport, $rpath); # request host, port, path 340 my ($rhost, $rport, $rscheme, $rpath); # request host, port, path
283 341
284 if ($proxy) { 342 if ($proxy) {
285 ($rhost, $rport, $scheme) = @$proxy; 343 ($rpath, $rhost, $rport, $rscheme) = ($url, @$proxy);
286 $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";
287 } else { 348 } else {
288 ($rhost, $rport, $rpath) = ($uhost, $uport, $upath); 349 ($rhost, $rport, $rscheme, $rpath) = ($uhost, $uport, $uscheme, $upath);
289 $hdr{host} = $uhost;
290 } 350 }
291 351
352 $hdr{host} = $uhost;
292 $hdr{"content-length"} = length $arg{body}; 353 $hdr{"content-length"} = length $arg{body};
293 354
294 my %state = (connect_guard => 1); 355 my %state = (connect_guard => 1);
295 356
296 _get_slot $uhost, sub { 357 _get_slot $uhost, sub {
… …
298 359
299 return unless $state{connect_guard}; 360 return unless $state{connect_guard};
300 361
301 $state{connect_guard} = AnyEvent::Socket::tcp_connect $rhost, $rport, sub { 362 $state{connect_guard} = AnyEvent::Socket::tcp_connect $rhost, $rport, sub {
302 $state{fh} = shift 363 $state{fh} = shift
303 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
304 366
305 delete $state{connect_guard}; # reduce memory usage, save a tree 367 return unless delete $state{connect_guard};
306 368
307 # get handle 369 # get handle
308 $state{handle} = new AnyEvent::Handle 370 $state{handle} = new AnyEvent::Handle
309 fh => $state{fh}, 371 fh => $state{fh},
310 ($scheme eq "https" ? (tls => "connect") : ()); 372 timeout => $timeout,
373 peername => $rhost,
374 tls_ctx => $arg{tls_ctx};
311 375
312 # limit the number of persistent connections 376 # limit the number of persistent connections
377 # keepalive not yet supported
313 if ($KA_COUNT{$_[1]} < $MAX_PERSISTENT_PER_HOST) { 378 if ($KA_COUNT{$_[1]} < $MAX_PERSISTENT_PER_HOST) {
314 ++$KA_COUNT{$_[1]}; 379 ++$KA_COUNT{$_[1]};
315 $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 };
316 $hdr{connection} = "keep-alive"; 383 $hdr{connection} = "keep-alive";
317 delete $hdr{connection}; # keep-alive not yet supported
318 } else { 384 } else {
319 delete $hdr{connection}; 385 delete $hdr{connection};
320 } 386 }
321 387
322 # (re-)configure handle 388 # (re-)configure handle
323 $state{handle}->timeout ($timeout);
324 $state{handle}->on_error (sub { 389 $state{handle}->on_error (sub {
325 %state = (); 390 %state = ();
326 $cb->(undef, { Status => 599, Reason => "$!" }); 391 $cb->(undef, { Status => 599, Reason => $_[2], URL => $url });
327 }); 392 });
328 $state{handle}->on_eof (sub { 393 $state{handle}->on_eof (sub {
329 %state = (); 394 %state = ();
330 $cb->(undef, { Status => 599, Reason => "unexpected end-of-file" }); 395 $cb->(undef, { Status => 599, Reason => "Unexpected end-of-file", URL => $url });
331 }); 396 });
332 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
333 # send request 404 # send request
334 $state{handle}->push_write ( 405 $state{handle}->push_write (
335 "$method $rpath HTTP/1.0\015\012" 406 "$method $rpath HTTP/1.0\015\012"
336 . (join "", map "$_: $hdr{$_}\015\012", keys %hdr) 407 . (join "", map "\u$_: $hdr{$_}\015\012", keys %hdr)
337 . "\015\012" 408 . "\015\012"
338 . (delete $arg{body}) 409 . (delete $arg{body})
339 );
340
341 %hdr = (); # reduce memory usage, save a kitten
342
343 # status line
344 $state{handle}->push_read (line => qr/\015?\012/, sub {
345 $_[1] =~ /^HTTP\/([0-9\.]+) \s+ ([0-9]{3}) \s+ ([^\015\012]+)/ix
346 or return (%state = (), $cb->(undef, { Status => 599, Reason => "invalid server response ($_[1])" }));
347
348 my %hdr = ( # response headers
349 HTTPVersion => "\x00$1",
350 Status => "\x00$2",
351 Reason => "\x00$3",
352 ); 410 );
353 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
354 # headers, could be optimized a bit 426 # headers, could be optimized a bit
355 $state{handle}->unshift_read (line => qr/\015?\012\015?\012/, sub { 427 $state{handle}->unshift_read (line => $qr_nlnl, sub {
356 for ("$_[1]\012") { 428 for ("$_[1]\012") {
357 # 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.
358 # creates them. 430
431 # things seen, not parsed:
432 # p3pP="NON CUR OTPi OUR NOR UNI"
433
359 $hdr{lc $1} .= "\x00$2" 434 $hdr{lc $1} .= ",$2"
360 while /\G 435 while /\G
361 ([^:\000-\037]+): 436 ([^:\000-\037]+):
362 [\011\040]* 437 [\011\040]*
363 ((?: [^\015\012]+ | \015?\012[\011\040] )*) 438 ((?: [^\012]+ | \012[\011\040] )*)
364 \015?\012 439 \012
365 /gxc; 440 /gxc;
366 441
367 /\G$/ 442 /\G$/
368 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 }));
369 } 444 }
370 445
371 substr $_, 0, 1, "" 446 substr $_, 0, 1, ""
372 for values %hdr; 447 for values %hdr;
373 448
374 my $finish = sub { 449 my $finish = sub {
450 $state{handle}->destroy;
375 %state = (); 451 %state = ();
376 452
377 # set-cookie processing 453 # set-cookie processing
378 if ($arg{cookie_jar} && exists $hdr{"set-cookie"}) { 454 if ($arg{cookie_jar}) {
379 for (split /\x00/, $hdr{"set-cookie"}) { 455 for ($hdr{"set-cookie"}) {
380 my ($cookie, @arg) = split /;\s*/; 456 # parse NAME=VALUE
381 my ($name, $value) = split /=/, $cookie, 2; 457 my @kv;
382 my %kv = (value => $value, map { split /=/, $_, 2 } @arg); 458
383 459 while (/\G\s* ([^=;,[:space:]]+) \s*=\s* (?: "((?:[^\\"]+|\\.)*)" | ([^=;,[:space:]]*) )/gcxs) {
384 my $cdom = (delete $kv{domain}) || $uhost; 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;
385 my $cpath = (delete $kv{path}) || "/"; 479 my $cpath = (delete $kv{path}) || "/";
386 480
481 if (exists $kv{domain}) {
482 $cdom = delete $kv{domain};
483
387 $cdom =~ s/^.?/./; # make sure it starts with a "." 484 $cdom =~ s/^\.?/./; # make sure it starts with a "."
388 485
389 next if $cdom =~ /\.$/; 486 next if $cdom =~ /\.$/;
390 487
391 # this is not rfc-like and not netscape-like. go figure. 488 # this is not rfc-like and not netscape-like. go figure.
392 my $ndots = $cdom =~ y/.//; 489 my $ndots = $cdom =~ y/.//;
393 next if $ndots < ($cdom =~ /\.[^.][^.]\.[^.][^.]$/ ? 3 : 2); 490 next if $ndots < ($cdom =~ /\.[^.][^.]\.[^.][^.]$/ ? 3 : 2);
394 491 } else {
492 $cdom = $uhost;
493 }
494
395 # store it 495 # store it
396 $arg{cookie_jar}{version} = 1; 496 $arg{cookie_jar}{version} = 1;
397 $arg{cookie_jar}{$cdom}{$cpath}{$name} = \%kv; 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 { });
398 } 555 }
399 } 556 }
400
401 if ($_[1]{Status} =~ /^x30[12]$/ && $recurse) {
402 # microsoft and other assholes don't give a shit for following standards,
403 # try to support a common form of broken Location header.
404 $_[1]{location} =~ s%^/%$scheme://$uhost:$uport/%;
405
406 http_request ($method, $_[1]{location}, %arg, recurse => $recurse - 1, $cb);
407 } else {
408 $cb->($_[0], $_[1]);
409 }
410 }; 557 });
558 });
559 };
411 560
412 if ($hdr{Status} =~ /^(?:1..|204|304)$/ or $method eq "HEAD") { 561 # now handle proxy-CONNECT method
413 $finish->(undef, \%hdr); 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;
414 } else { 574 } else {
415 if (exists $hdr{"content-length"}) { 575 %state = ();
416 $_[0]->unshift_read (chunk => $hdr{"content-length"}, sub { 576 $cb->(undef, { Status => $2, Reason => $3, URL => $url });
417 # could cache persistent connection now
418 if ($hdr{connection} =~ /\bkeep-alive\b/i) {
419 # but we don't, due to misdesigns, this is annoyingly complex
420 };
421
422 $finish->($_[1], \%hdr);
423 });
424 } else {
425 # too bad, need to read until we get an error or EOF,
426 # no way to detect winged data.
427 $_[0]->on_error (sub {
428 $finish->($_[0]{rbuf}, \%hdr);
429 });
430 $_[0]->on_eof (undef);
431 $_[0]->on_read (sub { });
432 }
433 } 577 }
434 }); 578 });
579 } else {
580 &$handle_actual_request;
435 }); 581 }
582
436 }, sub { 583 }, sub {
437 $timeout 584 $timeout
438 }; 585 };
439 }; 586 };
440 587
441 defined wantarray && AnyEvent::Util::guard { %state = () } 588 defined wantarray && AnyEvent::Util::guard { %state = () }
442} 589}
443 590
444sub http_get($$;@) { 591sub http_get($@) {
445 unshift @_, "GET"; 592 unshift @_, "GET";
446 &http_request 593 &http_request
447} 594}
448 595
449sub http_head($$;@) { 596sub http_head($@) {
450 unshift @_, "HEAD"; 597 unshift @_, "HEAD";
451 &http_request 598 &http_request
452} 599}
453 600
454sub http_post($$$;@) { 601sub http_post($$@) {
602 my $url = shift;
455 unshift @_, "POST", "body"; 603 unshift @_, "POST", $url, "body";
456 &http_request 604 &http_request
457} 605}
458 606
459=back 607=back
460 608
… …
472The default value for the C<recurse> request parameter (default: C<10>). 620The default value for the C<recurse> request parameter (default: C<10>).
473 621
474=item $AnyEvent::HTTP::USERAGENT 622=item $AnyEvent::HTTP::USERAGENT
475 623
476The default value for the C<User-Agent> header (the default is 624The default value for the C<User-Agent> header (the default is
477C<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)>).
478 626
479=item $AnyEvent::HTTP::MAX_PERSISTENT 627=item $AnyEvent::HTTP::MAX_PERSISTENT
480 628
481The maximum number of persistent connections to keep open (default: 8). 629The maximum number of persistent connections to keep open (default: 8).
482 630
… …
485=item $AnyEvent::HTTP::PERSISTENT_TIMEOUT 633=item $AnyEvent::HTTP::PERSISTENT_TIMEOUT
486 634
487The maximum time to cache a persistent connection, in seconds (default: 2). 635The maximum time to cache a persistent connection, in seconds (default: 2).
488 636
489Not 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.
490 644
491=back 645=back
492 646
493=cut 647=cut
494 648
… …
503 657
504L<AnyEvent>. 658L<AnyEvent>.
505 659
506=head1 AUTHOR 660=head1 AUTHOR
507 661
508 Marc Lehmann <schmorp@schmorp.de> 662 Marc Lehmann <schmorp@schmorp.de>
509 http://home.schmorp.de/ 663 http://home.schmorp.de/
664
665With many thanks to Дмитрий Шалашов, who provided countless
666testcases and bugreports.
510 667
511=cut 668=cut
512 669
5131 6701
514 671

Diff Legend

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