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

Comparing cvsroot/Coro/myhttpd/httpd.pl (file contents):
Revision 1.33 by root, Wed Aug 29 01:40:44 2001 UTC vs.
Revision 1.95 by root, Wed Apr 24 23:49:34 2013 UTC

…		…
		1	use AnyEvent ();
		2
1	use Coro;	3	use Coro;
2	use Coro::Semaphore;	4	use Coro::Semaphore;
		5	use Coro::SemaphoreSet;
3	use Coro::Event;	6	use Coro::EV;
4	use Coro::Socket;	7	use Coro::Socket;
		8	use Coro::Signal;
		9	use Coro::AIO ();
5		10
		11	use Fcntl;
6	use HTTP::Date;	12	use HTTP::Date;
		13	use POSIX ();
7		14
8	no utf8;	15	use Compress::Zlib ();
9	use bytes;
10		16
11	our @wait_time = (); # used to calculcate avg. waiting time	17	use common::sense;
12	our $wait_time_length = 25;
13		18
14	# at least on my machine, this thingy serves files	19	# at least on my machine, this thingy serves files
15	# quite a bit faster than apache, ;)	20	# quite a bit faster than apache, ;)
16	# and quite a bit slower than thttpd :(	21	# and quite a bit slower than thttpd :(
17		22
18	$SIG{PIPE} = 'IGNORE';	23	$SIG{PIPE} = 'IGNORE';
19		24
20	our $accesslog;	25	our $accesslog;
		26	our $errorlog;
		27	our @listen_sockets;
		28
		29	our $NOW;
		30	our $HTTP_NOW;
		31
		32	our $ERROR_LOG;
		33	our $ACCESS_LOG;
		34	our $TRANSFER_LOCK = new Coro::SemaphoreSet; # lock to be acquired per ip
		35
		36	our $update_time = EV::periodic 0, 1, undef, sub {
		37	$NOW = time;
		38	$HTTP_NOW = time2str $NOW;
		39	};
		40	$update_time->invoke;
		41
		42	if ($ERROR_LOG) {
		43	use IO::Handle;
		44	open $errorlog, ">>$ERROR_LOG"
		45	or die "$ERROR_LOG: $!";
		46	$errorlog->autoflush(1);
		47	}
