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

Comparing cvsroot/Coro/myhttpd/httpd.pl (file contents):
Revision 1.36 by root, Sun Sep 2 00:54:00 2001 UTC vs.
Revision 1.49 by root, Wed Nov 28 03:39:46 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 Coro::Semaphore $MAX_TRANSFERS_SMALL),
38	[(new Coro::Semaphore $MAX_TRANSFERS_LARGE \|\| 50), 1],	41	(new Coro::Semaphore $MAX_TRANSFERS_LARGE),
39	);	42	);
40		43
41	my @newcons;	44	my @newcons;
42	my @pool;	45	my @pool;
43		46
44	# one "execution thread"	47	# one "execution thread"
45	sub handler {	48	sub handler {
46	while () {	49	while () {
47	my $new = pop @newcons;
48	if ($new) {	50	if (@newcons) {
49	eval {	51	eval {
50	conn->new(@$new)->handle;	52	conn->new(@{pop @newcons})->handle;
51	};	53	};
52	slog 1, "$@" if $@ && !ref $@;	54	slog 1, "$@" if $@ && !ref $@;
53	$connections->up;	55	$connections->up;
54	} else {	56	} else {
55	last if @pool >= $MAX_POOL;	57	last if @pool >= $MAX_POOL;
…		…
57	schedule;	59	schedule;
58	}	60	}
59	}	61	}
60	}	62	}
61		63
		64	sub listen_on {
		65	my $listen = $_[0];
		66
		67	push @listen_sockets, $listen;
		68
		69	# the "main thread"
		70	async {
		71	slog 1, "accepting connections";
		72	while () {
		73	$connections->down;
		74	push @newcons, [$listen->accept];
		75	#slog 3, "accepted @$connections ".scalar(@pool);
		76	if (@pool) {
		77	(pop @pool)->ready;
		78	} else {
		79	async \&handler;
		80	}
		81
		82	}
		83	};
		84	}
		85
62	my $http_port = new Coro::Socket	86	my $http_port = new Coro::Socket
63	LocalAddr => $SERVER_HOST,	87	LocalAddr => $SERVER_HOST,
64	LocalPort => $SERVER_PORT,	88	LocalPort => $SERVER_PORT,
65	ReuseAddr => 1,	89	ReuseAddr => 1,
66	Listen => 50,	90	Listen => 50,
67	or die "unable to start server";	91	or die "unable to start server";
68		92
69	push @listen_sockets, $http_port;	93	listen_on $http_port;
		94
		95	if ($SERVER_PORT2) {
		96	my $http_port = new Coro::Socket
		97	LocalAddr => $SERVER_HOST,
		98	LocalPort => $SERVER_PORT2,
		99	ReuseAddr => 1,
		100	Listen => 50,
		101	or die "unable to start server";
		102
		103	listen_on $http_port;
		104	}
