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.48 by root, Wed Aug 5 16:09:10 2009 UTC vs.
Revision 1.69 by root, Fri Dec 31 19:32:47 2010 UTC

41use strict; 41use strict;
42no warnings; 42no warnings;
43 43
44use Errno (); 44use Errno ();
45 45
46use AnyEvent 4.8 (); 46use AnyEvent 5.0 ();
47use AnyEvent::Util (); 47use AnyEvent::Util ();
48use AnyEvent::Socket ();
49use AnyEvent::Handle (); 48use AnyEvent::Handle ();
50 49
51use base Exporter::; 50use base Exporter::;
52 51
53our $VERSION = '1.42'; 52our $VERSION = '1.5';
54 53
55our @EXPORT = qw(http_get http_post http_head http_request); 54our @EXPORT = qw(http_get http_post http_head http_request);
56 55
57our $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)";
58our $MAX_RECURSE = 10; 57our $MAX_RECURSE = 10;
92must be an absolute http or https URL. 91must be an absolute http or https URL.
93 92
94When called in void context, nothing is returned. In other contexts, 93When called in void context, nothing is returned. In other contexts,
95C<http_request> returns a "cancellation guard" - you have to keep the 94C<http_request> returns a "cancellation guard" - you have to keep the
96object 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
97destroyed before the callbakc is called, the request will be cancelled. 96destroyed before the callback is called, the request will be cancelled.
98 97
99The 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
100(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
101second argument. 100(and trailers) as second argument.
102 101
103All 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
104headers, the "pseudo-headers" C<HTTPVersion>, C<Status> and C<Reason> 103headers, the "pseudo-headers" (uppercase to avoid clashing with possible
104response headers) C<HTTPVersion>, C<Status> and C<Reason> contain the
105contain the three parts of the HTTP Status-Line of the same name. The 105three parts of the HTTP Status-Line of the same name. If an error occurs
106during the body phase of a request, then the original C<Status> and
107C<Reason> values from the header are available as C<OrigStatus> and
108C<OrigReason>.
109
106pseudo-header C<URL> contains the original URL (which can differ from the 110The pseudo-header C<URL> contains the actual URL (which can differ from
107requested URL when following redirects). 111the requested URL when following redirects - for example, you might get
112an error that your URL scheme is not supported even though your URL is a
113valid http URL because it redirected to an ftp URL, in which case you can
114look at the URL pseudo header).
115
116The pseudo-header C<Redirect> only exists when the request was a result
117of an internal redirect. In that case it is an array reference with
118the C<($data, $headers)> from the redirect response. Note that this
119response could in turn be the result of a redirect itself, and C<<
120$headers->{Redirect}[1]{Redirect} >> will then contain the original
121response, and so on.
108 122
109If the server sends a header multiple times, then their contents will be 123If the server sends a header multiple times, then their contents will be
110joined together with a comma (C<,>), as per the HTTP spec. 124joined together with a comma (C<,>), as per the HTTP spec.
111 125
112If an internal error occurs, such as not being able to resolve a hostname, 126If an internal error occurs, such as not being able to resolve a hostname,
136Whether to recurse requests or not, e.g. on redirects, authentication 150Whether to recurse requests or not, e.g. on redirects, authentication
137retries and so on, and how often to do so. 151retries and so on, and how often to do so.
138 152
139=item headers => hashref 153=item headers => hashref
140 154
141The request headers to use. Currently, C<http_request> may provide its 155The request headers to use. Currently, C<http_request> may provide its own
142own C<Host:>, C<Content-Length:>, C<Connection:> and C<Cookie:> headers 156C<Host:>, C<Content-Length:>, C<Connection:> and C<Cookie:> headers and
143and 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:>
144suppressed 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
145send at all). 159they won't be sent at all).
146 160
147=item timeout => $seconds 161=item timeout => $seconds
148 162
149The 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
150the timeout, as will read or write activity. Default timeout is 5 minutes. 164the timeout, as will read or write activity, i.e. this is not an overall
165timeout.
166
167Default timeout is 5 minutes.
151 168
152=item proxy => [$host, $port[, $scheme]] or undef 169=item proxy => [$host, $port[, $scheme]] or undef
153 170
154Use the given http proxy for all requests. If not specified, then the 171Use the given http proxy for all requests. If not specified, then the
155default proxy (as specified by C<$ENV{http_proxy}>) is used. 172default proxy (as specified by C<$ENV{http_proxy}>) is used.
157C<$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
158HTTPS. 175HTTPS.
159 176
160=item body => $string 177=item body => $string
161 178
162The 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
163this module might offer more options). 180this module might offer more options).
164 181
165=item cookie_jar => $hash_ref 182=item cookie_jar => $hash_ref
166 183
167Passing this parameter enables (simplified) cookie-processing, loosely 184Passing this parameter enables (simplified) cookie-processing, loosely
175Note that this cookie implementation is not of very high quality, nor 192Note that this cookie implementation is not of very high quality, nor
176meant to be complete. If you want complete cookie management you have to 193meant to be complete. If you want complete cookie management you have to
177do that on your own. C<cookie_jar> is meant as a quick fix to get some 194do that on your own. C<cookie_jar> is meant as a quick fix to get some
178cookie-using sites working. Cookies are a privacy disaster, do not use 195cookie-using sites working. Cookies are a privacy disaster, do not use
179them unless required to. 196them unless required to.
197
198When cookie processing is enabled, the C<Cookie:> and C<Set-Cookie:>
199headers will be ste and handled by this module, otherwise they will be
200left untouched.
180 201
181=item tls_ctx => $scheme | $tls_ctx 202=item tls_ctx => $scheme | $tls_ctx
182 203
183Specifies the AnyEvent::TLS context to be used for https connections. This 204Specifies the AnyEvent::TLS context to be used for https connections. This
184parameter follows the same rules as the C<tls_ctx> parameter to 205parameter follows the same rules as the C<tls_ctx> parameter to
188verification) TLS context. 209verification) TLS context.
189 210
190The default for this option is C<low>, which could be interpreted as "give 211The default for this option is C<low>, which could be interpreted as "give
191me the page, no matter what". 212me the page, no matter what".
192 213
214=item on_prepare => $callback->($fh)
215
216In rare cases you need to "tune" the socket before it is used to
217connect (for exmaple, to bind it on a given IP address). This parameter
218overrides the prepare callback passed to C<AnyEvent::Socket::tcp_connect>
219and behaves exactly the same way (e.g. it has to provide a
220timeout). See the description for the C<$prepare_cb> argument of
221C<AnyEvent::Socket::tcp_connect> for details.
222
223=item tcp_connect => $callback->($host, $service, $connect_cb, $prepare_cb)
224
225In even rarer cases you want total control over how AnyEvent::HTTP
226establishes connections. Normally it uses L<AnyEvent::Socket::tcp_connect>
227to do this, but you can provide your own C<tcp_connect> function -
228obviously, it has to follow the same calling conventions, except that it
229may always return a connection guard object.
230
231There are probably lots of weird uses for this function, starting from
232tracing the hosts C<http_request> actually tries to connect, to (inexact
233but fast) host => IP address caching or even socks protocol support.
234
193=item on_header => $callback->($headers) 235=item on_header => $callback->($headers)
194 236
195When specified, this callback will be called with the header hash as soon 237When specified, this callback will be called with the header hash as soon
196as headers have been successfully received from the remote server (not on 238as headers have been successfully received from the remote server (not on
197locally-generated errors). 239locally-generated errors).
202 244
203This callback is useful, among other things, to quickly reject unwanted 245This callback is useful, among other things, to quickly reject unwanted
204content, 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
205doing a C<HEAD> request. 247doing a C<HEAD> request.
206 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
207Example: cancel the request unless the content-type is "text/html". 253Example: cancel the request unless the content-type is "text/html".
208 254
209 on_header => sub { 255 on_header => sub {
210 $_[0]{"content-type"} =~ /^text\/html\s*(?:;|$)/ 256 $_[0]{"content-type"} =~ /^text\/html\s*(?:;|$)/
211 }, 257 },
217string instead of the body data. 263string instead of the body data.
218 264
219It 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),
220or 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
221the 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.
222 271
223This 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
224(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
225be extracted, or when the body should be processed incrementally. 274be extracted, or when the body should be processed incrementally.
226 275
252If 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
253that doesn't solve your problem in a better way. 302that doesn't solve your problem in a better way.
254 303
255=back 304=back
256 305
257Example: 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.
258 308
259 http_request GET => "http://www.nethype.de/", sub { 309 http_request GET => "http://www.nethype.de/", sub {
260 my ($body, $hdr) = @_; 310 my ($body, $hdr) = @_;
261 print "$body\n"; 311 print "$body\n";
262 }; 312 };
263 313
264Example: 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
265timeout of 30 seconds. 315timeout of 30 seconds.
266 316
267 http_request 317 http_request
268 GET => "https://www.google.com", 318 GET => "https://www.google.com",
269 timeout => 30, 319 timeout => 30,
272 use Data::Dumper; 322 use Data::Dumper;
273 print Dumper $hdr; 323 print Dumper $hdr;
274 } 324 }
275 ; 325 ;
276 326
277Example: make another simple HTTP GET request, but immediately try to 327Example: do another simple HTTP GET request, but immediately try to
278cancel it. 328cancel it.
279 329
280 my $request = http_request GET => "http://www.nethype.de/", sub { 330 my $request = http_request GET => "http://www.nethype.de/", sub {
281 my ($body, $hdr) = @_; 331 my ($body, $hdr) = @_;
282 print "$body\n"; 332 print "$body\n";
314 push @{ $CO_SLOT{$_[0]}[1] }, $_[1]; 364 push @{ $CO_SLOT{$_[0]}[1] }, $_[1];
315 365
316 _slot_schedule $_[0]; 366 _slot_schedule $_[0];
317} 367}
318 368
319our $qr_nl = qr{\015?\012}; 369# continue to parse $_ for headers and place them into the arg
370sub parse_hdr() {
371 my %hdr;
372
373 # things seen, not parsed:
374 # p3pP="NON CUR OTPi OUR NOR UNI"
375
376 $hdr{lc $1} .= ",$2"
377 while /\G
378 ([^:\000-\037]*):
379 [\011\040]*
380 ((?: [^\012]+ | \012[\011\040] )*)
381 \012
382 /gxc;
383
384 /\G$/
385 or return;
386
387 # remove the "," prefix we added to all headers above
388 substr $_, 0, 1, ""
389 for values %hdr;
390
391 \%hdr
392}
393
320our $qr_nlnl = qr{(?<![^\012])\015?\012}; 394our $qr_nlnl = qr{(?<![^\012])\015?\012};
321 395
322our $TLS_CTX_LOW = { cache => 1, sslv2 => 1 }; 396our $TLS_CTX_LOW = { cache => 1, sslv2 => 1 };
323our $TLS_CTX_HIGH = { cache => 1, verify => 1, verify_peername => "https" }; 397our $TLS_CTX_HIGH = { cache => 1, verify => 1, verify_peername => "https" };
324 398
337 while (my ($k, $v) = each %$hdr) { 411 while (my ($k, $v) = each %$hdr) {
338 $hdr{lc $k} = $v; 412 $hdr{lc $k} = $v;
339 } 413 }
340 } 414 }
341 415
416 # pseudo headers for all subsequent responses
417 my @pseudo = (URL => $url);
418 push @pseudo, Redirect => delete $arg{Redirect} if exists $arg{Redirect};
419
342 my $recurse = exists $arg{recurse} ? delete $arg{recurse} : $MAX_RECURSE; 420 my $recurse = exists $arg{recurse} ? delete $arg{recurse} : $MAX_RECURSE;
343 421
344 return $cb->(undef, { Status => 599, Reason => "Too many redirections", URL => $url }) 422 return $cb->(undef, { @pseudo, Status => 599, Reason => "Too many redirections" })
345 if $recurse < 0; 423 if $recurse < 0;
346 424
347 my $proxy = $arg{proxy} || $PROXY; 425 my $proxy = $arg{proxy} || $PROXY;
348 my $timeout = $arg{timeout} || $TIMEOUT; 426 my $timeout = $arg{timeout} || $TIMEOUT;
349 427
350 my ($uscheme, $uauthority, $upath, $query, $fragment) = 428 my ($uscheme, $uauthority, $upath, $query, $fragment) =
351 $url =~ m|(?:([^:/?#]+):)?(?://([^/?#]*))?([^?#]*)(?:\?([^#]*))?(?:#(.*))?|; 429 $url =~ m|(?:([^:/?#]+):)?(?://([^/?#]*))?([^?#]*)(?:(\?[^#]*))?(?:#(.*))?|;
352 430
353 $uscheme = lc $uscheme; 431 $uscheme = lc $uscheme;
354 432
355 my $uport = $uscheme eq "http" ? 80 433 my $uport = $uscheme eq "http" ? 80
356 : $uscheme eq "https" ? 443 434 : $uscheme eq "https" ? 443
357 : return $cb->(undef, { Status => 599, Reason => "Only http and https URL schemes supported", URL => $url }); 435 : return $cb->(undef, { @pseudo, Status => 599, Reason => "Only http and https URL schemes supported" });
358 436
359 $uauthority =~ /^(?: .*\@ )? ([^\@:]+) (?: : (\d+) )?$/x 437 $uauthority =~ /^(?: .*\@ )? ([^\@:]+) (?: : (\d+) )?$/x
360 or return $cb->(undef, { Status => 599, Reason => "Unparsable URL", URL => $url }); 438 or return $cb->(undef, { @pseudo, Status => 599, Reason => "Unparsable URL" });
361 439
362 my $uhost = $1; 440 my $uhost = $1;
363 $uport = $2 if defined $2; 441 $uport = $2 if defined $2;
364 442
365 $hdr{host} = defined $2 ? "$uhost:$2" : "$uhost"; 443 $hdr{host} = defined $2 ? "$uhost:$2" : "$uhost"
444 unless exists $hdr{host};
366 445
367 $uhost =~ s/^\[(.*)\]$/$1/; 446 $uhost =~ s/^\[(.*)\]$/$1/;
368 $upath .= "?$query" if length $query; 447 $upath .= $query if length $query;
369 448
370 $upath =~ s%^/?%/%; 449 $upath =~ s%^/?%/%;
371 450
372 # cookie processing 451 # cookie processing
373 if (my $jar = $arg{cookie_jar}) { 452 if (my $jar = $arg{cookie_jar}) {
413 } else { 492 } else {
414 ($rhost, $rport, $rscheme, $rpath) = ($uhost, $uport, $uscheme, $upath); 493 ($rhost, $rport, $rscheme, $rpath) = ($uhost, $uport, $uscheme, $upath);
415 } 494 }
416 495
417 # leave out fragment and query string, just a heuristic 496 # leave out fragment and query string, just a heuristic
418 $hdr{referer} ||= "$uscheme://$uauthority$upath" unless exists $hdr{referer}; 497 $hdr{referer} = "$uscheme://$uauthority$upath" unless exists $hdr{referer};
419 $hdr{"user-agent"} ||= $USERAGENT unless exists $hdr{"user-agent"}; 498 $hdr{"user-agent"} = $USERAGENT unless exists $hdr{"user-agent"};
420 499
421 $hdr{"content-length"} = length $arg{body}; 500 $hdr{"content-length"} = length $arg{body}
501 if length $arg{body} || $method ne "GET";
502
503 $hdr{connection} = "close TE"; #1.1
504 $hdr{te} = "trailers" unless exists $hdr{te}; #1.1
422 505
423 my %state = (connect_guard => 1); 506 my %state = (connect_guard => 1);
424 507
425 _get_slot $uhost, sub { 508 _get_slot $uhost, sub {
426 $state{slot_guard} = shift; 509 $state{slot_guard} = shift;
427 510
428 return unless $state{connect_guard}; 511 return unless $state{connect_guard};
429 512
430 $state{connect_guard} = AnyEvent::Socket::tcp_connect $rhost, $rport, sub { 513 my $connect_cb = sub {
431 $state{fh} = shift 514 $state{fh} = shift
432 or do { 515 or do {
433 my $err = "$!"; 516 my $err = "$!";
434 %state = (); 517 %state = ();
435 return $cb->(undef, { Status => 599, Reason => $err, URL => $url }); 518 return $cb->(undef, { @pseudo, Status => 599, Reason => $err });
436 }; 519 };
437 520
438 pop; # free memory, save a tree 521 pop; # free memory, save a tree
439 522
440 return unless delete $state{connect_guard}; 523 return unless delete $state{connect_guard};
441 524
442 # get handle 525 # get handle
443 $state{handle} = new AnyEvent::Handle 526 $state{handle} = new AnyEvent::Handle
444 fh => $state{fh}, 527 fh => $state{fh},
528 peername => $rhost,
529 tls_ctx => $arg{tls_ctx},
530 # these need to be reconfigured on keepalive handles
445 timeout => $timeout, 531 timeout => $timeout,
446 peername => $rhost, 532 on_error => sub {
447 tls_ctx => $arg{tls_ctx}; 533 %state = ();
534 $cb->(undef, { @pseudo, Status => 599, Reason => $_[2] });
535 },
536 on_eof => sub {
537 %state = ();
538 $cb->(undef, { @pseudo, Status => 599, Reason => "Unexpected end-of-file" });
539 },
540 ;
448 541
449 # limit the number of persistent connections 542 # limit the number of persistent connections
450 # keepalive not yet supported 543 # keepalive not yet supported
451 if ($KA_COUNT{$_[1]} < $MAX_PERSISTENT_PER_HOST) { 544# if ($KA_COUNT{$_[1]} < $MAX_PERSISTENT_PER_HOST) {
452 ++$KA_COUNT{$_[1]}; 545# ++$KA_COUNT{$_[1]};
453 $state{handle}{ka_count_guard} = AnyEvent::Util::guard { 546# $state{handle}{ka_count_guard} = AnyEvent::Util::guard {
454 --$KA_COUNT{$_[1]} 547# --$KA_COUNT{$_[1]}
455 }; 548# };
456 $hdr{connection} = "keep-alive"; 549# $hdr{connection} = "keep-alive";
457 } else {
458 delete $hdr{connection};
459 } 550# }
460
461 # (re-)configure handle
462 $state{handle}->on_error (sub {
463 %state = ();
464 $cb->(undef, { Status => 599, Reason => $_[2], URL => $url });
465 });
466 $state{handle}->on_eof (sub {
467 %state = ();
468 $cb->(undef, { Status => 599, Reason => "Unexpected end-of-file", URL => $url });
469 });
470 551
471 $state{handle}->starttls ("connect") if $rscheme eq "https"; 552 $state{handle}->starttls ("connect") if $rscheme eq "https";
472 553
473 # handle actual, non-tunneled, request 554 # handle actual, non-tunneled, request
474 my $handle_actual_request = sub { 555 my $handle_actual_request = sub {
475 $state{handle}->starttls ("connect") if $uscheme eq "https" && !exists $state{handle}{tls}; 556 $state{handle}->starttls ("connect") if $uscheme eq "https" && !exists $state{handle}{tls};
476 557
477 # send request 558 # send request
478 $state{handle}->push_write ( 559 $state{handle}->push_write (
479 "$method $rpath HTTP/1.0\015\012" 560 "$method $rpath HTTP/1.1\015\012"
480 . (join "", map "\u$_: $hdr{$_}\015\012", grep defined $hdr{$_}, keys %hdr) 561 . (join "", map "\u$_: $hdr{$_}\015\012", grep defined $hdr{$_}, keys %hdr)
481 . "\015\012" 562 . "\015\012"
482 . (delete $arg{body}) 563 . (delete $arg{body})
483 ); 564 );
484 565
566 # return if error occured during push_write()
567 return unless %state;
568
485 %hdr = (); # reduce memory usage, save a kitten 569 %hdr = (); # reduce memory usage, save a kitten, also make it possible to re-use
486 570
487 # status line 571 # status line and headers
488 $state{handle}->push_read (line => $qr_nl, sub { 572 $state{read_response} = sub {
489 $_[1] =~ /^HTTP\/([0-9\.]+) \s+ ([0-9]{3}) (?: \s+ ([^\015\012]*) )?/ix
490 or return (%state = (), $cb->(undef, { Status => 599, Reason => "Invalid server response ($_[1])", URL => $url }));
491
492 my %hdr = ( # response headers
493 HTTPVersion => ",$1",
494 Status => ",$2",
495 Reason => ",$3",
496 URL => ",$url"
497 );
498
499 # headers, could be optimized a bit
500 $state{handle}->unshift_read (line => $qr_nlnl, sub {
501 for ("$_[1]") { 573 for ("$_[1]") {
502 y/\015//d; # weed out any \015, as they show up in the weirdest of places. 574 y/\015//d; # weed out any \015, as they show up in the weirdest of places.
503 575
504 # things seen, not parsed: 576 /^HTTP\/([0-9\.]+) \s+ ([0-9]{3}) (?: \s+ ([^\012]*) )? \012/igxc
505 # p3pP="NON CUR OTPi OUR NOR UNI" 577 or return (%state = (), $cb->(undef, { @pseudo, Status => 599, Reason => "Invalid server response" }));
506 578
507 $hdr{lc $1} .= ",$2" 579 # 100 Continue handling
508 while /\G 580 # should not happen as we don't send expect: 100-continue,
509 ([^:\000-\037]*): 581 # but we handle it just in case.
510 [\011\040]* 582 # since we send the request body regardless, if we get an error
511 ((?: [^\012]+ | \012[\011\040] )*) 583 # we are out of-sync, which we currently do NOT handle correctly.
512 \012 584 return $state{handle}->push_read (line => $qr_nlnl, $state{read_response})
513 /gxc; 585 if $2 eq 100;
514 586
587 push @pseudo,
588 HTTPVersion => $1,
589 Status => $2,
590 Reason => $3,
515 /\G$/ 591 ;
592
593 my $hdr = parse_hdr
516 or return (%state = (), $cb->(undef, { Status => 599, Reason => "Garbled response headers", URL => $url })); 594 or return (%state = (), $cb->(undef, { @pseudo, Status => 599, Reason => "Garbled response headers" }));
595
596 %hdr = (%$hdr, @pseudo);
597 }
598
599 # redirect handling
600 # microsoft and other shitheads don't give a shit for following standards,
601 # try to support some common forms of broken Location headers.
602 if ($hdr{location} !~ /^(?: $ | [^:\/?\#]+ : )/x) {
603 $hdr{location} =~ s/^\.\/+//;
604
605 my $url = "$rscheme://$uhost:$uport";
606
607 unless ($hdr{location} =~ s/^\///) {
608 $url .= $upath;
609 $url =~ s/\/[^\/]*$//;
517 } 610 }
518 611
519 substr $_, 0, 1, ""
520 for values %hdr;
521
522 # redirect handling
523 # microsoft and other shitheads don't give a shit for following standards,
524 # try to support some common forms of broken Location headers.
525 if ($hdr{location} !~ /^(?: $ | [^:\/?\#]+ : )/x) {
526 $hdr{location} =~ s/^\.\/+//;
527
528 my $url = "$rscheme://$uhost:$uport";
529
530 unless ($hdr{location} =~ s/^\///) {
531 $url .= $upath;
532 $url =~ s/\/[^\/]*$//;
533 }
534
535 $hdr{location} = "$url/$hdr{location}"; 612 $hdr{location} = "$url/$hdr{location}";
613 }
614
615 my $redirect;
616
617 if ($recurse) {
618 my $status = $hdr{Status};
619
620 # industry standard is to redirect POST as GET for
621 # 301, 302 and 303, in contrast to http/1.0 and 1.1.
622 # also, the UA should ask the user for 301 and 307 and POST,
623 # industry standard seems to be to simply follow.
624 # we go with the industry standard.
625 if ($status == 301 or $status == 302 or $status == 303) {
626 # HTTP/1.1 is unclear on how to mutate the method
627 $method = "GET" unless $method eq "HEAD";
628 $redirect = 1;
629 } elsif ($status == 307) {
630 $redirect = 1;
536 } 631 }
632 }
537 633
634 my $finish = sub { # ($data, $err_status, $err_reason[, $keepalive])
538 my $redirect; 635 my $keepalive = pop;
539 636
637 $state{handle}->destroy if $state{handle};
638 %state = ();
639
640 if (defined $_[1]) {
641 $hdr{OrigStatus} = $hdr{Status}; $hdr{Status} = $_[1];
642 $hdr{OrigReason} = $hdr{Reason}; $hdr{Reason} = $_[2];
643 }
644
645 # set-cookie processing
540 if ($recurse) { 646 if ($arg{cookie_jar}) {
541 if ($hdr{Status} =~ /^30[12]$/ && $method ne "POST") { 647 for ($hdr{"set-cookie"}) {
542 # apparently, mozilla et al. just change POST to GET here 648 # parse NAME=VALUE
543 # more research is needed before we do the same 649 my @kv;
650
651 while (/\G\s* ([^=;,[:space:]]+) \s*=\s* (?: "((?:[^\\"]+|\\.)*)" | ([^=;,[:space:]]*) )/gcxs) {
544 $redirect = 1; 652 my $name = $1;
545 } elsif ($hdr{Status} == 303) { 653 my $value = $3;
546 # even http/1.1 is unclear on how to mutate the method 654
547 $method = "GET" unless $method eq "HEAD"; 655 unless ($value) {
656 $value = $2;
657 $value =~ s/\\(.)/$1/gs;
658 }
659
660 push @kv, $name => $value;
661
662 last unless /\G\s*;/gc;
663 }
664
665 last unless @kv;
666
667 my $name = shift @kv;
668 my %kv = (value => shift @kv, @kv);
669
670 my $cdom;
671 my $cpath = (delete $kv{path}) || "/";
672
673 if (exists $kv{domain}) {
674 $cdom = delete $kv{domain};
675
676 $cdom =~ s/^\.?/./; # make sure it starts with a "."
677
678 next if $cdom =~ /\.$/;
679
680 # this is not rfc-like and not netscape-like. go figure.
681 my $ndots = $cdom =~ y/.//;
682 next if $ndots < ($cdom =~ /\.[^.][^.]\.[^.][^.]$/ ? 3 : 2);
683 } else {
684 $cdom = $uhost;
685 }
686
548 $redirect = 1; 687 # store it
549 } elsif ($hdr{Status} == 307 && $method =~ /^(?:GET|HEAD)$/) { 688 $arg{cookie_jar}{version} = 1;
550 $redirect = 1; 689 $arg{cookie_jar}{$cdom}{$cpath}{$name} = \%kv;
690
691 redo if /\G\s*,/gc;
551 } 692 }
552 } 693 }
553 694
554 my $finish = sub {
555 $state{handle}->destroy if $state{handle};
556 %state = ();
557
558 # set-cookie processing
559 if ($arg{cookie_jar}) {
560 for ($_[1]{"set-cookie"}) {
561 # parse NAME=VALUE
562 my @kv;
563
564 while (/\G\s* ([^=;,[:space:]]+) \s*=\s* (?: "((?:[^\\"]+|\\.)*)" | ([^=;,[:space:]]*) )/gcxs) {
565 my $name = $1;
566 my $value = $3;
567
568 unless ($value) {
569 $value = $2;
570 $value =~ s/\\(.)/$1/gs;
571 }
572
573 push @kv, $name => $value;
574
575 last unless /\G\s*;/gc;
576 }
577
578 last unless @kv;
579
580 my $name = shift @kv;
581 my %kv = (value => shift @kv, @kv);
582
583 my $cdom;
584 my $cpath = (delete $kv{path}) || "/";
585
586 if (exists $kv{domain}) {
587 $cdom = delete $kv{domain};
588
589 $cdom =~ s/^\.?/./; # make sure it starts with a "."
590
591 next if $cdom =~ /\.$/;
592
593 # this is not rfc-like and not netscape-like. go figure.
594 my $ndots = $cdom =~ y/.//;
595 next if $ndots < ($cdom =~ /\.[^.][^.]\.[^.][^.]$/ ? 3 : 2);
596 } else {
597 $cdom = $uhost;
598 }
599
600 # store it
601 $arg{cookie_jar}{version} = 1;
602 $arg{cookie_jar}{$cdom}{$cpath}{$name} = \%kv;
603
604 redo if /\G\s*,/gc;
605 }
606 }
607
608 if ($redirect && exists $hdr{location}) { 695 if ($redirect && exists $hdr{location}) {
609 # we ignore any errors, as it is very common to receive 696 # we ignore any errors, as it is very common to receive
610 # Content-Length != 0 but no actual body 697 # Content-Length != 0 but no actual body
611 # we also access %hdr, as $_[1] might be an erro 698 # we also access %hdr, as $_[1] might be an erro
612 http_request ($method => $hdr{location}, %arg, recurse => $recurse - 1, $cb); 699 http_request (
613 } else { 700 $method => $hdr{location},
614 $cb->($_[0], $_[1]);
615 } 701 %arg,
702 recurse => $recurse - 1,
703 Redirect => [$_[0], \%hdr],
616 }; 704 $cb);
617
618 my $len = $hdr{"content-length"};
619
620 if (!$redirect && $arg{on_header} && !$arg{on_header}(\%hdr)) {
621 $finish->(undef, { Status => 598, Reason => "Request cancelled by on_header", URL => $url });
622 } elsif (
623 $hdr{Status} =~ /^(?:1..|[23]04)$/
624 or $method eq "HEAD"
625 or (defined $len && !$len)
626 ) {
627 # no body
628 $finish->("", \%hdr);
629 } else { 705 } else {
706 $cb->($_[0], \%hdr);
707 }
708 };
709
710 my $len = $hdr{"content-length"};
711
712 if (!$redirect && $arg{on_header} && !$arg{on_header}(\%hdr)) {
713 $finish->(undef, 598 => "Request cancelled by on_header");
714 } elsif (
715 $hdr{Status} =~ /^(?:1..|204|205|304)$/
716 or $method eq "HEAD"
717 or (defined $len && !$len)
718 ) {
719 # no body
720 $finish->("", undef, undef, 1);
721 } else {
630 # body handling, four different code paths 722 # body handling, many different code paths
631 # for want_body_handle, on_body (2x), normal (2x) 723 # - no body expected
632 # we might read too much here, but it does not matter yet (no pers. connections) 724 # - want_body_handle
725 # - te chunked
726 # - 2x length known (with or without on_body)
727 # - 2x length not known (with or without on_body)
633 if (!$redirect && $arg{want_body_handle}) { 728 if (!$redirect && $arg{want_body_handle}) {
634 $_[0]->on_eof (undef); 729 $_[0]->on_eof (undef);
635 $_[0]->on_error (undef); 730 $_[0]->on_error (undef);
636 $_[0]->on_read (undef); 731 $_[0]->on_read (undef);
637 732
638 $finish->(delete $state{handle}, \%hdr); 733 $finish->(delete $state{handle});
639 734
640 } elsif ($arg{on_body}) { 735 } elsif ($hdr{"transfer-encoding"} =~ /\bchunked\b/i) {
736 my $cl = 0;
737 my $body = undef;
738 my $on_body = $arg{on_body} || sub { $body .= shift; 1 };
739
641 $_[0]->on_error (sub { $finish->(undef, { Status => 599, Reason => $_[2], URL => $url }) }); 740 $_[0]->on_error (sub { $finish->(undef, 599 => $_[2]) });
741
742 my $read_chunk; $read_chunk = sub {
743 $_[1] =~ /^([0-9a-fA-F]+)/
744 or $finish->(undef, 599 => "Garbled chunked transfer encoding");
745
746 my $len = hex $1;
747
642 if ($len) { 748 if ($len) {
643 $_[0]->on_eof (undef); 749 $cl += $len;
750
751 $_[0]->push_read (chunk => $len, sub {
752 $on_body->($_[1], \%hdr)
753 or return $finish->(undef, 598 => "Request cancelled by on_body");
754
644 $_[0]->on_read (sub { 755 $_[0]->push_read (line => sub {
645 $len -= length $_[0]{rbuf}; 756 length $_[1]
646 757 and return $finish->(undef, 599 => "Garbled chunked transfer encoding");
647 $arg{on_body}(delete $_[0]{rbuf}, \%hdr) 758 $_[0]->push_read (line => $read_chunk);
648 or $finish->(undef, { Status => 598, Reason => "Request cancelled by on_body", URL => $url });
649
650 $len > 0 759 });
651 or $finish->("", \%hdr);
652 }); 760 });
653 } else { 761 } else {
654 $_[0]->on_eof (sub { 762 $hdr{"content-length"} ||= $cl;
655 $finish->("", \%hdr); 763
764 $_[0]->push_read (line => $qr_nlnl, sub {
765 if (length $_[1]) {
766 for ("$_[1]") {
767 y/\015//d; # weed out any \015, as they show up in the weirdest of places.
768
769 my $hdr = parse_hdr
770 or return $finish->(undef, 599 => "Garbled response trailers");
771
772 %hdr = (%hdr, %$hdr);
773 }
656 }); 774 }
657 $_[0]->on_read (sub { 775
658 $arg{on_body}(delete $_[0]{rbuf}, \%hdr) 776 $finish->($body, undef, undef, 1);
659 or $finish->(undef, { Status => 598, Reason => "Request cancelled by on_body", URL => $url });
660 }); 777 });
661 } 778 }
779 };
780
781 $_[0]->push_read (line => $read_chunk);
782
783 } elsif ($arg{on_body}) {
784 $_[0]->on_error (sub { $finish->(undef, 599 => $_[2]) });
785
786 if ($len) {
787 $_[0]->on_read (sub {
788 $len -= length $_[0]{rbuf};
789
790 $arg{on_body}(delete $_[0]{rbuf}, \%hdr)
791 or return $finish->(undef, 598 => "Request cancelled by on_body");
792
793 $len > 0
794 or $finish->("", undef, undef, 1);
795 });
662 } else { 796 } else {
663 $_[0]->on_eof (undef); 797 $_[0]->on_eof (sub {
664 798 $finish->("");
665 if ($len) { 799 });
666 $_[0]->on_error (sub { $finish->(undef, { Status => 599, Reason => $_[2], URL => $url }) });
667 $_[0]->on_read (sub { 800 $_[0]->on_read (sub {
801 $arg{on_body}(delete $_[0]{rbuf}, \%hdr)
802 or $finish->(undef, 598 => "Request cancelled by on_body");
803 });
804 }
805 } else {
806 $_[0]->on_eof (undef);
807
808 if ($len) {
809 $_[0]->on_error (sub { $finish->(undef, 599 => $_[2]) });
810 $_[0]->on_read (sub {
668 $finish->((substr delete $_[0]{rbuf}, 0, $len, ""), \%hdr) 811 $finish->((substr delete $_[0]{rbuf}, 0, $len, ""), undef, undef, 1)
669 if $len <= length $_[0]{rbuf}; 812 if $len <= length $_[0]{rbuf};
670 }); 813 });
671 } else { 814 } else {
672 $_[0]->on_error (sub { 815 $_[0]->on_error (sub {
673 $! == Errno::EPIPE || !$! 816 ($! == Errno::EPIPE || !$!)
674 ? $finish->(delete $_[0]{rbuf}, \%hdr) 817 ? $finish->(delete $_[0]{rbuf})
675 : $finish->(undef, { Status => 599, Reason => $_[2], URL => $url }); 818 : $finish->(undef, 599 => $_[2]);
676 }); 819 });
677 $_[0]->on_read (sub { }); 820 $_[0]->on_read (sub { });
678 }
679 } 821 }
680 } 822 }
681 }); 823 }
682 }); 824 };
825
826 $state{handle}->push_read (line => $qr_nlnl, $state{read_response});
683 }; 827 };
684 828
685 # now handle proxy-CONNECT method 829 # now handle proxy-CONNECT method
686 if ($proxy && $uscheme eq "https") { 830 if ($proxy && $uscheme eq "https") {
687 # oh dear, we have to wrap it into a connect request 831 # oh dear, we have to wrap it into a connect request
688 832
689 # maybe re-use $uauthority with patched port? 833 # maybe re-use $uauthority with patched port?
690 $state{handle}->push_write ("CONNECT $uhost:$uport HTTP/1.0\015\012Host: $uhost\015\012\015\012"); 834 $state{handle}->push_write ("CONNECT $uhost:$uport HTTP/1.0\015\012Host: $uhost\015\012\015\012");
691 $state{handle}->push_read (line => $qr_nlnl, sub { 835 $state{handle}->push_read (line => $qr_nlnl, sub {
692 $_[1] =~ /^HTTP\/([0-9\.]+) \s+ ([0-9]{3}) (?: \s+ ([^\015\012]*) )?/ix 836 $_[1] =~ /^HTTP\/([0-9\.]+) \s+ ([0-9]{3}) (?: \s+ ([^\015\012]*) )?/ix
693 or return (%state = (), $cb->(undef, { Status => 599, Reason => "Invalid proxy connect response ($_[1])", URL => $url })); 837 or return (%state = (), $cb->(undef, { @pseudo, Status => 599, Reason => "Invalid proxy connect response ($_[1])" }));
694 838
695 if ($2 == 200) { 839 if ($2 == 200) {
696 $rpath = $upath; 840 $rpath = $upath;
697 &$handle_actual_request; 841 &$handle_actual_request;
698 } else { 842 } else {
699 %state = (); 843 %state = ();
700 $cb->(undef, { Status => $2, Reason => $3, URL => $url }); 844 $cb->(undef, { @pseudo, Status => $2, Reason => $3 });
701 } 845 }
702 }); 846 });
703 } else { 847 } else {
704 &$handle_actual_request; 848 &$handle_actual_request;
705 } 849 }
706
707 }, sub {
708 $timeout
709 }; 850 };
851
852 my $tcp_connect = $arg{tcp_connect}
853 || do { require AnyEvent::Socket; \&AnyEvent::Socket::tcp_connect };
854
855 $state{connect_guard} = $tcp_connect->($rhost, $rport, $connect_cb, $arg{on_prepare} || sub { $timeout });
856
710 }; 857 };
711 858
712 defined wantarray && AnyEvent::Util::guard { %state = () } 859 defined wantarray && AnyEvent::Util::guard { %state = () }
713} 860}
714 861
728 &http_request 875 &http_request
729} 876}
730 877
731=back 878=back
732 879
880=head2 DNS CACHING
881
882AnyEvent::HTTP uses the AnyEvent::Socket::tcp_connect function for
883the actual connection, which in turn uses AnyEvent::DNS to resolve
884hostnames. The latter is a simple stub resolver and does no caching
885on its own. If you want DNS caching, you currently have to provide
886your own default resolver (by storing a suitable resolver object in
887C<$AnyEvent::DNS::RESOLVER>).
888
733=head2 GLOBAL FUNCTIONS AND VARIABLES 889=head2 GLOBAL FUNCTIONS AND VARIABLES
734 890
735=over 4 891=over 4
736 892
737=item AnyEvent::HTTP::set_proxy "proxy-url" 893=item AnyEvent::HTTP::set_proxy "proxy-url"
738 894
739Sets the default proxy server to use. The proxy-url must begin with a 895Sets the default proxy server to use. The proxy-url must begin with a
740string of the form C<http://host:port> (optionally C<https:...>). 896string of the form C<http://host:port> (optionally C<https:...>), croaks
897otherwise.
898
899To clear an already-set proxy, use C<undef>.
900
901=item $date = AnyEvent::HTTP::format_date $timestamp
902
903Takes a POSIX timestamp (seconds since the epoch) and formats it as a HTTP
904Date (RFC 2616).
905
906=item $timestamp = AnyEvent::HTTP::parse_date $date
907
908Takes a HTTP Date (RFC 2616) and returns the corresponding POSIX
909timestamp, or C<undef> if the date cannot be parsed.
741 910
742=item $AnyEvent::HTTP::MAX_RECURSE 911=item $AnyEvent::HTTP::MAX_RECURSE
743 912
744The default value for the C<recurse> request parameter (default: C<10>). 913The default value for the C<recurse> request parameter (default: C<10>).
745 914
765 934
766=back 935=back
767 936
768=cut 937=cut
769 938
939our @month = qw(Jan Feb Mar Apr May Jun Jul Aug Sep Oct Nov Dec);
940our @weekday = qw(Sun Mon Tue Wed Thu Fri Sat);
941
942sub format_date($) {
943 my ($time) = @_;
944
945 # RFC 822/1123 format
946 my ($S, $M, $H, $mday, $mon, $year, $wday, $yday, undef) = gmtime $time;
947
948 sprintf "%s, %02d %s %04d %02d:%02d:%02d GMT",
949 $weekday[$wday], $mday, $month[$mon], $year + 1900,
950 $H, $M, $S;
951}
952
953sub parse_date($) {
954 my ($date) = @_;
955
956 my ($d, $m, $y, $H, $M, $S);
957
958 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$/) {
959 # RFC 822/1123, required by RFC 2616
960 ($d, $m, $y, $H, $M, $S) = ($1, $2, $3, $4, $5, $6);
961
962 } 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$/) {
963 # RFC 850
964 ($d, $m, $y, $H, $M, $S) = ($1, $2, $3 < 69 ? $3 + 2000 : $3 + 1900, $4, $5, $6);
965
966 } 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])$/) {
967 # ISO C's asctime
968 ($d, $m, $y, $H, $M, $S) = ($2, $1, $6, $3, $4, $5);
969 }
970 # other formats fail in the loop below
971
972 for (0..11) {
973 if ($m eq $month[$_]) {
974 require Time::Local;
975 return Time::Local::timegm ($S, $M, $H, $d, $_, $y);
976 }
977 }
978
979 undef
980}
981
770sub set_proxy($) { 982sub set_proxy($) {
983 if (length $_[0]) {
771 $PROXY = [$2, $3 || 3128, $1] if $_[0] =~ m%^(https?):// ([^:/]+) (?: : (\d*) )?%ix; 984 $_[0] =~ m%^(https?):// ([^:/]+) (?: : (\d*) )?%ix
985 or Carp::croak "$_[0]: invalid proxy URL";
986 $PROXY = [$2, $3 || 3128, $1]
987 } else {
988 undef $PROXY;
989 }
772} 990}
773 991
774# initialise proxy from environment 992# initialise proxy from environment
993eval {
775set_proxy $ENV{http_proxy}; 994 set_proxy $ENV{http_proxy};
995};
996
997=head2 SOCKS PROXIES
998
999Socks proxies are not directly supported by AnyEvent::HTTP. You can
1000compile your perl to support socks, or use an external program such as
1001F<socksify> (dante) or F<tsocks> to make your program use a socks proxy
1002transparently.
1003
1004Alternatively, for AnyEvent::HTTP only, you can use your own
1005C<tcp_connect> function that does the proxy handshake - here is an example
1006that works with socks4a proxies:
1007
1008 use Errno;
1009 use AnyEvent::Util;
1010 use AnyEvent::Socket;
1011 use AnyEvent::Handle;
1012
1013 # host, port and username of/for your socks4a proxy
1014 my $socks_host = "10.0.0.23";
1015 my $socks_port = 9050;
1016 my $socks_user = "";
1017
1018 sub socks4a_connect {
1019 my ($host, $port, $connect_cb, $prepare_cb) = @_;
1020
1021 my $hdl = new AnyEvent::Handle
1022 connect => [$socks_host, $socks_port],
1023 on_prepare => sub { $prepare_cb->($_[0]{fh}) },
1024 on_error => sub { $connect_cb->() },
1025 ;
1026
1027 $hdl->push_write (pack "CCnNZ*Z*", 4, 1, $port, 1, $socks_user, $host);
1028
1029 $hdl->push_read (chunk => 8, sub {
1030 my ($hdl, $chunk) = @_;
1031 my ($status, $port, $ipn) = unpack "xCna4", $chunk;
1032
1033 if ($status == 0x5a) {
1034 $connect_cb->($hdl->{fh}, (format_address $ipn) . ":$port");
1035 } else {
1036 $! = Errno::ENXIO; $connect_cb->();
1037 }
1038 });
1039
1040 $hdl
1041 }
1042
1043Use C<socks4a_connect> instead of C<tcp_connect> when doing C<http_request>s,
1044possibly after switching off other proxy types:
1045
1046 AnyEvent::HTTP::set_proxy undef; # usually you do not want other proxies
1047
1048 http_get 'http://www.google.com', tcp_connect => \&socks4a_connect, sub {
1049 my ($data, $headers) = @_;
1050 ...
1051 };
776 1052
777=head1 SEE ALSO 1053=head1 SEE ALSO
778 1054
779L<AnyEvent>. 1055L<AnyEvent>.
780 1056

Diff Legend

Removed lines
+ Added lines
< Changed lines
> Changed lines