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

Comparing AnyEvent-HTTP/HTTP.pm (file contents):
Revision 1.5 by root, Wed Jun 4 12:03:47 2008 UTC vs.
Revision 1.11 by root, Thu Jun 5 15:34:00 2008 UTC

…		…
8		8
9	=head1 DESCRIPTION	9	=head1 DESCRIPTION
10		10
11	This module is an L<AnyEvent> user, you need to make sure that you use and	11	This module is an L<AnyEvent> user, you need to make sure that you use and
12	run a supported event loop.	12	run a supported event loop.
		13
		14	This module implements a simple, stateless and non-blocking HTTP
		15	client. It supports GET, POST and other request methods, cookies and more,
		16	all on a very low level. It can follow redirects supports proxies and
		17	automatically limits the number of connections to the values specified in
		18	the RFC.
		19
		20	It should generally be a "good client" that is enough for most HTTP
		21	tasks. Simple tasks should be simple, but complex tasks should still be
		22	possible as the user retains control over request and response headers.
		23
		24	The caller is responsible for authentication management, cookies (if
		25	the simplistic implementation in this module doesn't suffice), referer
		26	and other high-level protocol details for which this module offers only
		27	limited support.
13		28
14	=head2 METHODS	29	=head2 METHODS
15		30
16	=over 4	31	=over 4
17		32
…		…
41	our $PERSISTENT_TIMEOUT = 2;	56	our $PERSISTENT_TIMEOUT = 2;
42	our $TIMEOUT = 300;	57	our $TIMEOUT = 300;
43		58
44	# changing these is evil	59	# changing these is evil
45	our $MAX_PERSISTENT_PER_HOST = 2;	60	our $MAX_PERSISTENT_PER_HOST = 2;
46	our $MAX_PER_HOST = 4; # not respected yet :(	61	our $MAX_PER_HOST = 4;
47		62
48	our $PROXY;	63	our $PROXY;
49		64
50	my %KA_COUNT; # number of open keep-alive connections per host	65	my %KA_COUNT; # number of open keep-alive connections per host
		66	my %CO_SLOT; # number of open connections, and wait queue, per host
51		67
52	=item http_get $url, key => value..., $cb->($data, $headers)	68	=item http_get $url, key => value..., $cb->($data, $headers)
53		69
54	Executes an HTTP-GET request. See the http_request function for details on	70	Executes an HTTP-GET request. See the http_request function for details on
55	additional parameters.	71	additional parameters.
…		…
59	Executes an HTTP-HEAD request. See the http_request function for details on	75	Executes an HTTP-HEAD request. See the http_request function for details on
60	additional parameters.	76	additional parameters.
61		77
62	=item http_post $url, $body, key => value..., $cb->($data, $headers)	78	=item http_post $url, $body, key => value..., $cb->($data, $headers)
63		79
64	Executes an HTTP-POST request with a requets body of C<$bod>. See the	80	Executes an HTTP-POST request with a request body of C<$bod>. See the
65	http_request function for details on additional parameters.	81	http_request function for details on additional parameters.
66		82
67	=item http_request $method => $url, key => value..., $cb->($data, $headers)	83	=item http_request $method => $url, key => value..., $cb->($data, $headers)
68		84
69	Executes a HTTP request of type C<$method> (e.g. C<GET>, C<POST>). The URL	85	Executes a HTTP request of type C<$method> (e.g. C<GET>, C<POST>). The URL
…		…
71		87
72	The callback will be called with the response data as first argument	88	The callback will be called with the response data as first argument
73	(or C<undef> if it wasn't available due to errors), and a hash-ref with	89	(or C<undef> if it wasn't available due to errors), and a hash-ref with
74	response headers as second argument.	90	response headers as second argument.
75		91
76	All the headers in that has are lowercased. In addition to the response	92	All the headers in that hash are lowercased. In addition to the response
77	headers, the three "pseudo-headers" C<HTTPVersion>, C<Status> and	93	headers, the three "pseudo-headers" C<HTTPVersion>, C<Status> and
78	C<Reason> contain the three parts of the HTTP Status-Line of the same	94	C<Reason> contain the three parts of the HTTP Status-Line of the same
79	name.	95	name. If the server sends a header multiple lines, then their contents
		96	will be joined together with C<\x00>.
80		97
81	If an internal error occurs, such as not being able to resolve a hostname,	98	If an internal error occurs, such as not being able to resolve a hostname,
82	then C<$data> will be C<undef>, C<< $headers->{Status} >> will be C<599>	99	then C<$data> will be C<undef>, C<< $headers->{Status} >> will be C<599>
83	and the C<Reason> pseudo-header will contain an error message.	100	and the C<Reason> pseudo-header will contain an error message.
84		101
		102	A typical callback might look like this:
		103
		104	sub {
		105	my ($body, $hdr) = @_;
		106
		107	if ($hdr->{Status} =~ /^2/) {
		108	... everything should be ok
		109	} else {
		110	print "error, $hdr->{Status} $hdr->{Reason}\n";
		111	}
		112	}
		113
85	Additional parameters are key-value pairs, and are fully optional. They	114	Additional parameters are key-value pairs, and are fully optional. They
86	include:	115	include:
87		116
88	=over 4	117	=over 4
89		118
…		…
112	=item body => $string	141	=item body => $string
113		142
114	The request body, usually empty. Will be-sent as-is (future versions of	143	The request body, usually empty. Will be-sent as-is (future versions of
115	this module might offer more options).	144	this module might offer more options).
116		145
		146	=item cookie_jar => $hash_ref
		147
		148	Passing this parameter enables (simplified) cookie-processing, loosely
		149	based on the original netscape specification.
		150
		151	The C<$hash_ref> must be an (initially empty) hash reference which will
		152	get updated automatically. It is possible to save the cookie_jar to
		153	persistent storage with something like JSON or Storable, but this is not
		154	recommended, as expire times are currently being ignored.
		155
		156	Note that this cookie implementation is not of very high quality, nor
		157	meant to be complete. If you want complete cookie management you have to
		158	do that on your own. C<cookie_jar> is meant as a quick fix to get some
		159	cookie-using sites working. Cookies are a privacy disaster, do not use
		160	them unless required to.
		161
117	=back	162	=back
118		163
119	=back	164	Example: make a simple HTTP GET request for http://www.nethype.de/
		165
		166	http_request GET => "http://www.nethype.de/", sub {
		167	my ($body, $hdr) = @_;
		168	print "$body\n";
		169	};
		170
		171	Example: make a HTTP HEAD request on https://www.google.com/, use a
		172	timeout of 30 seconds.
		173
		174	http_request
		175	GET => "https://www.google.com",
		176	timeout => 30,
		177	sub {
		178	my ($body, $hdr) = @_;
		179	use Data::Dumper;
		180	print Dumper $hdr;
		181	}
		182	;
120		183
121	=cut	184	=cut
		185
		186	sub _slot_schedule($) {
		187	my $host = shift;
		188
		189	while ($CO_SLOT{$host}[0] < $MAX_PER_HOST) {
		190	if (my $cb = shift @{ $CO_SLOT{$host}[1] }) {
		191	# somebody wnats that slot
		192	++$CO_SLOT{$host}[0];
		193
		194	$cb->(AnyEvent::Util::guard {
		195	--$CO_SLOT{$host}[0];
		196	_slot_schedule $host;
		197	});
		198	} else {
		199	# nobody wants the slot, maybe we can forget about it
		200	delete $CO_SLOT{$host} unless $CO_SLOT{$host}[0];
		201	warn "$host deleted" unless $CO_SLOT{$host}[0];#d#
		202	last;
		203	}
		204	}
		205	}
		206
		207	# wait for a free slot on host, call callback
		208	sub _get_slot($$) {
		209	push @{ $CO_SLOT{$_[0]}[1] }, $_[1];
		210
		211	_slot_schedule $_[0];
		212	}
122		213
123	sub http_request($$$;@) {	214	sub http_request($$$;@) {
124	my $cb = pop;	215	my $cb = pop;
125	my ($method, $url, %arg) = @_;	216	my ($method, $url, %arg) = @_;
126		217
127	my %hdr;	218	my %hdr;
128		219
129	$method = uc $method;	220	$method = uc $method;
130		221
131	if (my $hdr = delete $arg{headers}) {	222	if (my $hdr = $arg{headers}) {
132	while (my ($k, $v) = each %$hdr) {	223	while (my ($k, $v) = each %$hdr) {
133	$hdr{lc $k} = $v;	224	$hdr{lc $k} = $v;
134	}	225	}
135	}	226	}
136		227
		228	my $recurse = exists $arg{recurse} ? $arg{recurse} : $MAX_RECURSE;
		229
		230	return $cb->(undef, { Status => 599, Reason => "recursion limit reached" })
		231	if $recurse < 0;
		232
137	my $proxy = $arg{proxy} \|\| $PROXY;	233	my $proxy = $arg{proxy} \|\| $PROXY;
138	my $timeout = $arg{timeout} \|\| $TIMEOUT;	234	my $timeout = $arg{timeout} \|\| $TIMEOUT;
139	my $recurse = exists $arg{recurse} ? $arg{recurse} : $MAX_RECURSE;
140		235
141	$hdr{"user-agent"} \|\|= $USERAGENT;	236	$hdr{"user-agent"} \|\|= $USERAGENT;
142		237
143	my ($host, $port, $path, $scheme);	238	my ($scheme, $authority, $upath, $query, $fragment) =
		239	$url =~ m\|(?:([^:/?#]+):)?(?://([^/?#]))?([^?#])(?:\?([^#]))?(?:#(.))?\|;
		240
		241	$scheme = lc $scheme;
		242
		243	my $uport = $scheme eq "http" ? 80
		244	: $scheme eq "https" ? 443
		245	: return $cb->(undef, { Status => 599, Reason => "only http and https URL schemes supported" });
		246
		247	$authority =~ /^(?: .*\@ )? ([^\@:]+) (?: : (\d+) )?$/x
		248	or return $cb->(undef, { Status => 599, Reason => "unparsable URL" });
		249
		250	my $uhost = $1;
		251	$uport = $2 if defined $2;
		252
		253	$uhost =~ s/^\[(.*)\]$/$1/;
		254	$upath .= "?$query" if length $query;
		255
		256	$upath =~ s%^/?%/%;
		257
		258	# cookie processing
		259	if (my $jar = $arg{cookie_jar}) {
		260	%$jar = () if $jar->{version} < 1;
		261
		262	my @cookie;
		263
		264	while (my ($chost, $v) = each %$jar) {
		265	next unless $chost eq substr $uhost, -length $chost;
		266	next unless $chost =~ /^\./;
		267
		268	while (my ($cpath, $v) = each %$v) {
		269	next unless $cpath eq substr $upath, 0, length $cpath;
		270
		271	while (my ($k, $v) = each %$v) {
		272	next if $scheme ne "https" && exists $v->{secure};
		273	push @cookie, "$k=$v->{value}";
		274	}
		275	}
		276	}
		277
		278	$hdr{cookie} = join "; ", @cookie
		279	if @cookie;
		280	}
		281
		282	my ($rhost, $rport, $rpath); # request host, port, path
144		283
145	if ($proxy) {	284	if ($proxy) {
146	($host, $port, $scheme) = @$proxy;	285	($rhost, $rport, $scheme) = @$proxy;
147	$path = $url;	286	$rpath = $url;
148	} else {	287	} else {
149	($scheme, my $authority, $path, my $query, my $fragment) =	288	($rhost, $rport, $rpath) = ($uhost, $uport, $upath);
150	$url =~ m\|(?:([^:/?#]+):)?(?://([^/?#]))?([^?#])(?:\?([^#]))?(?:#(.))?\|;
151
152	$port = $scheme eq "http" ? 80
153	: $scheme eq "https" ? 443
154	: croak "$url: only http and https URLs supported";
155
156	$authority =~ /^(?: .*\@ )? ([^\@:]+) (?: : (\d+) )?$/x
157	or croak "$authority: unparsable URL";
158
159	$host = $1;
160	$port = $2 if defined $2;
161
162	$host =~ s/^\[(.*)\]$/$1/;
163	$path .= "?$query" if length $query;
164
165	$path = "/" unless $path;
166
167	$hdr{host} = $host = lc $host;	289	$hdr{host} = $uhost;
168	}	290	}
169		291
170	$scheme = lc $scheme;
171
172	my %state;
173
174	$state{body} = delete $arg{body};
175
176	$hdr{"content-length"} = length $state{body};	292	$hdr{"content-length"} = length $arg{body};
177		293
		294	my %state = (connect_guard => 1);
		295
		296	_get_slot $uhost, sub {
		297	$state{slot_guard} = shift;
		298
		299	return unless $state{connect_guard};
		300
178	$state{connect_guard} = AnyEvent::Socket::tcp_connect $host, $port, sub {	301	$state{connect_guard} = AnyEvent::Socket::tcp_connect $rhost, $rport, sub {
179	$state{fh} = shift	302	$state{fh} = shift
180	or return $cb->(undef, { Status => 599, Reason => "$!" });	303	or return $cb->(undef, { Status => 599, Reason => "$!" });
181		304
182	delete $state{connect_guard}; # reduce memory usage, save a tree	305	delete $state{connect_guard}; # reduce memory usage, save a tree
183		306
184	# get handle	307	# get handle
185	$state{handle} = new AnyEvent::Handle	308	$state{handle} = new AnyEvent::Handle
186	fh => $state{fh},	309	fh => $state{fh},
187	($scheme eq "https" ? (tls => "connect") : ());	310	($scheme eq "https" ? (tls => "connect") : ());
188		311
189	# limit the number of persistent connections	312	# limit the number of persistent connections
190	if ($KA_COUNT{$_[1]} < $MAX_PERSISTENT_PER_HOST) {	313	if ($KA_COUNT{$_[1]} < $MAX_PERSISTENT_PER_HOST) {
191	++$KA_COUNT{$_[1]};	314	++$KA_COUNT{$_[1]};
192	$state{handle}{ka_count_guard} = AnyEvent::Util::guard { --$KA_COUNT{$_[1]} };	315	$state{handle}{ka_count_guard} = AnyEvent::Util::guard { --$KA_COUNT{$_[1]} };
193	$hdr{connection} = "keep-alive";	316	$hdr{connection} = "keep-alive";
194	delete $hdr{connection}; # keep-alive not yet supported	317	delete $hdr{connection}; # keep-alive not yet supported
195	} else {	318	} else {
196	delete $hdr{connection};	319	delete $hdr{connection};
197	}	320	}
198		321
199	# (re-)configure handle	322	# (re-)configure handle
200	$state{handle}->timeout ($timeout);	323	$state{handle}->timeout ($timeout);
201	$state{handle}->on_error (sub {	324	$state{handle}->on_error (sub {
202	%state = ();	325	%state = ();
203	$cb->(undef, { Status => 599, Reason => "$!" });	326	$cb->(undef, { Status => 599, Reason => "$!" });
204	});	327	});
205	$state{handle}->on_eof (sub {	328	$state{handle}->on_eof (sub {
206	%state = ();	329	%state = ();
207	$cb->(undef, { Status => 599, Reason => "unexpected end-of-file" });	330	$cb->(undef, { Status => 599, Reason => "unexpected end-of-file" });
208	});	331	});
209		332
210	# send request	333	# send request
211	$state{handle}->push_write (	334	$state{handle}->push_write (
212	"$method $path HTTP/1.0\015\012"	335	"$method $rpath HTTP/1.0\015\012"
213	. (join "", map "$_: $hdr{$_}\015\012", keys %hdr)	336	. (join "", map "$_: $hdr{$_}\015\012", keys %hdr)
214	. "\015\012"	337	. "\015\012"
215	. (delete $state{body})	338	. (delete $arg{body})
216	);
217
218	%hdr = (); # reduce memory usage, save a kitten
219
220	# status line
221	$state{handle}->push_read (line => qr/\015?\012/, sub {
222	$_[1] =~ /^HTTP\/([0-9\.]+) \s+ ([0-9]{3}) \s+ ([^\015\012]+)/ix
223	or return (%state = (), $cb->(undef, { Status => 599, Reason => "invalid server response ($_[1])" }));
224
225	my %hdr = ( # response headers
226	HTTPVersion => ",$1",
227	Status => ",$2",
228	Reason => ",$3",
229	);	339	);
230		340
		341	%hdr = (); # reduce memory usage, save a kitten
		342
		343	# status line
		344	$state{handle}->push_read (line => qr/\015?\012/, sub {
		345	$_[1] =~ /^HTTP\/([0-9\.]+) \s+ ([0-9]{3}) \s+ ([^\015\012]+)/ix
		346	or return (%state = (), $cb->(undef, { Status => 599, Reason => "invalid server response ($_[1])" }));
		347
		348	my %hdr = ( # response headers
		349	HTTPVersion => "\x00$1",
		350	Status => "\x00$2",
		351	Reason => "\x00$3",
		352	);
		353
231	# headers, could be optimized a bit	354	# headers, could be optimized a bit
232	$state{handle}->unshift_read (line => qr/\015?\012\015?\012/, sub {	355	$state{handle}->unshift_read (line => qr/\015?\012\015?\012/, sub {
233	for ("$_[1]\012") {	356	for ("$_[1]\012") {
234	# we support spaces in field names, as lotus domino	357	# we support spaces in field names, as lotus domino
235	# creates them.	358	# creates them.
236	$hdr{lc $1} .= ",$2"	359	$hdr{lc $1} .= "\x00$2"
237	while /\G	360	while /\G
238	([^:\000-\037]+):	361	([^:\000-\037]+):
239	[\011\040]*	362	[\011\040]*
240	((?: [^\015\012]+ \| \015?\012[\011\040] )*)	363	((?: [^\015\012]+ \| \015?\012[\011\040] )*)
241	\015?\012	364	\015?\012
242	/gxc;	365	/gxc;
243		366
244	/\G$/	367	/\G$/
245	or return $cb->(undef, { Status => 599, Reason => "garbled response headers" });	368	or return (%state = (), $cb->(undef, { Status => 599, Reason => "garbled response headers" }));
246	}	369	}
247		370
248	substr $_, 0, 1, ""	371	substr $_, 0, 1, ""
249	for values %hdr;	372	for values %hdr;
250		373
251	if ($method eq "HEAD") {	374	my $finish = sub {
252	%state = ();	375	%state = ();
253	$cb->(undef, \%hdr);	376
254	} else {	377	# set-cookie processing
255	if (exists $hdr{"content-length"}) {	378	if ($arg{cookie_jar} && exists $hdr{"set-cookie"}) {
256	$_[0]->unshift_read (chunk => $hdr{"content-length"}, sub {	379	for (split /\x00/, $hdr{"set-cookie"}) {
257	# could cache persistent connection now	380	my ($cookie, @arg) = split /;\s*/;
258	if ($hdr{connection} =~ /\bkeep-alive\b/i) {	381	my ($name, $value) = split /=/, $cookie, 2;
259	# but we don't, due to misdesigns, this is annoyingly complex	382	my %kv = (value => $value, map { split /=/, $_, 2 } @arg);
		383
		384	my $cdom = (delete $kv{domain}) \|\| $uhost;
		385	my $cpath = (delete $kv{path}) \|\| "/";
		386
		387	$cdom =~ s/^.?/./; # make sure it starts with a "."
		388
		389	next if $cdom =~ /\.$/;
		390
		391	# this is not rfc-like and not netscape-like. go figure.
		392	my $ndots = $cdom =~ y/.//;
		393	next if $ndots < ($cdom =~ /\.[^.][^.]\.[^.][^.]$/ ? 3 : 2);
		394
		395	# store it
		396	$arg{cookie_jar}{version} = 1;
		397	$arg{cookie_jar}{$cdom}{$cpath}{$name} = \%kv;
260	};	398	}
261
262	%state = ();
263	$cb->($_[1], \%hdr);
264	});	399	}
		400
		401	if ($_[1]{Status} =~ /^x30[12]$/ && $recurse) {
		402	# microsoft and other assholes don't give a shit for following standards,
		403	# try to support a common form of broken Location header.
		404	$_[1]{location} =~ s%^/%$scheme://$uhost:$uport/%;
		405
		406	http_request ($method, $_[1]{location}, %arg, recurse => $recurse - 1, $cb);
		407	} else {
		408	$cb->($_[0], $_[1]);
		409	}
		410	};
		411
		412	if ($hdr{Status} =~ /^(?:1..\|204\|304)$/ or $method eq "HEAD") {
		413	$finish->(undef, \%hdr);
265	} else {	414	} else {
		415	if (exists $hdr{"content-length"}) {
		416	$_[0]->unshift_read (chunk => $hdr{"content-length"}, sub {
		417	# could cache persistent connection now
		418	if ($hdr{connection} =~ /\bkeep-alive\b/i) {
		419	# but we don't, due to misdesigns, this is annoyingly complex
		420	};
		421
		422	$finish->($_[1], \%hdr);
		423	});
		424	} else {
266	# too bad, need to read until we get an error or EOF,	425	# too bad, need to read until we get an error or EOF,
267	# no way to detect winged data.	426	# no way to detect winged data.
268	$_[0]->on_error (sub {	427	$_[0]->on_error (sub {
269	%state = ();
270	$cb->($_[0]{rbuf}, \%hdr);	428	$finish->($_[0]{rbuf}, \%hdr);
271	});	429	});
272	$_[0]->on_eof (undef);	430	$_[0]->on_eof (undef);
273	$_[0]->on_read (sub { });	431	$_[0]->on_read (sub { });
		432	}
274	}	433	}
275	}	434	});
276	});	435	});
		436	}, sub {
		437	$timeout
277	});	438	};
278	}, sub {
279	$timeout
280	};	439	};
281		440
282	defined wantarray && AnyEvent::Util::guard { %state = () }	441	defined wantarray && AnyEvent::Util::guard { %state = () }
283	}	442	}
284		443
…		…
295	sub http_post($$$;@) {	454	sub http_post($$$;@) {
296	unshift @_, "POST", "body";	455	unshift @_, "POST", "body";
297	&http_request	456	&http_request
298	}	457	}
299		458
		459	=back
		460
300	=head2 GLOBAL FUNCTIONS AND VARIABLES	461	=head2 GLOBAL FUNCTIONS AND VARIABLES
301		462
302	=over 4	463	=over 4
303		464
304	=item AnyEvent::HTTP::set_proxy "proxy-url"	465	=item AnyEvent::HTTP::set_proxy "proxy-url"

Diff Legend

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

Comparing AnyEvent-HTTP/HTTP.pm (file contents): Revision 1.5 by root, Wed Jun 4 12:03:47 2008 UTC vs. Revision 1.11 by root, Thu Jun 5 15:34:00 2008 UTC

Diff Legend

Comparing AnyEvent-HTTP/HTTP.pm (file contents):
Revision 1.5 by root, Wed Jun 4 12:03:47 2008 UTC vs.
Revision 1.11 by root, Thu Jun 5 15:34:00 2008 UTC