[ViewVC] Diff of: cvs/cvsroot/Coro/myhttpd/httpd.pl

Comparing cvsroot/Coro/myhttpd/httpd.pl (file contents):
Revision 1.14 by root, Sun Aug 12 14:09:03 2001 UTC vs.
Revision 1.31 by root, Mon Aug 27 05:05:26 2001 UTC

…		…
9	# at least on my machine, this thingy serves files	9	# at least on my machine, this thingy serves files
10	# quite a bit faster than apache, ;)	10	# quite a bit faster than apache, ;)
11	# and quite a bit slower than thttpd :(	11	# and quite a bit slower than thttpd :(
12		12
13	$SIG{PIPE} = 'IGNORE';	13	$SIG{PIPE} = 'IGNORE';
14		14
		15	our $accesslog;
		16
		17	if ($ACCESS_LOG) {
		18	use IO::Handle;
		19	open $accesslog, ">>$ACCESS_LOG"
		20	or die "$ACCESS_LOG: $!";
		21	$accesslog->autoflush(1);
		22	}
		23
15	sub slog {	24	sub slog {
16	my $level = shift;	25	my $level = shift;
17	my $format = shift;	26	my $format = shift;
18	printf "---: $format\n", @_;	27	printf "---: $format\n", @_;
19	}	28	}
…		…
70	package conn;	79	package conn;
71		80
72	use Socket;	81	use Socket;
73	use HTTP::Date;	82	use HTTP::Date;
74	use Convert::Scalar 'weaken';	83	use Convert::Scalar 'weaken';
		84	use Linux::AIO;
75		85
		86	Linux::AIO::min_parallel $::AIO_PARALLEL;
		87
		88	my $aio_requests = new Coro::Semaphore $::AIO_PARALLEL * 4;
		89
		90	Event->io(fd => Linux::AIO::poll_fileno,
		91	poll => 'r', async => 1,
		92	cb => \&Linux::AIO::poll_cb);
		93
76	our %conn; # $conn{ip}{fh} => connobj	94	our %conn; # $conn{ip}{self} => connobj
		95	our %uri; # $uri{ip}{uri}{self}
