File Coverage

blib/lib/Dancer2/Core/Error.pm
Criterion Covered Total %
statement 164 166 98.8
branch 62 72 86.1
condition 35 45 77.7
subroutine 25 25 100.0
pod 5 8 62.5
total 291 316 92.0


line stmt bran cond sub pod time code
1             package Dancer2::Core::Error;
2             # ABSTRACT: Class representing fatal errors
3             $Dancer2::Core::Error::VERSION = '1.0.0';
4 146     146   109745 use Moo;
  146         8561  
  146         1071  
5 146     146   52702 use Carp;
  146         2834  
  146         9345  
6 146     146   2201 use Dancer2::Core::Types;
  146         2878  
  146         1757  
7 146     146   1800226 use Dancer2::Core::HTTP;
  146         485  
  146         6027  
8 146     146   91441 use Data::Dumper;
  146         989257  
  146         10418  
9 146     146   2157 use Dancer2::FileUtils qw/path open_file/;
  146         351  
  146         7487  
10 146     146   1049 use Sub::Quote;
  146         360  
  146         8561  
11 146     146   2126 use Module::Runtime 'require_module';
  146         3934  
  146         1760  
12 146     146   8567 use Ref::Util qw< is_hashref >;
  146         1465  
  146         6275  
13 146     146   17375 use Clone qw(clone);
  146         89151  
  146         404217  
