File Coverage

blib/lib/Chouette.pm
Criterion Covered Total %
statement 151 249 60.6
branch 17 74 22.9
condition 4 14 28.5
subroutine 29 34 85.2
pod 1 4 25.0
total 202 375 53.8


line stmt bran cond sub pod time code
1             package Chouette;
2              
3 1     1   29047 use common::sense;
  1         1  
  1         5  
4              
5 1     1   590 use EV;
  1         1711  
  1         23  
6 1     1   852 use AnyEvent;
  1         3672  
  1         24  
7 1     1   445 use AnyEvent::Util;
  1         6733  
  1         57  
8 1     1   403 use AnyEvent::Task::Client;
  1         20521  
  1         23  
9 1     1   379 use AnyEvent::Task::Server;
  1         14659  
  1         25  
10 1     1   446 use Feersum;
  1         8961  
  1         25  
11 1     1   5 use Callback::Frame;
  1         1  
  1         58  
12 1     1   428 use Log::File::Rolling;
  1         8349  
  1         33  
13 1     1   5 use Cwd;
  1         2  
  1         51  
14 1     1   710 use Regexp::Assemble;
  1         13571  
  1         28  
15 1     1   456 use Session::Token;
  1         1031  
  1         28  
16 1     1   554 use Data::Dumper;
  1         4569  
  1         53  
17              
18 1     1   367 use Chouette::Context;
  1         2  
  1         2334  
