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 = '0.400001';
4 145     145   99507 use Moo;
  145         6720  
  145         1027  
5 145     145   52338 use Carp;
  145         3229  
  145         9826  
6 145     145   1963 use Dancer2::Core::Types;
  145         2794  
  145         1707  
7 145     145   1732160 use Dancer2::Core::HTTP;
  145         426  
  145         5687  
8 145     145   86304 use Data::Dumper;
  145         920685  
  145         9875  
9 145     145   2072 use Dancer2::FileUtils qw/path open_file/;
  145         321  
  145         6948  
10 145     145   1032 use Sub::Quote;
  145         322  
  145         8137  
11 145     145   1868 use Module::Runtime 'require_module';
  145         3542  
  145         1398  
12 145     145   8084 use Ref::Util qw< is_hashref >;
  145         1331  
  145         6043  
13 145     145   16331 use Clone qw(clone);
  145         79927  
  145         375485  
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 126     126   3150 my ($self) = @_;
53 126         2019 my $title = 'Error ' . $self->status;
54 126 100       2659 if ( my $msg = Dancer2::Core::HTTP->status_message($self->status) ) {
55 125         346 $title .= ' - ' . $msg;
56             }
57              
58 126         2124 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 113     113   1049 my ($self) = @_;
69              
70             # look for a template named after the status number.
71             # E.g.: views/404.tt for a TT template
72 113         1842 my $engine = $self->app->template_engine;
73 113 100       2489 return $self->status
74             if $engine->pathname_exists( $engine->view_pathname( $self->status ) );
75              
76 107         785 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 107     107   1058 my ($self) = @_;
87              
88             # TODO there must be a better way to get it
89             my $public_dir = $ENV{DANCER_PUBLIC}
90 107   66     2244 || ( $self->has_app && $self->app->config->{public_dir} );
91              
92 107         2562 my $filename = sprintf "%s/%d.html", $public_dir, $self->status;
93              
94 107 100       4608 open my $fh, '<', $filename or return;
95              
96 2         18 local $/ = undef; # slurp time
97              
98 2         1983 return <$fh>;
99             }
100              
101             sub default_error_page {
102 109     109 0 230 my $self = shift;
103              
104 109         473 require_module('Template::Tiny');
105              
106 109 100 100     52371 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 109   100     809 my $show_fullmsg = $self->show_stacktrace && $self->status =~ /^5/;
111 109 100 100     2376 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 109         805 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 109         34278 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 245 my ($self) = @_;
159 7         33 my $html_output = "<h2>" . $self->type . "</h2>";
160 7         27 $html_output .= $self->backtrace;
161 7         33 $html_output .= $self->environment;
162 7         64 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 129     129   5362 my ($self) = @_;
173              
174 129 100 100     2028 $self->has_app && $self->app->has_serializer_engine
175             and return $self->app->serializer_engine;
176              
177 121         2112 return;
178             }
179              
180             sub BUILD {
181 132     132 0 3116 my ($self) = @_;
182              
183 132 100       2965 $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 128     128   1942 my $self = shift;
239              
240             # return a hashref if a serializer is available
241 128 100       618 if ( $self->serializer ) {
242 10         183 my $content = {
243             message => $self->message,
244             title => $self->title,
245             status => $self->status,
246             };
247 10 100       511 $content->{exception} = $self->exception
248             if $self->has_exception;
249 10         44 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 118 100 100     2132 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         85 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       102 $@ && $self->app->engine('logger')->log( warning => $@ );
271              
272             # return rendered content unless there was an error.
273 6 100       55 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 114 100 100     748 if ( !($self->show_stacktrace && $self->status eq '500') ) {
278 107 100       2339 if ( my $content = $self->static_page ) {
279 2         15 return $content;
280             }
281             }
282              
283 112 100 100     2932 if ($self->has_app && $self->app->config->{error_template}) {
284 3         31 my $content = eval {
285             $self->app->template(
286             $self->app->config->{error_template},
287 3         51 { 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       16 return $content if defined $content;
298             }
299              
300 109         1200 return $self->default_error_page;
301             }
302              
303             sub throw {
304 127     127 1 2065 my $self = shift;
305 127 100       399 $self->response(shift) if @_;
306              
307 127 50       2234 $self->response
308             or croak "error has no response to throw at";
309              
310 127 100       3005 $self->has_app &&
311             $self->app->execute_hook( 'core.error.before', $self );
312              
313 127         3170 my $message = $self->content;
314              
315 127         2737 $self->response->status( $self->status );
316 127         5975 $self->response->content_type( $self->content_type );
317 127         2323 $self->response->content($message);
318              
319 127 100       14548 $self->has_app &&
320             $self->app->execute_hook('core.error.after', $self->response);
321              
322 127         3384 $self->response->is_halted(1);
323 127         7664 return $self->response;
324             }
325              
326             sub backtrace {
327 7     7 1 18 my ($self) = @_;
328              
329 7         136 my $message = $self->message;
330 7 50       201 if ($self->exception) {
331 7 50       26 $message .= "\n" if $message;
332 7         27 $message .= $self->exception;
333             }
334 7   50     22 $message ||= 'Wooops, something went wrong';
335              
336 7         32 my $html = '<pre class="error">' . _html_encode($message) . "</pre>\n";
337              
338             # the default perl warning/error pattern
339 7         40 my ($file, $line) = $message =~ /at (\S+) line (\d+)/;
340             # the Devel::SimpleTrace pattern
341 7 100 66     53 ($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     40 return $html unless $file and $line;
345              
346             # file and line are located, let's read the source Luke!
347 4 50       9 my $fh = eval { open_file('<', $file) } or return $html;
  4         19  
348 4         122 my @lines = <$fh>;
349 4         717 close $fh;
350              
351 4         30 $html .= qq|<div class="title">$file around line $line</div>|;
352              
353             # get 5 lines of context
354 4 50       30 my $start = $line - 5 > 1 ? $line - 5 : 1;
355 4 50       21 my $stop = $line + 5 < @lines ? $line + 5 : @lines;
356              
357 4         15 $html .= qq|<pre class="content"><table class="context">\n|;
358 4         16 for my $l ($start .. $stop) {
359 44         78 chomp $lines[$l - 1];
360              
361 44 100       77 $html .= $l == $line ? '<tr class="errline">' : '<tr>';
362 44         94 $html .= "<th>$l</th><td>" . _html_encode($lines[$l - 1]) . "</td></tr>\n";
363             }
364 4         13 $html .= "</table></pre>\n";
365              
366 4         61 return $html;
367             }
368              
369             sub dumper {
370 7     7 1 45 my $obj = shift;
371              
372             # Take a copy of the data, so we can mask sensitive-looking stuff:
373 7         528 my $data = clone($obj);
374 7         40 my $censored = _censor( $data );
375              
376             #use Data::Dumper;
377 7         66 my $dd = Data::Dumper->new( [ $data ] );
378 7         244 my $hash_separator = ' @@!%,+$$#._(-- '; # Very unlikely string to exist already
379 7         12 my $prefix_padding = ' #+#+@%.,$_-!(( '; # Very unlikely string to exist already
380 7         34 $dd->Terse(1)->Quotekeys(0)->Indent(1)->Sortkeys(1)->Pair($hash_separator)->Pad($prefix_padding);
381 7         299 my $content = _html_encode( $dd->Dump );
382 7         71 $content =~ s/^.+//; # Remove the first line
383 7         149 $content =~ s/\n.+$//; # Remove the last line
384 7         314 $content =~ s/^\Q$prefix_padding\E //gm; # Remove the padding
385 7         887 $content =~ s{^(\s*)(.+)\Q$hash_separator}{$1<span class="key">$2</span> =&gt; }gm;
386 7 100       32 if ($censored) {
387 1         4 $content
388             .= "\n\nNote: Values of $censored sensitive-looking keys hidden\n";
389             }
390 7         234 return $content;
391             }
392              
393             sub environment {
394 7     7 1 20 my ($self) = @_;
395              
396 7         27 my $stack = $self->get_caller;
397 7   66     53 my $settings = $self->has_app && $self->app->settings;
398 7   33     129 my $session = $self->has_app && $self->app->_has_session && $self->app->session->data;
399 7   66     74 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       55 $_ = $_ ? dumper($_) : '<i>undefined</i>' for $settings, $session, $env;
403              
404 7         265 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 16 my ($self) = @_;
414 7         15 my @stack;
415              
416 7         16 my $deepness = 0;
417 7         88 while ( my ( $package, $file, $line ) = caller( $deepness++ ) ) {
418 130         753 push @stack, "$package in $file l. $line";
419             }
420              
421 7         68 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   78 my $hash = shift;
431 61   100     110 my $visited = shift || {};
432              
433 61 50 33     190 unless ( $hash && is_hashref($hash) ) {
434 0         0 carp "_censor given incorrect input: $hash";
435 0         0 return;
436             }
437              
438 61         92 my $censored = 0;
439 61         142 for my $key ( keys %$hash ) {
440 316 100       1029 if ( is_hashref( $hash->{$key} ) ) {
    100          
441 58 100       134 if (!$visited->{ $hash->{$key} }) {
442             # mark the new ref as visited
443 54         106 $visited->{ $hash->{$key} } = 1;
444              
445 54         122 $censored += _censor( $hash->{$key}, $visited );
446             }
447             }
448             elsif ( $key =~ /(pass|card?num|pan|secret)/i ) {
449 2         5 $hash->{$key} = "Hidden (looks potentially sensitive)";
450 2         5 $censored++;
451             }
452             }
453              
454 61         128 return $censored;
455             }
456              
457             # Replaces the entities that are illegal in (X)HTML.
458             sub _html_encode {
459 160     160   6420 my $value = shift;
460              
461 160 50       383 return if !defined $value;
462              
463 160         310 $value =~ s/&/&amp;/g;
464 160         277 $value =~ s/</&lt;/g;
465 160         320 $value =~ s/>/&gt;/g;
466 160         429 $value =~ s/'/&#39;/g;
467 160         296 $value =~ s/"/&quot;/g;
468              
469 160         834 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 0.400001
487              
488             =head1 SYNOPSIS
489              
490             # taken from send_file:
491             use Dancer2::Core::Error;
492              
493             my $error = Dancer2::Core::Error->new(
494             status => 404,
495             message => "No such file: `$path'"
496             );
497              
498             Dancer2::Core::Response->set($error->render);
499              
500             =head1 DESCRIPTION
501              
502             With Dancer2::Core::Error you can throw reasonable-looking errors to the user
503             instead of crashing the application and filling up the logs.
504              
505             This is usually used in debugging environments, and it's what Dancer2 uses as
506             well under debugging to catch errors and show them on screen.
507              
508             =head1 ATTRIBUTES
509              
510             =head2 show_stacktrace
511              
512             =head2 charset
513              
514             =head2 type
515              
516             The error type.
517              
518             =head2 title
519              
520             The title of the error page.
521              
522             This is only an attribute getter, you'll have to set it at C<new>.
523              
524             =head2 status
525              
526             The status that caused the error.
527              
528             This is only an attribute getter, you'll have to set it at C<new>.
529              
530             =head2 message
531              
532             The message of the error page.
533              
534             =head1 METHODS
535              
536             =head2 my $error=new Dancer2::Core::Error(status => 404, message => "No such file: `$path'");
537              
538             Create a new Dancer2::Core::Error object. For available arguments see ATTRIBUTES.
539              
540             =head2 supported_hooks ();
541              
542             =head2 throw($response)
543              
544             Populates the content of the response with the error's information.
545             If I<$response> is not given, acts on the I<app>
546             attribute's response.
547              
548             =head2 backtrace
549              
550             Show the surrounding lines of context at the line where the error was thrown.
551              
552             This method tries to find out where the error appeared according to the actual
553             error message (using the C<message> attribute) and tries to parse it (supporting
554             the regular/default Perl warning or error pattern and the L<Devel::SimpleTrace>
555             output) and then returns an error-highlighted C<message>.
556              
557             =head2 environment
558              
559             A main function to render environment information: the caller (using
560             C<get_caller>), the settings and environment (using C<dumper>) and more.
561              
562             =head2 get_caller
563              
564             Creates a stack trace of callers.
565              
566             =head1 FUNCTIONS
567              
568             =head2 _censor
569              
570             An private function that tries to censor out content which should be protected.
571              
572             C<dumper> calls this method to censor things like passwords and such.
573              
574             =head2 my $string=_html_encode ($string);
575              
576             Private function that replaces illegal entities in (X)HTML with their
577             escaped representations.
578              
579             html_encode() doesn't do any UTF black magic.
580              
581             =head2 dumper
582              
583             This uses L<Data::Dumper> to create nice content output with a few predefined
584             options.
585              
586             =head1 AUTHOR
587              
588             Dancer Core Developers
589              
590             =head1 COPYRIGHT AND LICENSE
591              
592             This software is copyright (c) 2023 by Alexis Sukrieh.
593              
594             This is free software; you can redistribute it and/or modify it under
595             the same terms as the Perl 5 programming language system itself.
596              
597             =cut