14              
15             has app => (
16             is => 'ro',
17             isa => InstanceOf['Dancer2::Core::App'],
18             predicate => 'has_app',
19             );
20              
21             has show_stacktrace => (
22             is => 'ro',
23             isa => Bool,
24             default => sub {
25             my $self = shift;
26              
27             $self->has_app
28             and return $self->app->setting('show_stacktrace');
29             },
30             );
31              
32             has charset => (
33             is => 'ro',
34             isa => Str,
35             default => sub {'UTF-8'},
36             );
37              
38             has type => (
39             is => 'ro',
40             isa => Str,
41             default => sub {'Runtime Error'},
42             );
43              
44             has title => (
45             is => 'ro',
46             isa => Str,
47             lazy => 1,
48             builder => '_build_title',
49             );
50              
51             sub _build_title {
52 132     132   3214 my ($self) = @_;
53 132         2170 my $title = 'Error ' . $self->status;
54 132 100       2818 if ( my $msg = Dancer2::Core::HTTP->status_message($self->status) ) {
55 131         389 $title .= ' - ' . $msg;
56             }
57              
58 132         2227 return $title;
59             }
60              
61             has template => (
62             is => 'ro',
63             lazy => 1,
64             builder => '_build_error_template',
65             );
66              
67             sub _build_error_template {
68 119     119   3051 my ($self) = @_;
69              
70             # look for a template named after the status number.
71             # E.g.: views/404.tt for a TT template
72 119         2033 my $engine = $self->app->template_engine;
73 119 100       2866 return $self->status
74             if $engine->pathname_exists( $engine->view_pathname( $self->status ) );
75              
76 113         859 return;
77             }
78              
79             has static_page => (
80             is => 'ro',
81             lazy => 1,
82             builder => '_build_static_page',
83             );
84              
85             sub _build_static_page {
86 113     113   1225 my ($self) = @_;
87              
88             # TODO there must be a better way to get it
89             my $public_dir = $ENV{DANCER_PUBLIC}
90 113   66     4246 || ( $self->has_app && $self->app->config->{public_dir} );
91              
92 113         2702 my $filename = sprintf "%s/%d.html", $public_dir, $self->status;
93              
94 113 100       4895 open my $fh, '<', $filename or return;
95              
96 2         16 local $/ = undef; # slurp time
97              
98 2         123 return <$fh>;
99             }
100              
101             sub default_error_page {
102 115     115 0 244 my $self = shift;
103              
104 115         498 require_module('Template::Tiny');
105              
106 115 100 100     55281 my $uri_base = $self->has_app && $self->app->has_request ?
107             $self->app->request->uri_base : '';
108              
109             # GH#1001 stack trace if show_stacktrace is true and this is a 'server' error (5xx)
110 115   100     800 my $show_fullmsg = $self->show_stacktrace && $self->status =~ /^5/;
111 115 100 100     2702 my $opts = {
112             title => $self->title,
113             charset => $self->charset,
114             content => $show_fullmsg ? $self->full_message : _html_encode($self->message) || 'Wooops, something went wrong',
115             version => Dancer2->VERSION,
116             uri_base => $uri_base,
117             };
118              
119 115         676 Template::Tiny->new->process( \<<"END_TEMPLATE", $opts, \my $output );
120             <!DOCTYPE html>
121             <html lang="en">
122             <head>
123             <meta charset="[% charset %]">
124             <meta name="viewport" content="width=device-width, initial-scale=1.0, user-scalable=yes">
125             <title>[% title %]</title>
126             <link rel="stylesheet" href="[% uri_base %]/css/error.css">
127             </head>
128             <body>
129             <h1>[% title %]</h1>
130             <div id="content">
131             [% content %]
132             </div>
133             <div id="footer">
134             Powered by <a href="http://perldancer.org/">Dancer2</a> [% version %]
135             </div>
136             </body>
137             </html>
138             END_TEMPLATE
139              
140 115         36535 return $output;
141             }
142              
143             # status and message are 'rw' to permit modification in core.error.before hooks
144             has status => (
145             is => 'rw',
146             default => sub {500},
147             isa => Num,
148             );
149              
150             has message => (
151             is => 'rw',
152             isa => Str,
153             lazy => 1,
154             default => sub { '' },
155             );
156              
157             sub full_message {
158 7     7 0 255 my ($self) = @_;
159 7         34 my $html_output = "<h2>" . $self->type . "</h2>";
160 7         31 $html_output .= $self->backtrace;
161 7         45 $html_output .= $self->environment;
162 7         58 return $html_output;
163             }
164              
165             has serializer => (
166             is => 'ro',
167             isa => Maybe[ConsumerOf['Dancer2::Core::Role::Serializer']],
168             builder => '_build_serializer',
169             );
170              
171             sub _build_serializer {
172 135     135   5654 my ($self) = @_;
173              
174 135 100 100     1387 $self->has_app && $self->app->has_serializer_engine
175             and return $self->app->serializer_engine;
176              
177 127         2234 return;
178             }
179              
180             sub BUILD {
181 138     138 0 3315 my ($self) = @_;
182              
183 138 100       3090 $self->has_app &&
184             $self->app->execute_hook( 'core.error.init', $self );
185             }
186              
187             has exception => (
188             is => 'ro',
189             isa => Str,
190             predicate => 1,
191             coerce => sub {
192             # Until we properly support exception objects, we shouldn't barf on
193             # them because that hides the actual error, if object overloads "",
194             # which most exception objects do, this will result in a nicer string.
195             # other references will produce a meaningless error, but that is
196             # better than a meaningless stacktrace
197             return "$_[0]"
198             }
199             );
200              
201             has response => (
202             is => 'rw',
203             lazy => 1,
204             default => sub {
205             my $self = shift;
206             my $serializer = $self->serializer;
207             # include server tokens in response ?
208             my $no_server_tokens = $self->has_app
209             ? $self->app->config->{'no_server_tokens'}
210             : defined $ENV{DANCER_NO_SERVER_TOKENS}
211             ? $ENV{DANCER_NO_SERVER_TOKENS}
212             : 0;
213             return Dancer2::Core::Response->new(
214             server_tokens => !$no_server_tokens,
215             ( serializer => $serializer )x!! $serializer
216             );
217             }
218             );
219              
220             has content_type => (
221             is => 'ro',
222             lazy => 1,
223             default => sub {
224             my $self = shift;
225             $self->serializer
226             ? $self->serializer->content_type
227             : 'text/html'
228             },
229             );
230              
231             has content => (
232             is => 'ro',
233             lazy => 1,
234             builder => '_build_content',
235             );
236              
237             sub _build_content {
238 134     134   2246 my $self = shift;
239              
240             # return a hashref if a serializer is available
241 134 100       561 if ( $self->serializer ) {
242 10         194 my $content = {
243             message => $self->message,
244             title => $self->title,
245             status => $self->status,
246             };
247 10 100       585 $content->{exception} = $self->exception
248             if $self->has_exception;
249 10         47 return $content;
250             }
251              
252             # otherwise we check for a template, for a static file,
253             # for configured error_template, and, if all else fails,
254             # the default error page
255 124 100 100     2280 if ( $self->has_app and $self->template ) {
256             # Render the template using apps' template engine.
257             # This may well be what caused the initial error, in which
258             # case we fall back to static page if any error was thrown.
259             # Note: this calls before/after render hooks.
260 6         105 my $content = eval {
261 6         119 $self->app->template(
262             $self->template,
263             { title => $self->title,
264             content => $self->message,
265             exception => $self->exception,
266             status => $self->status,
267             }
268             );
269             };
270 6 100       109 $@ && $self->app->engine('logger')->log( warning => $@ );
271              
272             # return rendered content unless there was an error.
273 6 100       56 return $content if defined $content;
274             }
275              
276             # It doesn't make sense to return a static page for a 500 if show_stacktrace is on
277 120 100 100     969 if ( !($self->show_stacktrace && $self->status eq '500') ) {
278 113 100       2558 if ( my $content = $self->static_page ) {
279 2         13 return $content;
280             }
281             }
282              
283 118 100 100     3052 if ($self->has_app && $self->app->config->{error_template}) {
284 3         52 my $content = eval {
285             $self->app->template(
286             $self->app->config->{error_template},
287 3         49 { title => $self->title,
288             content => $self->message,
289             exception => $self->exception,
290             status => $self->status,
291             }
292             );
293             };
294 3 50       15 $@ && $self->app->engine('logger')->log( warning => $@ );
295              
296             # return rendered content unless there was an error.
297 3 50       13 return $content if defined $content;
298             }
299              
300 115         1322 return $self->default_error_page;
301             }
302              
303             sub throw {
304 133     133 1 3900 my $self = shift;
305 133 100       449 $self->response(shift) if @_;
306              
307 133 50       2503 $self->response
308             or croak "error has no response to throw at";
309              
310 133 100       3192 $self->has_app &&
311             $self->app->execute_hook( 'core.error.before', $self );
312              
313 133         3420 my $message = $self->content;
314              
315 133         2863 $self->response->status( $self->status );
316 133         6434 $self->response->content_type( $self->content_type );
317 133         2474 $self->response->content($message);
318              
319 133 100       17121 $self->has_app &&
320             $self->app->execute_hook('core.error.after', $self->response);
321              
322 133         3301 $self->response->is_halted(1);
323 133         8201 return $self->response;
324             }
325              
326             sub backtrace {
327 7     7 1 20 my ($self) = @_;
328              
329 7         150 my $message = $self->message;
330 7 50       228 if ($self->exception) {
331 7 50       25 $message .= "\n" if $message;
332 7         30 $message .= $self->exception;
333             }
334 7   50     26 $message ||= 'Wooops, something went wrong';
335              
336 7         28 my $html = '<pre class="error">' . _html_encode($message) . "</pre>\n";
337              
338             # the default perl warning/error pattern
339 7         45 my ($file, $line) = $message =~ /at (\S+) line (\d+)/;
340             # the Devel::SimpleTrace pattern
341 7 100 66     56 ($file, $line) = $message =~ /at.*\((\S+):(\d+)\)/ unless $file and $line;
342              
343             # no file/line found, cannot open a file for context
344 7 100 66     42 return $html unless $file and $line;
345              
346             # file and line are located, let's read the source Luke!
347 4 50       12 my $fh = eval { open_file('<', $file) } or return $html;
  4         31  
348 4         157 my @lines = <$fh>;
349 4         870 close $fh;
350              
351 4         34 $html .= qq|<div class="title">$file around line $line</div>|;
352              
353             # get 5 lines of context
354 4 50       37 my $start = $line - 5 > 1 ? $line - 5 : 1;
355 4 50       21 my $stop = $line + 5 < @lines ? $line + 5 : @lines;
356              
357 4         16 $html .= qq|<pre class="content"><table class="context">\n|;
358 4         18 for my $l ($start .. $stop) {
359 44         76 chomp $lines[$l - 1];
360              
361 44 100       92 $html .= $l == $line ? '<tr class="errline">' : '<tr>';
362 44         101 $html .= "<th>$l</th><td>" . _html_encode($lines[$l - 1]) . "</td></tr>\n";
363             }
364 4         32 $html .= "</table></pre>\n";
365              
366 4         79 return $html;
367             }
368              
369             sub dumper {
370 7     7 1 85 my $obj = shift;
371              
372             # Take a copy of the data, so we can mask sensitive-looking stuff:
373 7         2333 my $data = clone($obj);
374 7         48 my $censored = _censor( $data );
375              
376             #use Data::Dumper;
377 7         77 my $dd = Data::Dumper->new( [ $data ] );
378 7         287 my $hash_separator = ' @@!%,+$$#._(-- '; # Very unlikely string to exist already
379 7         14 my $prefix_padding = ' #+#+@%.,$_-!(( '; # Very unlikely string to exist already
380 7         35 $dd->Terse(1)->Quotekeys(0)->Indent(1)->Sortkeys(1)->Pair($hash_separator)->Pad($prefix_padding);
381 7         341 my $content = _html_encode( $dd->Dump );
382 7         77 $content =~ s/^.+//; # Remove the first line
383 7         182 $content =~ s/\n.+$//; # Remove the last line
384 7         317 $content =~ s/^\Q$prefix_padding\E //gm; # Remove the padding
385 7         945 $content =~ s{^(\s*)(.+)\Q$hash_separator}{$1<span class="key">$2</span> =&gt; }gm;
386 7 100       36 if ($censored) {
387 1         7 $content
388             .= "\n\nNote: Values of $censored sensitive-looking keys hidden\n";
389             }
390 7         248 return $content;
391             }
392              
393             sub environment {
394 7     7 1 24 my ($self) = @_;
395              
396 7         28 my $stack = $self->get_caller;
397 7   66     70 my $settings = $self->has_app && $self->app->settings;
398 7   33     167 my $session = $self->has_app && $self->app->_has_session && $self->app->session->data;
399 7   66     90 my $env = $self->has_app && $self->app->has_request && $self->app->request->env;
400              
401             # Get a sanitised dump of the settings, session and environment
402 7 100       63 $_ = $_ ? dumper($_) : '<i>undefined</i>' for $settings, $session, $env;
403              
404 7         294 return <<"END_HTML";
405             <div class="title">Stack</div><pre class="content">$stack</pre>
406             <div class="title">Settings</div><pre class="content">$settings</pre>
407             <div class="title">Session</div><pre class="content">$session</pre>
408             <div class="title">Environment</div><pre class="content">$env</pre>
409             END_HTML
410             }
411              
412             sub get_caller {
413 7     7 1 19 my ($self) = @_;
414 7         12 my @stack;
415              
416 7         14 my $deepness = 0;
417 7         104 while ( my ( $package, $file, $line ) = caller( $deepness++ ) ) {
418 130         859 push @stack, "$package in $file l. $line";
419             }
420              
421 7         87 return join( "\n", reverse(@stack) );
422             }
423              
424             # private
425              
426             # Given a hashref, censor anything that looks sensitive. Returns number of
427             # items which were "censored".
428              
429             sub _censor {
430 61     61   86 my $hash = shift;
431 61   100     117 my $visited = shift || {};
432              
433 61 50 33     186 unless ( $hash && is_hashref($hash) ) {
434 0         0 carp "_censor given incorrect input: $hash";
435 0         0 return;
436             }
437              
438 61         74 my $censored = 0;
439 61         170 for my $key ( keys %$hash ) {
440 316 100       1100 if ( is_hashref( $hash->{$key} ) ) {
    100          
441 58 100       147 if (!$visited->{ $hash->{$key} }) {
442             # mark the new ref as visited
443 54         138 $visited->{ $hash->{$key} } = 1;
444              
445 54         128 $censored += _censor( $hash->{$key}, $visited );
446             }
447             }
448             elsif ( $key =~ /(pass|card?num|pan|secret)/i ) {
449 2         12 $hash->{$key} = "Hidden (looks potentially sensitive)";
450 2         4 $censored++;
451             }
452             }
453              
454 61         155 return $censored;
455             }
456              
457             # Replaces the entities that are illegal in (X)HTML.
458             sub _html_encode {
459 166     166   8805 my $value = shift;
460              
461 166 50       419 return if !defined $value;
462              
463 166         383 $value =~ s/&/&amp;/g;
464 166         316 $value =~ s/</&lt;/g;
465 166         351 $value =~ s/>/&gt;/g;
466 166         466 $value =~ s/'/&#39;/g;
467 166         313 $value =~ s/"/&quot;/g;
468              
469 166         1027 return $value;
470             }
471              
472             1;
473              
474             __END__
475              
476             =pod
477              
478             =encoding UTF-8
479              
480             =head1 NAME
481              
482             Dancer2::Core::Error - Class representing fatal errors
483              
484             =head1 VERSION
485              
486             version 1.0.0
487              
488             =head1 SYNOPSIS
489              
490             use Dancer2::Core::Error;
491              
492             my $error = Dancer2::Core::Error->new(
493             status => 404,
494             message => "No such file: `$path'"
495             );
496              
497             $error->throw;
498              
499             =head1 DESCRIPTION
500              
501             With Dancer2::Core::Error you can throw reasonable-looking errors to the user
502             instead of crashing the application and filling up the logs.
503              
504             This is usually used in debugging environments, and it's what Dancer2 uses as
505             well under debugging to catch errors and show them on screen.
506              
507             =head1 ATTRIBUTES
508              
509             =head2 show_stacktrace
510              
511             =head2 charset
512              
513             =head2 type
514              
515             The error type.
516              
517             =head2 title
518              
519             The title of the error page.
520              
521             This is only an attribute getter, you'll have to set it at C<new>.
522              
523             =head2 status
524              
525             The status that caused the error.
526              
527             This is only an attribute getter, you'll have to set it at C<new>.
528              
529             =head2 message
530              
531             The message of the error page.
532              
533             =head1 METHODS
534              
535             =head2 my $error=new Dancer2::Core::Error(status => 404, message => "No such file: `$path'");
536              
537             Create a new Dancer2::Core::Error object. For available arguments see ATTRIBUTES.
538              
539             =head2 supported_hooks ();
540              
541             =head2 throw($response)
542              
543             Populates the content of the response with the error's information.
544             If I<$response> is not given, acts on the I<app>
545             attribute's response.
546              
547             =head2 backtrace
548              
549             Show the surrounding lines of context at the line where the error was thrown.
550              
551             This method tries to find out where the error appeared according to the actual
552             error message (using the C<message> attribute) and tries to parse it (supporting
553             the regular/default Perl warning or error pattern and the L<Devel::SimpleTrace>
554             output) and then returns an error-highlighted C<message>.
555              
556             =head2 environment
557              
558             A main function to render environment information: the caller (using
559             C<get_caller>), the settings and environment (using C<dumper>) and more.
560              
561             =head2 get_caller
562              
563             Creates a stack trace of callers.
564              
565             =head1 FUNCTIONS
566              
567             =head2 _censor
568              
569             An private function that tries to censor out content which should be protected.
570              
571             C<dumper> calls this method to censor things like passwords and such.
572              
573             =head2 my $string=_html_encode ($string);
574              
575             Private function that replaces illegal entities in (X)HTML with their
576             escaped representations.
577              
578             html_encode() doesn't do any UTF black magic.
579              
580             =head2 dumper
581              
582             This uses L<Data::Dumper> to create nice content output with a few predefined
583             options.
584              
585             =head1 AUTHOR
586              
587             Dancer Core Developers
588              
589             =head1 COPYRIGHT AND LICENSE
590              
591             This software is copyright (c) 2023 by Alexis Sukrieh.
592              
593             This is free software; you can redistribute it and/or modify it under
594             the same terms as the Perl 5 programming language system itself.
595              
596             =cut