[ViewVC] Diff of: cvs/AnyEvent-HTTP/HTTP.pm

Comparing AnyEvent-HTTP/HTTP.pm (file contents):
Revision 1.70 by root, Fri Dec 31 20:31:47 2010 UTC vs.
Revision 1.90 by root, Mon Jan 3 00:41:25 2011 UTC

…		…
36		36
37	=cut	37	=cut
38		38
39	package AnyEvent::HTTP;	39	package AnyEvent::HTTP;
40		40
41	use strict;	41	use common::sense;
42	no warnings;
43		42
44	use Errno ();	43	use Errno ();
45		44
46	use AnyEvent 5.0 ();	45	use AnyEvent 5.0 ();
47	use AnyEvent::Util ();	46	use AnyEvent::Util ();
…		…
58	our $MAX_PERSISTENT = 8;	57	our $MAX_PERSISTENT = 8;
59	our $PERSISTENT_TIMEOUT = 2;	58	our $PERSISTENT_TIMEOUT = 2;
60	our $TIMEOUT = 300;	59	our $TIMEOUT = 300;
61		60
62	# changing these is evil	61	# changing these is evil
63	our $MAX_PERSISTENT_PER_HOST = 0;	62	our $MAX_PERSISTENT_PER_HOST = 2;
64	our $MAX_PER_HOST = 4;	63	our $MAX_PER_HOST = 4;
65		64
66	our $PROXY;	65	our $PROXY;
67	our $ACTIVE = 0;	66	our $ACTIVE = 0;
68		67
…		…
122		121
123	If the server sends a header multiple times, then their contents will be	122	If the server sends a header multiple times, then their contents will be
124	joined together with a comma (C<,>), as per the HTTP spec.	123	joined together with a comma (C<,>), as per the HTTP spec.
125		124
126	If an internal error occurs, such as not being able to resolve a hostname,	125	If an internal error occurs, such as not being able to resolve a hostname,
127	then C<$data> will be C<undef>, C<< $headers->{Status} >> will be C<59x>	126	then C<$data> will be C<undef>, C<< $headers->{Status} >> will be
128	(usually C<599>) and the C<Reason> pseudo-header will contain an error	127	C<590>-C<599> and the C<Reason> pseudo-header will contain an error
129	message.	128	message. Currently the following status codes are used:
		129
		130	=over 4
		131
		132	=item 595 - errors during connection etsbalishment, proxy handshake.
		133
		134	=item 596 - errors during TLS negotiation, request sending and header processing.
		135
		136	=item 597 - errors during body receiving or processing.
		137
		138	=item 598 - user aborted request via C<on_header> or C<on_body>.
		139
		140	=item 599 - other, usually nonretryable, errors (garbled URL etc.).
		141
		142	=back
