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

Comparing cvsroot/Coro/myhttpd/httpd.pl (file contents):
Revision 1.62 by root, Sun Jan 6 05:29:39 2002 UTC vs.
Revision 1.80 by root, Fri Dec 1 04:18:32 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;	5	use Coro::Signal;
		6	use Coro::AIO ();
6		7
7	use HTTP::Date;	8	use HTTP::Date;
8	use POSIX ();	9	use POSIX ();
		10
		11	use Compress::Zlib ();
9		12
10	no utf8;	13	no utf8;
11	use bytes;	14	use bytes;
12		15
13	# at least on my machine, this thingy serves files	16	# at least on my machine, this thingy serves files
19	our $accesslog;	22	our $accesslog;
20	our $errorlog;	23	our $errorlog;
21		24
22	our $NOW;	25	our $NOW;
23	our $HTTP_NOW;	26	our $HTTP_NOW;
		27
		28	our $ERROR_LOG;
		29	our $ACCESS_LOG;
24		30
25	Event->timer(interval => 1, hard => 1, cb => sub {	31	Event->timer(interval => 1, hard => 1, cb => sub {
26	$NOW = time;	32	$NOW = time;
27	$HTTP_NOW = time2str $NOW;	33	$HTTP_NOW = time2str $NOW;
28	})->now;	34	})->now;
…		…
50	}	56	}
51		57
52	our $connections = new Coro::Semaphore $MAX_CONNECTS \|\| 250;	58	our $connections = new Coro::Semaphore $MAX_CONNECTS \|\| 250;
53	our $httpevent = new Coro::Signal;	59	our $httpevent = new Coro::Signal;
54		60
55	our $queue_file = new transferqueue slots => $MAX_TRANSFERS, maxsize => 250_000_000;	61	our $queue_file = new transferqueue $MAX_TRANSFERS;
56	our $queue_index = new transferqueue slots => 10;	62	our $queue_index = new transferqueue 10;
57		63
58	our $requests;	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	}
59		78
60	my @newcons;	79	my @newcons;
61	my @pool;	80	my @pool;
62		81
63	# one "execution thread"	82	# one "execution thread"
…		…
95	if (@pool) {	114	if (@pool) {
96	(pop @pool)->ready;	115	(pop @pool)->ready;
97	} else {	116	} else {
98	async \&handler;	117	async \&handler;
99	}	118	}
100
101	}	119	}
102	};	120	};
103	}	121	}
104		122
105	my $http_port = new Coro::Socket	123	my $http_port = new Coro::Socket
…		…
122	listen_on $http_port;	140	listen_on $http_port;
123	}	141	}
124		142
125	package conn;	143	package conn;
126		144
		145	use strict;
		146	use bytes;
		147
127	use Socket;	148	use Socket;
128	use HTTP::Date;	149	use HTTP::Date;
129	use Convert::Scalar 'weaken';	150	use Convert::Scalar 'weaken';
130	use Linux::AIO;	151	use IO::AIO;
131		152
132	Linux::AIO::min_parallel $::AIO_PARALLEL;	153	IO::AIO::min_parallel $::AIO_PARALLEL;
133		154
134	Event->io(fd => Linux::AIO::poll_fileno,	155	Event->io (fd => IO::AIO::poll_fileno,
135	poll => 'r', async => 1,	156	poll => 'r', async => 1,
136	cb => \&Linux::AIO::poll_cb);	157	cb => \&IO::AIO::poll_cb);
137		158
138	our %conn; # $conn{ip}{self} => connobj	159	our %conn; # $conn{ip}{self} => connobj
139	our %uri; # $uri{ip}{uri}{self}	160	our %uri; # $uri{ip}{uri}{self}
140	our %blocked;	161	our %blocked;
141	our %mimetype;	162	our %mimetype;
…		…
179	sub DESTROY {	200	sub DESTROY {
180	#my $self = shift;	201	#my $self = shift;
181	$::conns--;	202	$::conns--;
182	}	203	}
183		204
		205	sub prune_cache {
		206	my $hash = $_[0];
		207
		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	}
		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);
		228
