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

Comparing AnyEvent-HTTP/HTTP.pm (file contents):
Revision 1.6 by root, Wed Jun 4 12:05:45 2008 UTC vs.
Revision 1.13 by root, Thu Jun 5 16:43:45 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
…		…
104	Whether to recurse requests or not, e.g. on redirects, authentication	121	Whether to recurse requests or not, e.g. on redirects, authentication
105	retries and so on, and how often to do so.	122	retries and so on, and how often to do so.
106		123
107	=item headers => hashref	124	=item headers => hashref
108		125
109	The request headers to use.	126	The request headers to use. Currently, C<http_request> may provide its
		127	own C<Host:>, C<Content-Length:>, C<Connection:> and C<Cookie:> headers
		128	and will provide defaults for C<User-Agent:> and C<Referer:>.
110		129
111	=item timeout => $seconds	130	=item timeout => $seconds
112		131
113	The time-out to use for various stages - each connect attempt will reset	132	The time-out to use for various stages - each connect attempt will reset
114	the timeout, as will read or write activity. Default timeout is 5 minutes.	133	the timeout, as will read or write activity. Default timeout is 5 minutes.
…		…
124	=item body => $string	143	=item body => $string
125		144
126	The request body, usually empty. Will be-sent as-is (future versions of	145	The request body, usually empty. Will be-sent as-is (future versions of
127	this module might offer more options).	146	this module might offer more options).
128		147
		148	=item cookie_jar => $hash_ref
		149
		150	Passing this parameter enables (simplified) cookie-processing, loosely
		151	based on the original netscape specification.
		152
		153	The C<$hash_ref> must be an (initially empty) hash reference which will
		154	get updated automatically. It is possible to save the cookie_jar to
		155	persistent storage with something like JSON or Storable, but this is not
		156	recommended, as expire times are currently being ignored.
		157
		158	Note that this cookie implementation is not of very high quality, nor
		159	meant to be complete. If you want complete cookie management you have to
		160	do that on your own. C<cookie_jar> is meant as a quick fix to get some
		161	cookie-using sites working. Cookies are a privacy disaster, do not use
		162	them unless required to.
		163
129	=back	164	=back
130		165
131	=back	166	Example: make a simple HTTP GET request for http://www.nethype.de/
		167
		168	http_request GET => "http://www.nethype.de/", sub {
		169	my ($body, $hdr) = @_;
		170	print "$body\n";
		171	};
		172
		173	Example: make a HTTP HEAD request on https://www.google.com/, use a
		174	timeout of 30 seconds.
		175
		176	http_request
		177	GET => "https://www.google.com",
		178	timeout => 30,
		179	sub {
		180	my ($body, $hdr) = @_;
		181	use Data::Dumper;
		182	print Dumper $hdr;
		183	}
		184	;
132		185
133	=cut	186	=cut
		187
		188	sub _slot_schedule;
		189	sub _slot_schedule($) {
		190	my $host = shift;
		191
		192	while ($CO_SLOT{$host}[0] < $MAX_PER_HOST) {
		193	if (my $cb = shift @{ $CO_SLOT{$host}[1] }) {
		194	# somebody wants that slot
		195	++$CO_SLOT{$host}[0];
		196
		197	$cb->(AnyEvent::Util::guard {
		198	--$CO_SLOT{$host}[0];
		199	_slot_schedule $host;
		200	});
		201	} else {
		202	# nobody wants the slot, maybe we can forget about it
		203	delete $CO_SLOT{$host} unless $CO_SLOT{$host}[0];
		204	last;
		205	}
		206	}
		207	}
		208
		209	# wait for a free slot on host, call callback
		210	sub _get_slot($$) {
		211	push @{ $CO_SLOT{$_[0]}[1] }, $_[1];
		212
		213	_slot_schedule $_[0];
		214	}