130		143
131	A typical callback might look like this:	144	A typical callback might look like this:
132		145
133	sub {	146	sub {
134	my ($body, $hdr) = @_;	147	my ($body, $hdr) = @_;
…		…
156	C<Host:>, C<Content-Length:>, C<Connection:> and C<Cookie:> headers and	169	C<Host:>, C<Content-Length:>, C<Connection:> and C<Cookie:> headers and
157	will provide defaults at least for C<TE:>, C<Referer:> and C<User-Agent:>	170	will provide defaults at least for C<TE:>, C<Referer:> and C<User-Agent:>
158	(this can be suppressed by using C<undef> for these headers in which case	171	(this can be suppressed by using C<undef> for these headers in which case
159	they won't be sent at all).	172	they won't be sent at all).
160		173
		174	You really should provide your own C<User-Agent:> header value that is
		175	appropriate for your program - I wouldn't be surprised if the default
		176	AnyEvent string gets blocked by webservers sooner or later.
		177
161	=item timeout => $seconds	178	=item timeout => $seconds
162		179
163	The time-out to use for various stages - each connect attempt will reset	180	The time-out to use for various stages - each connect attempt will reset
164	the timeout, as will read or write activity, i.e. this is not an overall	181	the timeout, as will read or write activity, i.e. this is not an overall
165	timeout.	182	timeout.
…		…
182	=item cookie_jar => $hash_ref	199	=item cookie_jar => $hash_ref
183		200
184	Passing this parameter enables (simplified) cookie-processing, loosely	201	Passing this parameter enables (simplified) cookie-processing, loosely
185	based on the original netscape specification.	202	based on the original netscape specification.
186		203
187	The C<$hash_ref> must be an (initially empty) hash reference which will	204	The C<$hash_ref> must be an (initially empty) hash reference which
188	get updated automatically. It is possible to save the cookie jar to	205	will get updated automatically. It is possible to save the cookie jar
189	persistent storage with something like JSON or Storable, but this is not	206	to persistent storage with something like JSON or Storable - see the
190	recommended, as session-only cookies might survive longer than expected.	207	C<AnyEvent::HTTP::cookie_jar_expire> function if you wish to remove
		208	expired or session-only cookies, and also for documentation on the format
		209	of the cookie jar.
191		210
192	Note that this cookie implementation is not meant to be complete. If	211	Note that this cookie implementation is not meant to be complete. If
193	you want complete cookie management you have to do that on your	212	you want complete cookie management you have to do that on your
194	own. C<cookie_jar> is meant as a quick fix to get some cookie-using sites	213	own. C<cookie_jar> is meant as a quick fix to get most cookie-using sites
195	working. Cookies are a privacy disaster, do not use them unless required	214	working. Cookies are a privacy disaster, do not use them unless required
196	to.	215	to.
197		216
198	When cookie processing is enabled, the C<Cookie:> and C<Set-Cookie:>	217	When cookie processing is enabled, the C<Cookie:> and C<Set-Cookie:>
199	headers will be set and handled by this module, otherwise they will be	218	headers will be set and handled by this module, otherwise they will be
…		…
314	Example: do a HTTP HEAD request on https://www.google.com/, use a	333	Example: do a HTTP HEAD request on https://www.google.com/, use a
315	timeout of 30 seconds.	334	timeout of 30 seconds.
316		335
317	http_request	336	http_request
318	GET => "https://www.google.com",	337	GET => "https://www.google.com",
		338	headers => { "user-agent" => "MySearchClient 1.0" },
319	timeout => 30,	339	timeout => 30,
320	sub {	340	sub {
321	my ($body, $hdr) = @_;	341	my ($body, $hdr) = @_;
322	use Data::Dumper;	342	use Data::Dumper;
323	print Dumper $hdr;	343	print Dumper $hdr;
…		…
364	push @{ $CO_SLOT{$_[0]}[1] }, $_[1];	384	push @{ $CO_SLOT{$_[0]}[1] }, $_[1];
365		385
366	_slot_schedule $_[0];	386	_slot_schedule $_[0];
367	}	387	}
368		388
		389	#############################################################################
		390
		391	# expire cookies
		392	sub cookie_jar_expire($;$) {
		393	my ($jar, $session_end) = @_;
		394
		395	%$jar = () if $jar->{version} != 1;
		396
		397	my $anow = AE::now;
		398
		399	while (my ($chost, $paths) = each %$jar) {
		400	next unless ref $paths;
		401
		402	while (my ($cpath, $cookies) = each %$paths) {
		403	while (my ($cookie, $kv) = each %$cookies) {
		404	if (exists $kv->{_expires}) {
		405	delete $cookies->{$cookie}
		406	if $anow > $kv->{_expires};
		407	} elsif ($session_end) {
		408	delete $cookies->{$cookie};
		409	}
		410	}
		411
		412	delete $paths->{$cpath}
		413	unless %$cookies;
		414	}
		415
		416	delete $jar->{$chost}
		417	unless %$paths;
		418	}
		419	}
		420
		421	# extract cookies from jar
		422	sub cookie_jar_extract($$$$) {
		423	my ($jar, $uscheme, $uhost, $upath) = @_;
		424
		425	%$jar = () if $jar->{version} != 1;
		426
		427	my @cookies;
		428
		429	while (my ($chost, $paths) = each %$jar) {
		430	next unless ref $paths;
		431
		432	if ($chost =~ /^\./) {
		433	next unless $chost eq substr $uhost, -length $chost;
		434	} elsif ($chost =~ /\./) {
		435	next unless $chost eq $uhost;
		436	} else {
		437	next;
		438	}
		439
		440	while (my ($cpath, $cookies) = each %$paths) {
		441	next unless $cpath eq substr $upath, 0, length $cpath;
		442
		443	while (my ($cookie, $kv) = each %$cookies) {
		444	next if $uscheme ne "https" && exists $kv->{secure};
		445
		446	if (exists $kv->{_expires} and AE::now > $kv->{_expires}) {
		447	delete $cookies->{$cookie};
		448	next;
		449	}
		450
		451	my $value = $kv->{value};
		452
		453	if ($value =~ /[=;,[:space:]]/) {
		454	$value =~ s/([\\"])/\\$1/g;
		455	$value = "\"$value\"";
		456	}
		457
		458	push @cookies, "$cookie=$value";
		459	}
		460	}
		461	}
		462
		463	\@cookies
		464	}
		465
		466	# parse set_cookie header into jar
		467	sub cookie_jar_set_cookie($$$$) {
		468	my ($jar, $set_cookie, $uhost, $date) = @_;
		469
		470	my $anow = int AE::now;
		471	my $snow; # server-now
		472
		473	for ($set_cookie) {
		474	# parse NAME=VALUE
		475	my @kv;
		476
		477	# expires is not http-compliant in the original cookie-spec,
		478	# we support the official date format and some extensions
		479	while (
		480	m{
		481	\G\s*
		482	(?:
		483	expires \s=\s ([A-Z][a-z][a-z]+,\ [^,;]+)
		484	\| ([^=;,[:space:]]+) (?: \s=\s (?: "((?:[^\\"]+\|\\.))" \| ([^=;,[:space:]]) ) )?
		485	)
		486	}gcxsi
		487	) {
		488	my $name = $2;
		489	my $value = $4;
		490
		491	if (defined $1) {
		492	# expires
		493	$name = "expires";
		494	$value = $1;
		495	} elsif (defined $3) {
		496	# quoted
		497	$value = $3;
		498	$value =~ s/\\(.)/$1/gs;
		499	}
		500
		501	push @kv, lc $name, $value;
		502
		503	last unless /\G\s*;/gc;
		504	}
		505
		506	last unless @kv;
		507
		508	my $name = shift @kv;
		509	my %kv = (value => shift @kv, @kv);
		510
		511	if (exists $kv{"max-age"}) {
		512	$kv{_expires} = $anow + delete $kv{"max-age"};
		513	} elsif (exists $kv{expires}) {
		514	$snow \|\|= parse_date ($date) \|\| $anow;
		515	$kv{_expires} = $anow + (parse_date (delete $kv{expires}) - $snow);
		516	} else {
		517	delete $kv{_expires};
		518	}
		519
		520	my $cdom;
		521	my $cpath = (delete $kv{path}) \|\| "/";
		522
		523	if (exists $kv{domain}) {
		524	$cdom = delete $kv{domain};
		525
		526	$cdom =~ s/^\.?/./; # make sure it starts with a "."
		527
		528	next if $cdom =~ /\.$/;
		529
		530	# this is not rfc-like and not netscape-like. go figure.
		531	my $ndots = $cdom =~ y/.//;
		532	next if $ndots < ($cdom =~ /\.[^.][^.]\.[^.][^.]$/ ? 3 : 2);
		533	} else {
		534	$cdom = $uhost;
		535	}
		536
		537	# store it
		538	$jar->{version} = 1;
		539	$jar->{lc $cdom}{$cpath}{$name} = \%kv;
		540
		541	redo if /\G\s*,/gc;
		542	}
		543	}
		544
369	# continue to parse $_ for headers and place them into the arg	545	# continue to parse $_ for headers and place them into the arg
370	sub parse_hdr() {	546	sub parse_hdr() {
371	my %hdr;	547	my %hdr;
372		548
373	# things seen, not parsed:	549	# things seen, not parsed:
…		…
435	: return $cb->(undef, { @pseudo, Status => 599, Reason => "Only http and https URL schemes supported" });	611	: return $cb->(undef, { @pseudo, Status => 599, Reason => "Only http and https URL schemes supported" });
436		612
437	$uauthority =~ /^(?: .*\@ )? ([^\@:]+) (?: : (\d+) )?$/x	613	$uauthority =~ /^(?: .*\@ )? ([^\@:]+) (?: : (\d+) )?$/x
438	or return $cb->(undef, { @pseudo, Status => 599, Reason => "Unparsable URL" });	614	or return $cb->(undef, { @pseudo, Status => 599, Reason => "Unparsable URL" });
439		615
440	my $uhost = $1;	616	my $uhost = lc $1;
441	$uport = $2 if defined $2;	617	$uport = $2 if defined $2;
442		618
443	$hdr{host} = defined $2 ? "$uhost:$2" : "$uhost"	619	$hdr{host} = defined $2 ? "$uhost:$2" : "$uhost"
444	unless exists $hdr{host};	620	unless exists $hdr{host};
445		621
…		…
448		624
449	$upath =~ s%^/?%/%;	625	$upath =~ s%^/?%/%;
450		626
451	# cookie processing	627	# cookie processing
452	if (my $jar = $arg{cookie_jar}) {	628	if (my $jar = $arg{cookie_jar}) {
453	%$jar = () if $jar->{version} != 1;	629	my $cookies = cookie_jar_extract $jar, $uscheme, $uhost, $upath;
454
455	my @cookie;
456
457	while (my ($chost, $paths) = each %$jar) {
458	if ($chost =~ /^\./) {
459	next unless $chost eq substr $uhost, -length $chost;
460	} elsif ($chost =~ /\./) {
461	next unless $chost eq $uhost;
462	} else {
463	next;
464	}
465		630
466	while (my ($cpath, $cookies) = each %$paths) {
467	next unless $cpath eq substr $upath, 0, length $cpath;
468
469	while (my ($cookie, $kv) = each %$cookies) {
470	next if $uscheme ne "https" && exists $kv->{secure};
471
472	if (exists $kv->{expires}) {
473	if (AE::now > parse_date ($kv->{expires})) {
474	delete $cookies->{$cookie};
475	next;
476	}
477	}
478
479	my $value = $kv->{value};
480	$value =~ s/([\\"])/\\$1/g;
481	push @cookie, "$cookie=\"$value\"";
482	}
483	}
484	}
485
486	$hdr{cookie} = join "; ", @cookie	631	$hdr{cookie} = join "; ", @$cookies
487	if @cookie;	632	if @$cookies;
488	}	633	}
489		634
490	my ($rhost, $rport, $rscheme, $rpath); # request host, port, path	635	my ($rhost, $rport, $rscheme, $rpath); # request host, port, path
491		636
492	if ($proxy) {	637	if ($proxy) {
…		…
495	$rscheme = "http" unless defined $rscheme;	640	$rscheme = "http" unless defined $rscheme;
496		641
497	# don't support https requests over https-proxy transport,	642	# don't support https requests over https-proxy transport,
498	# can't be done with tls as spec'ed, unless you double-encrypt.	643	# can't be done with tls as spec'ed, unless you double-encrypt.
499	$rscheme = "http" if $uscheme eq "https" && $rscheme eq "https";	644	$rscheme = "http" if $uscheme eq "https" && $rscheme eq "https";
		645
		646	$rhost = lc $rhost;
		647	$rscheme = lc $rscheme;
500	} else {	648	} else {
501	($rhost, $rport, $rscheme, $rpath) = ($uhost, $uport, $uscheme, $upath);	649	($rhost, $rport, $rscheme, $rpath) = ($uhost, $uport, $uscheme, $upath);
502	}	650	}
503		651
504	# leave out fragment and query string, just a heuristic	652	# leave out fragment and query string, just a heuristic
…		…
506	$hdr{"user-agent"} = $USERAGENT unless exists $hdr{"user-agent"};	654	$hdr{"user-agent"} = $USERAGENT unless exists $hdr{"user-agent"};
507		655
508	$hdr{"content-length"} = length $arg{body}	656	$hdr{"content-length"} = length $arg{body}
509	if length $arg{body} \|\| $method ne "GET";	657	if length $arg{body} \|\| $method ne "GET";
510		658
511	$hdr{connection} = "close TE"; #1.1	659	my $idempotent = $method =~ /^(?:GET\|HEAD\|PUT\|DELETE\|OPTIONS\|TRACE)$/;
		660
		661	# default value for keepalive is true iff the request is for an idempotent method
		662	my $keepalive = exists $arg{keepalive}
		663	? $arg{keepalive}*1
		664	: $idempotent ? $PERSISTENT_TIMEOUT : 0;
		665
		666	$hdr{connection} = ($keepalive ? "" : "close ") . "Te"; #1.1
512	$hdr{te} = "trailers" unless exists $hdr{te}; #1.1	667	$hdr{te} = "trailers" unless exists $hdr{te}; #1.1
513		668
514	my %state = (connect_guard => 1);	669	my %state = (connect_guard => 1);
515		670
516	_get_slot $uhost, sub {	671	my $ae_error = 595; # connecting
517	$state{slot_guard} = shift;
518		672
		673	# handle actual, non-tunneled, request
		674	my $handle_actual_request = sub {
		675	$ae_error = 596; # request phase
		676
		677	$state{handle}->starttls ("connect") if $uscheme eq "https" && !exists $state{handle}{tls};
		678
		679	# send request
		680	$state{handle}->push_write (
		681	"$method $rpath HTTP/1.1\015\012"
		682	. (join "", map "\u$_: $hdr{$_}\015\012", grep defined $hdr{$_}, keys %hdr)
		683	. "\015\012"
		684	. (delete $arg{body})
		685	);
		686
		687	# return if error occured during push_write()
519	return unless $state{connect_guard};	688	return unless %state;
520		689
521	my $connect_cb = sub {	690	# reduce memory usage, save a kitten, also re-use it for the response headers.
522	$state{fh} = shift	691	%hdr = ();
		692
		693	# status line and headers
		694	$state{read_response} = sub {
		695	for ("$_[1]") {
		696	y/\015//d; # weed out any \015, as they show up in the weirdest of places.
		697
		698	/^HTTP\/0([0-9\.]+) \s+ ([0-9]{3}) (?: \s+ ([^\012]) )? \012/gxci
		699	or return (%state = (), $cb->(undef, { @pseudo, Status => 599, Reason => "Invalid server response" }));
		700
		701	# 100 Continue handling
		702	# should not happen as we don't send expect: 100-continue,
		703	# but we handle it just in case.
		704	# since we send the request body regardless, if we get an error
		705	# we are out of-sync, which we currently do NOT handle correctly.
		706	return $state{handle}->push_read (line => $qr_nlnl, $state{read_response})
		707	if $2 eq 100;
		708
		709	push @pseudo,
		710	HTTPVersion => $1,
		711	Status => $2,
		712	Reason => $3,
523	or do {	713	;
524	my $err = "$!";	714
		715	my $hdr = parse_hdr
		716	or return (%state = (), $cb->(undef, { @pseudo, Status => 599, Reason => "Garbled response headers" }));
		717
		718	%hdr = (%$hdr, @pseudo);
		719	}
		720
		721	# redirect handling
		722	# microsoft and other shitheads don't give a shit for following standards,
		723	# try to support some common forms of broken Location headers.
		724	if ($hdr{location} !~ /^(?: $ \| [^:\/?\#]+ : )/x) {
		725	$hdr{location} =~ s/^\.\/+//;
		726
		727	my $url = "$rscheme://$uhost:$uport";
		728
		729	unless ($hdr{location} =~ s/^\///) {
		730	$url .= $upath;
		731	$url =~ s/\/[^\/]*$//;
		732	}
		733
		734	$hdr{location} = "$url/$hdr{location}";
		735	}
		736
		737	my $redirect;
		738
		739	if ($recurse) {
		740	my $status = $hdr{Status};
		741
		742	# industry standard is to redirect POST as GET for
		743	# 301, 302 and 303, in contrast to HTTP/1.0 and 1.1.
		744	# also, the UA should ask the user for 301 and 307 and POST,
		745	# industry standard seems to be to simply follow.
		746	# we go with the industry standard.
		747	if ($status == 301 or $status == 302 or $status == 303) {
		748	# HTTP/1.1 is unclear on how to mutate the method
		749	$method = "GET" unless $method eq "HEAD";
		750	$redirect = 1;
		751	} elsif ($status == 307) {
		752	$redirect = 1;
		753	}
		754	}
		755
		756	my $finish = sub { # ($data, $err_status, $err_reason[, $keepalive])
		757	my $may_keep_alive = $_[3];
		758
		759	$state{handle}->destroy if $state{handle};
525	%state = ();	760	%state = ();
526	return $cb->(undef, { @pseudo, Status => 599, Reason => $err });	761
		762	if (defined $_[1]) {
		763	$hdr{OrigStatus} = $hdr{Status}; $hdr{Status} = $_[1];
		764	$hdr{OrigReason} = $hdr{Reason}; $hdr{Reason} = $_[2];
		765	}
		766
		767	# set-cookie processing
		768	if ($arg{cookie_jar}) {
		769	cookie_jar_set_cookie $arg{cookie_jar}, $hdr{"set-cookie"}, $uhost, $hdr{date};
		770	}
		771
		772	if ($redirect && exists $hdr{location}) {
		773	# we ignore any errors, as it is very common to receive
		774	# Content-Length != 0 but no actual body
		775	# we also access %hdr, as $_[1] might be an erro
		776	http_request (
		777	$method => $hdr{location},
		778	%arg,
		779	recurse => $recurse - 1,
		780	Redirect => [$_[0], \%hdr],
		781	$cb);
		782	} else {
		783	$cb->($_[0], \%hdr);
		784	}
		785	};
		786
		787	$ae_error = 597; # body phase
		788
		789	my $len = $hdr{"content-length"};
		790
		791	# body handling, many different code paths
		792	# - no body expected
		793	# - want_body_handle
		794	# - te chunked
		795	# - 2x length known (with or without on_body)
		796	# - 2x length not known (with or without on_body)
		797	if (!$redirect && $arg{on_header} && !$arg{on_header}(\%hdr)) {
		798	$finish->(undef, 598 => "Request cancelled by on_header");
		799	} elsif (
		800	$hdr{Status} =~ /^(?:1..\|204\|205\|304)$/
		801	or $method eq "HEAD"
		802	or (defined $len && $len == 0) # == 0, not !, because "0 " is true
		803	) {
		804	# no body
		805	$finish->("", undef, undef, 1);
		806
		807	} elsif (!$redirect && $arg{want_body_handle}) {
		808	$_[0]->on_eof (undef);
		809	$_[0]->on_error (undef);
		810	$_[0]->on_read (undef);
		811
		812	$finish->(delete $state{handle});
		813
		814	} elsif ($hdr{"transfer-encoding"} =~ /\bchunked\b/i) {
		815	my $cl = 0;
		816	my $body = undef;
		817	my $on_body = $arg{on_body} \|\| sub { $body .= shift; 1 };
		818
		819	$state{read_chunk} = sub {
		820	$_[1] =~ /^([0-9a-fA-F]+)/
		821	or $finish->(undef, $ae_error => "Garbled chunked transfer encoding");
		822
		823	my $len = hex $1;
		824
		825	if ($len) {
		826	$cl += $len;
		827
		828	$_[0]->push_read (chunk => $len, sub {
		829	$on_body->($_[1], \%hdr)
		830	or return $finish->(undef, 598 => "Request cancelled by on_body");
		831
		832	$_[0]->push_read (line => sub {
		833	length $_[1]
		834	and return $finish->(undef, $ae_error => "Garbled chunked transfer encoding");
		835	$_[0]->push_read (line => $state{read_chunk});
		836	});
		837	});
		838	} else {
		839	$hdr{"content-length"} \|\|= $cl;
		840
		841	$_[0]->push_read (line => $qr_nlnl, sub {
		842	if (length $_[1]) {
		843	for ("$_[1]") {
		844	y/\015//d; # weed out any \015, as they show up in the weirdest of places.
		845
		846	my $hdr = parse_hdr
		847	or return $finish->(undef, $ae_error => "Garbled response trailers");
		848
		849	%hdr = (%hdr, %$hdr);
		850	}
		851	}
		852
		853	$finish->($body, undef, undef, 1);
		854	});
		855	}
527	};	856	};
528		857
529	pop; # free memory, save a tree	858	$_[0]->push_read (line => $state{read_chunk});
530		859
		860	} elsif ($arg{on_body}) {
		861	if (defined $len) {
		862	$_[0]->on_read (sub {
		863	$len -= length $_[0]{rbuf};
		864
		865	$arg{on_body}(delete $_[0]{rbuf}, \%hdr)
		866	or return $finish->(undef, 598 => "Request cancelled by on_body");
		867
		868	$len > 0
		869	or $finish->("", undef, undef, 1);
		870	});
		871	} else {
		872	$_[0]->on_eof (sub {
		873	$finish->("");
		874	});
		875	$_[0]->on_read (sub {
		876	$arg{on_body}(delete $_[0]{rbuf}, \%hdr)
		877	or $finish->(undef, 598 => "Request cancelled by on_body");
		878	});
		879	}
		880	} else {
		881	$_[0]->on_eof (undef);
		882
		883	if (defined $len) {
		884	$_[0]->on_read (sub {
		885	$finish->((substr delete $_[0]{rbuf}, 0, $len, ""), undef, undef, 1)
		886	if $len <= length $_[0]{rbuf};
		887	});
		888	} else {
		889	$_[0]->on_error (sub {
		890	($! == Errno::EPIPE \|\| !$!)
		891	? $finish->(delete $_[0]{rbuf})
		892	: $finish->(undef, $ae_error => $_[2]);
		893	});
		894	$_[0]->on_read (sub { });
		895	}
		896	}
		897	};
		898
		899	$state{handle}->push_read (line => $qr_nlnl, $state{read_response});
		900	};
		901
		902	my $connect_cb = sub {
		903	$state{fh} = shift
		904	or do {
		905	my $err = "$!";
		906	%state = ();
		907	return $cb->(undef, { @pseudo, Status => $ae_error, Reason => $err });
		908	};
		909
531	return unless delete $state{connect_guard};	910	return unless delete $state{connect_guard};
532		911
533	# get handle	912	# get handle
534	$state{handle} = new AnyEvent::Handle	913	$state{handle} = new AnyEvent::Handle
535	fh => $state{fh},	914	fh => $state{fh},
536	peername => $rhost,	915	peername => $rhost,
537	tls_ctx => $arg{tls_ctx},	916	tls_ctx => $arg{tls_ctx},
538	# these need to be reconfigured on keepalive handles	917	# these need to be reconfigured on keepalive handles
539	timeout => $timeout,	918	timeout => $timeout,
540	on_error => sub {	919	on_error => sub {
541	%state = ();	920	%state = ();
542	$cb->(undef, { @pseudo, Status => 599, Reason => $_[2] });	921	$cb->(undef, { @pseudo, Status => $ae_error, Reason => $_[2] });
543	},	922	},
544	on_eof => sub {	923	on_eof => sub {
545	%state = ();	924	%state = ();
546	$cb->(undef, { @pseudo, Status => 599, Reason => "Unexpected end-of-file" });	925	$cb->(undef, { @pseudo, Status => $ae_error, Reason => "Unexpected end-of-file" });
547	},	926	},
548	;	927	;
549		928
550	# limit the number of persistent connections	929	# limit the number of persistent connections
551	# keepalive not yet supported	930	# keepalive not yet supported
552	# if ($KA_COUNT{$_[1]} < $MAX_PERSISTENT_PER_HOST) {	931	# if ($KA_COUNT{$_[1]} < $MAX_PERSISTENT_PER_HOST) {
553	# ++$KA_COUNT{$_[1]};	932	# ++$KA_COUNT{$_[1]};
554	# $state{handle}{ka_count_guard} = AnyEvent::Util::guard {	933	# $state{handle}{ka_count_guard} = AnyEvent::Util::guard {
555	# --$KA_COUNT{$_[1]}	934	# --$KA_COUNT{$_[1]}
556	# };	935	# };
557	# $hdr{connection} = "keep-alive";	936	# $hdr{connection} = "keep-alive";
558	# }	937	# }
559		938
560	$state{handle}->starttls ("connect") if $rscheme eq "https";	939	$state{handle}->starttls ("connect") if $rscheme eq "https";
561		940
562	# handle actual, non-tunneled, request
563	my $handle_actual_request = sub {
564	$state{handle}->starttls ("connect") if $uscheme eq "https" && !exists $state{handle}{tls};
565
566	# send request
567	$state{handle}->push_write (
568	"$method $rpath HTTP/1.1\015\012"
569	. (join "", map "\u$_: $hdr{$_}\015\012", grep defined $hdr{$_}, keys %hdr)
570	. "\015\012"
571	. (delete $arg{body})
572	);
573
574	# return if error occured during push_write()
575	return unless %state;
576
577	%hdr = (); # reduce memory usage, save a kitten, also make it possible to re-use
578
579	# status line and headers
580	$state{read_response} = sub {
581	for ("$_[1]") {
582	y/\015//d; # weed out any \015, as they show up in the weirdest of places.
583
584	/^HTTP\/([0-9\.]+) \s+ ([0-9]{3}) (?: \s+ ([^\012]*) )? \012/igxc
585	or return (%state = (), $cb->(undef, { @pseudo, Status => 599, Reason => "Invalid server response" }));
586
587	# 100 Continue handling
588	# should not happen as we don't send expect: 100-continue,
589	# but we handle it just in case.
590	# since we send the request body regardless, if we get an error
591	# we are out of-sync, which we currently do NOT handle correctly.
592	return $state{handle}->push_read (line => $qr_nlnl, $state{read_response})
593	if $2 eq 100;
594
595	push @pseudo,
596	HTTPVersion => $1,
597	Status => $2,
598	Reason => $3,
599	;
600
601	my $hdr = parse_hdr
602	or return (%state = (), $cb->(undef, { @pseudo, Status => 599, Reason => "Garbled response headers" }));
603
604	%hdr = (%$hdr, @pseudo);
605	}
606
607	# redirect handling
608	# microsoft and other shitheads don't give a shit for following standards,
609	# try to support some common forms of broken Location headers.
610	if ($hdr{location} !~ /^(?: $ \| [^:\/?\#]+ : )/x) {
611	$hdr{location} =~ s/^\.\/+//;
612
613	my $url = "$rscheme://$uhost:$uport";
614
615	unless ($hdr{location} =~ s/^\///) {
616	$url .= $upath;
617	$url =~ s/\/[^\/]*$//;
618	}
619
620	$hdr{location} = "$url/$hdr{location}";
621	}
622
623	my $redirect;
624
625	if ($recurse) {
626	my $status = $hdr{Status};
627
628	# industry standard is to redirect POST as GET for
629	# 301, 302 and 303, in contrast to http/1.0 and 1.1.
630	# also, the UA should ask the user for 301 and 307 and POST,
631	# industry standard seems to be to simply follow.
632	# we go with the industry standard.
633	if ($status == 301 or $status == 302 or $status == 303) {
634	# HTTP/1.1 is unclear on how to mutate the method
635	$method = "GET" unless $method eq "HEAD";
636	$redirect = 1;
637	} elsif ($status == 307) {
638	$redirect = 1;
639	}
640	}
641
642	my $finish = sub { # ($data, $err_status, $err_reason[, $keepalive])
643	my $keepalive = pop;
644
645	$state{handle}->destroy if $state{handle};
646	%state = ();
647
648	if (defined $_[1]) {
649	$hdr{OrigStatus} = $hdr{Status}; $hdr{Status} = $_[1];
650	$hdr{OrigReason} = $hdr{Reason}; $hdr{Reason} = $_[2];
651	}
652
653	# set-cookie processing
654	if ($arg{cookie_jar}) {
655	for ($hdr{"set-cookie"}) {
656	# parse NAME=VALUE
657	my @kv;
658
659	while (
660	m{
661	\G\s*
662	(?:
663	expires \s=\s ([A-Z][a-z][a-z],\ [^,;]+)
664	\| ([^=;,[:space:]]+) \s=\s (?: "((?:[^\\"]+\|\\.))" \| ([^=;,[:space:]]) )
665	)
666	}gcxsi
667	) {
668	my $name = $2;
669	my $value = $4;
670
671	unless (defined $name) {
672	# expires
673	$name = "expires";
674	$value = $1;
675	} elsif (!defined $value) {
676	# quoted
677	$value = $3;
678	$value =~ s/\\(.)/$1/gs;
679	}
680
681	push @kv, lc $name, $value;
682
683	last unless /\G\s*;/gc;
684	}
685
686	last unless @kv;
687
688	my $name = shift @kv;
689	my %kv = (value => shift @kv, @kv);
690
691	$kv{expires} \|\|= format_date (AE::now + $kv{"max-age"})
692	if exists $kv{"max-age"};
693
694	my $cdom;
695	my $cpath = (delete $kv{path}) \|\| "/";
696
697	if (exists $kv{domain}) {
698	$cdom = delete $kv{domain};
699
700	$cdom =~ s/^\.?/./; # make sure it starts with a "."
701
702	next if $cdom =~ /\.$/;
703
704	# this is not rfc-like and not netscape-like. go figure.
705	my $ndots = $cdom =~ y/.//;
706	next if $ndots < ($cdom =~ /\.[^.][^.]\.[^.][^.]$/ ? 3 : 2);
707	} else {
708	$cdom = $uhost;
709	}
710
711	# store it
712	$arg{cookie_jar}{version} = 1;
713	$arg{cookie_jar}{$cdom}{$cpath}{$name} = \%kv;
714
715	redo if /\G\s*,/gc;
716	}
717	}
718
719	if ($redirect && exists $hdr{location}) {
720	# we ignore any errors, as it is very common to receive
721	# Content-Length != 0 but no actual body
722	# we also access %hdr, as $_[1] might be an erro
723	http_request (
724	$method => $hdr{location},
725	%arg,
726	recurse => $recurse - 1,
727	Redirect => [$_[0], \%hdr],
728	$cb);
729	} else {
730	$cb->($_[0], \%hdr);
731	}
732	};
733
734	my $len = $hdr{"content-length"};
735
736	if (!$redirect && $arg{on_header} && !$arg{on_header}(\%hdr)) {
737	$finish->(undef, 598 => "Request cancelled by on_header");
738	} elsif (
739	$hdr{Status} =~ /^(?:1..\|204\|205\|304)$/
740	or $method eq "HEAD"
741	or (defined $len && !$len)
742	) {
743	# no body
744	$finish->("", undef, undef, 1);
745	} else {
746	# body handling, many different code paths
747	# - no body expected
748	# - want_body_handle
749	# - te chunked
750	# - 2x length known (with or without on_body)
751	# - 2x length not known (with or without on_body)
752	if (!$redirect && $arg{want_body_handle}) {
753	$_[0]->on_eof (undef);
754	$_[0]->on_error (undef);
755	$_[0]->on_read (undef);
756
757	$finish->(delete $state{handle});
758
759	} elsif ($hdr{"transfer-encoding"} =~ /\bchunked\b/i) {
760	my $cl = 0;
761	my $body = undef;
762	my $on_body = $arg{on_body} \|\| sub { $body .= shift; 1 };
763
764	$_[0]->on_error (sub { $finish->(undef, 599 => $_[2]) });
765
766	my $read_chunk; $read_chunk = sub {
767	$_[1] =~ /^([0-9a-fA-F]+)/
768	or $finish->(undef, 599 => "Garbled chunked transfer encoding");
769
770	my $len = hex $1;
771
772	if ($len) {
773	$cl += $len;
774
775	$_[0]->push_read (chunk => $len, sub {
776	$on_body->($_[1], \%hdr)
777	or return $finish->(undef, 598 => "Request cancelled by on_body");
778
779	$_[0]->push_read (line => sub {
780	length $_[1]
781	and return $finish->(undef, 599 => "Garbled chunked transfer encoding");
782	$_[0]->push_read (line => $read_chunk);
783	});
784	});
785	} else {
786	$hdr{"content-length"} \|\|= $cl;
787
788	$_[0]->push_read (line => $qr_nlnl, sub {
789	if (length $_[1]) {
790	for ("$_[1]") {
791	y/\015//d; # weed out any \015, as they show up in the weirdest of places.
792
793	my $hdr = parse_hdr
794	or return $finish->(undef, 599 => "Garbled response trailers");
795
796	%hdr = (%hdr, %$hdr);
797	}
798	}
799
800	$finish->($body, undef, undef, 1);
801	});
802	}
803	};
804
805	$_[0]->push_read (line => $read_chunk);
806
807	} elsif ($arg{on_body}) {
808	$_[0]->on_error (sub { $finish->(undef, 599 => $_[2]) });
809
810	if ($len) {
811	$_[0]->on_read (sub {
812	$len -= length $_[0]{rbuf};
813
814	$arg{on_body}(delete $_[0]{rbuf}, \%hdr)
815	or return $finish->(undef, 598 => "Request cancelled by on_body");
816
817	$len > 0
818	or $finish->("", undef, undef, 1);
819	});
820	} else {
821	$_[0]->on_eof (sub {
822	$finish->("");
823	});
824	$_[0]->on_read (sub {
825	$arg{on_body}(delete $_[0]{rbuf}, \%hdr)
826	or $finish->(undef, 598 => "Request cancelled by on_body");
827	});
828	}
829	} else {
830	$_[0]->on_eof (undef);
831
832	if ($len) {
833	$_[0]->on_error (sub { $finish->(undef, 599 => $_[2]) });
834	$_[0]->on_read (sub {
835	$finish->((substr delete $_[0]{rbuf}, 0, $len, ""), undef, undef, 1)
836	if $len <= length $_[0]{rbuf};
837	});
838	} else {
839	$_[0]->on_error (sub {
840	($! == Errno::EPIPE \|\| !$!)
841	? $finish->(delete $_[0]{rbuf})
842	: $finish->(undef, 599 => $_[2]);
843	});
844	$_[0]->on_read (sub { });
845	}
846	}
847	}
848	};
849
850	$state{handle}->push_read (line => $qr_nlnl, $state{read_response});
851	};
852
853	# now handle proxy-CONNECT method	941	# now handle proxy-CONNECT method
854	if ($proxy && $uscheme eq "https") {	942	if ($proxy && $uscheme eq "https") {
855	# oh dear, we have to wrap it into a connect request	943	# oh dear, we have to wrap it into a connect request
856		944
857	# maybe re-use $uauthority with patched port?	945	# maybe re-use $uauthority with patched port?
858	$state{handle}->push_write ("CONNECT $uhost:$uport HTTP/1.0\015\012Host: $uhost\015\012\015\012");	946	$state{handle}->push_write ("CONNECT $uhost:$uport HTTP/1.0\015\012\015\012");
859	$state{handle}->push_read (line => $qr_nlnl, sub {	947	$state{handle}->push_read (line => $qr_nlnl, sub {
860	$_[1] =~ /^HTTP\/([0-9\.]+) \s+ ([0-9]{3}) (?: \s+ ([^\015\012]*) )?/ix	948	$_[1] =~ /^HTTP\/([0-9\.]+) \s+ ([0-9]{3}) (?: \s+ ([^\015\012]*) )?/ix
861	or return (%state = (), $cb->(undef, { @pseudo, Status => 599, Reason => "Invalid proxy connect response ($_[1])" }));	949	or return (%state = (), $cb->(undef, { @pseudo, Status => 599, Reason => "Invalid proxy connect response ($_[1])" }));
862		950
863	if ($2 == 200) {	951	if ($2 == 200) {
864	$rpath = $upath;	952	$rpath = $upath;
865	&$handle_actual_request;	953	$handle_actual_request->();
866	} else {	954	} else {
867	%state = ();	955	%state = ();
868	$cb->(undef, { @pseudo, Status => $2, Reason => $3 });	956	$cb->(undef, { @pseudo, Status => $2, Reason => $3 });
869	}
870	});	957	}
871	} else {
872	&$handle_actual_request;
873	}	958	});
		959	} else {
		960	$handle_actual_request->();
874	};	961	}
		962	};
		963
		964	_get_slot $uhost, sub {
		965	$state{slot_guard} = shift;
		966
		967	return unless $state{connect_guard};
875		968
876	my $tcp_connect = $arg{tcp_connect}	969	my $tcp_connect = $arg{tcp_connect}
877	\|\| do { require AnyEvent::Socket; \&AnyEvent::Socket::tcp_connect };	970	\|\| do { require AnyEvent::Socket; \&AnyEvent::Socket::tcp_connect };
878		971
879	$state{connect_guard} = $tcp_connect->($rhost, $rport, $connect_cb, $arg{on_prepare} \|\| sub { $timeout });	972	$state{connect_guard} = $tcp_connect->($rhost, $rport, $connect_cb, $arg{on_prepare} \|\| sub { $timeout });
880
881	};	973	};
882		974
883	defined wantarray && AnyEvent::Util::guard { %state = () }	975	defined wantarray && AnyEvent::Util::guard { %state = () }
884	}	976	}
885		977
…		…
920	string of the form C<http://host:port> (optionally C<https:...>), croaks	1012	string of the form C<http://host:port> (optionally C<https:...>), croaks
921	otherwise.	1013	otherwise.
922		1014
923	To clear an already-set proxy, use C<undef>.	1015	To clear an already-set proxy, use C<undef>.
924		1016
		1017	=item AnyEvent::HTTP::cookie_jar_expire $jar[, $session_end]
		1018
		1019	Remove all cookies from the cookie jar that have been expired. If
		1020	C<$session_end> is given and true, then additionally remove all session
		1021	cookies.
		1022
		1023	You should call this function (with a true C<$session_end>) before you
		1024	save cookies to disk, and you should call this function after loading them
		1025	again. If you have a long-running program you can additonally call this
		1026	function from time to time.
		1027
		1028	A cookie jar is initially an empty hash-reference that is managed by this
		1029	module. It's format is subject to change, but currently it is like this:
		1030
		1031	The key C<version> has to contain C<1>, otherwise the hash gets
		1032	emptied. All other keys are hostnames or IP addresses pointing to
		1033	hash-references. The key for these inner hash references is the
		1034	server path for which this cookie is meant, and the values are again
		1035	hash-references. The keys of those hash-references is the cookie name, and
		1036	the value, you guessed it, is another hash-reference, this time with the
		1037	key-value pairs from the cookie, except for C<expires> and C<max-age>,
		1038	which have been replaced by a C<_expires> key that contains the cookie
		1039	expiry timestamp.
		1040
		1041	Here is an example of a cookie jar with a single cookie, so you have a
		1042	chance of understanding the above paragraph:
		1043
		1044	{
		1045	version => 1,
		1046	"10.0.0.1" => {
		1047	"/" => {
		1048	"mythweb_id" => {
		1049	_expires => 1293917923,
		1050	value => "ooRung9dThee3ooyXooM1Ohm",
		1051	},
		1052	},
		1053	},
		1054	}
		1055
925	=item $date = AnyEvent::HTTP::format_date $timestamp	1056	=item $date = AnyEvent::HTTP::format_date $timestamp
926		1057
927	Takes a POSIX timestamp (seconds since the epoch) and formats it as a HTTP	1058	Takes a POSIX timestamp (seconds since the epoch) and formats it as a HTTP
928	Date (RFC 2616).	1059	Date (RFC 2616).
929		1060
930	=item $timestamp = AnyEvent::HTTP::parse_date $date	1061	=item $timestamp = AnyEvent::HTTP::parse_date $date
931		1062
932	Takes a HTTP Date (RFC 2616) or a Cookie date (netscape cookie spec) and	1063	Takes a HTTP Date (RFC 2616) or a Cookie date (netscape cookie spec) or a
933	returns the corresponding POSIX timestamp, or C<undef> if the date cannot	1064	bunch of minor variations of those, and returns the corresponding POSIX
934	be parsed.	1065	timestamp, or C<undef> if the date cannot be parsed.
935		1066
936	=item $AnyEvent::HTTP::MAX_RECURSE	1067	=item $AnyEvent::HTTP::MAX_RECURSE
937		1068
938	The default value for the C<recurse> request parameter (default: C<10>).	1069	The default value for the C<recurse> request parameter (default: C<10>).
939		1070
…		…
978	sub parse_date($) {	1109	sub parse_date($) {
979	my ($date) = @_;	1110	my ($date) = @_;
980		1111
981	my ($d, $m, $y, $H, $M, $S);	1112	my ($d, $m, $y, $H, $M, $S);
982		1113
983	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$/) {	1114	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$/) {
984	# RFC 822/1123, required by RFC 2616 (with " ")	1115	# RFC 822/1123, required by RFC 2616 (with " ")
985	# cookie dates (with "-")	1116	# cookie dates (with "-")
986		1117
987	($d, $m, $y, $H, $M, $S) = ($1, $2, $3, $4, $5, $6);	1118	($d, $m, $y, $H, $M, $S) = ($1, $2, $3, $4, $5, $6);
988		1119
989	} 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$/) {	1120	} elsif ($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]?) GMT$/) {
990	# RFC 850	1121	# RFC 850
991	($d, $m, $y, $H, $M, $S) = ($1, $2, $3 < 69 ? $3 + 2000 : $3 + 1900, $4, $5, $6);	1122	($d, $m, $y, $H, $M, $S) = ($1, $2, $3 < 69 ? $3 + 2000 : $3 + 1900, $4, $5, $6);
992		1123
993	} 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])$/) {	1124	} 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])$/) {
994	# ISO C's asctime	1125	# ISO C's asctime
995	($d, $m, $y, $H, $M, $S) = ($2, $1, $6, $3, $4, $5);	1126	($d, $m, $y, $H, $M, $S) = ($2, $1, $6, $3, $4, $5);
996	}	1127	}
997	# other formats fail in the loop below	1128	# other formats fail in the loop below
998		1129

Diff Legend

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

Comparing AnyEvent-HTTP/HTTP.pm (file contents): Revision 1.70 by root, Fri Dec 31 20:31:47 2010 UTC vs. Revision 1.90 by root, Mon Jan 3 00:41:25 2011 UTC

Diff Legend

Comparing AnyEvent-HTTP/HTTP.pm (file contents):
Revision 1.70 by root, Fri Dec 31 20:31:47 2010 UTC vs.
Revision 1.90 by root, Mon Jan 3 00:41:25 2011 UTC