Commit | Line | Data |
2cdfbf5e |
1 | package Catalyst::Engine::HTTP::Daemon; |
2 | |
3 | use strict; |
4 | use base 'Catalyst::Engine::HTTP::Base'; |
5 | |
8a0ec4fd |
6 | use IO::Select; |
89f2bd8d |
7 | use IO::Socket; |
2cdfbf5e |
8 | |
73ad9769 |
9 | BEGIN { |
10 | |
11 | if ( $^O eq 'MSWin32' ) { |
12 | |
13 | *EINPROGRESS = sub { 10036 }; |
14 | *EWOULDBLOCK = sub { 10035 }; |
15 | *F_GETFL = sub { 0 }; |
16 | *F_SETFL = sub { 0 }; |
17 | |
18 | *IO::Socket::blocking = sub { |
19 | my ( $self, $blocking ) = @_; |
20 | my $nonblocking = $blocking ? 0 : 1; |
21 | ioctl( $self, 0x8004667e, \$nonblocking ); |
22 | }; |
23 | } |
24 | |
25 | else { |
26 | Errno->require; |
27 | Errno->import( qw[EWOULDBLOCK EINPROGRESS] ); |
28 | } |
29 | } |
30 | |
2cdfbf5e |
31 | =head1 NAME |
32 | |
33 | Catalyst::Engine::HTTP::Daemon - Catalyst HTTP Daemon Engine |
34 | |
35 | =head1 SYNOPSIS |
36 | |
37 | A script using the Catalyst::Engine::HTTP::Daemon module might look like: |
38 | |
39 | #!/usr/bin/perl -w |
40 | |
41 | BEGIN { $ENV{CATALYST_ENGINE} = 'HTTP::Daemon' } |
42 | |
43 | use strict; |
44 | use lib '/path/to/MyApp/lib'; |
45 | use MyApp; |
46 | |
47 | MyApp->run; |
48 | |
49 | =head1 DESCRIPTION |
50 | |
51 | This is the Catalyst engine specialized for development and testing. |
52 | |
53 | =head1 OVERLOADED METHODS |
54 | |
55 | This class overloads some methods from C<Catalyst::Engine::HTTP::Base>. |
56 | |
57 | =over 4 |
58 | |
bce14c0d |
59 | =item $c->handler |
2cdfbf5e |
60 | |
61 | =cut |
62 | |
bce14c0d |
63 | sub handler { |
8a0ec4fd |
64 | my ( $class, $request, $response, $client ) = @_; |
bce14c0d |
65 | |
8a0ec4fd |
66 | $request->uri->scheme('http'); # Force URI::http |
67 | $request->uri->host( $request->header('Host') || $client->sockhost ); |
68 | $request->uri->port( $client->sockport ); |
bce14c0d |
69 | |
8a0ec4fd |
70 | my $http = Catalyst::Engine::HTTP::Base::struct->new( |
71 | address => $client->peerhost, |
72 | request => $request, |
73 | response => $response |
74 | ); |
bce14c0d |
75 | |
8a0ec4fd |
76 | $class->SUPER::handler($http); |
bce14c0d |
77 | } |
78 | |
79 | =item $c->run |
80 | |
81 | =cut |
2cdfbf5e |
82 | |
83 | sub run { |
84 | my $class = shift; |
85 | my $port = shift || 3000; |
8a0ec4fd |
86 | |
bce14c0d |
87 | $SIG{'PIPE'} = 'IGNORE'; |
2cdfbf5e |
88 | |
296e7663 |
89 | my $daemon = Catalyst::Engine::HTTP::Daemon::Catalyst->new( |
89f2bd8d |
90 | Listen => SOMAXCONN, |
2cdfbf5e |
91 | LocalPort => $port, |
92 | ReuseAddr => 1, |
8a0ec4fd |
93 | Timeout => 5 |
2cdfbf5e |
94 | ); |
8a0ec4fd |
95 | |
b4ca0ee8 |
96 | unless ( defined $daemon ) { |
8a0ec4fd |
97 | die(qq/Failed to create daemon. Reason: '$!'/); |
b4ca0ee8 |
98 | } |
2cdfbf5e |
99 | |
2cdfbf5e |
100 | my $base = URI->new( $daemon->url )->canonical; |
101 | |
102 | printf( "You can connect to your server at %s\n", $base ); |
103 | |
8a0ec4fd |
104 | my $select = IO::Select->new($daemon); |
105 | |
106 | while (1) { |
107 | |
61b19d8b |
108 | for my $client ( $select->can_read(0.01) ) { |
8a0ec4fd |
109 | |
110 | if ( $client == $daemon ) { |
111 | $client = $daemon->accept; |
c7b7c423 |
112 | $client->timestamp = time; |
8a0ec4fd |
113 | $client->blocking(0); |
114 | $select->add($client); |
115 | } |
116 | |
117 | else { |
118 | next if $client->request; |
119 | next if $client->response; |
120 | |
ad1fb680 |
121 | my $nread = $client->sysread( my $buf, 4096 ); |
abdcb6e4 |
122 | |
ad1fb680 |
123 | unless ( defined($nread) && length($buf) ) { |
abdcb6e4 |
124 | |
8a0ec4fd |
125 | $select->remove($client); |
126 | $client->close; |
127 | |
128 | next; |
129 | } |
130 | |
abdcb6e4 |
131 | $client->request_buffer .= $buf; |
c7b7c423 |
132 | |
133 | if ( my $request = $client->get_request ) { |
134 | $client->request = $request; |
135 | $client->timestamp = time |
136 | } |
8a0ec4fd |
137 | } |
138 | } |
139 | |
140 | for my $client ( $select->handles ) { |
141 | |
142 | next if $client == $daemon; |
c7b7c423 |
143 | |
144 | if ( ( time - $client->timestamp ) > 60 ) { |
145 | |
146 | $select->remove($client); |
147 | $client->close; |
148 | |
149 | next; |
150 | } |
151 | |
8a0ec4fd |
152 | next if $client->response; |
153 | next unless $client->request; |
154 | |
abdcb6e4 |
155 | $client->response = HTTP::Response->new; |
156 | $client->response->protocol( $client->request->protocol ); |
c7b7c423 |
157 | |
abdcb6e4 |
158 | $class->handler( $client->request, $client->response, $client ); |
8a0ec4fd |
159 | } |
160 | |
61b19d8b |
161 | for my $client ( $select->can_write(0.01) ) { |
8a0ec4fd |
162 | |
163 | next unless $client->response; |
164 | |
abdcb6e4 |
165 | unless ( $client->response_buffer ) { |
61b19d8b |
166 | |
167 | my $connection = $client->request->header('Connection'); |
168 | |
169 | if ( $connection && $connection =~ /Keep-Alive/i ) { |
170 | $client->response->header( 'Connection' => 'Keep-Alive' ); |
171 | $client->response->header( 'Keep-Alive' => 'timeout=60, max=100' ); |
172 | } |
173 | |
abdcb6e4 |
174 | $client->response_buffer = $client->response->as_string; |
175 | $client->response_offset = 0; |
176 | } |
177 | |
ad1fb680 |
178 | my $nwrite = $client->syswrite( $client->response_buffer, |
179 | $client->response_length, |
180 | $client->response_offset ); |
8a0ec4fd |
181 | |
ad1fb680 |
182 | unless ( defined($nwrite) ) { |
8a0ec4fd |
183 | |
8a0ec4fd |
184 | $select->remove($client); |
185 | $client->close; |
abdcb6e4 |
186 | |
187 | next; |
8a0ec4fd |
188 | } |
189 | |
ad1fb680 |
190 | $client->response_offset += $nwrite; |
c7b7c423 |
191 | |
abdcb6e4 |
192 | if ( $client->response_offset == $client->response_length ) { |
193 | |
194 | my $connection = $client->request->header('Connection'); |
195 | |
196 | unless ( $connection && $connection =~ /Keep-Alive/i ) { |
197 | $select->remove($client); |
198 | $client->close; |
199 | } |
200 | |
201 | $client->response = undef; |
202 | $client->request = undef; |
203 | $client->response_buffer = undef; |
204 | } |
8a0ec4fd |
205 | } |
2cdfbf5e |
206 | } |
207 | } |
208 | |
209 | =back |
210 | |
211 | =head1 SEE ALSO |
212 | |
8a0ec4fd |
213 | L<Catalyst>, L<Catalyst::Engine>, L<Catalyst::Engine::HTTP::Base>, |
2cdfbf5e |
214 | L<HTTP::Daemon>. |
215 | |
216 | =head1 AUTHOR |
217 | |
218 | Sebastian Riedel, C<sri@cpan.org> |
219 | Christian Hansen, C<ch@ngmedia.com> |
220 | |
221 | =head1 COPYRIGHT |
222 | |
223 | This program is free software, you can redistribute it and/or modify it under |
224 | the same terms as Perl itself. |
225 | |
226 | =cut |
227 | |
296e7663 |
228 | package Catalyst::Engine::HTTP::Daemon::Catalyst; |
2cdfbf5e |
229 | |
230 | use strict; |
231 | use base 'HTTP::Daemon'; |
232 | |
8a0ec4fd |
233 | sub accept { |
234 | return shift->SUPER::accept('Catalyst::Engine::HTTP::Daemon::Client'); |
235 | } |
236 | |
2cdfbf5e |
237 | sub product_tokens { |
8a0ec4fd |
238 | return "Catalyst/$Catalyst::VERSION"; |
239 | } |
240 | |
241 | package Catalyst::Engine::HTTP::Daemon::Client; |
242 | |
243 | use strict; |
244 | use base 'HTTP::Daemon::ClientConn'; |
245 | |
abdcb6e4 |
246 | sub request : lvalue { |
8a0ec4fd |
247 | my $self = shift; |
abdcb6e4 |
248 | ${*$self}{'request'}; |
8a0ec4fd |
249 | } |
250 | |
abdcb6e4 |
251 | sub request_buffer : lvalue { |
8a0ec4fd |
252 | my $self = shift; |
abdcb6e4 |
253 | ${*$self}{'httpd_rbuf'}; |
254 | } |
8a0ec4fd |
255 | |
abdcb6e4 |
256 | sub response : lvalue { |
257 | my $self = shift; |
258 | ${*$self}{'response'}; |
8a0ec4fd |
259 | } |
260 | |
abdcb6e4 |
261 | sub response_buffer : lvalue { |
8a0ec4fd |
262 | my $self = shift; |
abdcb6e4 |
263 | ${*$self}{'httpd_wbuf'}; |
264 | } |
8a0ec4fd |
265 | |
abdcb6e4 |
266 | sub response_length { |
267 | my $self = shift; |
268 | return length( $self->response_buffer ); |
269 | } |
8a0ec4fd |
270 | |
abdcb6e4 |
271 | sub response_offset : lvalue { |
272 | my $self = shift; |
273 | ${*$self}{'httpd_woffset'}; |
2cdfbf5e |
274 | } |
275 | |
c7b7c423 |
276 | sub timestamp : lvalue { |
277 | my $self = shift; |
278 | ${*$self}{'timestamp'}; |
279 | } |
abdcb6e4 |
280 | |
2cdfbf5e |
281 | 1; |