| 1 | #!/usr/bin/perl |
|
|
| 2 | |
|
|
| 3 | use Coro; |
1 | use Coro; |
| 4 | use Coro::Semaphore; |
2 | use Coro::Semaphore; |
| 5 | use Coro::Event; |
3 | use Coro::Event; |
| 6 | use Coro::Socket; |
4 | use Coro::Socket; |
| 7 | |
5 | |
| … | |
… | |
| 30 | my $connections = new Coro::Semaphore $MAX_CONNECTS; |
28 | my $connections = new Coro::Semaphore $MAX_CONNECTS; |
| 31 | |
29 | |
| 32 | my @fh; |
30 | my @fh; |
| 33 | my @pool; |
31 | my @pool; |
| 34 | |
32 | |
|
|
33 | # one "execution thread" |
| 35 | sub handler { |
34 | sub handler { |
| 36 | while () { |
35 | while () { |
| 37 | my $fh = pop @fh; |
36 | my $fh = pop @fh; |
| 38 | if ($fh) { |
37 | if ($fh) { |
| 39 | eval { |
38 | eval { |
| … | |
… | |
| 48 | schedule; |
47 | schedule; |
| 49 | } |
48 | } |
| 50 | } |
49 | } |
| 51 | } |
50 | } |
| 52 | |
51 | |
|
|
52 | # the "main thread" |
| 53 | async { |
53 | async { |
| 54 | slog 1, "accepting connections"; |
54 | slog 1, "accepting connections"; |
| 55 | while () { |
55 | while () { |
| 56 | $connections->down; |
56 | $connections->down; |
| 57 | push @fh, $port->accept; |
57 | push @fh, $port->accept; |
| 58 | #slog 3, "accepted @$connections ".scalar(@pool); |
58 | #slog 3, "accepted @$connections ".scalar(@pool); |
|
|
59 | $::NOW = time; |
| 59 | if (@pool) { |
60 | if (@pool) { |
| 60 | (pop @pool)->ready; |
61 | (pop @pool)->ready; |
| 61 | } else { |
62 | } else { |
| 62 | async \&handler; |
63 | async \&handler; |
| 63 | } |
64 | } |
| … | |
… | |
| 70 | |
71 | |
| 71 | package conn; |
72 | package conn; |
| 72 | |
73 | |
| 73 | use Socket; |
74 | use Socket; |
| 74 | use HTTP::Date; |
75 | use HTTP::Date; |
|
|
76 | use Convert::Scalar 'weaken'; |
|
|
77 | |
|
|
78 | our %conn; # $conn{ip}{fh} => connobj |
|
|
79 | our %blocked; |
| 75 | |
80 | |
| 76 | sub new { |
81 | sub new { |
| 77 | my $class = shift; |
82 | my $class = shift; |
| 78 | my $fh = shift; |
83 | my $fh = shift; |
|
|
84 | my $self = bless { fh => $fh }, $class; |
| 79 | my (undef, $iaddr) = unpack_sockaddr_in $fh->getpeername |
85 | my (undef, $iaddr) = unpack_sockaddr_in $fh->getpeername |
| 80 | or $self->err(500, "unable to get peername"); |
86 | or $self->err(500, "unable to get peername"); |
| 81 | $self->{remote_address} = inet_ntoa $iaddr; |
87 | $self->{remote_addr} = inet_ntoa $iaddr; |
| 82 | bless { fh => $fh }, $class; |
88 | |
|
|
89 | # enter ourselves into various lists |
|
|
90 | weaken ($conn{$self->{remote_addr}}{$self*1} = $self); |
|
|
91 | |
|
|
92 | print "$self->{remote_addr}: ".($self*1)." > ".%{$conn{$self->{remote_addr}}},"\n"; |
|
|
93 | $self; |
|
|
94 | } |
|
|
95 | |
|
|
96 | sub DESTROY { |
|
|
97 | my $self = shift; |
|
|
98 | delete $conn{$self->{remote_addr}}{$self*1}; |
|
|
99 | delete $uri{$self->{uri}}{$self*1}; |
| 83 | } |
100 | } |
| 84 | |
101 | |
| 85 | sub slog { |
102 | sub slog { |
| 86 | main::slog(@_); |
103 | main::slog(@_); |
| 87 | } |
104 | } |
| 88 | |
105 | |
| 89 | sub print_response { |
106 | sub print_response { |
| 90 | my ($self, $code, $msg, $hdr, $content) = @_; |
107 | my ($self, $code, $msg, $hdr, $content) = @_; |
| 91 | my $res = "HTTP/1.0 $code $msg\015\012"; |
108 | my $res = "HTTP/1.0 $code $msg\015\012"; |
| 92 | |
109 | |
| 93 | $hdr->{Date} = time2str time; # slow? nah. |
110 | $hdr->{Date} = time2str $::NOW; # slow? nah. |
| 94 | |
111 | |
| 95 | while (my ($h, $v) = each %$hdr) { |
112 | while (my ($h, $v) = each %$hdr) { |
| 96 | $res .= "$h: $v\015\012" |
113 | $res .= "$h: $v\015\012" |
| 97 | } |
114 | } |
| 98 | $res .= "\015\012$content" if defined $content; |
115 | $res .= "\015\012$content" if defined $content; |
|
|
116 | |
|
|
117 | print STDERR "$self->{remote_addr} \"$self->{uri}\" $code ".$hdr->{"Content-Length"}." \"$self->{h}{referer}\"\n";#d# |
| 99 | |
118 | |
| 100 | print {$self->{fh}} $res; |
119 | print {$self->{fh}} $res; |
| 101 | } |
120 | } |
| 102 | |
121 | |
| 103 | sub err { |
122 | sub err { |
| … | |
… | |
| 115 | $self->print_response($code, $msg, $hdr, $content); |
134 | $self->print_response($code, $msg, $hdr, $content); |
| 116 | |
135 | |
| 117 | die bless {}, err::; |
136 | die bless {}, err::; |
| 118 | } |
137 | } |
| 119 | |
138 | |
|
|
139 | sub err_blocked { |
|
|
140 | my $self = shift; |
|
|
141 | my $ip = $self->{remote_addr}; |
|
|
142 | my $time = time2str $blocked{$ip} = $::NOW + $::BLOCKTIME; |
|
|
143 | $self->err(403, "too many connections", |
|
|
144 | { "Retry-After" => $::BLOCKTIME }, |
|
|
145 | <<EOF); |
|
|
146 | You have been blocked because you opened too many connections. You |
|
|
147 | may retry at $time. Until then, |
|
|
148 | every new access will renew the block. |
|
|
149 | EOF |
|
|
150 | } |
|
|
151 | |
| 120 | sub handle { |
152 | sub handle { |
| 121 | my $self = shift; |
153 | my $self = shift; |
| 122 | my $fh = $self->{fh}; |
154 | my $fh = $self->{fh}; |
| 123 | |
155 | |
| 124 | #while() { |
156 | #while() { |
| … | |
… | |
| 129 | my $req = $fh->readline("\015\012\015\012"); |
161 | my $req = $fh->readline("\015\012\015\012"); |
| 130 | $fh->timeout($::RES_TIMEOUT); |
162 | $fh->timeout($::RES_TIMEOUT); |
| 131 | |
163 | |
| 132 | defined $req or |
164 | defined $req or |
| 133 | $self->err(408, "request timeout"); |
165 | $self->err(408, "request timeout"); |
|
|
166 | |
|
|
167 | my $ip = $self->{remote_addr}; |
|
|
168 | |
|
|
169 | if ($blocked{$ip}) { |
|
|
170 | $self->err_blocked($blocked{$ip}) |
|
|
171 | if $blocked{$ip} > $::NOW; |
|
|
172 | |
|
|
173 | delete $blocked{$ip}; |
|
|
174 | } |
|
|
175 | |
|
|
176 | if (%{$conn{$ip}} > $::MAX_CONN_IP) { |
|
|
177 | $self->slog("blocked ip $ip"); |
|
|
178 | $self->err_blocked; |
|
|
179 | } |
| 134 | |
180 | |
| 135 | $req =~ /^(?:\015\012)? |
181 | $req =~ /^(?:\015\012)? |
| 136 | (GET|HEAD) \040+ |
182 | (GET|HEAD) \040+ |
| 137 | ([^\040]+) \040+ |
183 | ([^\040]+) \040+ |
| 138 | HTTP\/([0-9]+\.[0-9]+) |
184 | HTTP\/([0-9]+\.[0-9]+) |
| … | |
… | |
| 164 | while ($h, $v) = each %hdr; |
210 | while ($h, $v) = each %hdr; |
| 165 | } |
211 | } |
| 166 | |
212 | |
| 167 | $self->{server_port} = $self->{h}{host} =~ s/:([0-9]+)$// ? $1 : 80; |
213 | $self->{server_port} = $self->{h}{host} =~ s/:([0-9]+)$// ? $1 : 80; |
| 168 | |
214 | |
|
|
215 | weaken ($uri{$self->{uri}}{$self*1} = $self); |
|
|
216 | |
| 169 | $self->map_uri; |
217 | $self->map_uri; |
|
|
218 | |
|
|
219 | Coro::Event::do_timer(after => 5); |
|
|
220 | |
| 170 | $self->respond; |
221 | $self->respond; |
| 171 | #} |
222 | #} |
| 172 | } |
223 | } |
| 173 | |
224 | |
| 174 | # uri => path mapping |
225 | # uri => path mapping |
| … | |
… | |
| 347 | } |
398 | } |
| 348 | } |
399 | } |
| 349 | |
400 | |
| 350 | close $fh; |
401 | close $fh; |
| 351 | } |
402 | } |
|
|
403 | |
|
|
404 | 1; |