134		215
135	sub http_request($$$;@) {	216	sub http_request($$$;@) {
136	my $cb = pop;	217	my $cb = pop;
137	my ($method, $url, %arg) = @_;	218	my ($method, $url, %arg) = @_;
138		219
139	my %hdr;	220	my %hdr;
140		221
141	$method = uc $method;	222	$method = uc $method;
142		223
143	if (my $hdr = delete $arg{headers}) {	224	if (my $hdr = $arg{headers}) {
144	while (my ($k, $v) = each %$hdr) {	225	while (my ($k, $v) = each %$hdr) {
145	$hdr{lc $k} = $v;	226	$hdr{lc $k} = $v;
146	}	227	}
147	}	228	}
148		229
		230	my $recurse = exists $arg{recurse} ? $arg{recurse} : $MAX_RECURSE;
		231
		232	return $cb->(undef, { Status => 599, Reason => "recursion limit reached" })
		233	if $recurse < 0;
		234
149	my $proxy = $arg{proxy} \|\| $PROXY;	235	my $proxy = $arg{proxy} \|\| $PROXY;
150	my $timeout = $arg{timeout} \|\| $TIMEOUT;	236	my $timeout = $arg{timeout} \|\| $TIMEOUT;
151	my $recurse = exists $arg{recurse} ? $arg{recurse} : $MAX_RECURSE;
152		237
153	$hdr{"user-agent"} \|\|= $USERAGENT;	238	$hdr{"user-agent"} \|\|= $USERAGENT;
154		239
155	my ($host, $port, $path, $scheme);	240	my ($scheme, $authority, $upath, $query, $fragment) =
		241	$url =~ m\|(?:([^:/?#]+):)?(?://([^/?#]))?([^?#])(?:\?([^#]))?(?:#(.))?\|;
		242
		243	$scheme = lc $scheme;
		244
		245	my $uport = $scheme eq "http" ? 80
		246	: $scheme eq "https" ? 443
		247	: return $cb->(undef, { Status => 599, Reason => "only http and https URL schemes supported" });
		248
		249	$hdr{referer} \|\|= "$scheme://$authority$upath"; # leave out fragment and query string, just a heuristic
		250
		251	$authority =~ /^(?: .*\@ )? ([^\@:]+) (?: : (\d+) )?$/x
		252	or return $cb->(undef, { Status => 599, Reason => "unparsable URL" });
		253
		254	my $uhost = $1;
		255	$uport = $2 if defined $2;
		256
		257	$uhost =~ s/^\[(.*)\]$/$1/;
		258	$upath .= "?$query" if length $query;
		259
		260	$upath =~ s%^/?%/%;
		261
		262	# cookie processing
		263	if (my $jar = $arg{cookie_jar}) {
		264	%$jar = () if $jar->{version} < 1;
		265
		266	my @cookie;
		267
		268	while (my ($chost, $v) = each %$jar) {
		269	next unless $chost eq substr $uhost, -length $chost;
		270	next unless $chost =~ /^\./;
		271
		272	while (my ($cpath, $v) = each %$v) {
		273	next unless $cpath eq substr $upath, 0, length $cpath;
		274
		275	while (my ($k, $v) = each %$v) {
		276	next if $scheme ne "https" && exists $v->{secure};
		277	push @cookie, "$k=$v->{value}";
		278	}
		279	}
		280	}
		281
		282	$hdr{cookie} = join "; ", @cookie
		283	if @cookie;
		284	}
		285
		286	my ($rhost, $rport, $rpath); # request host, port, path
156		287
157	if ($proxy) {	288	if ($proxy) {
158	($host, $port, $scheme) = @$proxy;	289	($rhost, $rport, $scheme) = @$proxy;
159	$path = $url;	290	$rpath = $url;
160	} else {	291	} else {
161	($scheme, my $authority, $path, my $query, my $fragment) =	292	($rhost, $rport, $rpath) = ($uhost, $uport, $upath);
162	$url =~ m\|(?:([^:/?#]+):)?(?://([^/?#]))?([^?#])(?:\?([^#]))?(?:#(.))?\|;
163
164	$port = $scheme eq "http" ? 80
165	: $scheme eq "https" ? 443
166	: croak "$url: only http and https URLs supported";
167
168	$authority =~ /^(?: .*\@ )? ([^\@:]+) (?: : (\d+) )?$/x
169	or croak "$authority: unparsable URL";
170
171	$host = $1;
172	$port = $2 if defined $2;
173
174	$host =~ s/^\[(.*)\]$/$1/;
175	$path .= "?$query" if length $query;
176
177	$path = "/" unless $path;
178
179	$hdr{host} = $host = lc $host;	293	$hdr{host} = $uhost;
180	}	294	}
181		295
182	$scheme = lc $scheme;
183
184	my %state;
185
186	$state{body} = delete $arg{body};
187
188	$hdr{"content-length"} = length $state{body};	296	$hdr{"content-length"} = length $arg{body};
189		297
		298	my %state = (connect_guard => 1);
		299
		300	_get_slot $uhost, sub {
		301	$state{slot_guard} = shift;
		302
		303	return unless $state{connect_guard};
		304
190	$state{connect_guard} = AnyEvent::Socket::tcp_connect $host, $port, sub {	305	$state{connect_guard} = AnyEvent::Socket::tcp_connect $rhost, $rport, sub {
191	$state{fh} = shift	306	$state{fh} = shift
192	or return $cb->(undef, { Status => 599, Reason => "$!" });	307	or return $cb->(undef, { Status => 599, Reason => "$!" });
193		308
194	delete $state{connect_guard}; # reduce memory usage, save a tree	309	delete $state{connect_guard}; # reduce memory usage, save a tree
195		310
196	# get handle	311	# get handle
197	$state{handle} = new AnyEvent::Handle	312	$state{handle} = new AnyEvent::Handle
198	fh => $state{fh},	313	fh => $state{fh},
199	($scheme eq "https" ? (tls => "connect") : ());	314	($scheme eq "https" ? (tls => "connect") : ());
200		315
201	# limit the number of persistent connections	316	# limit the number of persistent connections
202	if ($KA_COUNT{$_[1]} < $MAX_PERSISTENT_PER_HOST) {	317	if ($KA_COUNT{$_[1]} < $MAX_PERSISTENT_PER_HOST) {
203	++$KA_COUNT{$_[1]};	318	++$KA_COUNT{$_[1]};
204	$state{handle}{ka_count_guard} = AnyEvent::Util::guard { --$KA_COUNT{$_[1]} };	319	$state{handle}{ka_count_guard} = AnyEvent::Util::guard { --$KA_COUNT{$_[1]} };
205	$hdr{connection} = "keep-alive";	320	$hdr{connection} = "keep-alive";
206	delete $hdr{connection}; # keep-alive not yet supported	321	delete $hdr{connection}; # keep-alive not yet supported
207	} else {	322	} else {
208	delete $hdr{connection};	323	delete $hdr{connection};
209	}	324	}
210		325
211	# (re-)configure handle	326	# (re-)configure handle
212	$state{handle}->timeout ($timeout);	327	$state{handle}->timeout ($timeout);
213	$state{handle}->on_error (sub {	328	$state{handle}->on_error (sub {
214	%state = ();	329	%state = ();
215	$cb->(undef, { Status => 599, Reason => "$!" });	330	$cb->(undef, { Status => 599, Reason => "$!" });
216	});	331	});
217	$state{handle}->on_eof (sub {	332	$state{handle}->on_eof (sub {
218	%state = ();	333	%state = ();
219	$cb->(undef, { Status => 599, Reason => "unexpected end-of-file" });	334	$cb->(undef, { Status => 599, Reason => "unexpected end-of-file" });
220	});	335	});
221		336
222	# send request	337	# send request
223	$state{handle}->push_write (	338	$state{handle}->push_write (
224	"$method $path HTTP/1.0\015\012"	339	"$method $rpath HTTP/1.0\015\012"
225	. (join "", map "$_: $hdr{$_}\015\012", keys %hdr)	340	. (join "", map "$_: $hdr{$_}\015\012", keys %hdr)
226	. "\015\012"	341	. "\015\012"
227	. (delete $state{body})	342	. (delete $arg{body})
228	);
229
230	%hdr = (); # reduce memory usage, save a kitten
231
232	# status line
233	$state{handle}->push_read (line => qr/\015?\012/, sub {
234	$_[1] =~ /^HTTP\/([0-9\.]+) \s+ ([0-9]{3}) \s+ ([^\015\012]+)/ix
235	or return (%state = (), $cb->(undef, { Status => 599, Reason => "invalid server response ($_[1])" }));
236
237	my %hdr = ( # response headers
238	HTTPVersion => ",$1",
239	Status => ",$2",
240	Reason => ",$3",
241	);	343	);
242		344
		345	%hdr = (); # reduce memory usage, save a kitten
		346
		347	# status line
		348	$state{handle}->push_read (line => qr/\015?\012/, sub {
		349	$_[1] =~ /^HTTP\/([0-9\.]+) \s+ ([0-9]{3}) \s+ ([^\015\012]+)/ix
		350	or return (%state = (), $cb->(undef, { Status => 599, Reason => "invalid server response ($_[1])" }));
		351
		352	my %hdr = ( # response headers
		353	HTTPVersion => "\x00$1",
		354	Status => "\x00$2",
		355	Reason => "\x00$3",
		356	);
		357
243	# headers, could be optimized a bit	358	# headers, could be optimized a bit
244	$state{handle}->unshift_read (line => qr/\015?\012\015?\012/, sub {	359	$state{handle}->unshift_read (line => qr/\015?\012\015?\012/, sub {
245	for ("$_[1]\012") {	360	for ("$_[1]\012") {
246	# we support spaces in field names, as lotus domino	361	# we support spaces in field names, as lotus domino
247	# creates them.	362	# creates them.
248	$hdr{lc $1} .= ",$2"	363	$hdr{lc $1} .= "\x00$2"
249	while /\G	364	while /\G
250	([^:\000-\037]+):	365	([^:\000-\037]+):
251	[\011\040]*	366	[\011\040]*
252	((?: [^\015\012]+ \| \015?\012[\011\040] )*)	367	((?: [^\015\012]+ \| \015?\012[\011\040] )*)
253	\015?\012	368	\015?\012
254	/gxc;	369	/gxc;
255		370
256	/\G$/	371	/\G$/
257	or return $cb->(undef, { Status => 599, Reason => "garbled response headers" });	372	or return (%state = (), $cb->(undef, { Status => 599, Reason => "garbled response headers" }));
258	}	373	}
259		374
260	substr $_, 0, 1, ""	375	substr $_, 0, 1, ""
261	for values %hdr;	376	for values %hdr;
262		377
263	if ($method eq "HEAD") {	378	my $finish = sub {
264	%state = ();	379	%state = ();
265	$cb->(undef, \%hdr);	380
266	} else {	381	# set-cookie processing
267	if (exists $hdr{"content-length"}) {	382	if ($arg{cookie_jar} && exists $hdr{"set-cookie"}) {
268	$_[0]->unshift_read (chunk => $hdr{"content-length"}, sub {	383	for (split /\x00/, $hdr{"set-cookie"}) {
269	# could cache persistent connection now	384	my ($cookie, @arg) = split /;\s*/;
270	if ($hdr{connection} =~ /\bkeep-alive\b/i) {	385	my ($name, $value) = split /=/, $cookie, 2;
271	# but we don't, due to misdesigns, this is annoyingly complex	386	my %kv = (value => $value, map { split /=/, $_, 2 } @arg);
		387
		388	my $cdom = (delete $kv{domain}) \|\| $uhost;
		389	my $cpath = (delete $kv{path}) \|\| "/";
		390
		391	$cdom =~ s/^.?/./; # make sure it starts with a "."
		392
		393	next if $cdom =~ /\.$/;
		394
		395	# this is not rfc-like and not netscape-like. go figure.
		396	my $ndots = $cdom =~ y/.//;
		397	next if $ndots < ($cdom =~ /\.[^.][^.]\.[^.][^.]$/ ? 3 : 2);
		398
		399	# store it
		400	$arg{cookie_jar}{version} = 1;
		401	$arg{cookie_jar}{$cdom}{$cpath}{$name} = \%kv;
272	};	402	}
273
274	%state = ();
275	$cb->($_[1], \%hdr);
276	});	403	}
		404
		405	if ($_[1]{Status} =~ /^30[12]$/ && $recurse) {
		406	# microsoft and other assholes don't give a shit for following standards,
		407	# try to support a common form of broken Location header.
		408	$_[1]{location} =~ s%^/%$scheme://$uhost:$uport/%;
		409
		410	http_request ($method, $_[1]{location}, %arg, recurse => $recurse - 1, $cb);
		411	} else {
		412	$cb->($_[0], $_[1]);
		413	}
		414	};
		415
		416	if ($hdr{Status} =~ /^(?:1..\|204\|304)$/ or $method eq "HEAD") {
		417	$finish->(undef, \%hdr);
277	} else {	418	} else {
		419	if (exists $hdr{"content-length"}) {
		420	$_[0]->unshift_read (chunk => $hdr{"content-length"}, sub {
		421	# could cache persistent connection now
		422	if ($hdr{connection} =~ /\bkeep-alive\b/i) {
		423	# but we don't, due to misdesigns, this is annoyingly complex
		424	};
		425
		426	$finish->($_[1], \%hdr);
		427	});
		428	} else {
278	# too bad, need to read until we get an error or EOF,	429	# too bad, need to read until we get an error or EOF,
279	# no way to detect winged data.	430	# no way to detect winged data.
280	$_[0]->on_error (sub {	431	$_[0]->on_error (sub {
281	%state = ();
282	$cb->($_[0]{rbuf}, \%hdr);	432	$finish->($_[0]{rbuf}, \%hdr);
283	});	433	});
284	$_[0]->on_eof (undef);	434	$_[0]->on_eof (undef);
285	$_[0]->on_read (sub { });	435	$_[0]->on_read (sub { });
		436	}
286	}	437	}
287	}	438	});
288	});	439	});
		440	}, sub {
		441	$timeout
289	});	442	};
290	}, sub {
291	$timeout
292	};	443	};
293		444
294	defined wantarray && AnyEvent::Util::guard { %state = () }	445	defined wantarray && AnyEvent::Util::guard { %state = () }
295	}	446	}
296		447
…		…
307	sub http_post($$$;@) {	458	sub http_post($$$;@) {
308	unshift @_, "POST", "body";	459	unshift @_, "POST", "body";
309	&http_request	460	&http_request
310	}	461	}
311		462
		463	=back
		464
312	=head2 GLOBAL FUNCTIONS AND VARIABLES	465	=head2 GLOBAL FUNCTIONS AND VARIABLES
313		466
314	=over 4	467	=over 4
315		468
316	=item AnyEvent::HTTP::set_proxy "proxy-url"	469	=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.6 by root, Wed Jun 4 12:05:45 2008 UTC vs. Revision 1.13 by root, Thu Jun 5 16:43:45 2008 UTC

Diff Legend

Comparing AnyEvent-HTTP/HTTP.pm (file contents):
Revision 1.6 by root, Wed Jun 4 12:05:45 2008 UTC vs.
Revision 1.13 by root, Thu Jun 5 16:43:45 2008 UTC