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

Comparing Coro/myhttpd/httpd.pl (file contents):
Revision 1.43 by root, Wed Sep 12 20:29:43 2001 UTC vs.
Revision 1.51 by root, Thu Nov 29 01:50:41 2001 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		6
6	use HTTP::Date;	7	use HTTP::Date;
		8	use POSIX ();
7		9
8	no utf8;	10	no utf8;
9	use bytes;	11	use bytes;
10		12
11	# at least on my machine, this thingy serves files	13	# at least on my machine, this thingy serves files
28	my $format = shift;	30	my $format = shift;
29	printf "---: $format\n", @_;	31	printf "---: $format\n", @_;
30	}	32	}
31		33
32	our $connections = new Coro::Semaphore $MAX_CONNECTS \|\| 250;	34	our $connections = new Coro::Semaphore $MAX_CONNECTS \|\| 250;
		35	our $httpevent = new Coro::Signal;
33		36
34	our $wait_factor = 0.95;	37	our $wait_factor = 0.95;
35		38
36	our @transfers = (	39	our @transfers = (
37	[(new Coro::Semaphore $MAX_TRANSFERS_SMALL \|\| 50), 1],	40	(new transferqueue $MAX_TRANSFERS_SMALL),
38	[(new Coro::Semaphore $MAX_TRANSFERS_LARGE \|\| 50), 1],	41	(new transferqueue $MAX_TRANSFERS_LARGE),
39	);	42	);
40		43
41	my @newcons;	44	my @newcons;
42	my @pool;	45	my @pool;
43		46
…		…
147	my $peername = shift;	150	my $peername = shift;
148	my $self = bless { fh => $fh }, $class;	151	my $self = bless { fh => $fh }, $class;
149	my (undef, $iaddr) = unpack_sockaddr_in $peername	152	my (undef, $iaddr) = unpack_sockaddr_in $peername
150	or $self->err(500, "unable to decode peername");	153	or $self->err(500, "unable to decode peername");
151		154
		155	$self->{remote_addr} =
152	$self->{remote_addr} = inet_ntoa $iaddr;	156	$self->{remote_id} = inet_ntoa $iaddr;
153	$self->{time} = $::NOW;	157	$self->{time} = $::NOW;
		158
		159	weaken ($Coro::current->{conn} = $self);
154		160
155	$::conns++;	161	$::conns++;
156		162
157	$self;	163	$self;
158	}	164	}
…		…
168	my $self = shift;	174	my $self = shift;
169		175
170	# clean up hints	176	# clean up hints
171	delete $conn{$self->{remote_id}}{$self*1};	177	delete $conn{$self->{remote_id}}{$self*1};
172	delete $uri{$self->{remote_id}}{$self->{uri}}{$self*1};	178	delete $uri{$self->{remote_id}}{$self->{uri}}{$self*1};
		179
		180	$httpevent->broadcast;
173	}	181	}
174		182
175	sub slog {	183	sub slog {
176	my $self = shift;	184	my $self = shift;
177	main::slog($_[0], ($self->{remote_id} \|\| $self->{remote_addr}) ."> $_[1]");	185	main::slog($_[0], "$self->{remote_id}> $_[1]");
178	}	186	}
179		187
180	sub response {	188	sub response {
181	my ($self, $code, $msg, $hdr, $content) = @_;	189	my ($self, $code, $msg, $hdr, $content) = @_;
182	my $res = "HTTP/1.1 $code $msg\015\012";	190	my $res = "HTTP/1.1 $code $msg\015\012";
183		191
184	$self->{h}{connection} = "close" if $hdr->{Connection} =~ /close/;	192	if (exists $hdr->{Connection}) {
		193	if ($hdr->{Connection} =~ /close/) {
		194	$self->{h}{connection} = "close"
		195	}
		196	} else {
		197	if ($self->{version} < 1.1) {
		198	if ($self->{h}{connection} =~ /keep-alive/i) {
		199	$hdr->{Connection} = "Keep-Alive";
		200	} else {
		201	$self->{h}{connection} = "close"
		202	}
		203	}
		204	}
185		205
186	$res .= "Date: $HTTP_NOW\015\012";	206	$res .= "Date: $HTTP_NOW\015\012";
187		207
188	while (my ($h, $v) = each %$hdr) {	208	while (my ($h, $v) = each %$hdr) {
189	$res .= "$h: $v\015\012"	209	$res .= "$h: $v\015\012"
190	}	210	}
191	$res .= "\015\012";	211	$res .= "\015\012";
192		212
193	$res .= $content if defined $content and $self->{method} ne "HEAD";	213	$res .= $content if defined $content and $self->{method} ne "HEAD";
194		214
195	my $log = "$self->{remote_addr} \"$self->{uri}\" $code ".$hdr->{"Content-Length"}." \"$self->{h}{referer}\"\n";	215	my $log = (POSIX::strftime "%Y-%m-%d %H:%M:%S", gmtime $NOW).
		216	" $self->{remote_id} \"$self->{uri}\" $code ".$hdr->{"Content-Length"}.
		217	" \"$self->{h}{referer}\"\n";
196		218
197	print $accesslog $log if $accesslog;	219	print $accesslog $log if $accesslog;
198	print STDERR $log;	220	print STDERR $log;
199		221
200	$self->{written} +=	222	$self->{written} +=
…		…
292		314
293	delete $blocked{$id};	315	delete $blocked{$id};
294	}	316	}
295		317
296	if (%{$conn{$id}} >= $::MAX_CONN_IP) {	318	if (%{$conn{$id}} >= $::MAX_CONN_IP) {
297	my $delay = $::PER_TIMEOUT + 15;	319	my $delay = $::PER_TIMEOUT + $::NOW + 15;
298	while (%{$conn{$id}} >= $::MAX_CONN_IP) {	320	while (%{$conn{$id}} >= $::MAX_CONN_IP) {
299	if ($delay <= 0) {	321	if ($delay < $::NOW) {
300	$self->slog(2, "blocked ip $id");	322	$self->slog(2, "blocked ip $id");
301	$self->err_blocked;	323	$self->err_blocked;
302	} else {	324	} else {
303	Coro::Event::do_timer(after => 4); $delay -= 4;	325	$httpevent->wait;
304	}	326	}
305	}	327	}
306	}	328	}
307		329
308	# find out server name and port	330	# find out server name and port
…		…
334		356
335	$self->eoconn;	357	$self->eoconn;
336		358
337	die if $@ && !ref $@;	359	die if $@ && !ref $@;
338		360
339	last if $self->{h}{connection} =~ /close/ \|\| $self->{version} < 1.1;	361	last if $self->{h}{connection} =~ /close/;
		362
		363	$httpevent->broadcast;
