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

Comparing cvsroot/Coro/myhttpd/httpd.pl (file contents):
Revision 1.13 by root, Sun Aug 12 01:16:48 2001 UTC vs.
Revision 1.32 by root, Wed Aug 29 01:32:50 2001 UTC

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

Diff Legend

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

Comparing cvsroot/Coro/myhttpd/httpd.pl (file contents): Revision 1.13 by root, Sun Aug 12 01:16:48 2001 UTC vs. Revision 1.32 by root, Wed Aug 29 01:32:50 2001 UTC

Diff Legend

Comparing cvsroot/Coro/myhttpd/httpd.pl (file contents):
Revision 1.13 by root, Sun Aug 12 01:16:48 2001 UTC vs.
Revision 1.32 by root, Wed Aug 29 01:32:50 2001 UTC