21		48
22	if ($ACCESS_LOG) {	49	if ($ACCESS_LOG) {
23	use IO::Handle;	50	use IO::Handle;
24	open $accesslog, ">>$ACCESS_LOG"	51	open $accesslog, ">>$ACCESS_LOG"
25	or die "$ACCESS_LOG: $!";	52	or die "$ACCESS_LOG: $!";
27	}	54	}
28		55
29	sub slog {	56	sub slog {
30	my $level = shift;	57	my $level = shift;
31	my $format = shift;	58	my $format = shift;
		59
		60	$format = sprintf $format, @_ if @_;
		61
		62	my $NOW = (POSIX::strftime "%Y-%m-%d %H:%M:%S", gmtime $::NOW);
32	printf "---: $format\n", @_;	63	print "$NOW: $format\n";
		64	print $errorlog "$NOW: $format\n", @_ if $errorlog;
33	}	65	}
34		66
35	our $connections = new Coro::Semaphore $MAX_CONNECTS \|\| 250;	67	our $connections = new Coro::Semaphore $::MAX_CONNECTS \|\| 250;
36	our $transfers = new Coro::Semaphore $MAX_TRANSFER \|\| 50;	68	our $httpevent = new Coro::Signal;
37		69
38	my @newcons;	70	our $queue_file = new transferqueue $::MAX_TRANSFERS;
39	my @pool;	71	our $queue_index = new transferqueue 10;
40		72
41	# one "execution thread"	73	our $tbf_top = new tbf rate => $::TBF_RATE \|\| 100000;
42	sub handler {	74
		75	my $unused_bytes = 0;
		76	my $unused_last = time;
		77
		78	sub unused_bandwidth {
		79	$unused_bytes += $_[0];
		80	if ($unused_last < $NOW - 30 && $unused_bytes / ($NOW - $unused_last) > 50000) {
		81	$unused_last = $NOW;
		82	$unused_bytes = 0;
		83	$queue_file->force_wake_next
		84	and slog 1, "forced filetransfer due to unused bandwidth";
		85	}
		86	}
		87
		88	sub listen_on {
		89	my $listen = $_[0];
		90
		91	push @listen_sockets, $listen;
		92
		93	# the "main thread"
		94	async {
		95	slog 1, "accepting connections";
43	while () {	96	while () {
44	my $new = pop @newcons;	97	$connections->down;
45	if ($new) {	98	my @conn = $listen->accept;
		99	#slog 3, "accepted @$connections ".scalar(@pool);
		100
		101	async_pool {
46	eval {	102	eval {
47	conn->new(@$new)->handle;	103	conn->new (@conn)->handle;
48	};	104	};
49	slog 1, "$@" if $@ && !ref $@;	105	slog 1, "$@" if $@ && !ref $@;
		106
		107	$httpevent->broadcast; # only for testing, but doesn't matter much
		108
50	$connections->up;	109	$connections->up;
51	} else {
52	last if @pool >= $MAX_POOL;
53	push @pool, $Coro::current;
54	schedule;
55	}	110	}
		111	}
56	}	112	};
57	}	113	}
58		114
59	my $http_port = new Coro::Socket	115	my $http_port = new Coro::Socket
60	LocalAddr => $SERVER_HOST,	116	LocalAddr => $::SERVER_HOST,
61	LocalPort => $SERVER_PORT,	117	LocalPort => $::SERVER_PORT,
62	ReuseAddr => 1,	118	ReuseAddr => 1,
63	Listen => 50,	119	Listen => 50,
64	or die "unable to start server";	120	or die "unable to start server";
65		121
66	push @listen_sockets, $http_port;	122	listen_on $http_port;
67		123
68	our $NOW;	124	if ($::SERVER_PORT2) {
69	our $HTTP_NOW;	125	my $http_port = new Coro::Socket
		126	LocalAddr => $::SERVER_HOST,
		127	LocalPort => $::SERVER_PORT2,
		128	ReuseAddr => 1,
		129	Listen => 50,
		130	or die "unable to start server";
70		131
71	Event->timer(interval => 1, hard => 1, cb => sub {	132	listen_on $http_port;
72	$NOW = time;	133	}
73	$HTTP_NOW = time2str $NOW;
74	});
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		134
92	package conn;	135	package conn;
		136
		137	use common::sense;
93		138
94	use Socket;	139	use Socket;
95	use HTTP::Date;	140	use HTTP::Date;
96	use Convert::Scalar 'weaken';	141	use Convert::Scalar 'weaken';
97	use Linux::AIO;	142	use IO::AIO;
		143	use AnyEvent::AIO;
