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

Comparing cvsroot/Coro/myhttpd/httpd.pl (file contents):
Revision 1.3 by root, Fri Aug 10 02:28:28 2001 UTC vs.
Revision 1.16 by root, Tue Aug 14 19:38:25 2001 UTC

…		…
7	use bytes;	7	use bytes;
8		8
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
13	my $port = new Coro::Socket
14	LocalAddr => $SERVER_HOST,
15	LocalPort => $SERVER_PORT,
16	ReuseAddr => 1,
17	Listen => 1,
18	or die "unable to start server";
19		12
20	$SIG{PIPE} = 'IGNORE';	13	$SIG{PIPE} = 'IGNORE';
21		14
22	sub slog {	15	sub slog {
23	my $level = shift;	16	my $level = shift;
…		…
25	printf "---: $format\n", @_;	18	printf "---: $format\n", @_;
26	}	19	}
27		20
28	my $connections = new Coro::Semaphore $MAX_CONNECTS;	21	my $connections = new Coro::Semaphore $MAX_CONNECTS;
29		22
30	my @fh;	23	my @newcons;
31	my @pool;	24	my @pool;
32		25
33	# one "execution thread"	26	# one "execution thread"
34	sub handler {	27	sub handler {
35	while () {	28	while () {
36	my $fh = pop @fh;	29	my $new = pop @newcons;
37	if ($fh) {	30	if ($new) {
38	eval {	31	eval {
39	conn->new($fh)->handle;	32	conn->new(@$new)->handle;
40	};	33	};
41	close $fh;
42	slog 1, "$@" if $@ && !ref $@;	34	slog 1, "$@" if $@ && !ref $@;
43	$connections->up;	35	$connections->up;
44	} else {	36	} else {
45	last if @pool >= $MAX_POOL;	37	last if @pool >= $MAX_POOL;
46	push @pool, $Coro::current;	38	push @pool, $Coro::current;
47	schedule;	39	schedule;
48	}	40	}
49	}	41	}
50	}	42	}
51		43
		44	my $http_port = new Coro::Socket
		45	LocalAddr => $SERVER_HOST,
		46	LocalPort => $SERVER_PORT,
		47	ReuseAddr => 1,
		48	Listen => 50,
		49	or die "unable to start server";
		50
		51	push @listen_sockets, $http_port;
		52
52	# the "main thread"	53	# the "main thread"
53	async {	54	async {
54	slog 1, "accepting connections";	55	slog 1, "accepting connections";
55	while () {	56	while () {
56	$connections->down;	57	$connections->down;
57	push @fh, $port->accept;	58	push @newcons, [$http_port->accept];
58	#slog 3, "accepted @$connections ".scalar(@pool);	59	#slog 3, "accepted @$connections ".scalar(@pool);
59	$::NOW = time;	60	$::NOW = time;
60	if (@pool) {	61	if (@pool) {
61	(pop @pool)->ready;	62	(pop @pool)->ready;
62	} else {	63	} else {
…		…
64	}	65	}
65		66
66	}	67	}
67	};	68	};
68		69
69	loop;
70	print "ende\n";#d#
71
72	package conn;	70	package conn;
73		71
74	use Socket;	72	use Socket;
75	use HTTP::Date;	73	use HTTP::Date;
76	use Convert::Scalar 'weaken';	74	use Convert::Scalar 'weaken';
		75	use Linux::AIO;
		76
		77	Linux::AIO::min_parallel $::AIO_PARALLEL;
		78
		79	Event->io(fd => Linux::AIO::poll_fileno,
		80	poll => 'r',
		81	async => 1,
		82	cb => \&Linux::AIO::poll_cb );
		83
		84	Event->add_hooks(prepare => sub {
		85	&Coro::cede while &Coro::nready;
		86	1e6;
		87	});