340		364
341	$fh->timeout($::PER_TIMEOUT);	365	$fh->timeout($::PER_TIMEOUT);
342	}	366	}
343	}	367	}
344		368
…		…
394		418
395	sub respond {	419	sub respond {
396	my $self = shift;	420	my $self = shift;
397	my $path = $self->{path};	421	my $path = $self->{path};
398		422
399	stat $path	423	if ($self->{name} =~ s%^/internal/([^/]+)%%) {
400	or $self->err(404, "not found");	424	if ($::internal{$1}) {
401		425	$::internal{$1}->($self);
402	$self->{stat} = [stat _];
403
404	# idiotic netscape sends idiotic headers AGAIN
405	my $ims = $self->{h}{"if-modified-since"} =~ /^([^;]+)/
406	? str2time $1 : 0;
407
408	if (-d _ && -r _) {
409	# directory
410	if ($path !~ /\/$/) {
411	# create a redirect to get the trailing "/"
412	# we don't try to avoid the :80
413	$self->err(301, "moved permanently", { Location => "http://".$self->server_hostport."$self->{uri}/" });
414	} else {	426	} else {
415	$ims < $self->{stat}[9]	427	$self->err(404, "not found");
		428	}
		429	} else {
		430
		431	stat $path
416	or $self->err(304, "not modified");	432	or $self->err(404, "not found");
417		433
418	if (-r "$path/index.html") {	434	$self->{stat} = [stat _];
419	$self->{path} .= "/index.html";	435
420	$self->handle_file;	436	# idiotic netscape sends idiotic headers AGAIN
		437	my $ims = $self->{h}{"if-modified-since"} =~ /^([^;]+)/
		438	? str2time $1 : 0;
		439
		440	if (-d _ && -r _) {
		441	# directory
		442	if ($path !~ /\/$/) {
		443	# create a redirect to get the trailing "/"
		444	# we don't try to avoid the :80
		445	$self->err(301, "moved permanently", { Location => "http://".$self->server_hostport."$self->{uri}/" });
421	} else {	446	} else {
		447	$ims < $self->{stat}[9]
		448	or $self->err(304, "not modified");
		449
		450	if (-r "$path/index.html") {
		451	# replace directory "size" by index.html filesize
		452	$self->{stat}[7] = (stat ($self->{path} .= "/index.html"))[7];
		453	$self->handle_file;
		454	} else {
422	$self->handle_dir;	455	$self->handle_dir;
423	}	456	}
424	}	457	}
425	} elsif (-f _ && -r _) {	458	} elsif (-f _ && -r _) {
426	-x _ and $self->err(403, "forbidden");	459	-x _ and $self->err(403, "forbidden");
427	$self->handle_file;	460	$self->handle_file;
428	} else {	461	} else {
429	$self->err(404, "not found");	462	$self->err(404, "not found");
		463	}
430	}	464	}
431	}	465	}
432		466
433	sub handle_dir {	467	sub handle_dir {
434	my $self = shift;	468	my $self = shift;
…		…
436		470
437	$self->response(200, "ok",	471	$self->response(200, "ok",
438	{	472	{
439	"Content-Type" => "text/html",	473	"Content-Type" => "text/html",
440	"Content-Length" => length $idx,	474	"Content-Length" => length $idx,
		475	#d# directories change all the time, so X-
		476	"X-Last-Modified" => time2str ((stat _)[9]),
441	},	477	},
442	$idx);	478	$idx);
443	}	479	}
444		480
445	sub handle_file {	481	sub handle_file {
…		…
470	$self->err(416, "not satisfiable", $hdr, "");	506	$self->err(416, "not satisfiable", $hdr, "");
471		507
472	satisfiable:	508	satisfiable:
473	# check for segmented downloads	509	# check for segmented downloads
474	if ($l && $::NO_SEGMENTED) {	510	if ($l && $::NO_SEGMENTED) {
475	my $delay = $::PER_TIMEOUT + 15;	511	my $delay = $::NOW + $::PER_TIMEOUT + 15;
476	while (%{$uri{$self->{remote_id}}{$self->{uri}}} > 1) {	512	while (%{$uri{$self->{remote_id}}{$self->{uri}}} > 1) {
477	if ($delay <= 0) {	513	if ($delay <= $::NOW) {
478	$self->err_segmented_download;	514	$self->err_segmented_download;
479	} else {	515	} else {
480	Coro::Event::do_timer(after => 4); $delay -= 4;	516	$httpevent->wait;
481	}	517	}
482	}	518	}
483	}	519	}
484		520
485	$hdr->{"Content-Range"} = "bytes $l-$h/$length";	521	$hdr->{"Content-Range"} = "bytes $l-$h/$length";
…		…
498	$self->response(@code, $hdr, "");	534	$self->response(@code, $hdr, "");
499		535
500	if ($self->{method} eq "GET") {	536	if ($self->{method} eq "GET") {
501	$self->{time} = $::NOW;	537	$self->{time} = $::NOW;
502		538
503	my $fudge = $queue->[0]->waiters;	539	my $current = $Coro::current;
504	$fudge = $fudge ? ($fudge+1)/$fudge : 1;
505
506	$queue->[1] *= $fudge;
507	my $transfer = $queue->[0]->guard;
508
509	if ($fudge != 1) {
510	$queue->[1] /= $fudge;
511	$queue->[1] = $queue->[1] * $::wait_factor
512	+ ($::NOW - $self->{time}) * (1 - $::wait_factor);
513	}
514	$self->{time} = $::NOW;
515
516	$self->{fh}->writable or return;
517		540
518	my ($fh, $buf, $r);	541	my ($fh, $buf, $r);
519	my $current = $Coro::current;	542
520	open $fh, "<", $self->{path}	543	open $fh, "<", $self->{path}
521	or die "$self->{path}: late open failure ($!)";	544	or die "$self->{path}: late open failure ($!)";
522		545
523	$h -= $l - 1;	546	$h -= $l - 1;
524		547
525	if (0) {	548	if (0) { # !AIO
526	if ($l) {	549	if ($l) {
527	sysseek $fh, $l, 0;	550	sysseek $fh, $l, 0;
528	}	551	}
529	}	552	}
		553
		554	my $transfer = $queue->start_transfer;
		555	my $locked;
		556	my $bufsize = $::WAIT_BUFSIZE; # initial buffer size
530		557
531	while ($h > 0) {	558	while ($h > 0) {
		559	unless ($locked) {
		560	if ($locked \|\|= $transfer->try($::WAIT_INTERVAL)) {
		561	$bufsize = $::BUFSIZE;
		562	$self->{time} = $::NOW;
		563	}
		564	}
		565
532	if (0) {	566	if (0) { # !AIO
533	sysread $fh, $buf, $h > $::BUFSIZE ? $::BUFSIZE : $h	567	sysread $fh, $buf, $h > $bufsize ? $bufsize : $h
534	or last;	568	or last;
535	} else {	569	} else {
536	aio_read($fh, $l, ($h > $::BUFSIZE ? $::BUFSIZE : $h),	570	aio_read($fh, $l, ($h > $bufsize ? $bufsize : $h),
537	$buf, 0, sub {	571	$buf, 0, sub {
538	$r = $_[0];	572	$r = $_[0];
539	Coro::ready($current);	573	Coro::ready($current);
540	});	574	});
541	&Coro::schedule;	575	&Coro::schedule;

Diff Legend

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

Comparing Coro/myhttpd/httpd.pl (file contents): Revision 1.43 by root, Wed Sep 12 20:29:43 2001 UTC vs. Revision 1.51 by root, Thu Nov 29 01:50:41 2001 UTC

Diff Legend

Comparing Coro/myhttpd/httpd.pl (file contents):
Revision 1.43 by root, Wed Sep 12 20:29:43 2001 UTC vs.
Revision 1.51 by root, Thu Nov 29 01:50:41 2001 UTC