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

Comparing Coro/myhttpd/httpd.pl (file contents):
Revision 1.12 by root, Sat Aug 11 23:10:56 2001 UTC vs.
Revision 1.84 by root, Sat Dec 8 21:01:16 2007 UTC

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

Diff Legend

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

Comparing Coro/myhttpd/httpd.pl (file contents): Revision 1.12 by root, Sat Aug 11 23:10:56 2001 UTC vs. Revision 1.84 by root, Sat Dec 8 21:01:16 2007 UTC

Diff Legend

Comparing Coro/myhttpd/httpd.pl (file contents):
Revision 1.12 by root, Sat Aug 11 23:10:56 2001 UTC vs.
Revision 1.84 by root, Sat Dec 8 21:01:16 2007 UTC