77	our %blocked;	96	our %blocked;
78	our %mimetype;	97	our %mimetype;
79		98
80	sub read_mimetypes {	99	sub read_mimetypes {
81	local *M;	100	local *M;
…		…
114	sub DESTROY {	133	sub DESTROY {
115	my $self = shift;	134	my $self = shift;
116		135
117	$::conns--;	136	$::conns--;
118		137
		138	$self->eoconn;
119	delete $conn{$self->{remote_addr}}{$self*1};	139	delete $conn{$self->{remote_addr}}{$self*1};
		140	}
		141
		142	# end of connection
		143	sub eoconn {
		144	my $self = shift;
120	delete $uri{$self->{remote_addr}}{$self->{uri}}{$self*1};	145	delete $uri{$self->{remote_addr}}{$self->{uri}}{$self*1};
121	}	146	}
122		147
123	sub slog {	148	sub slog {
124	my $self = shift;	149	my $self = shift;
125	main::slog($_[0], "$self->{remote_addr}> $_[1]");	150	main::slog($_[0], ($self->{remote_id} \|\| $self->{remote_addr}) ."> $_[1]");
126	}	151	}
127		152
128	sub response {	153	sub response {
129	my ($self, $code, $msg, $hdr, $content) = @_;	154	my ($self, $code, $msg, $hdr, $content) = @_;
130	my $res = "HTTP/1.0 $code $msg\015\012";	155	my $res = "HTTP/1.1 $code $msg\015\012";
131		156
132	$res .= "Connection: close\015\012";	157	$self->{h}{connection} \|\|= $hdr->{Connection};
		158
133	$res .= "Date: ".(time2str $::NOW)."\015\012"; # slow? nah. :(	159	$res .= "Date: ".(time2str $::NOW)."\015\012"; # slow? nah. :(
134		160
135	while (my ($h, $v) = each %$hdr) {	161	while (my ($h, $v) = each %$hdr) {
136	$res .= "$h: $v\015\012"	162	$res .= "$h: $v\015\012"
137	}	163	}
138	$res .= "\015\012";	164	$res .= "\015\012";
139		165
140	$res .= $content if defined $content and $self->{method} ne "HEAD";	166	$res .= $content if defined $content and $self->{method} ne "HEAD";
141		167
142	print STDERR "$self->{remote_addr} \"$self->{uri}\" $code ".$hdr->{"Content-Length"}." \"$self->{h}{referer}\"\n";#d#	168	my $log = "$self->{remote_addr} \"$self->{uri}\" $code ".$hdr->{"Content-Length"}." \"$self->{h}{referer}\"\n";
		169
		170	print $accesslog $log if $accesslog;
		171	print STDERR $log;
143		172
144	$self->{written} +=	173	$self->{written} +=
145	print {$self->{fh}} $res;	174	print {$self->{fh}} $res;
146	}	175	}
147		176
…		…
152	unless (defined $content) {	181	unless (defined $content) {
153	$content = "$code $msg";	182	$content = "$code $msg";
154	$hdr->{"Content-Type"} = "text/plain";	183	$hdr->{"Content-Type"} = "text/plain";
155	$hdr->{"Content-Length"} = length $content;	184	$hdr->{"Content-Length"} = length $content;
156	}	185	}
		186	$hdr->{"Connection"} = "close";
157		187
158	$self->response($code, $msg, $hdr, $content);	188	$self->response($code, $msg, $hdr, $content);
159		189
160	die bless {}, err::;	190	die bless {}, err::;
161	}	191	}
162		192
163	sub err_blocked {
164	my $self = shift;
165	my $ip = $self->{remote_addr};
166	my $time = time2str $blocked{$ip} = $::NOW + $::BLOCKTIME;
167
168	Coro::Event::do_timer(after => 15);
169
170	$self->err(401, "too many connections",
171	{
172	"Content-Type" => "text/html",
173	"Retry-After" => $::BLOCKTIME
174	},
175	<<EOF);
176	<html><p>
177	You have been blocked because you opened too many connections. You
178	may retry at</p>
179
180	<p><blockquote>$time.</blockquote></p>
181
182	<p>Until then, each new access will renew the block. You might want to have a
183	look at the <a href="http://www.goof.com/pcg/marc/animefaq.html">FAQ</a>.</p>
184	</html>
185	EOF
186	}
187
188	sub handle {	193	sub handle {
189	my $self = shift;	194	my $self = shift;
190	my $fh = $self->{fh};	195	my $fh = $self->{fh};
191		196
		197	my $host;
		198
		199	$fh->timeout($::REQ_TIMEOUT);
192	#while() {	200	while() {
		201	$self->{reqs}++;
		202
		203	# read request and parse first line
		204	my $req = $fh->readline("\015\012\015\012");
		205
		206	unless (defined $req) {
		207	if (exists $self->{version}) {
		208	last;
		209	} else {
		210	$self->err(408, "request timeout");
		211	}
		212	}
		213
193	$self->{h} = {};	214	$self->{h} = {};
194		215
195	# read request and parse first line
196	$fh->timeout($::REQ_TIMEOUT);
197	my $req = $fh->readline("\015\012\015\012");
198	$fh->timeout($::RES_TIMEOUT);	216	$fh->timeout($::RES_TIMEOUT);
199
200	defined $req or
201	$self->err(408, "request timeout");
202
203	my $ip = $self->{remote_addr};	217	my $ip = $self->{remote_addr};
204		218
205	$self->err_blocked($blocked{$ip});
206	if ($blocked{$ip}) {	219	if ($blocked{$ip}) {
207	$self->err_blocked($blocked{$ip})	220	$self->err_blocked($blocked{$ip})
208	if $blocked{$ip} > $::NOW;	221	if $blocked{$ip} > $::NOW;
209		222
210	delete $blocked{$ip};	223	delete $blocked{$ip};
211	}	224	}
212		225
213	if (%{$conn{$ip}} > $::MAX_CONN_IP) {	226	if (%{$conn{$ip}} > $::MAX_CONN_IP) {
		227	my $delay = 120;
		228	while (%{$conn{$ip}} > $::MAX_CONN_IP) {
		229	if ($delay <= 0) {
214	$self->slog(2, "blocked ip $ip");	230	$self->slog(2, "blocked ip $ip");
215	$self->err_blocked;	231	$self->err_blocked;
		232	} else {
		233	Coro::Event::do_timer(after => 3);
		234	$delay -= 3;
		235	}
		236	}
216	}	237	}
217		238
218	$req =~ /^(?:\015\012)?	239	$req =~ /^(?:\015\012)?
219	(GET\|HEAD) \040+	240	(GET\|HEAD) \040+
220	([^\040]+) \040+	241	([^\040]+) \040+
221	HTTP\/([0-9]+\.[0-9]+)	242	HTTP\/([0-9]+\.[0-9]+)
222	\015\012/gx	243	\015\012/gx
223	or $self->err(405, "method not allowed", { Allow => "GET,HEAD" });	244	or $self->err(405, "method not allowed", { Allow => "GET,HEAD" });
224		245
225	$2 ne "1.0"
226	or $self->err(506, "http protocol version not supported");
227
228	$self->{method} = $1;	246	$self->{method} = $1;
229	$self->{uri} = $2;	247	$self->{uri} = $2;
		248	$self->{version} = $3;
		249
		250	$3 =~ /^1\./
		251	or $self->err(506, "http protocol version $3 not supported");
230		252
231	# parse headers	253	# parse headers
232	{	254	{
233	my (%hdr, $h, $v);	255	my (%hdr, $h, $v);
234		256
…		…
245		267
246	$self->{h}{$h} = substr $v, 1	268	$self->{h}{$h} = substr $v, 1
247	while ($h, $v) = each %hdr;	269	while ($h, $v) = each %hdr;
248	}	270	}
249		271
		272	# find out server name and port
		273	if ($self->{uri} =~ s/^http:\/\/([^\/?#]*)//i) {
		274	$host = $1;
		275	} else {
		276	$host = $self->{h}{host};
		277	}
		278
		279	if (defined $host) {
250	$self->{server_port} = $self->{h}{host} =~ s/:([0-9]+)$// ? $1 : 80;	280	$self->{server_port} = $host =~ s/:([0-9]+)$// ? $1 : 80;
		281	} else {
		282	($self->{server_port}, $host)
		283	= unpack_sockaddr_in $self->{fh}->getsockname
		284	or $self->err(500, "unable to get socket name");
		285	$host = inet_ntoa $host;
		286	}
		287
		288	$self->{server_name} = $host;
		289
		290	# remote id should be unique per user
		291	$self->{remote_id} = $self->{remote_addr};
		292
		293	if (exists $self->{h}{"client-ip"}) {
		294	$self->{remote_id} .= "[".$self->{h}{"client-ip"}."]";
		295	} elsif (exists $self->{h}{"x-forwarded-for"}) {
		296	$self->{remote_id} .= "[".$self->{h}{"x-forwarded-for"}."]";
		297	}
251		298
252	weaken ($uri{$self->{remote_addr}}{$self->{uri}}{$self*1} = $self);	299	weaken ($uri{$self->{remote_addr}}{$self->{uri}}{$self*1} = $self);
253		300
		301	eval {
254	$self->map_uri;	302	$self->map_uri;
255	$self->respond;	303	$self->respond;
		304	};
		305
		306	$self->eoconn;
		307
		308	die if $@ && !ref $@;
		309
		310	last if $self->{h}{connection} =~ /close/ \|\| $self->{version} < 1.1;
		311
		312	$fh->timeout($::PER_TIMEOUT);
256	#}	313	}
257	}	314	}
258		315
259	# uri => path mapping	316	# uri => path mapping
260	sub map_uri {	317	sub map_uri {
261	my $self = shift;	318	my $self = shift;
262	my $host = $self->{h}{host} \|\| "default";	319	my $host = $self->{server_name};
263	my $uri = $self->{uri};	320	my $uri = $self->{uri};
264		321
265	# some massaging, also makes it more secure	322	# some massaging, also makes it more secure
266	$uri =~ s/%([0-9a-fA-F][0-9a-fA-F])/chr hex $1/ge;	323	$uri =~ s/%([0-9a-fA-F][0-9a-fA-F])/chr hex $1/ge;
267	$uri =~ s%//+%/%g;	324	$uri =~ s%//+%/%g;
…		…
277	$self->{path} = "$::DOCROOT/$host$uri";	334	$self->{path} = "$::DOCROOT/$host$uri";
278		335
279	$self->access_check;	336	$self->access_check;
280	}	337	}
281		338
282	sub server_address {
283	my $self = shift;
284	my ($port, $iaddr) = unpack_sockaddr_in $self->{fh}->getsockname
285	or $self->err(500, "unable to get socket name");
286	((inet_ntoa $iaddr), $port);
287	}
288
289	sub server_host {
290	my $self = shift;
291	if (exists $self->{h}{host}) {
292	return $self->{h}{host};
293	} else {
294	return (($self->server_address)[0]);
295	}
296	}
297
298	sub server_hostport {
299	my $self = shift;
300	my ($host, $port);
301	if (exists $self->{h}{host}) {
302	($host, $port) = ($self->{h}{host}, $self->{server_port});
303	} else {
304	($host, $port) = $self->server_address;
305	}
306	$port = $port == 80 ? "" : ":$port";
307	$host.$port;
308	}
309
310	sub _cgi {	339	sub _cgi {
311	my $self = shift;	340	my $self = shift;
312	my $path = shift;	341	my $path = shift;
313	my $fh;	342	my $fh;
314		343
315	# no two-way xxx supported	344	# no two-way xxx supported
316	if (0 == fork) {	345	if (0 == fork) {
317	open STDOUT, ">&".fileno($self->{fh});	346	open STDOUT, ">&".fileno($self->{fh});
318	if (chdir $::DOCROOT) {	347	if (chdir $::DOCROOT) {
319	$ENV{SERVER_SOFTWARE} = "thttpd-myhttpd"; # we are thttpd-alike	348	$ENV{SERVER_SOFTWARE} = "thttpd-myhttpd"; # we are thttpd-alike
320	$ENV{HTTP_HOST} = $self->server_host;	349	$ENV{HTTP_HOST} = $self->{server_name};
321	$ENV{HTTP_PORT} = $self->{server_host};	350	$ENV{HTTP_PORT} = $self->{server_port};
322	$ENV{SCRIPT_NAME} = $self->{name};	351	$ENV{SCRIPT_NAME} = $self->{name};
323	exec $path;	352	exec $path;
324	}	353	}
325	Coro::State::_exit(0);	354	Coro::State::_exit(0);
326	} else {	355	} else {
		356	die;
327	}	357	}
		358	}
		359
		360	sub server_hostport {
		361	$_[0]{server_port} == 80
		362	? $_[0]{server_name}
		363	: "$_[0]{server_name}:$_[0]{server_port}";
328	}	364	}
329		365
330	sub respond {	366	sub respond {
331	my $self = shift;	367	my $self = shift;
332	my $path = $self->{path};	368	my $path = $self->{path};
…		…
342		378
343	if (-d _ && -r _) {	379	if (-d _ && -r _) {
344	# directory	380	# directory
345	if ($path !~ /\/$/) {	381	if ($path !~ /\/$/) {
346	# create a redirect to get the trailing "/"	382	# create a redirect to get the trailing "/"
347	my $host = $self->server_hostport;	383	# we don't try to avoid the :80
348	$self->err(301, "moved permanently", { Location => "http://$host$self->{uri}/" });	384	$self->err(301, "moved permanently", { Location => "http://".$self->server_hostport."$self->{uri}/" });
349	} else {	385	} else {
350	$ims < $self->{stat}[9]	386	$ims < $self->{stat}[9]
351	or $self->err(304, "not modified");	387	or $self->err(304, "not modified");
352		388
353	if ($self->{method} eq "GET") {
354	if (-r "$path/index.html") {	389	if (-r "$path/index.html") {
355	$self->{path} .= "/index.html";	390	$self->{path} .= "/index.html";
356	$self->handle_file;	391	$self->handle_file;
357	} else {	392	} else {
358	$self->handle_dir;	393	$self->handle_dir;
359	}
360	}	394	}
361	}	395	}
362	} elsif (-f _ && -r _) {	396	} elsif (-f _ && -r _) {
363	-x _ and $self->err(403, "forbidden");	397	-x _ and $self->err(403, "forbidden");
364	$self->handle_file;	398	$self->handle_file;
…		…
397	($l, $h) = ($1, ($2 ne "" \|\| $2 >= $length) ? $2 : $length - 1);	431	($l, $h) = ($1, ($2 ne "" \|\| $2 >= $length) ? $2 : $length - 1);
398	} else {	432	} else {
399	($l, $h) = (0, $length - 1);	433	($l, $h) = (0, $length - 1);
400	goto ignore;	434	goto ignore;
401	}	435	}
402	goto satisfiable if $l >= 0 && $l < $length && $h >= 0 && $h > $l;	436	goto satisfiable if $l >= 0 && $l < $length && $h >= 0 && $h >= $l;
403	}	437	}
404	$hdr->{"Content-Range"} = "bytes */$length";	438	$hdr->{"Content-Range"} = "bytes */$length";
		439	$hdr->{"Content-Length"} = $length;
		440	$self->slog(9, "not satisfiable($self->{h}{range}\|".$self->{h}{"user-agent"}.")");
405	$self->err(416, "not satisfiable", $hdr);	441	$self->err(416, "not satisfiable", $hdr, "");
406		442
407	satisfiable:	443	satisfiable:
408	# check for segmented downloads	444	# check for segmented downloads
409	if ($l && $::NO_SEGMENTED) {	445	if ($l && $::NO_SEGMENTED) {
		446	my $delay = 180;
410	if (%{$uri{$self->{remote_addr}}{$self->{uri}}} > 1) {	447	while (%{$uri{$self->{remote_addr}}{$self->{uri}}} > 1) {
		448	if ($delay <= 0) {
		449	$self->err_segmented_download;
		450	} else {
411	Coro::Event::do_timer(after => 15);	451	Coro::Event::do_timer(after => 3); $delay -= 3;
412		452	}
413	$self->err(400, "segmented downloads are not allowed");
414	}	453	}
415	}	454	}
416		455
417	$hdr->{"Content-Range"} = "bytes $l-$h/$length";	456	$hdr->{"Content-Range"} = "bytes $l-$h/$length";
418	@code = (206, "partial content");	457	@code = (206, "partial content");
…		…
428	$hdr->{"Content-Length"} = $length;	467	$hdr->{"Content-Length"} = $length;
429		468
430	$self->response(@code, $hdr, "");	469	$self->response(@code, $hdr, "");
431		470
432	if ($self->{method} eq "GET") {	471	if ($self->{method} eq "GET") {
433	my ($fh, $buf);	472	my ($fh, $buf, $r);
		473	my $current = $Coro::current;
434	open $fh, "<", $self->{path}	474	open $fh, "<", $self->{path}
435	or die "$self->{path}: late open failure ($!)";	475	or die "$self->{path}: late open failure ($!)";
436		476
437	if ($l) {
438	sysseek $fh, $l, 0
439	or die "$self->{path}: cannot seek to $l ($!)";
440	}
441
442	$h -= $l - 1;	477	$h -= $l - 1;
443		478
		479	if (0) {
		480	if ($l) {
		481	sysseek $fh, $l, 0;
		482	}
		483	}
		484
444	while ($h > 0) {	485	while ($h > 0) {
		486	if (0) {
445	$h -= sysread $fh, $buf, $h > $::BUFSIZE ? $::BUFSIZE : $h;	487	sysread $fh, $buf, $h > $::BUFSIZE ? $::BUFSIZE : $h
		488	or last;
		489	} else {
		490	undef $buf;
		491	$aio_requests->down;
		492	aio_read($fh, $l, ($h > $::BUFSIZE ? $::BUFSIZE : $h),
		493	$buf, 0, sub {
		494	$r = $_[0];
		495	$current->ready;
		496	});
		497	&Coro::schedule;
		498	$aio_requests->up;
		499	last unless $r;
		500	}
446	my $w = $self->{fh}->syswrite($buf)	501	my $w = $self->{fh}->syswrite($buf)
447	or last;	502	or last;
448	$::written += $w;	503	$::written += $w;
449	$self->{written} += $w;	504	$self->{written} += $w;
		505	$l += $r;
450	}	506	}
451	}	507	}
452		508
453	close $fh;	509	close $fh;
454	}	510	}

Diff Legend

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

Comparing cvsroot/Coro/myhttpd/httpd.pl (file contents): Revision 1.14 by root, Sun Aug 12 14:09:03 2001 UTC vs. Revision 1.31 by root, Mon Aug 27 05:05:26 2001 UTC

Diff Legend

Comparing cvsroot/Coro/myhttpd/httpd.pl (file contents):
Revision 1.14 by root, Sun Aug 12 14:09:03 2001 UTC vs.
Revision 1.31 by root, Mon Aug 27 05:05:26 2001 UTC