File Coverage

blib/lib/Dancer2/Plugin/LogReport.pm

Criterion	Covered	Total	%
statement	88	101	87.1
branch	23	36	63.8
condition	26	42	61.9
subroutine	23	31	74.1
pod	1	1	100.0
total	161	211	76.3

# This code is part of Perl distribution Dancer2-Plugin-LogReport version 2.02.
# The POD got stripped from this file by OODoc version 3.05.
# For contributors see file ChangeLog.

# This software is copyright (c) 2015-2025 by Mark Overmeer.

# This is free software; you can redistribute it and/or modify it under
# the same terms as the Perl 5 programming language system itself.
# SPDX-License-Identifier: Artistic-1.0-Perl OR GPL-1.0-or-later

#oodist: *** DO NOT USE THIS VERSION FOR PRODUCTION ***
#oodist: This file contains OODoc-style documentation which will get stripped
#oodist: during its release in the distribution.  You can use this file for
#oodist: testing, however the code of this development version may be broken!

package Dancer2::Plugin::LogReport;{
our $VERSION = '2.02';
}


use warnings;
use strict;
use version;

BEGIN { use Log::Report () }  # require very early

use Dancer2::Plugin;    # register
use Dancer2::Plugin::LogReport::Message ();

use Log::Report  'dancer2-plugin-logreport',
	syntax => 'REPORT',
	message_class => 'Dancer2::Plugin::LogReport::Message';

use Scalar::Util qw/blessed refaddr/;

my %_all_dsls;  # The DSLs for each app within the Dancer application
my $_settings;

#--------------------

# "use" import
sub import
{	my $class = shift;

	# Import Log::Report into the caller. Import options get passed through
	my $level = version->parse($Dancer2::Plugin::VERSION) > 0.166001 ? '+1' : '+2';
	Log::Report->import($level, @_, syntax => 'LONG');

	# Ensure the overridden import method is called (from Exporter::Tiny)
	# note this does not (currently) pass options through.
	my $caller = caller;
	$class->SUPER::import( {into => $caller} );
}

my %session_messages;
# The default reasons that a message will be displayed to the end user
my @default_reasons = qw/NOTICE WARNING MISTAKE ERROR FAULT ALERT FAILURE PANIC/;
my $hide_real_message; # Used to hide the real message to the end user
my $messages_variable = $_settings->{messages_key} || 'messages';


