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

Comparing Coro/myhttpd/httpd.pl (file contents):
Revision 1.33 by root, Wed Aug 29 01:40:44 2001 UTC vs.
Revision 1.40 by root, Mon Sep 3 00:06:06 2001 UTC

…		…
5		5
6	use HTTP::Date;	6	use HTTP::Date;
7		7
8	no utf8;	8	no utf8;
9	use bytes;	9	use bytes;
10
11	our @wait_time = (); # used to calculcate avg. waiting time
12	our $wait_time_length = 25;
13		10
14	# at least on my machine, this thingy serves files	11	# at least on my machine, this thingy serves files
15	# quite a bit faster than apache, ;)	12	# quite a bit faster than apache, ;)
16	# and quite a bit slower than thttpd :(	13	# and quite a bit slower than thttpd :(
17		14
…		…
31	my $format = shift;	28	my $format = shift;
32	printf "---: $format\n", @_;	29	printf "---: $format\n", @_;
33	}	30	}
34		31
35	our $connections = new Coro::Semaphore $MAX_CONNECTS \|\| 250;	32	our $connections = new Coro::Semaphore $MAX_CONNECTS \|\| 250;
36	our $transfers = new Coro::Semaphore $MAX_TRANSFER \|\| 50;	33
		34	our $wait_factor = 0.95;
		35
		36	our @transfers = (
		37	[(new Coro::Semaphore $MAX_TRANSFERS_SMALL \|\| 50), 1],
		38	[(new Coro::Semaphore $MAX_TRANSFERS_LARGE \|\| 50), 1],
		39	);
37		40
38	my @newcons;	41	my @newcons;
39	my @pool;	42	my @pool;
40		43
41	# one "execution thread"	44	# one "execution thread"
42	sub handler {	45	sub handler {
43	while () {	46	while () {
44	my $new = pop @newcons;
45	if ($new) {	47	if (@newcons) {
46	eval {	48	eval {
47	conn->new(@$new)->handle;	49	conn->new(@{pop @newcons})->handle;
48	};	50	};
49	slog 1, "$@" if $@ && !ref $@;	51	slog 1, "$@" if $@ && !ref $@;
50	$connections->up;	52	$connections->up;
51	} else {	53	} else {
52	last if @pool >= $MAX_POOL;	54	last if @pool >= $MAX_POOL;
…		…
54	schedule;	56	schedule;
55	}	57	}
56	}	58	}
57	}	59	}
58		60
		61	sub listen_on {
		62	my $listen = $_[0];
		63
		64	push @listen_sockets, $listen;
		65
		66	# the "main thread"
		67	async {
		68	slog 1, "accepting connections";
		69	while () {
		70	$connections->down;
		71	push @newcons, [$listen->accept];
		72	#slog 3, "accepted @$connections ".scalar(@pool);
		73	if (@pool) {
		74	(pop @pool)->ready;
		75	} else {
		76	async \&handler;
		77	}
		78
		79	}
		80	};
		81	}
		82
59	my $http_port = new Coro::Socket	83	my $http_port = new Coro::Socket
60	LocalAddr => $SERVER_HOST,	84	LocalAddr => $SERVER_HOST,
61	LocalPort => $SERVER_PORT,	85	LocalPort => $SERVER_PORT,
62	ReuseAddr => 1,	86	ReuseAddr => 1,
63	Listen => 50,	87	Listen => 50,
64	or die "unable to start server";	88	or die "unable to start server";
65		89
66	push @listen_sockets, $http_port;	90	listen_on $http_port;
		91
		92	my $http_port = new Coro::Socket
		93	LocalAddr => $SERVER_HOST,
		94	LocalPort => $SERVER_PORT2,
		95	ReuseAddr => 1,
		96	Listen => 50,
		97	or die "unable to start server";
		98
		99	listen_on $http_port;
