| 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 | |
| 3 | use Coro; |
8 | use Coro; |
| 4 | use Coro::Semaphore; |
9 | use Coro::Semaphore; |
| 5 | use Coro::Event; |
10 | use Coro::Event; |
| 6 | use Coro::Socket; |
11 | use Coro::Socket; |
| … | |
… | |
| 57 | schedule; |
62 | schedule; |
| 58 | } |
63 | } |
| 59 | } |
64 | } |
| 60 | } |
65 | } |
| 61 | |
66 | |
| 62 | async { |
67 | async { loop }; |
|
|
68 | |
| 63 | slog 1, "accepting connections"; |
69 | slog 1, "accepting connections"; |
| 64 | while () { |
70 | while () { |
| 65 | $connections->down; |
71 | $connections->down; |
| 66 | push @fh, $port->accept; |
72 | push @fh, $port->accept; |
| 67 | #slog 3, "accepted @$connections ".scalar(@pool); |
73 | #slog 3, "accepted @$connections ".scalar(@pool); |
| 68 | if (@pool) { |
74 | if (@pool) { |
| 69 | (pop @pool)->ready; |
75 | (pop @pool)->ready; |
| 70 | } else { |
76 | } else { |
| 71 | async \&handler; |
77 | async \&handler; |
| 72 | } |
|
|
| 73 | |
|
|
| 74 | } |
78 | } |
| 75 | }; |
|
|
| 76 | |
79 | |
| 77 | loop; |
80 | } |
| 78 | print "ende\n";#d# |
|
|
| 79 | |
81 | |
| 80 | package conn; |
82 | package conn; |
| 81 | |
83 | |
| 82 | use Socket; |
84 | use Socket; |
| 83 | use HTTP::Date; |
85 | use HTTP::Date; |
| 84 | |
86 | |
| 85 | sub new { |
87 | sub new { |
| 86 | my $class = shift; |
88 | my $class = shift; |
| 87 | my $fh = shift; |
89 | my $fh = shift; |
| 88 | my (undef, $iaddr) = unpack_sockaddr_in $fh->getpeername |
90 | my (undef, $iaddr) = unpack_sockaddr_in $fh->peername |
| 89 | or $self->err(500, "unable to get peername"); |
91 | or $self->err(500, "unable to get peername"); |
| 90 | $self->{remote_address} = inet_ntoa $iaddr; |
92 | $self->{remote_address} = inet_ntoa $iaddr; |
| 91 | bless { fh => $fh }, $class; |
93 | bless { fh => $fh }, $class; |
| 92 | } |
94 | } |
| 93 | |
95 | |
| … | |
… | |
| 146 | ([^\040]+) \040+ |
148 | ([^\040]+) \040+ |
| 147 | HTTP\/([0-9]+\.[0-9]+) |
149 | HTTP\/([0-9]+\.[0-9]+) |
| 148 | \015\012/gx |
150 | \015\012/gx |
| 149 | or $self->err(403, "method not allowed", { Allow => "GET,HEAD" }); |
151 | or $self->err(403, "method not allowed", { Allow => "GET,HEAD" }); |
| 150 | |
152 | |
| 151 | $2 ne "1.0" |
153 | $2 < 2 |
| 152 | or $self->err(506, "http protocol version not supported"); |
154 | or $self->err(506, "http protocol version not supported"); |
| 153 | |
155 | |
| 154 | $self->{method} = $1; |
156 | $self->{method} = $1; |
| 155 | $self->{uri} = $2; |
157 | $self->{uri} = $2; |
| 156 | |
158 | |
| … | |
… | |
| 159 | my (%hdr, $h, $v); |
161 | my (%hdr, $h, $v); |
| 160 | |
162 | |
| 161 | $hdr{lc $1} .= ",$2" |
163 | $hdr{lc $1} .= ",$2" |
| 162 | while $req =~ /\G |
164 | while $req =~ /\G |
| 163 | ([^:\000-\040]+): |
165 | ([^:\000-\040]+): |
| 164 | [\008\040]* |
166 | [\011\040]* |
| 165 | ((?: [^\015\012]+ | \015\012[\008\040] )*) |
167 | ((?: [^\015\012]+ | \015\012[\011\040] )*) |
| 166 | \015\012 |
168 | \015\012 |
| 167 | /gxc; |
169 | /gxc; |
| 168 | |
170 | |
| 169 | $req =~ /\G\015\012$/ |
171 | $req =~ /\G\015\012$/ |
| 170 | or $self->err(400, "bad request"); |
172 | or $self->err(400, "bad request"); |
| … | |
… | |
| 201 | $self->{path} = "$::DOCROOT/$host$uri"; |
203 | $self->{path} = "$::DOCROOT/$host$uri"; |
| 202 | } |
204 | } |
| 203 | |
205 | |
| 204 | sub server_address { |
206 | sub server_address { |
| 205 | my $self = shift; |
207 | my $self = shift; |
| 206 | my ($port, $iaddr) = unpack_sockaddr_in $self->{fh}->getsockname |
208 | my ($port, $iaddr) = unpack_sockaddr_in $self->{fh}->sockname |
| 207 | or $self->err(500, "unable to get socket name"); |
209 | or $self->err(500, "unable to get socket name"); |
| 208 | ((inet_ntoa $iaddr), $port); |
210 | ((inet_ntoa $iaddr), $port); |
| 209 | } |
211 | } |
| 210 | |
212 | |
| 211 | sub server_host { |
213 | sub server_host { |
| … | |
… | |
| 227 | } |
229 | } |
| 228 | $port = $port == 80 ? "" : ":$port"; |
230 | $port = $port == 80 ? "" : ":$port"; |
| 229 | $host.$port; |
231 | $host.$port; |
| 230 | } |
232 | } |
| 231 | |
233 | |
|
|
234 | # no, this doesn't do cgi, but it's close enough |
|
|
235 | # for the no-longer-used directory indexing script. |
| 232 | sub _cgi { |
236 | sub _cgi { |
| 233 | my $self = shift; |
237 | my $self = shift; |
| 234 | my $path = shift; |
238 | my $path = shift; |
| 235 | my $fh; |
239 | my $fh; |
| 236 | |
240 | |
| … | |
… | |
| 310 | ($l, $h) = ($1, ($2 ne "" || $2 >= $length) ? $2 : $length - 1); |
314 | ($l, $h) = ($1, ($2 ne "" || $2 >= $length) ? $2 : $length - 1); |
| 311 | } else { |
315 | } else { |
| 312 | ($l, $h) = (0, $length - 1); |
316 | ($l, $h) = (0, $length - 1); |
| 313 | goto ignore; |
317 | goto ignore; |
| 314 | } |
318 | } |
| 315 | goto satisfiable if $l >= 0 && $l < $length && $h >= 0 && $h > $l; |
319 | goto satisfiable if $l >= 0 && $l < $length && $h >= 0 && $h >= $l; |
| 316 | } |
320 | } |
| 317 | $hdr->{"Content-Range"} = "bytes */$length"; |
321 | $hdr->{"Content-Range"} = "bytes */$length"; |
| 318 | $self->err(416, "not satisfiable", $hdr); |
322 | $self->err(416, "not satisfiable", $hdr); |
| 319 | |
323 | |
| 320 | satisfiable: |
324 | satisfiable: |
| … | |
… | |
| 356 | } |
360 | } |
| 357 | } |
361 | } |
| 358 | |
362 | |
| 359 | close $fh; |
363 | close $fh; |
| 360 | } |
364 | } |
|
|
365 | |