77		88
78	our %conn; # $conn{ip}{fh} => connobj	89	our %conn; # $conn{ip}{fh} => connobj
79	our %blocked;	90	our %blocked;
		91	our %mimetype;
		92
		93	sub read_mimetypes {
		94	local *M;
		95	if (open M, "<mime_types") {
		96	while (<M>) {
		97	if (/^([^#]\S+)\t+(\S+)$/) {
		98	$mimetype{lc $1} = $2;
		99	}
		100	}
		101	} else {
		102	print "cannot open mime_types\n";
		103	}
		104	}
		105
		106	read_mimetypes;
80		107
81	sub new {	108	sub new {
82	my $class = shift;	109	my $class = shift;
		110	my $peername = shift;
83	my $fh = shift;	111	my $fh = shift;
84	my $self = bless { fh => $fh }, $class;	112	my $self = bless { fh => $fh }, $class;
85	my (undef, $iaddr) = unpack_sockaddr_in $fh->getpeername	113	my (undef, $iaddr) = unpack_sockaddr_in $peername
86	or $self->err(500, "unable to get peername");	114	or $self->err(500, "unable to decode peername");
		115
87	$self->{remote_addr} = inet_ntoa $iaddr;	116	$self->{remote_addr} = inet_ntoa $iaddr;
		117	$self->{time} = $::NOW;
88		118
89	# enter ourselves into various lists	119	# enter ourselves into various lists
90	weaken ($conn{$self->{remote_addr}}{$self*1} = $self);	120	weaken ($conn{$self->{remote_addr}}{$self*1} = $self);
91		121
92	print "$self->{remote_addr}: ".($self*1)." > ".%{$conn{$self->{remote_addr}}},"\n";	122	$::conns++;
		123
93	$self;	124	$self;
94	}	125	}
95		126
96	sub DESTROY {	127	sub DESTROY {
97	my $self = shift;	128	my $self = shift;
		129
		130	$::conns--;
		131
98	delete $conn{$self->{remote_addr}}{$self*1};	132	delete $conn{$self->{remote_addr}}{$self*1};
99	delete $uri{$self->{uri}}{$self*1};	133	delete $uri{$self->{remote_addr}}{$self->{uri}}{$self*1};
100	}	134	}
101		135
102	sub slog {	136	sub slog {
103	main::slog(@_);	137	my $self = shift;
		138	main::slog($_[0], "$self->{remote_addr}> $_[1]");
104	}	139	}
105		140
106	sub print_response {	141	sub response {
107	my ($self, $code, $msg, $hdr, $content) = @_;	142	my ($self, $code, $msg, $hdr, $content) = @_;
108	my $res = "HTTP/1.0 $code $msg\015\012";	143	my $res = "HTTP/1.0 $code $msg\015\012";
109		144
110	$hdr->{Date} = time2str $::NOW; # slow? nah.	145	$res .= "Connection: close\015\012";
		146	$res .= "Date: ".(time2str $::NOW)."\015\012"; # slow? nah. :(
111		147
112	while (my ($h, $v) = each %$hdr) {	148	while (my ($h, $v) = each %$hdr) {
113	$res .= "$h: $v\015\012"	149	$res .= "$h: $v\015\012"
114	}	150	}
115	$res .= "\015\012$content" if defined $content;	151	$res .= "\015\012";
		152
		153	$res .= $content if defined $content and $self->{method} ne "HEAD";
116		154
117	print STDERR "$self->{remote_addr} \"$self->{uri}\" $code ".$hdr->{"Content-Length"}." \"$self->{h}{referer}\"\n";#d#	155	print STDERR "$self->{remote_addr} \"$self->{uri}\" $code ".$hdr->{"Content-Length"}." \"$self->{h}{referer}\"\n";#d#
118		156
		157	$self->{written} +=
119	print {$self->{fh}} $res;	158	print {$self->{fh}} $res;
120	}	159	}
121		160
122	sub err {	161	sub err {
123	my $self = shift;	162	my $self = shift;
124	my ($code, $msg, $hdr, $content) = @_;	163	my ($code, $msg, $hdr, $content) = @_;
…		…
127	$content = "$code $msg";	166	$content = "$code $msg";
128	$hdr->{"Content-Type"} = "text/plain";	167	$hdr->{"Content-Type"} = "text/plain";
129	$hdr->{"Content-Length"} = length $content;	168	$hdr->{"Content-Length"} = length $content;
130	}	169	}
131		170
132	$self->slog($msg) if $code;
133
134	$self->print_response($code, $msg, $hdr, $content);	171	$self->response($code, $msg, $hdr, $content);
135		172
136	die bless {}, err::;	173	die bless {}, err::;
137	}	174	}
138		175
139	sub err_blocked {	176	sub err_blocked {
140	my $self = shift;	177	my $self = shift;
141	my $ip = $self->{remote_addr};	178	my $ip = $self->{remote_addr};
142	my $time = time2str $blocked{$ip} = $::NOW + $::BLOCKTIME;	179	my $time = time2str $blocked{$ip} = $::NOW + $::BLOCKTIME;
		180
		181	Coro::Event::do_timer(after => 15);
		182
143	$self->err(403, "too many connections",	183	$self->err(401, "too many connections",
		184	{
		185	"Content-Type" => "text/html",
144	{ "Retry-After" => $::BLOCKTIME },	186	"Retry-After" => $::BLOCKTIME
		187	},
145	<<EOF);	188	<<EOF);
		189	<html><p>
146	You have been blocked because you opened too many connections. You	190	You have been blocked because you opened too many connections. You
147	may retry at $time. Until then,	191	may retry at</p>
148	every new access will renew the block.	192
		193	<p><blockquote>$time.</blockquote></p>
		194
		195	<p>Until then, each new access will renew the block. You might want to have a
		196	look at the <a href="http://www.goof.com/pcg/marc/animefaq.html">FAQ</a>.</p>
		197	</html>
149	EOF	198	EOF
150	}	199	}
151		200
152	sub handle {	201	sub handle {
153	my $self = shift;	202	my $self = shift;
…		…
172		221
173	delete $blocked{$ip};	222	delete $blocked{$ip};
174	}	223	}
175		224
176	if (%{$conn{$ip}} > $::MAX_CONN_IP) {	225	if (%{$conn{$ip}} > $::MAX_CONN_IP) {
177	$self->slog("blocked ip $ip");	226	$self->slog(2, "blocked ip $ip");
178	$self->err_blocked;	227	$self->err_blocked;
179	}	228	}
180		229
181	$req =~ /^(?:\015\012)?	230	$req =~ /^(?:\015\012)?
182	(GET\|HEAD) \040+	231	(GET\|HEAD) \040+
183	([^\040]+) \040+	232	([^\040]+) \040+
184	HTTP\/([0-9]+\.[0-9]+)	233	HTTP\/([0-9]+\.[0-9]+)
185	\015\012/gx	234	\015\012/gx
186	or $self->err(403, "method not allowed", { Allow => "GET,HEAD" });	235	or $self->err(405, "method not allowed", { Allow => "GET,HEAD" });
187		236
188	$2 ne "1.0"	237	$2 ne "1.0"
189	or $self->err(506, "http protocol version not supported");	238	or $self->err(506, "http protocol version not supported");
190		239
191	$self->{method} = $1;	240	$self->{method} = $1;
…		…
210	while ($h, $v) = each %hdr;	259	while ($h, $v) = each %hdr;
211	}	260	}
212		261
213	$self->{server_port} = $self->{h}{host} =~ s/:([0-9]+)$// ? $1 : 80;	262	$self->{server_port} = $self->{h}{host} =~ s/:([0-9]+)$// ? $1 : 80;
214		263
215	weaken ($uri{$self->{uri}}{$self*1} = $self);	264	weaken ($uri{$self->{remote_addr}}{$self->{uri}}{$self*1} = $self);
216		265
217	$self->map_uri;	266	$self->map_uri;
218
219	Coro::Event::do_timer(after => 5);
220
221	$self->respond;	267	$self->respond;
222	#}	268	#}
223	}	269	}
224		270
225	# uri => path mapping	271	# uri => path mapping
…		…
239		285
240	$self->{name} = $uri;	286	$self->{name} = $uri;
241		287
242	# now do the path mapping	288	# now do the path mapping
243	$self->{path} = "$::DOCROOT/$host$uri";	289	$self->{path} = "$::DOCROOT/$host$uri";
		290
		291	$self->access_check;
