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

Comparing cvsroot/Coro/myhttpd/httpd.pl (file contents):
Revision 1.67 by root, Sun May 19 21:00:47 2002 UTC vs.
Revision 1.89 by root, Sun Jan 24 20:44:34 2010 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;
8	use POSIX ();	9	use POSIX ();
9		10
10	use Compress::Zlib ();	11	use Compress::Zlib ();
22	our $errorlog;	23	our $errorlog;
23		24
24	our $NOW;	25	our $NOW;
25	our $HTTP_NOW;	26	our $HTTP_NOW;
26		27
27	Event->timer(interval => 1, hard => 1, cb => sub {	28	our $ERROR_LOG;
		29	our $ACCESS_LOG;
		30
		31	our $update_time = EV::periodic 0, 1, undef, sub {
28	$NOW = time;	32	$NOW = time;
29	$HTTP_NOW = time2str $NOW;	33	$HTTP_NOW = time2str $NOW;
30	})->now;	34	};
		35	$update_time->invoke;
31		36
32	if ($ERROR_LOG) {	37	if ($ERROR_LOG) {
33	use IO::Handle;	38	use IO::Handle;
34	open $errorlog, ">>$ERROR_LOG"	39	open $errorlog, ">>$ERROR_LOG"
35	or die "$ERROR_LOG: $!";	40	or die "$ERROR_LOG: $!";
…		…
55	our $httpevent = new Coro::Signal;	60	our $httpevent = new Coro::Signal;
56		61
57	our $queue_file = new transferqueue $MAX_TRANSFERS;	62	our $queue_file = new transferqueue $MAX_TRANSFERS;
58	our $queue_index = new transferqueue 10;	63	our $queue_index = new transferqueue 10;
59		64
60	our $tbf_top = new tbf rate => 200000;	65	our $tbf_top = new tbf rate => $TBF_RATE \|\| 100000;
61		66
62	my @newcons;	67	my $unused_bytes = 0;
63	my @pool;	68	my $unused_last = time;
64		69
65	# one "execution thread"	70	sub unused_bandwidth {
66	sub handler {	71	$unused_bytes += $_[0];
67	while () {	72	if ($unused_last < $NOW - 30 && $unused_bytes / ($NOW - $unused_last) > 50000) {
68	if (@newcons) {	73	$unused_last = $NOW;
69	eval {	74	$unused_bytes = 0;
70	conn->new(@{pop @newcons})->handle;	75	$queue_file->force_wake_next;
71	};	76	slog 1, "forced filetransfer due to unused bandwidth";
72	slog 1, "$@" if $@ && !ref $@;
73
74	$httpevent->broadcast; # only for testing, but doesn't matter much
75
76	$connections->up;
77	} else {
78	last if @pool >= $MAX_POOL;
79	push @pool, $Coro::current;
80	schedule;
81	}
82	}	77	}
83	}	78	}
84		79
85	sub listen_on {	80	sub listen_on {
86	my $listen = $_[0];	81	my $listen = $_[0];
…		…
90	# the "main thread"	85	# the "main thread"
91	async {	86	async {
92	slog 1, "accepting connections";	87	slog 1, "accepting connections";
93	while () {	88	while () {
94	$connections->down;	89	$connections->down;
95	push @newcons, [$listen->accept];	90	my @conn = $listen->accept;
96	#slog 3, "accepted @$connections ".scalar(@pool);	91	#slog 3, "accepted @$connections ".scalar(@pool);
97	if (@pool) {	92
98	(pop @pool)->ready;	93	async_pool {
99	} else {	94	eval {
100	async \&handler;	95	conn->new (@conn)->handle;
101	}	96	};
		97	slog 1, "$@" if $@ && !ref $@;
102		98
		99	$httpevent->broadcast; # only for testing, but doesn't matter much
		100
		101	$connections->up;
		102	}
103	}	103	}
104	};	104	};
105	}	105	}
106		106
107	my $http_port = new Coro::Socket	107	my $http_port = new Coro::Socket
108	LocalAddr => $SERVER_HOST,	108	LocalAddr => $SERVER_HOST,
109	LocalPort => $SERVER_PORT,	109	LocalPort => $SERVER_PORT,
110	ReuseAddr => 1,	110	ReuseAddr => 1,
111	Listen => 50,	111	Listen => 50,
112	or die "unable to start server";	112	or die "unable to start server";
113		113
114	listen_on $http_port;	114	listen_on $http_port;
115		115
116	if ($SERVER_PORT2) {	116	if ($SERVER_PORT2) {
117	my $http_port = new Coro::Socket	117	my $http_port = new Coro::Socket
118	LocalAddr => $SERVER_HOST,	118	LocalAddr => $SERVER_HOST,
119	LocalPort => $SERVER_PORT2,	119	LocalPort => $SERVER_PORT2,
120	ReuseAddr => 1,	120	ReuseAddr => 1,
121	Listen => 50,	121	Listen => 50,
122	or die "unable to start server";	122	or die "unable to start server";
123		123
124	listen_on $http_port;	124	listen_on $http_port;
125	}	125	}
126		126
127	package conn;	127	package conn;
		128
		129	use strict;
		130	use bytes;
128		131
129	use Socket;	132	use Socket;
130	use HTTP::Date;	133	use HTTP::Date;
131	use Convert::Scalar 'weaken';	134	use Convert::Scalar 'weaken';
132	use Linux::AIO;	135	use IO::AIO;
133		136
134	Linux::AIO::min_parallel $::AIO_PARALLEL;	137	IO::AIO::min_parallel $::AIO_PARALLEL;
135		138
136	Event->io(fd => Linux::AIO::poll_fileno,	139	our $AIO_WATCHER = EV::io IO::AIO::poll_fileno, EV::READ, \&IO::AIO::poll_cb;
137	poll => 'r', async => 1,
138	cb => \&Linux::AIO::poll_cb);
139		140
140	our %conn; # $conn{ip}{self} => connobj	141	our %conn; # $conn{ip}{self} => connobj
141	our %uri; # $uri{ip}{uri}{self}	142	our %uri; # $uri{ip}{uri}{self}
142	our %blocked;	143	our %blocked;
143	our %mimetype;	144	our %mimetype;
144		145
145	sub read_mimetypes {	146	sub read_mimetypes {
146	local *M;
147	if (open M, "<mime_types") {	147	if (open my $fh, "<mime_types") {
148	while (<M>) {	148	while (<$fh>) {
149	if (/^([^#]\S+)\t+(\S+)$/) {	149	if (/^([^#]\S+)\t+(\S+)$/) {
150	$mimetype{lc $1} = $2;	150	$mimetype{lc $1} = $2;
151	}	151	}
152	}	152	}
153	} else {	153	} else {
…		…
161	my $class = shift;	161	my $class = shift;
162	my $fh = shift;	162	my $fh = shift;
163	my $peername = shift;	163	my $peername = shift;
164	my $self = bless { fh => $fh }, $class;	164	my $self = bless { fh => $fh }, $class;
165	my (undef, $iaddr) = unpack_sockaddr_in $peername	165	my (undef, $iaddr) = unpack_sockaddr_in $peername
166	or $self->err(500, "unable to decode peername");	166	or $self->err (500, "unable to decode peername");
167		167
168	$self->{remote_addr} =	168	$self->{remote_addr} =
169	$self->{remote_id} = inet_ntoa $iaddr;	169	$self->{remote_id} = inet_ntoa $iaddr;
170		170
171	$self->{time} = $::NOW;	171	$self->{time} = $::NOW;
172		172
173	weaken ($Coro::current->{conn} = $self);	173	weaken ($Coro::current->{conn} = $self);
174		174
175	$::conns++;	175	++$::conns;
176	$::maxconns = $::conns if $::conns > $::maxconns;	176	$::maxconns = $::conns if $::conns > $::maxconns;
177		177
178	$self;	178	$self
179	}	179	}
180		180
181	sub DESTROY {	181	sub DESTROY {
182	#my $self = shift;	182	my $self = shift;
		183
183	$::conns--;	184	--$::conns;
184	}	185	}
		186
		187	sub prune_cache {
		188	my $hash = $_[0];
		189
		190	for (keys %$hash) {
		191	if (ref $hash->{$_} eq HASH::) {
		192	prune_cache($hash->{$_});
		193	unless (scalar keys %{$hash->{$_}}) {
		194	delete $hash->{$_};
		195	}
		196	}
		197	}
		198	}
		199
		200	sub prune_caches {
		201	prune_cache \%conn;
		202	prune_cache \%uri;
		203
		204	for (keys %blocked) {
		205	delete $blocked{$_} unless $blocked{$_}[0] > $::NOW;
		206	}
		207	}
		208
		209	our $PRUNE_WATCHER = EV::timer 60, 60, \&prune_caches;
185		210
186	sub slog {	211	sub slog {
187	my $self = shift;	212	my $self = shift;
188	main::slog($_[0], "$self->{remote_id}> $_[1]");	213	main::slog($_[0], "$self->{remote_id}> $_[1]");
189	}	214	}
…		…
219	$hdr->{"Content-Length"} = length $content;	244	$hdr->{"Content-Length"} = length $content;
220	$GZ = sprintf "GZ%02d", 100 - 100*((length $content) / $orig);	245	$GZ = sprintf "GZ%02d", 100 - 100*((length $content) / $orig);
221	}	246	}
222		247
223	$res .= "Date: $HTTP_NOW\015\012";	248	$res .= "Date: $HTTP_NOW\015\012";
		249	$res .= "Server: $::NAME\015\012";
224		250
225	while (my ($h, $v) = each %$hdr) {	251	while (my ($h, $v) = each %$hdr) {
226	$res .= "$h: $v\015\012"	252	$res .= "$h: $v\015\012"
227	}	253	}
228	$res .= "\015\012";	254	$res .= "\015\012";
…		…
249	$hdr->{"Content-Type"} = "text/plain";	275	$hdr->{"Content-Type"} = "text/plain";
250	$hdr->{"Content-Length"} = length $content;	276	$hdr->{"Content-Length"} = length $content;
251	}	277	}
252	$hdr->{"Connection"} = "close";	278	$hdr->{"Connection"} = "close";
253		279
254	$self->response($code, $msg, $hdr, $content);	280	$self->response ($code, $msg, $hdr, $content);
255		281
256	die bless {}, err::;	282	die bless {}, err::
257	}	283	}
258		284
259	sub handle {	285	sub handle {
260	my $self = shift;	286	my $self = shift;
261	my $fh = $self->{fh};	287	my $fh = $self->{fh};
262		288
263	my $host;	289	my $host;
264		290
265	$fh->timeout($::REQ_TIMEOUT);	291	$fh->timeout($::REQ_TIMEOUT);
266	while() {	292	while () {
267	$self->{reqs}++;	293	$self->{reqs}++;
268		294
269	# read request and parse first line	295	# read request and parse first line
270	my $req = $fh->readline("\015\012\015\012");	296	my $req = $fh->readline("\015\012\015\012");
271		297
…		…
380	# uri => path mapping	406	# uri => path mapping
381	sub map_uri {	407	sub map_uri {
382	my $self = shift;	408	my $self = shift;
383	my $host = $self->{server_name};	409	my $host = $self->{server_name};
384	my $uri = $self->{uri};	410	my $uri = $self->{uri};
		411
		412	$host =~ /[\/\\]/
		413	and $self->err(400, "bad request");
385		414
386	# some massaging, also makes it more secure	415	# some massaging, also makes it more secure
387	$uri =~ s/%([0-9a-fA-F][0-9a-fA-F])/chr hex $1/ge;	416	$uri =~ s/%([0-9a-fA-F][0-9a-fA-F])/chr hex $1/ge;
388	$uri =~ s%//+%/%g;	417	$uri =~ s%//+%/%g;
389	$uri =~ s%/\.(?=/\|$)%%g;	418	$uri =~ s%/\.(?=/\|$)%%g;
…		…
433		462
434	if ($self->{name} =~ s%^/internal/([^/]+)%%) {	463	if ($self->{name} =~ s%^/internal/([^/]+)%%) {
435	if ($::internal{$1}) {	464	if ($::internal{$1}) {
436	$::internal{$1}->($self);	465	$::internal{$1}->($self);
437	} else {	466	} else {
438	$self->err(404, "not found");	467	$self->err (404, "not found");
439	}	468	}
440	} else {	469	} else {
441		470
442	stat $path	471	Coro::AIO::aio_stat $path
443	or $self->err(404, "not found");	472	and $self->err (404, "not found");
444		473
445	$self->{stat} = [stat _];	474	$self->{stat} = [stat _];
446		475
447	# idiotic netscape sends idiotic headers AGAIN	476	# idiotic netscape sends idiotic headers AGAIN
448	my $ims = $self->{h}{"if-modified-since"} =~ /^([^;]+)/	477	my $ims = $self->{h}{"if-modified-since"} =~ /^([^;]+)/
…		…
451	if (-d _ && -r _) {	480	if (-d _ && -r _) {
452	# directory	481	# directory
453	if ($path !~ /\/$/) {	482	if ($path !~ /\/$/) {
454	# create a redirect to get the trailing "/"	483	# create a redirect to get the trailing "/"
455	# we don't try to avoid the :80	484	# we don't try to avoid the :80
456	$self->err(301, "moved permanently", { Location => "http://".$self->server_hostport."$self->{uri}/" });	485	$self->err (301, "moved permanently", { Location => "http://".$self->server_hostport."$self->{uri}/" });
457	} else {	486	} else {
458	$ims < $self->{stat}[9]	487	$ims < $self->{stat}[9]
459	or $self->err(304, "not modified");	488	or $self->err (304, "not modified");
460		489
461	if (-r "$path/index.html") {	490	if (-r "$path/index.html") {
462	# replace directory "size" by index.html filesize	491	# replace directory "size" by index.html filesize
463	$self->{stat} = [stat ($self->{path} .= "/index.html")];	492	$self->{stat} = [stat ($self->{path} .= "/index.html")];
464	$self->handle_file($queue_index, $tbf_top);	493	$self->handle_file ($queue_index, $tbf_top);
465	} else {	494	} else {
466	$self->handle_dir;	495	$self->handle_dir;
467	}	496	}
468	}	497	}
469	} elsif (-f _ && -r _) {	498	} elsif (-f _ && -r _) {
470	-x _ and $self->err(403, "forbidden");	499	-x _ and $self->err (403, "forbidden");
471		500
472	if (keys %{$conn{$self->{remote_id}}} > $::MAX_TRANSFERS_IP) {	501	if (keys %{$conn{$self->{remote_id}}} > $::MAX_TRANSFERS_IP) {
473	my $timeout = $::NOW + 10;	502	my $timeout = $::NOW + 10;
474	while (keys %{$conn{$self->{remote_id}}} > $::MAX_TRANSFERS_IP) {	503	while (keys %{$conn{$self->{remote_id}}} > $::MAX_TRANSFERS_IP) {
475	if ($timeout < $::NOW) {	504	if ($timeout < $::NOW) {
…		…
478	$httpevent->wait;	507	$httpevent->wait;
479	}	508	}
480	}	509	}
481	}	510	}
482		511
483	$self->handle_file($queue_file, $tbf_top);	512	$self->handle_file ($queue_file, $tbf_top);
484	} else {	513	} else {
485	$self->err(404, "not found");	514	$self->err (404, "not found");
486	}	515	}
487	}	516	}
488	}	517	}
489		518
490	sub handle_dir {	519	sub handle_dir {
491	my $self = shift;	520	my $self = shift;
492	my $idx = $self->diridx;	521	my $idx = $self->diridx;
493		522
494	$self->response(200, "ok",	523	$self->response (200, "ok",
495	{	524	{
496	"Content-Type" => "text/html",	525	"Content-Type" => "text/html; charset=utf-8",
497	"Content-Length" => length $idx,	526	"Content-Length" => length $idx,
498	"Last-Modified" => time2str ($self->{stat}[9]),	527	"Last-Modified" => time2str ($self->{stat}[9]),
499	},	528	},
500	$idx);	529	$idx);
501	}	530	}
502		531
503	sub handle_file {	532	sub handle_file {
504	my ($self, $queue, $tbf) = @_;	533	my ($self, $queue, $tbf) = @_;
505	my $length = $self->{stat}[7];	534	my $length = $self->{stat}[7];
506	my $hdr = {	535	my $hdr = {
507	"Last-Modified" => time2str ((stat _)[9]),	536	"Last-Modified" => time2str ((stat _)[9]),
		537	"Accept-Ranges" => "bytes",
508	};	538	};
509		539
510	my @code = (200, "ok");	540	my @code = (200, "ok");
511	my ($l, $h);	541	my ($l, $h);
512		542
513	if ($self->{h}{range} =~ /^bytes=(.*)$/) {	543	if ($self->{h}{range} =~ /^bytes=(.*)$/i) {
514	for (split /,/, $1) {	544	for (split /,/, $1) {
515	if (/^-(\d+)$/) {	545	if (/^-(\d+)$/) {
516	($l, $h) = ($length - $1, $length - 1);	546	($l, $h) = ($length - $1, $length - 1);
517	} elsif (/^(\d+)-(\d*)$/) {	547	} elsif (/^(\d+)-(\d*)$/) {
518	($l, $h) = ($1, ($2 ne "" \|\| $2 >= $length) ? $2 : $length - 1);	548	($l, $h) = ($1, ($2 ne "" \|\| $2 >= $length) ? $2 : $length - 1);
…		…
522	}	552	}
523	goto satisfiable if $l >= 0 && $l < $length && $h >= 0 && $h >= $l;	553	goto satisfiable if $l >= 0 && $l < $length && $h >= 0 && $h >= $l;
524	}	554	}
525	$hdr->{"Content-Range"} = "bytes */$length";	555	$hdr->{"Content-Range"} = "bytes */$length";
526	$hdr->{"Content-Length"} = $length;	556	$hdr->{"Content-Length"} = $length;
527	$self->err(416, "not satisfiable", $hdr, "");	557	$self->err (416, "not satisfiable", $hdr, "");
528		558
529	satisfiable:	559	satisfiable:
530	# check for segmented downloads	560	# check for segmented downloads
531	if ($l && $::NO_SEGMENTED) {	561	if ($l && $::NO_SEGMENTED) {
532	my $timeout = $::NOW + 15;	562	my $timeout = $::NOW + 15;
533	while (keys %{$uri{$self->{remote_id}}{$self->{uri}}} > 1) {	563	while (keys %{$uri{$self->{remote_id}}{$self->{uri}}} > 1) {
534	if ($timeout <= $::NOW) {	564	if ($timeout <= $::NOW) {
535	$self->block($::BLOCKTIME, "segmented downloads are forbidden");	565	$self->block ($::BLOCKTIME, "segmented downloads are forbidden");
536	#$self->err_segmented_download;	566	#$self->err_segmented_download;
537	} else {	567	} else {
538	$httpevent->wait;	568	$httpevent->wait;
539	}	569	}
540	}	570	}
…		…
551		581
552	$self->{path} =~ /\.([^.]+)$/;	582	$self->{path} =~ /\.([^.]+)$/;
553	$hdr->{"Content-Type"} = $mimetype{lc $1} \|\| "application/octet-stream";	583	$hdr->{"Content-Type"} = $mimetype{lc $1} \|\| "application/octet-stream";
554	$hdr->{"Content-Length"} = $length;	584	$hdr->{"Content-Length"} = $length;
555		585
556	$self->response(@code, $hdr, "");	586	$self->response (@code, $hdr, "");
557		587
558	if ($self->{method} eq "GET") {	588	if ($self->{method} eq "GET") {
559	$self->{time} = $::NOW;	589	$self->{time} = $::NOW;
		590	$self->{written} = 0;
560		591
561	my $current = $Coro::current;
562
563	my ($fh, $buf, $r);
564
565	open $fh, "<", $self->{path}	592	open my $fh, "<", $self->{path}
566	or die "$self->{path}: late open failure ($!)";	593	or die "$self->{path}: late open failure ($!)";
567		594
568	$h -= $l - 1;	595	$h -= $l - 1;
569		596
570	if (0) { # !AIO
571	if ($l) {
572	sysseek $fh, $l, 0;
573	}
574	}
575
576	my $transfer = $queue->start_transfer($h);	597	my $transfer = $queue->start_transfer ($h);
577	my $locked;	598	my $locked;
578	my $bufsize = $::WAIT_BUFSIZE; # initial buffer size	599	my $bufsize = $::WAIT_BUFSIZE; # initial buffer size
579		600
580	while ($h > 0) {	601	while ($h > 0) {
581	unless ($locked) {	602	unless ($locked) {
582	if ($locked \|\|= $transfer->try($::WAIT_INTERVAL)) {	603	if ($locked \|\|= $transfer->try ($::WAIT_INTERVAL)) {
583	$bufsize = $::BUFSIZE;	604	$bufsize = $::BUFSIZE;
584	$self->{time} = $::NOW;	605	$self->{time} = $::NOW;
		606	$self->{written} = 0;
585	}	607	}
586	}	608	}
587		609
588	if ($blocked{$self->{remote_id}}) {	610	if ($blocked{$self->{remote_id}}) {
589	$self->{h}{connection} = "close";	611	$self->{h}{connection} = "close";
590	die bless {}, err::;	612	die bless {}, err::;
591	}	613	}
592		614
593	if (0) { # !AIO	615	Coro::AIO::aio_read $fh, $l, ($h > $bufsize ? $bufsize : $h), my $buf, 0
594	sysread $fh, $buf, $h > $bufsize ? $bufsize : $h
595	or last;	616	or last;
596	} else {
597	aio_read($fh, $l, ($h > $bufsize ? $bufsize : $h),
598	$buf, 0, sub {
599	$r = $_[0];
600	Coro::ready($current);
601	});
602	&Coro::schedule;
603	last unless $r;
604	}
605		617
606	$tbf->request(length $buf);	618	$tbf->request (length $buf);
607	my $w = syswrite $self->{fh}, $buf	619	my $w = $self->{fh}->syswrite ($buf)
608	or last;	620	or last;
609	$::written += $w;	621	$::written += $w;
610	$self->{written} += $w;	622	$self->{written} += $w;
611	$l += $r;	623	$l += $w;
612	}	624	}
613		625
614	close $fh;	626	close $fh;
615	}	627	}
616	}	628	}
617		629
618	1;	630	1
		631

Diff Legend

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

Comparing cvsroot/Coro/myhttpd/httpd.pl (file contents): Revision 1.67 by root, Sun May 19 21:00:47 2002 UTC vs. Revision 1.89 by root, Sun Jan 24 20:44:34 2010 UTC

Diff Legend

Comparing cvsroot/Coro/myhttpd/httpd.pl (file contents):
Revision 1.67 by root, Sun May 19 21:00:47 2002 UTC vs.
Revision 1.89 by root, Sun Jan 24 20:44:34 2010 UTC