184	sub slog {	229	sub slog {
185	my $self = shift;	230	my $self = shift;
186	main::slog($_[0], "$self->{remote_id}> $_[1]");	231	main::slog($_[0], "$self->{remote_id}> $_[1]");
187	}	232	}
188		233
189	sub response {	234	sub response {
190	my ($self, $code, $msg, $hdr, $content) = @_;	235	my ($self, $code, $msg, $hdr, $content) = @_;
191	my $res = "HTTP/1.1 $code $msg\015\012";	236	my $res = "HTTP/1.1 $code $msg\015\012";
		237	my $GZ = "";
192		238
193	if (exists $hdr->{Connection}) {	239	if (exists $hdr->{Connection}) {
194	if ($hdr->{Connection} =~ /close/) {	240	if ($hdr->{Connection} =~ /close/) {
195	$self->{h}{connection} = "close"	241	$self->{h}{connection} = "close"
196	}	242	}
…		…
202	$self->{h}{connection} = "close"	248	$self->{h}{connection} = "close"
203	}	249	}
204	}	250	}
205	}	251	}
206		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	}
		265
207	$res .= "Date: $HTTP_NOW\015\012";	266	$res .= "Date: $HTTP_NOW\015\012";
		267	$res .= "Server: $::NAME\015\012";
