[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.91 by root, Mon Jan 3 01:03:29 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 $chunked = $hdr{"transfer-encoding"} =~ /\bchunked\b/i; # not quite correct...
		790
		791	my $len = $chunked ? undef : $hdr{"content-length"};
		792
		793	# body handling, many different code paths
		794	# - no body expected
		795	# - want_body_handle
		796	# - te chunked
		797	# - 2x length known (with or without on_body)
		798	# - 2x length not known (with or without on_body)
		799	if (!$redirect && $arg{on_header} && !$arg{on_header}(\%hdr)) {
		800	$finish->(undef, 598 => "Request cancelled by on_header");
		801	} elsif (
		802	$hdr{Status} =~ /^(?:1..\|204\|205\|304)$/
		803	or $method eq "HEAD"
		804	or (defined $len && $len == 0) # == 0, not !, because "0 " is true
		805	) {
		806	# no body
		807	$finish->("", undef, undef, 1);
		808
		809	} elsif (!$redirect && $arg{want_body_handle}) {
		810	$_[0]->on_eof (undef);
		811	$_[0]->on_error (undef);
		812	$_[0]->on_read (undef);
		813
		814	$finish->(delete $state{handle});
		815
		816	} elsif ($chunked) {
		817	my $cl = 0;
		818	my $body = undef;
		819	my $on_body = $arg{on_body} \|\| sub { $body .= shift; 1 };
		820
		821	$state{read_chunk} = sub {
		822	$_[1] =~ /^([0-9a-fA-F]+)/
		823	or $finish->(undef, $ae_error => "Garbled chunked transfer encoding");
		824
		825	my $len = hex $1;
		826
		827	if ($len) {
		828	$cl += $len;
		829
		830	$_[0]->push_read (chunk => $len, sub {
		831	$on_body->($_[1], \%hdr)
		832	or return $finish->(undef, 598 => "Request cancelled by on_body");
		833
		834	$_[0]->push_read (line => sub {
		835	length $_[1]
		836	and return $finish->(undef, $ae_error => "Garbled chunked transfer encoding");
		837	$_[0]->push_read (line => $state{read_chunk});
		838	});
		839	});
		840	} else {
		841	$hdr{"content-length"} \|\|= $cl;
		842
		843	$_[0]->push_read (line => $qr_nlnl, sub {
		844	if (length $_[1]) {
		845	for ("$_[1]") {
		846	y/\015//d; # weed out any \015, as they show up in the weirdest of places.
		847
		848	my $hdr = parse_hdr
		849	or return $finish->(undef, $ae_error => "Garbled response trailers");
		850
		851	%hdr = (%hdr, %$hdr);
		852	}
		853	}
		854
		855	$finish->($body, undef, undef, 1);
		856	});
		857	}
527	};	858	};
528		859
529	pop; # free memory, save a tree	860	$_[0]->push_read (line => $state{read_chunk});
530		861
		862	} elsif ($arg{on_body}) {
		863	if (defined $len) {
		864	$_[0]->on_read (sub {
		865	$len -= length $_[0]{rbuf};
		866
		867	$arg{on_body}(delete $_[0]{rbuf}, \%hdr)
		868	or return $finish->(undef, 598 => "Request cancelled by on_body");
		869
		870	$len > 0
		871	or $finish->("", undef, undef, 1);
		872	});
		873	} else {
		874	$_[0]->on_eof (sub {
		875	$finish->("");
		876	});
		877	$_[0]->on_read (sub {
		878	$arg{on_body}(delete $_[0]{rbuf}, \%hdr)
		879	or $finish->(undef, 598 => "Request cancelled by on_body");
		880	});
		881	}
		882	} else {
		883	$_[0]->on_eof (undef);
		884
		885	if (defined $len) {
		886	$_[0]->on_read (sub {
		887	$finish->((substr delete $_[0]{rbuf}, 0, $len, ""), undef, undef, 1)
		888	if $len <= length $_[0]{rbuf};
		889	});
		890	} else {
		891	$_[0]->on_error (sub {
		892	($! == Errno::EPIPE \|\| !$!)
		893	? $finish->(delete $_[0]{rbuf})
		894	: $finish->(undef, $ae_error => $_[2]);
		895	});
		896	$_[0]->on_read (sub { });
		897	}
		898	}
		899	};
		900
		901	$state{handle}->push_read (line => $qr_nlnl, $state{read_response});
		902	};
		903
		904	my $connect_cb = sub {
		905	$state{fh} = shift
		906	or do {
		907	my $err = "$!";
		908	%state = ();
		909	return $cb->(undef, { @pseudo, Status => $ae_error, Reason => $err });
		910	};
		911
531	return unless delete $state{connect_guard};	912	return unless delete $state{connect_guard};
532		913
533	# get handle	914	# get handle
534	$state{handle} = new AnyEvent::Handle	915	$state{handle} = new AnyEvent::Handle
535	fh => $state{fh},	916	fh => $state{fh},
536	peername => $rhost,	917	peername => $rhost,
537	tls_ctx => $arg{tls_ctx},	918	tls_ctx => $arg{tls_ctx},
538	# these need to be reconfigured on keepalive handles	919	# these need to be reconfigured on keepalive handles
539	timeout => $timeout,	920	timeout => $timeout,
540	on_error => sub {	921	on_error => sub {
541	%state = ();	922	%state = ();
542	$cb->(undef, { @pseudo, Status => 599, Reason => $_[2] });	923	$cb->(undef, { @pseudo, Status => $ae_error, Reason => $_[2] });
543	},	924	},
544	on_eof => sub {	925	on_eof => sub {
545	%state = ();	926	%state = ();
546	$cb->(undef, { @pseudo, Status => 599, Reason => "Unexpected end-of-file" });	927	$cb->(undef, { @pseudo, Status => $ae_error, Reason => "Unexpected end-of-file" });
547	},	928	},
548	;	929	;
549		930
550	# limit the number of persistent connections	931	# limit the number of persistent connections
551	# keepalive not yet supported	932	# keepalive not yet supported
552	# if ($KA_COUNT{$_[1]} < $MAX_PERSISTENT_PER_HOST) {	933	# if ($KA_COUNT{$_[1]} < $MAX_PERSISTENT_PER_HOST) {
553	# ++$KA_COUNT{$_[1]};	934	# ++$KA_COUNT{$_[1]};
554	# $state{handle}{ka_count_guard} = AnyEvent::Util::guard {	935	# $state{handle}{ka_count_guard} = AnyEvent::Util::guard {
555	# --$KA_COUNT{$_[1]}	936	# --$KA_COUNT{$_[1]}
556	# };	937	# };
557	# $hdr{connection} = "keep-alive";	938	# $hdr{connection} = "keep-alive";
558	# }	939	# }
559		940
560	$state{handle}->starttls ("connect") if $rscheme eq "https";	941	$state{handle}->starttls ("connect") if $rscheme eq "https";
561		942
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	943	# now handle proxy-CONNECT method
854	if ($proxy && $uscheme eq "https") {	944	if ($proxy && $uscheme eq "https") {
855	# oh dear, we have to wrap it into a connect request	945	# oh dear, we have to wrap it into a connect request
856		946
857	# maybe re-use $uauthority with patched port?	947	# 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");	948	$state{handle}->push_write ("CONNECT $uhost:$uport HTTP/1.0\015\012\015\012");
859	$state{handle}->push_read (line => $qr_nlnl, sub {	949	$state{handle}->push_read (line => $qr_nlnl, sub {
860	$_[1] =~ /^HTTP\/([0-9\.]+) \s+ ([0-9]{3}) (?: \s+ ([^\015\012]*) )?/ix	950	$_[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])" }));	951	or return (%state = (), $cb->(undef, { @pseudo, Status => 599, Reason => "Invalid proxy connect response ($_[1])" }));
862		952
863	if ($2 == 200) {	953	if ($2 == 200) {
864	$rpath = $upath;	954	$rpath = $upath;
865	&$handle_actual_request;	955	$handle_actual_request->();
866	} else {	956	} else {
867	%state = ();	957	%state = ();
868	$cb->(undef, { @pseudo, Status => $2, Reason => $3 });	958	$cb->(undef, { @pseudo, Status => $2, Reason => $3 });
869	}
870	});	959	}
871	} else {
872	&$handle_actual_request;
873	}	960	});
		961	} else {
		962	$handle_actual_request->();
874	};	963	}
		964	};
		965
		966	_get_slot $uhost, sub {
		967	$state{slot_guard} = shift;
		968
		969	return unless $state{connect_guard};
875		970
876	my $tcp_connect = $arg{tcp_connect}	971	my $tcp_connect = $arg{tcp_connect}
877	\|\| do { require AnyEvent::Socket; \&AnyEvent::Socket::tcp_connect };	972	\|\| do { require AnyEvent::Socket; \&AnyEvent::Socket::tcp_connect };
878		973
879	$state{connect_guard} = $tcp_connect->($rhost, $rport, $connect_cb, $arg{on_prepare} \|\| sub { $timeout });	974	$state{connect_guard} = $tcp_connect->($rhost, $rport, $connect_cb, $arg{on_prepare} \|\| sub { $timeout });
880
881	};	975	};
882		976
883	defined wantarray && AnyEvent::Util::guard { %state = () }	977	defined wantarray && AnyEvent::Util::guard { %state = () }
884	}	978	}
885		979
…		…
920	string of the form C<http://host:port> (optionally C<https:...>), croaks	1014	string of the form C<http://host:port> (optionally C<https:...>), croaks
921	otherwise.	1015	otherwise.
922		1016
923	To clear an already-set proxy, use C<undef>.	1017	To clear an already-set proxy, use C<undef>.
924		1018
		1019	=item AnyEvent::HTTP::cookie_jar_expire $jar[, $session_end]
		1020
		1021	Remove all cookies from the cookie jar that have been expired. If
		1022	C<$session_end> is given and true, then additionally remove all session
		1023	cookies.
		1024
		1025	You should call this function (with a true C<$session_end>) before you
		1026	save cookies to disk, and you should call this function after loading them
		1027	again. If you have a long-running program you can additonally call this
		1028	function from time to time.
		1029
		1030	A cookie jar is initially an empty hash-reference that is managed by this
		1031	module. It's format is subject to change, but currently it is like this:
		1032
		1033	The key C<version> has to contain C<1>, otherwise the hash gets
		1034	emptied. All other keys are hostnames or IP addresses pointing to
		1035	hash-references. The key for these inner hash references is the
		1036	server path for which this cookie is meant, and the values are again
		1037	hash-references. The keys of those hash-references is the cookie name, and
		1038	the value, you guessed it, is another hash-reference, this time with the
		1039	key-value pairs from the cookie, except for C<expires> and C<max-age>,
		1040	which have been replaced by a C<_expires> key that contains the cookie
		1041	expiry timestamp.
		1042
		1043	Here is an example of a cookie jar with a single cookie, so you have a
		1044	chance of understanding the above paragraph:
		1045
		1046	{
		1047	version => 1,
		1048	"10.0.0.1" => {
		1049	"/" => {
		1050	"mythweb_id" => {
		1051	_expires => 1293917923,
		1052	value => "ooRung9dThee3ooyXooM1Ohm",
		1053	},
		1054	},
		1055	},
		1056	}
		1057
