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.17 by root, Fri Jun 6 13:02:38 2008 UTC vs.
Revision 1.40 by root, Sun Jul 5 01:45:01 2009 UTC

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

Diff Legend

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