File Coverage

blib/lib/DiaColloDB/WWW/Server.pm
Criterion Covered Total %
statement 42 184 22.8
branch 0 70 0.0
condition 0 52 0.0
subroutine 14 29 48.2
pod 11 11 100.0
total 67 346 19.3


line stmt bran cond sub pod time code
1             ##-*- Mode: CPerl; coding: utf-8; -*-
2             ##
3             ## File: DiaColloDB/WWW/Server.pm
4             ## Author: Bryan Jurish <moocow@cpan.org>
5             ## Description: collocation db, www wrappers: standalone tiny www server
6             ## + adapted from DTA::CAB::Server::HTTP
7              
8             package DiaColloDB::WWW::Server;
9 1     1   1322 use DiaColloDB;
  1         2  
  1         26  
10 1     1   5 use DiaColloDB::Logger;
  1         1  
  1         16  
11 1     1   4 use DiaColloDB::WWW::CGI;
  1         2  
  1         14  
12 1     1   403 use DiaColloDB::WWW::Handler;
  1         2  
  1         8  
13 1     1   412 use DiaColloDB::WWW::Handler::cgi;
  1         2  
  1         10  
14 1     1   378 use DiaColloDB::WWW::Handler::static;
  1         2  
  1         11  
15 1     1   27 use File::ShareDir qw(dist_dir);
  1         2  
  1         36  
16 1     1   977 use HTTP::Daemon;
  1         26028  
  1         9  
17 1     1   627 use HTTP::Status;
  1         2  
  1         55  
18 1     1   802 use MIME::Types; ##-- for guessing mime types
  1         3850  
  1         21  
19 1     1   83 use POSIX ':sys_wait_h'; ##-- for WNOHANG
  1         2  
  1         8  
20 1     1   312 use Socket qw(SOMAXCONN);
  1         2  
  1         17  
21 1     1   100 use Carp;
  1         2  
  1         15  
22              
23 1     1   93 use strict;
  1         2  
  1         1713  
