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