208		268
209	while (my ($h, $v) = each %$hdr) {	269	while (my ($h, $v) = each %$hdr) {
210	$res .= "$h: $v\015\012"	270	$res .= "$h: $v\015\012"
211	}	271	}
212	$res .= "\015\012";	272	$res .= "\015\012";
213		273
214	$res .= $content if defined $content and $self->{method} ne "HEAD";	274	$res .= $content if defined $content and $self->{method} ne "HEAD";
215		275
216	my $log = (POSIX::strftime "%Y-%m-%d %H:%M:%S", gmtime $NOW).	276	my $log = (POSIX::strftime "%Y-%m-%d %H:%M:%S", gmtime $::NOW).
217	" $self->{remote_id} \"$self->{uri}\" $code ".$hdr->{"Content-Length"}.	277	" $self->{remote_id} \"$self->{uri}\" $code ".$hdr->{"Content-Length"}.$GZ.
218	" \"$self->{h}{referer}\"\n";	278	" \"$self->{h}{referer}\"\n";
219		279
220	print $accesslog $log if $accesslog;	280	print $::accesslog $log if $::accesslog;
221	print STDERR $log;	281	print STDERR $log;
222		282
223	$self->{written} +=	283	$tbf_top->request(length $res, 1e6);
224	print {$self->{fh}} $res;	284	$self->{written} += print {$self->{fh}} $res;
225	}	285	}
226		286
227	sub err {	287	sub err {
228	my $self = shift;	288	my $self = shift;
229	my ($code, $msg, $hdr, $content) = @_;	289	my ($code, $msg, $hdr, $content) = @_;
…		…
284	my (%hdr, $h, $v);	344	my (%hdr, $h, $v);
285		345
286	$hdr{lc $1} .= ",$2"	346	$hdr{lc $1} .= ",$2"
287	while $req =~ /\G	347	while $req =~ /\G
288	([^:\000-\040]+):	348	([^:\000-\040]+):
289	[\008\040]*	349	[\011\040]*
290	((?: [^\015\012]+ \| \015\012[\008\040] )*)	350	((?: [^\015\012]+ \| \015\012[\011\040] )*)
291	\015\012	351	\015\012
292	/gxc;	352	/gxc;
293		353
294	$req =~ /\G\015\012$/	354	$req =~ /\G\015\012$/
295	or $self->err(400, "bad request");	355	or $self->err(400, "bad request");
296		356
297	$self->{h}{$h} = substr $v, 1	357	$self->{h}{$h} = substr $v, 1
298	while ($h, $v) = each %hdr;	358	while ($h, $v) = each %hdr;
299	}	359	}
300
301	$requests++;
302		360
303	# remote id should be unique per user	361	# remote id should be unique per user
304	my $id = $self->{remote_addr};	362	my $id = $self->{remote_addr};
305		363
306	if (exists $self->{h}{"client-ip"}) {	364	if (exists $self->{h}{"client-ip"}) {
…		…
445	or $self->err(304, "not modified");	503	or $self->err(304, "not modified");
446		504
447	if (-r "$path/index.html") {	505	if (-r "$path/index.html") {
448	# replace directory "size" by index.html filesize	506	# replace directory "size" by index.html filesize
449	$self->{stat} = [stat ($self->{path} .= "/index.html")];	507	$self->{stat} = [stat ($self->{path} .= "/index.html")];
450	$self->handle_file($queue_index);	508	$self->handle_file($queue_index, $tbf_top);
451	} else {	509	} else {
452	$self->handle_dir;	510	$self->handle_dir;
453	}	511	}
454	}	512	}
455	} elsif (-f _ && -r _) {	513	} elsif (-f _ && -r _) {
…		…
464	$httpevent->wait;	522	$httpevent->wait;
465	}	523	}
466	}	524	}
467	}	525	}
468		526
469	$self->handle_file($queue_file);	527	$self->handle_file($queue_file, $tbf_top);
470	} else {	528	} else {
471	$self->err(404, "not found");	529	$self->err(404, "not found");
472	}	530	}
473	}	531	}
474	}	532	}
…		…
477	my $self = shift;	535	my $self = shift;
478	my $idx = $self->diridx;	536	my $idx = $self->diridx;
479		537
480	$self->response(200, "ok",	538	$self->response(200, "ok",
481	{	539	{
482	"Content-Type" => "text/html",	540	"Content-Type" => "text/html; charset=utf-8",
483	"Content-Length" => length $idx,	541	"Content-Length" => length $idx,
484	"Last-Modified" => time2str ($self->{stat}[9]),	542	"Last-Modified" => time2str ($self->{stat}[9]),
485	},	543	},
486	$idx);	544	$idx);
487	}	545	}
488		546
489	sub handle_file {	547	sub handle_file {
490	my ($self, $queue) = @_;	548	my ($self, $queue, $tbf) = @_;
491	my $length = $self->{stat}[7];	549	my $length = $self->{stat}[7];
492	my $hdr = {	550	my $hdr = {
493	"Last-Modified" => time2str ((stat _)[9]),	551	"Last-Modified" => time2str ((stat _)[9]),
		552	"Accept-Ranges" => "bytes",
494	};	553	};
495		554
496	my @code = (200, "ok");	555	my @code = (200, "ok");
497	my ($l, $h);	556	my ($l, $h);
498		557
…		…
541		600
542	$self->response(@code, $hdr, "");	601	$self->response(@code, $hdr, "");
543		602
544	if ($self->{method} eq "GET") {	603	if ($self->{method} eq "GET") {
545	$self->{time} = $::NOW;	604	$self->{time} = $::NOW;
		605	$self->{written} = 0;
546		606
547	my $current = $Coro::current;	607	my $fh;
548
549	my ($fh, $buf, $r);
550		608
551	open $fh, "<", $self->{path}	609	open $fh, "<", $self->{path}
552	or die "$self->{path}: late open failure ($!)";	610	or die "$self->{path}: late open failure ($!)";
553		611
554	$h -= $l - 1;	612	$h -= $l - 1;
…		…
566	while ($h > 0) {	624	while ($h > 0) {
567	unless ($locked) {	625	unless ($locked) {
568	if ($locked \|\|= $transfer->try($::WAIT_INTERVAL)) {	626	if ($locked \|\|= $transfer->try($::WAIT_INTERVAL)) {
569	$bufsize = $::BUFSIZE;	627	$bufsize = $::BUFSIZE;
570	$self->{time} = $::NOW;	628	$self->{time} = $::NOW;
		629	$self->{written} = 0;
571	}	630	}
572	}	631	}
573		632
574	if ($blocked{$self->{remote_id}}) {	633	if ($blocked{$self->{remote_id}}) {
575	$self->{h}{connection} = "close";	634	$self->{h}{connection} = "close";
576	die bless {}, err::;	635	die bless {}, err::;
577	}	636	}
578		637
579	if (0) { # !AIO	638	Coro::AIO::aio_read $fh, $l, ($h > $bufsize ? $bufsize : $h), my $buf, 0
580	sysread $fh, $buf, $h > $bufsize ? $bufsize : $h
581	or last;	639	or last;
582	} else {	640
583	aio_read($fh, $l, ($h > $bufsize ? $bufsize : $h),	641	$tbf->request (length $buf);
584	$buf, 0, sub {
585	$r = $_[0];
586	Coro::ready($current);
587	});
588	&Coro::schedule;
589	last unless $r;
590	}
591	my $w = syswrite $self->{fh}, $buf	642	my $w = syswrite $self->{fh}, $buf
592	or last;	643	or last;
593	$::written += $w;	644	$::written += $w;
594	$self->{written} += $w;	645	$self->{written} += $w;
595	$l += $r;	646	$l += $w;
596	}	647	}
597		648
598	close $fh;	649	close $fh;
599	}	650	}
600	}	651	}
601		652
602	1;	653	1
		654

Diff Legend

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

Comparing cvsroot/Coro/myhttpd/httpd.pl (file contents): Revision 1.62 by root, Sun Jan 6 05:29:39 2002 UTC vs. Revision 1.80 by root, Fri Dec 1 04:18:32 2006 UTC

Diff Legend

Comparing cvsroot/Coro/myhttpd/httpd.pl (file contents):
Revision 1.62 by root, Sun Jan 6 05:29:39 2002 UTC vs.
Revision 1.80 by root, Fri Dec 1 04:18:32 2006 UTC