24              
25             ##======================================================================
26             ## globals
27              
28             our $VERSION = "0.02.005";
29             our @ISA = qw(DiaColloDB::Logger);
30              
31             ##======================================================================
32             ## constructors etc.
33              
34             ## $srv = $that->new(%args)
35             ## + %args, %$srv:
36             ## (
37             ## ##-- underlying HTTP::Daemon server
38             ## daemonMode => $daemonMode, ##-- one of 'serial' or 'fork' [default='serial']
39             ## daemonArgs => \%daemonArgs, ##-- args to HTTP::Daemon->new(); default={LocalAddr=>'0.0.0.0',LocalPort=>6066}
40             ## daemon => $daemon, ##-- underlying HTTP::Daemon object
41             ## cgiArgs => \%cgiArgs, ##-- args to DiaColloDB::WWW::CGI->new(); default=none
42             ## mimetypes => $mt, ##-- a MIME::Types object for guessing mime types
43             ## ##
44             ## ##-- user data
45             ## wwwdir => $wwwdir, ##-- root directory for www wrapper data (default=File::ShareDir::dist_dir("DiaColloDB-WWW")."/htdocs"
46             ## dburl => $dburl, ##-- DiaColloDB client URL (e.g. local indexed directory; alias='dbdir')
47             ## ##
48             ## ##-- logging
49             ## logAttempt => $level, ##-- log connection attempts at $level (default='trace')
50             ## logConnect => $level, ##-- log successful connections (client IP and requested path) at $level (default='debug')
51             ## logRquestData => $level, ##-- log full client request data at $level (default='trace')
52             ## logResponse => $level, ##-- log full client response at $level (default='trace')
53             ## logClientError => $level, ##-- log errors to client at $level (default='debug')
54             ## logClose => $level, ##-- log close client connections (default='trace')
55             ## )
56             sub new {
57 0     0 1   my $that = shift;
58 0   0       my $srv = bless({
59             ##-- underlying server
60             daemon => undef,
61             daemonArgs => {
62             LocalAddr=>'0.0.0.0', ##-- all
63             LocalPort=>6066,
64             ReuseAddr=>1,
65             #ReusePort=>1, ##-- don't set this; it causes errors "Your vendor has not defined Socket macro SO_REUSEPORT"
66             },
67             cgiArgs => {},
68             mimetypes => undef, ##-- see prepareLocal()
69              
70             ##-- user data
71             dburl => undef,
72             wwwdir => undef, ##-- see prepareLocal()
73              
74             ##-- logging
75             logAttempt => 'trace',
76             logConnect => 'debug',
77             logRequestData => 'trace',
78             logResponse => 'trace',
79             logCache => 'debug',
80             logClose => 'trace',
81             logClientError => 'debug',
82              
83             ##-- user args
84             @_,
85             }, ref($that)||$that);
86 0 0 0       $srv->{dburl} = $srv->{dbdir} if ($srv->{dbdir} && !defined($srv->{dburl}));
87              
88 0           return $srv;
89             }
90              
91             ##==============================================================================
92             ## Methods: Generic Server API
93             ##==============================================================================
94              
95             ## $rc = $srv->prepare()
96             ## + default implementation initializes logger & pre-loads all analyzers
97             sub prepare {
98 0     0 1   my $srv = shift;
99 0           my $rc = 1;
100              
101             ##-- prepare: logger
102 0           DiaColloDB::Logger->ensureLog();
103              
104             ##-- prepare: PID file
105 0 0         if (defined($srv->{pidfile})) {
106 0 0         my $pidfh = IO::File->new(">$srv->{pidfile}")
107             or $srv->logconfess("prepare(): could not write PID file '$srv->{pidfile}': $!");
108 0   0       $pidfh->print(($srv->{pid} || $$), "\n");
109 0           $pidfh->close()
110             }
111              
112             ##-- prepare: signal handlers
113 0   0       $rc &&= $srv->prepareSignalHandlers();
114              
115             ##-- prepare: subclass-local
116 0   0       $rc &&= $srv->prepareLocal(@_);
117              
118             ##-- prepare: timestamp
119 0   0       $srv->{t_started} //= time();
120              
121             ##-- return
122 0           $srv->info("initialization complete");
123              
124 0           return $rc;
125             }
126              
127             ## $rc = $srv->prepareSignalHandlers()
128             ## + initialize signal handlers
129             sub prepareSignalHandlers {
130 0     0 1   my $srv = shift;
131             $SIG{'__DIE__'} = sub {
132 0 0   0     die @_ if ($^S); ##-- normal operation if executing inside an eval{} block
133 0           $srv->finish();
134 0           $srv->logconfess("__DIE__ handler called - exiting: ", @_);
135 0           exit(255);
136 0           };
137             my $sig_catcher = sub {
138 0     0     my $signame = shift;
139 0           $srv->finish();
140 0           $srv->logwarn("caught signal SIG$signame - exiting");
141 0           exit(255);
142 0           };
143 0           my ($sig);
144 0           foreach $sig (qw(TERM KILL QUIT INT HUP ABRT SEGV)) {
145 0           $SIG{$sig} = $sig_catcher;
146             }
147             #$SIG{$sig} = $sig_catcher foreach $sig (qw(IO URG SYS USR1 USR2)); ##-- DEBUG
148 0           return $sig_catcher;
149             }
150              
151             ## $rc = $srv->prepareLocal(@args_to_prepare)
152             ## + subclass-local initialization
153             ## + called by prepare() after default prepare() guts have run
154             sub prepareLocal {
155 0     0 1   my $srv = shift;
156              
157             ##-- setup wwwdir
158 0   0       $srv->{wwwdir} //= dist_dir("DiaColloDB-WWW")."/htdocs";
159              
160             ##-- setup mimetypes object
161 0 0 0       if (!($srv->{mimetypes} //= MIME::Types->new())) {
162 0           $srv->logconfess("could not create MIME::Types object: $!");
163             }
164              
165             ##-- setup HTTP::Daemon object
166 0 0         if (!($srv->{daemon}=HTTP::Daemon->new(%{$srv->{daemonArgs}}))) {
  0            
167 0           $srv->logconfess("could not create HTTP::Daemon object: $!");
168             }
169 0           my $daemon = $srv->{daemon};
170              
171             ##-- setup mode-specific options
172 0   0       $srv->{daemonMode} //= 'serial';
173 0 0         if ($srv->{daemonMode} eq 'fork') {
174 0   0       $srv->{children} //= {};
175 0   0       $srv->{pid} //= $$;
176 0           $SIG{CHLD} = $srv->reaper();
177             }
178              
179 0           return 1;
180             }
181              
182              
183             ## $rc = $srv->run()
184             ## + run the server (just a dummy method)
185             sub run {
186 0     0 1   my $srv = shift;
187 0 0         $srv->prepare() if (!$srv->{daemon}); ##-- sanity check
188 0 0         $srv->logconfess("run(): no underlying HTTP::Daemon object!") if (!$srv->{daemon});
189              
190 0           my $daemon = $srv->{daemon};
191 0   0       my $mode = $srv->{daemonMode} || 'serial';
192 0           $srv->info("server starting in $mode mode on host ", $daemon->sockhost, ", port ", $daemon->sockport, "\n");
193              
194             ##-- setup SIGPIPE handler (avoid heinous death)
195             ## + following suggestion on http://www.perlmonks.org/?node_id=580411
196 0     0     $SIG{PIPE} = sub { $srv->vlog('warn',"got SIGPIPE (ignoring)"); };
  0            
197              
198 0           my ($csock,$chost,$hreq,$urikey,$handler,$pid,$rsp);
199 0           while (1) {
200             ##-- call accept() within the loop to avoid breaking out in fork mode
201 0 0         if (!defined($csock=$daemon->accept())) {
202             #sleep(1);
203 0           next;
204             }
205              
206             ##-- got client $csock (HTTP::Daemon::ClientConn object; see HTTP::Daemon(3pm))
207 0           $chost = $csock->peerhost();
208              
209             ##-- serve client: parse HTTP request
210 0           ${*$csock}{'httpd_client_proto'} = HTTP::Daemon::ClientConn::_http_version("HTTP/1.0"); ##-- HACK: force status line on send_error() from $csock->get_request()
  0            
211 0           $hreq = $csock->get_request();
212 0 0         if (!$hreq) {
213 0   0       $srv->clientError($csock, RC_BAD_REQUEST, "could not parse HTTP request: ", ($csock->reason || 'get_request() failed'));
214 0           next;
215             }
216              
217             ##-- log basic request, and possibly request data
218 0           $urikey = $hreq->uri->as_string;
219 0           $srv->vlog($srv->{logConnect}, "client $chost: ", $hreq->method, ' ', $urikey);
220 0           $srv->vlog($srv->{logRequestData}, "client $chost: HTTP::Request={\n", $hreq->as_string, "}");
221              
222             ##-- map request to handler
223 0           $handler = $srv->getPathHandler($hreq->uri);
224 0 0         if (!defined($handler)) {
225 0           $srv->clientError($csock, RC_NOT_FOUND, "cannot resolve URI ", $hreq->uri);
226 0           next;
227             }
228              
229             ##-- child|serial code: pass request to handler
230 0           eval {
231 0           $rsp = $handler->run($srv,$csock,$hreq);
232             };
233 0 0         if ($@) {
    0          
234 0   0       $srv->clientError($csock,RC_INTERNAL_SERVER_ERROR,"handler ", (ref($handler)||$handler), " died:<br/><pre>$@</pre>");
235 0           $srv->reapClient($csock,$handler,$chost);
236             }
237             elsif (!defined($rsp)) {
238 0   0       $srv->clientError($csock,RC_INTERNAL_SERVER_ERROR,"handler ", (ref($handler)||$handler), " failed for ", $hreq->uri->path);
239 0           $srv->reapClient($csock,$handler,$chost);
240             }
241              
242             ##-- ... and dump response to client
243 0 0         if (!$csock->opened) {
    0          
244 0           $srv->logwarn("client socket closed unexpectedly");
245 0           next;
246             } elsif ($csock->error) {
247 0           $srv->logwarn("client socket has errors");
248 0           next;
249             }
250 0 0         $srv->vlog($srv->{logResponse}, "returning response: ", $rsp->as_string) if ($srv->{logResponse});
251 0           $csock->send_response($rsp);
252             }
253             continue {
254             ##-- cleanup after client
255 0 0         $srv->reapClient($csock,undef,$chost) if (!$pid);
256 0           $hreq=$handler=$pid=$rsp=undef;
257             }
258              
259              
260 0           $srv->info("server exiting\n");
261 0           return $srv->finish();
262             }
263              
264             ## $rc = $srv->finish()
265             ## + cleanup method; should be called when server dies or after run() has completed
266             sub finish {
267 0     0 1   my $srv = shift;
268 0           delete @SIG{qw(HUP TERM KILL __DIE__)}; ##-- unset signal handlers
269 0 0         unlink($srv->{pidfile}) if ($srv->{pidfile});
270 0           return 1;
271             }
272              
273             ##==============================================================================
274             ## Methods: Local: spawn and reap
275              
276             ## \&reaper = $srv->reaper()
277             ## + zombie-harvesting code; installed to local %SIG
278             sub reaper {
279 0     0 1   my $srv = shift;
280             return sub {
281 0     0     my ($child);
282 0           while (($child = waitpid(-1,WNOHANG)) > 0) {
283 0           $srv->vlog($srv->{logReap},"reaped subprocess pid=$child, status=$?");
284 0           delete $srv->{children}{$child};
285             }
286             #$SIG{CHLD}=$srv->reaper() if ($srv->{installReaper}); ##-- re-install reaper for SysV
287 0           };
288             }
289              
290             ## undef = $srv->reapClient($csock, $handler_or_undef, $chost_or_undef)
291             sub reapClient {
292 0     0 1   my ($srv,$csock,$handler,$chost) = @_;
293 0 0         return if (!$csock);
294 0 0 0       $srv->vlog($srv->{logClose}, "closing connection to client ", ($chost // ($csock->opened ? $csock->peerhost : '-undef-')));
295 0 0         if ($csock->opened) {
296 0           $csock->force_last_request();
297 0           $csock->shutdown(2);
298             }
299 0 0         $handler->finish($srv,$csock) if (UNIVERSAL::can($handler,'finish'));
300 0 0 0       exit 0 if ($srv->{pid} && $srv->{pid} != $$);
301 0           return;
302             }
303              
304             ##==============================================================================
305             ## Methods: Local: path handlers
306              
307             ## $handler = $srv->getPathHandler($hreq_uri)
308             ## + returns a callback for handling $hreq_uri, called as $handler->($clientSocket,$httpRequest)
309             sub getPathHandler {
310 0     0 1   my ($srv,$uri) = @_;
311 0           (my $path = $uri->path) =~ s{/+$}{};
312 0   0       $path ||= 'index.perl';
313 0           $path =~ s{/+}{/}g;
314 0           $path =~ s{^/}{};
315 0           my $wwwdir = $srv->{wwwdir};
316              
317 0 0         if ($path =~ /Makefile|README|\.svn|(?:\.(?:ttk|rc|pod|txt|pm)$)|~$/) {
    0          
    0          
    0          
318             ##-- ignore special paths
319 0           return undef;
320             }
321             elsif ($path =~ /\.perl$/) {
322             ##-- handle "*.perl" requests via cgi (e.g. http://HOST:PORT/profile.perl?q=foo)
323 0           (my $base = $path) =~ s/\.perl$//;
324 0 0 0       return DiaColloDB::WWW::Handler::cgi->new(template=>"$wwwdir/$base.ttk")
325             if (-e "$wwwdir/$base.perl" && -r "$wwwdir/$base.ttk");
326 0           return undef; ##-- don't serve up raw perl files
327             }
328             elsif (-e "$wwwdir/$path.ttk") {
329             ##-- handle template requests via cgi (e.g. http://HOST:PORT/profile?q=foo)
330 0           return DiaColloDB::WWW::Handler::cgi->new(template=>"$wwwdir/$path.ttk");
331             }
332             elsif (-r "$wwwdir/$path") {
333             ##-- handle static files
334 0           return DiaColloDB::WWW::Handler::static->new(file=>"$wwwdir/$path");
335             }
336              
337 0           return undef;
338             }
339              
340             ## $type_or_undef = $srv->mimetype($filename)
341             ## + gets stringified MIME-type of $filename via MIME::Types::mimeTypeOf()
342             sub mimetype {
343 0     0 1   my ($srv,$file) = @_;
344 0 0         $srv->logconfess("mimetype() called but no {mimetypes} key defined!") if (!defined($srv->{mimetypes}));
345 0           my $type = $srv->{mimetypes}->mimeTypeOf($file);
346 0 0         return defined($type) ? $type->type : undef;
347             }
348              
349             ##======================================================================
350             ## Methods: Local: error handling
351              
352             ## undef = $srv->clientError($clientSock,$status,@message)
353             ## + send an error message to the client
354             ## + $status defaults to RC_INTERNAL_SERVER_ERROR
355             ## + shuts down the client socket
356             sub clientError {
357 0     0 1   my ($srv,$csock,$status,@msg) = @_;
358 0 0         if ($csock->opened) {
359 0           my $chost = $csock->peerhost();
360 0           my $msg = join('',@msg);
361 0 0         $status = RC_INTERNAL_SERVER_ERROR if (!defined($status));
362 0           $srv->vlog($srv->{logClientError}, "clientError($chost): $msg");
363 0 0         if ($msg !~ /: client closed$/i) {
364             ##-- don't try to write to sockets reporting 'client closed': this crashes the running server inexplicably!
365 0           my $_warn=$^W;
366 0           $^W=0;
367 0           $csock->send_error($status, $msg);
368 0           $^W=$_warn;
369             }
370 0           $csock->force_last_request();
371 0           $csock->shutdown(2);
372             }
373 0 0         $csock->close() if (UNIVERSAL::can($csock,'close'));
374 0           $@ = undef; ##-- unset eval error
375 0           return undef;
376             }
377              
378              
379             1; ##-- be happy
380              
381             __END__