70		105
71	our $NOW;	106	our $NOW;
72	our $HTTP_NOW;	107	our $HTTP_NOW;
73		108
74	Event->timer(interval => 1, hard => 1, cb => sub {	109	Event->timer(interval => 1, hard => 1, cb => sub {
75	$NOW = time;	110	$NOW = time;
76	$HTTP_NOW = time2str $NOW;	111	$HTTP_NOW = time2str $NOW;
77	})->now;	112	})->now;
78		113
79	# the "main thread"
80	async {
81	slog 1, "accepting connections";
82	while () {
83	$connections->down;
84	push @newcons, [$http_port->accept];
85	#slog 3, "accepted @$connections ".scalar(@pool);
86	if (@pool) {
87	(pop @pool)->ready;
88	} else {
89	async \&handler;
90	}
91
92	}
93	};
94
95	package conn;	114	package conn;
96		115
97	use Socket;	116	use Socket;
98	use HTTP::Date;	117	use HTTP::Date;
99	use Convert::Scalar 'weaken';	118	use Convert::Scalar 'weaken';
100	use Linux::AIO;	119	use Linux::AIO;
101		120
102	Linux::AIO::min_parallel $::AIO_PARALLEL;	121	Linux::AIO::min_parallel $::AIO_PARALLEL;
103
104	my $aio_requests = new Coro::Semaphore $::AIO_PARALLEL * 4;
105		122
106	Event->io(fd => Linux::AIO::poll_fileno,	123	Event->io(fd => Linux::AIO::poll_fileno,
107	poll => 'r', async => 1,	124	poll => 'r', async => 1,
108	cb => \&Linux::AIO::poll_cb);	125	cb => \&Linux::AIO::poll_cb);
109		126
…		…
127		144
128	read_mimetypes;	145	read_mimetypes;
129		146
130	sub new {	147	sub new {
131	my $class = shift;	148	my $class = shift;
		149	my $fh = shift;
132	my $peername = shift;	150	my $peername = shift;
133	my $fh = shift;
134	my $self = bless { fh => $fh }, $class;	151	my $self = bless { fh => $fh }, $class;
135	my (undef, $iaddr) = unpack_sockaddr_in $peername	152	my (undef, $iaddr) = unpack_sockaddr_in $peername
136	or $self->err(500, "unable to decode peername");	153	or $self->err(500, "unable to decode peername");
137		154
138	$self->{remote_addr} = inet_ntoa $iaddr;	155	$self->{remote_addr} = inet_ntoa $iaddr;
139	$self->{time} = $::NOW;	156	$self->{time} = $::NOW;
140		157
		158	weaken ($Coro::current->{conn} = $self);
		159
141	$::conns++;	160	$::conns++;
142		161
143	$self;	162	$self;
144	}	163	}
145		164
146	sub DESTROY {	165	sub DESTROY {
147	my $self = shift;	166	my $self = shift;
148
149	$::conns--;	167	$::conns--;
150
151	$self->eoconn;	168	$self->eoconn;
152	}	169	}
153		170
154	# end of connection	171	# end of connection
155	sub eoconn {	172	sub eoconn {
156	my $self = shift;	173	my $self = shift;
157		174
158	# clean up hints	175	# clean up hints
159	delete $conn{$self->{remote_id}}{$self*1};	176	delete $conn{$self->{remote_id}}{$self*1};
160	delete $uri{$self->{remote_id}}{$self->{uri}}{$self*1};	177	delete $uri{$self->{remote_id}}{$self->{uri}}{$self*1};
		178
		179	$httpevent->broadcast;
161	}	180	}
162		181
163	sub slog {	182	sub slog {
164	my $self = shift;	183	my $self = shift;
165	main::slog($_[0], ($self->{remote_id} \|\| $self->{remote_addr}) ."> $_[1]");	184	main::slog($_[0], ($self->{remote_id} \|\| $self->{remote_addr}) ."> $_[1]");
…		…
167		186
168	sub response {	187	sub response {
169	my ($self, $code, $msg, $hdr, $content) = @_;	188	my ($self, $code, $msg, $hdr, $content) = @_;
170	my $res = "HTTP/1.1 $code $msg\015\012";	189	my $res = "HTTP/1.1 $code $msg\015\012";
171		190
172	$self->{h}{connection} \|\|= $hdr->{Connection};	191	if (exists $hdr->{Connection}) {
		192	if ($hdr->{Connection} =~ /close/) {
		193	$self->{h}{connection} = "close"
		194	}
		195	} else {
		196	if ($self->{version} < 1.1) {
		197	if ($self->{h}{connection} =~ /keep-alive/i) {
		198	$hdr->{Connection} = "Keep-Alive";
		199	} else {
		200	$self->{h}{connection} = "close"
		201	}
		202	}
		203	}
173		204
174	$res .= "Date: $HTTP_NOW\015\012";	205	$res .= "Date: $HTTP_NOW\015\012";
175		206
176	while (my ($h, $v) = each %$hdr) {	207	while (my ($h, $v) = each %$hdr) {
177	$res .= "$h: $v\015\012"	208	$res .= "$h: $v\015\012"
178	}	209	}
179	$res .= "\015\012";	210	$res .= "\015\012";
180		211
181	$res .= $content if defined $content and $self->{method} ne "HEAD";	212	$res .= $content if defined $content and $self->{method} ne "HEAD";
182		213
		214	my $log = (POSIX::strftime "%Y-%m-%d %H:%M:%S", gmtime $NOW).
183	my $log = "$self->{remote_addr} \"$self->{uri}\" $code ".$hdr->{"Content-Length"}." \"$self->{h}{referer}\"\n";	215	" $self->{remote_addr} \"$self->{uri}\" $code ".$hdr->{"Content-Length"}." \"$self->{h}{referer}\"\n";
184		216
185	print $accesslog $log if $accesslog;	217	print $accesslog $log if $accesslog;
186	print STDERR $log;	218	print STDERR $log;
187		219
188	$self->{written} +=	220	$self->{written} +=
…		…
280		312
281	delete $blocked{$id};	313	delete $blocked{$id};
282	}	314	}
283		315
284	if (%{$conn{$id}} >= $::MAX_CONN_IP) {	316	if (%{$conn{$id}} >= $::MAX_CONN_IP) {
285	my $delay = $::PER_TIMEOUT + 15;	317	my $delay = $::PER_TIMEOUT + $::NOW + 15;
286	while (%{$conn{$id}} >= $::MAX_CONN_IP) {	318	while (%{$conn{$id}} >= $::MAX_CONN_IP) {
287	if ($delay <= 0) {	319	if ($delay < $::NOW) {
288	$self->slog(2, "blocked ip $id");	320	$self->slog(2, "blocked ip $id");
289	$self->err_blocked;	321	$self->err_blocked;
290	} else {	322	} else {
291	Coro::Event::do_timer(after => 4); $delay -= 4;	323	$httpevent->wait;
292	}	324	}
293	}	325	}
294	}	326	}
295		327
296	# find out server name and port	328	# find out server name and port
…		…
302		334
303	if (defined $host) {	335	if (defined $host) {
304	$self->{server_port} = $host =~ s/:([0-9]+)$// ? $1 : 80;	336	$self->{server_port} = $host =~ s/:([0-9]+)$// ? $1 : 80;
305	} else {	337	} else {
306	($self->{server_port}, $host)	338	($self->{server_port}, $host)
307	= unpack_sockaddr_in $self->{fh}->getsockname	339	= unpack_sockaddr_in $self->{fh}->sockname
308	or $self->err(500, "unable to get socket name");	340	or $self->err(500, "unable to get socket name");
309	$host = inet_ntoa $host;	341	$host = inet_ntoa $host;
310	}	342	}
311		343
312	$self->{server_name} = $host;	344	$self->{server_name} = $host;
…		…
322		354
323	$self->eoconn;	355	$self->eoconn;
324		356
325	die if $@ && !ref $@;	357	die if $@ && !ref $@;
326		358
327	last if $self->{h}{connection} =~ /close/ \|\| $self->{version} < 1.1;	359	last if $self->{h}{connection} =~ /close/;
		360
		361	$httpevent->broadcast;
328		362
329	$fh->timeout($::PER_TIMEOUT);	363	$fh->timeout($::PER_TIMEOUT);
330	}	364	}
331	}	365	}
332		366
…		…
382		416
383	sub respond {	417	sub respond {
384	my $self = shift;	418	my $self = shift;
385	my $path = $self->{path};	419	my $path = $self->{path};
386		420
387	stat $path	421	if ($self->{name} =~ s%^/internal/([^/]+)%%) {
388	or $self->err(404, "not found");	422	if ($::internal{$1}) {
389		423	$::internal{$1}->($self);
390	$self->{stat} = [stat _];
391
392	# idiotic netscape sends idiotic headers AGAIN
393	my $ims = $self->{h}{"if-modified-since"} =~ /^([^;]+)/
394	? str2time $1 : 0;
395
396	if (-d _ && -r _) {
397	# directory
398	if ($path !~ /\/$/) {
399	# create a redirect to get the trailing "/"
400	# we don't try to avoid the :80
401	$self->err(301, "moved permanently", { Location => "http://".$self->server_hostport."$self->{uri}/" });
402	} else {	424	} else {
403	$ims < $self->{stat}[9]	425	$self->err(404, "not found");
		426	}
		427	} else {
		428
		429	stat $path
404	or $self->err(304, "not modified");	430	or $self->err(404, "not found");
405		431
406	if (-r "$path/index.html") {	432	$self->{stat} = [stat _];
407	$self->{path} .= "/index.html";	433
408	$self->handle_file;	434	# idiotic netscape sends idiotic headers AGAIN
		435	my $ims = $self->{h}{"if-modified-since"} =~ /^([^;]+)/
		436	? str2time $1 : 0;
		437
		438	if (-d _ && -r _) {
		439	# directory
		440	if ($path !~ /\/$/) {
		441	# create a redirect to get the trailing "/"
		442	# we don't try to avoid the :80
		443	$self->err(301, "moved permanently", { Location => "http://".$self->server_hostport."$self->{uri}/" });
409	} else {	444	} else {
		445	$ims < $self->{stat}[9]
		446	or $self->err(304, "not modified");
		447
		448	if (-r "$path/index.html") {
		449	# replace directory "size" by index.html filesize
		450	$self->{stat}[7] = (stat ($self->{path} .= "/index.html"))[7];
		451	$self->handle_file;
		452	} else {
410	$self->handle_dir;	453	$self->handle_dir;
411	}	454	}
412	}	455	}
413	} elsif (-f _ && -r _) {	456	} elsif (-f _ && -r _) {
414	-x _ and $self->err(403, "forbidden");	457	-x _ and $self->err(403, "forbidden");
415	$self->handle_file;	458	$self->handle_file;
416	} else {	459	} else {
417	$self->err(404, "not found");	460	$self->err(404, "not found");
		461	}
418	}	462	}
419	}	463	}
420		464
421	sub handle_dir {	465	sub handle_dir {
422	my $self = shift;	466	my $self = shift;
…		…
424		468
425	$self->response(200, "ok",	469	$self->response(200, "ok",
426	{	470	{
427	"Content-Type" => "text/html",	471	"Content-Type" => "text/html",
428	"Content-Length" => length $idx,	472	"Content-Length" => length $idx,
		473	"Last-Modified" => time2str ((stat _)[9]),
429	},	474	},
430	$idx);	475	$idx);
431	}	476	}
432		477
433	sub handle_file {	478	sub handle_file {
…		…
458	$self->err(416, "not satisfiable", $hdr, "");	503	$self->err(416, "not satisfiable", $hdr, "");
459		504
460	satisfiable:	505	satisfiable:
461	# check for segmented downloads	506	# check for segmented downloads
462	if ($l && $::NO_SEGMENTED) {	507	if ($l && $::NO_SEGMENTED) {
463	my $delay = $::PER_TIMEOUT + 15;	508	my $delay = $::NOW + $::PER_TIMEOUT + 15;
464	while (%{$uri{$self->{remote_id}}{$self->{uri}}} > 1) {	509	while (%{$uri{$self->{remote_id}}{$self->{uri}}} > 1) {
465	if ($delay <= 0) {	510	if ($delay <= $::NOW) {
466	$self->err_segmented_download;	511	$self->err_segmented_download;
467	} else {	512	} else {
468	Coro::Event::do_timer(after => 4); $delay -= 4;	513	$httpevent->wait;
469	}	514	}
470	}	515	}
471	}	516	}
472		517
473	$hdr->{"Content-Range"} = "bytes $l-$h/$length";	518	$hdr->{"Content-Range"} = "bytes $l-$h/$length";
…		…
486	$self->response(@code, $hdr, "");	531	$self->response(@code, $hdr, "");
487		532
488	if ($self->{method} eq "GET") {	533	if ($self->{method} eq "GET") {
489	$self->{time} = $::NOW;	534	$self->{time} = $::NOW;
490		535
491	my $fudge = $queue->[0]->waiters;	536	my $current = $Coro::current;
492	$fudge = $fudge ? ($fudge+1)/$fudge : 1;
493
494	$queue->[1] *= $fudge;
495	my $transfer = $queue->[0]->guard;
496
497	if ($fudge != 1) {
498	$queue->[1] /= $fudge;
499	$queue->[1] = $queue->[1] * $::wait_factor
500	+ ($::NOW - $self->{time}) * (1 - $::wait_factor);
501	}
502	$self->{time} = $::NOW;
503
504	$self->{fh}->writable or return;
505		537
506	my ($fh, $buf, $r);	538	my ($fh, $buf, $r);
507	my $current = $Coro::current;	539
508	open $fh, "<", $self->{path}	540	open $fh, "<", $self->{path}
509	or die "$self->{path}: late open failure ($!)";	541	or die "$self->{path}: late open failure ($!)";
510		542
511	$h -= $l - 1;	543	$h -= $l - 1;
512		544
513	if (0) {	545	if (0) { # !AIO
514	if ($l) {	546	if ($l) {
515	sysseek $fh, $l, 0;	547	sysseek $fh, $l, 0;
516	}	548	}
517	}	549	}
		550
		551	my $transfer; # transfer guard
		552	my $bufsize = $::WAIT_BUFSIZE; # initial buffer size
		553
		554	$self->{time} = $::NOW;
518		555
519	while ($h > 0) {	556	while ($h > 0) {
		557	unless ($transfer) {
		558	if ($transfer \|\|= $queue->timed_guard($::WAIT_INTERVAL)) {
		559	$bufsize = $::BUFSIZE;
		560	$self->{time} = $::NOW;
		561	}
		562	}
		563
520	if (0) {	564	if (0) { # !AIO
521	sysread $fh, $buf, $h > $::BUFSIZE ? $::BUFSIZE : $h	565	sysread $fh, $buf, $h > $bufsize ? $bufsize : $h
522	or last;	566	or last;
523	} else {	567	} else {
524	undef $buf;	568	aio_read($fh, $l, ($h > $bufsize ? $bufsize : $h),
525	$aio_requests->down;
526	aio_read($fh, $l, ($h > $::BUFSIZE ? $::BUFSIZE : $h),
527	$buf, 0, sub {	569	$buf, 0, sub {
528	$r = $_[0];	570	$r = $_[0];
529	$current->ready;	571	Coro::ready($current);
530	});	572	});
531	&Coro::schedule;	573	&Coro::schedule;
532	$aio_requests->up;
533	last unless $r;	574	last unless $r;
534	}	575	}
535	my $w = $self->{fh}->syswrite($buf)	576	my $w = syswrite $self->{fh}, $buf
536	or last;	577	or last;
537	$::written += $w;	578	$::written += $w;
538	$self->{written} += $w;	579	$self->{written} += $w;
539	$l += $r;	580	$l += $r;
540	}	581	}

Diff Legend

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

Comparing cvsroot/Coro/myhttpd/httpd.pl (file contents): Revision 1.36 by root, Sun Sep 2 00:54:00 2001 UTC vs. Revision 1.49 by root, Wed Nov 28 03:39:46 2001 UTC

Diff Legend

Comparing cvsroot/Coro/myhttpd/httpd.pl (file contents):
Revision 1.36 by root, Sun Sep 2 00:54:00 2001 UTC vs.
Revision 1.49 by root, Wed Nov 28 03:39:46 2001 UTC