[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.92 by root, Tue Mar 9 16:46:23 2010 UTC

…		…
1	use Coro;	1	use Coro;
2	use Coro::Semaphore;	2	use Coro::Semaphore;
		3	use Coro::SemaphoreSet;
3	use Coro::Event;	4	use Coro::EV;
4	use Coro::Socket;	5	use Coro::Socket;
		6	use Coro::Signal;
		7	use Coro::AIO ();
5		8
6	no utf8;	9	use Fcntl;
7	use bytes;	10	use HTTP::Date;
		11	use POSIX ();
		12
		13	use Compress::Zlib ();
		14
		15	use common::sense;
8		16
9	# at least on my machine, this thingy serves files	17	# at least on my machine, this thingy serves files
10	# quite a bit faster than apache, ;)	18	# quite a bit faster than apache, ;)
11	# and quite a bit slower than thttpd :(	19	# and quite a bit slower than thttpd :(
12		20
13	$SIG{PIPE} = 'IGNORE';	21	$SIG{PIPE} = 'IGNORE';
14		22
		23	our $accesslog;
		24	our $errorlog;
		25	our @listen_sockets;
		26
		27	our $NOW;
		28	our $HTTP_NOW;
		29
		30	our $ERROR_LOG;
		31	our $ACCESS_LOG;
		32	our $TRANSFER_LOCK = new Coro::SemaphoreSet; # lock to be acquired per ip
		33
		34	our $update_time = EV::periodic 0, 1, undef, sub {
		35	$NOW = time;
		36	$HTTP_NOW = time2str $NOW;
		37	};
		38	$update_time->invoke;
		39
		40	if ($ERROR_LOG) {
		41	use IO::Handle;
		42	open $errorlog, ">>$ERROR_LOG"
		43	or die "$ERROR_LOG: $!";
		44	$errorlog->autoflush(1);
		45	}
		46
		47	if ($ACCESS_LOG) {
		48	use IO::Handle;
		49	open $accesslog, ">>$ACCESS_LOG"
		50	or die "$ACCESS_LOG: $!";
		51	$accesslog->autoflush(1);
		52	}
		53
15	sub slog {	54	sub slog {
16	my $level = shift;	55	my $level = shift;
17	my $format = shift;	56	my $format = shift;
		57
		58	$format = sprintf $format, @_ if @_;
		59
		60	my $NOW = (POSIX::strftime "%Y-%m-%d %H:%M:%S", gmtime $::NOW);
18	printf "---: $format\n", @_;	61	print "$NOW: $format\n";
		62	printf $errorlog "$NOW: $format\n", @_ if $errorlog;
19	}	63	}
20		64
21	my $connections = new Coro::Semaphore $MAX_CONNECTS;	65	our $connections = new Coro::Semaphore $::MAX_CONNECTS \|\| 250;
		66	our $httpevent = new Coro::Signal;
22		67
23	my @newcons;	68	our $queue_file = new transferqueue $::MAX_TRANSFERS;
24	my @pool;	69	our $queue_index = new transferqueue 10;
25		70
26	# one "execution thread"	71	our $tbf_top = new tbf rate => $::TBF_RATE \|\| 100000;
27	sub handler {	72
		73	my $unused_bytes = 0;
		74	my $unused_last = time;
		75
		76	sub unused_bandwidth {
		77	$unused_bytes += $_[0];
		78	if ($unused_last < $NOW - 30 && $unused_bytes / ($NOW - $unused_last) > 50000) {
		79	$unused_last = $NOW;
		80	$unused_bytes = 0;
		81	$queue_file->force_wake_next
		82	and slog 1, "forced filetransfer due to unused bandwidth";
		83	}
		84	}
		85
		86	sub listen_on {
		87	my $listen = $_[0];
		88
		89	push @listen_sockets, $listen;
		90
		91	# the "main thread"
		92	async {
		93	slog 1, "accepting connections";
28	while () {	94	while () {
29	my $new = pop @newcons;	95	$connections->down;
30	if ($new) {	96	my @conn = $listen->accept;
		97	#slog 3, "accepted @$connections ".scalar(@pool);
		98
		99	async_pool {
31	eval {	100	eval {
32	conn->new(@$new)->handle;	101	conn->new (@conn)->handle;
33	};	102	};
34	slog 1, "$@" if $@ && !ref $@;	103	slog 1, "$@" if $@ && !ref $@;
		104
		105	$httpevent->broadcast; # only for testing, but doesn't matter much
		106
35	$connections->up;	107	$connections->up;
36	} else {
37	last if @pool >= $MAX_POOL;
38	push @pool, $Coro::current;
39	schedule;
40	}	108	}
		109	}
41	}	110	};
42	}	111	}
43		112
44	my $http_port = new Coro::Socket	113	my $http_port = new Coro::Socket
45	LocalAddr => $SERVER_HOST,	114	LocalAddr => $::SERVER_HOST,
46	LocalPort => $SERVER_PORT,	115	LocalPort => $::SERVER_PORT,
47	ReuseAddr => 1,	116	ReuseAddr => 1,
48	Listen => 50,	117	Listen => 50,
49	or die "unable to start server";	118	or die "unable to start server";
50		119
51	push @listen_sockets, $http_port;	120	listen_on $http_port;
52		121
53	# the "main thread"	122	if ($::SERVER_PORT2) {
54	async {	123	my $http_port = new Coro::Socket
55	slog 1, "accepting connections";	124	LocalAddr => $::SERVER_HOST,
56	while () {	125	LocalPort => $::SERVER_PORT2,
57	$connections->down;	126	ReuseAddr => 1,
58	push @newcons, [$http_port->accept];	127	Listen => 50,
59	#slog 3, "accepted @$connections ".scalar(@pool);	128	or die "unable to start server";
60	$::NOW = time;
61	if (@pool) {
62	(pop @pool)->ready;
63	} else {
64	async \&handler;
65	}
66		129
67	}	130	listen_on $http_port;
68	};	131	}
69		132
70	package conn;	133	package conn;
		134
		135	use common::sense;
