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

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

Diff Legend

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

Comparing Coro/myhttpd/httpd.pl (file contents): Revision 1.2 by root, Thu Aug 9 19:11:13 2001 UTC vs. Revision 1.28 by root, Mon Aug 20 16:58:19 2001 UTC

Diff Legend

Comparing Coro/myhttpd/httpd.pl (file contents):
Revision 1.2 by root, Thu Aug 9 19:11:13 2001 UTC vs.
Revision 1.28 by root, Mon Aug 20 16:58:19 2001 UTC