# Dancer2 import
on_plugin_import
{	# The DSL for the particular app that is loading the plugin
	my $dsl      = shift;  # capture global singleton
	$_all_dsls{refaddr($dsl->app)} = $dsl;

	my $settings = $_settings = plugin_setting;

	# Any exceptions in routes should not be happening. Therefore,
	# raise to PANIC.
	$dsl->app->add_hook(
		Dancer2::Core::Hook->new(
			name => 'core.app.route_exception',
			code => sub {
				my ($app, $error) = @_;

				# If there is no request object then we are in an early hook
				# and Dancer will not handle an exception cleanly (which will
				# result in a stacktrace to the browser, a potential security
				# vulnerability). Therefore in this case do not raise as fatal.
				# Note: Dancer2 always seem to have a request at this point
				# now, so this has probably been overtaken by events. Also, the
				# hook_exception below is now used instead to avoid any stack
				# information in the browser.
				my $is_fatal = $app->request ? 1 : 0;

				# Use a flag to avoid the panic here throwing a second panic in
				# the exception hook below.
				$app->request->var(_lr_panic_thrown => 1)
					if $app->request;

				report {is_fatal => $is_fatal}, 'PANIC' => $error;
			},
		),
	);

	$dsl->app->add_hook(
		Dancer2::Core::Hook->new(
			name => 'core.app.hook_exception',
			code => sub {
				my ($app, $error, $hook_name) = @_;
				my $fatal_error_message = _fatal_error_message();

				# If we are after the request then we need to override the
				# content now (which will likely be an ugly exception message).
				# This is because no further changes are made to the content
				# after the request (unlike at other times of the response
				# cycle)
				if ($hook_name =~ /after_request/)
				{	$app->response->content($fatal_error_message);

					# Prevent dancer throwing in its own ugly messages
					$app->response->halt;
				}

				# See comment above about not throwing same panic twice
				$app->request->var('_lr_panic_thrown')
					or report PANIC => $error;
			},
		),
	) if version->parse($Dancer2::Plugin::VERSION) >= 2;

	if($settings->{handle_http_errors})
	{	# Need after_error for HTTP errors (eg 404) so as to
		# be able to change the forwarding location
		$dsl->app->add_hook(Dancer2::Core::Hook->new(
			name => 'after_error',
			code => sub {
				my $error = shift;
				my $msg = __($error->status . ": " . Dancer2::Core::HTTP->status_message($error->status));

				#XXX This doesn't work at the moment. The DSL at this point
				# doesn't seem to respond to changes in the session or
				# forward requests
				_forward_home($msg);
			},
		));
	}

	$dsl->app->add_hook(Dancer2::Core::Hook->new(
		name => 'after_layout_render',
		code => sub {
			my $session = $dsl->app->session;
			$session->write($messages_variable => []);
		},
	));

	# Define which messages are saved to the session for later display
	# to the user. This can be configured in the config file, or we
	# choose some sensible defaults.
	my $sm = $settings->{session_messages} // \@default_reasons;
	$session_messages{$_} = 1
		for ref $sm eq 'ARRAY' ? @$sm : $sm;

	if(my $forward_template = $settings->{forward_template})
	{	# Add a route for the specified template
		$dsl->app->add_route(
			method => 'get',
			regexp => qr!^/\Q$forward_template\E$!,,
			code   => sub { shift->app->template($forward_template) }
		);
		# Forward to that new route
		$settings->{forward_url} = $forward_template;
	}

	# This is so that all messages go into the session, to be displayed
	# on the web page (if required)
	dispatcher CALLBACK => 'error_handler', callback => \&_error_handler, mode => 'DEBUG'
		unless dispatcher find => 'error_handler';

	Log::Report::Dispatcher->addSkipStack( sub { $_[0][0] =~
		m/ ^ Dancer2\:\:(?:Plugin|Logger)
		 | ^ Dancer2\:\:Core\:\:Role\:\:DSL
		 | ^ Dancer2\:\:Core\:\:App
		 /x
	});

};    # ";" required!


sub process($$)
{	my ($dsl, $coderef) = @_;
	ref $coderef eq 'CODE' or report PANIC => "plugin process() requires a CODE";
	try { $coderef->() } hide => 'ALL', on_die => 'PANIC';
	my $e = $@;  # fragile
	$e->reportAll(is_fatal => 0);
	$e->success || 0;
}

register process => \&process;


my @user_fatal_handlers;

plugin_keywords fatal_handler => sub {
	my ($plugin, $sub) = @_;
	push @user_fatal_handlers, $sub;
};

sub _get_dsl()
{	# Similar trick to Log::Report::Dispatcher::collectStack(), this time to
	# work out which Dancer app we were called from. We then use that app's
	# DSL. If we use the wrong DSL, then the request object will not be
	# available and we won't be able to forward if needed

	package DB;
	use Scalar::Util qw/blessed refaddr/;

	my (@ret, $ref, $i);

	do { @ret = caller ++$i }
	until !@ret
	  || (blessed $DB::args[0] && blessed $DB::args[0] eq 'Dancer2::Core::App' && ( $ref = refaddr $DB::args[0] ))
	  || (blessed $DB::args[1] && blessed $DB::args[1] eq 'Dancer2::Core::App' && ( $ref = refaddr $DB::args[1] ));

	$ref ? $_all_dsls{$ref} : undef;
}

