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

Comparing cvsroot/Coro/myhttpd/httpd.pl (file contents):
Revision 1.80 by root, Fri Dec 1 04:18:32 2006 UTC vs.
Revision 1.90 by root, Wed Jan 27 20:06:57 2010 UTC

…		…
1	use Coro;	1	use Coro;
2	use Coro::Semaphore;	2	use Coro::Semaphore;
		3	use Coro::SemaphoreSet;
3	use Coro::Event;	4	use Coro::EV;
4	use Coro::Socket;	5	use Coro::Socket;
5	use Coro::Signal;	6	use Coro::Signal;
6	use Coro::AIO ();	7	use Coro::AIO ();
7		8
		9	use Fcntl;
8	use HTTP::Date;	10	use HTTP::Date;
9	use POSIX ();	11	use POSIX ();
10		12
11	use Compress::Zlib ();	13	use Compress::Zlib ();
12		14
13	no utf8;	15	use common::sense;
14	use bytes;
15		16
16	# at least on my machine, this thingy serves files	17	# at least on my machine, this thingy serves files
17	# quite a bit faster than apache, ;)	18	# quite a bit faster than apache, ;)
18	# and quite a bit slower than thttpd :(	19	# and quite a bit slower than thttpd :(
19		20
20	$SIG{PIPE} = 'IGNORE';	21	$SIG{PIPE} = 'IGNORE';
21		22
22	our $accesslog;	23	our $accesslog;
23	our $errorlog;	24	our $errorlog;
		25	our @listen_sockets;
24		26
25	our $NOW;	27	our $NOW;
26	our $HTTP_NOW;	28	our $HTTP_NOW;
27		29
28	our $ERROR_LOG;	30	our $ERROR_LOG;
29	our $ACCESS_LOG;	31	our $ACCESS_LOG;
		32	our $TRANSFER_LOCK = new Coro::SemaphoreSet; # lock to be acquired per ip
30		33
31	Event->timer(interval => 1, hard => 1, cb => sub {	34	our $update_time = EV::periodic 0, 1, undef, sub {
32	$NOW = time;	35	$NOW = time;
33	$HTTP_NOW = time2str $NOW;	36	$HTTP_NOW = time2str $NOW;
34	})->now;	37	};
		38	$update_time->invoke;