244	}	292	}
245		293
246	sub server_address {	294	sub server_address {
247	my $self = shift;	295	my $self = shift;
248	my ($port, $iaddr) = unpack_sockaddr_in $self->{fh}->getsockname	296	my ($port, $iaddr) = unpack_sockaddr_in $self->{fh}->getsockname
…		…
282	if (chdir $::DOCROOT) {	330	if (chdir $::DOCROOT) {
283	$ENV{SERVER_SOFTWARE} = "thttpd-myhttpd"; # we are thttpd-alike	331	$ENV{SERVER_SOFTWARE} = "thttpd-myhttpd"; # we are thttpd-alike
284	$ENV{HTTP_HOST} = $self->server_host;	332	$ENV{HTTP_HOST} = $self->server_host;
285	$ENV{HTTP_PORT} = $self->{server_host};	333	$ENV{HTTP_PORT} = $self->{server_host};
286	$ENV{SCRIPT_NAME} = $self->{name};	334	$ENV{SCRIPT_NAME} = $self->{name};
287	exec $::INDEXPROG;	335	exec $path;
288	}	336	}
289	Coro::State::_exit(0);	337	Coro::State::_exit(0);
290	} else {	338	} else {
291	}	339	}
292	}	340	}
…		…
295	my $self = shift;	343	my $self = shift;
296	my $path = $self->{path};	344	my $path = $self->{path};
297		345
298	stat $path	346	stat $path
299	or $self->err(404, "not found");	347	or $self->err(404, "not found");
		348
		349	$self->{stat} = [stat _];
