[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.27 by root, Sun Aug 19 23:57:52 2001 UTC

…		…
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		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
20	$SIG{PIPE} = 'IGNORE';	13	$SIG{PIPE} = 'IGNORE';
21		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
22	sub slog {	24	sub slog {
23	my $level = shift;	25	my $level = shift;
24	my $format = shift;	26	my $format = shift;
25	printf "---: $format\n", @_;	27	printf "---: $format\n", @_;
26	}	28	}
27		29
28	my $connections = new Coro::Semaphore $MAX_CONNECTS;	30	my $connections = new Coro::Semaphore $MAX_CONNECTS;
29		31
30	my @fh;	32	my @newcons;
31	my @pool;	33	my @pool;
32		34
33	# one "execution thread"	35	# one "execution thread"
34	sub handler {	36	sub handler {
35	while () {	37	while () {
36	my $fh = pop @fh;	38	my $new = pop @newcons;
37	if ($fh) {	39	if ($new) {
38	eval {	40	eval {
39	conn->new($fh)->handle;	41	conn->new(@$new)->handle;
40	};	42	};
41	close $fh;
42	slog 1, "$@" if $@ && !ref $@;	43	slog 1, "$@" if $@ && !ref $@;
43	$connections->up;	44	$connections->up;
44	} else {	45	} else {
45	last if @pool >= $MAX_POOL;	46	last if @pool >= $MAX_POOL;
46	push @pool, $Coro::current;	47	push @pool, $Coro::current;
47	schedule;	48	schedule;
48	}	49	}
49	}	50	}
50	}	51	}
51		52
		53	my $http_port = new Coro::Socket
		54	LocalAddr => $SERVER_HOST,
		55	LocalPort => $SERVER_PORT,
		56	ReuseAddr => 1,
		57	Listen => 50,
		58	or die "unable to start server";
		59
		60	push @listen_sockets, $http_port;
		61
52	# the "main thread"	62	# the "main thread"
53	async {	63	async {
54	slog 1, "accepting connections";	64	slog 1, "accepting connections";
55	while () {	65	while () {
56	$connections->down;	66	$connections->down;
57	push @fh, $port->accept;	67	push @newcons, [$http_port->accept];
58	#slog 3, "accepted @$connections ".scalar(@pool);	68	#slog 3, "accepted @$connections ".scalar(@pool);
59	$::NOW = time;	69	$::NOW = time;
60	if (@pool) {	70	if (@pool) {
61	(pop @pool)->ready;	71	(pop @pool)->ready;
62	} else {	72	} else {
…		…
64	}	74	}
65		75
66	}	76	}
67	};	77	};
68		78
69	loop;
70	print "ende\n";#d#
71
72	package conn;	79	package conn;
73		80
74	use Socket;	81	use Socket;
75	use HTTP::Date;	82	use HTTP::Date;
76	use Convert::Scalar 'weaken';	83	use Convert::Scalar 'weaken';
		84	use Linux::AIO;
77		85
		86	Linux::AIO::min_parallel $::AIO_PARALLEL;
		87
		88	Event->io(fd => Linux::AIO::poll_fileno,
		89	poll => 'r', async => 1,
		90	cb => \&Linux::AIO::poll_cb);
		91
78	our %conn; # $conn{ip}{fh} => connobj	92	our %conn; # $conn{ip}{self} => connobj
		93	our %uri; # $uri{ip}{uri}{self}
79	our %blocked;	94	our %blocked;
		95	our %mimetype;
		96
		97	sub read_mimetypes {
		98	local *M;
		99	if (open M, "<mime_types") {
		100	while (<M>) {
		101	if (/^([^#]\S+)\t+(\S+)$/) {
		102	$mimetype{lc $1} = $2;
		103	}
		104	}
		105	} else {
		106	print "cannot open mime_types\n";
		107	}
		108	}
		109
		110	read_mimetypes;
80		111
81	sub new {	112	sub new {
82	my $class = shift;	113	my $class = shift;
		114	my $peername = shift;
83	my $fh = shift;	115	my $fh = shift;
84	my $self = bless { fh => $fh }, $class;	116	my $self = bless { fh => $fh }, $class;
85	my (undef, $iaddr) = unpack_sockaddr_in $fh->getpeername	117	my (undef, $iaddr) = unpack_sockaddr_in $peername
86	or $self->err(500, "unable to get peername");	118	or $self->err(500, "unable to decode peername");
		119
87	$self->{remote_addr} = inet_ntoa $iaddr;	120	$self->{remote_addr} = inet_ntoa $iaddr;
		121	$self->{time} = $::NOW;
88		122
89	# enter ourselves into various lists	123	# enter ourselves into various lists
90	weaken ($conn{$self->{remote_addr}}{$self*1} = $self);	124	weaken ($conn{$self->{remote_addr}}{$self*1} = $self);
91		125
92	print "$self->{remote_addr}: ".($self*1)." > ".%{$conn{$self->{remote_addr}}},"\n";	126	$::conns++;
		127
93	$self;	128	$self;
94	}	129	}
95		130
96	sub DESTROY {	131	sub DESTROY {
97	my $self = shift;	132	my $self = shift;
		133
		134	$::conns--;
		135
		136	$self->eoconn;
98	delete $conn{$self->{remote_addr}}{$self*1};	137	delete $conn{$self->{remote_addr}}{$self*1};
		138	}
		139
		140	# end of connection
		141	sub eoconn {
		142	my $self = shift;
99	delete $uri{$self->{uri}}{$self*1};	143	delete $uri{$self->{remote_addr}}{$self->{uri}}{$self*1};
100	}	144	}
101		145
102	sub slog {	146	sub slog {
103	main::slog(@_);	147	my $self = shift;
		148	main::slog($_[0], "$self->{remote_addr}> $_[1]");
104	}	149	}
105		150
106	sub print_response {	151	sub response {
107	my ($self, $code, $msg, $hdr, $content) = @_;	152	my ($self, $code, $msg, $hdr, $content) = @_;
108	my $res = "HTTP/1.0 $code $msg\015\012";	153	my $res = "HTTP/1.1 $code $msg\015\012";
109		154
110	$hdr->{Date} = time2str $::NOW; # slow? nah.	155	#$res .= "Connection: close\015\012";
		156	$res .= "Date: ".(time2str $::NOW)."\015\012"; # slow? nah. :(
111		157
112	while (my ($h, $v) = each %$hdr) {	158	while (my ($h, $v) = each %$hdr) {
113	$res .= "$h: $v\015\012"	159	$res .= "$h: $v\015\012"
114	}	160	}
115	$res .= "\015\012$content" if defined $content;	161	$res .= "\015\012";
116		162
		163	$res .= $content if defined $content and $self->{method} ne "HEAD";
		164
117	print STDERR "$self->{remote_addr} \"$self->{uri}\" $code ".$hdr->{"Content-Length"}." \"$self->{h}{referer}\"\n";#d#	165	my $log = "$self->{remote_addr} \"$self->{uri}\" $code ".$hdr->{"Content-Length"}." \"$self->{h}{referer}\"\n";
118		166
		167	print $accesslog $log if $accesslog;
		168	print STDERR $log;
		169
		170	$self->{written} +=
119	print {$self->{fh}} $res;	171	print {$self->{fh}} $res;
120	}	172	}
121		173
122	sub err {	174	sub err {
123	my $self = shift;	175	my $self = shift;
124	my ($code, $msg, $hdr, $content) = @_;	176	my ($code, $msg, $hdr, $content) = @_;
…		…
126	unless (defined $content) {	178	unless (defined $content) {
127	$content = "$code $msg";	179	$content = "$code $msg";
128	$hdr->{"Content-Type"} = "text/plain";	180	$hdr->{"Content-Type"} = "text/plain";
129	$hdr->{"Content-Length"} = length $content;	181	$hdr->{"Content-Length"} = length $content;
130	}	182	}
		183	$hdr->{"Connection"} = "close";
131		184
132	$self->slog($msg) if $code;
133
134	$self->print_response($code, $msg, $hdr, $content);	185	$self->response($code, $msg, $hdr, $content);
135		186
136	die bless {}, err::;	187	die bless {}, err::;
137	}	188	}
138		189
139	sub err_blocked {	190	sub err_blocked {
140	my $self = shift;	191	my $self = shift;
141	my $ip = $self->{remote_addr};	192	my $ip = $self->{remote_addr};
142	my $time = time2str $blocked{$ip} = $::NOW + $::BLOCKTIME;	193	my $time = time2str $blocked{$ip} = $::NOW + $::BLOCKTIME;
		194
		195	Coro::Event::do_timer(after => 20*rand);
		196
143	$self->err(403, "too many connections",	197	$self->err(401, "too many connections",
		198	{
		199	"Content-Type" => "text/html",
144	{ "Retry-After" => $::BLOCKTIME },	200	"Retry-After" => $::BLOCKTIME,
		201	"Warning" => "Please do NOT retry, you have been blocked",
		202	"WWW-Authenticate" => "Basic realm=\"Please do NOT retry, you have been blocked\"",
		203	},
145	<<EOF);	204	<<EOF);
		205	<html>
		206	<head>
		207	<title>Too many connections</title>
		208	</head>
		209	<body bgcolor="#ffffff" text="#000000" link="#0000ff" vlink="#000080" alink="#ff0000">
		210
146	You have been blocked because you opened too many connections. You	211	<p>You have been blocked because you opened too many connections. You
147	may retry at $time. Until then,	212	may retry at</p>
148	every new access will renew the block.	213
		214	<p><blockquote>$time.</blockquote></p>
		215
		216	<p>Until then, each new access will renew the block. You might want to have a
		217	look at the <a href="http://www.goof.com/pcg/marc/animefaq.html">FAQ</a>.</p>
		218
		219	</body></html>
149	EOF	220	EOF
150	}	221	}
151		222
152	sub handle {	223	sub handle {
153	my $self = shift;	224	my $self = shift;
154	my $fh = $self->{fh};	225	my $fh = $self->{fh};
155		226
		227	$fh->timeout($::REQ_TIMEOUT);
156	#while() {	228	while() {
		229	$self->{reqs}++;
		230
		231	# read request and parse first line
		232	my $req = $fh->readline("\015\012\015\012");
		233
		234	unless (defined $req) {
		235	if (exists $self->{version}) {
		236	last;
		237	} else {
		238	$self->err(408, "request timeout");
		239	}
		240	}
		241
157	$self->{h} = {};	242	$self->{h} = {};
158		243
159	# read request and parse first line
160	$fh->timeout($::REQ_TIMEOUT);
161	my $req = $fh->readline("\015\012\015\012");
162	$fh->timeout($::RES_TIMEOUT);	244	$fh->timeout($::RES_TIMEOUT);
163
164	defined $req or
165	$self->err(408, "request timeout");
166
167	my $ip = $self->{remote_addr};	245	my $ip = $self->{remote_addr};
168		246
169	if ($blocked{$ip}) {	247	if ($blocked{$ip}) {
170	$self->err_blocked($blocked{$ip})	248	$self->err_blocked($blocked{$ip})
171	if $blocked{$ip} > $::NOW;	249	if $blocked{$ip} > $::NOW;
172		250
173	delete $blocked{$ip};	251	delete $blocked{$ip};
174	}	252	}
175		253
176	if (%{$conn{$ip}} > $::MAX_CONN_IP) {	254	if (%{$conn{$ip}} > $::MAX_CONN_IP) {
177	$self->slog("blocked ip $ip");	255	$self->slog(2, "blocked ip $ip");
178	$self->err_blocked;	256	$self->err_blocked;
179	}	257	}
180		258
181	$req =~ /^(?:\015\012)?	259	$req =~ /^(?:\015\012)?
182	(GET\|HEAD) \040+	260	(GET\|HEAD) \040+
183	([^\040]+) \040+	261	([^\040]+) \040+
184	HTTP\/([0-9]+\.[0-9]+)	262	HTTP\/([0-9]+\.[0-9]+)
185	\015\012/gx	263	\015\012/gx
186	or $self->err(403, "method not allowed", { Allow => "GET,HEAD" });	264	or $self->err(405, "method not allowed", { Allow => "GET,HEAD" });
187
188	$2 ne "1.0"
189	or $self->err(506, "http protocol version not supported");
190		265
191	$self->{method} = $1;	266	$self->{method} = $1;
192	$self->{uri} = $2;	267	$self->{uri} = $2;
		268	$self->{version} = $3;
		269
		270	$3 =~ /^1\./
		271	or $self->err(506, "http protocol version $3 not supported");
193		272
194	# parse headers	273	# parse headers
195	{	274	{
196	my (%hdr, $h, $v);	275	my (%hdr, $h, $v);
197		276
…		…
210	while ($h, $v) = each %hdr;	289	while ($h, $v) = each %hdr;
211	}	290	}
212		291
213	$self->{server_port} = $self->{h}{host} =~ s/:([0-9]+)$// ? $1 : 80;	292	$self->{server_port} = $self->{h}{host} =~ s/:([0-9]+)$// ? $1 : 80;
214		293
215	weaken ($uri{$self->{uri}}{$self*1} = $self);	294	weaken ($uri{$self->{remote_addr}}{$self->{uri}}{$self*1} = $self);
216		295
		296	eval {
217	$self->map_uri;	297	$self->map_uri;
218
219	Coro::Event::do_timer(after => 5);
220
221	$self->respond;	298	$self->respond;
		299	};
		300
		301	$self->eoconn;
		302
		303	die if $@ && !ref $@;
		304
		305	last if $self->{h}{connection} =~ /close/ \|\| $self->{version} lt "1.1";
		306
		307	$self->slog(9, "persistent connection [".$self->{h}{"user-agent"}."][$self->{reqs}]");
		308	$fh->timeout($::PER_TIMEOUT);
222	#}	309	}
223	}	310	}
224		311
225	# uri => path mapping	312	# uri => path mapping
226	sub map_uri {	313	sub map_uri {
227	my $self = shift;	314	my $self = shift;
…		…
239		326
240	$self->{name} = $uri;	327	$self->{name} = $uri;
241		328
242	# now do the path mapping	329	# now do the path mapping
243	$self->{path} = "$::DOCROOT/$host$uri";	330	$self->{path} = "$::DOCROOT/$host$uri";
		331
		332	$self->access_check;
244	}	333	}
245		334
246	sub server_address {	335	sub server_address {
247	my $self = shift;	336	my $self = shift;
248	my ($port, $iaddr) = unpack_sockaddr_in $self->{fh}->getsockname	337	my ($port, $iaddr) = unpack_sockaddr_in $self->{fh}->getsockname
…		…
282	if (chdir $::DOCROOT) {	371	if (chdir $::DOCROOT) {
283	$ENV{SERVER_SOFTWARE} = "thttpd-myhttpd"; # we are thttpd-alike	372	$ENV{SERVER_SOFTWARE} = "thttpd-myhttpd"; # we are thttpd-alike
284	$ENV{HTTP_HOST} = $self->server_host;	373	$ENV{HTTP_HOST} = $self->server_host;
285	$ENV{HTTP_PORT} = $self->{server_host};	374	$ENV{HTTP_PORT} = $self->{server_host};
286	$ENV{SCRIPT_NAME} = $self->{name};	375	$ENV{SCRIPT_NAME} = $self->{name};
287	exec $::INDEXPROG;	376	exec $path;
288	}	377	}
289	Coro::State::_exit(0);	378	Coro::State::_exit(0);
290	} else {	379	} else {
291	}	380	}
292	}	381	}
…		…
295	my $self = shift;	384	my $self = shift;
296	my $path = $self->{path};	385	my $path = $self->{path};
297		386
298	stat $path	387	stat $path
299	or $self->err(404, "not found");	388	or $self->err(404, "not found");
		389
		390	$self->{stat} = [stat _];
300		391
301	# idiotic netscape sends idiotic headers AGAIN	392	# idiotic netscape sends idiotic headers AGAIN
302	my $ims = $self->{h}{"if-modified-since"} =~ /^([^;]+)/	393	my $ims = $self->{h}{"if-modified-since"} =~ /^([^;]+)/
303	? str2time $1 : 0;	394	? str2time $1 : 0;
304		395
…		…
307	if ($path !~ /\/$/) {	398	if ($path !~ /\/$/) {
308	# create a redirect to get the trailing "/"	399	# create a redirect to get the trailing "/"
309	my $host = $self->server_hostport;	400	my $host = $self->server_hostport;
310	$self->err(301, "moved permanently", { Location => "http://$host$self->{uri}/" });	401	$self->err(301, "moved permanently", { Location => "http://$host$self->{uri}/" });
311	} else {	402	} else {
312	$ims < (stat _)[9]	403	$ims < $self->{stat}[9]
313	or $self->err(304, "not modified");	404	or $self->err(304, "not modified");
314		405
315	if ($self->{method} eq "GET") {
316	if (-r "$path/index.html") {	406	if (-r "$path/index.html") {
317	$self->{path} .= "/index.html";	407	$self->{path} .= "/index.html";
318	$self->handle_file;	408	$self->handle_file;
319	} else {	409	} else {
320	$self->handle_dir;	410	$self->handle_dir;
321	}
322	}	411	}
323	}	412	}
324	} elsif (-f _ && -r _) {	413	} elsif (-f _ && -r _) {
325	-x _ and $self->err(403, "forbidden");	414	-x _ and $self->err(403, "forbidden");
326	$self->handle_file;	415	$self->handle_file;
…		…
329	}	418	}
330	}	419	}
331		420
332	sub handle_dir {	421	sub handle_dir {
333	my $self = shift;	422	my $self = shift;
334	$self->_cgi($::INDEXPROG);	423	my $idx = $self->diridx;
		424
		425	$self->response(200, "ok",
		426	{
		427	"Content-Type" => "text/html",
		428	"Content-Length" => length $idx,
		429	},
		430	$idx);
335	}	431	}
336		432
337	sub handle_file {	433	sub handle_file {
338	my $self = shift;	434	my $self = shift;
339	my $length = -s _;	435	my $length = -s _;
…		…
352	($l, $h) = ($1, ($2 ne "" \|\| $2 >= $length) ? $2 : $length - 1);	448	($l, $h) = ($1, ($2 ne "" \|\| $2 >= $length) ? $2 : $length - 1);
353	} else {	449	} else {
354	($l, $h) = (0, $length - 1);	450	($l, $h) = (0, $length - 1);
355	goto ignore;	451	goto ignore;
356	}	452	}
357	goto satisfiable if $l >= 0 && $l < $length && $h >= 0 && $h > $l;	453	goto satisfiable if $l >= 0 && $l < $length && $h >= 0 && $h >= $l;
358	}	454	}
359	$hdr->{"Content-Range"} = "bytes */$length";	455	$hdr->{"Content-Range"} = "bytes */$length";
		456	$hdr->{"Content-Length"} = $length;
		457	$self->slog(9, "not satisfiable($self->{h}{range}\|".$self->{h}{"user-agent"}.")");