35		39
36	if ($ERROR_LOG) {	40	if ($ERROR_LOG) {
37	use IO::Handle;	41	use IO::Handle;
38	open $errorlog, ">>$ERROR_LOG"	42	open $errorlog, ">>$ERROR_LOG"
39	or die "$ERROR_LOG: $!";	43	or die "$ERROR_LOG: $!";
53	my $NOW = (POSIX::strftime "%Y-%m-%d %H:%M:%S", gmtime $::NOW);	57	my $NOW = (POSIX::strftime "%Y-%m-%d %H:%M:%S", gmtime $::NOW);
54	printf "$NOW: $format\n", @_;	58	printf "$NOW: $format\n", @_;
55	printf $errorlog "$NOW: $format\n", @_ if $errorlog;	59	printf $errorlog "$NOW: $format\n", @_ if $errorlog;
56	}	60	}
57		61
58	our $connections = new Coro::Semaphore $MAX_CONNECTS \|\| 250;	62	our $connections = new Coro::Semaphore $::MAX_CONNECTS \|\| 250;
59	our $httpevent = new Coro::Signal;	63	our $httpevent = new Coro::Signal;
60		64
61	our $queue_file = new transferqueue $MAX_TRANSFERS;	65	our $queue_file = new transferqueue $::MAX_TRANSFERS;
62	our $queue_index = new transferqueue 10;	66	our $queue_index = new transferqueue 10;
63		67
64	our $tbf_top = new tbf rate => $TBF_RATE \|\| 100000;	68	our $tbf_top = new tbf rate => $::TBF_RATE \|\| 100000;
65		69
66	my $unused_bytes = 0;	70	my $unused_bytes = 0;
67	my $unused_last = time;	71	my $unused_last = time;
68		72
69	sub unused_bandwidth {	73	sub unused_bandwidth {
…		…
74	$queue_file->force_wake_next;	78	$queue_file->force_wake_next;
75	slog 1, "forced filetransfer due to unused bandwidth";	79	slog 1, "forced filetransfer due to unused bandwidth";
76	}	80	}
77	}	81	}
78		82
79	my @newcons;
80	my @pool;
81
82	# one "execution thread"
83	sub handler {
84	while () {
85	if (@newcons) {
86	eval {
87	conn->new(@{pop @newcons})->handle;
88	};
89	slog 1, "$@" if $@ && !ref $@;
90
91	$httpevent->broadcast; # only for testing, but doesn't matter much
92
93	$connections->up;
94	} else {
95	last if @pool >= $MAX_POOL;
96	push @pool, $Coro::current;
97	schedule;
98	}
99	}
100	}
101
102	sub listen_on {	83	sub listen_on {
103	my $listen = $_[0];	84	my $listen = $_[0];
104		85
105	push @listen_sockets, $listen;	86	push @listen_sockets, $listen;
106		87
107	# the "main thread"	88	# the "main thread"
108	async {	89	async {
109	slog 1, "accepting connections";	90	slog 1, "accepting connections";
110	while () {	91	while () {
111	$connections->down;	92	$connections->down;
112	push @newcons, [$listen->accept];	93	my @conn = $listen->accept;
113	#slog 3, "accepted @$connections ".scalar(@pool);	94	#slog 3, "accepted @$connections ".scalar(@pool);
114	if (@pool) {	95
115	(pop @pool)->ready;	96	async_pool {
116	} else {	97	eval {
117	async \&handler;	98	conn->new (@conn)->handle;
		99	};
		100	slog 1, "$@" if $@ && !ref $@;
		101
		102	$httpevent->broadcast; # only for testing, but doesn't matter much
		103
		104	$connections->up;
118	}	105	}
119	}	106	}
120	};	107	};
121	}	108	}
122		109
123	my $http_port = new Coro::Socket	110	my $http_port = new Coro::Socket
124	LocalAddr => $SERVER_HOST,	111	LocalAddr => $::SERVER_HOST,
125	LocalPort => $SERVER_PORT,	112	LocalPort => $::SERVER_PORT,
126	ReuseAddr => 1,	113	ReuseAddr => 1,
127	Listen => 50,	114	Listen => 50,
128	or die "unable to start server";	115	or die "unable to start server";
129		116
130	listen_on $http_port;	117	listen_on $http_port;
131		118
132	if ($SERVER_PORT2) {	119	if ($::SERVER_PORT2) {
133	my $http_port = new Coro::Socket	120	my $http_port = new Coro::Socket
134	LocalAddr => $SERVER_HOST,	121	LocalAddr => $::SERVER_HOST,
135	LocalPort => $SERVER_PORT2,	122	LocalPort => $::SERVER_PORT2,
136	ReuseAddr => 1,	123	ReuseAddr => 1,
137	Listen => 50,	124	Listen => 50,
138	or die "unable to start server";	125	or die "unable to start server";
139		126
140	listen_on $http_port;	127	listen_on $http_port;
141	}	128	}
142		129
143	package conn;	130	package conn;
144		131
145	use strict;	132	use common::sense;
146	use bytes;
147		133
148	use Socket;	134	use Socket;
149	use HTTP::Date;	135	use HTTP::Date;
150	use Convert::Scalar 'weaken';	136	use Convert::Scalar 'weaken';
151	use IO::AIO;	137	use IO::AIO;
152		138
153	IO::AIO::min_parallel $::AIO_PARALLEL;	139	IO::AIO::min_parallel $::AIO_PARALLEL;
154		140
155	Event->io (fd => IO::AIO::poll_fileno,	141	our $AIO_WATCHER = EV::io IO::AIO::poll_fileno, EV::READ, \&IO::AIO::poll_cb;
156	poll => 'r', async => 1,
157	cb => \&IO::AIO::poll_cb);
158		142
159	our %conn; # $conn{ip}{self} => connobj	143	our %conn; # $conn{ip}{self} => connobj
160	our %uri; # $uri{ip}{uri}{self}	144	our %uri; # $uri{ip}{uri}{self}
161	our %blocked;	145	our %blocked;
162	our %mimetype;	146	our %mimetype;
163		147
164	sub read_mimetypes {	148	sub read_mimetypes {
165	local *M;
166	if (open M, "<mime_types") {	149	if (open my $fh, "<mime_types") {
167	while (<M>) {	150	while (<$fh>) {
168	if (/^([^#]\S+)\t+(\S+)$/) {	151	if (/^([^#]\S+)\t+(\S+)$/) {
169	$mimetype{lc $1} = $2;	152	$mimetype{lc $1} = $2;
170	}	153	}
171	}	154	}
172	} else {	155	} else {
…		…
180	my $class = shift;	163	my $class = shift;
181	my $fh = shift;	164	my $fh = shift;
182	my $peername = shift;	165	my $peername = shift;
183	my $self = bless { fh => $fh }, $class;	166	my $self = bless { fh => $fh }, $class;
184	my (undef, $iaddr) = unpack_sockaddr_in $peername	167	my (undef, $iaddr) = unpack_sockaddr_in $peername
185	or $self->err(500, "unable to decode peername");	168	or $self->err (500, "unable to decode peername");
186		169
187	$self->{remote_addr} =	170	$self->{remote_addr} =
188	$self->{remote_id} = inet_ntoa $iaddr;	171	$self->{remote_id} = inet_ntoa $iaddr;
189		172
190	$self->{time} = $::NOW;	173	$self->{time} = $::NOW;
191		174
192	weaken ($Coro::current->{conn} = $self);	175	weaken ($Coro::current->{conn} = $self);
193		176
194	$::conns++;	177	++$::conns;
195	$::maxconns = $::conns if $::conns > $::maxconns;	178	$::maxconns = $::conns if $::conns > $::maxconns;
196		179
197	$self;	180	$self
198	}	181	}
199		182
200	sub DESTROY {	183	sub DESTROY {
201	#my $self = shift;	184	my $self = shift;
		185
202	$::conns--;	186	--$::conns;
203	}	187	}
204		188
205	sub prune_cache {	189	sub prune_cache {
206	my $hash = $_[0];	190	my $hash = $_[0];
207		191
…		…
222	for (keys %blocked) {	206	for (keys %blocked) {
223	delete $blocked{$_} unless $blocked{$_}[0] > $::NOW;	207	delete $blocked{$_} unless $blocked{$_}[0] > $::NOW;
224	}	208	}
225	}	209	}
226		210
227	Event->timer(interval => 60, cb => \&prune_caches);	211	our $PRUNE_WATCHER = EV::timer 60, 60, \&prune_caches;
228		212
229	sub slog {	213	sub slog {
230	my $self = shift;	214	my $self = shift;
231	main::slog($_[0], "$self->{remote_id}> $_[1]");	215	main::slog($_[0], "$self->{remote_id}> $_[1]");
232	}	216	}
…		…
293	$hdr->{"Content-Type"} = "text/plain";	277	$hdr->{"Content-Type"} = "text/plain";
294	$hdr->{"Content-Length"} = length $content;	278	$hdr->{"Content-Length"} = length $content;
295	}	279	}
296	$hdr->{"Connection"} = "close";	280	$hdr->{"Connection"} = "close";
297		281
298	$self->response($code, $msg, $hdr, $content);	282	$self->response ($code, $msg, $hdr, $content);
299		283
300	die bless {}, err::;	284	die bless {}, err::
301	}	285	}
302		286
303	sub handle {	287	sub handle {
304	my $self = shift;	288	my $self = shift;
305	my $fh = $self->{fh};	289	my $fh = $self->{fh};
306		290
307	my $host;	291	my $host;
308		292
309	$fh->timeout($::REQ_TIMEOUT);	293	$fh->timeout($::REQ_TIMEOUT);
310	while() {	294	while () {
311	$self->{reqs}++;	295	$self->{reqs}++;
312		296
313	# read request and parse first line	297	# read request and parse first line
314	my $req = $fh->readline("\015\012\015\012");	298	my $req = $fh->readline("\015\012\015\012");
315		299
…		…
424	# uri => path mapping	408	# uri => path mapping
425	sub map_uri {	409	sub map_uri {
426	my $self = shift;	410	my $self = shift;
427	my $host = $self->{server_name};	411	my $host = $self->{server_name};
428	my $uri = $self->{uri};	412	my $uri = $self->{uri};
		413
		414	$host =~ /[\/\\]/
		415	and $self->err(400, "bad request");
429		416
430	# some massaging, also makes it more secure	417	# some massaging, also makes it more secure
431	$uri =~ s/%([0-9a-fA-F][0-9a-fA-F])/chr hex $1/ge;	418	$uri =~ s/%([0-9a-fA-F][0-9a-fA-F])/chr hex $1/ge;
432	$uri =~ s%//+%/%g;	419	$uri =~ s%//+%/%g;
433	$uri =~ s%/\.(?=/\|$)%%g;	420	$uri =~ s%/\.(?=/\|$)%%g;
…		…
477		464
478	if ($self->{name} =~ s%^/internal/([^/]+)%%) {	465	if ($self->{name} =~ s%^/internal/([^/]+)%%) {
479	if ($::internal{$1}) {	466	if ($::internal{$1}) {
480	$::internal{$1}->($self);	467	$::internal{$1}->($self);
481	} else {	468	} else {
482	$self->err(404, "not found");	469	$self->err (404, "not found");
483	}	470	}
484	} else {	471	} else {
485		472
486	stat $path	473	Coro::AIO::aio_stat $path
487	or $self->err(404, "not found");	474	and $self->err (404, "not found");
488		475
489	$self->{stat} = [stat _];	476	$self->{stat} = [stat _];
490		477
491	# idiotic netscape sends idiotic headers AGAIN	478	# idiotic netscape sends idiotic headers AGAIN
492	my $ims = $self->{h}{"if-modified-since"} =~ /^([^;]+)/	479	my $ims = $self->{h}{"if-modified-since"} =~ /^([^;]+)/
…		…
495	if (-d _ && -r _) {	482	if (-d _ && -r _) {
496	# directory	483	# directory
497	if ($path !~ /\/$/) {	484	if ($path !~ /\/$/) {
498	# create a redirect to get the trailing "/"	485	# create a redirect to get the trailing "/"
499	# we don't try to avoid the :80	486	# we don't try to avoid the :80
500	$self->err(301, "moved permanently", { Location => "http://".$self->server_hostport."$self->{uri}/" });	487	$self->err (301, "moved permanently", { Location => "http://".$self->server_hostport."$self->{uri}/" });
501	} else {	488	} else {
502	$ims < $self->{stat}[9]	489	$ims < $self->{stat}[9]
503	or $self->err(304, "not modified");	490	or $self->err (304, "not modified");
504		491
505	if (-r "$path/index.html") {	492	if (-r "$path/index.html") {
506	# replace directory "size" by index.html filesize	493	# replace directory "size" by index.html filesize
507	$self->{stat} = [stat ($self->{path} .= "/index.html")];	494	$self->{stat} = [stat ($self->{path} .= "/index.html")];
508	$self->handle_file($queue_index, $tbf_top);	495	$self->handle_file ($queue_index, $tbf_top);
509	} else {	496	} else {
510	$self->handle_dir;	497	$self->handle_dir;
511	}	498	}
512	}	499	}
513	} elsif (-f _ && -r _) {	500	} elsif (-f _ && -r _) {
514	-x _ and $self->err(403, "forbidden");	501	-x _ and $self->err (403, "forbidden");
515		502
516	if (keys %{$conn{$self->{remote_id}}} > $::MAX_TRANSFERS_IP) {	503	if (keys %{$conn{$self->{remote_id}}} > $::MAX_TRANSFERS_IP) {
517	my $timeout = $::NOW + 10;	504	my $timeout = $::NOW + 10;
518	while (keys %{$conn{$self->{remote_id}}} > $::MAX_TRANSFERS_IP) {	505	while (keys %{$conn{$self->{remote_id}}} > $::MAX_TRANSFERS_IP) {
519	if ($timeout < $::NOW) {	506	if ($timeout < $::NOW) {
…		…
522	$httpevent->wait;	509	$httpevent->wait;
523	}	510	}
524	}	511	}
525	}	512	}
526		513
527	$self->handle_file($queue_file, $tbf_top);	514	$self->handle_file ($queue_file, $tbf_top);
528	} else {	515	} else {
529	$self->err(404, "not found");	516	$self->err (404, "not found");
530	}	517	}
531	}	518	}
532	}	519	}
533		520
534	sub handle_dir {	521	sub handle_dir {
535	my $self = shift;	522	my $self = shift;
536	my $idx = $self->diridx;	523	my $idx = $self->diridx;
537		524
538	$self->response(200, "ok",	525	$self->response (200, "ok",
539	{	526	{
540	"Content-Type" => "text/html; charset=utf-8",	527	"Content-Type" => "text/html; charset=utf-8",
541	"Content-Length" => length $idx,	528	"Content-Length" => length $idx,
542	"Last-Modified" => time2str ($self->{stat}[9]),	529	"Last-Modified" => time2str ($self->{stat}[9]),
543	},	530	},
…		…
553	};	540	};
554		541
555	my @code = (200, "ok");	542	my @code = (200, "ok");
556	my ($l, $h);	543	my ($l, $h);
557		544
558	if ($self->{h}{range} =~ /^bytes=(.*)$/) {	545	if ($self->{h}{range} =~ /^bytes=(.*)$/i) {
559	for (split /,/, $1) {	546	for (split /,/, $1) {
560	if (/^-(\d+)$/) {	547	if (/^-(\d+)$/) {
561	($l, $h) = ($length - $1, $length - 1);	548	($l, $h) = ($length - $1, $length - 1);
562	} elsif (/^(\d+)-(\d*)$/) {	549	} elsif (/^(\d+)-(\d*)$/) {
563	($l, $h) = ($1, ($2 ne "" \|\| $2 >= $length) ? $2 : $length - 1);	550	($l, $h) = ($1, ($2 ne "" \|\| $2 >= $length) ? $2 : $length - 1);
…		…
567	}	554	}
568	goto satisfiable if $l >= 0 && $l < $length && $h >= 0 && $h >= $l;	555	goto satisfiable if $l >= 0 && $l < $length && $h >= 0 && $h >= $l;
569	}	556	}
570	$hdr->{"Content-Range"} = "bytes */$length";	557	$hdr->{"Content-Range"} = "bytes */$length";
571	$hdr->{"Content-Length"} = $length;	558	$hdr->{"Content-Length"} = $length;
572	$self->err(416, "not satisfiable", $hdr, "");	559	$self->err (416, "not satisfiable", $hdr, "");
573		560
574	satisfiable:	561	satisfiable:
575	# check for segmented downloads	562	# check for segmented downloads
576	if ($l && $::NO_SEGMENTED) {	563	if ($l && $::NO_SEGMENTED) {
577	my $timeout = $::NOW + 15;	564	my $timeout = $::NOW + 15;
578	while (keys %{$uri{$self->{remote_id}}{$self->{uri}}} > 1) {	565	while (keys %{$uri{$self->{remote_id}}{$self->{uri}}} > 1) {
579	if ($timeout <= $::NOW) {	566	if ($timeout <= $::NOW) {
580	$self->block($::BLOCKTIME, "segmented downloads are forbidden");	567	$self->block ($::BLOCKTIME, "segmented downloads are forbidden");
581	#$self->err_segmented_download;	568	#$self->err_segmented_download;
582	} else {	569	} else {
583	$httpevent->wait;	570	$httpevent->wait;
584	}	571	}
585	}	572	}
…		…
596		583
597	$self->{path} =~ /\.([^.]+)$/;	584	$self->{path} =~ /\.([^.]+)$/;
598	$hdr->{"Content-Type"} = $mimetype{lc $1} \|\| "application/octet-stream";	585	$hdr->{"Content-Type"} = $mimetype{lc $1} \|\| "application/octet-stream";
599	$hdr->{"Content-Length"} = $length;	586	$hdr->{"Content-Length"} = $length;
600		587
601	$self->response(@code, $hdr, "");	588	$self->response (@code, $hdr, "");
602		589
603	if ($self->{method} eq "GET") {	590	if ($self->{method} eq "GET") {
604	$self->{time} = $::NOW;	591	$self->{time} = $::NOW;
605	$self->{written} = 0;	592	$self->{written} = 0;
606		593
607	my $fh;	594	my $fh = Coro::AIO::aio_open $self->{path}, Fcntl::O_RDONLY, 0
608
609	open $fh, "<", $self->{path}
610	or die "$self->{path}: late open failure ($!)";	595	or die "$self->{path}: late open failure ($!)";
611		596
612	$h -= $l - 1;	597	$h -= $l - 1;
613		598
614	if (0) { # !AIO
615	if ($l) {
616	sysseek $fh, $l, 0;
617	}
618	}
619
620	my $transfer = $queue->start_transfer($h);	599	my $transfer = $queue->start_transfer ($h);
621	my $locked;	600	my $locked;
622	my $bufsize = $::WAIT_BUFSIZE; # initial buffer size	601	my $bufsize = $::WAIT_BUFSIZE; # initial buffer size
623		602
624	while ($h > 0) {	603	while ($h > 0) {
		604	Coro::cede;
		605	my $transfer_lock = $TRANSFER_LOCK->guard ($self->{remote_id});
		606
625	unless ($locked) {	607	unless ($locked) {
626	if ($locked \|\|= $transfer->try($::WAIT_INTERVAL)) {	608	if ($locked \|\|= $transfer->try ($::WAIT_INTERVAL)) {
627	$bufsize = $::BUFSIZE;	609	$bufsize = $::BUFSIZE;
628	$self->{time} = $::NOW;	610	$self->{time} = $::NOW;
629	$self->{written} = 0;	611	$self->{written} = 0;
630	}	612	}
631	}	613	}
…		…
637		619
638	Coro::AIO::aio_read $fh, $l, ($h > $bufsize ? $bufsize : $h), my $buf, 0	620	Coro::AIO::aio_read $fh, $l, ($h > $bufsize ? $bufsize : $h), my $buf, 0
639	or last;	621	or last;
640		622
641	$tbf->request (length $buf);	623	$tbf->request (length $buf);
642	my $w = syswrite $self->{fh}, $buf	624	my $w = $self->{fh}->syswrite ($buf)
643	or last;	625	or last;
644	$::written += $w;	626	$::written += $w;
645	$self->{written} += $w;	627	$self->{written} += $w;
646	$l += $w;	628	$l += $w;
647	}	629	}

Diff Legend

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

Comparing cvsroot/Coro/myhttpd/httpd.pl (file contents): Revision 1.80 by root, Fri Dec 1 04:18:32 2006 UTC vs. Revision 1.90 by root, Wed Jan 27 20:06:57 2010 UTC

Diff Legend

Comparing cvsroot/Coro/myhttpd/httpd.pl (file contents):
Revision 1.80 by root, Fri Dec 1 04:18:32 2006 UTC vs.
Revision 1.90 by root, Wed Jan 27 20:06:57 2010 UTC