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.59 by root, Wed Dec 29 23:59:36 2010 UTC vs.
Revision 1.71 by root, Fri Dec 31 20:50:58 2010 UTC

47use AnyEvent::Util (); 47use AnyEvent::Util ();
48use AnyEvent::Handle (); 48use AnyEvent::Handle ();
49 49
50use base Exporter::; 50use base Exporter::;
51 51
52our $VERSION = '1.46'; 52our $VERSION = '1.5';
53 53
54our @EXPORT = qw(http_get http_post http_head http_request); 54our @EXPORT = qw(http_get http_post http_head http_request);
55 55
56our $USERAGENT = "Mozilla/5.0 (compatible; U; 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)";
57our $MAX_RECURSE = 10; 57our $MAX_RECURSE = 10;
94C<http_request> returns a "cancellation guard" - you have to keep the 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 95object at least alive until the callback get called. If the object gets
96destroyed before the callback is called, the request will be cancelled. 96destroyed before the callback is called, the request will be cancelled.
97 97
98The callback will be called with the response body data as first argument 98The callback will be called with the response body data as first argument
99(or C<undef> if an error occured), and a hash-ref with response headers as 99(or C<undef> if an error occured), and a hash-ref with response headers
100second argument. 100(and trailers) as second argument.
101 101
102All 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
103headers, the "pseudo-headers" (uppercase to avoid clashing with possible 103headers, the "pseudo-headers" (uppercase to avoid clashing with possible
104response headers) C<HTTPVersion>, C<Status> and C<Reason> contain the 104response headers) C<HTTPVersion>, C<Status> and C<Reason> contain the
105three parts of the HTTP Status-Line of the same name. 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>.
106 109
107The pseudo-header C<URL> contains the actual URL (which can differ from 110The pseudo-header C<URL> contains the actual URL (which can differ from
108the requested URL when following redirects - for example, you might get 111the requested URL when following redirects - for example, you might get
109an error that your URL scheme is not supported even though your URL is a 112an error that your URL scheme is not supported even though your URL is a
110valid http URL because it redirected to an ftp URL, in which case you can 113valid http URL because it redirected to an ftp URL, in which case you can
147Whether to recurse requests or not, e.g. on redirects, authentication 150Whether to recurse requests or not, e.g. on redirects, authentication
148retries and so on, and how often to do so. 151retries and so on, and how often to do so.
149 152
150=item headers => hashref 153=item headers => hashref
151 154
152The request headers to use. Currently, C<http_request> may provide its 155The request headers to use. Currently, C<http_request> may provide its own
153own C<Host:>, C<Content-Length:>, C<Connection:> and C<Cookie:> headers 156C<Host:>, C<Content-Length:>, C<Connection:> and C<Cookie:> headers and
154and will provide defaults for C<User-Agent:> and C<Referer:> (this can be 157will provide defaults at least for C<TE:>, C<Referer:> and C<User-Agent:>
155suppressed by using C<undef> for these headers in which case they won't be 158(this can be suppressed by using C<undef> for these headers in which case
156sent at all). 159they won't be sent at all).
157 160
158=item timeout => $seconds 161=item timeout => $seconds
159 162
160The 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
161the timeout, as will read or write activity, i.e. this is not an overall 164the timeout, as will read or write activity, i.e. this is not an overall
171C<$scheme> must be either missing, C<http> for HTTP or C<https> for 174C<$scheme> must be either missing, C<http> for HTTP or C<https> for
172HTTPS. 175HTTPS.
173 176
174=item body => $string 177=item body => $string
175 178
176The 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
177this module might offer more options). 180this module might offer more options).
178 181
179=item cookie_jar => $hash_ref 182=item cookie_jar => $hash_ref
180 183
181Passing this parameter enables (simplified) cookie-processing, loosely 184Passing this parameter enables (simplified) cookie-processing, loosely
182based on the original netscape specification. 185based on the original netscape specification.
183 186
184The 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
185get updated automatically. It is possible to save the cookie_jar to 188get updated automatically. It is possible to save the cookie jar to
186persistent storage with something like JSON or Storable, but this is not 189persistent storage with something like JSON or Storable, but this is not
187recommended, as expiry times are currently being ignored. 190recommended, as session-only cookies might survive longer than expected.
188 191
189Note that this cookie implementation is not of very high quality, nor 192Note that this cookie implementation is not meant to be complete. If
190meant to be complete. If you want complete cookie management you have to 193you want complete cookie management you have to do that on your
191do that on your own. C<cookie_jar> is meant as a quick fix to get some 194own. C<cookie_jar> is meant as a quick fix to get some cookie-using sites
192cookie-using sites working. Cookies are a privacy disaster, do not use 195working. Cookies are a privacy disaster, do not use them unless required
193them unless required to. 196to.
197
198When cookie processing is enabled, the C<Cookie:> and C<Set-Cookie:>
199headers will be set and handled by this module, otherwise they will be
200left untouched.
194 201
195=item tls_ctx => $scheme | $tls_ctx 202=item tls_ctx => $scheme | $tls_ctx
196 203
197Specifies the AnyEvent::TLS context to be used for https connections. This 204Specifies the AnyEvent::TLS context to be used for https connections. This
198parameter follows the same rules as the C<tls_ctx> parameter to 205parameter follows the same rules as the C<tls_ctx> parameter to
216=item tcp_connect => $callback->($host, $service, $connect_cb, $prepare_cb) 223=item tcp_connect => $callback->($host, $service, $connect_cb, $prepare_cb)
217 224
218In even rarer cases you want total control over how AnyEvent::HTTP 225In even rarer cases you want total control over how AnyEvent::HTTP
219establishes connections. Normally it uses L<AnyEvent::Socket::tcp_connect> 226establishes connections. Normally it uses L<AnyEvent::Socket::tcp_connect>
220to do this, but you can provide your own C<tcp_connect> function - 227to do this, but you can provide your own C<tcp_connect> function -
221obviously, it has to follow the same calling conventions. 228obviously, it has to follow the same calling conventions, except that it
229may always return a connection guard object.
222 230
223There are probably lots of weird uses for this function, starting from 231There are probably lots of weird uses for this function, starting from
224tracing the hosts C<http_request> actually tries to connect, to (inexact 232tracing the hosts C<http_request> actually tries to connect, to (inexact
225but fast) host => IP address caching or even socks protocol support. 233but fast) host => IP address caching or even socks protocol support.
226 234
236 244
237This callback is useful, among other things, to quickly reject unwanted 245This callback is useful, among other things, to quickly reject unwanted
238content, which, if it is supposed to be rare, can be faster than first 246content, which, if it is supposed to be rare, can be faster than first
239doing a C<HEAD> request. 247doing a C<HEAD> request.
240 248
249The downside is that cancelling the request makes it impossible to re-use
250the connection. Also, the C<on_header> callback will not receive any
251trailer (headers sent after the response body).
252
241Example: cancel the request unless the content-type is "text/html". 253Example: cancel the request unless the content-type is "text/html".
242 254
243 on_header => sub { 255 on_header => sub {
244 $_[0]{"content-type"} =~ /^text\/html\s*(?:;|$)/ 256 $_[0]{"content-type"} =~ /^text\/html\s*(?:;|$)/
245 }, 257 },
251string instead of the body data. 263string instead of the body data.
252 264
253It has to return either true (in which case AnyEvent::HTTP will continue), 265It has to return either true (in which case AnyEvent::HTTP will continue),
254or false, in which case AnyEvent::HTTP will cancel the download (and call 266or false, in which case AnyEvent::HTTP will cancel the download (and call
255the completion callback with an error code of C<598>). 267the completion callback with an error code of C<598>).
268
269The downside to cancelling the request is that it makes it impossible to
270re-use the connection.
256 271
257This callback is useful when the data is too large to be held in memory 272This callback is useful when the data is too large to be held in memory
258(so the callback writes it to a file) or when only some information should 273(so the callback writes it to a file) or when only some information should
259be extracted, or when the body should be processed incrementally. 274be extracted, or when the body should be processed incrementally.
260 275
286If you think you need this, first have a look at C<on_body>, to see if 301If you think you need this, first have a look at C<on_body>, to see if
287that doesn't solve your problem in a better way. 302that doesn't solve your problem in a better way.
288 303
289=back 304=back
290 305
291Example: make a simple HTTP GET request for http://www.nethype.de/ 306Example: do a simple HTTP GET request for http://www.nethype.de/ and print
307the response body.
292 308
293 http_request GET => "http://www.nethype.de/", sub { 309 http_request GET => "http://www.nethype.de/", sub {
294 my ($body, $hdr) = @_; 310 my ($body, $hdr) = @_;
295 print "$body\n"; 311 print "$body\n";
296 }; 312 };
297 313
298Example: make a HTTP HEAD request on https://www.google.com/, use a 314Example: do a HTTP HEAD request on https://www.google.com/, use a
299timeout of 30 seconds. 315timeout of 30 seconds.
300 316
301 http_request 317 http_request
302 GET => "https://www.google.com", 318 GET => "https://www.google.com",
303 timeout => 30, 319 timeout => 30,
306 use Data::Dumper; 322 use Data::Dumper;
307 print Dumper $hdr; 323 print Dumper $hdr;
308 } 324 }
309 ; 325 ;
310 326
311Example: make another simple HTTP GET request, but immediately try to 327Example: do another simple HTTP GET request, but immediately try to
312cancel it. 328cancel it.
313 329
314 my $request = http_request GET => "http://www.nethype.de/", sub { 330 my $request = http_request GET => "http://www.nethype.de/", sub {
315 my ($body, $hdr) = @_; 331 my ($body, $hdr) = @_;
316 print "$body\n"; 332 print "$body\n";
348 push @{ $CO_SLOT{$_[0]}[1] }, $_[1]; 364 push @{ $CO_SLOT{$_[0]}[1] }, $_[1];
349 365
350 _slot_schedule $_[0]; 366 _slot_schedule $_[0];
351} 367}
352 368
369sub cookie_jar_extract($$$$) {
370 my ($jar, $uscheme, $uhost, $upath) = @_;
371
372 %$jar = () if $jar->{version} != 1;
373
374 my @cookies;
375
376 while (my ($chost, $paths) = each %$jar) {
377 next unless ref $paths;
378
379 if ($chost =~ /^\./) {
380 next unless $chost eq substr $uhost, -length $chost;
381 } elsif ($chost =~ /\./) {
382 next unless $chost eq $uhost;
383 } else {
384 next;
385 }
386
387 while (my ($cpath, $cookies) = each %$paths) {
388 next unless $cpath eq substr $upath, 0, length $cpath;
389
390 while (my ($cookie, $kv) = each %$cookies) {
391 next if $uscheme ne "https" && exists $kv->{secure};
392
393 if (exists $kv->{expires}) {
394 if (AE::now > parse_date ($kv->{expires})) {
395 delete $cookies->{$cookie};
396 next;
397 }
398 }
399
400 my $value = $kv->{value};
401
402 if ($value =~ /[=;,[:space:]]/) {
403 $value =~ s/([\\"])/\\$1/g;
404 $value = "\"$value\"";
405 }
406
407 push @cookies, "$cookie=$value";
408 }
409 }
410 }
411
412 \@cookies
413}
414
415# continue to parse $_ for headers and place them into the arg
416sub parse_hdr() {
417 my %hdr;
418
419 # things seen, not parsed:
420 # p3pP="NON CUR OTPi OUR NOR UNI"
421
422 $hdr{lc $1} .= ",$2"
423 while /\G
424 ([^:\000-\037]*):
425 [\011\040]*
426 ((?: [^\012]+ | \012[\011\040] )*)
427 \012
428 /gxc;
429
430 /\G$/
431 or return;
432
433 # remove the "," prefix we added to all headers above
434 substr $_, 0, 1, ""
435 for values %hdr;
436
437 \%hdr
438}
439
353our $qr_nlnl = qr{(?<![^\012])\015?\012}; 440our $qr_nlnl = qr{(?<![^\012])\015?\012};
354 441
355our $TLS_CTX_LOW = { cache => 1, sslv2 => 1 }; 442our $TLS_CTX_LOW = { cache => 1, sslv2 => 1 };
356our $TLS_CTX_HIGH = { cache => 1, verify => 1, verify_peername => "https" }; 443our $TLS_CTX_HIGH = { cache => 1, verify => 1, verify_peername => "https" };
357 444
376 my @pseudo = (URL => $url); 463 my @pseudo = (URL => $url);
377 push @pseudo, Redirect => delete $arg{Redirect} if exists $arg{Redirect}; 464 push @pseudo, Redirect => delete $arg{Redirect} if exists $arg{Redirect};
378 465
379 my $recurse = exists $arg{recurse} ? delete $arg{recurse} : $MAX_RECURSE; 466 my $recurse = exists $arg{recurse} ? delete $arg{recurse} : $MAX_RECURSE;
380 467
381 return $cb->(undef, { Status => 599, Reason => "Too many redirections", @pseudo }) 468 return $cb->(undef, { @pseudo, Status => 599, Reason => "Too many redirections" })
382 if $recurse < 0; 469 if $recurse < 0;
383 470
384 my $proxy = $arg{proxy} || $PROXY; 471 my $proxy = $arg{proxy} || $PROXY;
385 my $timeout = $arg{timeout} || $TIMEOUT; 472 my $timeout = $arg{timeout} || $TIMEOUT;
386 473
389 476
390 $uscheme = lc $uscheme; 477 $uscheme = lc $uscheme;
391 478
392 my $uport = $uscheme eq "http" ? 80 479 my $uport = $uscheme eq "http" ? 80
393 : $uscheme eq "https" ? 443 480 : $uscheme eq "https" ? 443
394 : return $cb->(undef, { Status => 599, Reason => "Only http and https URL schemes supported", @pseudo }); 481 : return $cb->(undef, { @pseudo, Status => 599, Reason => "Only http and https URL schemes supported" });
395 482
396 $uauthority =~ /^(?: .*\@ )? ([^\@:]+) (?: : (\d+) )?$/x 483 $uauthority =~ /^(?: .*\@ )? ([^\@:]+) (?: : (\d+) )?$/x
397 or return $cb->(undef, { Status => 599, Reason => "Unparsable URL", @pseudo }); 484 or return $cb->(undef, { @pseudo, Status => 599, Reason => "Unparsable URL" });
398 485
399 my $uhost = $1; 486 my $uhost = $1;
400 $uport = $2 if defined $2; 487 $uport = $2 if defined $2;
401 488
402 $hdr{host} = defined $2 ? "$uhost:$2" : "$uhost" 489 $hdr{host} = defined $2 ? "$uhost:$2" : "$uhost"
407 494
408 $upath =~ s%^/?%/%; 495 $upath =~ s%^/?%/%;
409 496
410 # cookie processing 497 # cookie processing
411 if (my $jar = $arg{cookie_jar}) { 498 if (my $jar = $arg{cookie_jar}) {
412 %$jar = () if $jar->{version} != 1; 499 my $cookies = cookie_jar_extract $jar, $uscheme, $uhost, $upath;
413 500
414 my @cookie;
415
416 while (my ($chost, $v) = each %$jar) {
417 if ($chost =~ /^\./) {
418 next unless $chost eq substr $uhost, -length $chost;
419 } elsif ($chost =~ /\./) {
420 next unless $chost eq $uhost;
421 } else {
422 next;
423 }
424
425 while (my ($cpath, $v) = each %$v) {
426 next unless $cpath eq substr $upath, 0, length $cpath;
427
428 while (my ($k, $v) = each %$v) {
429 next if $uscheme ne "https" && exists $v->{secure};
430 my $value = $v->{value};
431 $value =~ s/([\\"])/\\$1/g;
432 push @cookie, "$k=\"$value\"";
433 }
434 }
435 }
436
437 $hdr{cookie} = join "; ", @cookie 501 $hdr{cookie} = join "; ", @$cookies
438 if @cookie; 502 if @$cookies;
439 } 503 }
440 504
441 my ($rhost, $rport, $rscheme, $rpath); # request host, port, path 505 my ($rhost, $rport, $rscheme, $rpath); # request host, port, path
442 506
443 if ($proxy) { 507 if ($proxy) {
451 } else { 515 } else {
452 ($rhost, $rport, $rscheme, $rpath) = ($uhost, $uport, $uscheme, $upath); 516 ($rhost, $rport, $rscheme, $rpath) = ($uhost, $uport, $uscheme, $upath);
453 } 517 }
454 518
455 # leave out fragment and query string, just a heuristic 519 # leave out fragment and query string, just a heuristic
456 $hdr{referer} ||= "$uscheme://$uauthority$upath" unless exists $hdr{referer}; 520 $hdr{referer} = "$uscheme://$uauthority$upath" unless exists $hdr{referer};
457 $hdr{"user-agent"} ||= $USERAGENT unless exists $hdr{"user-agent"}; 521 $hdr{"user-agent"} = $USERAGENT unless exists $hdr{"user-agent"};
458 522
459 $hdr{"content-length"} = length $arg{body} 523 $hdr{"content-length"} = length $arg{body}
460 if length $arg{body} || $method ne "GET"; 524 if length $arg{body} || $method ne "GET";
461 525
526 $hdr{connection} = "close TE"; #1.1
527 $hdr{te} = "trailers" unless exists $hdr{te}; #1.1
528
462 my %state = (connect_guard => 1); 529 my %state = (connect_guard => 1);
463 530
464 _get_slot $uhost, sub { 531 _get_slot $uhost, sub {
465 $state{slot_guard} = shift; 532 $state{slot_guard} = shift;
466 533
467 return unless $state{connect_guard}; 534 return unless $state{connect_guard};
468 535
469 my $tcp_connect = $arg{tcp_connect} 536 my $connect_cb = sub {
470 || do { require AnyEvent::Socket; \&AnyEvent::Socket::tcp_connect };
471
472 $state{connect_guard} = $tcp_connect->(
473 $rhost,
474 $rport,
475 sub {
476 $state{fh} = shift 537 $state{fh} = shift
477 or do { 538 or do {
478 my $err = "$!"; 539 my $err = "$!";
479 %state = (); 540 %state = ();
480 return $cb->(undef, { Status => 599, Reason => $err, @pseudo }); 541 return $cb->(undef, { @pseudo, Status => 599, Reason => $err });
481 }; 542 };
482 543
483 pop; # free memory, save a tree 544 pop; # free memory, save a tree
484 545
485 return unless delete $state{connect_guard}; 546 return unless delete $state{connect_guard};
486 547
487 # get handle 548 # get handle
488 $state{handle} = new AnyEvent::Handle 549 $state{handle} = new AnyEvent::Handle
489 fh => $state{fh}, 550 fh => $state{fh},
490 peername => $rhost, 551 peername => $rhost,
491 tls_ctx => $arg{tls_ctx}, 552 tls_ctx => $arg{tls_ctx},
492 # these need to be reconfigured on keepalive handles 553 # these need to be reconfigured on keepalive handles
493 timeout => $timeout, 554 timeout => $timeout,
494 on_error => sub { 555 on_error => sub {
495 %state = (); 556 %state = ();
496 $cb->(undef, { Status => 599, Reason => $_[2], @pseudo }); 557 $cb->(undef, { @pseudo, Status => 599, Reason => $_[2] });
497 }, 558 },
498 on_eof => sub { 559 on_eof => sub {
499 %state = (); 560 %state = ();
500 $cb->(undef, { Status => 599, Reason => "Unexpected end-of-file", @pseudo }); 561 $cb->(undef, { @pseudo, Status => 599, Reason => "Unexpected end-of-file" });
501 }, 562 },
502 ; 563 ;
503 564
504 # limit the number of persistent connections 565 # limit the number of persistent connections
505 # keepalive not yet supported 566 # keepalive not yet supported
506# if ($KA_COUNT{$_[1]} < $MAX_PERSISTENT_PER_HOST) { 567# if ($KA_COUNT{$_[1]} < $MAX_PERSISTENT_PER_HOST) {
507# ++$KA_COUNT{$_[1]}; 568# ++$KA_COUNT{$_[1]};
508# $state{handle}{ka_count_guard} = AnyEvent::Util::guard { 569# $state{handle}{ka_count_guard} = AnyEvent::Util::guard {
509# --$KA_COUNT{$_[1]} 570# --$KA_COUNT{$_[1]}
510# }; 571# };
511# $hdr{connection} = "keep-alive"; 572# $hdr{connection} = "keep-alive";
512# } else {
513 delete $hdr{connection};
514# } 573# }
515 574
516 $state{handle}->starttls ("connect") if $rscheme eq "https"; 575 $state{handle}->starttls ("connect") if $rscheme eq "https";
517 576
518 # handle actual, non-tunneled, request 577 # handle actual, non-tunneled, request
519 my $handle_actual_request = sub { 578 my $handle_actual_request = sub {
520 $state{handle}->starttls ("connect") if $uscheme eq "https" && !exists $state{handle}{tls}; 579 $state{handle}->starttls ("connect") if $uscheme eq "https" && !exists $state{handle}{tls};
521 580
522 # send request 581 # send request
523 $state{handle}->push_write ( 582 $state{handle}->push_write (
524 "$method $rpath HTTP/1.0\015\012" 583 "$method $rpath HTTP/1.1\015\012"
525 . (join "", map "\u$_: $hdr{$_}\015\012", grep defined $hdr{$_}, keys %hdr) 584 . (join "", map "\u$_: $hdr{$_}\015\012", grep defined $hdr{$_}, keys %hdr)
526 . "\015\012" 585 . "\015\012"
527 . (delete $arg{body}) 586 . (delete $arg{body})
528 ); 587 );
529 588
530 # return if error occured during push_write() 589 # return if error occured during push_write()
531 return unless %state; 590 return unless %state;
532 591
533 %hdr = (); # reduce memory usage, save a kitten, also make it possible to re-use 592 %hdr = (); # reduce memory usage, save a kitten, also make it possible to re-use
534 593
535 # status line and headers 594 # status line and headers
536 $state{handle}->push_read (line => $qr_nlnl, sub { 595 $state{read_response} = sub {
537 for ("$_[1]") { 596 for ("$_[1]") {
538 y/\015//d; # weed out any \015, as they show up in the weirdest of places. 597 y/\015//d; # weed out any \015, as they show up in the weirdest of places.
539 598
540 /^HTTP\/([0-9\.]+) \s+ ([0-9]{3}) (?: \s+ ([^\015\012]*) )? \015?\012/igxc 599 /^HTTP\/([0-9\.]+) \s+ ([0-9]{3}) (?: \s+ ([^\012]*) )? \012/igxc
541 or return (%state = (), $cb->(undef, { Status => 599, Reason => "Invalid server response", @pseudo })); 600 or return (%state = (), $cb->(undef, { @pseudo, Status => 599, Reason => "Invalid server response" }));
542 601
602 # 100 Continue handling
603 # should not happen as we don't send expect: 100-continue,
604 # but we handle it just in case.
605 # since we send the request body regardless, if we get an error
606 # we are out of-sync, which we currently do NOT handle correctly.
607 return $state{handle}->push_read (line => $qr_nlnl, $state{read_response})
608 if $2 eq 100;
609
543 push @pseudo, 610 push @pseudo,
544 HTTPVersion => $1, 611 HTTPVersion => $1,
545 Status => $2, 612 Status => $2,
546 Reason => $3, 613 Reason => $3,
547 ; 614 ;
548 615
549 # things seen, not parsed: 616 my $hdr = parse_hdr
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, { Status => 599, Reason => "Garbled response headers", @pseudo })); 617 or return (%state = (), $cb->(undef, { @pseudo, Status => 599, Reason => "Garbled response headers" }));
618
619 %hdr = (%$hdr, @pseudo);
620 }
621
622 # redirect handling
623 # microsoft and other shitheads don't give a shit for following standards,
624 # try to support some common forms of broken Location headers.
625 if ($hdr{location} !~ /^(?: $ | [^:\/?\#]+ : )/x) {
626 $hdr{location} =~ s/^\.\/+//;
627
628 my $url = "$rscheme://$uhost:$uport";
629
630 unless ($hdr{location} =~ s/^\///) {
631 $url .= $upath;
632 $url =~ s/\/[^\/]*$//;
562 } 633 }
563 634
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}"; 635 $hdr{location} = "$url/$hdr{location}";
636 }
637
638 my $redirect;
639
640 if ($recurse) {
641 my $status = $hdr{Status};
642
643 # industry standard is to redirect POST as GET for
644 # 301, 302 and 303, in contrast to http/1.0 and 1.1.
645 # also, the UA should ask the user for 301 and 307 and POST,
646 # industry standard seems to be to simply follow.
647 # we go with the industry standard.
648 if ($status == 301 or $status == 302 or $status == 303) {
649 # HTTP/1.1 is unclear on how to mutate the method
650 $method = "GET" unless $method eq "HEAD";
651 $redirect = 1;
652 } elsif ($status == 307) {
653 $redirect = 1;
585 } 654 }
655 }
586 656
657 my $finish = sub { # ($data, $err_status, $err_reason[, $keepalive])
587 my $redirect; 658 my $keepalive = pop;
588 659
660 $state{handle}->destroy if $state{handle};
661 %state = ();
662
663 if (defined $_[1]) {
664 $hdr{OrigStatus} = $hdr{Status}; $hdr{Status} = $_[1];
665 $hdr{OrigReason} = $hdr{Reason}; $hdr{Reason} = $_[2];
666 }
667
668 # set-cookie processing
589 if ($recurse) { 669 if ($arg{cookie_jar}) {
590 my $status = $hdr{Status}; 670 for ($hdr{"set-cookie"}) {
671 # parse NAME=VALUE
672 my @kv;
591 673
592 # industry standard is to redirect POST as GET for 674 while (
593 # 301, 302 and 303, in contrast to http/1.0 and 1.1. 675 m{
594 # also, the UA should ask the user for 301 and 307 and POST, 676 \G\s*
595 # industry standard seems to be to simply follow. 677 (?:
596 # we go with the industry standard. 678 expires \s*=\s* ([A-Z][a-z][a-z],\ [^,;]+)
597 if ($status == 301 or $status == 302 or $status == 303) { 679 | ([^=;,[:space:]]+) \s*=\s* (?: "((?:[^\\"]+|\\.)*)" | ([^=;,[:space:]]*) )
598 # HTTP/1.1 is unclear on how to mutate the method 680 )
599 $method = "GET" unless $method eq "HEAD"; 681 }gcxsi
682 ) {
683 my $name = $2;
684 my $value = $4;
685
686 unless (defined $name) {
687 # expires
688 $name = "expires";
689 $value = $1;
690 } elsif (!defined $value) {
691 # quoted
692 $value = $3;
693 $value =~ s/\\(.)/$1/gs;
694 }
695
696 push @kv, lc $name, $value;
697
698 last unless /\G\s*;/gc;
699 }
700
701 last unless @kv;
702
703 my $name = shift @kv;
704 my %kv = (value => shift @kv, @kv);
705
706 $kv{expires} ||= format_date (AE::now + $kv{"max-age"})
707 if exists $kv{"max-age"};
708
709 my $cdom;
710 my $cpath = (delete $kv{path}) || "/";
711
712 if (exists $kv{domain}) {
713 $cdom = delete $kv{domain};
714
715 $cdom =~ s/^\.?/./; # make sure it starts with a "."
716
717 next if $cdom =~ /\.$/;
718
719 # this is not rfc-like and not netscape-like. go figure.
720 my $ndots = $cdom =~ y/.//;
721 next if $ndots < ($cdom =~ /\.[^.][^.]\.[^.][^.]$/ ? 3 : 2);
722 } else {
723 $cdom = $uhost;
724 }
725
600 $redirect = 1; 726 # store it
601 } elsif ($status == 307) { 727 $arg{cookie_jar}{version} = 1;
602 $redirect = 1; 728 $arg{cookie_jar}{$cdom}{$cpath}{$name} = \%kv;
729
730 redo if /\G\s*,/gc;
603 } 731 }
604 } 732 }
605 733
606 my $finish = sub {
607 $state{handle}->destroy if $state{handle};
608 %state = ();
609
610 # set-cookie processing
611 if ($arg{cookie_jar}) {
612 for ($_[1]{"set-cookie"}) {
613 # parse NAME=VALUE
614 my @kv;
615
616 while (/\G\s* ([^=;,[:space:]]+) \s*=\s* (?: "((?:[^\\"]+|\\.)*)" | ([^=;,[:space:]]*) )/gcxs) {
617 my $name = $1;
618 my $value = $3;
619
620 unless ($value) {
621 $value = $2;
622 $value =~ s/\\(.)/$1/gs;
623 }
624
625 push @kv, $name => $value;
626
627 last unless /\G\s*;/gc;
628 }
629
630 last unless @kv;
631
632 my $name = shift @kv;
633 my %kv = (value => shift @kv, @kv);
634
635 my $cdom;
636 my $cpath = (delete $kv{path}) || "/";
637
638 if (exists $kv{domain}) {
639 $cdom = delete $kv{domain};
640
641 $cdom =~ s/^\.?/./; # make sure it starts with a "."
642
643 next if $cdom =~ /\.$/;
644
645 # this is not rfc-like and not netscape-like. go figure.
646 my $ndots = $cdom =~ y/.//;
647 next if $ndots < ($cdom =~ /\.[^.][^.]\.[^.][^.]$/ ? 3 : 2);
648 } else {
649 $cdom = $uhost;
650 }
651
652 # store it
653 $arg{cookie_jar}{version} = 1;
654 $arg{cookie_jar}{$cdom}{$cpath}{$name} = \%kv;
655
656 redo if /\G\s*,/gc;
657 }
658 }
659
660 if ($redirect && exists $hdr{location}) { 734 if ($redirect && exists $hdr{location}) {
661 # we ignore any errors, as it is very common to receive 735 # we ignore any errors, as it is very common to receive
662 # Content-Length != 0 but no actual body 736 # Content-Length != 0 but no actual body
663 # we also access %hdr, as $_[1] might be an erro 737 # we also access %hdr, as $_[1] might be an erro
664 http_request ( 738 http_request (
665 $method => $hdr{location}, 739 $method => $hdr{location},
666 %arg, 740 %arg,
667 recurse => $recurse - 1, 741 recurse => $recurse - 1,
668 Redirect => \@_, 742 Redirect => [$_[0], \%hdr],
669 $cb); 743 $cb);
670 } else {
671 $cb->($_[0], $_[1]);
672 }
673 };
674
675 my $len = $hdr{"content-length"};
676
677 if (!$redirect && $arg{on_header} && !$arg{on_header}(\%hdr)) {
678 $finish->(undef, { Status => 598, Reason => "Request cancelled by on_header", @pseudo });
679 } elsif (
680 $hdr{Status} =~ /^(?:1..|[23]04)$/
681 or $method eq "HEAD"
682 or (defined $len && !$len)
683 ) {
684 # no body
685 $finish->("", \%hdr);
686 } else { 744 } else {
745 $cb->($_[0], \%hdr);
746 }
747 };
748
749 my $len = $hdr{"content-length"};
750
751 if (!$redirect && $arg{on_header} && !$arg{on_header}(\%hdr)) {
752 $finish->(undef, 598 => "Request cancelled by on_header");
753 } elsif (
754 $hdr{Status} =~ /^(?:1..|204|205|304)$/
755 or $method eq "HEAD"
756 or (defined $len && !$len)
757 ) {
758 # no body
759 $finish->("", undef, undef, 1);
760 } else {
687 # body handling, four different code paths 761 # body handling, many different code paths
688 # for want_body_handle, on_body (2x), normal (2x) 762 # - no body expected
689 # we might read too much here, but it does not matter yet (no pers. connections) 763 # - want_body_handle
764 # - te chunked
765 # - 2x length known (with or without on_body)
766 # - 2x length not known (with or without on_body)
690 if (!$redirect && $arg{want_body_handle}) { 767 if (!$redirect && $arg{want_body_handle}) {
691 $_[0]->on_eof (undef); 768 $_[0]->on_eof (undef);
692 $_[0]->on_error (undef); 769 $_[0]->on_error (undef);
693 $_[0]->on_read (undef); 770 $_[0]->on_read (undef);
694 771
695 $finish->(delete $state{handle}, \%hdr); 772 $finish->(delete $state{handle});
696 773
697 } elsif ($arg{on_body}) { 774 } elsif ($hdr{"transfer-encoding"} =~ /\bchunked\b/i) {
775 my $cl = 0;
776 my $body = undef;
777 my $on_body = $arg{on_body} || sub { $body .= shift; 1 };
778
698 $_[0]->on_error (sub { $finish->(undef, { Status => 599, Reason => $_[2], @pseudo }) }); 779 $_[0]->on_error (sub { $finish->(undef, 599 => $_[2]) });
780
781 my $read_chunk; $read_chunk = sub {
782 $_[1] =~ /^([0-9a-fA-F]+)/
783 or $finish->(undef, 599 => "Garbled chunked transfer encoding");
784
785 my $len = hex $1;
786
699 if ($len) { 787 if ($len) {
700 $_[0]->on_eof (undef); 788 $cl += $len;
789
790 $_[0]->push_read (chunk => $len, sub {
791 $on_body->($_[1], \%hdr)
792 or return $finish->(undef, 598 => "Request cancelled by on_body");
793
701 $_[0]->on_read (sub { 794 $_[0]->push_read (line => sub {
702 $len -= length $_[0]{rbuf}; 795 length $_[1]
703 796 and return $finish->(undef, 599 => "Garbled chunked transfer encoding");
704 $arg{on_body}(delete $_[0]{rbuf}, \%hdr) 797 $_[0]->push_read (line => $read_chunk);
705 or $finish->(undef, { Status => 598, Reason => "Request cancelled by on_body", @pseudo });
706
707 $len > 0 798 });
708 or $finish->("", \%hdr);
709 }); 799 });
710 } else { 800 } else {
711 $_[0]->on_eof (sub { 801 $hdr{"content-length"} ||= $cl;
712 $finish->("", \%hdr); 802
803 $_[0]->push_read (line => $qr_nlnl, sub {
804 if (length $_[1]) {
805 for ("$_[1]") {
806 y/\015//d; # weed out any \015, as they show up in the weirdest of places.
807
808 my $hdr = parse_hdr
809 or return $finish->(undef, 599 => "Garbled response trailers");
810
811 %hdr = (%hdr, %$hdr);
812 }
713 }); 813 }
714 $_[0]->on_read (sub { 814
715 $arg{on_body}(delete $_[0]{rbuf}, \%hdr) 815 $finish->($body, undef, undef, 1);
716 or $finish->(undef, { Status => 598, Reason => "Request cancelled by on_body", @pseudo });
717 }); 816 });
718 } 817 }
818 };
819
820 $_[0]->push_read (line => $read_chunk);
821
822 } elsif ($arg{on_body}) {
823 $_[0]->on_error (sub { $finish->(undef, 599 => $_[2]) });
824
825 if ($len) {
826 $_[0]->on_read (sub {
827 $len -= length $_[0]{rbuf};
828
829 $arg{on_body}(delete $_[0]{rbuf}, \%hdr)
830 or return $finish->(undef, 598 => "Request cancelled by on_body");
831
832 $len > 0
833 or $finish->("", undef, undef, 1);
834 });
719 } else { 835 } else {
720 $_[0]->on_eof (undef); 836 $_[0]->on_eof (sub {
721 837 $finish->("");
722 if ($len) { 838 });
723 $_[0]->on_error (sub { $finish->(undef, { Status => 599, Reason => $_[2], @pseudo }) });
724 $_[0]->on_read (sub { 839 $_[0]->on_read (sub {
840 $arg{on_body}(delete $_[0]{rbuf}, \%hdr)
841 or $finish->(undef, 598 => "Request cancelled by on_body");
842 });
843 }
844 } else {
845 $_[0]->on_eof (undef);
846
847 if ($len) {
848 $_[0]->on_error (sub { $finish->(undef, 599 => $_[2]) });
849 $_[0]->on_read (sub {
725 $finish->((substr delete $_[0]{rbuf}, 0, $len, ""), \%hdr) 850 $finish->((substr delete $_[0]{rbuf}, 0, $len, ""), undef, undef, 1)
726 if $len <= length $_[0]{rbuf}; 851 if $len <= length $_[0]{rbuf};
727 }); 852 });
728 } else { 853 } else {
729 $_[0]->on_error (sub { 854 $_[0]->on_error (sub {
730 ($! == Errno::EPIPE || !$!) 855 ($! == Errno::EPIPE || !$!)
731 ? $finish->(delete $_[0]{rbuf}, \%hdr) 856 ? $finish->(delete $_[0]{rbuf})
732 : $finish->(undef, { Status => 599, Reason => $_[2], @pseudo }); 857 : $finish->(undef, 599 => $_[2]);
733 }); 858 });
734 $_[0]->on_read (sub { }); 859 $_[0]->on_read (sub { });
735 }
736 } 860 }
737 } 861 }
738 }); 862 }
739 }; 863 };
740 864
865 $state{handle}->push_read (line => $qr_nlnl, $state{read_response});
866 };
867
741 # now handle proxy-CONNECT method 868 # now handle proxy-CONNECT method
742 if ($proxy && $uscheme eq "https") { 869 if ($proxy && $uscheme eq "https") {
743 # oh dear, we have to wrap it into a connect request 870 # oh dear, we have to wrap it into a connect request
744 871
745 # maybe re-use $uauthority with patched port? 872 # maybe re-use $uauthority with patched port?
746 $state{handle}->push_write ("CONNECT $uhost:$uport HTTP/1.0\015\012Host: $uhost\015\012\015\012"); 873 $state{handle}->push_write ("CONNECT $uhost:$uport HTTP/1.0\015\012Host: $uhost\015\012\015\012");
747 $state{handle}->push_read (line => $qr_nlnl, sub { 874 $state{handle}->push_read (line => $qr_nlnl, sub {
748 $_[1] =~ /^HTTP\/([0-9\.]+) \s+ ([0-9]{3}) (?: \s+ ([^\015\012]*) )?/ix 875 $_[1] =~ /^HTTP\/([0-9\.]+) \s+ ([0-9]{3}) (?: \s+ ([^\015\012]*) )?/ix
749 or return (%state = (), $cb->(undef, { Status => 599, Reason => "Invalid proxy connect response ($_[1])", @pseudo })); 876 or return (%state = (), $cb->(undef, { @pseudo, Status => 599, Reason => "Invalid proxy connect response ($_[1])" }));
750 877
751 if ($2 == 200) { 878 if ($2 == 200) {
752 $rpath = $upath; 879 $rpath = $upath;
753 &$handle_actual_request; 880 &$handle_actual_request;
754 } else { 881 } else {
755 %state = (); 882 %state = ();
756 $cb->(undef, { Status => $2, Reason => $3, @pseudo }); 883 $cb->(undef, { @pseudo, Status => $2, Reason => $3 });
757 }
758 }); 884 }
885 });
759 } else { 886 } else {
760 &$handle_actual_request; 887 &$handle_actual_request;
761 }
762
763 }, 888 }
764 $arg{on_prepare} || sub { $timeout }
765 ); 889 };
890
891 my $tcp_connect = $arg{tcp_connect}
892 || do { require AnyEvent::Socket; \&AnyEvent::Socket::tcp_connect };
893
894 $state{connect_guard} = $tcp_connect->($rhost, $rport, $connect_cb, $arg{on_prepare} || sub { $timeout });
895
766 }; 896 };
767 897
768 defined wantarray && AnyEvent::Util::guard { %state = () } 898 defined wantarray && AnyEvent::Util::guard { %state = () }
769} 899}
770 900
805string of the form C<http://host:port> (optionally C<https:...>), croaks 935string of the form C<http://host:port> (optionally C<https:...>), croaks
806otherwise. 936otherwise.
807 937
808To clear an already-set proxy, use C<undef>. 938To clear an already-set proxy, use C<undef>.
809 939
940=item $date = AnyEvent::HTTP::format_date $timestamp
941
942Takes a POSIX timestamp (seconds since the epoch) and formats it as a HTTP
943Date (RFC 2616).
944
945=item $timestamp = AnyEvent::HTTP::parse_date $date
946
947Takes a HTTP Date (RFC 2616) or a Cookie date (netscape cookie spec) and
948returns the corresponding POSIX timestamp, or C<undef> if the date cannot
949be parsed.
950
810=item $AnyEvent::HTTP::MAX_RECURSE 951=item $AnyEvent::HTTP::MAX_RECURSE
811 952
812The default value for the C<recurse> request parameter (default: C<10>). 953The default value for the C<recurse> request parameter (default: C<10>).
813 954
814=item $AnyEvent::HTTP::USERAGENT 955=item $AnyEvent::HTTP::USERAGENT
832connections. This number of can be useful for load-leveling. 973connections. This number of can be useful for load-leveling.
833 974
834=back 975=back
835 976
836=cut 977=cut
978
979our @month = qw(Jan Feb Mar Apr May Jun Jul Aug Sep Oct Nov Dec);
980our @weekday = qw(Sun Mon Tue Wed Thu Fri Sat);
981
982sub format_date($) {
983 my ($time) = @_;
984
985 # RFC 822/1123 format
986 my ($S, $M, $H, $mday, $mon, $year, $wday, $yday, undef) = gmtime $time;
987
988 sprintf "%s, %02d %s %04d %02d:%02d:%02d GMT",
989 $weekday[$wday], $mday, $month[$mon], $year + 1900,
990 $H, $M, $S;
991}
992
993sub parse_date($) {
994 my ($date) = @_;
995
996 my ($d, $m, $y, $H, $M, $S);
997
998 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$/) {
999 # RFC 822/1123, required by RFC 2616 (with " ")
1000 # cookie dates (with "-")
1001
1002 ($d, $m, $y, $H, $M, $S) = ($1, $2, $3, $4, $5, $6);
1003
1004 } 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$/) {
1005 # RFC 850
1006 ($d, $m, $y, $H, $M, $S) = ($1, $2, $3 < 69 ? $3 + 2000 : $3 + 1900, $4, $5, $6);
1007
1008 } 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])$/) {
1009 # ISO C's asctime
1010 ($d, $m, $y, $H, $M, $S) = ($2, $1, $6, $3, $4, $5);
1011 }
1012 # other formats fail in the loop below
1013
1014 for (0..11) {
1015 if ($m eq $month[$_]) {
1016 require Time::Local;
1017 return Time::Local::timegm ($S, $M, $H, $d, $_, $y);
1018 }
1019 }
1020
1021 undef
1022}
837 1023
838sub set_proxy($) { 1024sub set_proxy($) {
839 if (length $_[0]) { 1025 if (length $_[0]) {
840 $_[0] =~ m%^(https?):// ([^:/]+) (?: : (\d*) )?%ix 1026 $_[0] =~ m%^(https?):// ([^:/]+) (?: : (\d*) )?%ix
841 or Carp::croak "$_[0]: invalid proxy URL"; 1027 or Carp::croak "$_[0]: invalid proxy URL";
848# initialise proxy from environment 1034# initialise proxy from environment
849eval { 1035eval {
850 set_proxy $ENV{http_proxy}; 1036 set_proxy $ENV{http_proxy};
851}; 1037};
852 1038
1039=head2 SOCKS PROXIES
1040
1041Socks proxies are not directly supported by AnyEvent::HTTP. You can
1042compile your perl to support socks, or use an external program such as
1043F<socksify> (dante) or F<tsocks> to make your program use a socks proxy
1044transparently.
1045
1046Alternatively, for AnyEvent::HTTP only, you can use your own
1047C<tcp_connect> function that does the proxy handshake - here is an example
1048that works with socks4a proxies:
1049
1050 use Errno;
1051 use AnyEvent::Util;
1052 use AnyEvent::Socket;
1053 use AnyEvent::Handle;
1054
1055 # host, port and username of/for your socks4a proxy
1056 my $socks_host = "10.0.0.23";
1057 my $socks_port = 9050;
1058 my $socks_user = "";
1059
1060 sub socks4a_connect {
1061 my ($host, $port, $connect_cb, $prepare_cb) = @_;
1062
1063 my $hdl = new AnyEvent::Handle
1064 connect => [$socks_host, $socks_port],
1065 on_prepare => sub { $prepare_cb->($_[0]{fh}) },
1066 on_error => sub { $connect_cb->() },
1067 ;
1068
1069 $hdl->push_write (pack "CCnNZ*Z*", 4, 1, $port, 1, $socks_user, $host);
1070
1071 $hdl->push_read (chunk => 8, sub {
1072 my ($hdl, $chunk) = @_;
1073 my ($status, $port, $ipn) = unpack "xCna4", $chunk;
1074
1075 if ($status == 0x5a) {
1076 $connect_cb->($hdl->{fh}, (format_address $ipn) . ":$port");
1077 } else {
1078 $! = Errno::ENXIO; $connect_cb->();
1079 }
1080 });
1081
1082 $hdl
1083 }
1084
1085Use C<socks4a_connect> instead of C<tcp_connect> when doing C<http_request>s,
1086possibly after switching off other proxy types:
1087
1088 AnyEvent::HTTP::set_proxy undef; # usually you do not want other proxies
1089
1090 http_get 'http://www.google.com', tcp_connect => \&socks4a_connect, sub {
1091 my ($data, $headers) = @_;
1092 ...
1093 };
1094
853=head1 SEE ALSO 1095=head1 SEE ALSO
854 1096
855L<AnyEvent>. 1097L<AnyEvent>.
856 1098
857=head1 AUTHOR 1099=head1 AUTHOR

Diff Legend

Removed lines
+ Added lines
< Changed lines
> Changed lines