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

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

Diff Legend

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

Comparing cvsroot/Coro/myhttpd/httpd.pl (file contents): Revision 1.34 by root, Thu Aug 30 02:58:17 2001 UTC vs. Revision 1.87 by root, Wed Nov 19 11:41:06 2008 UTC

Diff Legend

Comparing cvsroot/Coro/myhttpd/httpd.pl (file contents):
Revision 1.34 by root, Thu Aug 30 02:58:17 2001 UTC vs.
Revision 1.87 by root, Wed Nov 19 11:41:06 2008 UTC