360	$self->err(416, "not satisfiable", $hdr);	458	$self->err(416, "not satisfiable", $hdr, "");
361		459
362	satisfiable:	460	satisfiable:
		461	# check for segmented downloads
		462	if ($l && $::NO_SEGMENTED) {
		463	if (%{$uri{$self->{remote_addr}}{$self->{uri}}} > 1) {
		464	$self->err(400, "segmented downloads are not allowed");
		465	}
		466	}
		467
363	$hdr->{"Content-Range"} = "bytes $l-$h/$length";	468	$hdr->{"Content-Range"} = "bytes $l-$h/$length";
364	@code = (206, "partial content");	469	@code = (206, "partial content");
365	$length = $h - $l + 1;	470	$length = $h - $l + 1;
366		471
367	ignore:	472	ignore:
368	} else {	473	} else {
369	($l, $h) = (0, $length - 1);	474	($l, $h) = (0, $length - 1);
370	}	475	}
371		476
372	if ($self->{path} =~ /\.html$/) {	477	$self->{path} =~ /\.([^.]+)$/;
373	$hdr->{"Content-Type"} = "text/html";
374	} else {
375	$hdr->{"Content-Type"} = "application/octet-stream";	478	$hdr->{"Content-Type"} = $mimetype{lc $1} \|\| "application/octet-stream";
376	}
377
378	$hdr->{"Content-Length"} = $length;	479	$hdr->{"Content-Length"} = $length;
379		480
380	$self->print_response(@code, $hdr, "");	481	$self->response(@code, $hdr, "");
381		482
382	if ($self->{method} eq "GET") {	483	if ($self->{method} eq "GET") {
383	my ($fh, $buf);	484	my ($fh, $buf, $r);
		485	my $current = $Coro::current;
384	open $fh, "<", $self->{path}	486	open $fh, "<", $self->{path}
385	or die "$self->{path}: late open failure ($!)";	487	or die "$self->{path}: late open failure ($!)";
386		488
387	if ($l) {
388	sysseek $fh, $l, 0
389	or die "$self->{path}: cannot seek to $l ($!)";
390	}
391
392	$h -= $l - 1;	489	$h -= $l - 1;
393		490
		491	if (0) {
		492	if ($l) {
		493	sysseek $fh, $l, 0;
		494	}
		495	}
		496
394	while ($h > 0) {	497	while ($h > 0) {
395	$h -= sysread $fh, $buf, $h > 4096 ? 4096 : $h;	498	if (0) {
396	print {$self->{fh}} $buf	499	sysread $fh, $buf, $h > $::BUFSIZE ? $::BUFSIZE : $h
		500	or last;
		501	} else {
		502	aio_read($fh, $l, ($h > $::BUFSIZE ? $::BUFSIZE : $h),
		503	$buf, 0, sub {
		504	$r = $_[0];
		505	$current->ready;
		506	});
		507	&Coro::schedule;
		508	last unless $r;
		509	}
		510	my $w = $self->{fh}->syswrite($buf)
397	or last;	511	or last;
		512	$::written += $w;
		513	$self->{written} += $w;
		514	$l += $r;
398	}	515	}
399	}	516	}
400		517
401	close $fh;	518	close $fh;
402	}	519	}

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.27 by root, Sun Aug 19 23:57:52 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.27 by root, Sun Aug 19 23:57:52 2001 UTC