925	=item $date = AnyEvent::HTTP::format_date $timestamp	1058	=item $date = AnyEvent::HTTP::format_date $timestamp
926		1059
927	Takes a POSIX timestamp (seconds since the epoch) and formats it as a HTTP	1060	Takes a POSIX timestamp (seconds since the epoch) and formats it as a HTTP
928	Date (RFC 2616).	1061	Date (RFC 2616).
929		1062
930	=item $timestamp = AnyEvent::HTTP::parse_date $date	1063	=item $timestamp = AnyEvent::HTTP::parse_date $date
931		1064
932	Takes a HTTP Date (RFC 2616) or a Cookie date (netscape cookie spec) and	1065	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	1066	bunch of minor variations of those, and returns the corresponding POSIX
934	be parsed.	1067	timestamp, or C<undef> if the date cannot be parsed.
935		1068
936	=item $AnyEvent::HTTP::MAX_RECURSE	1069	=item $AnyEvent::HTTP::MAX_RECURSE
937		1070
938	The default value for the C<recurse> request parameter (default: C<10>).	1071	The default value for the C<recurse> request parameter (default: C<10>).
939		1072
…		…
978	sub parse_date($) {	1111	sub parse_date($) {
979	my ($date) = @_;	1112	my ($date) = @_;
980		1113
981	my ($d, $m, $y, $H, $M, $S);	1114	my ($d, $m, $y, $H, $M, $S);
982		1115
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$/) {	1116	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 " ")	1117	# RFC 822/1123, required by RFC 2616 (with " ")
985	# cookie dates (with "-")	1118	# cookie dates (with "-")
986		1119
987	($d, $m, $y, $H, $M, $S) = ($1, $2, $3, $4, $5, $6);	1120	($d, $m, $y, $H, $M, $S) = ($1, $2, $3, $4, $5, $6);
988		1121
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$/) {	1122	} 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	1123	# RFC 850
991	($d, $m, $y, $H, $M, $S) = ($1, $2, $3 < 69 ? $3 + 2000 : $3 + 1900, $4, $5, $6);	1124	($d, $m, $y, $H, $M, $S) = ($1, $2, $3 < 69 ? $3 + 2000 : $3 + 1900, $4, $5, $6);
992		1125
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])$/) {	1126	} 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	1127	# ISO C's asctime
995	($d, $m, $y, $H, $M, $S) = ($2, $1, $6, $3, $4, $5);	1128	($d, $m, $y, $H, $M, $S) = ($2, $1, $6, $3, $4, $5);
996	}	1129	}
997	# other formats fail in the loop below	1130	# other formats fail in the loop below
998		1131

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.91 by root, Mon Jan 3 01:03:29 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.91 by root, Mon Jan 3 01:03:29 2011 UTC