sub _fatal_error_message
{
	# In a production server, we don't want the end user seeing (unexpected)
	# exception messages, for both security and usability. If we detect
	# that this is a production server (show_errors is 0), then we change
	# the specific error to a generic error, when displayed to the user.
	# The message can be customised in the config file.
	# We evaluate this each message to allow show_errors to be set in the
	# application (specifically makes testing a lot easier)
	my $dsl = _get_dsl();
	!$dsl->app->config->{show_errors}
		&& ($_settings->{fatal_error_message} // "An unexpected error has occurred");
}

sub _message_add($)
{	my $msg = shift;

	$session_messages{$msg->reason} && ! $msg->inClass('no_session')
		or return;

	# Get the DSL, only now that we know it's needed
	my $dsl = _get_dsl();

	if (!$dsl)
	{	report +{ to => 'default' }, NOTICE => "Unable to write message $msg to the session. "
		  . "Have you loaded Dancer2::Plugin::LogReport to all your separate Dancer apps?";
		return;
	}

	my $app = $dsl->app;

	# Check that we can write to the session before continuing. We can't
	# check $app->session as that can be true regardless. Instead, we check
	# for request(), which is used to access the cookies of a session.
	$app->request or return;

	my $fatal_error_message = _fatal_error_message();

	$hide_real_message->{$_} = $fatal_error_message
		for qw/FAULT ALERT FAILURE PANIC/;

	my $r = $msg->reason;
	if(my $newm = $hide_real_message->{$r})
	{	$msg    = __$newm;
		$msg->reason($r);
	}

	my $session = $app->session;
	my $msgs    = $session->read($messages_variable);
	push @$msgs, $msg;
	$session->write($messages_variable => $msgs);

	($dsl || undef, $msg);
}

#--------------------

sub _forward_home($)
{	my ($dsl, $msg) = _message_add(shift);
	$dsl ||= _get_dsl();

	my $page = $_settings->{forward_url} || '/';

	# Don't forward if it's a GET request to the error page, as it will cause a
	# recursive loop. In this case, return the fatal error message as plain
	# text to render that instead. If we can't do that because it's too early
	# in the request, then let Dancer handle this with its default error
	# handling
	my $req = $dsl->app->request or return;

	  $req->uri eq $page && $req->is_get
	? $dsl->send_as(plain => "$msg")
	: $dsl->redirect($page);
}

sub _error_handler($$$$)
{	my ($disp, $options, $reason, $message) = @_;

	my $default_handler = sub {

		# Check whether this fatal message has been caught, in which case we
		# don't want to redirect
		return _message_add($message)
			if exists $options->{is_fatal} && !$options->{is_fatal};

		_forward_home($message);
	};

	my $user_fatal_handler = sub {
		my $return;
		foreach my $ufh (@user_fatal_handlers)
		{	last if $return = $ufh->(_get_dsl, $message, $reason);
		}
		$default_handler->($message) if !$return;
	};

	my $fatal_handler = @user_fatal_handlers ? $user_fatal_handler : $default_handler;
	$message->reason($reason);

	my %handler =
	( # Default do nothing for the moment (TRACE|ASSERT|INFO)
		default => sub { _message_add $message },

		# A user-created error condition that is not recoverable.
		# This could have already been caught by the process
		# subroutine, in which case we should continue running
		# of the program. In all other cases, we should bail,
		# out.
		ERROR   => $fatal_handler,

		# All these are fatal errors.
		FAULT   => $fatal_handler,
		ALERT   => $fatal_handler,
		FAILURE => $fatal_handler,
		PANIC   => $fatal_handler,
	);

	my $call = $handler{$reason} || $handler{default};
	$call->();
}

sub _report($@) {
	my ($reason, $dsl) = (shift, shift);

	my $msg = blessed $_[0] && $_[0]->isa('Log::Report::Message')
		? $_[0] : Dancer2::Core::Role::Logger::_serialize(@_);

	if ($reason eq 'SUCCESS')
	{	$msg = __$msg unless blessed $msg;
		$msg = $msg->clone(_class => 'success');
		$reason = 'NOTICE';
	}
	report uc($reason) => $msg;
}

register trace   => sub { _report(TRACE => @_) };
register assert  => sub { _report(ASSERT => @_) };
register notice  => sub { _report(NOTICE => @_) };
register mistake => sub { _report(MISTAKE => @_) };
register panic   => sub { _report(PANIC => @_) };
register alert   => sub { _report(ALERT => @_) };
register fault   => sub { _report(FAULT => @_) };
register failure => sub { _report(FAILURE => @_) };

register success => sub { _report(SUCCESS => @_) };

register_plugin for_versions => ['2'];

#--------------------

1;