ViewVC Help
View File | Revision Log | Show Annotations | Download File
/cvs/Coro/eg/myhttpd
(Generate patch)

Comparing Coro/eg/myhttpd (file contents):
Revision 1.1 by root, Thu Aug 9 02:57:54 2001 UTC vs.
Revision 1.11 by root, Wed Apr 11 03:05:15 2007 UTC

1#!/usr/bin/perl 1#!/usr/bin/perl
2
3# this is a relatively small web-server, using coroutines for connections.
4# play around with it but do not use it in production without checking it
5# works for you. ask myhttpd@plan9.de in case of problems, or if you are
6# interested in a newer version (more useless features).
2 7
3use Coro; 8use Coro;
4use Coro::Semaphore; 9use Coro::Semaphore;
5use Coro::Event; 10use Coro::Event;
6use Coro::Socket; 11use Coro::Socket;
… …
37} 42}
38 43
39my $connections = new Coro::Semaphore $MAX_CONNECTS; 44my $connections = new Coro::Semaphore $MAX_CONNECTS;
40 45
41my @fh; 46my @fh;
42my @pool;
43 47
44sub handler { 48# move the event main loop into a coroutine
49async { loop };
50
51slog 1, "accepting connections";
45 while () { 52while () {
46 my $fh = pop @fh; 53 $connections->down;
47 if ($fh) { 54 if (my $fh = $port->accept) {
55 #slog 3, "accepted @$connections ".scalar(@pool);
56 async_pool {
48 eval { 57 eval {
49 conn->new($fh)->handle; 58 conn->new($fh)->handle;
50 }; 59 };
51 close $fh; 60 close $fh;
52 slog 1, "$@" if $@ && !ref $@; 61 slog 1, "$@" if $@ && !ref $@;
53 $connections->up; 62 $connections->up;
54 } else {
55 last if @pool >= $MAX_POOL;
56 push @pool, $Coro::current;
57 schedule;
58 } 63 };
59 } 64 }
60} 65}
61
62async {
63 slog 1, "accepting connections";
64 while () {
65 $connections->down;
66 push @fh, $port->accept;
67 #slog 3, "accepted @$connections ".scalar(@pool);
68 if (@pool) {
69 (pop @pool)->ready;
70 } else {
71 async \&handler;
72 }
73
74 }
75};
76
77loop;
78print "ende\n";#d#
79 66
80package conn; 67package conn;
81 68
82use Socket; 69use Socket;
83use HTTP::Date; 70use HTTP::Date;
84 71
85sub new { 72sub new {
86 my $class = shift; 73 my $class = shift;
87 my $fh = shift; 74 my $fh = shift;
88 my (undef, $iaddr) = unpack_sockaddr_in $fh->getpeername 75 my (undef, $iaddr) = unpack_sockaddr_in $fh->peername
89 or $self->err(500, "unable to get peername"); 76 or $self->err(500, "unable to get peername");
90 $self->{remote_address} = inet_ntoa $iaddr; 77 $self->{remote_address} = inet_ntoa $iaddr;
91 bless { fh => $fh }, $class; 78 bless { fh => $fh }, $class;
92} 79}
93 80
… …
146 ([^\040]+) \040+ 133 ([^\040]+) \040+
147 HTTP\/([0-9]+\.[0-9]+) 134 HTTP\/([0-9]+\.[0-9]+)
148 \015\012/gx 135 \015\012/gx
149 or $self->err(403, "method not allowed", { Allow => "GET,HEAD" }); 136 or $self->err(403, "method not allowed", { Allow => "GET,HEAD" });
150 137
151 $2 ne "1.0" 138 $2 < 2
152 or $self->err(506, "http protocol version not supported"); 139 or $self->err(506, "http protocol version not supported");
153 140
154 $self->{method} = $1; 141 $self->{method} = $1;
155 $self->{uri} = $2; 142 $self->{uri} = $2;
156 143
… …
159 my (%hdr, $h, $v); 146 my (%hdr, $h, $v);
160 147
161 $hdr{lc $1} .= ",$2" 148 $hdr{lc $1} .= ",$2"
162 while $req =~ /\G 149 while $req =~ /\G
163 ([^:\000-\040]+): 150 ([^:\000-\040]+):
164 [\008\040]* 151 [\011\040]*
165 ((?: [^\015\012]+ | \015\012[\008\040] )*) 152 ((?: [^\015\012]+ | \015\012[\011\040] )*)
166 \015\012 153 \015\012
167 /gxc; 154 /gxc;
168 155
169 $req =~ /\G\015\012$/ 156 $req =~ /\G\015\012$/
170 or $self->err(400, "bad request"); 157 or $self->err(400, "bad request");
… …
201 $self->{path} = "$::DOCROOT/$host$uri"; 188 $self->{path} = "$::DOCROOT/$host$uri";
202} 189}
203 190
204sub server_address { 191sub server_address {
205 my $self = shift; 192 my $self = shift;
206 my ($port, $iaddr) = unpack_sockaddr_in $self->{fh}->getsockname 193 my ($port, $iaddr) = unpack_sockaddr_in $self->{fh}->sockname
207 or $self->err(500, "unable to get socket name"); 194 or $self->err(500, "unable to get socket name");
208 ((inet_ntoa $iaddr), $port); 195 ((inet_ntoa $iaddr), $port);
209} 196}
210 197
211sub server_host { 198sub server_host {
… …
227 } 214 }
228 $port = $port == 80 ? "" : ":$port"; 215 $port = $port == 80 ? "" : ":$port";
229 $host.$port; 216 $host.$port;
230} 217}
231 218
219# no, this doesn't do cgi, but it's close enough
220# for the no-longer-used directory indexing script.
232sub _cgi { 221sub _cgi {
233 my $self = shift; 222 my $self = shift;
234 my $path = shift; 223 my $path = shift;
235 my $fh; 224 my $fh;
236 225
… …
310 ($l, $h) = ($1, ($2 ne "" || $2 >= $length) ? $2 : $length - 1); 299 ($l, $h) = ($1, ($2 ne "" || $2 >= $length) ? $2 : $length - 1);
311 } else { 300 } else {
312 ($l, $h) = (0, $length - 1); 301 ($l, $h) = (0, $length - 1);
313 goto ignore; 302 goto ignore;
314 } 303 }
315 goto satisfiable if $l >= 0 && $l < $length && $h >= 0 && $h > $l; 304 goto satisfiable if $l >= 0 && $l < $length && $h >= 0 && $h >= $l;
316 } 305 }
317 $hdr->{"Content-Range"} = "bytes */$length"; 306 $hdr->{"Content-Range"} = "bytes */$length";
318 $self->err(416, "not satisfiable", $hdr); 307 $self->err(416, "not satisfiable", $hdr);
319 308
320satisfiable: 309satisfiable:
… …
356 } 345 }
357 } 346 }
358 347
359 close $fh; 348 close $fh;
360} 349}
350

Diff Legend

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