71		136
72	use Socket;	137	use Socket;
73	use HTTP::Date;	138	use HTTP::Date;
74	use Convert::Scalar 'weaken';	139	use Convert::Scalar 'weaken';
		140	use IO::AIO;
75		141
		142	IO::AIO::min_parallel $::AIO_PARALLEL;
		143
		144	our $AIO_WATCHER = EV::io IO::AIO::poll_fileno, EV::READ, \&IO::AIO::poll_cb;
		145
76	our %conn; # $conn{ip}{fh} => connobj	146	our %conn; # $conn{ip}{self} => connobj
		147	our %uri; # $uri{ip}{uri}{self}
77	our %blocked;	148	our %blocked;
78	our %mimetype;	149	our %mimetype;
79		150
80	sub read_mimetypes {	151	sub read_mimetypes {
81	local *M;
82	if (open M, "<mime_types") {	152	if (open my $fh, "<mime_types") {
83	while (<M>) {	153	while (<$fh>) {
84	if (/^([^#]\S+)\t+(\S+)$/) {	154	if (/^([^#]\S+)\t+(\S+)$/) {
85	$mimetype{lc $1} = $2;	155	$mimetype{lc $1} = $2;
86	}	156	}
87	}	157	}
88	} else {	158	} else {
92		162
93	read_mimetypes;	163	read_mimetypes;
94		164
95	sub new {	165	sub new {
96	my $class = shift;	166	my $class = shift;
		167	my $fh = shift;
97	my $peername = shift;	168	my $peername = shift;
98	my $fh = shift;
99	my $self = bless { fh => $fh }, $class;	169	my $self = bless { fh => $fh }, $class;
100	my (undef, $iaddr) = unpack_sockaddr_in $peername	170	my (undef, $iaddr) = unpack_sockaddr_in $peername
101	or $self->err(500, "unable to decode peername");	171	or $self->err (500, "unable to decode peername");
102		172
		173	$self->{remote_addr} =
103	$self->{remote_addr} = inet_ntoa $iaddr;	174	$self->{remote_id} = inet_ntoa $iaddr;
		175
104	$self->{time} = $::NOW;	176	$self->{time} = $::NOW;
105		177
106	# enter ourselves into various lists	178	weaken ($Coro::current->{conn} = $self);
107	weaken ($conn{$self->{remote_addr}}{$self*1} = $self);
108		179
109	$::conns++;	180	++$::conns;
		181	$::maxconns = $::conns if $::conns > $::maxconns;
110		182
111	$self;	183	$self
112	}	184	}
113		185
114	sub DESTROY {	186	sub DESTROY {
115	my $self = shift;	187	my $self = shift;
116		188
117	$::conns--;	189	--$::conns;
118
119	delete $conn{$self->{remote_addr}}{$self*1};
120	delete $uri{$self->{remote_addr}}{$self->{uri}}{$self*1};
121	}	190	}
		191
		192	sub prune_cache {
		193	my $hash = $_[0];
		194
		195	for (keys %$hash) {
		196	if (ref $hash->{$_} eq HASH::) {
		197	prune_cache($hash->{$_});
		198	unless (scalar keys %{$hash->{$_}}) {
		199	delete $hash->{$_};
		200	}
		201	}
		202	}
		203	}
		204
		205	sub prune_caches {
		206	prune_cache \%conn;
		207	prune_cache \%uri;
		208
		209	for (keys %blocked) {
		210	delete $blocked{$_} unless $blocked{$_}[0] > $::NOW;
		211	}
		212	}
		213
		214	our $PRUNE_WATCHER = EV::timer 60, 60, \&prune_caches;
122		215
123	sub slog {	216	sub slog {
124	my $self = shift;	217	my $self = shift;
125	main::slog($_[0], "$self->{remote_addr}> $_[1]");	218	main::slog($_[0], "$self->{remote_id}> $_[1]");
126	}	219	}
127		220
128	sub response {	221	sub response {
129	my ($self, $code, $msg, $hdr, $content) = @_;	222	my ($self, $code, $msg, $hdr, $content) = @_;
130	my $res = "HTTP/1.0 $code $msg\015\012";	223	my $res = "HTTP/1.1 $code $msg\015\012";
		224	my $GZ = "";
131		225
132	$res .= "Connection: close\015\012";	226	if (exists $hdr->{Connection}) {
133	$res .= "Date: ".(time2str $::NOW)."\015\012"; # slow? nah. :(	227	if ($hdr->{Connection} =~ /close/) {
		228	$self->{h}{connection} = "close"
		229	}
		230	} else {
		231	if ($self->{version} < 1.1) {
		232	if ($self->{h}{connection} =~ /keep-alive/i) {
		233	$hdr->{Connection} = "Keep-Alive";
		234	} else {
		235	$self->{h}{connection} = "close"
		236	}
		237	}
		238	}
		239
		240	if ($self->{method} ne "HEAD"
		241	&& $self->{h}{"accept-encoding"} =~ /\bgzip\b/
		242	&& 400 < length $content
		243	&& $hdr->{"Content-Length"} == length $content
		244	&& !exists $hdr->{"Content-Encoding"}
		245	) {
		246	my $orig = length $content;
		247	$hdr->{"Content-Encoding"} = "gzip";
		248	$content = Compress::Zlib::memGzip(\$content);
		249	$hdr->{"Content-Length"} = length $content;
		250	$GZ = sprintf "GZ%02d", 100 - 100*((length $content) / $orig);
		251	}
		252
		253	$res .= "Date: $HTTP_NOW\015\012";
		254	$res .= "Server: $::NAME\015\012";
134		255
135	while (my ($h, $v) = each %$hdr) {	256	while (my ($h, $v) = each %$hdr) {
136	$res .= "$h: $v\015\012"	257	$res .= "$h: $v\015\012"
137	}	258	}
138	$res .= "\015\012";	259	$res .= "\015\012";
139		260
140	$res .= $content if defined $content and $self->{method} ne "HEAD";	261	$res .= $content if defined $content and $self->{method} ne "HEAD";
141		262
142	print STDERR "$self->{remote_addr} \"$self->{uri}\" $code ".$hdr->{"Content-Length"}." \"$self->{h}{referer}\"\n";#d#	263	my $log = (POSIX::strftime "%Y-%m-%d %H:%M:%S", gmtime $::NOW).
		264	" $self->{remote_id} \"$self->{uri}\" $code ".$hdr->{"Content-Length"}.$GZ.
		265	" \"$self->{h}{referer}\"\n";
143		266
144	$self->{written} +=	267	print $::accesslog $log if $::accesslog;
145	print {$self->{fh}} $res;	268	print STDERR $log;
		269
		270	$tbf_top->request(length $res, 1e6);
		271	$self->{written} += print {$self->{fh}} $res;
146	}	272	}
147		273
148	sub err {	274	sub err {
149	my $self = shift;	275	my $self = shift;
150	my ($code, $msg, $hdr, $content) = @_;	276	my ($code, $msg, $hdr, $content) = @_;
151		277
152	unless (defined $content) {	278	unless (defined $content) {
153	$content = "$code $msg";	279	$content = "$code $msg\n";
154	$hdr->{"Content-Type"} = "text/plain";	280	$hdr->{"Content-Type"} = "text/plain";
155	$hdr->{"Content-Length"} = length $content;	281	$hdr->{"Content-Length"} = length $content;
156	}	282	}
		283	$hdr->{"Connection"} = "close";
157		284
158	$self->response($code, $msg, $hdr, $content);	285	$self->response ($code, $msg, $hdr, $content);
159		286
160	die bless {}, err::;	287	die bless {}, err::
161	}
162
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	}	288	}
185		289
186	sub handle {	290	sub handle {
187	my $self = shift;	291	my $self = shift;
188	my $fh = $self->{fh};	292	my $fh = $self->{fh};
189		293
		294	my $host;
		295
		296	$fh->timeout($::REQ_TIMEOUT);
190	#while() {	297	while () {
		298	$self->{reqs}++;
		299
		300	# read request and parse first line
		301	my $req = $fh->readline("\015\012\015\012");
		302
		303	unless (defined $req) {
		304	if (exists $self->{version}) {
		305	last;
		306	} else {
		307	$self->err(408, "request timeout");
		308	}
		309	}
		310
191	$self->{h} = {};	311	$self->{h} = {};
192		312
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);	313	$fh->timeout($::RES_TIMEOUT);
197
198	defined $req or
199	$self->err(408, "request timeout");
200
201	my $ip = $self->{remote_addr};
202
203	if ($blocked{$ip}) {
204	$self->err_blocked($blocked{$ip})
205	if $blocked{$ip} > $::NOW;
206
207	delete $blocked{$ip};
208	}
209
210	if (%{$conn{$ip}} > $::MAX_CONN_IP) {
211	$self->slog(2, "blocked ip $ip");
212	$self->err_blocked;
213	}
214		314
215	$req =~ /^(?:\015\012)?	315	$req =~ /^(?:\015\012)?
216	(GET\|HEAD) \040+	316	(GET\|HEAD) \040+
217	([^\040]+) \040+	317	([^\040]+) \040+
218	HTTP\/([0-9]+\.[0-9]+)	318	HTTP\/([0-9]+\.[0-9]+)
219	\015\012/gx	319	\015\012/gx
220	or $self->err(403, "method not allowed", { Allow => "GET,HEAD" });	320	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		321
225	$self->{method} = $1;	322	$self->{method} = $1;
226	$self->{uri} = $2;	323	$self->{uri} = $2;
		324	$self->{version} = $3;
		325
		326	$3 =~ /^1\./
		327	or $self->err(506, "http protocol version $3 not supported");
227		328
228	# parse headers	329	# parse headers
229	{	330	{
230	my (%hdr, $h, $v);	331	my (%hdr, $h, $v);
231		332
232	$hdr{lc $1} .= ",$2"	333	$hdr{lc $1} .= ",$2"
233	while $req =~ /\G	334	while $req =~ /\G
234	([^:\000-\040]+):	335	([^:\000-\040]+):
235	[\008\040]*	336	[\011\040]*
236	((?: [^\015\012]+ \| \015\012[\008\040] )*)	337	((?: [^\015\012]+ \| \015\012[\011\040] )*)
237	\015\012	338	\015\012
238	/gxc;	339	/gxc;
239		340
240	$req =~ /\G\015\012$/	341	$req =~ /\G\015\012$/
241	or $self->err(400, "bad request");	342	or $self->err(400, "bad request");
242		343
243	$self->{h}{$h} = substr $v, 1	344	$self->{h}{$h} = substr $v, 1
244	while ($h, $v) = each %hdr;	345	while ($h, $v) = each %hdr;
245	}	346	}
246		347
		348	# remote id should be unique per user
		349	my $id = $self->{remote_addr};
		350
		351	if (exists $self->{h}{"client-ip"}) {
		352	$id .= "[".$self->{h}{"client-ip"}."]";
		353	} elsif (exists $self->{h}{"x-forwarded-for"}) {
		354	$id .= "[".$self->{h}{"x-forwarded-for"}."]";
		355	}
		356
		357	$self->{remote_id} = $id;
		358
		359	weaken (local $conn{$id}{$self*1} = $self);
		360
		361	if ($blocked{$id}) {
		362	$self->err_blocked
		363	if $blocked{$id}[0] > $::NOW;
		364
		365	delete $blocked{$id};
		366	}
		367
		368	# find out server name and port
		369	if ($self->{uri} =~ s/^http:\/\/([^\/?#]*)//i) {
		370	$host = $1;
		371	} else {
		372	$host = $self->{h}{host};
		373	}
		374
		375	if (defined $host) {
247	$self->{server_port} = $self->{h}{host} =~ s/:([0-9]+)$// ? $1 : 80;	376	$self->{server_port} = $host =~ s/:([0-9]+)$// ? $1 : 80;
		377	} else {
		378	($self->{server_port}, $host)
		379	= unpack_sockaddr_in $self->{fh}->sockname
		380	or $self->err(500, "unable to get socket name");
		381	$host = inet_ntoa $host;
		382	}
248		383
		384	$self->{server_name} = $host;
		385
249	weaken ($uri{$self->{remote_addr}}{$self->{uri}}{$self*1} = $self);	386	weaken (local $uri{$id}{$self->{uri}}{$self*1} = $self);
250		387
		388	eval {
251	$self->map_uri;	389	$self->map_uri;
252	$self->respond;	390	$self->respond;
		391	};
		392
		393	die if $@ && !ref $@;
		394
		395	last if $self->{h}{connection} =~ /close/i;
		396
		397	$httpevent->broadcast;
		398
		399	$fh->timeout($::PER_TIMEOUT);
253	#}	400	}
		401	}
		402
		403	sub block {
		404	my $self = shift;
		405
		406	$blocked{$self->{remote_id}} = [$::NOW + $_[0], $_[1]];
		407	$self->slog(2, "blocked ip $self->{remote_id}");
		408	$self->err_blocked;
254	}	409	}
255		410
256	# uri => path mapping	411	# uri => path mapping
257	sub map_uri {	412	sub map_uri {
258	my $self = shift;	413	my $self = shift;
259	my $host = $self->{h}{host} \|\| "default";	414	my $host = $self->{server_name};
260	my $uri = $self->{uri};	415	my $uri = $self->{uri};
		416
		417	$host =~ /[\/\\]/
		418	and $self->err(400, "bad request");
261		419
262	# some massaging, also makes it more secure	420	# some massaging, also makes it more secure
263	$uri =~ s/%([0-9a-fA-F][0-9a-fA-F])/chr hex $1/ge;	421	$uri =~ s/%([0-9a-fA-F][0-9a-fA-F])/chr hex $1/ge;
264	$uri =~ s%//+%/%g;	422	$uri =~ s%//+%/%g;
265	$uri =~ s%/\.(?=/\|$)%%g;	423	$uri =~ s%/\.(?=/\|$)%%g;
…		…
274	$self->{path} = "$::DOCROOT/$host$uri";	432	$self->{path} = "$::DOCROOT/$host$uri";
275		433
276	$self->access_check;	434	$self->access_check;
277	}	435	}
278		436
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 {	437	sub _cgi {
308	my $self = shift;	438	my $self = shift;
309	my $path = shift;	439	my $path = shift;
310	my $fh;	440	my $fh;
311		441
312	# no two-way xxx supported	442	# no two-way xxx supported
313	if (0 == fork) {	443	if (0 == fork) {
314	open STDOUT, ">&".fileno($self->{fh});	444	open STDOUT, ">&".fileno($self->{fh});
315	if (chdir $::DOCROOT) {	445	if (chdir $::DOCROOT) {
316	$ENV{SERVER_SOFTWARE} = "thttpd-myhttpd"; # we are thttpd-alike	446	$ENV{SERVER_SOFTWARE} = "thttpd-myhttpd"; # we are thttpd-alike
317	$ENV{HTTP_HOST} = $self->server_host;	447	$ENV{HTTP_HOST} = $self->{server_name};
318	$ENV{HTTP_PORT} = $self->{server_host};	448	$ENV{HTTP_PORT} = $self->{server_port};
319	$ENV{SCRIPT_NAME} = $self->{name};	449	$ENV{SCRIPT_NAME} = $self->{name};
320	exec $path;	450	exec $path;
321	}	451	}
322	Coro::State::_exit(0);	452	Coro::State::_exit(0);
323	} else {	453	} else {
		454	die;
324	}	455	}
		456	}
		457
		458	sub server_hostport {
		459	$_[0]{server_port} == 80
		460	? $_[0]{server_name}
		461	: "$_[0]{server_name}:$_[0]{server_port}";
325	}	462	}
326		463
327	sub respond {	464	sub respond {
328	my $self = shift;	465	my $self = shift;
329	my $path = $self->{path};	466	my $path = $self->{path};
330		467
331	stat $path	468	if ($self->{name} =~ s%^/internal/([^/]+)%%) {
332	or $self->err(404, "not found");	469	if ($::internal{$1}) {
333		470	$::internal{$1}->($self);
334	$self->{stat} = [stat _];
335
336	# idiotic netscape sends idiotic headers AGAIN
337	my $ims = $self->{h}{"if-modified-since"} =~ /^([^;]+)/
338	? str2time $1 : 0;
339
340	if (-d _ && -r _) {
341	# directory
342	if ($path !~ /\/$/) {
343	# create a redirect to get the trailing "/"
344	my $host = $self->server_hostport;
345	$self->err(301, "moved permanently", { Location => "http://$host$self->{uri}/" });
346	} else {	471	} else {
		472	$self->err (404, "not found");
		473	}
		474	} else {
		475
		476	Coro::AIO::aio_stat $path
		477	and $self->err (404, "not found");
		478
		479	$self->{stat} = [stat _];
		480
		481	# idiotic netscape sends idiotic headers AGAIN
		482	my $ims = $self->{h}{"if-modified-since"} =~ /^([^;]+)/
		483	? str2time $1 : 0;
		484
		485	if (-d _ && -r _) {
		486	# directory
		487	if ($path !~ /\/$/) {
		488	# create a redirect to get the trailing "/"
		489	# we don't try to avoid the :80
		490	$self->err (301, "moved permanently", { Location => "http://".$self->server_hostport."$self->{uri}/" });
		491	} else {
347	$ims < $self->{stat}[9]	492	$ims < $self->{stat}[9]
348	or $self->err(304, "not modified");	493	or $self->err (304, "not modified");
349		494
350	if ($self->{method} eq "GET") {
351	if (-r "$path/index.html") {	495	if (-r "$path/index.html") {
		496	# replace directory "size" by index.html filesize
352	$self->{path} .= "/index.html";	497	$self->{stat} = [stat ($self->{path} .= "/index.html")];
353	$self->handle_file;	498	$self->handle_file ($queue_index, $tbf_top);
354	} else {	499	} else {
355	$self->handle_dir;	500	$self->handle_dir;
356	}	501	}
357	}	502	}
358	}
359	} elsif (-f _ && -r _) {	503	} elsif (-f _ && -r _) {
360	-x _ and $self->err(403, "forbidden");	504	-x _ and $self->err (403, "forbidden");
361	$self->handle_file;	505
		506	if (keys %{$conn{$self->{remote_id}}} > $::MAX_TRANSFERS_IP) {
		507	my $timeout = $::NOW + 10;
		508	while (keys %{$conn{$self->{remote_id}}} > $::MAX_TRANSFERS_IP) {
		509	if ($timeout < $::NOW) {
		510	$self->block($::BLOCKTIME, "too many connections");
		511	} else {
		512	$httpevent->wait;
		513	}
		514	}
		515	}
		516
		517	$self->handle_file ($queue_file, $tbf_top);
362	} else {	518	} else {
363	$self->err(404, "not found");	519	$self->err (404, "not found");
		520	}
364	}	521	}
365	}	522	}
366		523
367	sub handle_dir {	524	sub handle_dir {
368	my $self = shift;	525	my $self = shift;
369	my $idx = $self->diridx;	526	my $idx = $self->diridx;
370		527
371	$self->response(200, "ok",	528	$self->response (200, "ok",
372	{	529	{
373	"Content-Type" => "text/html",	530	"Content-Type" => "text/html; charset=utf-8",
374	"Content-Length" => length $idx,	531	"Content-Length" => length $idx,
		532	"Last-Modified" => time2str ($self->{stat}[9]),
375	},	533	},
376	$idx);	534	$idx);
377	}	535	}
378		536
379	sub handle_file {	537	sub handle_file {
380	my $self = shift;	538	my ($self, $queue, $tbf) = @_;
381	my $length = -s _;	539	my $length = $self->{stat}[7];
382	my $hdr = {	540	my $hdr = {
383	"Last-Modified" => time2str ((stat _)[9]),	541	"Last-Modified" => time2str ((stat _)[9]),
		542	"Accept-Ranges" => "bytes",
384	};	543	};
385		544
386	my @code = (200, "ok");	545	my @code = (200, "ok");
387	my ($l, $h);	546	my ($l, $h);
388		547
389	if ($self->{h}{range} =~ /^bytes=(.*)$/) {	548	if ($self->{h}{range} =~ /^bytes=(.*)$/i) {
390	for (split /,/, $1) {	549	for (split /,/, $1) {
391	if (/^-(\d+)$/) {	550	if (/^-(\d+)$/) {
392	($l, $h) = ($length - $1, $length - 1);	551	($l, $h) = ($length - $1, $length - 1);
393	} elsif (/^(\d+)-(\d*)$/) {	552	} elsif (/^(\d+)-(\d*)$/) {
394	($l, $h) = ($1, ($2 ne "" \|\| $2 >= $length) ? $2 : $length - 1);	553	($l, $h) = ($1, ($2 ne "" \|\| $2 >= $length) ? $2 : $length - 1);
395	} else {	554	} else {
396	($l, $h) = (0, $length - 1);	555	($l, $h) = (0, $length - 1);
397	goto ignore;	556	goto ignore;
398	}	557	}
399	goto satisfiable if $l >= 0 && $l < $length && $h >= 0 && $h > $l;	558	goto satisfiable if $l >= 0 && $l < $length && $h >= 0 && $h >= $l;
400	}	559	}
401	$hdr->{"Content-Range"} = "bytes */$length";	560	$hdr->{"Content-Range"} = "bytes */$length";
		561	$hdr->{"Content-Length"} = $length;
402	$self->err(416, "not satisfiable", $hdr);	562	$self->err (416, "not satisfiable", $hdr, "");
403		563
404	satisfiable:	564	satisfiable:
405	# check for segmented downloads	565	# check for segmented downloads
406	if ($l && $::NO_SEGMENTED) {	566	if ($l && $::NO_SEGMENTED) {
		567	my $timeout = $::NOW + 15;
407	if (%{$uri{$self->{remote_addr}}{$self->{uri}}} > 1) {	568	while (keys %{$uri{$self->{remote_id}}{$self->{uri}}} > 1) {
408	$self->err(400, "segmented downloads are not allowed");	569	if ($timeout <= $::NOW) {
		570	$self->block ($::BLOCKTIME, "segmented downloads are forbidden");
		571	#$self->err_segmented_download;
		572	} else {
		573	$httpevent->wait;
		574	}
409	}	575	}
410	}	576	}
411		577
412	$hdr->{"Content-Range"} = "bytes $l-$h/$length";	578	$hdr->{"Content-Range"} = "bytes $l-$h/$length";
413	@code = (206, "partial content");	579	@code = (206, "partial content");
…		…
420		586
421	$self->{path} =~ /\.([^.]+)$/;	587	$self->{path} =~ /\.([^.]+)$/;
422	$hdr->{"Content-Type"} = $mimetype{lc $1} \|\| "application/octet-stream";	588	$hdr->{"Content-Type"} = $mimetype{lc $1} \|\| "application/octet-stream";
423	$hdr->{"Content-Length"} = $length;	589	$hdr->{"Content-Length"} = $length;
424		590
425	$self->response(@code, $hdr, "");	591	$self->response (@code, $hdr, "");
426		592
427	if ($self->{method} eq "GET") {	593	if ($self->{method} eq "GET") {
428	my ($fh, $buf);	594	$self->{time} = $::NOW;
429	open $fh, "<", $self->{path}	595	$self->{written} = 0;
		596
		597	my $fh = Coro::AIO::aio_open $self->{path}, Fcntl::O_RDONLY, 0
430	or die "$self->{path}: late open failure ($!)";	598	or die "$self->{path}: late open failure ($!)";
431		599
432	if ($l) {
433	sysseek $fh, $l, 0
434	or die "$self->{path}: cannot seek to $l ($!)";
435	}
436
437	$h -= $l - 1;	600	$h -= $l - 1;
438		601
		602	my $transfer = $queue->start_transfer ($h);
		603	my $locked;
		604	my $bufsize = $::WAIT_BUFSIZE; # initial buffer size
		605
439	while ($h > 0) {	606	while ($h > 0) {
440	$h -= sysread $fh, $buf, $h > $::BUFSIZE ? $::BUFSIZE : $h;	607	Coro::cede;
		608	my $transfer_lock = $TRANSFER_LOCK->guard ($self->{remote_id});
		609
		610	unless ($locked) {
		611	if ($locked \|\|= $transfer->try ($::WAIT_INTERVAL)) {
		612	$bufsize = $::BUFSIZE;
		613	$self->{time} = $::NOW;
		614	$self->{written} = 0;
		615	}
		616	}
		617
		618	if ($blocked{$self->{remote_id}}) {
		619	$self->{h}{connection} = "close";
		620	die bless {}, err::;
		621	}
		622
		623	Coro::AIO::aio_read $fh, $l, ($h > $bufsize ? $bufsize : $h), my $buf, 0
		624	or last;
		625
		626	$tbf->request (length $buf);
441	my $w = $self->{fh}->syswrite($buf)	627	my $w = $self->{fh}->syswrite ($buf)
442	or last;	628	or last;
443	$::written += $w;	629	$::written += $w;
444	$self->{written} += $w;	630	$self->{written} += $w;
		631	$l += $w;
445	}	632	}
446	}
447		633
448	close $fh;	634	close $fh;
		635	}
449	}	636	}
450		637
451	1;	638	1
		639

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.92 by root, Tue Mar 9 16:46:23 2010 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.92 by root, Tue Mar 9 16:46:23 2010 UTC