19              
20             our $VERSION = '0.101';
21              
22              
23              
24             sub new {
25 1     1 0 486 my ($class, $app_spec) = @_;
26              
27 1         3 my $self = {
28             app_spec => $app_spec,
29             };
30 1         2 bless $self, $class;
31              
32 1         1 my $config = {};
33              
34 1 50       4 if ($app_spec->{config_file}) {
35 0         0 require YAML;
36 0         0 $config = YAML::LoadFile($app_spec->{config_file});
37             }
38              
39             $self->{config} = {
40 1         15 %{ $app_spec->{config_defaults} },
  1         7  
41             %$config,
42             };
43              
44 1         2 $self->{quiet} = $app_spec->{quiet};
45              
46 1         4 $self->_validate_config();
47              
48 1         4 $self->_compile_app();
49              
50 1         2 $self->{_done_gensym} = \'';
51              
52 1         3 return $self;
53             }
54              
55              
56              
57              
58             sub _validate_config {
59 1     1   1 my ($self) = @_;
60              
61 1 50       12 die "var_dir $self->{config}->{var_dir} is not a directory" if !-e $self->{config}->{var_dir};
62             }
63              
64              
65             sub _compile_app {
66 1     1   1 my ($self) = @_;
67              
68             ## Middleware
69              
70 1         1 foreach my $middleware_spec (@{ $self->{app_spec}->{middleware} }) {
  1         5  
71 0 0       0 $middleware_spec = [ $middleware_spec ] if !ref($middleware_spec);
72 0         0 $middleware_spec = [ @$middleware_spec ]; ## copy so don't destroy app_spec version
73              
74 0         0 my $pkg = $middleware_spec->[0];
75              
76 0 0       0 if ($pkg =~ m{^Plack::Middleware::}) {
77 0 0       0 eval "require $pkg" || die "Couldn't require middleware $pkg\n\n$@";
78             } else {
79 0 0       0 if (!eval "require $pkg") {
80 0         0 my $new_pkg = "Plack::Middleware::" . $pkg;
81 0 0       0 eval "require $new_pkg" || die "Couldn't require middleware $pkg (or $new_pkg)";
82 0         0 $middleware_spec->[0] = $new_pkg;
83             }
84             }
85              
86 0         0 push @{ $self->{middleware_specs} }, $middleware_spec;
  0         0  
87             }
88              
89              
90             ## Pre-route wrappers
91              
92 1 50       3 if (defined $self->{app_spec}->{pre_route}) {
93 0         0 $self->{pre_route_cb} = $self->_load_function($self->{app_spec}->{pre_route}, "pre-route");
94             }
95              
96              
97             ## Routes
98              
99 1         6 $self->{route_regexp_assemble} = Regexp::Assemble->new->track(1);
100 1         75 $self->{route_patterns} = {};
101              
102 1         2 my $routes = $self->{app_spec}->{routes};
103              
104 1         2 foreach my $route (keys %$routes) {
105 1         3 my $re = '\A' . $route . '\z';
106              
107 1         3 $re =~ s{/}{\\/}g; ## Hack for Regexp::Assemble: https://github.com/ronsavage/Regexp-Assemble/issues/4
108              
109 1         2 $re =~ s{:([\w]+)}{(?<$1>[^/]+)};
110              
111 1         4 $self->{route_regexp_assemble}->add($re);
112              
113 1         288 my $methods = {};
114              
115 1         1 foreach my $method (keys %{ $routes->{$route} }) {
  1         4  
116 1         6 $methods->{$method} = $self->_load_function($routes->{$route}->{$method}, "route: $method $route");
117             }
118              
119 1         4 $self->{route_patterns}->{$re} = $methods;
120             }
121              
122 1         3 $self->{route_regexp} = $self->{route_regexp_assemble}->re;
123              
124              
125             ## Tasks
126              
127 1         150 foreach my $task_name (keys %{ $self->{app_spec}->{tasks} }) {
  1         5  
128 0 0       0 die "invalid task name: $task_name" if $task_name !~ /\A\w+\z/;
129              
130 0         0 my $task = $self->{app_spec}->{tasks}->{$task_name};
131 0         0 my $pkg = $task->{pkg};
132              
133 0 0       0 eval "require $pkg" || die "Couldn't require task package $pkg (required for task $task_name)\n\n$@";
134 0 0       0 die "Couldn't find function new in $pkg (needed task $task_name)" if !defined &{ "${pkg}::new" };
  0         0  
135             }
136             }
137              
138              
139              
140             sub _load_function {
141 1     1   2 my ($self, $spec, $needed_for) = @_;
142              
143 1 50       5 $needed_for = "(needed for $needed_for)" if defined $needed_for;
144              
145 1 50       3 if (ref $spec eq 'CODE') {
    0          
146 1         3 return $spec;
147             } elsif ($spec =~ /^(.*)::([^:]+)$/) {
148 0         0 my ($pkg, $func_name) = ($1, $2);
149 0 0       0 eval "require $pkg" || die "Couldn't require $pkg $needed_for\n\n$@";
150 0 0       0 die "Couldn't find function $func_name in $pkg $needed_for" if !defined &{ "${pkg}::${func_name}" };
  0         0  
151 0         0 my $func = \&{ "${pkg}::${func_name}" };
  0         0  
152 0         0 return $func;
153             } else {
154 0         0 die "couldn't parse function: '$spec'";
155             }
156             }
157              
158              
159              
160             sub _listen {
161 1     1   1 my ($self) = @_;
162              
163 1         2 my $listen = $self->{config}->{listen};
164              
165 1         1 my $socket;
166              
167 1 50       5 if ($listen =~ m{^unix:(.*)}) {
168 1         3 my $socket_file = $1;
169              
170 1         5 require IO::Socket::UNIX;
171              
172 1         16 unlink($socket_file);
173              
174 1   50     9 $socket = IO::Socket::UNIX->new(
175             Listen => 5,
176             Type => IO::Socket::SOCK_STREAM(),
177             Local => $socket_file,
178             ) || die "unable to listen on $listen : $!";
179              
180 1         234 $self->{_friendly_socket_desc} = "http://[unix:$socket_file]";
181             } else {
182 0         0 my $local_addr = '0.0.0.0';
183 0         0 my $port;
184              
185 0 0       0 if ($listen =~ m{^(.*):(\d+)$}) {
    0          
186 0         0 $local_addr = $1;
187 0         0 $port = $2;
188             } elsif ($listen =~ m{^(\d+)$}) {
189 0         0 $port = $1;
190             } else {
191 0         0 die "unable to parse listen param: '$listen'";
192             }
193              
194 0         0 require IO::Socket::INET;
195              
196 0   0     0 $socket = IO::Socket::INET->new(
197             Listen => 5,
198             Proto => 'tcp',
199             LocalAddr => $local_addr,
200             LocalPort => $port,
201             ReuseAddr => 1,
202             ) || die "unable to listen on $listen : $!";
203              
204 0         0 $self->{_friendly_socket_desc} = "http://$local_addr:$port";
205             }
206              
207 1         5 AnyEvent::Util::fh_nonblocking($socket, 1);
208              
209 1         5 $self->{accept_socket} = $socket;
210             }
211              
212             sub _logging {
213 1     1   1 my ($self) = @_;
214              
215 1         3 my $log_dir = "$self->{config}->{var_dir}/logs";
216              
217 1 50       17 if (!-e $log_dir) {
218 1 50       34 mkdir($log_dir) || die "couldn't mkdir($log_dir): $!";
219             }
220              
221 1         20 $log_dir = Cwd::abs_path($log_dir);
222              
223 1   50     6 my $app_name = $self->{config}->{logging}->{file_prefix} // 'app';
224              
225 1         3 my $curr_symlink = "$log_dir/$app_name.current.log";
226              
227             $self->{raw_logger} = Log::File::Rolling->new(
228             filename => "$log_dir/$app_name.%Y-%m-%dT%H.log",
229             current_symlink => $curr_symlink,
230 1   50     12 timezone => ($self->{config}->{logging}->{timezone} // 'gmtime'),
231             ) || die "Error creating Log::File::Rolling logger: $!";
232              
233 1         325 $self->{_friendly_current_logfile} = $curr_symlink;
234             }
235              
236              
237             sub _start_task_servers {
238 1     1   2 my ($self) = @_;
239              
240 1         2 my $task_dir = "$self->{config}->{var_dir}/tasks";
241              
242 1 50       3 if ($self->{app_spec}->{tasks}) {
243 1 50       26 if (!-e $task_dir) {
244 1 50       38 mkdir($task_dir) || die "couldn't mkdir($task_dir): $!";
245             }
246             }
247              
248 1         1 foreach my $task_name (keys %{ $self->{app_spec}->{tasks} }) {
  1         4  
249 0         0 my $task = $self->{app_spec}->{tasks}->{$task_name};
250 0         0 my $pkg = $task->{pkg};
251              
252 0         0 my $obj;
253              
254 0         0 my $constructor_func = \&{ "${pkg}::new" };
  0         0  
255              
256 0         0 my $checkout_done;
257 0 0       0 $checkout_done = \&{ "${pkg}::CHECKOUT_DONE" } if defined &{ "${pkg}::CHECKOUT_DONE" };
  0         0  
  0         0  
258              
259             AnyEvent::Task::Server::fork_task_server(
260             listen => ['unix/', "$task_dir/$task_name.socket"],
261              
262             setup => sub {
263 0     0   0 $obj = $constructor_func->($pkg, $self->{config});
264             },
265              
266             interface => sub {
267 0     0   0 my ($method, @args) = @_;
268 0         0 $obj->$method(@args);
269             },
270              
271             $checkout_done ? (
272             checkout_done => sub {
273 0     0   0 $checkout_done->($obj);
274             },
275             ) : (),
276              
277 0 0       0 %{ $task->{server} },
  0         0  
278             );
279             }
280             }
281              
282              
283             sub _start_task_clients {
284 1     1   1 my ($self) = @_;
285              
286 1         3 my $task_dir = "$self->{config}->{var_dir}/tasks";
287              
288 1         1 foreach my $task_name (keys %{ $self->{app_spec}->{tasks} }) {
  1         3  
289 0         0 my $task = $self->{app_spec}->{tasks}->{$task_name};
290              
291             $self->{task_clients}->{$task_name} = AnyEvent::Task::Client->new(
292             connect => ['unix/', "$task_dir/$task_name.socket"],
293 0         0 %{ $task->{client} },
  0         0  
294             );
295              
296 0 0       0 $self->{task_checkout_caching}->{$task_name} = 1 if $self->{app_spec}->{tasks}->{$task_name}->{checkout_caching};
297             }
298             }
299              
300              
301              
302             sub serve {
303 1     1 0 4 my ($self) = @_;
304              
305 1         3 $self->{_serving} = 1;
306              
307 1         3 $self->_start_task_servers();
308 1         3 $self->_start_task_clients();
309 1         3 $self->_listen();
310 1         3 $self->_logging();
311              
312 1         6 $self->{feersum} = Feersum->endjinn;
313 1         19 $self->{feersum}->use_socket($self->{accept_socket});
314              
315             my $app = sub {
316 1     1   2021 my $env = shift;
317              
318             return sub {
319 1         6 my $responder = shift;
320              
321 1         8 my $c = Chouette::Context->new(
322             chouette => $self,
323             env => $env,
324             responder => $responder,
325             );
326              
327 1         3 $self->_handle_request($c);
328 1         9 };
329 1         90 };
330              
331 1         2 foreach my $middleware_spec (@{ $self->{middleware_specs} }) {
  1         4  
332 0         0 my @s = @$middleware_spec;
333 0         0 my $pkg = shift(@s);
334 0         0 $app = $pkg->wrap($app, @s);
335             }
336              
337 1         3 $self->{feersum}->psgi_request_handler($app);
338              
339 1 50       3 return if $self->{quiet};
340              
341 0         0 say "="x79;
342 0         0 say;
343 0         0 say "Chouette $VERSION";
344 0         0 say;
345 0         0 say "PID = $$";
346 0         0 say "UID/GIDs = $
347 0         0 say "Listening on: $self->{_friendly_socket_desc}";
348 0         0 say;
349 0         0 say "Follow log messages:";
350 0         0 say " log-defer-viz -F $self->{_friendly_current_logfile}";
351 0         0 say;
352 0         0 say "="x79;
353             }
354              
355              
356             sub run {
357 0     0 0 0 my ($self) = @_;
358              
359 0 0       0 $self->serve unless $self->{_serving};
360              
361 0         0 AE::cv->recv;
362             }
363              
364              
365             sub _handle_request {
366 1     1   1 my ($self, $c) = @_;
367              
368 1         4 my $req = $c->req;
369 1         3 $c->logger->info("Request from " . $req->address . " : " . $req->method . " " . $req->path);
370              
371             frame_try {
372 1 50   1   95 if ($self->{pre_route_cb}) {
373 0         0 my $pre_route_cb = fub { $self->{pre_route_cb}->(@_) };
  0         0  
374 0         0 $pre_route_cb->($c, fub { $self->_do_routing($c) });
  0         0  
375             } else {
376 1         4 $self->_do_routing($c);
377             }
378             } frame_catch {
379 1     1   29 my $err = $@;
380              
381 1 50 33     8 return if ref($err) && ($err + 0 == $c->{chouette}->{_done_gensym} + 0);
382              
383 0 0       0 if ($err =~ /^(\d\d\d)\b(?:\s*:\s*)?(.*)/) {
384 0         0 my $status = $1;
385 0         0 my $msg = $2;
386              
387 0         0 my $body = {};
388              
389 0 0 0     0 if ($status < 200 || $status >= 400) {
390 0         0 $c->logger->warn("threw $err");
391 0 0       0 if (length($msg)) {
392 0         0 $msg =~ s/ at \S+ line \d+\.$//;
393 0         0 $body->{error} = $msg;
394             } else {
395 0         0 $msg = "HTTP code $status";
396             }
397             } else {
398 0         0 $msg =~ s/ at \S+ line \d+\.$//;
399 0         0 $body->{ok} = $msg;
400             }
401              
402 0         0 $c->respond($body, $status);
403 0         0 return;
404             }
405              
406 0         0 $c->logger->error($err);
407 0         0 $c->logger->data->{stacktrace} = $_[0];
408              
409 0         0 $c->respond({ error => 'internal server error' }, 500);
410 1         47 };
411             }
412              
413              
414             sub _do_routing {
415 1     1   2 my ($self, $c) = @_;
416              
417 1         2 my $path = $c->{env}->{PATH_INFO};
418 1 50       4 $path = '/' if $path eq '';
419              
420 1 50       25 die "404: Not Found" unless $path =~ $self->{route_regexp};
421              
422 1     1   436 my $route_params = \%+;
  1         307  
  1         150  
  1         6  
423              
424 1         5 my $methods = $self->{route_patterns}->{ $self->{route_regexp_assemble}->source($^R) };
425              
426 1         9 my $method = $c->{env}->{REQUEST_METHOD};
427              
428 1         2 my $func = $methods->{$method};
429              
430 1 50       2 die "405: Method Not Allowed" if !$func;
431              
432 1         2 $c->{route_params} = $route_params;
433              
434 1         2 $func->($c);
435             }
436              
437              
438              
439             sub generate_token {
440 0     0 1   state $generator = Session::Token->new;
441              
442 0           return $generator->get;
443             }
444              
445             1;
446              
447              
448              
449             __END__