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

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

Diff Legend

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

Comparing cvsroot/Coro/myhttpd/httpd.pl (file contents): Revision 1.31 by root, Mon Aug 27 05:05:26 2001 UTC vs. Revision 1.82 by root, Sat Dec 2 03:31:42 2006 UTC

Diff Legend

Comparing cvsroot/Coro/myhttpd/httpd.pl (file contents):
Revision 1.31 by root, Mon Aug 27 05:05:26 2001 UTC vs.
Revision 1.82 by root, Sat Dec 2 03:31:42 2006 UTC