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

Comparing cvsroot/Coro/myhttpd/httpd.pl (file contents):
Revision 1.35 by root, Thu Aug 30 12:35:28 2001 UTC vs.
Revision 1.81 by root, Sat Dec 2 03:29:29 2006 UTC

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

Diff Legend

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

Comparing cvsroot/Coro/myhttpd/httpd.pl (file contents): Revision 1.35 by root, Thu Aug 30 12:35:28 2001 UTC vs. Revision 1.81 by root, Sat Dec 2 03:29:29 2006 UTC

Diff Legend

Comparing cvsroot/Coro/myhttpd/httpd.pl (file contents):
Revision 1.35 by root, Thu Aug 30 12:35:28 2001 UTC vs.
Revision 1.81 by root, Sat Dec 2 03:29:29 2006 UTC