300		350
301	# idiotic netscape sends idiotic headers AGAIN	351	# idiotic netscape sends idiotic headers AGAIN
302	my $ims = $self->{h}{"if-modified-since"} =~ /^([^;]+)/	352	my $ims = $self->{h}{"if-modified-since"} =~ /^([^;]+)/
303	? str2time $1 : 0;	353	? str2time $1 : 0;
304		354
…		…
307	if ($path !~ /\/$/) {	357	if ($path !~ /\/$/) {
308	# create a redirect to get the trailing "/"	358	# create a redirect to get the trailing "/"
309	my $host = $self->server_hostport;	359	my $host = $self->server_hostport;
310	$self->err(301, "moved permanently", { Location => "http://$host$self->{uri}/" });	360	$self->err(301, "moved permanently", { Location => "http://$host$self->{uri}/" });
311	} else {	361	} else {
312	$ims < (stat _)[9]	362	$ims < $self->{stat}[9]
313	or $self->err(304, "not modified");	363	or $self->err(304, "not modified");
314		364
315	if ($self->{method} eq "GET") {	365	if ($self->{method} eq "GET") {
316	if (-r "$path/index.html") {	366	if (-r "$path/index.html") {
317	$self->{path} .= "/index.html";	367	$self->{path} .= "/index.html";
…		…
329	}	379	}
330	}	380	}
331		381
332	sub handle_dir {	382	sub handle_dir {
333	my $self = shift;	383	my $self = shift;
334	$self->_cgi($::INDEXPROG);	384	my $idx = $self->diridx;
		385
		386	$self->response(200, "ok",
		387	{
		388	"Content-Type" => "text/html",
		389	"Content-Length" => length $idx,
		390	},
		391	$idx);
335	}	392	}
336		393
337	sub handle_file {	394	sub handle_file {
338	my $self = shift;	395	my $self = shift;
339	my $length = -s _;	396	my $length = -s _;
…		…
358	}	415	}
359	$hdr->{"Content-Range"} = "bytes */$length";	416	$hdr->{"Content-Range"} = "bytes */$length";
360	$self->err(416, "not satisfiable", $hdr);	417	$self->err(416, "not satisfiable", $hdr);
361		418
362	satisfiable:	419	satisfiable:
		420	# check for segmented downloads
		421	if ($l && $::NO_SEGMENTED) {
		422	if (%{$uri{$self->{remote_addr}}{$self->{uri}}} > 1) {
		423	Coro::Event::do_timer(after => 15);
		424
		425	$self->err(400, "segmented downloads are not allowed");
		426	}
		427	}
		428
363	$hdr->{"Content-Range"} = "bytes $l-$h/$length";	429	$hdr->{"Content-Range"} = "bytes $l-$h/$length";
364	@code = (206, "partial content");	430	@code = (206, "partial content");
365	$length = $h - $l + 1;	431	$length = $h - $l + 1;
366		432
367	ignore:	433	ignore:
368	} else {	434	} else {
369	($l, $h) = (0, $length - 1);	435	($l, $h) = (0, $length - 1);
370	}	436	}
371		437
372	if ($self->{path} =~ /\.html$/) {	438	$self->{path} =~ /\.([^.]+)$/;
373	$hdr->{"Content-Type"} = "text/html";
374	} else {
375	$hdr->{"Content-Type"} = "application/octet-stream";	439	$hdr->{"Content-Type"} = $mimetype{lc $1} \|\| "application/octet-stream";
376	}
377
378	$hdr->{"Content-Length"} = $length;	440	$hdr->{"Content-Length"} = $length;
379		441
380	$self->print_response(@code, $hdr, "");	442	$self->response(@code, $hdr, "");
381		443
382	if ($self->{method} eq "GET") {	444	if ($self->{method} eq "GET") {
383	my ($fh, $buf);	445	my ($fh, $buf, $r);
		446	my $current = $Coro::current;
384	open $fh, "<", $self->{path}	447	open $fh, "<", $self->{path}
385	or die "$self->{path}: late open failure ($!)";	448	or die "$self->{path}: late open failure ($!)";
386		449
387	if ($l) {
388	sysseek $fh, $l, 0
389	or die "$self->{path}: cannot seek to $l ($!)";
390	}
391
392	$h -= $l - 1;	450	$h -= $l - 1;
393		451
394	while ($h > 0) {	452	while ($h > 0) {
395	$h -= sysread $fh, $buf, $h > 4096 ? 4096 : $h;	453	aio_read($fh, $l, ($h > $::BUFSIZE ? $::BUFSIZE : $h),
396	print {$self->{fh}} $buf	454	$buf, 0, sub {
		455	$r = $_[0];
		456	$current->ready;
		457	});
		458	&Coro::schedule;
		459	last unless $r;
		460	my $w = $self->{fh}->syswrite($buf)
397	or last;	461	or last;
		462	$::written += $w;
		463	$self->{written} += $w;
		464	$l += $r;
398	}	465	}
399	}	466	}
400		467
401	close $fh;	468	close $fh;
402	}	469	}

Diff Legend

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

Comparing cvsroot/Coro/myhttpd/httpd.pl (file contents): Revision 1.3 by root, Fri Aug 10 02:28:28 2001 UTC vs. Revision 1.16 by root, Tue Aug 14 19:38:25 2001 UTC

Diff Legend

Comparing cvsroot/Coro/myhttpd/httpd.pl (file contents):
Revision 1.3 by root, Fri Aug 10 02:28:28 2001 UTC vs.
Revision 1.16 by root, Tue Aug 14 19:38:25 2001 UTC