blib/lib/EmbedIT/WebIT.pm | |||
---|---|---|---|
Criterion | Covered | Total | % |
statement | 33 | 1135 | 2.9 |
branch | 0 | 478 | 0.0 |
condition | 0 | 45 | 0.0 |
subroutine | 11 | 52 | 21.1 |
pod | 4 | 4 | 100.0 |
total | 48 | 1714 | 2.8 |
line | stmt | bran | cond | sub | pod | time | code |
---|---|---|---|---|---|---|---|
1 | package EmbedIT::WebIT; | ||||||
2 | |||||||
3 | 1 | 1 | 41622 | use strict; | |||
1 | 3 | ||||||
1 | 51 | ||||||
4 | 1 | 1 | 1063 | use POSIX; | |||
1 | 10195 | ||||||
1 | 11 | ||||||
5 | 1 | 1 | 6848 | use HTTP::Date qw(time2str time2iso); | |||
1 | 12432 | ||||||
1 | 3861 | ||||||
6 | 1 | 1 | 1075 | use IO::Socket; | |||
1 | 37021 | ||||||
1 | 5 | ||||||
7 | 1 | 1 | 1861 | use IO::Select; | |||
1 | 2066 | ||||||
1 | 68 | ||||||
8 | 1 | 1 | 1089 | use LWP::MediaTypes qw(guess_media_type read_media_types); | |||
1 | 21108 | ||||||
1 | 136 | ||||||
9 | 1 | 1 | 985 | use IPC::Open3; | |||
1 | 3224 | ||||||
1 | 66 | ||||||
10 | 1 | 1 | 942 | use Taint::Runtime qw(disable); | |||
1 | 1756 | ||||||
1 | 6 | ||||||
11 | 1 | 1 | 172 | no strict "refs"; | |||
1 | 2 | ||||||
1 | 61 | ||||||
12 | |||||||
13 | our $VERSION = '1.6.3'; | ||||||
14 | our $CRLF = "\015\012"; | ||||||
15 | |||||||
16 | 1 | 1 | 6 | use vars qw(@childs $data); | |||
1 | 2 | ||||||
1 | 10064 | ||||||
17 | |||||||
18 | # -------------------------------------------------------------------------------------- | ||||||
19 | # Public functions | ||||||
20 | # -------------------------------------------------------------------------------------- | ||||||
21 | |||||||
22 | # -------------------------------------------------------------------------------------- | ||||||
23 | # Create a new web server object | ||||||
24 | # | ||||||
25 | |||||||
26 | sub new { | ||||||
27 | 0 | 0 | 1 | my ($class, %conf) = @_; | |||
28 | |||||||
29 | 0 | 0 | if (not defined %conf) { | ||||
30 | 0 | %conf = (); | |||||
31 | } | ||||||
32 | |||||||
33 | 0 | EmbedIT::WebIT::__fix_conf(\%conf); | |||||
34 | 0 | EmbedIT::WebIT::__clean_env(\%conf); | |||||
35 | 0 | EmbedIT::WebIT::__report(\%conf); | |||||
36 | |||||||
37 | 0 | my $start_time = time(); | |||||
38 | 0 | my $has_cgi_pm = undef; | |||||
39 | |||||||
40 | 0 | my $logging = $conf{"LOG_METHOD"}; | |||||
41 | |||||||
42 | 0 | read_media_types($conf{"MIME_TYPES"}); | |||||
43 | 0 | Taint::Runtime::taint_stop; | |||||
44 | |||||||
45 | #open STDIN, ' | ||||||
46 | #open STDOUT, '>>/dev/null'; | ||||||
47 | #open STDERR, '>>/dev/null'; | ||||||
48 | |||||||
49 | 0 | my @childs = (); | |||||
50 | 0 | $SIG{CHLD} = 'IGNORE'; | |||||
51 | 0 | $SIG{SIGPIPE} = 'IGNORE'; | |||||
52 | 0 | $SIG{TERM} = \&__stop_server; | |||||
53 | 0 | my $Server = undef; | |||||
54 | |||||||
55 | 0 | 0 | if (defined $conf{"USE_SSL"}) { | ||||
56 | 0 | $Server = EmbedIT::WebIT::__start_server_ssl(\%conf); | |||||
57 | } else { | ||||||
58 | 0 | $Server = EmbedIT::WebIT::__start_server_socket(\%conf); | |||||
59 | } | ||||||
60 | |||||||
61 | 0 | 0 | if (not defined $Server) { | ||||
62 | 0 | &$logging("Unable to open socket"); | |||||
63 | 0 | return; | |||||
64 | } | ||||||
65 | |||||||
66 | 0 | 0 | if (defined $conf{"RUN_AS_USER"}) { | ||||
67 | 0 | my $UID = EmbedIT::WebIT::__get_uid($conf{"RUN_AS_USER"}); | |||||
68 | 0 | $> = $UID; | |||||
69 | } | ||||||
70 | 0 | 0 | if (defined $conf{"RUN_AS_GROUP"}) { | ||||
71 | 0 | my $GID = EmbedIT::WebIT::__get_gid($conf{"RUN_AS_GROUP"}); | |||||
72 | 0 | $) = "$GID $GID"; | |||||
73 | 0 | $( = $GID; | |||||
74 | } | ||||||
75 | |||||||
76 | 0 | my $self = { | |||||
77 | SERVER => $Server, | ||||||
78 | START_TIME => $start_time, | ||||||
79 | HAS_CGI_PM => $has_cgi_pm, | ||||||
80 | CONF => \%conf, | ||||||
81 | }; | ||||||
82 | |||||||
83 | 0 | bless $self; | |||||
84 | 0 | return $self; | |||||
85 | } | ||||||
86 | |||||||
87 | # -------------------------------------------------------------------------------------- | ||||||
88 | # Execute the server | ||||||
89 | # | ||||||
90 | |||||||
91 | sub execute { | ||||||
92 | 0 | 0 | 1 | my ($self) = @_; | |||
93 | |||||||
94 | 0 | my $logging = $self->{CONF}->{"LOG_METHOD"}; | |||||
95 | |||||||
96 | 0 | 0 | if (defined $self->{SERVER}) { | ||||
97 | 0 | $0 = $self->{CONF}->{"PROC_PREFIX"} . " starting "; | |||||
98 | 0 | $self->__fork_workers(); | |||||
99 | 0 | 0 | if ($self->{CONF}->{"SERVERS"} == 0) { | ||||
100 | 0 | $0 = $self->{CONF}->{"PROC_PREFIX"} . " server (" . $self->{CONF}->{"SERVER_IP"} . ":" . $self->{CONF}->{"SERVER_PORT"} . ")"; | |||||
101 | 0 | $self->__single_server(0, 1); | |||||
102 | } else { | ||||||
103 | 0 | $self->__fork_servers(); | |||||
104 | 0 | $0 = $self->{CONF}->{"PROC_PREFIX"} . " master (" . $self->{CONF}->{"SERVER_IP"} . ":" . $self->{CONF}->{"SERVER_PORT"} . ")"; | |||||
105 | 0 | waitpid(-1,0); | |||||
106 | } | ||||||
107 | 0 | &$logging("Shuting down"); | |||||
108 | } else { | ||||||
109 | 0 | &$logging("Failed to start"); | |||||
110 | } | ||||||
111 | } | ||||||
112 | |||||||
113 | # -------------------------------------------------------------------------------------- | ||||||
114 | # Get the process specific data | ||||||
115 | # | ||||||
116 | |||||||
117 | sub data { | ||||||
118 | 0 | 0 | 1 | my ($self) = @_; | |||
119 | 0 | return $data; | |||||
120 | } | ||||||
121 | |||||||
122 | # -------------------------------------------------------------------------------------- | ||||||
123 | # Get the process startup time | ||||||
124 | # | ||||||
125 | |||||||
126 | sub start_time { | ||||||
127 | 0 | 0 | 1 | my ($self) = @_; | |||
128 | 0 | return $self->{START_TIME}; | |||||
129 | } | ||||||
130 | |||||||
131 | # -------------------------------------------------------------------------------------- | ||||||
132 | # Private functions | ||||||
133 | # -------------------------------------------------------------------------------------- | ||||||
134 | |||||||
135 | # -------------------------------------------------------------------------------------- | ||||||
136 | # Stop the running web server | ||||||
137 | # | ||||||
138 | |||||||
139 | sub __stop_server { | ||||||
140 | 0 | 0 | my ($self) = @_; | ||||
141 | 0 | $self->{SERVER}->close(); | |||||
142 | 0 | kill "TERM", @childs; | |||||
143 | } | ||||||
144 | |||||||
145 | # -------------------------------------------------------------------------------------- | ||||||
146 | # Fork off the servers | ||||||
147 | # | ||||||
148 | |||||||
149 | sub __fork_servers { | ||||||
150 | 0 | 0 | my ($self) = @_; | ||||
151 | 0 | my $conf = $self->{CONF}; | |||||
152 | 0 | for (my $i = 0; $i < $conf->{"SERVERS"}; $i++) { | |||||
153 | 0 | my $pid = fork(); | |||||
154 | 0 | 0 | if ($pid == 0) { | ||||
155 | 0 | $self->__single_server($i); | |||||
156 | } else { | ||||||
157 | 0 | push @childs, $pid; | |||||
158 | } | ||||||
159 | } | ||||||
160 | } | ||||||
161 | |||||||
162 | # -------------------------------------------------------------------------------------- | ||||||
163 | # Fork off the page workers | ||||||
164 | # | ||||||
165 | |||||||
166 | sub __fork_workers { | ||||||
167 | 0 | 0 | my ($self) = @_; | ||||
168 | 0 | my $conf = $self->{CONF}; | |||||
169 | 0 | 0 | if ($conf->{"FORK_CONN"}) { return; } | ||||
0 | |||||||
170 | 0 | for (my $i = 0; $i < $conf->{"WORKERS"}; $i++) { | |||||
171 | 0 | my $pid = fork(); | |||||
172 | 0 | 0 | if ($pid == 0) { | ||||
173 | 0 | $self->__single_worker($i); | |||||
174 | } else { | ||||||
175 | 0 | push @childs, $pid; | |||||
176 | } | ||||||
177 | } | ||||||
178 | } | ||||||
179 | |||||||
180 | # -------------------------------------------------------------------------------------- | ||||||
181 | # Start single server | ||||||
182 | # | ||||||
183 | |||||||
184 | sub __single_server { | ||||||
185 | 0 | 0 | my ($self, $i, $avoid) = @_; | ||||
186 | 0 | my $conf = $self->{CONF}; | |||||
187 | 0 | 0 | if ($conf->{"FORK_CONN"} == 0) { | ||||
188 | 0 | $self->__pre_fork("S$i"); | |||||
189 | } | ||||||
190 | 0 | 0 | if (not defined $avoid) { | ||||
191 | 0 | $0 = $conf->{"PROC_PREFIX"} . " listener ($i)"; | |||||
192 | 0 | @childs = (); | |||||
193 | } | ||||||
194 | 0 | 0 | if ($conf->{"FORK_CONN"} == 1) { | ||||
195 | 0 | $SIG{TERM} = \&__stop_server; | |||||
196 | 0 | $self->__fork_connections("S$i"); | |||||
197 | } else { | ||||||
198 | 0 | $self->__multiplex_connections("S$i"); | |||||
199 | } | ||||||
200 | 0 | 0 | if ($conf->{"FORK_CONN"} == 0) { | ||||
201 | 0 | $self->__post_fork("S$i"); | |||||
202 | } | ||||||
203 | 0 | exit 0; | |||||
204 | } | ||||||
205 | |||||||
206 | # -------------------------------------------------------------------------------------- | ||||||
207 | # Start single worker | ||||||
208 | # | ||||||
209 | |||||||
210 | sub __single_worker { | ||||||
211 | 0 | 0 | my ($self, $i) = @_; | ||||
212 | 0 | my $conf = $self->{CONF}; | |||||
213 | 0 | $self->__pre_fork("W$i"); | |||||
214 | 0 | $0 = $conf->{"PROC_PREFIX"} . " worker ($i)"; | |||||
215 | 0 | @childs = (); | |||||
216 | 0 | $SIG{TERM} = 'DEFAULT'; | |||||
217 | 0 | select(undef,undef,undef,undef); | |||||
218 | 0 | $self->__post_fork("W$i"); | |||||
219 | 0 | exit 0; | |||||
220 | } | ||||||
221 | |||||||
222 | # -------------------------------------------------------------------------------------- | ||||||
223 | # Report configuration | ||||||
224 | # | ||||||
225 | |||||||
226 | sub __report { | ||||||
227 | 0 | 0 | my ($conf) = @_; | ||||
228 | 0 | my $logging = $conf->{"LOG_METHOD"}; | |||||
229 | |||||||
230 | 0 | &$logging("Staring " . $conf->{"SOFTWARE"} . " web server on " . | |||||
231 | $conf->{"SERVER_IP"} . ":" . $conf->{"SERVER_PORT"} . | ||||||
232 | " with " . $conf->{"QUEUE_SIZE"} . " connection queue limit"); | ||||||
233 | |||||||
234 | 0 | 0 | if ($conf->{"USE_SSL"}) { | ||||
235 | 0 | &$logging("SSL will be used on all connections"); | |||||
236 | } | ||||||
237 | |||||||
238 | 0 | 0 | if ($conf->{"SERVERS"} > 0) { | ||||
239 | 0 | &$logging("PREFORKING " . $conf->{"SERVERS"} . " servers"); | |||||
240 | } else { | ||||||
241 | 0 | &$logging("SINGLE process server"); | |||||
242 | } | ||||||
243 | |||||||
244 | 0 | 0 | if ($conf->{"FORK_CONN"}) { | ||||
245 | 0 | &$logging("REQUESTS are forked"); | |||||
246 | } else { | ||||||
247 | 0 | &$logging("REQUESTS are multiplexed"); | |||||
248 | 0 | 0 | if ($conf->{"WORKERS"} > 0) { | ||||
249 | 0 | &$logging("PREFORKING " . $conf->{"WORKERS"} . " page workers"); | |||||
250 | } else { | ||||||
251 | 0 | &$logging("WORKERS are embeded into SERVERS"); | |||||
252 | } | ||||||
253 | } | ||||||
254 | |||||||
255 | 0 | 0 | if ($conf->{"WAIT_RESPONSE"}) { | ||||
256 | 0 | &$logging("RESPONSE will be sent normaly"); | |||||
257 | 0 | 0 | if ($conf->{"IMMED_CLOSE"}) { | ||||
258 | 0 | &$logging("CONNECTION will close immediatelly regardless of client request"); | |||||
259 | } else { | ||||||
260 | 0 | &$logging("CONNECTION will remain open per client request"); | |||||
261 | } | ||||||
262 | } else { | ||||||
263 | 0 | 0 | if (defined $conf->{"NO_WAIT_REPLY"}) { | ||||
264 | 0 | &$logging("RESPONSE " . $conf->{"NO_WAIT_REPLY"} . " will be sent before page load"); | |||||
265 | } else { | ||||||
266 | 0 | &$logging("RESPONSE 204 will be sent before page load"); | |||||
267 | } | ||||||
268 | 0 | &$logging("CONNECTION will close immediatelly regardless of client request"); | |||||
269 | } | ||||||
270 | |||||||
271 | 0 | 0 | if ($conf->{'LOG_PACKETS'}) { | ||||
0 | |||||||
272 | 0 | &$logging("PACKET contents will be logged"); | |||||
273 | } elsif ($conf->{'LOG_HEADERS'}) { | ||||||
274 | 0 | &$logging("HEADERS will be logged"); | |||||
275 | } | ||||||
276 | |||||||
277 | 0 | 0 | if (defined $conf->{"DOCUMENTS"}) { | ||||
278 | 0 | 0 | if (defined $conf->{"DOCUMENT_ROOT"}) { | ||||
279 | 0 | &$logging("EMBEDED pages with EXTERNAL pages on (" . $conf->{"DOCUMENT_ROOT"} . ")"); | |||||
280 | } else { | ||||||
281 | 0 | &$logging("EMBEDED pages"); | |||||
282 | } | ||||||
283 | } else { | ||||||
284 | 0 | &$logging("EXTERNAL pages on (" . $conf->{"DOCUMENT_ROOT"} . ")"); | |||||
285 | } | ||||||
286 | |||||||
287 | 0 | 0 | if (defined $conf->{"CGI_PATH"}) { | ||||
288 | 0 | 0 | if ($conf->{"EMBED_PERL"}) { | ||||
289 | 0 | &$logging("CGI pages on (" . $conf->{"CGI_PATH_PRINT"} . ") with PERL embeded"); | |||||
290 | } else { | ||||||
291 | 0 | &$logging("CGI pages on (" . $conf->{"CGI_PATH_PRINT"} . ")"); | |||||
292 | } | ||||||
293 | } | ||||||
294 | |||||||
295 | 0 | 0 | if (defined $conf->{"AUTH_PATH"}) { | ||||
296 | 0 | 0 | if (not defined $conf->{"AUTH_METHOD"}) { | ||||
297 | 0 | &$logging("AUTHENTICATION will always fail"); | |||||
298 | } else { | ||||||
299 | 0 | &$logging("AUTHENTICATION on (" . $conf->{"AUTH_PATH_PRINT"} . ")"); | |||||
300 | } | ||||||
301 | } else { | ||||||
302 | 0 | &$logging("AUTHENTICATION is not defined for any path"); | |||||
303 | } | ||||||
304 | |||||||
305 | 0 | 0 | if (defined $conf->{"STARTUP"}) { | ||||
306 | 0 | &$logging("STARTUP script can be found in (" . $conf->{"STARTUP"}. ")"); | |||||
307 | } | ||||||
308 | |||||||
309 | } | ||||||
310 | |||||||
311 | # -------------------------------------------------------------------------------------- | ||||||
312 | # Start a single web server | ||||||
313 | # | ||||||
314 | |||||||
315 | sub __start_server_socket { | ||||||
316 | 0 | 0 | my ($conf) = @_; | ||||
317 | 0 | 0 | return new IO::Socket::INET( LocalAddr => $conf->{"SERVER_IP"}, | ||||
318 | LocalPort => $conf->{"SERVER_PORT"}, | ||||||
319 | Proto => 'tcp', | ||||||
320 | Reuse => 1, | ||||||
321 | Listen => $conf->{"QUEUE_SIZE"}) || return undef; | ||||||
322 | } | ||||||
323 | |||||||
324 | # -------------------------------------------------------------------------------------- | ||||||
325 | # Start a single SSL web server | ||||||
326 | # | ||||||
327 | |||||||
328 | sub __start_server_ssl { | ||||||
329 | 0 | 0 | my ($conf) = @_; | ||||
330 | 0 | 0 | return new IO::Socket::INET( LocalAddr => $conf->{"SERVER_IP"}, | ||||
331 | LocalPort => $conf->{"SERVER_PORT"}, | ||||||
332 | Proto => 'tcp', | ||||||
333 | Reuse => 1, | ||||||
334 | Listen => $conf->{"QUEUE_SIZE"}) || return undef; | ||||||
335 | } | ||||||
336 | |||||||
337 | # -------------------------------------------------------------------------------------- | ||||||
338 | # Start accepting connecitons | ||||||
339 | # | ||||||
340 | |||||||
341 | sub __multiplex_connections { | ||||||
342 | 0 | 0 | my ($self, $id) = @_; | ||||
343 | 0 | my $conf = $self->{CONF}; | |||||
344 | 0 | my $d = $self->{SERVER}; | |||||
345 | |||||||
346 | 0 | $d->blocking(0); | |||||
347 | |||||||
348 | 0 | my %buffers = (); | |||||
349 | 0 | my $logging = $conf->{"DEBLOG_METHOD"}; | |||||
350 | 0 | my $read_handles = new IO::Select(); | |||||
351 | 0 | my $write_handles = new IO::Select(); | |||||
352 | 0 | $read_handles->add($d); | |||||
353 | |||||||
354 | 0 | while (1) { | |||||
355 | 0 | my @ret = IO::Select->select($read_handles, $write_handles, undef, undef); | |||||
356 | 0 | 0 | 0 | if ((not defined @ret) || (@ret == 0)) { &$logging("[$id] has failed on select"); return; } | |||
0 | |||||||
0 | |||||||
357 | 0 | my ($rset, $wset, $eset) = @ret; | |||||
358 | |||||||
359 | 0 | my $r = scalar(@$rset); | |||||
360 | 0 | my $w = scalar(@$wset); | |||||
361 | 0 | my $e = scalar(@$eset); | |||||
362 | |||||||
363 | 0 | foreach my $fh (@$rset) { | |||||
364 | 0 | my $no = $fh->fileno; | |||||
365 | 0 | 0 | if ($fh == $d) { | ||||
366 | 0 | my $ns = $d->accept(); | |||||
367 | 0 | 0 | if (defined $ns) { | ||||
368 | 0 | $ns->blocking(0); | |||||
369 | 0 | $ns->autoflush(0); | |||||
370 | 0 | $read_handles->add($ns); | |||||
371 | 0 | $no = $ns->fileno; | |||||
372 | 0 | $buffers{$no}{InBuffer} = ''; | |||||
373 | 0 | $buffers{$no}{OutBuffer} = ''; | |||||
374 | 0 | $buffers{$no}{AutoClose} = 0; | |||||
375 | 0 | $buffers{$no}{CloseAfter} = 0; | |||||
376 | 0 | $buffers{$no}{CLen} = -1; | |||||
377 | 0 | $buffers{$no}{CPos} = 0; | |||||
378 | 0 | $buffers{$no}{Socket} = $ns; | |||||
379 | 0 | &$logging("[$id] NEW connection [$no] from " . $ns->peerhost . ":" . $ns->peerport); | |||||
380 | } | ||||||
381 | } else { | ||||||
382 | 0 | 0 | if (!$self->__fill_buffer($id, $fh, \%{$buffers{$no}})) { | ||||
0 | |||||||
383 | 0 | $read_handles->remove($fh); | |||||
384 | 0 | $write_handles->remove($fh); | |||||
385 | 0 | close($fh); | |||||
386 | 0 | delete $buffers{$no}; | |||||
387 | 0 | &$logging("[$id] END connection (1) [$no]"); | |||||
388 | } | ||||||
389 | |||||||
390 | 0 | 0 | if ($buffers{$no}{AutoClose}) { | ||||
391 | 0 | $read_handles->remove($fh); | |||||
392 | 0 | $write_handles->remove($fh); | |||||
393 | 0 | delete $buffers{$no}; | |||||
394 | 0 | close($fh); | |||||
395 | 0 | &$logging("[$id] END connection (2) [$no]"); | |||||
396 | } else { | ||||||
397 | 0 | 0 | if ($buffers{$no}{OutBuffer} ne '') { | ||||
398 | 0 | $write_handles->add($fh); | |||||
399 | 0 | $read_handles->remove($fh); | |||||
400 | } | ||||||
401 | } | ||||||
402 | } | ||||||
403 | } | ||||||
404 | |||||||
405 | 0 | foreach my $fh (@$wset) { | |||||
406 | |||||||
407 | 0 | my $no = $fh->fileno; | |||||
408 | 0 | my $size = length($buffers{$no}{OutBuffer}); | |||||
409 | |||||||
410 | 0 | 0 | if ($size == 0) { | ||||
411 | 0 | $write_handles->remove($fh); | |||||
412 | 0 | 0 | if ($buffers{$no}{CloseAfter}) { | ||||
413 | 0 | $read_handles->remove($fh); | |||||
414 | 0 | delete $buffers{$no}; | |||||
415 | 0 | close($fh); | |||||
416 | 0 | &$logging("[$id] END connection (3) [$no]"); | |||||
417 | } else { | ||||||
418 | 0 | $read_handles->add($fh); | |||||
419 | } | ||||||
420 | } else { | ||||||
421 | 0 | 0 | if (!$self->__socket_write($id, $fh, $size, \%{$buffers{$no}})) { | ||||
0 | |||||||
422 | 0 | $read_handles->remove($fh); | |||||
423 | 0 | $write_handles->remove($fh); | |||||
424 | 0 | delete $buffers{$no}; | |||||
425 | 0 | close($fh); | |||||
426 | 0 | &$logging("[$id] END connection (4) [$no]"); | |||||
427 | } | ||||||
428 | } | ||||||
429 | |||||||
430 | } | ||||||
431 | |||||||
432 | } | ||||||
433 | |||||||
434 | } | ||||||
435 | |||||||
436 | # -------------------------------------------------------------------------------------- | ||||||
437 | # Start a single forking web server | ||||||
438 | # | ||||||
439 | |||||||
440 | sub __fork_connections { | ||||||
441 | 0 | 0 | my ($self, $id) = @_; | ||||
442 | 0 | my $conf = $self->{CONF}; | |||||
443 | 0 | my $d = $self->{SERVER}; | |||||
444 | 0 | my $logging = $conf->{"DEBLOG_METHOD"}; | |||||
445 | 0 | my $handles = new IO::Select(); | |||||
446 | |||||||
447 | 0 | $d->blocking(0); | |||||
448 | 0 | $handles->add($d); | |||||
449 | |||||||
450 | 0 | while (1) { | |||||
451 | 0 | my @ret = IO::Select->select($handles, undef, undef, undef); | |||||
452 | 0 | 0 | if (not defined @ret) { return; } | ||||
0 | |||||||
453 | 0 | 0 | if (@ret == 0) { &$logging("[$id] has failed on select"); return; } | ||||
0 | |||||||
0 | |||||||
454 | 0 | my ($rset, $wset, $eset) = @ret; | |||||
455 | |||||||
456 | 0 | my $c = $d->accept(); | |||||
457 | 0 | 0 | if (defined $c) { | ||||
458 | 0 | $c->blocking(0); | |||||
459 | 0 | $c->autoflush(0); | |||||
460 | 0 | my $pid = fork(); | |||||
461 | 0 | 0 | if ($pid == 0) { | ||||
462 | 0 | $self->__pre_fork("S$id"); | |||||
463 | 0 | $0 = $conf->{"PROC_PREFIX"} . " serving (" . $c->peerhost . ":" . $c->peerport . ")"; | |||||
464 | 0 | &$logging("NEW connection from " . $c->peerhost . ":" . $c->peerport); | |||||
465 | 0 | $self->__forked_loop($id, $c); | |||||
466 | 0 | $self->__post_fork("S$id"); | |||||
467 | 0 | exit 0; | |||||
468 | } else { | ||||||
469 | 0 | push @childs, $pid; | |||||
470 | 0 | my $ended = waitpid(-1,WNOHANG); | |||||
471 | 0 | 0 | if ($ended > 0) { | ||||
472 | 0 | for (my $i = 0; $i < @childs; $i++) { | |||||
473 | 0 | 0 | if ($childs[$i] == $ended) { | ||||
474 | 0 | splice(@childs,$i,1); | |||||
475 | 0 | last; | |||||
476 | } | ||||||
477 | } | ||||||
478 | } | ||||||
479 | } | ||||||
480 | } | ||||||
481 | |||||||
482 | } | ||||||
483 | } | ||||||
484 | |||||||
485 | # -------------------------------------------------------------------------------------- | ||||||
486 | # Main loop of a forked child | ||||||
487 | # | ||||||
488 | |||||||
489 | sub __forked_loop { | ||||||
490 | 0 | 0 | my ($self, $id, $c) = @_; | ||||
491 | 0 | my $conf = $self->{CONF}; | |||||
492 | 0 | my $logging = $conf->{"DEBLOG_METHOD"}; | |||||
493 | |||||||
494 | 0 | my %buffer = (); | |||||
495 | 0 | $buffer{InBuffer} = ''; | |||||
496 | 0 | $buffer{OutBuffer} = ''; | |||||
497 | 0 | $buffer{AutoClose} = 0; | |||||
498 | 0 | $buffer{CloseAfter} = 0; | |||||
499 | 0 | $buffer{CLen} = -1; | |||||
500 | 0 | $buffer{CPos} = 0; | |||||
501 | 0 | $buffer{Socket} = $c; | |||||
502 | |||||||
503 | 0 | my $read_handles = new IO::Select(); | |||||
504 | 0 | my $write_handles = new IO::Select(); | |||||
505 | 0 | $read_handles->add($c); | |||||
506 | |||||||
507 | 0 | my $exit_loop = 0; | |||||
508 | |||||||
509 | 0 | while (1) { | |||||
510 | 0 | 0 | if ($exit_loop) { last; } | ||||
0 | |||||||
511 | 0 | my @ret = IO::Select->select($read_handles, $write_handles, undef, undef); | |||||
512 | 0 | 0 | 0 | if ((not defined @ret) || (@ret == 0)) { &$logging("[$id] has failed on select"); return; } | |||
0 | |||||||
0 | |||||||
513 | 0 | my ($rset, $wset, $eset) = @ret; | |||||
514 | |||||||
515 | 0 | foreach my $fh (@$rset) { | |||||
516 | |||||||
517 | 0 | my $no = $fh->fileno; | |||||
518 | |||||||
519 | 0 | 0 | if (!$self->__fill_buffer($id, $fh, \%buffer)) { | ||||
520 | 0 | $read_handles->remove($fh); | |||||
521 | 0 | $write_handles->remove($fh); | |||||
522 | 0 | close($fh); | |||||
523 | 0 | &$logging("[$id] END connection [$no]"); | |||||
524 | 0 | $exit_loop = 1; | |||||
525 | } | ||||||
526 | |||||||
527 | 0 | 0 | if ($buffer{AutoClose}) { | ||||
528 | 0 | $read_handles->remove($fh); | |||||
529 | 0 | $write_handles->remove($fh); | |||||
530 | 0 | close($fh); | |||||
531 | 0 | &$logging("[$id] END connection [$no]"); | |||||
532 | 0 | $exit_loop = 1; | |||||
533 | } else { | ||||||
534 | 0 | 0 | if ($buffer{OutBuffer} ne '') { | ||||
535 | 0 | $write_handles->add($fh); | |||||
536 | 0 | $read_handles->remove($fh); | |||||
537 | } | ||||||
538 | } | ||||||
539 | } | ||||||
540 | |||||||
541 | 0 | foreach my $fh (@$wset) { | |||||
542 | |||||||
543 | 0 | my $no = $fh->fileno; | |||||
544 | |||||||
545 | 0 | my $size = length($buffer{OutBuffer}); | |||||
546 | |||||||
547 | 0 | 0 | if ($size == 0) { | ||||
548 | 0 | $read_handles->add($fh); | |||||
549 | 0 | $write_handles->remove($fh); | |||||
550 | 0 | 0 | if ($buffer{CloseAfter}) { | ||||
551 | 0 | $read_handles->remove($fh); | |||||
552 | 0 | close($fh); | |||||
553 | 0 | &$logging("[$id] END connection [$no]"); | |||||
554 | 0 | $exit_loop = 1; | |||||
555 | } | ||||||
556 | } else { | ||||||
557 | 0 | 0 | if (!$self->__socket_write($id, $fh, $size, \%buffer)) { | ||||
558 | 0 | $read_handles->remove($fh); | |||||
559 | 0 | $write_handles->remove($fh); | |||||
560 | 0 | close($fh); | |||||
561 | 0 | &$logging("[$id] END connection [$no]"); | |||||
562 | 0 | $exit_loop = 1; | |||||
563 | } | ||||||
564 | } | ||||||
565 | |||||||
566 | } | ||||||
567 | |||||||
568 | } | ||||||
569 | |||||||
570 | } | ||||||
571 | |||||||
572 | # -------------------------------------------------------------------------------------- | ||||||
573 | # Try to fill out the buffer of the connection | ||||||
574 | # | ||||||
575 | |||||||
576 | sub __fill_buffer { | ||||||
577 | 0 | 0 | my ($self, $id, $c, $buf) = @_; | ||||
578 | 0 | my $conf = $self->{CONF}; | |||||
579 | 0 | my $res; | |||||
580 | |||||||
581 | 0 | $res = $self->__socket_read($id, $c, $buf); | |||||
582 | 0 | 0 | if ($res < 0) { | ||||
0 | |||||||
583 | 0 | $buf->{InBuffer} = ''; | |||||
584 | 0 | $buf->{CLen} = -1; | |||||
585 | 0 | $buf->{CPos} = 0; | |||||
586 | 0 | return 0; | |||||
587 | } elsif ($res == 1) { | ||||||
588 | 0 | my $r = $self->__parse_http_request($buf->{InBuffer}); | |||||
589 | 0 | $buf->{InBuffer} = ''; | |||||
590 | 0 | $buf->{CLen} = -1; | |||||
591 | 0 | $buf->{CPos} = 0; | |||||
592 | 0 | return $self->__handle_request($id, $c, $r, $buf); | |||||
593 | } else { | ||||||
594 | 0 | return 1; | |||||
595 | } | ||||||
596 | } | ||||||
597 | |||||||
598 | # -------------------------------------------------------------------------------------- | ||||||
599 | # Try to send out the buffer to the connection | ||||||
600 | # | ||||||
601 | |||||||
602 | sub __socket_write { | ||||||
603 | 0 | 0 | my ($self, $id, $c, $size, $buf) = @_; | ||||
604 | 0 | my $conf = $self->{CONF}; | |||||
605 | |||||||
606 | 0 | my $res; | |||||
607 | 0 | eval { | |||||
608 | #$res = $c->send($buf->{OutBuffer}); | ||||||
609 | 0 | $res = syswrite($c, $buf->{OutBuffer}, length($buf->{OutBuffer})); | |||||
610 | }; | ||||||
611 | 0 | 0 | if ($@) { | ||||
612 | 0 | my $logging = $conf->{'DEBLOG_METHOD'}; | |||||
613 | 0 | &$logging("[$id] " . $@); | |||||
614 | 0 | return 0; | |||||
615 | } | ||||||
616 | |||||||
617 | 0 | 0 | if ($res) { | ||||
618 | 0 | 0 | if ($res == 0) { return 0; } | ||||
0 | |||||||
619 | 0 | $buf->{OutBuffer} = substr($buf->{OutBuffer}, $res); | |||||
620 | 0 | return 1; | |||||
621 | } else { | ||||||
622 | 0 | return 0; | |||||
623 | } | ||||||
624 | } | ||||||
625 | |||||||
626 | # -------------------------------------------------------------------------------------- | ||||||
627 | # Read from socket and fill out the given buffer | ||||||
628 | # | ||||||
629 | |||||||
630 | sub __socket_read { | ||||||
631 | 0 | 0 | my ($self, $id, $c, $buf) = @_; | ||||
632 | 0 | my $conf = $self->{CONF}; | |||||
633 | |||||||
634 | 0 | my $tbuf = ''; | |||||
635 | 0 | my $read = 0; | |||||
636 | |||||||
637 | #$read = $c->read($tbuf, 8192); | ||||||
638 | 0 | $read = sysread($c, $tbuf, 8192); | |||||
639 | 0 | 0 | if (not defined $read) { | ||||
640 | 0 | my $errstr = $!; | |||||
641 | 0 | my $errno = $! + 0; | |||||
642 | 0 | 0 | if ($errno != 0) { | ||||
643 | 0 | my $logging = $conf->{'DEBLOG_METHOD'}; | |||||
644 | 0 | &$logging("[$id] Socket read error was [$errno] ($errstr)"); | |||||
645 | } | ||||||
646 | 0 | return -1; # socket read got an error | |||||
647 | } | ||||||
648 | |||||||
649 | 0 | 0 | if ($read == 0) { | ||||
650 | 0 | return -1; # socket closed | |||||
651 | } | ||||||
652 | |||||||
653 | 0 | $buf->{InBuffer} .= $tbuf; | |||||
654 | |||||||
655 | 0 | 0 | if ($buf->{CLen} < 0) { | ||||
656 | 0 | my $pos; | |||||
657 | 0 | 0 | if (($pos = index($buf->{InBuffer}, "$CRLF$CRLF")) > 0) { # we have full headers | ||||
658 | 0 | 0 | if ($buf->{InBuffer} =~ /Content-Length:\s*(\d+)/io) { | ||||
659 | 0 | $buf->{CLen} = $1; | |||||
660 | } else { | ||||||
661 | 0 | $buf->{CLen} = 0; | |||||
662 | } | ||||||
663 | 0 | $buf->{CPos} = $pos; | |||||
664 | } else { | ||||||
665 | 0 | return 0; # not a complete packet yet | |||||
666 | } | ||||||
667 | } | ||||||
668 | |||||||
669 | 0 | 0 | if ($buf->{CLen} >= 0) { | ||||
670 | 0 | my $expected = $buf->{CPos} + $buf->{CLen} + 4; # we have up to a point. Read the remaining | |||||
671 | 0 | 0 | if (length($buf->{InBuffer}) < $expected) { | ||||
672 | 0 | return 0; | |||||
673 | } | ||||||
674 | } else { | ||||||
675 | 0 | return 0; | |||||
676 | } | ||||||
677 | |||||||
678 | 0 | return 1; # we have a complete packet | |||||
679 | } | ||||||
680 | |||||||
681 | # -------------------------------------------------------------------------------------- | ||||||
682 | # Parse a request packet | ||||||
683 | # | ||||||
684 | |||||||
685 | sub __parse_http_request { | ||||||
686 | 0 | 0 | my ($self, $packet) = @_; | ||||
687 | 0 | my $conf = $self->{CONF}; | |||||
688 | |||||||
689 | 0 | my $spacket = $packet; | |||||
690 | 0 | my %request = (); | |||||
691 | |||||||
692 | 0 | my $head = ''; | |||||
693 | |||||||
694 | 0 | $packet =~ s/^(.*)\n?//o; | |||||
695 | 0 | my $line = $1; | |||||
696 | 0 | $line =~ s/\r//gco; | |||||
697 | 0 | $line =~ s/^\s*//go; | |||||
698 | 0 | my ($meth, $uri, $ver) = split(/\s+/o, $line); | |||||
699 | |||||||
700 | 0 | $head .= $line . $CRLF; | |||||
701 | |||||||
702 | 0 | 0 | if ($uri =~ /(.*?)\?(.*)/o) { | ||||
703 | 0 | $request{URI} = $1; | |||||
704 | 0 | $request{QUERY_STRING} = $2; | |||||
705 | } else { | ||||||
706 | 0 | $request{URI} = $uri; | |||||
707 | 0 | $request{QUERY_STRING} = ''; | |||||
708 | } | ||||||
709 | 0 | $request{METHOD} = $meth; | |||||
710 | 0 | $request{VERSION} = $ver; | |||||
711 | |||||||
712 | 0 | while (1) { | |||||
713 | 0 | $packet =~ s/^(.*)\n?//o; | |||||
714 | 0 | $line = $1; | |||||
715 | 0 | $line =~ s/\r//gco; | |||||
716 | 0 | $line =~ s/^\s*//go; | |||||
717 | 0 | my ($k, $v) = ($line =~ /^\s*(.*?)\s*?\:\s*?(.*)/o); | |||||
718 | 0 | 0 | if ($k ne '') { | ||||
719 | 0 | $head .= $line . $CRLF; | |||||
720 | 0 | $v =~ s/^\s*//go; | |||||
721 | 0 | $v =~ s/\s*$//go; | |||||
722 | 0 | $request{HEADERS}{uc($k)} = $v; | |||||
723 | } else { | ||||||
724 | 0 | $head .= $CRLF; | |||||
725 | 0 | last; | |||||
726 | } | ||||||
727 | } | ||||||
728 | |||||||
729 | 0 | my $logging = $conf->{"DEBLOG_METHOD"}; | |||||
730 | |||||||
731 | 0 | 0 | if ($conf->{'LOG_PACKETS'}) { | ||||
732 | 0 | &$logging($spacket); | |||||
733 | } else { | ||||||
734 | 0 | 0 | if ($conf->{'LOG_HEADERS'}) { | ||||
735 | 0 | &$logging($head); | |||||
736 | } | ||||||
737 | } | ||||||
738 | |||||||
739 | 0 | $request{CONTENT} = $packet; | |||||
740 | |||||||
741 | 0 | return \%request; | |||||
742 | } | ||||||
743 | |||||||
744 | # -------------------------------------------------------------------------------------- | ||||||
745 | # Handle a request | ||||||
746 | # | ||||||
747 | |||||||
748 | sub __handle_request { | ||||||
749 | 0 | 0 | my ($self, $id, $c, $r, $buf) = @_; | ||||
750 | 0 | my $conf = $self->{CONF}; | |||||
751 | |||||||
752 | 0 | 0 | if (not defined $r->{METHOD}) { | ||||
753 | 0 | return 0; | |||||
754 | } else { | ||||||
755 | 0 | 0 | if ($conf->{"WAIT_RESPONSE"} == 0) { | ||||
756 | 0 | my $page = $self->__make_response($conf->{"NO_WAIT_REPLY"}, undef, undef, 0); | |||||
757 | 0 | $c->blocking(1); | |||||
758 | 0 | print $c, $page; | |||||
759 | 0 | $buf->{AutoClose} = 1; | |||||
760 | 0 | close($c); | |||||
761 | 0 | $self->__get_page($id, $c->peerhost, $c->peerport, $r, 0); | |||||
762 | } else { | ||||||
763 | 0 | my $page = $self->__get_page($id, $c->peerhost, $c->peerport, $r, 1); | |||||
764 | 0 | $buf->{OutBuffer} .= $page; | |||||
765 | 0 | 0 | 0 | if (($conf->{"IMMED_CLOSE"}) || ($r->{HEADERS}{'CONNECTION'} eq 'Close')) { | |||
766 | 0 | $buf->{CloseAfter} = 1; | |||||
767 | } | ||||||
768 | } | ||||||
769 | } | ||||||
770 | 0 | return 1; | |||||
771 | } | ||||||
772 | |||||||
773 | # -------------------------------------------------------------------------------------- | ||||||
774 | # Get the requested page | ||||||
775 | # | ||||||
776 | |||||||
777 | sub __get_page { | ||||||
778 | 0 | 0 | my ($self, $id, $rhost, $rport, $r, $err) = @_; | ||||
779 | 0 | my $conf = $self->{CONF}; | |||||
780 | |||||||
781 | 0 | my $page = undef; | |||||
782 | |||||||
783 | 0 | my $logging = $conf->{"LOG_METHOD"}; | |||||
784 | 0 | my $logging2 = $conf->{"DEBLOG_METHOD"}; | |||||
785 | 0 | my $path = $r->{URI}; | |||||
786 | 0 | my $embed = undef; | |||||
787 | 0 | my $script = undef; | |||||
788 | 0 | my $inauth_space = 0; | |||||
789 | |||||||
790 | 0 | $path =~ s/\/\//\//gco; | |||||
791 | |||||||
792 | 0 | 0 | if ($path =~ /\/$/o) { | ||||
793 | 0 | $path .= "index.html"; | |||||
794 | } | ||||||
795 | |||||||
796 | 0 | 0 | if (exists $conf->{"DOCUMENTS"}{$path}) { | ||||
797 | 0 | $embed = 1; | |||||
798 | } else { | ||||||
799 | 0 | 0 | if (defined $conf->{"DOCUMENT_ROOT"}) { | ||||
800 | 0 | my $fname = $conf->{"DOCUMENT_ROOT"} . $path; | |||||
801 | 0 | $fname =~ s/\/\//\//gco; | |||||
802 | 0 | 0 | if (! -e $fname) { | ||||
803 | 0 | 0 | if (exists $conf->{"DOCUMENTS"}{'*'}) { | ||||
804 | 0 | $embed = 1; | |||||
805 | } else { | ||||||
806 | 0 | 0 | if ($path =~ /$conf->{"CGI_PATH"}/) { | ||||
807 | 0 | 0 | if ($conf->{"SETUP_ENV"}) { | ||||
808 | 0 | $script = 1; | |||||
809 | 0 | $ENV{"SCRIPT_NAME"} = $path; | |||||
810 | 0 | $ENV{"SCRIPT_FILENAME"} = $fname; | |||||
811 | 0 | $ENV{"QUERY_STRING"} = ""; | |||||
812 | } | ||||||
813 | } | ||||||
814 | } | ||||||
815 | } else { | ||||||
816 | 0 | 0 | if ($path =~ /$conf->{"CGI_PATH"}/) { | ||||
817 | 0 | 0 | if ($conf->{"SETUP_ENV"}) { | ||||
818 | 0 | $script = 1; | |||||
819 | 0 | $ENV{"SCRIPT_NAME"} = $path; | |||||
820 | 0 | $ENV{"SCRIPT_FILENAME"} = $fname; | |||||
821 | 0 | $ENV{"QUERY_STRING"} = ""; | |||||
822 | } | ||||||
823 | } | ||||||
824 | } | ||||||
825 | } else { | ||||||
826 | 0 | 0 | if (exists $conf->{"DOCUMENTS"}{'*'}) { | ||||
827 | 0 | $embed = 1; | |||||
828 | } | ||||||
829 | } | ||||||
830 | } | ||||||
831 | |||||||
832 | # &$logging("[$id] Request was \n" . $r->as_string()); | ||||||
833 | |||||||
834 | 0 | $ENV{"REQUEST_URI"} = $path; | |||||
835 | |||||||
836 | 0 | my $pmeth = sprintf("%-4s", $r->{METHOD}); | |||||
837 | |||||||
838 | 0 | my ($auth_ok, $page) = $self->__is_auth_ok($id, $rhost, $rport, $r, $path, $inauth_space, $err); | |||||
839 | 0 | 0 | if ($auth_ok) { | ||||
840 | |||||||
841 | 0 | 0 | if ($conf->{"SETUP_ENV"}) { | ||||
842 | 0 | $self->__fix_env($r); | |||||
843 | } | ||||||
844 | 0 | $ENV{"REMOTE_PORT"} = $rport; | |||||
845 | 0 | $ENV{"REMOTE_ADDR"} = $rhost; | |||||
846 | |||||||
847 | 0 | my $retval = undef; | |||||
848 | 0 | my $reterr = undef; | |||||
849 | |||||||
850 | 0 | my $type = ''; | |||||
851 | |||||||
852 | 0 | 0 | if ($r->{METHOD} =~ /GET|HEAD|POST/o) { | ||||
853 | 0 | 0 | if ($script) { | ||||
0 | |||||||
854 | 0 | 0 | 0 | if (($conf->{"EMBED_PERL"} == 1) && ($path =~ /\.pl$/o)) { | |||
855 | 0 | $type = 'PERL '; | |||||
856 | 0 | ($retval, $reterr, $page) = $self->__do_perl($id, $path, $r, $inauth_space); | |||||
857 | 0 | 0 | if (!$retval) { | ||||
858 | 0 | &$logging2("[$id] Script error ($reterr) on (" . $r->{URI} . ")"); | |||||
859 | 0 | 0 | if ($err) { | ||||
860 | 0 | $page = $self->__make_error($reterr, $inauth_space, $id, $rhost, $rport, $r); | |||||
861 | } | ||||||
862 | } | ||||||
863 | } else { | ||||||
864 | 0 | $type = 'CGI '; | |||||
865 | 0 | ($retval, $reterr, $page) = $self->__do_cgi($id, $path, $r, $inauth_space); | |||||
866 | 0 | 0 | if (!$retval) { | ||||
867 | 0 | &$logging2("[$id] Script error ($reterr) on (" . $r->{URI} . ")"); | |||||
868 | 0 | 0 | if ($err) { | ||||
869 | 0 | $page = $self->__make_error($reterr, $inauth_space, $id, $rhost, $rport, $r); | |||||
870 | } | ||||||
871 | } | ||||||
872 | } | ||||||
873 | } elsif ($embed) { | ||||||
874 | 0 | $type = 'EMBED'; | |||||
875 | 0 | ($retval, $reterr, $page) = $self->__do_embeded($id, $path, $r, $inauth_space); | |||||
876 | 0 | 0 | if (!$retval) { | ||||
877 | 0 | &$logging2("[$id] Embeded function error ($reterr) on ($path)"); | |||||
878 | 0 | 0 | if ($err) { | ||||
879 | 0 | $page = $self->__make_error($reterr, $inauth_space, $id, $rhost, $rport, $r); | |||||
880 | } | ||||||
881 | } | ||||||
882 | } else { | ||||||
883 | 0 | $type = 'FILE '; | |||||
884 | 0 | ($retval, $reterr, $page) = $self->__do_file($path, $r, $inauth_space); | |||||
885 | 0 | 0 | if (!$retval) { | ||||
886 | 0 | &$logging2("[$id] FILE (" . $r->{URI} . ") not found"); | |||||
887 | 0 | 0 | if ($err) { | ||||
888 | 0 | $page = $self->__make_error($reterr, $inauth_space, $id, $rhost, $rport, $r); | |||||
889 | } | ||||||
890 | } | ||||||
891 | } | ||||||
892 | } else { | ||||||
893 | 0 | $type = 'FAIL '; | |||||
894 | 0 | &$logging2("[$id] Method $pmeth for (" . $r->{URI} . ") is not implemented"); | |||||
895 | 0 | 0 | if ($err) { | ||||
896 | 0 | $reterr = 405; | |||||
897 | 0 | $page = $self->__make_error($reterr, $inauth_space, $id, $rhost, $rport, $r); | |||||
898 | } | ||||||
899 | } | ||||||
900 | |||||||
901 | 0 | &$logging("[$id] $pmeth [$type] from $rhost:$rport ($path) got ($reterr " . $conf->{'HTML_CODES'}{$reterr}. ")"); | |||||
902 | |||||||
903 | } else { | ||||||
904 | 0 | &$logging("[$id] $pmeth from $rhost:$rport ($path) failed authentication"); | |||||
905 | } | ||||||
906 | |||||||
907 | 0 | return $page; | |||||
908 | } | ||||||
909 | |||||||
910 | # -------------------------------------------------------------------------------------- | ||||||
911 | # Get the authorization from the packet -- packet | ||||||
912 | # | ||||||
913 | |||||||
914 | sub __get_authorization { | ||||||
915 | 0 | 0 | my ($self, $r, $log) = @_; | ||||
916 | |||||||
917 | 0 | my $h = $r->{HEADERS}->{'AUTHORIZATION'}; | |||||
918 | |||||||
919 | 0 | 0 | if (defined $h) { | ||||
920 | 0 | $h =~ s/^\s*Basic\s+//gco; | |||||
921 | 0 | require MIME::Base64; | |||||
922 | 0 | my $val = MIME::Base64::decode_base64($h); | |||||
923 | 0 | 0 | return $val unless wantarray; | ||||
924 | 0 | return split(/:/, $val, 2); | |||||
925 | } | ||||||
926 | 0 | return; | |||||
927 | } | ||||||
928 | |||||||
929 | # -------------------------------------------------------------------------------------- | ||||||
930 | # Check if we are in a path with authentication and authentication data exists | ||||||
931 | # | ||||||
932 | |||||||
933 | sub __is_auth_ok { | ||||||
934 | 0 | 0 | my ($self, $id, $rhost, $rport, $r, $path, $inauth_space, $err) = @_; | ||||
935 | 0 | my $conf = $self->{CONF}; | |||||
936 | |||||||
937 | 0 | 0 | if (not defined $conf->{"AUTH_PATH"}) { return (1, undef); } | ||||
0 | |||||||
938 | |||||||
939 | 0 | my $auth_f = $conf->{"AUTH_METHOD"}; | |||||
940 | 0 | my $logging = $conf->{"DEBLOG_METHOD"}; | |||||
941 | 0 | my $logging2 = $conf->{"LOG_METHOD"}; | |||||
942 | 0 | my $page = undef; | |||||
943 | |||||||
944 | 0 | 0 | if ($path =~ /$conf->{"AUTH_PATH"}/) { | ||||
945 | 0 | my $five = 5; | |||||
946 | 0 | $_[$five] = 1; | |||||
947 | 0 | my ($user, $pass) = $self->__get_authorization($r, $logging); | |||||
948 | 0 | 0 | if (not defined $user) { | ||||
949 | 0 | $page = $self->__make_response("401", undef, undef, 1); | |||||
950 | 0 | &$logging("[$id] AUTH to $rhost:$rport ($path)"); | |||||
951 | 0 | return (0, $page); | |||||
952 | } else { | ||||||
953 | 0 | 0 | if (not defined $auth_f) { | ||||
0 | |||||||
954 | 0 | 0 | if ($conf->{"SETUP_ENV"}) { | ||||
955 | 0 | $ENV{"REMOTE_USER"} = $user; | |||||
956 | 0 | $ENV{"AUTH_TYPE"} = "Basic"; | |||||
957 | } | ||||||
958 | 0 | return (1, $page); | |||||
959 | } elsif (&$auth_f($user, $pass)) { | ||||||
960 | 0 | 0 | if ($conf->{"SETUP_ENV"}) { | ||||
961 | 0 | $ENV{"REMOTE_USER"} = $user; | |||||
962 | 0 | $ENV{"AUTH_TYPE"} = "Basic"; | |||||
963 | } | ||||||
964 | 0 | return (1, $page); | |||||
965 | } else { | ||||||
966 | 0 | 0 | if ($err) { | ||||
967 | 0 | $page = $self->__make_error("403", 1, $id, $rhost, $rport, $r); | |||||
968 | } | ||||||
969 | 0 | &$logging2("[$id] REJECT to $rhost:$rport for ($user) on ($path)"); | |||||
970 | 0 | return (0, $page); | |||||
971 | } | ||||||
972 | } | ||||||
973 | } | ||||||
974 | 0 | return (1, $page); | |||||
975 | } | ||||||
976 | |||||||
977 | # -------------------------------------------------------------------------------------- | ||||||
978 | # get the expiration time for a given media type | ||||||
979 | # | ||||||
980 | |||||||
981 | sub __get_type_expiration { | ||||||
982 | 0 | 0 | my ($self, $type) = @_; | ||||
983 | 0 | my $conf = $self->{CONF}; | |||||
984 | |||||||
985 | 0 | my $exp = undef; # default is not defined | |||||
986 | |||||||
987 | 0 | 0 | if (exists $conf->{'EXPIRATIONS'}) { | ||||
988 | 0 | 0 | if (exists $conf->{'EXPIRATIONS'}->{$type}) { | ||||
989 | 0 | $exp = $conf->{'EXPIRATIONS'}->{$type}; | |||||
990 | } else { | ||||||
991 | 0 | 0 | if (exists $conf->{'EXPIRATIONS'}->{'ALL'}) { | ||||
992 | 0 | $exp = $conf->{'EXPIRATIONS'}->{'ALL'}; | |||||
993 | } | ||||||
994 | } | ||||||
995 | } | ||||||
996 | |||||||
997 | 0 | return $exp; | |||||
998 | } | ||||||
999 | |||||||
1000 | # -------------------------------------------------------------------------------------- | ||||||
1001 | # send file | ||||||
1002 | # | ||||||
1003 | |||||||
1004 | sub __do_file { | ||||||
1005 | 0 | 0 | my ($self, $p, $r, $auth) = @_; | ||||
1006 | 0 | my $conf = $self->{CONF}; | |||||
1007 | |||||||
1008 | 0 | my $res = ""; | |||||
1009 | 0 | my $page = undef; | |||||
1010 | |||||||
1011 | 0 | 0 | if ($conf->{"WAIT_RESPONSE"} == 0) { | ||||
1012 | 0 | return (1, 200, $self->__make_response("200", undef, undef, undef)); | |||||
1013 | } | ||||||
1014 | |||||||
1015 | 0 | 0 | if (not defined $conf->{"DOCUMENT_ROOT"}) { | ||||
1016 | 0 | return (0, 404, $self->__make_response("404", undef, undef, undef)); | |||||
1017 | } | ||||||
1018 | |||||||
1019 | 0 | $p = $conf->{"DOCUMENT_ROOT"} . $p; | |||||
1020 | |||||||
1021 | 0 | 0 | if (-e $p) { | ||||
1022 | 0 | my %headers = (); | |||||
1023 | |||||||
1024 | 0 | 0 | if ($r->{METHOD} eq "HEAD") { | ||||
1025 | 0 | return (1, 200, $self->__make_response("200", undef, undef, $auth)); | |||||
1026 | } else { | ||||||
1027 | 0 | my @s = stat($p); | |||||
1028 | 0 | my $nine = 9; | |||||
1029 | 0 | my $seven = 7; | |||||
1030 | 0 | my $mdate = time2str($s[$nine]); | |||||
1031 | 0 | my $size = $s[$seven]; | |||||
1032 | |||||||
1033 | 0 | my ($type, $enc) = guess_media_type($p); | |||||
1034 | 0 | my $expiration = $self->__get_type_expiration($type); | |||||
1035 | |||||||
1036 | 0 | 0 | if ($r->{HEADERS}{"IF-MODIFIED-SINCE"} eq $mdate) { | ||||
1037 | 0 | $headers{'Date'} = time2str(time); | |||||
1038 | 0 | $headers{'Last-Modified'} = $mdate; | |||||
1039 | 0 | 0 | 0 | if ((defined $expiration) && ($expiration =~ /\d+/)) { | |||
1040 | 0 | $headers{'Cache-Control'} = "max-age=$expiration, must-revalidate"; | |||||
1041 | 0 | $headers{'Expires'} = time2str(time + $expiration); | |||||
1042 | } | ||||||
1043 | |||||||
1044 | 0 | return (1, 304, $self->__make_response("304", \%headers, undef, $auth)); | |||||
1045 | } | ||||||
1046 | |||||||
1047 | # if ($r->{HEADERS}{"IF-UNMODIFIED-SINCE"} ne $mdate) { | ||||||
1048 | # return (1, 412, __make_response("412", undef, undef, $auth, $conf)); | ||||||
1049 | # } | ||||||
1050 | |||||||
1051 | 0 | $res = $self->__load_file($p); | |||||
1052 | 0 | 0 | if (not defined $res) { | ||||
1053 | 0 | return (0, 404, $self->__make_response("404", undef, undef, $auth)); | |||||
1054 | } | ||||||
1055 | |||||||
1056 | 0 | 0 | if (length($res) > 0) { | ||||
1057 | 0 | 0 | if ($enc ne '') { | ||||
1058 | 0 | $headers{'Content-Encoding'} = $enc; | |||||
1059 | } | ||||||
1060 | |||||||
1061 | 0 | $headers{'Content-Type'} = $type; | |||||
1062 | 0 | $headers{'Date'} = time2str(time); | |||||
1063 | 0 | $headers{'Last-Modified'} = $mdate; | |||||
1064 | 0 | 0 | 0 | if ((defined $expiration) && ($expiration =~ /\d+/)) { | |||
1065 | 0 | $headers{'Cache-Control'} = "max-age=$expiration, must-revalidate"; | |||||
1066 | 0 | $headers{'Expires'} = time2str(time + $expiration); | |||||
1067 | } | ||||||
1068 | |||||||
1069 | 0 | $res = $CRLF . $CRLF . $res; | |||||
1070 | |||||||
1071 | 0 | return (1, 200, $self->__make_response("200", \%headers, $res, $auth)); | |||||
1072 | } | ||||||
1073 | } | ||||||
1074 | } | ||||||
1075 | |||||||
1076 | 0 | return (0, 404, $self->__make_response("404", undef, undef, $auth)); | |||||
1077 | } | ||||||
1078 | |||||||
1079 | # -------------------------------------------------------------------------------------- | ||||||
1080 | # Run an embeded function | ||||||
1081 | # | ||||||
1082 | |||||||
1083 | sub __do_embeded { | ||||||
1084 | 0 | 0 | my ($self, $id, $s, $r, $auth) = @_; | ||||
1085 | 0 | my $conf = $self->{CONF}; | |||||
1086 | |||||||
1087 | 0 | my $logging = $conf->{"DEBLOG_METHOD"}; | |||||
1088 | 0 | my $p = $r->{CONTENT}; | |||||
1089 | 0 | my $page = undef; | |||||
1090 | 0 | my $post = 0; | |||||
1091 | 0 | my $sub = $conf->{"DOCUMENTS"}{$s}; | |||||
1092 | |||||||
1093 | 0 | 0 | if (not defined $sub) { | ||||
1094 | 0 | $sub = $conf->{"DOCUMENTS"}{'*'}; | |||||
1095 | } | ||||||
1096 | |||||||
1097 | 0 | 0 | 0 | if ((defined $sub) && (exists &$sub)) { | |||
1098 | 0 | $ENV{'REQUEST_METHOD'} = $r->{METHOD}; | |||||
1099 | 0 | 0 | if ($r->{METHOD} =~ /GET|HEAD/o) { | ||||
1100 | 0 | $ENV{"QUERY_STRING"} = $r->{'QUERY_STRING'}; | |||||
1101 | } else { | ||||||
1102 | 0 | $post = 1; | |||||
1103 | } | ||||||
1104 | 0 | 0 | if ($r->{METHOD} =~ /GET/o) { | ||||
1105 | 0 | 0 | if ($r->{HEADERS}{"IF-MODIFIED-SINCE"} eq time2str($self->{START_TIME})) { | ||||
1106 | 0 | my %headers = (); | |||||
1107 | 0 | $headers{'Date'} = time2str($self->{START_TIME}); | |||||
1108 | 0 | $headers{'Last-Modified'} = time2str($self->{START_TIME}); | |||||
1109 | |||||||
1110 | 0 | my $expiration = undef; | |||||
1111 | 0 | 0 | if (exists $conf->{'EXPIRATIONS'}->{'ALL'}) { | ||||
1112 | 0 | $expiration = $conf->{'EXPIRATIONS'}->{'ALL'}; | |||||
1113 | } | ||||||
1114 | 0 | 0 | 0 | if ((defined $expiration) && ($expiration =~ /\d+/)) { | |||
1115 | 0 | $headers{'Cache-Control'} = "max-age=$expiration, must-revalidate"; | |||||
1116 | 0 | $headers{'Expires'} = time2str($self->{START_TIME} + $expiration); | |||||
1117 | } | ||||||
1118 | |||||||
1119 | 0 | return (1, 304, $self->__make_response("304", \%headers, undef, $auth)); | |||||
1120 | } | ||||||
1121 | } | ||||||
1122 | 0 | 0 | if ($conf->{"SETUP_ENV"}) { | ||||
1123 | 0 | 0 | if (exists $r->{HEADERS}{"CONTENT-TYPE"}) { $ENV{"CONTENT_TYPE"} = $r->{HEADERS}{"CONTENT-TYPE"}; } | ||||
0 | |||||||
1124 | 0 | 0 | if (exists $r->{HEADERS}{"CONTENT-ENCODING"}) { $ENV{"CONTENT_ENCODING"} = $r->{HEADERS}{"CONTENT-ENCODING"}; } | ||||
0 | |||||||
1125 | 0 | 0 | if (exists $r->{HEADERS}{"CONTENT-LENGTH"}) { $ENV{"CONTENT_LENGTH"} = $r->{HEADERS}{"CONTENT-LENGTH"}; } | ||||
0 | |||||||
1126 | 0 | 0 | if (exists $r->{HEADERS}{"CONTENT-LANGUAGE"}) { $ENV{"CONTENT_LANGUAGE"} = $r->{HEADERS}{"CONTENT-LANGUAGE"}; } | ||||
0 | |||||||
1127 | } | ||||||
1128 | |||||||
1129 | 0 | my $res = ''; | |||||
1130 | 0 | my $errs = ''; | |||||
1131 | 0 | my $evalerrs = ''; | |||||
1132 | |||||||
1133 | # save all STD files | ||||||
1134 | 0 | open OLDERR, ">&STDERR"; | |||||
1135 | 0 | open OLDOUT, ">&STDOUT"; | |||||
1136 | 0 | open OLDIN, "<&STDIN"; | |||||
1137 | |||||||
1138 | # reopen STDIN to $p string if we have POST | ||||||
1139 | 0 | close STDIN; | |||||
1140 | 0 | open STDIN, "<", \$p; | |||||
1141 | 0 | binmode STDIN; | |||||
1142 | |||||||
1143 | # reopen STDOUT to $res string | ||||||
1144 | 0 | close STDOUT; | |||||
1145 | 0 | open STDOUT, ">", \$res; | |||||
1146 | 0 | binmode STDOUT; | |||||
1147 | |||||||
1148 | # reopen STDERR to $errs string | ||||||
1149 | 0 | close STDERR; | |||||
1150 | 0 | open STDERR, ">", \$errs; | |||||
1151 | |||||||
1152 | 0 | 0 | if ($self->{HAS_CGI_PM}) { | ||||
1153 | 0 | eval('CGI::initialize_globals();'); | |||||
1154 | } else { | ||||||
1155 | 0 | for my $k (keys %INC) { | |||||
1156 | 0 | 0 | if ($k eq 'CGI.pm') { | ||||
1157 | 0 | $self->{HAS_CGI_PM} = 1; | |||||
1158 | 0 | eval('CGI::initialize_globals();'); | |||||
1159 | 0 | last; | |||||
1160 | } | ||||||
1161 | } | ||||||
1162 | } | ||||||
1163 | |||||||
1164 | 0 | eval { | |||||
1165 | 0 | &$sub($data); | |||||
1166 | }; | ||||||
1167 | |||||||
1168 | 0 | $evalerrs = $@; | |||||
1169 | |||||||
1170 | # restore STD files | ||||||
1171 | 0 | close STDOUT; | |||||
1172 | 0 | open STDOUT, ">&OLDOUT"; | |||||
1173 | 0 | close OLDOUT; | |||||
1174 | 0 | close STDERR; | |||||
1175 | 0 | open STDERR, ">&OLDERR"; | |||||
1176 | 0 | close OLDERR; | |||||
1177 | 0 | close STDIN; | |||||
1178 | 0 | open STDIN, "<&OLDIN"; | |||||
1179 | 0 | close OLDIN; | |||||
1180 | |||||||
1181 | 0 | 0 | if ($conf->{"SETUP_ENV"}) { | ||||
1182 | 0 | delete $ENV{"QUERY_STRING"}; | |||||
1183 | 0 | delete $ENV{"CONTENT_TYPE"}; | |||||
1184 | 0 | delete $ENV{"CONTENT_ENCODING"}; | |||||
1185 | 0 | delete $ENV{"CONTENT_LENGTH"}; | |||||
1186 | 0 | delete $ENV{"CONTENT_LANGUAGE"}; | |||||
1187 | } | ||||||
1188 | |||||||
1189 | 0 | $errs .= $evalerrs; | |||||
1190 | |||||||
1191 | 0 | 0 | if (length($errs) > 0) { | ||||
1192 | 0 | &$logging("[$id] ($s) \n$errs"); | |||||
1193 | } | ||||||
1194 | |||||||
1195 | 0 | 0 | if ($conf->{"WAIT_RESPONSE"} == 0) { return (1, 200, $page); } | ||||
0 | |||||||
1196 | |||||||
1197 | 0 | 0 | if ($evalerrs ne '') { | ||||
1198 | 0 | return (0, 500, $self->__make_response("500", undef, undef, $auth)); | |||||
1199 | } else { | ||||||
1200 | 0 | 0 | if ($r->{METHOD} eq "HEAD") { | ||||
1201 | 0 | return (1, 200, $self->__make_response("200", undef, undef, $auth)); | |||||
1202 | } else { | ||||||
1203 | 0 | return (1, 200, $self->__make_response("200", undef, $res, $auth)); | |||||
1204 | } | ||||||
1205 | } | ||||||
1206 | } else { | ||||||
1207 | 0 | return (0, 404, $page); | |||||
1208 | } | ||||||
1209 | } | ||||||
1210 | |||||||
1211 | # -------------------------------------------------------------------------------------- | ||||||
1212 | # Run a perl script | ||||||
1213 | # | ||||||
1214 | |||||||
1215 | sub __do_perl { | ||||||
1216 | 0 | 0 | my ($self, $id, $s, $r, $auth) = @_; | ||||
1217 | 0 | my $conf = $self->{CONF}; | |||||
1218 | |||||||
1219 | 0 | my $logging = $conf->{"DEBLOG_METHOD"}; | |||||
1220 | 0 | my $p = $r->{'CONTENT'}; | |||||
1221 | 0 | my $page = undef; | |||||
1222 | 0 | my $post = 0; | |||||
1223 | |||||||
1224 | 0 | $s = $conf->{"DOCUMENT_ROOT"} . $s; | |||||
1225 | |||||||
1226 | 0 | 0 | if (-e $s) { | ||||
1227 | 0 | $ENV{'REQUEST_METHOD'} = $r->{METHOD}; | |||||
1228 | 0 | 0 | if ($r->{METHOD} =~ /GET|HEAD/o) { | ||||
1229 | 0 | $ENV{"QUERY_STRING"} = $r->{'QUERY_STRING'}; | |||||
1230 | } else { | ||||||
1231 | 0 | $post = 1; | |||||
1232 | } | ||||||
1233 | 0 | 0 | if ($conf->{"SETUP_ENV"}) { | ||||
1234 | 0 | 0 | if (exists $r->{HEADERS}{"CONTENT-TYPE"}) { $ENV{"CONTENT_TYPE"} = $r->{HEADERS}{"CONTENT-TYPE"}; } | ||||
0 | |||||||
1235 | 0 | 0 | if (exists $r->{HEADERS}{"CONTENT-ENCODING"}) { $ENV{"CONTENT_ENCODING"} = $r->{HEADERS}{"CONTENT-ENCODING"}; } | ||||
0 | |||||||
1236 | 0 | 0 | if (exists $r->{HEADERS}{"CONTENT-LENGTH"}) { $ENV{"CONTENT_LENGTH"} = $r->{HEADERS}{"CONTENT-LENGTH"}; } | ||||
0 | |||||||
1237 | 0 | 0 | if (exists $r->{HEADERS}{"CONTENT-LANGUAGE"}) { $ENV{"CONTENT_LANGUAGE"} = $r->{HEADERS}{"CONTENT-LANGUAGE"}; } | ||||
0 | |||||||
1238 | } | ||||||
1239 | |||||||
1240 | 0 | my $script = $self->__load_file($s); | |||||
1241 | 0 | 0 | if (not defined $script) { return (0, 400, $page); } | ||||
0 | |||||||
1242 | |||||||
1243 | 0 | my $res = ''; | |||||
1244 | 0 | my $errs = ''; | |||||
1245 | 0 | my $evalerrs = ''; | |||||
1246 | |||||||
1247 | # save all STD files | ||||||
1248 | 0 | open OLDERR, ">&STDERR"; | |||||
1249 | 0 | open OLDOUT, ">&STDOUT"; | |||||
1250 | 0 | open OLDIN, "<&STDIN"; | |||||
1251 | |||||||
1252 | # reopen STDIN to $p string if we have POST | ||||||
1253 | 0 | close STDIN; | |||||
1254 | 0 | open STDIN, "<", \$p; | |||||
1255 | 0 | binmode STDIN; | |||||
1256 | |||||||
1257 | # reopen STDOUT to $res string | ||||||
1258 | 0 | close STDOUT; | |||||
1259 | 0 | open STDOUT, ">", \$res; | |||||
1260 | 0 | binmode STDOUT; | |||||
1261 | |||||||
1262 | # reopen STDERR to $errs string | ||||||
1263 | 0 | close STDERR; | |||||
1264 | 0 | open STDERR, ">", \$errs; | |||||
1265 | |||||||
1266 | 0 | 0 | if ($self->{HAS_CGI_PM}) { | ||||
1267 | 0 | eval('CGI::initialize_globals();'); | |||||
1268 | } else { | ||||||
1269 | 0 | for my $k (keys %INC) { | |||||
1270 | 0 | 0 | if ($k eq 'CGI.pm') { | ||||
1271 | 0 | $self->{HAS_CGI_PM} = 1; | |||||
1272 | 0 | eval('CGI::initialize_globals();'); | |||||
1273 | } | ||||||
1274 | } | ||||||
1275 | } | ||||||
1276 | |||||||
1277 | 0 | eval { | |||||
1278 | 0 | eval($script); | |||||
1279 | 0 | $evalerrs = $@; | |||||
1280 | }; | ||||||
1281 | |||||||
1282 | # restore STD files | ||||||
1283 | 0 | close STDOUT; | |||||
1284 | 0 | open STDOUT, ">&OLDOUT"; | |||||
1285 | 0 | close OLDOUT; | |||||
1286 | 0 | close STDERR; | |||||
1287 | 0 | open STDERR, ">&OLDERR"; | |||||
1288 | 0 | close OLDERR; | |||||
1289 | 0 | close STDIN; | |||||
1290 | 0 | open STDIN, "<&OLDIN"; | |||||
1291 | 0 | close OLDIN; | |||||
1292 | |||||||
1293 | 0 | 0 | if ($conf->{"SETUP_ENV"}) { | ||||
1294 | 0 | delete $ENV{"QUERY_STRING"}; | |||||
1295 | 0 | delete $ENV{"CONTENT_TYPE"}; | |||||
1296 | 0 | delete $ENV{"CONTENT_ENCODING"}; | |||||
1297 | 0 | delete $ENV{"CONTENT_LENGTH"}; | |||||
1298 | 0 | delete $ENV{"CONTENT_LANGUAGE"}; | |||||
1299 | } | ||||||
1300 | |||||||
1301 | 0 | $errs .= $evalerrs; | |||||
1302 | |||||||
1303 | 0 | 0 | if (length($errs) > 0) { | ||||
1304 | 0 | &$logging("[$id] ($s) \n$errs"); | |||||
1305 | } | ||||||
1306 | |||||||
1307 | 0 | 0 | if ($conf->{"WAIT_RESPONSE"} == 0) { return (1, 200, $page); } | ||||
0 | |||||||
1308 | |||||||
1309 | 0 | 0 | if ($evalerrs ne '') { | ||||
1310 | 0 | return (0, 500, $page); | |||||
1311 | } else { | ||||||
1312 | 0 | 0 | if ($r->{METHOD} eq "HEAD") { | ||||
1313 | 0 | return (1, 200, $self->__make_response("200", undef, undef, $auth)); | |||||
1314 | } else { | ||||||
1315 | 0 | return (1, 200, $self->__make_response("200", undef, $res, $auth)); | |||||
1316 | } | ||||||
1317 | } | ||||||
1318 | } else { | ||||||
1319 | 0 | return (0, 404, $page); | |||||
1320 | } | ||||||
1321 | } | ||||||
1322 | |||||||
1323 | # -------------------------------------------------------------------------------------- | ||||||
1324 | # Run a CGI script | ||||||
1325 | # | ||||||
1326 | |||||||
1327 | sub __do_cgi { | ||||||
1328 | 0 | 0 | my ($self, $id, $s, $r, $auth) = @_; | ||||
1329 | 0 | my $conf = $self->{CONF}; | |||||
1330 | |||||||
1331 | 0 | my $logging = $conf->{"DEBLOG_METHOD"}; | |||||
1332 | 0 | my $p = $r->{'CONTENT'}; | |||||
1333 | 0 | my $page = undef; | |||||
1334 | 0 | my $post = 0; | |||||
1335 | |||||||
1336 | 0 | $s = $conf->{"DOCUMENT_ROOT"} . $s; | |||||
1337 | |||||||
1338 | 0 | 0 | if (-e $s) { | ||||
1339 | 0 | $ENV{'REQUEST_METHOD'} = $r->{METHOD}; | |||||
1340 | 0 | 0 | if ($r->{METHOD} =~ /GET|HEAD/o) { | ||||
1341 | 0 | $ENV{"QUERY_STRING"} = $r->{'QUERY_STRING'}; | |||||
1342 | } else { | ||||||
1343 | 0 | $post = 1; | |||||
1344 | } | ||||||
1345 | 0 | 0 | if ($conf->{"SETUP_ENV"}) { | ||||
1346 | 0 | 0 | if (exists $r->{HEADERS}{"CONTENT-TYPE"}) { $ENV{"CONTENT_TYPE"} = $r->{HEADERS}{"CONTENT-TYPE"}; } | ||||
0 | |||||||
1347 | 0 | 0 | if (exists $r->{HEADERS}{"CONTENT-ENCODING"}) { $ENV{"CONTENT_ENCODING"} = $r->{HEADERS}{"CONTENT-ENCODING"}; } | ||||
0 | |||||||
1348 | 0 | 0 | if (exists $r->{HEADERS}{"CONTENT-LENGTH"}) { $ENV{"CONTENT_LENGTH"} = $r->{HEADERS}{"CONTENT-LENGTH"}; } | ||||
0 | |||||||
1349 | 0 | 0 | if (exists $r->{HEADERS}{"CONTENT-LANGUAGE"}) { $ENV{"CONTENT_LANGUAGE"} = $r->{HEADERS}{"CONTENT-LANGUAGE"}; } | ||||
0 | |||||||
1350 | } | ||||||
1351 | |||||||
1352 | 0 | my $pid; | |||||
1353 | my $res; | ||||||
1354 | 0 | my $errs; | |||||
1355 | |||||||
1356 | 0 | my ($IN, $OUT, $ERR); | |||||
1357 | |||||||
1358 | 1 | 1 | 13 | use Symbol; | |||
1 | 3 | ||||||
1 | 5155 | ||||||
1359 | 0 | $ERR = Symbol::gensym; | |||||
1360 | |||||||
1361 | 0 | 0 | if ($r->{METHOD} =~ /GET|HEAD/o) { | ||||
1362 | 0 | 0 | $pid = IPC::Open3::open3($IN,$OUT,$ERR,$s,$p) or return (0, 503, $page); | ||||
1363 | } else { | ||||||
1364 | 0 | 0 | $pid = IPC::Open3::open3($IN,$OUT,$ERR,$s) or return (0, 503, $page); | ||||
1365 | |||||||
1366 | 0 | binmode $IN; | |||||
1367 | 0 | print $IN $p; | |||||
1368 | 0 | close $IN; | |||||
1369 | } | ||||||
1370 | |||||||
1371 | 0 | my $sel = new IO::Select; | |||||
1372 | |||||||
1373 | 0 | $sel->add($OUT,$ERR); | |||||
1374 | |||||||
1375 | 0 | while(my @ready = $sel->can_read) { | |||||
1376 | 0 | foreach my $fh (@ready) { | |||||
1377 | 0 | my $line = <$fh>; | |||||
1378 | 0 | 0 | if (not defined $line) { | ||||
1379 | 0 | $sel->remove($fh); | |||||
1380 | 0 | next; | |||||
1381 | } | ||||||
1382 | 0 | 0 | if ($fh == $OUT) { $res .= $line; } | ||||
0 | 0 | ||||||
1383 | 0 | elsif ($fh == $ERR) { $errs .= $line; } | |||||
1384 | } | ||||||
1385 | } | ||||||
1386 | |||||||
1387 | 0 | 0 | if ($conf->{"SETUP_ENV"}) { | ||||
1388 | 0 | delete $ENV{"QUERY_STRING"}; | |||||
1389 | 0 | delete $ENV{"CONTENT_TYPE"}; | |||||
1390 | 0 | delete $ENV{"CONTENT_ENCODING"}; | |||||
1391 | 0 | delete $ENV{"CONTENT_LENGTH"}; | |||||
1392 | 0 | delete $ENV{"CONTENT_LANGUAGE"}; | |||||
1393 | } | ||||||
1394 | |||||||
1395 | 0 | 0 | if (length($errs) > 0) { | ||||
1396 | 0 | &$logging("[$id] ($s) \n$errs"); | |||||
1397 | } | ||||||
1398 | |||||||
1399 | 0 | 0 | if ($conf->{"WAIT_RESPONSE"} == 0) { return (1, 200, $page); } | ||||
0 | |||||||
1400 | |||||||
1401 | 0 | 0 | if ($r->{METHOD} eq "HEAD") { | ||||
1402 | 0 | return (1, 200, $self->__make_response("200", undef, undef, $auth)); | |||||
1403 | } else { | ||||||
1404 | 0 | return (1, 200, $self->__make_response("200", undef, $res, $auth)); | |||||
1405 | } | ||||||
1406 | } else { | ||||||
1407 | 0 | return (0, 404, $page); | |||||
1408 | } | ||||||
1409 | } | ||||||
1410 | |||||||
1411 | # -------------------------------------------------------------------------------------- | ||||||
1412 | # Make response to client given variable contents | ||||||
1413 | # | ||||||
1414 | |||||||
1415 | sub __make_response { | ||||||
1416 | 0 | 0 | my ($self, $code, $headers, $cont, $auth) = @_; | ||||
1417 | 0 | my $conf = $self->{CONF}; | |||||
1418 | |||||||
1419 | 0 | my $logging = $conf->{"DEBLOG_METHOD"}; | |||||
1420 | 0 | my $msg = $conf->{"HTML_CODES"}{$code}; | |||||
1421 | 0 | my $len = 0; | |||||
1422 | 0 | my $page = undef; | |||||
1423 | 0 | my $base_headers = ''; | |||||
1424 | 0 | 0 | if ($auth) { | ||||
1425 | 0 | $base_headers = "WWW-Authenticate: Basic realm=\"" . $conf->{"AUTH_REALM"} . "\"$CRLF"; | |||||
1426 | } | ||||||
1427 | 0 | my $http = "HTTP/1.1 $code ($msg) $CRLF"; | |||||
1428 | 0 | my $len = "Content-Length: 0$CRLF"; | |||||
1429 | |||||||
1430 | 0 | $base_headers .= "Server: WebIT $VERSION$CRLF"; | |||||
1431 | |||||||
1432 | 0 | my $extra_headers = ''; | |||||
1433 | |||||||
1434 | 0 | 0 | if (defined $headers) { | ||||
1435 | 0 | 0 | if (ref($headers) eq 'HASH') { | ||||
0 | |||||||
1436 | 0 | for my $k (keys %$headers) { | |||||
1437 | 0 | $extra_headers .= $k . ': ' . $headers->{$k} . $CRLF; | |||||
1438 | } | ||||||
1439 | } elsif (ref($headers) eq '') { | ||||||
1440 | 0 | $extra_headers = $headers; | |||||
1441 | } | ||||||
1442 | } | ||||||
1443 | |||||||
1444 | 0 | my $hr = $cont; | |||||
1445 | 0 | 0 | if (defined $cont) { | ||||
1446 | 0 | my $split; | |||||
1447 | 0 | ($hr, $split, $cont) = split(/($CRLF$CRLF|\n\n)/, $cont, 2); | |||||
1448 | 0 | 0 | 0 | if (($cont eq '') && ($split eq '')) { | |||
1449 | 0 | $cont = $hr; | |||||
1450 | 0 | $hr = ''; | |||||
1451 | } | ||||||
1452 | 0 | $hr =~ s/($CRLF|\n)$//gc; | |||||
1453 | 0 | 0 | if ($hr ne '') { | ||||
1454 | 0 | $http .= $hr . $CRLF; | |||||
1455 | } | ||||||
1456 | 0 | $len = "Content-Length: " . length($cont) . $CRLF; | |||||
1457 | } | ||||||
1458 | |||||||
1459 | 0 | my $total_headers = $http . $base_headers . $extra_headers . $len . $CRLF; | |||||
1460 | |||||||
1461 | 0 | $page = $total_headers . $cont; | |||||
1462 | |||||||
1463 | 0 | 0 | if ($conf->{'LOG_PACKETS'}) { | ||||
1464 | 0 | &$logging($page); | |||||
1465 | } else { | ||||||
1466 | 0 | 0 | if ($conf->{'LOG_HEADERS'}) { | ||||
1467 | 0 | &$logging($total_headers); | |||||
1468 | } | ||||||
1469 | } | ||||||
1470 | |||||||
1471 | 0 | return $page; | |||||
1472 | } | ||||||
1473 | |||||||
1474 | # -------------------------------------------------------------------------------------- | ||||||
1475 | # Make response given error and check if there is an error page to send as well | ||||||
1476 | # | ||||||
1477 | |||||||
1478 | sub __make_error { | ||||||
1479 | 0 | 0 | my ($self, $code, $auth, $id, $rhost, $rport, $r) = @_; | ||||
1480 | 0 | my $conf = $self->{CONF}; | |||||
1481 | |||||||
1482 | 0 | my $msg = $conf->{"HTML_CODES"}{$code}; | |||||
1483 | 0 | my $logging = $conf->{"LOG_METHOD"}; | |||||
1484 | |||||||
1485 | 0 | my $page = undef; | |||||
1486 | |||||||
1487 | 0 | 0 | if ($conf->{'SETUP_ENV'}) { | ||||
1488 | 0 | $ENV{'ERROR_CODE'} = $code; | |||||
1489 | 0 | $ENV{'ERROR_TEXT'} = $msg; | |||||
1490 | 0 | $ENV{'ERROR_URI'} = $r->{URI}; | |||||
1491 | 0 | $ENV{'ERROR_METHOD'} = $r->{METHOD}; | |||||
1492 | } | ||||||
1493 | |||||||
1494 | 0 | 0 | if (exists $conf->{'ERROR_PAGES'}) { | ||||
1495 | 0 | 0 | 0 | if ((exists $conf->{'ERROR_PAGES'}{$code}) && | |||
0 | 0 | ||||||
0 | |||||||
0 | |||||||
1496 | ((-e $conf->{'DOCUMENT_ROOT'}.$conf->{'ERROR_PAGES'}{$code}) || | ||||||
1497 | (exists $conf->{'DOCUMENTS'}{$conf->{'ERROR_PAGES'}{$code}}) | ||||||
1498 | ) | ||||||
1499 | ) { | ||||||
1500 | 0 | $r->{METHOD} = 'GET'; | |||||
1501 | 0 | $r->{URI} = $conf->{'ERROR_PAGES'}{$code}; | |||||
1502 | 0 | my $page = $self->__get_page($id, $rhost, $rport, $r, 0); | |||||
1503 | 0 | 0 | if (defined $page) { | ||||
1504 | 0 | $page =~ s/^(.+)\s+\d+\s+\(.*\)(\s*$CRLF)/$1 $code ($msg)$2/; | |||||
1505 | } | ||||||
1506 | 0 | return $page; | |||||
1507 | |||||||
1508 | } elsif ((exists $conf->{'ERROR_PAGES'}{'ALL'}) && | ||||||
1509 | ((-e $conf->{'DOCUMENT_ROOT'}.$conf->{'ERROR_PAGES'}{'ALL'}) || | ||||||
1510 | (exists $conf->{'DOCUMENTS'}{$conf->{'ERROR_PAGES'}{'ALL'}}) | ||||||
1511 | ) | ||||||
1512 | ) { | ||||||
1513 | 0 | $r->{METHOD} = 'GET'; | |||||
1514 | 0 | $r->{URI} = $conf->{'ERROR_PAGES'}{'ALL'}; | |||||
1515 | 0 | my $page = $self->__get_page($id, $rhost, $rport, $r, 0); | |||||
1516 | 0 | 0 | if (defined $page) { | ||||
1517 | 0 | $page =~ s/^(.+)\s+\d+\s+\(.*\)(\s*$CRLF)/$1 $code ($msg)$2/; | |||||
1518 | } | ||||||
1519 | 0 | return $page; | |||||
1520 | |||||||
1521 | } | ||||||
1522 | } | ||||||
1523 | |||||||
1524 | |||||||
1525 | 0 | my $pmeth = sprintf("%-4s", $r->{METHOD}); | |||||
1526 | 0 | &$logging("[$id] $pmeth [ERROR] from $rhost:$rport got ($code " . $msg. ")"); | |||||
1527 | |||||||
1528 | 0 | my $cont = "$code $msg"; |
|||||
1529 | |||||||
1530 | 0 | my %headers = (); | |||||
1531 | 0 | $headers{'Content-type'} = 'text/html'; | |||||
1532 | |||||||
1533 | 0 | return $self->__make_response($code, \%headers, $cont, $auth); | |||||
1534 | } | ||||||
1535 | |||||||
1536 | # -------------------------------------------------------------------------------------- | ||||||
1537 | # Perform fork start initialization | ||||||
1538 | # | ||||||
1539 | |||||||
1540 | sub __pre_fork { | ||||||
1541 | 0 | 0 | my ($self, $id) = @_; | ||||
1542 | 0 | my $rconf = $self->{CONF}; | |||||
1543 | |||||||
1544 | # Pre fork is only for workers | ||||||
1545 | # if ($id =~ /^S\d+$/) { return; } | ||||||
1546 | |||||||
1547 | 0 | 0 | if (defined $rconf->{"STARTUP"}) { | ||||
1548 | 0 | $0 = $rconf->{"PROC_PREFIX"} . " loading startup "; | |||||
1549 | 0 | 0 | if (!$self->__load_startup()) { | ||||
1550 | 0 | return; | |||||
1551 | } | ||||||
1552 | } | ||||||
1553 | |||||||
1554 | 0 | my $f = $rconf->{"CHILD_START"}; | |||||
1555 | 0 | 0 | if (defined $f) { | ||||
1556 | |||||||
1557 | 0 | $0 = $rconf->{"PROC_PREFIX"} . " running pre-fork "; | |||||
1558 | |||||||
1559 | 0 | my $logging = $rconf->{"DEBLOG_METHOD"}; | |||||
1560 | 0 | my $logging2 = $rconf->{"LOG_METHOD"}; | |||||
1561 | 0 | my $errs = ''; | |||||
1562 | 0 | my $res = ''; | |||||
1563 | |||||||
1564 | # save all STD files | ||||||
1565 | 0 | open OLDERR, ">&STDERR"; | |||||
1566 | 0 | open OLDOUT, ">&STDOUT"; | |||||
1567 | |||||||
1568 | # reopen STDERR to $errs string | ||||||
1569 | 0 | close STDERR; | |||||
1570 | 0 | open STDERR, ">", \$errs; | |||||
1571 | |||||||
1572 | # reopen STDOUT to $res string | ||||||
1573 | 0 | close STDOUT; | |||||
1574 | 0 | open STDOUT, ">", \$res; | |||||
1575 | 0 | binmode STDOUT; | |||||
1576 | |||||||
1577 | 0 | my $evalerr; | |||||
1578 | 0 | eval { | |||||
1579 | 0 | $data = &$f; | |||||
1580 | 0 | $evalerr = $@; | |||||
1581 | }; | ||||||
1582 | |||||||
1583 | 0 | close STDOUT; | |||||
1584 | 0 | open STDOUT, ">&OLDOUT"; | |||||
1585 | 0 | close OLDOUT; | |||||
1586 | 0 | close STDERR; | |||||
1587 | 0 | open STDERR, ">&OLDERR"; | |||||
1588 | 0 | close OLDERR; | |||||
1589 | |||||||
1590 | 0 | $errs .= $evalerr; | |||||
1591 | |||||||
1592 | 0 | 0 | if (length($errs) > 0) { | ||||
1593 | 0 | &$logging("[$id] (Child start) \n$errs"); | |||||
1594 | } | ||||||
1595 | |||||||
1596 | 0 | &$logging2("[$id] Child ready\n"); | |||||
1597 | } | ||||||
1598 | |||||||
1599 | 0 | return; | |||||
1600 | } | ||||||
1601 | |||||||
1602 | # -------------------------------------------------------------------------------------- | ||||||
1603 | # Perform fork stop de-initialization | ||||||
1604 | # | ||||||
1605 | |||||||
1606 | sub __post_fork { | ||||||
1607 | 0 | 0 | my ($self, $id) = @_; | ||||
1608 | 0 | my $rconf = $self->{CONF}; | |||||
1609 | |||||||
1610 | # Post fork is only for workers | ||||||
1611 | # if ($id =~ /^S\d+$/) { return; } | ||||||
1612 | |||||||
1613 | 0 | my $f = $rconf->{"CHILD_END"}; | |||||
1614 | 0 | 0 | if (defined $f) { | ||||
1615 | |||||||
1616 | 0 | my $logging = $rconf->{"DEBLOG_METHOD"}; | |||||
1617 | 0 | my $logging2 = $rconf->{"LOG_METHOD"}; | |||||
1618 | 0 | my $errs = ''; | |||||
1619 | 0 | my $res = ''; | |||||
1620 | |||||||
1621 | # save all STD files | ||||||
1622 | 0 | open OLDERR, ">&STDERR"; | |||||
1623 | 0 | open OLDOUT, ">&STDOUT"; | |||||
1624 | |||||||
1625 | # reopen STDERR to $errs string | ||||||
1626 | 0 | close STDERR; | |||||
1627 | 0 | open STDERR, ">", \$errs; | |||||
1628 | |||||||
1629 | # reopen STDOUT to $res string | ||||||
1630 | 0 | close STDOUT; | |||||
1631 | 0 | open STDOUT, ">", \$res; | |||||
1632 | 0 | binmode STDOUT; | |||||
1633 | |||||||
1634 | 0 | my $evalerr; | |||||
1635 | 0 | eval { | |||||
1636 | 0 | &$f($data); | |||||
1637 | 0 | $evalerr = $@; | |||||
1638 | }; | ||||||
1639 | |||||||
1640 | 0 | close STDOUT; | |||||
1641 | 0 | open STDOUT, ">&OLDOUT"; | |||||
1642 | 0 | close OLDOUT; | |||||
1643 | 0 | close STDERR; | |||||
1644 | 0 | open STDERR, ">&OLDERR"; | |||||
1645 | 0 | close OLDERR; | |||||
1646 | |||||||
1647 | 0 | $errs .= $evalerr; | |||||
1648 | |||||||
1649 | 0 | 0 | if (length($errs) > 0) { | ||||
1650 | 0 | &$logging("[$id] (Child end) \n$errs"); | |||||
1651 | } | ||||||
1652 | |||||||
1653 | 0 | &$logging2("[$id] Child finished\n"); | |||||
1654 | } | ||||||
1655 | |||||||
1656 | 0 | return; | |||||
1657 | } | ||||||
1658 | |||||||
1659 | # -------------------------------------------------------------------------------------- | ||||||
1660 | # Patch configuration for our needs | ||||||
1661 | # | ||||||
1662 | |||||||
1663 | sub __fix_conf { | ||||||
1664 | 0 | 0 | my ($rconf) = @_; | ||||
1665 | |||||||
1666 | 0 | 0 | if (not defined $rconf->{"SERVER_NAME"}) { | ||||
1667 | 0 | $rconf->{"SERVER_NAME"} = "localhost" | |||||
1668 | } | ||||||
1669 | 0 | 0 | if (not defined $rconf->{"SERVER_IP"}) { | ||||
1670 | 0 | $rconf->{"SERVER_IP"} = "127.0.0.1"; | |||||
1671 | } | ||||||
1672 | 0 | 0 | if (not defined $rconf->{"SERVER_PORT"}) { | ||||
1673 | 0 | $rconf->{"SERVER_PORT"} = 80; | |||||
1674 | } | ||||||
1675 | 0 | 0 | if (not defined $rconf->{"WAIT_RESPONSE"}) { | ||||
1676 | 0 | $rconf->{"WAIT_RESPONSE"} = 1; | |||||
1677 | } | ||||||
1678 | 0 | 0 | if (not defined $rconf->{"NO_WAIT_REPLY"}) { | ||||
1679 | 0 | $rconf->{"NO_WAIT_REPLY"} = 204; | |||||
1680 | } | ||||||
1681 | 0 | 0 | if (not defined $rconf->{"IMMED_CLOSE"}) { | ||||
1682 | 0 | $rconf->{"IMMED_CLOSE"} = 0; | |||||
1683 | } | ||||||
1684 | 0 | 0 | if (not defined $rconf->{"SOFTWARE"}) { | ||||
1685 | 0 | $rconf->{"SOFTWARE"} = "WebIT/$VERSION"; | |||||
1686 | } | ||||||
1687 | 0 | 0 | if (not defined $rconf->{"SIGNATURE"}) { | ||||
1688 | 0 | $rconf->{"SIGNATURE"} = " WebIT/$VERSION for Perl "; |
|||||
1689 | } | ||||||
1690 | 0 | 0 | if (not defined $rconf->{"PROC_PREFIX"}) { | ||||
1691 | 0 | $rconf->{"PROC_PREFIX"} = 'WebIT'; | |||||
1692 | } | ||||||
1693 | 0 | $rconf->{"PROC_PREFIX"} =~ s/\s\s/\s/go; | |||||
1694 | 0 | 0 | if (not defined $rconf->{"EMBED_PERL"}) { | ||||
1695 | 0 | $rconf->{"EMBED_PERL"} = 1; | |||||
1696 | } | ||||||
1697 | 0 | 0 | if (not defined $rconf->{"QUEUE_SIZE"}) { | ||||
1698 | 0 | $rconf->{"QUEUE_SIZE"} = 5; | |||||
1699 | } | ||||||
1700 | 0 | 0 | if (defined $rconf->{"DOCUMENT_ROOT"}) { | ||||
1701 | 0 | 0 | if ($rconf->{"DOCUMENT_ROOT"} !~ /\/$/) { | ||||
1702 | 0 | $rconf->{"DOCUMENT_ROOT"} .= "/"; | |||||
1703 | } | ||||||
1704 | } else { | ||||||
1705 | 0 | $rconf->{"DOCUMENT_ROOT"} = undef; | |||||
1706 | } | ||||||
1707 | |||||||
1708 | 0 | 0 | if (not defined $rconf->{"SETUP_ENV"}) { | ||||
1709 | 0 | $rconf->{"SETUP_ENV"} = 1; | |||||
1710 | } | ||||||
1711 | |||||||
1712 | 0 | 0 | if (length($rconf->{"STARTUP"}) > 0) { | ||||
1713 | 0 | $rconf->{"STARTUP"} =~ s/\/\//\//gco; | |||||
1714 | } | ||||||
1715 | |||||||
1716 | 0 | 0 | if (not defined $rconf->{"ENV_KEEP"}) { | ||||
1717 | 0 | push(@{$rconf->{"ENV_KEEP"}}, 'PATH'); | |||||
0 | |||||||
1718 | } | ||||||
1719 | |||||||
1720 | 0 | 0 | if (not defined $rconf->{"ENV_ADD"}) { | ||||
1721 | 0 | $rconf->{"ENV_ADD"} = (); | |||||
1722 | } | ||||||
1723 | |||||||
1724 | 0 | 0 | if (not defined $rconf->{"MIME_TYPES"}) { | ||||
1725 | 0 | $rconf->{"MIME_TYPES"} = '/etc/mime.types'; | |||||
1726 | } | ||||||
1727 | |||||||
1728 | 0 | 0 | if (not defined $rconf->{"SERVERS"}) { | ||||
1729 | 0 | $rconf->{"SERVERS"} = 0; | |||||
1730 | } | ||||||
1731 | |||||||
1732 | 0 | 0 | if (not defined $rconf->{"WORKERS"}) { | ||||
1733 | 0 | $rconf->{"WORKERS"} = 0; | |||||
1734 | } | ||||||
1735 | |||||||
1736 | 0 | 0 | if (not defined $rconf->{"FORK_CONN"}) { | ||||
1737 | 0 | $rconf->{"FORK_CONN"} = 0; | |||||
1738 | } | ||||||
1739 | |||||||
1740 | 0 | 0 | if ($rconf->{"FORK_CONN"}) { | ||||
1741 | 0 | $rconf->{"WORKERS"} = 0; | |||||
1742 | } | ||||||
1743 | |||||||
1744 | 0 | 0 | if (not defined $rconf->{"USE_SSL"}) { | ||||
1745 | 0 | $rconf->{"USE_SSL"} = 0; | |||||
1746 | 0 | $rconf->{"SSL_CERTIFICATE"} = undef; | |||||
1747 | 0 | $rconf->{"SSL_KEY"} = undef; | |||||
1748 | } | ||||||
1749 | |||||||
1750 | 0 | 0 | if (not defined $rconf->{"LOG_METHOD"}) { | ||||
1751 | 0 | 0 | if ($rconf->{"NO_LOGGING"}) { | ||||
1752 | 0 | $rconf->{"LOG_METHOD"} = 'EmbedIT::WebIT::__no_logging'; | |||||
1753 | } else { | ||||||
1754 | 0 | $rconf->{"LOG_METHOD"} = 'EmbedIT::WebIT::__logging'; | |||||
1755 | } | ||||||
1756 | } | ||||||
1757 | 0 | 0 | if (not defined $rconf->{"DEBLOG_METHOD"}) { | ||||
1758 | 0 | $rconf->{"DEBLOG_METHOD"} = $rconf->{"LOG_METHOD"}; | |||||
1759 | } | ||||||
1760 | |||||||
1761 | 0 | 0 | if (not defined $rconf->{"LOG_HEADERS"}) { | ||||
1762 | 0 | $rconf->{"LOG_HEADERS"} = 0; | |||||
1763 | } | ||||||
1764 | |||||||
1765 | 0 | 0 | if (not defined $rconf->{"LOG_PACKETS"}) { | ||||
1766 | 0 | $rconf->{"LOG_PACKETS"} = 0; | |||||
1767 | } | ||||||
1768 | |||||||
1769 | 0 | 0 | if ($rconf->{'LOG_PACKETS'}) { | ||||
1770 | 0 | $rconf->{"LOG_HEADERS"} = 1; | |||||
1771 | } | ||||||
1772 | |||||||
1773 | 0 | 0 | if (defined $rconf->{"CGI_PATH"}) { | ||||
1774 | 0 | $rconf->{"CGI_PATH_PRINT"} = $rconf->{"CGI_PATH"}; | |||||
1775 | # transform CGI_PATH to a regular expression for single step matching | ||||||
1776 | 0 | $rconf->{"CGI_PATH"} =~ s/\s(:|;)\s/$1/g; | |||||
1777 | 0 | $rconf->{"CGI_PATH"} =~ s/(:|;)/\/$1/g; | |||||
1778 | 0 | $rconf->{"CGI_PATH"} =~ s/$/\//g; | |||||
1779 | 0 | $rconf->{"CGI_PATH"} =~ s/\/\//\//g; | |||||
1780 | 0 | $rconf->{"CGI_PATH"} =~ s/\//\\\//g; | |||||
1781 | 0 | $rconf->{"CGI_PATH"} =~ s/^(.)/($1/g; | |||||
1782 | 0 | $rconf->{"CGI_PATH"} =~ s/(.)$/$1)/g; | |||||
1783 | 0 | $rconf->{"CGI_PATH"} =~ s/(:|;)/)|(/g; | |||||
1784 | 0 | $rconf->{"CGI_PATH"} =~ s/\)/.*?\\\..*)/g; | |||||
1785 | } | ||||||
1786 | 0 | 0 | if (defined $rconf->{"AUTH_PATH"}) { | ||||
1787 | 0 | $rconf->{"AUTH_PATH_PRINT"} = $rconf->{"AUTH_PATH"}; | |||||
1788 | # transform AUTH_PATH to a regular expression for single step matching | ||||||
1789 | 0 | $rconf->{"AUTH_PATH"} =~ s/\s(:|;)\s/$1/g; | |||||
1790 | 0 | $rconf->{"AUTH_PATH"} =~ s/(:|;)/\/$1/g; | |||||
1791 | 0 | $rconf->{"AUTH_PATH"} =~ s/$/\//g; | |||||
1792 | 0 | $rconf->{"AUTH_PATH"} =~ s/\/\//\//g; | |||||
1793 | 0 | $rconf->{"AUTH_PATH"} =~ s/\//\\\//g; | |||||
1794 | 0 | $rconf->{"AUTH_PATH"} =~ s/^(.)/($1/g; | |||||
1795 | 0 | $rconf->{"AUTH_PATH"} =~ s/(.)$/$1)/g; | |||||
1796 | 0 | $rconf->{"AUTH_PATH"} =~ s/(:|;)/)|(/g; | |||||
1797 | } | ||||||
1798 | |||||||
1799 | 0 | 0 | if (not exists $rconf->{"HTML_CODES"}) { | ||||
1800 | 0 | $rconf->{"HTML_CODES"} = { | |||||
1801 | 100 => "Continue", | ||||||
1802 | 101 => "Switching Protocols", | ||||||
1803 | 200 => "OK", | ||||||
1804 | 201 => "Created", | ||||||
1805 | 202 => "Accepted", | ||||||
1806 | 203 => "Non-Authoritative Information", | ||||||
1807 | 204 => "No Content", | ||||||
1808 | 205 => "Reset Content", | ||||||
1809 | 206 => "Partial Content", | ||||||
1810 | 300 => "Multiple Choices", | ||||||
1811 | 301 => "Moved Permanently", | ||||||
1812 | 302 => "Found", | ||||||
1813 | 303 => "See Other", | ||||||
1814 | 304 => "Not Modified", | ||||||
1815 | 305 => "Use Proxy", | ||||||
1816 | 306 => "No Longer Used", | ||||||
1817 | 307 => "Temporary Redirect", | ||||||
1818 | 400 => "Bad Request", | ||||||
1819 | 401 => "Not Authorised", | ||||||
1820 | 402 => "Payment Required", | ||||||
1821 | 403 => "Forbidden", | ||||||
1822 | 404 => "Not Found", | ||||||
1823 | 405 => "Method Not Allowed", | ||||||
1824 | 406 => "Not Acceptable", | ||||||
1825 | 407 => "Proxy Authentication Required", | ||||||
1826 | 408 => "Request Timeout", | ||||||
1827 | 409 => "Conflict", | ||||||
1828 | 410 => "Gone", | ||||||
1829 | 411 => "Length Required", | ||||||
1830 | 412 => "Precondition Failed", | ||||||
1831 | 413 => "Request Entity Too Large", | ||||||
1832 | 414 => "Request URI Too Long", | ||||||
1833 | 415 => "Unsupported Media Type", | ||||||
1834 | 416 => "Requested Range Not Satisfiable", | ||||||
1835 | 417 => "Expectation Failed", | ||||||
1836 | 500 => "Internal Server Error", | ||||||
1837 | 501 => "Not Implemented", | ||||||
1838 | 502 => "Bad Gateway", | ||||||
1839 | 503 => "Service Unavailable", | ||||||
1840 | 504 => "Gateway Timeout", | ||||||
1841 | 505 => "HTTP Version Not Supported", | ||||||
1842 | }; | ||||||
1843 | } | ||||||
1844 | } | ||||||
1845 | |||||||
1846 | # -------------------------------------------------------------------------------------- | ||||||
1847 | # Clean up the process environment variables | ||||||
1848 | # | ||||||
1849 | |||||||
1850 | sub __clean_env { | ||||||
1851 | 0 | 0 | my ($conf) = @_; | ||||
1852 | |||||||
1853 | 0 | foreach my $k (keys %ENV) { | |||||
1854 | 0 | my $found = 0; | |||||
1855 | 0 | foreach my $w (@{$conf->{"ENV_KEEP"}}) { | |||||
0 | |||||||
1856 | 0 | 0 | if ($k eq $w) { $found = 1; } | ||||
0 | |||||||
1857 | } | ||||||
1858 | 0 | 0 | if (!$found) { delete $ENV{$k} }; | ||||
0 | |||||||
1859 | } | ||||||
1860 | |||||||
1861 | 0 | 0 | if ($conf->{"SETUP_ENV"}) { | ||||
1862 | 0 | $ENV{"SERVER_NAME"} = $conf->{"SERVER_NAME"}; | |||||
1863 | 0 | $ENV{"SERVER_PORT"} = $conf->{"SERVER_PORT"}; | |||||
1864 | 0 | $ENV{"SERVER_ADMIN"} = $conf->{"SERVER_ADMIN"}; | |||||
1865 | 0 | $ENV{"DOCUMENT_ROOT"} = $conf->{"DOCUMENT_ROOT"}; | |||||
1866 | 0 | $ENV{"SERVER_PROTOCOL"} = "HTTP/1.1"; | |||||
1867 | 0 | $ENV{"SERVER_SOFTWARE"} = $conf->{"SOFTWARE"}; | |||||
1868 | 0 | $ENV{"SERVER_SIGNATURE"} = $conf->{"SIGNATURE"}; | |||||
1869 | 0 | $ENV{"GATEWAY_INTERFACE"} = "CGI/1.1 WebIT for Perl"; | |||||
1870 | 0 | 0 | if ($conf->{"EMBED_PERL"}) { | ||||
1871 | 0 | $ENV{"WEBIT_DATA"} = "INTERNAL"; | |||||
1872 | } | ||||||
1873 | } | ||||||
1874 | 0 | foreach my $k (keys %{$conf->{"ENV_ADD"}}) { | |||||
0 | |||||||
1875 | 0 | $ENV{$k} = $conf->{"ENV_ADD"}->{$k}; | |||||
1876 | } | ||||||
1877 | } | ||||||
1878 | |||||||
1879 | # -------------------------------------------------------------------------------------- | ||||||
1880 | # Fix environment variables for current request | ||||||
1881 | # | ||||||
1882 | |||||||
1883 | sub __fix_env { | ||||||
1884 | 0 | 0 | my ($self, $r) = @_; | ||||
1885 | |||||||
1886 | 0 | for my $k (keys %{ $r->{HEADERS} }) { | |||||
0 | |||||||
1887 | 0 | 0 | if ($k !~ /CONTENT-LENGTH|COOKIE/) { | ||||
1888 | 0 | my $l = $k; | |||||
1889 | 0 | $l =~ s/[^A-Za-z0-9_]/_/gco; | |||||
1890 | 0 | $l = 'HTTP_' . $l; | |||||
1891 | 0 | $ENV{$l} = $r->{HEADERS}{$k}; | |||||
1892 | } | ||||||
1893 | } | ||||||
1894 | 0 | 0 | if (exists $r->{HEADERS}{'COOKIE'}) { | ||||
1895 | 0 | $ENV{'COOKIE'} = $r->{HEADERS}{'COOKIE'}; | |||||
1896 | } else { | ||||||
1897 | 0 | delete $ENV{'COOKIE'}; | |||||
1898 | } | ||||||
1899 | } | ||||||
1900 | |||||||
1901 | # -------------------------------------------------------------------------------------- | ||||||
1902 | # Load a file a return its contents or undef on error | ||||||
1903 | # | ||||||
1904 | |||||||
1905 | sub __load_file { | ||||||
1906 | 0 | 0 | my ($self, $f) = @_; | ||||
1907 | |||||||
1908 | 0 | 0 | open FILE, $f || return undef; | ||||
1909 | 0 | binmode FILE; | |||||
1910 | 0 | my @l = |
|||||
1911 | 0 | close FILE; | |||||
1912 | |||||||
1913 | 0 | return join('',@l); | |||||
1914 | } | ||||||
1915 | |||||||
1916 | # -------------------------------------------------------------------------------------- | ||||||
1917 | # Load startup file to fix server environment | ||||||
1918 | # | ||||||
1919 | |||||||
1920 | sub __load_startup { | ||||||
1921 | 0 | 0 | my ($self) = @_; | ||||
1922 | 0 | my $conf = $self->{CONF}; | |||||
1923 | |||||||
1924 | 0 | my $logging = $conf->{"DEBLOG_METHOD"}; | |||||
1925 | |||||||
1926 | 0 | my $scr = $self->__load_file($conf->{"STARTUP"}); | |||||
1927 | 0 | 0 | if (not defined $scr) { | ||||
1928 | 0 | &$logging("Startup file cannot be loaded"); | |||||
1929 | 0 | return 0; | |||||
1930 | } | ||||||
1931 | |||||||
1932 | 0 | my $errs = ''; | |||||
1933 | 0 | my $res = ''; | |||||
1934 | |||||||
1935 | # save all STD files | ||||||
1936 | 0 | open OLDERR, ">&STDERR"; | |||||
1937 | 0 | open OLDOUT, ">&STDOUT"; | |||||
1938 | |||||||
1939 | # reopen STDERR to $errs string | ||||||
1940 | 0 | close STDERR; | |||||
1941 | 0 | open STDERR, ">", \$errs; | |||||
1942 | |||||||
1943 | # reopen STDOUT to $res string | ||||||
1944 | 0 | close STDOUT; | |||||
1945 | 0 | open STDOUT, ">", \$res; | |||||
1946 | 0 | binmode STDOUT; | |||||
1947 | |||||||
1948 | 0 | my $evalerr; | |||||
1949 | 0 | eval { | |||||
1950 | 0 | eval($scr); | |||||
1951 | 0 | $evalerr = $@; | |||||
1952 | }; | ||||||
1953 | |||||||
1954 | 0 | close STDOUT; | |||||
1955 | 0 | open STDOUT, ">&OLDOUT"; | |||||
1956 | 0 | close OLDOUT; | |||||
1957 | 0 | close STDERR; | |||||
1958 | 0 | open STDERR, ">&OLDERR"; | |||||
1959 | 0 | close OLDERR; | |||||
1960 | |||||||
1961 | 0 | $errs .= $evalerr; | |||||
1962 | |||||||
1963 | 0 | 0 | if (length($errs) > 0) { | ||||
1964 | 0 | &$logging("(" . $conf->{"STARTUP"} . ") \n$errs"); | |||||
1965 | } | ||||||
1966 | |||||||
1967 | 0 | 0 | if ($evalerr ne '') { return 0; } | ||||
0 | |||||||
1968 | |||||||
1969 | 0 | return 1; | |||||
1970 | } | ||||||
1971 | |||||||
1972 | # -------------------------------------------------------------------------------------- | ||||||
1973 | # get user id from given id or name | ||||||
1974 | # | ||||||
1975 | |||||||
1976 | sub __get_uid { | ||||||
1977 | 0 | 0 | my ($i_id) = @_; | ||||
1978 | |||||||
1979 | 0 | my ($n, $p, $uid, $gid, $quota, $comment, $gcos, $dir, $shell, $expire) = getpwnam($i_id); | |||||
1980 | 0 | 0 | if (not defined $uid) { | ||||
1981 | 0 | ($n, $p, $uid, $gid, $quota, $comment, $gcos, $dir, $shell, $expire) = getpwuid($i_id); | |||||
1982 | 0 | 0 | if (not defined $uid) { | ||||
1983 | 0 | return 0; | |||||
1984 | } | ||||||
1985 | } | ||||||
1986 | |||||||
1987 | 0 | return $uid; | |||||
1988 | } | ||||||
1989 | |||||||
1990 | # -------------------------------------------------------------------------------------- | ||||||
1991 | # get group id from given id or name | ||||||
1992 | # | ||||||
1993 | |||||||
1994 | sub __get_gid { | ||||||
1995 | 0 | 0 | my ($i_id) = @_; | ||||
1996 | |||||||
1997 | 0 | my ($n, $p, $gid, $members) = getgrnam($i_id); | |||||
1998 | 0 | 0 | if (not defined $gid) { | ||||
1999 | 0 | ($n, $p, $gid, $members) = getgrgid($i_id); | |||||
2000 | 0 | 0 | if (not defined $gid) { | ||||
2001 | 0 | return 0; | |||||
2002 | } | ||||||
2003 | } | ||||||
2004 | 0 | return $gid; | |||||
2005 | } | ||||||
2006 | |||||||
2007 | # -------------------------------------------------------------------------------------- | ||||||
2008 | # Empty logger | ||||||
2009 | # | ||||||
2010 | |||||||
2011 | 0 | 0 | sub __no_logging { | ||||
2012 | } | ||||||
2013 | |||||||
2014 | # -------------------------------------------------------------------------------------- | ||||||
2015 | # Elementary log | ||||||
2016 | # | ||||||
2017 | |||||||
2018 | sub __logging { | ||||||
2019 | 0 | 0 | my ($self, $str) = @_; | ||||
2020 | 0 | 0 | if (ref($self) eq '') { | ||||
2021 | 0 | print STDERR time2iso(time) . " - $self\n"; | |||||
2022 | } else { | ||||||
2023 | 0 | print STDERR time2iso(time) . " - $str\n"; | |||||
2024 | } | ||||||
2025 | } | ||||||
2026 | |||||||
2027 | # -------------------------------------------------------------------------------------- | ||||||
2028 | |||||||
2029 | 1; | ||||||
2030 | |||||||
2031 | =head1 NAME | ||||||
2032 | |||||||
2033 | EmbedIT::WebIT - A small yet very effective embeded web server for any perl application | ||||||
2034 | |||||||
2035 | =head1 Synopsis | ||||||
2036 | |||||||
2037 | use EmbedIT::WebIT; | ||||||
2038 | |||||||
2039 | $server = new EmbedIT::WebIT( SERVER_NAME => 'www.my.org', | ||||||
2040 | SERVER_IP => '127.0.0.1', | ||||||
2041 | SERVER_PORT => 8080, | ||||||
2042 | SOFTWARE => 'MyApp web server', | ||||||
2043 | QUEUE_SIZE => 100, | ||||||
2044 | RUN_AS_USER => nobody, | ||||||
2045 | RUN_AS_GROUP => nogroup, | ||||||
2046 | WAIT_RESPONSE => 1, | ||||||
2047 | IMMED_CLOSE => 1, | ||||||
2048 | EMBED_PERL => 1, | ||||||
2049 | FORK_CONN => 0, | ||||||
2050 | SETUP_ENV => 1, | ||||||
2051 | SERVER_ADMIN => 'info@my.org', | ||||||
2052 | SERVERS => 3, | ||||||
2053 | WORKERS => 1, | ||||||
2054 | DOCUMENT_ROOT => '/opt/my/web', | ||||||
2055 | DOCUMENTS => { | ||||||
2056 | '/index.html' => 'WPages::index', | ||||||
2057 | '/error.html' => 'WPages::error', | ||||||
2058 | '/style.css' => 'WPages::style', | ||||||
2059 | '/print.css' => 'WPages::print', | ||||||
2060 | '/404.html' => 'WPages::error404', | ||||||
2061 | '*' => 'WPages::pageHandle', | ||||||
2062 | }, | ||||||
2063 | ERROR_PAGES => { | ||||||
2064 | '404' => '/404.html', # embeded subroutine error | ||||||
2065 | 'ALL' => '/error.html', # simple html file error | ||||||
2066 | }, | ||||||
2067 | EXPIRATIONS => { | ||||||
2068 | 'image/jpg' => 86400, | ||||||
2069 | 'ALL' => 3600, | ||||||
2070 | }, | ||||||
2071 | PROC_PREFIX => 'my:', | ||||||
2072 | CHILD_START => 'WControl::start_db', | ||||||
2073 | CHILD_END => 'WControl::stop_db', | ||||||
2074 | LOG_METHOD => 'WControl::logInfo', | ||||||
2075 | DEBLOG_METHOD => 'WControl::logDebug', | ||||||
2076 | LOG_HEADERS => 0, | ||||||
2077 | LOG_PACKETS => 0, | ||||||
2078 | CGI_PATH => '/cgi', | ||||||
2079 | ENV_KEEP => [ 'PERL5LIB', 'LD_LIBRARY_PATH' ], | ||||||
2080 | NO_LOGGING => 0, | ||||||
2081 | ); | ||||||
2082 | |||||||
2083 | $server->execute(); | ||||||
2084 | |||||||
2085 | =head1 Description | ||||||
2086 | |||||||
2087 | The WebIT embeded web server was created a long time ago to make a pure perl application that will interact | ||||||
2088 | directly with I |
||||||
2089 | its scripts before going back to serve another SMS message. In this respect WebIT is a hack and can be | ||||||
2090 | configured to behave in a manner which is not according to the RFC's for HTTP. Yet, creating Perl applications | ||||||
2091 | with WebIT using embeded html pages as perl functions outperforms Apache with mod_perl installations. | ||||||
2092 | |||||||
2093 | For this reason I was asked by a few to release this code so that they can use it for their applications. | ||||||
2094 | |||||||
2095 | So even though WebIT is not complete (Workers and SSL not implemented yet) WebIT is already used by | ||||||
2096 | 14 perl applications that I know of excluding my personal work. | ||||||
2097 | |||||||
2098 | To work with WebIT all you need to do is to create a new server object by giving to it the parameters | ||||||
2099 | that you want, and then at any point in time call the execute method to run the server. The execute method | ||||||
2100 | returns only when the server has finished execution, and that can only be done by sending a TERM signal to | ||||||
2101 | the process. | ||||||
2102 | |||||||
2103 | Once the server has started it will fork the predefined number of servers and workers. Since workers are not | ||||||
2104 | implemented yet you are advised to ask for 0 workers on startup. From then on, WebIT will serve HTTP requests | ||||||
2105 | by using external files in a configured directory and/or internal pages served by perl subroutines. The code | ||||||
2106 | of the cgi pages and subroutines is as you already know by Apache and mod_perl. You can use the CGI module to | ||||||
2107 | get the request parameters, print on the standard output to form the response to the caller, and print to | ||||||
2108 | standard error to log text to the logger of the server. | ||||||
2109 | |||||||
2110 | =head1 Things to avoid | ||||||
2111 | |||||||
2112 | =over | ||||||
2113 | |||||||
2114 | =item * | ||||||
2115 | |||||||
2116 | Dont use perl threads ! Perl does not really have threads anyway, so dont use them. Threads that do not by | ||||||
2117 | default share their data are not threads, they are forks, and in perl threads are isolated. If you are really | ||||||
2118 | inclined to use threads move to another language like Java. | ||||||
2119 | |||||||
2120 | =item * | ||||||
2121 | |||||||
2122 | Dont use IPC. The server already uses IPC, and some things you can do might break the server. | ||||||
2123 | |||||||
2124 | =back | ||||||
2125 | |||||||
2126 | Just use the server for what it is, and that is an embeded web server for applications, not for hacks, thus you | ||||||
2127 | should not need any of the above to create you application. Now if for any reason you really have to use some of | ||||||
2128 | the above, then WebIT is not for you. | ||||||
2129 | |||||||
2130 | =head1 Configuration | ||||||
2131 | |||||||
2132 | Now lets take a look at the configuration hash of the server. | ||||||
2133 | |||||||
2134 | =over 4 | ||||||
2135 | |||||||
2136 | =item SERVER_NAME | ||||||
2137 | |||||||
2138 | The DNS name of the server (default is localhost) | ||||||
2139 | |||||||
2140 | =item SERVER_IP | ||||||
2141 | |||||||
2142 | The IP address to bind to (default is 127.0.0.1) | ||||||
2143 | |||||||
2144 | =item SERVER_PORT | ||||||
2145 | |||||||
2146 | The TCP port to use (default is 80) | ||||||
2147 | |||||||
2148 | =item QUEUE_SIZE | ||||||
2149 | |||||||
2150 | The number of connections to queue per child (default is 5) | ||||||
2151 | |||||||
2152 | =item USE_SSL | ||||||
2153 | |||||||
2154 | The server will work in SSL mode accepting https connections only. (default is undef) | ||||||
2155 | B |
||||||
2156 | |||||||
2157 | =item SSL_CERTIFICATE | ||||||
2158 | |||||||
2159 | The servers SSL certificate path and file. If not defined no certificate file will be | ||||||
2160 | used for the connection. You can pass the actual certificate here as is. The value is | ||||||
2161 | first tested to see if it matches an existing file, and if not it will be used as an | ||||||
2162 | actual certificate. (default is undef) | ||||||
2163 | B |
||||||
2164 | |||||||
2165 | =item SSL_KEY | ||||||
2166 | |||||||
2167 | The servers SSL key path and file. If not defined no key will be used for the | ||||||
2168 | connection. You can pass the actual key here as is. The value is first tested | ||||||
2169 | to see if it matches an existing file, and if not it will be used as an | ||||||
2170 | actual key. (default is undef). | ||||||
2171 | B |
||||||
2172 | |||||||
2173 | =item WAIT_RESPONSE | ||||||
2174 | |||||||
2175 | Directs the server to wait until a response is generated. If 0 server will | ||||||
2176 | close connection before running scripts or getting pages and returns 204 | ||||||
2177 | (No Content) to client (default is 1 and the server will wait for responses) | ||||||
2178 | |||||||
2179 | =item NO_WAIT_REPLY | ||||||
2180 | |||||||
2181 | The code to send when WAIT_RESPONCE is 0. (default is undef and 204 is returned) | ||||||
2182 | |||||||
2183 | =item IMMED_CLOSE | ||||||
2184 | |||||||
2185 | Close connection immediately after serving request. Ignored if WAIT_RESPONSE is 0. (default is 0) | ||||||
2186 | If it is set to 0 the server will respect the client's request about the handling of the connection (might be | ||||||
2187 | immediate close or keep open) | ||||||
2188 | |||||||
2189 | =item RUN_AS_USER | ||||||
2190 | |||||||
2191 | The user under which the server should run as | ||||||
2192 | |||||||
2193 | =item RUN_AS_GROUP | ||||||
2194 | |||||||
2195 | The group under which the server should run as | ||||||
2196 | |||||||
2197 | =item SETUP_ENV | ||||||
2198 | |||||||
2199 | Allow the server to setup the children environment. This requires some milliseconds for each request | ||||||
2200 | served since the server will have to contruct the environment for each call. If you are not using the CGI | ||||||
2201 | module and you know what you are doing you can set this to 0-false and save some time for running requests | ||||||
2202 | (default is 1) | ||||||
2203 | |||||||
2204 | =item ENV_KEEP | ||||||
2205 | |||||||
2206 | List of environment variables to keep for scripts. For normal execution all environment variables are cleared | ||||||
2207 | and CGI and embeded pages run in a clean environment. If however you need to preserve some, like database variables | ||||||
2208 | you can specify their names here in an array, and they will be preserved for your scripts. | ||||||
2209 | |||||||
2210 | =item ENV_ADD | ||||||
2211 | |||||||
2212 | Hash with environment variables and values to set for scripts. These environment variables and their values will be | ||||||
2213 | added to the environment of your CGI and embeded pages. | ||||||
2214 | |||||||
2215 | =item MIME_TYPES | ||||||
2216 | |||||||
2217 | Path and file where the server can find valid mimetypes. (default is /etc/mime.types) | ||||||
2218 | |||||||
2219 | =item EMBED_PERL | ||||||
2220 | |||||||
2221 | Run perl CGI scripts inside the server, not in a separate process. Faster than Apache and mod_perl. (default is 0) | ||||||
2222 | |||||||
2223 | =item SERVER_ADMIN | ||||||
2224 | |||||||
2225 | The email of the server administrator. This text will appear in the environment variables of the CGI / embeded pages (default is empty) | ||||||
2226 | |||||||
2227 | =item DOCUMENT_ROOT | ||||||
2228 | |||||||
2229 | The path where the site documents and scripts are stored. (default is undef) | ||||||
2230 | |||||||
2231 | =item DOCUMENTS | ||||||
2232 | |||||||
2233 | A hash of documents and their subroutines to execute within the server. This is | ||||||
2234 | used to create fully embeded web servers that respond to specific URL's using | ||||||
2235 | specific subroutines. A special page name '*' can be used to direct all unknown | ||||||
2236 | page requests to be directed to the subroutine of this special page. | ||||||
2237 | Can be used in conjunction with and has precedence over DOCUMENT_ROOT (default is undef) | ||||||
2238 | |||||||
2239 | =item ERROR_PAGES | ||||||
2240 | |||||||
2241 | A hash with the site supplied error pages. It contains the error code as a key and | ||||||
2242 | the page path within DOCUMENT_ROOT or DOCUMENTS of the page for the error. Alternatevly there can | ||||||
2243 | be an entry with keyword ALL where all errors without a specific entry in the hash | ||||||
2244 | will find their error pages. Error pages can be cgi's or plain html. (default is undef) | ||||||
2245 | For all error pages the server sets 4 extra environment variables. These are: | ||||||
2246 | |||||||
2247 | =over 4 | ||||||
2248 | |||||||
2249 | =item ERROR_CODE | ||||||
2250 | |||||||
2251 | This contains the numeric value of the error, eg 404. | ||||||
2252 | |||||||
2253 | =item ERROR_TEXT | ||||||
2254 | |||||||
2255 | This contains the text value of the error, eg Page not found. | ||||||
2256 | |||||||
2257 | =item ERROR_URI | ||||||
2258 | |||||||
2259 | This contains the URI that generated the error. | ||||||
2260 | |||||||
2261 | =item ERROR_METHOD | ||||||
2262 | |||||||
2263 | This contains the method used to access the URI, eg POST | ||||||
2264 | |||||||
2265 | =back | ||||||
2266 | |||||||
2267 | Along with all other environment variables used you can track all errors to their fullest detail, and handle | ||||||
2268 | them not just for display but for administrator notifications as well. | ||||||
2269 | |||||||
2270 | =item EXPIRATIONS | ||||||
2271 | |||||||
2272 | A hash with expiration times. It contains the content type as a key and the expiration | ||||||
2273 | time in seconds. A special entry called ALL specifies the expiration time of any type NOT | ||||||
2274 | already defined in the hash. | ||||||
2275 | |||||||
2276 | =item SERVERS | ||||||
2277 | |||||||
2278 | Number of servers to prefork. Default is 0 where only the master instance exists | ||||||
2279 | |||||||
2280 | =item WORKERS | ||||||
2281 | |||||||
2282 | Number of page workers to prefork. Default is 0 where only the master instance exists | ||||||
2283 | B |
||||||
2284 | |||||||
2285 | =item FORK_CONN | ||||||
2286 | |||||||
2287 | Create a child everytime a new connection arrives. (default is 0) Usefull for hard headed | ||||||
2288 | perl modules like SOAP::WSDL that retain information between calls and confuse the server. Not to be | ||||||
2289 | used with time sensitive HTTP applications like SMS applications with I |
||||||
2290 | requires quite some time to be performed. | ||||||
2291 | |||||||
2292 | =item STARTUP | ||||||
2293 | |||||||
2294 | Run this script at startup to load the environment for the pages. Can only be an external perl script. | ||||||
2295 | Embeded pages startup code can be done in many ways without the need of external scripts. | ||||||
2296 | |||||||
2297 | =item CHILD_START | ||||||
2298 | |||||||
2299 | Subroutine to call on every fork for initialization. Returned values of this | ||||||
2300 | subroutine are passed to internally called functions (default is undef) Persistant database connections | ||||||
2301 | and other paraphenalia that are required for your application should be initialized in the method | ||||||
2302 | defined here. All values that are needed by your application should be returned in a hash or an array | ||||||
2303 | by your method, so that they can be retrieved later on by your CGI's and embeded pages. | ||||||
2304 | |||||||
2305 | =item CHILD_END | ||||||
2306 | |||||||
2307 | Subrouting to call on termination of a forked child. It is passed the return values of the start subroutine | ||||||
2308 | (default is undef) All values initialized by the method defined in CHILD_START that require some form | ||||||
2309 | of proper termination should be treated by the method defined here. The parameter passed to that method | ||||||
2310 | is the pointer returned by the CHILD_START, so you should know how to deal with it. | ||||||
2311 | |||||||
2312 | =item PROC_PREFIX | ||||||
2313 | |||||||
2314 | Text line to be used as prefix for the process name of the childs. (default is WebIT) This is | ||||||
2315 | just for decorating the ps listing of those OS's that give us the ability to change the name of the process. | ||||||
2316 | |||||||
2317 | =item LOG_METHOD | ||||||
2318 | |||||||
2319 | Subroutine to call for logging. It is passed a single string to log. | ||||||
2320 | (default is internal logging to stderr) | ||||||
2321 | |||||||
2322 | =item DEBLOG_METHOD | ||||||
2323 | |||||||
2324 | Subroutine to call for debug logging. It is passed a single string to log. | ||||||
2325 | (default is the same with LOG_METHOD) | ||||||
2326 | |||||||
2327 | =item LOG_HEADERS | ||||||
2328 | |||||||
2329 | Log input and output packet headers as those come and go to and from the server (default is 0) | ||||||
2330 | |||||||
2331 | =item LOG_PACKETS | ||||||
2332 | |||||||
2333 | Log input and output packets as those come and go to anf from the server. By turning on packet logging you will | ||||||
2334 | implicity get header logging. (default is 0) | ||||||
2335 | |||||||
2336 | =item NO_LOGGING | ||||||
2337 | |||||||
2338 | When set to 1-true the server will avoid all possible logging speeding up processing to the max. (default is 0) | ||||||
2339 | |||||||
2340 | =item CGI_PATH | ||||||
2341 | |||||||
2342 | A colon or semicolon separated list of paths under the DOCUMENT_ROOT where | ||||||
2343 | CGI scripts exist. (default is undef) | ||||||
2344 | |||||||
2345 | =item AUTH_PATH | ||||||
2346 | |||||||
2347 | A colon or semicolon separated list of paths under the DOCUMENT_ROOT where | ||||||
2348 | authentication is needed. Works with embeded pages as well. (default is undef) | ||||||
2349 | |||||||
2350 | =item AUTH_REALM | ||||||
2351 | |||||||
2352 | A string specifying the realm of the authentication for the AUTH_PATH's. There is only one | ||||||
2353 | realm (default is undef) | ||||||
2354 | |||||||
2355 | =item AUTH_METHOD | ||||||
2356 | |||||||
2357 | Subroutine to call for authenticating remote users. Parameters are the returned values of | ||||||
2358 | the child start subroutine preceeded by a username and a password. (default is undef) | ||||||
2359 | |||||||
2360 | =item SOFTWARE | ||||||
2361 | |||||||
2362 | Text with software name and version. This text will appear in the environment variables of the CGI / embeded pages | ||||||
2363 | (default is WebIT/$VESRION) | ||||||
2364 | |||||||
2365 | =item SIGNATURE | ||||||
2366 | |||||||
2367 | Text with web server signature. This text will appear in the environment variables of the CGI / embeded pages. (default is WebIT/$VERSION for Perl )` |
||||||
2368 | |||||||
2369 | =back | ||||||
2370 | |||||||
2371 | =head1 Methods | ||||||
2372 | |||||||
2373 | The methods that are available to use are the following: | ||||||
2374 | |||||||
2375 | =over | ||||||
2376 | |||||||
2377 | =item new() | ||||||
2378 | |||||||
2379 | This is the constructor of the object. It takes as a parameter a hash with keys and values as described above. | ||||||
2380 | |||||||
2381 | =item execute() | ||||||
2382 | |||||||
2383 | This is the routing to enter the execution loop of the server. This method will never return, so if you need to do | ||||||
2384 | anyting more with your application you might want to call this method from a forked process. | ||||||
2385 | |||||||
2386 | =item data() | ||||||
2387 | |||||||
2388 | This method returns the server child data as those were returned by the CHILD_START method. | ||||||
2389 | |||||||
2390 | Lets assume that you have a CHILD_START method as follows: | ||||||
2391 | |||||||
2392 | sub start_up { | ||||||
2393 | %res = (); | ||||||
2394 | $db = DBI->connect("DBI:Oracle:sid=pits;host=127.0.0.2;port=3127", "user", "pass"); | ||||||
2395 | |||||||
2396 | $res{DATABASE} = $db; | ||||||
2397 | |||||||
2398 | return \%res; | ||||||
2399 | } | ||||||
2400 | |||||||
2401 | If you want to retrieve that connection from inside a CGI script or an embeded page what you need to do is the | ||||||
2402 | following: | ||||||
2403 | |||||||
2404 | $res = EmbedIT::WebIT::data(); | ||||||
2405 | $db = $res->{DATABASE}; | ||||||
2406 | |||||||
2407 | or if you have access to you server object you can do the following: | ||||||
2408 | |||||||
2409 | $res = $server->data(); | ||||||
2410 | $db = $res->{DATABASE}; | ||||||
2411 | |||||||
2412 | =item start_time() | ||||||
2413 | |||||||
2414 | This method returns the timestamp of the server startup time. Usefull for applications that need to know when | ||||||
2415 | the server started in order to perform some functions. | ||||||
2416 | |||||||
2417 | =back | ||||||
2418 | |||||||
2419 | =head1 WebIT and SOAP::WSDL | ||||||
2420 | |||||||
2421 | One of the main reasons why I use now days WebIT, is to expose soap methods. SOAP::WSDL (and not SOAP::Lite) is the | ||||||
2422 | best possible soap package available for perl. If you want to use WebIT as a server for SOAP::WSDL this is what you | ||||||
2423 | have to do: | ||||||
2424 | |||||||
2425 | First of all you need to specify FORK_CONN as true (1 for perl) to force the server to fork a new child for each | ||||||
2426 | new connection. Then you need to specify the embeded pages that will serve the methods exposed by the WSDL. For | ||||||
2427 | example, assume you need to expose a method test that takes a string as input and returns another string as output. | ||||||
2428 | |||||||
2429 | Create you WSDL | ||||||
2430 | |||||||
2431 | |||||||
2432 | | ||||||
2433 | xmlns:soap="http://schemas.xmlsoap.org/wsdl/soap/" | ||||||
2434 | xmlns:xs="http://www.w3.org/2001/XMLSchema" | ||||||
2435 | xmlns:soapenc="http://schemas.xmlsoap.org/soap/encoding/" | ||||||
2436 | xmlns:tns="http://tempuri.org/" | ||||||
2437 | xmlns:tm="http://microsoft.com/wsdl/mime/textMatching/" | ||||||
2438 | xmlns:mime="http://schemas.xmlsoap.org/wsdl/mime/" | ||||||
2439 | targetNamespace="http://tempuri.org/" | ||||||
2440 | xmlns:wc="http://tempuri.org/" | ||||||
2441 | xmlns:wsdl="http://schemas.xmlsoap.org/wsdl/"> | ||||||
2442 | |
||||||
2443 | |
||||||
2444 | |
||||||
2445 | |
||||||
2446 | |
||||||
2447 | |
||||||
2448 | |||||||
2449 | |||||||
2450 | |||||||
2451 | |||||||
2452 | |
||||||
2453 | |
||||||
2454 | |
||||||
2455 | |
||||||
2456 | |||||||
2457 | |||||||
2458 | |||||||
2459 | |||||||
2460 | |||||||
2461 | |||||||
2462 | |
||||||
2463 | |
||||||
2464 | |||||||
2465 | |
||||||
2466 | |
||||||
2467 | |
||||||
2468 | |
||||||
2469 | |||||||
2470 | |||||||
2471 | |||||||
2472 | |
||||||
2473 | |
||||||
2474 | |||||||
2475 | |
||||||
2476 | |
||||||
2477 | |||||||
2478 | |
||||||
2479 | |
||||||
2480 | |||||||
2481 | |||||||
2482 | |||||||
2483 | |||||||
2484 | |
||||||
2485 | |
||||||
2486 | |
||||||
2487 | |||||||
2488 | |||||||
2489 | |||||||
2490 | |||||||
2491 | |||||||
2492 | and compile it with wsdl2perl | ||||||
2493 | |||||||
2494 | Then create your handling object (use SOAP::WSDL documentation to see what you need to do) as follows: | ||||||
2495 | |||||||
2496 | package WebService | ||||||
2497 | |||||||
2498 | our $VERSION = "1.0"; | ||||||
2499 | |||||||
2500 | sub new { | ||||||
2501 | my $self = {}; | ||||||
2502 | bless $self; | ||||||
2503 | return $self; | ||||||
2504 | } | ||||||
2505 | |||||||
2506 | sub Test { | ||||||
2507 | my ($self,$body,$header) = @_; | ||||||
2508 | my %idata = (); | ||||||
2509 | |||||||
2510 | $idata{Flag} = $body->get_Flag() . ""; | ||||||
2511 | |||||||
2512 | return MyElements::OutputFlag->new(\%idata); | ||||||
2513 | } | ||||||
2514 | |||||||
2515 | and finally create your embeded page that will handle the HTTP request. | ||||||
2516 | |||||||
2517 | sub WebService { | ||||||
2518 | eval { | ||||||
2519 | unshift @INC, $lib_path; # add at run time the library path of the generated classes from wsdl2perl | ||||||
2520 | require MyServer::Test::Test; # use the server class generated by wsdl2perl | ||||||
2521 | |||||||
2522 | my $t = WebService->new(); # create a WebService handling object | ||||||
2523 | my $server = MyServer::Test::Test->new({ dispatch_to => 'WebService', | ||||||
2524 | transport_class => 'SOAP::WSDL::Server::CGI' }); | ||||||
2525 | $server->handle(); | ||||||
2526 | }; | ||||||
2527 | if ($@) { print "just do something ...the call has failed\n"; } | ||||||
2528 | } | ||||||
2529 | |||||||
2530 | On your WebIT configuration hash you need to remember to add the above subroutine as the handler | ||||||
2531 | for a page like so: | ||||||
2532 | |||||||
2533 | $server = new EmbedIT::WebIT( SERVER_NAME => 'name.org', | ||||||
2534 | ... | ||||||
2535 | FORK_CONN => 1, | ||||||
2536 | ... | ||||||
2537 | DOCUMENTS => { | ||||||
2538 | 'WS/Test' => 'main::WebService', | ||||||
2539 | }, | ||||||
2540 | ... | ||||||
2541 | ); | ||||||
2542 | |||||||
2543 | and thats it. You have exposed web services working with WebIT as an embeded web server. | ||||||
2544 | |||||||
2545 | =head1 Requirements | ||||||
2546 | |||||||
2547 | You need to have installed the following packages for WebIT to work. | ||||||
2548 | |||||||
2549 | =over 4 | ||||||
2550 | |||||||
2551 | =item HTTP::Date | ||||||
2552 | |||||||
2553 | =item IO::Socket | ||||||
2554 | |||||||
2555 | =item IO::Select | ||||||
2556 | |||||||
2557 | =item LWP::MediaTypes | ||||||
2558 | |||||||
2559 | =item IPC::Open3 | ||||||
2560 | |||||||
2561 | =item Taint::Runtime | ||||||
2562 | |||||||
2563 | =item MIME::Base64 | ||||||
2564 | |||||||
2565 | =back | ||||||
2566 | |||||||
2567 | =head1 Copyright | ||||||
2568 | |||||||
2569 | Copyright 2008 D. Evmorfopoulos |
||||||
2570 | |||||||
2571 | Permission is granted to copy, distribute and/or modify this | ||||||
2572 | document under the terms of the GNU Free Documentation | ||||||
2573 | License, Version 1.2 or any later version published by the | ||||||
2574 | Free Software Foundation; with no Invariant Sections, with | ||||||
2575 | no Front-Cover Texts, and with no Back-Cover Texts. | ||||||
2576 | |||||||
2577 | =cut |