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

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

Diff Legend

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

Comparing Coro/myhttpd/httpd.pl (file contents): Revision 1.46 by root, Sat Nov 17 04:15:23 2001 UTC vs. Revision 1.85 by root, Mon Feb 18 17:48:00 2008 UTC

Diff Legend

Comparing Coro/myhttpd/httpd.pl (file contents):
Revision 1.46 by root, Sat Nov 17 04:15:23 2001 UTC vs.
Revision 1.85 by root, Mon Feb 18 17:48:00 2008 UTC