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

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

Diff Legend

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

Comparing cvsroot/Coro/myhttpd/httpd.pl (file contents): Revision 1.36 by root, Sun Sep 2 00:54:00 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.36 by root, Sun Sep 2 00:54:00 2001 UTC vs.
Revision 1.91 by root, Thu Feb 4 22:35:47 2010 UTC