98		144
99	Linux::AIO::min_parallel $::AIO_PARALLEL;	145	IO::AIO::min_parallel $::AIO_PARALLEL;
100
101	my $aio_requests = new Coro::Semaphore $::AIO_PARALLEL * 4;
102
103	Event->io(fd => Linux::AIO::poll_fileno,
104	poll => 'r', async => 1,
105	cb => \&Linux::AIO::poll_cb);
106		146
107	our %conn; # $conn{ip}{self} => connobj	147	our %conn; # $conn{ip}{self} => connobj
108	our %uri; # $uri{ip}{uri}{self}	148	our %uri; # $uri{ip}{uri}{self}
109	our %blocked;	149	our %blocked;
110	our %mimetype;	150	our %mimetype;
111		151
112	sub read_mimetypes {	152	sub read_mimetypes {
113	local *M;
114	if (open M, "<mime_types") {	153	if (open my $fh, "<mime_types") {
115	while (<M>) {	154	while (<$fh>) {
116	if (/^([^#]\S+)\t+(\S+)$/) {	155	if (/^([^#]\S+)\t+(\S+)$/) {
117	$mimetype{lc $1} = $2;	156	$mimetype{lc $1} = $2;
118	}	157	}
119	}	158	}
120	} else {	159	} else {
…		…
124		163
125	read_mimetypes;	164	read_mimetypes;
126		165
127	sub new {	166	sub new {
128	my $class = shift;	167	my $class = shift;
		168	my $fh = shift;
129	my $peername = shift;	169	my $peername = shift;
130	my $fh = shift;
131	my $self = bless { fh => $fh }, $class;	170	my $self = bless { fh => $fh }, $class;
132	my (undef, $iaddr) = unpack_sockaddr_in $peername	171	my (undef, $iaddr) = unpack_sockaddr_in $peername
133	or $self->err(500, "unable to decode peername");	172	or $self->err (500, "unable to decode peername");
134		173
		174	$self->{remote_addr} =
135	$self->{remote_addr} = inet_ntoa $iaddr;	175	$self->{remote_id} = inet_ntoa $iaddr;
		176
136	$self->{time} = $::NOW;	177	$self->{time} = $::NOW;
137		178
138	# enter ourselves into various lists	179	weaken ($Coro::current->{conn} = $self);
139	weaken ($conn{$self->{remote_addr}}{$self*1} = $self);
140		180
141	$::conns++;	181	++$::conns;
		182	$::maxconns = $::conns if $::conns > $::maxconns;
142		183
143	$self;	184	$self
144	}	185	}
145		186
146	sub DESTROY {	187	sub DESTROY {
147	my $self = shift;	188	my $self = shift;
148		189
149	$::conns--;	190	--$::conns;
150
151	$self->eoconn;
152	delete $conn{$self->{remote_addr}}{$self*1};
153	}	191	}
154		192
155	# end of connection	193	sub prune_cache {
156	sub eoconn {	194	my $hash = $_[0];
157	my $self = shift;	195
158	delete $uri{$self->{remote_addr}}{$self->{uri}}{$self*1};	196	for (keys %$hash) {
		197	if (ref $hash->{$_} eq HASH::) {
		198	prune_cache($hash->{$_});
		199	unless (scalar keys %{$hash->{$_}}) {
		200	delete $hash->{$_};
		201	}
		202	}
		203	}
159	}	204	}
		205
		206	sub prune_caches {
		207	prune_cache \%conn;
		208	prune_cache \%uri;
		209
		210	for (keys %blocked) {
		211	delete $blocked{$_} unless $blocked{$_}[0] > $::NOW;
		212	}
		213	}
		214
		215	our $PRUNE_WATCHER = AE::timer 60, 60, \&prune_caches;
160		216
161	sub slog {	217	sub slog {
162	my $self = shift;	218	my $self = shift;
163	main::slog($_[0], ($self->{remote_id} \|\| $self->{remote_addr}) ."> $_[1]");	219	main::slog($_[0], "$self->{remote_id}> $_[1]");
164	}	220	}
165		221
166	sub response {	222	sub response {
167	my ($self, $code, $msg, $hdr, $content) = @_;	223	my ($self, $code, $msg, $hdr, $content) = @_;
168	my $res = "HTTP/1.1 $code $msg\015\012";	224	my $res = "HTTP/1.1 $code $msg\015\012";
		225	my $GZ = "";
169		226
170	$self->{h}{connection} \|\|= $hdr->{Connection};	227	if (exists $hdr->{Connection}) {
		228	if ($hdr->{Connection} =~ /close/) {
		229	$self->{h}{connection} = "close"
		230	}
		231	} else {
		232	if ($self->{version} < 1.1) {
		233	if ($self->{h}{connection} =~ /keep-alive/i) {
		234	$hdr->{Connection} = "Keep-Alive";
		235	} else {
		236	$self->{h}{connection} = "close"
		237	}
		238	}
		239	}
		240
		241	if ($self->{method} ne "HEAD"
		242	&& $self->{h}{"accept-encoding"} =~ /\bgzip\b/
		243	&& 400 < length $content
		244	&& $hdr->{"Content-Length"} == length $content
		245	&& !exists $hdr->{"Content-Encoding"}
		246	) {
		247	my $orig = length $content;
		248	$hdr->{"Content-Encoding"} = "gzip";
		249	$content = Compress::Zlib::memGzip(\$content);
		250	$hdr->{"Content-Length"} = length $content;
		251	$GZ = sprintf "GZ%02d", 100 - 100*((length $content) / $orig);
		252	}
171		253
172	$res .= "Date: $HTTP_NOW\015\012";	254	$res .= "Date: $HTTP_NOW\015\012";
		255	$res .= "Server: $::NAME\015\012";
173		256
174	while (my ($h, $v) = each %$hdr) {	257	while (my ($h, $v) = each %$hdr) {
175	$res .= "$h: $v\015\012"	258	$res .= "$h: $v\015\012"
176	}	259	}
177	$res .= "\015\012";	260	$res .= "\015\012";
178		261
179	$res .= $content if defined $content and $self->{method} ne "HEAD";	262	$res .= $content if defined $content and $self->{method} ne "HEAD";
180		263
181	my $log = "$self->{remote_addr} \"$self->{uri}\" $code ".$hdr->{"Content-Length"}." \"$self->{h}{referer}\"\n";	264	my $log = (POSIX::strftime "%Y-%m-%d %H:%M:%S", gmtime $::NOW).
		265	" $self->{remote_id} \"$self->{uri}\" $code ".$hdr->{"Content-Length"}.$GZ.
		266	" \"$self->{h}{referer}\"\n";
182		267
183	print $accesslog $log if $accesslog;	268	print $::accesslog $log if $::accesslog;
184	print STDERR $log;	269	print STDERR $log;
185		270
186	$self->{written} +=	271	$tbf_top->request(length $res, 1e6);
187	print {$self->{fh}} $res;	272	$self->{written} += print {$self->{fh}} $res;
188	}	273	}
189		274
190	sub err {	275	sub err {
191	my $self = shift;	276	my $self = shift;
192	my ($code, $msg, $hdr, $content) = @_;	277	my ($code, $msg, $hdr, $content) = @_;
193		278
194	unless (defined $content) {	279	unless (defined $content) {
195	$content = "$code $msg";	280	$content = "$code $msg\n";
196	$hdr->{"Content-Type"} = "text/plain";	281	$hdr->{"Content-Type"} = "text/plain";
197	$hdr->{"Content-Length"} = length $content;	282	$hdr->{"Content-Length"} = length $content;
198	}	283	}
199	$hdr->{"Connection"} = "close";	284	$hdr->{"Connection"} = "close";
200		285
201	$self->response($code, $msg, $hdr, $content);	286	$self->response ($code, $msg, $hdr, $content);
202		287
203	die bless {}, err::;	288	die bless {}, err::
204	}	289	}
205		290
206	sub handle {	291	sub handle {
207	my $self = shift;	292	my $self = shift;
208	my $fh = $self->{fh};	293	my $fh = $self->{fh};
209		294
210	my $host;	295	my $host;
211		296
212	$fh->timeout($::REQ_TIMEOUT);	297	$fh->timeout($::REQ_TIMEOUT);
213	while() {	298	while () {
214	$self->{reqs}++;	299	$self->{reqs}++;
215		300
216	# read request and parse first line	301	# read request and parse first line
217	my $req = $fh->readline("\015\012\015\012");	302	my $req = $fh->readline("\015\012\015\012");
218		303
…		…
225	}	310	}
226		311
227	$self->{h} = {};	312	$self->{h} = {};
228		313
229	$fh->timeout($::RES_TIMEOUT);	314	$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		315
252	$req =~ /^(?:\015\012)?	316	$req =~ /^(?:\015\012)?
253	(GET\|HEAD) \040+	317	(GET\|HEAD) \040+
254	([^\040]+) \040+	318	([^\040]+) \040+
255	HTTP\/([0-9]+\.[0-9]+)	319	HTTP\/([0-9]+\.[0-9]+)
…		…
268	my (%hdr, $h, $v);	332	my (%hdr, $h, $v);
269		333
270	$hdr{lc $1} .= ",$2"	334	$hdr{lc $1} .= ",$2"
271	while $req =~ /\G	335	while $req =~ /\G
272	([^:\000-\040]+):	336	([^:\000-\040]+):
273	[\008\040]*	337	[\011\040]*
274	((?: [^\015\012]+ \| \015\012[\008\040] )*)	338	((?: [^\015\012]+ \| \015\012[\011\040] )*)
275	\015\012	339	\015\012
276	/gxc;	340	/gxc;
277		341
278	$req =~ /\G\015\012$/	342	$req =~ /\G\015\012$/
279	or $self->err(400, "bad request");	343	or $self->err(400, "bad request");
280		344
281	$self->{h}{$h} = substr $v, 1	345	$self->{h}{$h} = substr $v, 1
282	while ($h, $v) = each %hdr;	346	while ($h, $v) = each %hdr;
		347	}
		348
		349	# remote id should be unique per user
		350	my $id = $self->{remote_addr};
		351
		352	if (exists $self->{h}{"client-ip"}) {
		353	$id .= "[".$self->{h}{"client-ip"}."]";
		354	} elsif (exists $self->{h}{"x-forwarded-for"}) {
		355	$id .= "[".$self->{h}{"x-forwarded-for"}."]";
		356	}
		357
		358	$self->{remote_id} = $id;
		359
		360	weaken (local $conn{$id}{$self*1} = $self);
		361
		362	if ($blocked{$id}) {
		363	$self->err_blocked
		364	if $blocked{$id}[0] > $::NOW;
		365
		366	delete $blocked{$id};
283	}	367	}
284		368
285	# find out server name and port	369	# find out server name and port
286	if ($self->{uri} =~ s/^http:\/\/([^\/?#]*)//i) {	370	if ($self->{uri} =~ s/^http:\/\/([^\/?#]*)//i) {
287	$host = $1;	371	$host = $1;
…		…
291		375
292	if (defined $host) {	376	if (defined $host) {
293	$self->{server_port} = $host =~ s/:([0-9]+)$// ? $1 : 80;	377	$self->{server_port} = $host =~ s/:([0-9]+)$// ? $1 : 80;
294	} else {	378	} else {
295	($self->{server_port}, $host)	379	($self->{server_port}, $host)
296	= unpack_sockaddr_in $self->{fh}->getsockname	380	= unpack_sockaddr_in $self->{fh}->sockname
297	or $self->err(500, "unable to get socket name");	381	or $self->err(500, "unable to get socket name");
298	$host = inet_ntoa $host;	382	$host = inet_ntoa $host;
299	}	383	}
300		384
301	$self->{server_name} = $host;	385	$self->{server_name} = $host;
302		386
303	# remote id should be unique per user
304	$self->{remote_id} = $self->{remote_addr};
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);	387	weaken (local $uri{$id}{$self->{uri}}{$self*1} = $self);
313		388
314	eval {	389	eval {
315	$self->map_uri;	390	$self->map_uri;
316	$self->respond;	391	$self->respond;
317	};	392	};
318		393
319	$self->eoconn;
320
321	die if $@ && !ref $@;	394	die if $@ && !ref $@;
322		395
323	last if $self->{h}{connection} =~ /close/ \|\| $self->{version} < 1.1;	396	last if $self->{h}{connection} =~ /close/i;
		397
		398	$httpevent->broadcast;
324		399
325	$fh->timeout($::PER_TIMEOUT);	400	$fh->timeout($::PER_TIMEOUT);
326	}	401	}
		402	}
		403
		404	sub block {
		405	my $self = shift;
		406
		407	$blocked{$self->{remote_id}} = [$::NOW + $_[0], $_[1]];
		408	$self->slog(2, "blocked ip $self->{remote_id}");
		409	$self->err_blocked;
327	}	410	}
328		411
329	# uri => path mapping	412	# uri => path mapping
330	sub map_uri {	413	sub map_uri {
331	my $self = shift;	414	my $self = shift;
332	my $host = $self->{server_name};	415	my $host = $self->{server_name};
333	my $uri = $self->{uri};	416	my $uri = $self->{uri};
		417
		418	$host =~ /[\/\\]/
		419	and $self->err(400, "bad request");
334		420
335	# some massaging, also makes it more secure	421	# some massaging, also makes it more secure
336	$uri =~ s/%([0-9a-fA-F][0-9a-fA-F])/chr hex $1/ge;	422	$uri =~ s/%([0-9a-fA-F][0-9a-fA-F])/chr hex $1/ge;
337	$uri =~ s%//+%/%g;	423	$uri =~ s%//+%/%g;
338	$uri =~ s%/\.(?=/\|$)%%g;	424	$uri =~ s%/\.(?=/\|$)%%g;
…		…
378		464
379	sub respond {	465	sub respond {
380	my $self = shift;	466	my $self = shift;
381	my $path = $self->{path};	467	my $path = $self->{path};
382		468
383	stat $path	469	if ($self->{name} =~ s%^/internal/([^/]+)%%) {
384	or $self->err(404, "not found");	470	if ($::internal{$1}) {
385		471	$::internal{$1}->($self);
386	$self->{stat} = [stat _];
387
388	# idiotic netscape sends idiotic headers AGAIN
389	my $ims = $self->{h}{"if-modified-since"} =~ /^([^;]+)/
390	? str2time $1 : 0;
391
392	if (-d _ && -r _) {
393	# directory
394	if ($path !~ /\/$/) {
395	# create a redirect to get the trailing "/"
396	# we don't try to avoid the :80
397	$self->err(301, "moved permanently", { Location => "http://".$self->server_hostport."$self->{uri}/" });
398	} else {	472	} else {
399	$ims < $self->{stat}[9]
400	or $self->err(304, "not modified");	473	$self->err (404, "not found");
		474	}
		475	} else {
401		476
402	if (-r "$path/index.html") {	477	Coro::AIO::aio_stat $path
403	$self->{path} .= "/index.html";	478	and $self->err (404, "not found");
404	$self->handle_file;	479
		480	$self->{stat} = [stat _];
		481
		482	# idiotic netscape sends idiotic headers AGAIN
		483	my $ims = $self->{h}{"if-modified-since"} =~ /^([^;]+)/
		484	? str2time $1 : 0;
		485
		486	if (-d _ && -r _) {
		487	# directory
		488	if ($path !~ /\/$/) {
		489	# create a redirect to get the trailing "/"
		490	# we don't try to avoid the :80
		491	$self->err (301, "moved permanently", { Location => "http://".$self->server_hostport."$self->{uri}/" });
405	} else {	492	} else {
		493	$ims < $self->{stat}[9]
		494	or $self->err (304, "not modified");
		495
		496	if (-r "$path/index.html") {
		497	# replace directory "size" by index.html filesize
		498	$self->{stat} = [stat ($self->{path} .= "/index.html")];
		499	$self->handle_file ($queue_index, $tbf_top);
		500	} else {
406	$self->handle_dir;	501	$self->handle_dir;
407	}	502	}
408	}	503	}
409	} elsif (-f _ && -r _) {	504	} elsif (-f _ && -r _) {
410	-x _ and $self->err(403, "forbidden");	505	-x _ and $self->err (403, "forbidden");
411	$self->handle_file;	506
		507	if (keys %{$conn{$self->{remote_id}}} > $::MAX_TRANSFERS_IP) {
		508	my $timeout = $::NOW + 10;
		509	while (keys %{$conn{$self->{remote_id}}} > $::MAX_TRANSFERS_IP) {
		510	if ($timeout < $::NOW) {
		511	$self->block($::BLOCKTIME, "too many connections");
		512	} else {
		513	$httpevent->wait;
		514	}
		515	}
		516	}
		517
		518	$self->handle_file ($queue_file, $tbf_top);
412	} else {	519	} else {
413	$self->err(404, "not found");	520	$self->err (404, "not found");
		521	}
414	}	522	}
415	}	523	}
416		524
417	sub handle_dir {	525	sub handle_dir {
418	my $self = shift;	526	my $self = shift;
419	my $idx = $self->diridx;	527	my $idx = $self->diridx;
420		528
421	$self->response(200, "ok",	529	$self->response (200, "ok",
422	{	530	{
423	"Content-Type" => "text/html",	531	"Content-Type" => "text/html; charset=utf-8",
424	"Content-Length" => length $idx,	532	"Content-Length" => length $idx,
		533	"Last-Modified" => time2str ($self->{stat}[9]),
425	},	534	},
426	$idx);	535	$idx);
427	}	536	}
428		537
429	sub handle_file {	538	sub handle_file {
430	my $self = shift;	539	my ($self, $queue, $tbf) = @_;
431	my $length = -s _;	540	my $length = $self->{stat}[7];
432	my $hdr = {	541	my $hdr = {
433	"Last-Modified" => time2str ((stat _)[9]),	542	"Last-Modified" => time2str ((stat _)[9]),
		543	"Accept-Ranges" => "bytes",
434	};	544	};
435		545
436	my @code = (200, "ok");	546	my @code = (200, "ok");
437	my ($l, $h);	547	my ($l, $h);
438		548
439	if ($self->{h}{range} =~ /^bytes=(.*)$/) {	549	if ($self->{h}{range} =~ /^bytes=(.*)$/i) {
440	for (split /,/, $1) {	550	for (split /,/, $1) {
441	if (/^-(\d+)$/) {	551	if (/^-(\d+)$/) {
442	($l, $h) = ($length - $1, $length - 1);	552	($l, $h) = ($length - $1, $length - 1);
443	} elsif (/^(\d+)-(\d*)$/) {	553	} elsif (/^(\d+)-(\d*)$/) {
444	($l, $h) = ($1, ($2 ne "" \|\| $2 >= $length) ? $2 : $length - 1);	554	($l, $h) = ($1, ($2 ne "" \|\| $2 >= $length) ? $2 : $length - 1);
…		…
448	}	558	}
449	goto satisfiable if $l >= 0 && $l < $length && $h >= 0 && $h >= $l;	559	goto satisfiable if $l >= 0 && $l < $length && $h >= 0 && $h >= $l;
450	}	560	}
451	$hdr->{"Content-Range"} = "bytes */$length";	561	$hdr->{"Content-Range"} = "bytes */$length";
452	$hdr->{"Content-Length"} = $length;	562	$hdr->{"Content-Length"} = $length;
453	$self->slog(9, "not satisfiable($self->{h}{range}\|".$self->{h}{"user-agent"}.")");
454	$self->err(416, "not satisfiable", $hdr, "");	563	$self->err (416, "not satisfiable", $hdr, "");
455		564
456	satisfiable:	565	satisfiable:
457	# check for segmented downloads	566	# check for segmented downloads
458	if ($l && $::NO_SEGMENTED) {	567	if ($l && $::NO_SEGMENTED) {
459	my $delay = 180;	568	my $timeout = $::NOW + 60;
460	while (%{$uri{$self->{remote_addr}}{$self->{uri}}} > 1) {	569	while (keys %{$uri{$self->{remote_id}}{$self->{uri}}} > 1) {
461	if ($delay <= 0) {	570	if ($timeout <= $::NOW) {
462	$self->err_segmented_download;	571	$self->err_segmented_download;
463	} else {	572	} else {
464	Coro::Event::do_timer(after => 3); $delay -= 3;	573	$httpevent->wait;
465	}	574	}
466	}	575	}
467	}	576	}
468		577
469	$hdr->{"Content-Range"} = "bytes $l-$h/$length";	578	$hdr->{"Content-Range"} = "bytes $l-$h/$length";
…		…
477		586
478	$self->{path} =~ /\.([^.]+)$/;	587	$self->{path} =~ /\.([^.]+)$/;
479	$hdr->{"Content-Type"} = $mimetype{lc $1} \|\| "application/octet-stream";	588	$hdr->{"Content-Type"} = $mimetype{lc $1} \|\| "application/octet-stream";
480	$hdr->{"Content-Length"} = $length;	589	$hdr->{"Content-Length"} = $length;
481		590
482	$self->response(@code, $hdr, "");	591	$self->response (@code, $hdr, "");
483		592
484	if ($self->{method} eq "GET") {	593	if ($self->{method} eq "GET") {
485	$self->{time} = $::NOW;	594	$self->{time} = $::NOW;
486
487	my $transfer = $::transfers->guard;
488	$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;	595	$self->{written} = 0;
493		596
494	my ($fh, $buf, $r);	597	my $fh = Coro::AIO::aio_open $self->{path}, Fcntl::O_RDONLY, 0
495	my $current = $Coro::current;
496	open $fh, "<", $self->{path}
497	or die "$self->{path}: late open failure ($!)";	598	or die "$self->{path}: late open failure ($!)";
498		599
499	$h -= $l - 1;	600	$h -= $l - 1;
500		601
501	if (0) {	602	my $transfer = $queue->start_transfer ($h);
502	if ($l) {	603	my $locked;
503	sysseek $fh, $l, 0;	604	my $bufsize = $::WAIT_BUFSIZE; # initial buffer size
504	}
505	}
506		605
507	while ($h > 0) {	606	while ($h > 0) {
508	if (0) {	607	Coro::cede;
509	sysread $fh, $buf, $h > $::BUFSIZE ? $::BUFSIZE : $h	608	my $transfer_lock = $TRANSFER_LOCK->guard ($self->{remote_id});
		609
		610	unless ($locked) {
		611	if ($locked \|\|= $transfer->try ($::WAIT_INTERVAL)) {
		612	$bufsize = $::BUFSIZE;
		613	$self->{time} = $::NOW;
		614	$self->{written} = 0;
		615	}
		616	}
		617
		618	if ($blocked{$self->{remote_id}}) {
		619	$self->{h}{connection} = "close";
		620	die bless {}, err::;
		621	}
		622
		623	Coro::AIO::aio_read $fh, $l, ($h > $bufsize ? $bufsize : $h), my $buf, 0
510	or last;	624	or last;
511	} else {	625
512	undef $buf;	626	# readahead to work around rijk disk issues
513	$aio_requests->down;	627	IO::AIO::aio_readahead $fh, $l + $bufsize, $bufsize;
514	aio_read($fh, $l, ($h > $::BUFSIZE ? $::BUFSIZE : $h),	628
515	$buf, 0, sub {	629	$tbf->request (length $buf);
516	$r = $_[0];
517	$current->ready;
518	});
519	&Coro::schedule;
520	$aio_requests->up;
521	last unless $r;
522	}
523	my $w = $self->{fh}->syswrite($buf)	630	my $w = $self->{fh}->syswrite ($buf)
524	or last;	631	or last;
525	$::written += $w;	632	$::written += $w;
526	$self->{written} += $w;	633	$self->{written} += $w;
527	$l += $r;	634	$l += $w;
528	}	635	}
529		636
530	close $fh;	637	close $fh;
531	}	638	}
532	}	639	}
533		640
534	1;	641	1
		642

Diff Legend

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

Comparing cvsroot/Coro/myhttpd/httpd.pl (file contents): Revision 1.33 by root, Wed Aug 29 01:40:44 2001 UTC vs. Revision 1.95 by root, Wed Apr 24 23:49:34 2013 UTC

Diff Legend

Comparing cvsroot/Coro/myhttpd/httpd.pl (file contents):
Revision 1.33 by root, Wed Aug 29 01:40:44 2001 UTC vs.
Revision 1.95 by root, Wed Apr 24 23:49:34 2013 UTC