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

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

Diff Legend

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

Comparing cvsroot/Coro/myhttpd/httpd.pl (file contents): Revision 1.45 by root, Sun Nov 11 03:32:19 2001 UTC vs. Revision 1.91 by root, Thu Feb 4 22:35:47 2010 UTC

Diff Legend

Comparing cvsroot/Coro/myhttpd/httpd.pl (file contents):
Revision 1.45 by root, Sun Nov 11 03:32:19 2001 UTC vs.
Revision 1.91 by root, Thu Feb 4 22:35:47 2010 UTC