67		100
68	our $NOW;	101	our $NOW;
69	our $HTTP_NOW;	102	our $HTTP_NOW;
70		103
71	Event->timer(interval => 1, hard => 1, cb => sub {	104	Event->timer(interval => 1, hard => 1, cb => sub {
72	$NOW = time;	105	$NOW = time;
73	$HTTP_NOW = time2str $NOW;	106	$HTTP_NOW = time2str $NOW;
74	});	107	})->now;
75
76	# the "main thread"
77	async {
78	slog 1, "accepting connections";
79	while () {
80	$connections->down;
81	push @newcons, [$http_port->accept];
82	#slog 3, "accepted @$connections ".scalar(@pool);
83	if (@pool) {
84	(pop @pool)->ready;
85	} else {
86	async \&handler;
87	}
88
89	}
90	};
91		108
92	package conn;	109	package conn;
93		110
94	use Socket;	111	use Socket;
95	use HTTP::Date;	112	use HTTP::Date;
96	use Convert::Scalar 'weaken';	113	use Convert::Scalar 'weaken';
97	use Linux::AIO;	114	use Linux::AIO;
98		115
99	Linux::AIO::min_parallel $::AIO_PARALLEL;	116	Linux::AIO::min_parallel $::AIO_PARALLEL;
100
101	my $aio_requests = new Coro::Semaphore $::AIO_PARALLEL * 4;
102		117
103	Event->io(fd => Linux::AIO::poll_fileno,	118	Event->io(fd => Linux::AIO::poll_fileno,
104	poll => 'r', async => 1,	119	poll => 'r', async => 1,
105	cb => \&Linux::AIO::poll_cb);	120	cb => \&Linux::AIO::poll_cb);
106		121
…		…
133	or $self->err(500, "unable to decode peername");	148	or $self->err(500, "unable to decode peername");
134		149
135	$self->{remote_addr} = inet_ntoa $iaddr;	150	$self->{remote_addr} = inet_ntoa $iaddr;
136	$self->{time} = $::NOW;	151	$self->{time} = $::NOW;
137		152
138	# enter ourselves into various lists
139	weaken ($conn{$self->{remote_addr}}{$self*1} = $self);
140
141	$::conns++;	153	$::conns++;
142		154
143	$self;	155	$self;
144	}	156	}
145		157
146	sub DESTROY {	158	sub DESTROY {
147	my $self = shift;	159	my $self = shift;
148
149	$::conns--;	160	$::conns--;
150
151	$self->eoconn;	161	$self->eoconn;
152	delete $conn{$self->{remote_addr}}{$self*1};
153	}	162	}
154		163
155	# end of connection	164	# end of connection
156	sub eoconn {	165	sub eoconn {
157	my $self = shift;	166	my $self = shift;
		167
		168	# clean up hints
		169	delete $conn{$self->{remote_id}}{$self*1};
158	delete $uri{$self->{remote_addr}}{$self->{uri}}{$self*1};	170	delete $uri{$self->{remote_id}}{$self->{uri}}{$self*1};
159	}	171	}
160		172
161	sub slog {	173	sub slog {
162	my $self = shift;	174	my $self = shift;
163	main::slog($_[0], ($self->{remote_id} \|\| $self->{remote_addr}) ."> $_[1]");	175	main::slog($_[0], ($self->{remote_id} \|\| $self->{remote_addr}) ."> $_[1]");
…		…
190	sub err {	202	sub err {
191	my $self = shift;	203	my $self = shift;
192	my ($code, $msg, $hdr, $content) = @_;	204	my ($code, $msg, $hdr, $content) = @_;
193		205
194	unless (defined $content) {	206	unless (defined $content) {
195	$content = "$code $msg";	207	$content = "$code $msg\n";
196	$hdr->{"Content-Type"} = "text/plain";	208	$hdr->{"Content-Type"} = "text/plain";
197	$hdr->{"Content-Length"} = length $content;	209	$hdr->{"Content-Length"} = length $content;
198	}	210	}
199	$hdr->{"Connection"} = "close";	211	$hdr->{"Connection"} = "close";
200		212
…		…
225	}	237	}
226		238
227	$self->{h} = {};	239	$self->{h} = {};
228		240
229	$fh->timeout($::RES_TIMEOUT);	241	$fh->timeout($::RES_TIMEOUT);
230	my $ip = $self->{remote_addr};
231
232	if ($blocked{$ip}) {
233	$self->err_blocked($blocked{$ip})
234	if $blocked{$ip} > $::NOW;
235
236	delete $blocked{$ip};
237	}
238
239	if (%{$conn{$ip}} > $::MAX_CONN_IP) {
240	my $delay = 120;
241	while (%{$conn{$ip}} > $::MAX_CONN_IP) {
242	if ($delay <= 0) {
243	$self->slog(2, "blocked ip $ip");
244	$self->err_blocked;
245	} else {
246	Coro::Event::do_timer(after => 3);
247	$delay -= 3;
248	}
249	}
250	}
251		242
252	$req =~ /^(?:\015\012)?	243	$req =~ /^(?:\015\012)?
253	(GET\|HEAD) \040+	244	(GET\|HEAD) \040+
254	([^\040]+) \040+	245	([^\040]+) \040+
255	HTTP\/([0-9]+\.[0-9]+)	246	HTTP\/([0-9]+\.[0-9]+)
…		…
280		271
281	$self->{h}{$h} = substr $v, 1	272	$self->{h}{$h} = substr $v, 1
282	while ($h, $v) = each %hdr;	273	while ($h, $v) = each %hdr;
283	}	274	}
284		275
		276	# remote id should be unique per user
		277	my $id = $self->{remote_addr};
		278
		279	if (exists $self->{h}{"client-ip"}) {
		280	$id .= "[".$self->{h}{"client-ip"}."]";
		281	} elsif (exists $self->{h}{"x-forwarded-for"}) {
		282	$id .= "[".$self->{h}{"x-forwarded-for"}."]";
		283	}
		284
		285	$self->{remote_id} = $id;
		286
		287	if ($blocked{$id}) {
		288	$self->err_blocked($blocked{$id})
		289	if $blocked{$id} > $::NOW;
		290
		291	delete $blocked{$id};
		292	}
		293
		294	if (%{$conn{$id}} >= $::MAX_CONN_IP) {
		295	my $delay = $::PER_TIMEOUT + 15;
		296	while (%{$conn{$id}} >= $::MAX_CONN_IP) {
		297	if ($delay <= 0) {
		298	$self->slog(2, "blocked ip $id");
		299	$self->err_blocked;
		300	} else {
		301	Coro::Event::do_timer(after => 4); $delay -= 4;
		302	}
		303	}
		304	}
		305
285	# find out server name and port	306	# find out server name and port
286	if ($self->{uri} =~ s/^http:\/\/([^\/?#]*)//i) {	307	if ($self->{uri} =~ s/^http:\/\/([^\/?#]*)//i) {
287	$host = $1;	308	$host = $1;
288	} else {	309	} else {
289	$host = $self->{h}{host};	310	$host = $self->{h}{host};
…		…
298	$host = inet_ntoa $host;	319	$host = inet_ntoa $host;
299	}	320	}
300		321
301	$self->{server_name} = $host;	322	$self->{server_name} = $host;
302		323
303	# remote id should be unique per user	324	# enter ourselves into various lists
304	$self->{remote_id} = $self->{remote_addr};	325	weaken ($conn{$id}{$self*1} = $self);
305
306	if (exists $self->{h}{"client-ip"}) {
307	$self->{remote_id} .= "[".$self->{h}{"client-ip"}."]";
308	} elsif (exists $self->{h}{"x-forwarded-for"}) {
309	$self->{remote_id} .= "[".$self->{h}{"x-forwarded-for"}."]";
310	}
311
312	weaken ($uri{$self->{remote_addr}}{$self->{uri}}{$self*1} = $self);	326	weaken ($uri{$id}{$self->{uri}}{$self*1} = $self);
313		327
314	eval {	328	eval {
315	$self->map_uri;	329	$self->map_uri;
316	$self->respond;	330	$self->respond;
317	};	331	};
…		…
426	$idx);	440	$idx);
427	}	441	}
428		442
429	sub handle_file {	443	sub handle_file {
430	my $self = shift;	444	my $self = shift;
431	my $length = -s _;	445	my $length = $self->{stat}[7];
		446	my $queue = $::transfers[$length >= $::TRANSFER_SMALL];
432	my $hdr = {	447	my $hdr = {
433	"Last-Modified" => time2str ((stat _)[9]),	448	"Last-Modified" => time2str ((stat _)[9]),
434	};	449	};
435		450
436	my @code = (200, "ok");	451	my @code = (200, "ok");
…		…
448	}	463	}
449	goto satisfiable if $l >= 0 && $l < $length && $h >= 0 && $h >= $l;	464	goto satisfiable if $l >= 0 && $l < $length && $h >= 0 && $h >= $l;
450	}	465	}
451	$hdr->{"Content-Range"} = "bytes */$length";	466	$hdr->{"Content-Range"} = "bytes */$length";
452	$hdr->{"Content-Length"} = $length;	467	$hdr->{"Content-Length"} = $length;
453	$self->slog(9, "not satisfiable($self->{h}{range}\|".$self->{h}{"user-agent"}.")");
454	$self->err(416, "not satisfiable", $hdr, "");	468	$self->err(416, "not satisfiable", $hdr, "");
455		469
456	satisfiable:	470	satisfiable:
457	# check for segmented downloads	471	# check for segmented downloads
458	if ($l && $::NO_SEGMENTED) {	472	if ($l && $::NO_SEGMENTED) {
459	my $delay = 180;	473	my $delay = $::PER_TIMEOUT + 15;
460	while (%{$uri{$self->{remote_addr}}{$self->{uri}}} > 1) {	474	while (%{$uri{$self->{remote_id}}{$self->{uri}}} > 1) {
461	if ($delay <= 0) {	475	if ($delay <= 0) {
462	$self->err_segmented_download;	476	$self->err_segmented_download;
463	} else {	477	} else {
464	Coro::Event::do_timer(after => 3); $delay -= 3;	478	Coro::Event::do_timer(after => 4); $delay -= 4;
465	}	479	}
466	}	480	}
467	}	481	}
468		482
469	$hdr->{"Content-Range"} = "bytes $l-$h/$length";	483	$hdr->{"Content-Range"} = "bytes $l-$h/$length";
…		…
482	$self->response(@code, $hdr, "");	496	$self->response(@code, $hdr, "");
483		497
484	if ($self->{method} eq "GET") {	498	if ($self->{method} eq "GET") {
485	$self->{time} = $::NOW;	499	$self->{time} = $::NOW;
486		500
		501	my $fudge = $queue->[0]->waiters;
		502	$fudge = $fudge ? ($fudge+1)/$fudge : 1;
		503
		504	$queue->[1] *= $fudge;
487	my $transfer = $::transfers->guard;	505	my $transfer = $queue->[0]->guard;
		506
		507	if ($fudge != 1) {
		508	$queue->[1] /= $fudge;
		509	$queue->[1] = $queue->[1] * $::wait_factor
		510	+ ($::NOW - $self->{time}) * (1 - $::wait_factor);
		511	}
		512	$self->{time} = $::NOW;
		513
488	$self->{fh}->writable or return;	514	$self->{fh}->writable or return;
489
490	push @::wait_time, $::NOW - $self->{time};
491	shift @::wait_time if @wait_time > $wait_time_length;
492	$self->{time} = $::NOW;
493		515
494	my ($fh, $buf, $r);	516	my ($fh, $buf, $r);
495	my $current = $Coro::current;	517	my $current = $Coro::current;
496	open $fh, "<", $self->{path}	518	open $fh, "<", $self->{path}
497	or die "$self->{path}: late open failure ($!)";	519	or die "$self->{path}: late open failure ($!)";
…		…
507	while ($h > 0) {	529	while ($h > 0) {
508	if (0) {	530	if (0) {
509	sysread $fh, $buf, $h > $::BUFSIZE ? $::BUFSIZE : $h	531	sysread $fh, $buf, $h > $::BUFSIZE ? $::BUFSIZE : $h
510	or last;	532	or last;
511	} else {	533	} else {
512	undef $buf;
513	$aio_requests->down;
514	aio_read($fh, $l, ($h > $::BUFSIZE ? $::BUFSIZE : $h),	534	aio_read($fh, $l, ($h > $::BUFSIZE ? $::BUFSIZE : $h),
515	$buf, 0, sub {	535	$buf, 0, sub {
516	$r = $_[0];	536	$r = $_[0];
517	$current->ready;	537	Coro::ready($current);
518	});	538	});
519	&Coro::schedule;	539	&Coro::schedule;
520	$aio_requests->up;
521	last unless $r;	540	last unless $r;
522	}	541	}
523	my $w = $self->{fh}->syswrite($buf)	542	my $w = syswrite $self->{fh}, $buf
524	or last;	543	or last;
525	$::written += $w;	544	$::written += $w;
526	$self->{written} += $w;	545	$self->{written} += $w;
527	$l += $r;	546	$l += $r;
528	}	547	}

Diff Legend

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

Comparing Coro/myhttpd/httpd.pl (file contents): Revision 1.33 by root, Wed Aug 29 01:40:44 2001 UTC vs. Revision 1.40 by root, Mon Sep 3 00:06:06 2001 UTC

Diff Legend

Comparing Coro/myhttpd/httpd.pl (file contents):
Revision 1.33 by root, Wed Aug 29 01:40:44 2001 UTC vs.
Revision 1.40 by root, Mon Sep 3 00:06:06 2001 UTC