File Coverage

blib/lib/Dancer2/Core/Error.pm

Criterion	Covered	Total	%
statement	152	152	100.0
branch	55	64	85.9
condition	32	40	80.0
subroutine	24	24	100.0
pod	5	8	62.5
total	268	288	93.0

package Dancer2::Core::Error;
# ABSTRACT: Class representing fatal errors
$Dancer2::Core::Error::VERSION = '2.0.1';
use Moo;
use Carp;
use Dancer2::Core::Types;
use Dancer2::Core::HTTP;
use Data::Dumper;
use Dancer2::FileUtils qw/path open_file/;
use Sub::Quote;
use Module::Runtime qw/ require_module use_module /;
use Ref::Util qw< is_hashref >;
use Clone qw(clone);

has app => (
    is        => 'ro',
    isa       => InstanceOf['Dancer2::Core::App'],
    predicate => 'has_app',
);

has show_stacktrace => (
    is      => 'ro',
    isa     => Bool,
    default => sub {
        my $self = shift;

        $self->has_app
            and return $self->app->setting('show_stacktrace');
    },
);

has charset => (
    is      => 'ro',
    isa     => Str,
    default => sub {'UTF-8'},
);

has type => (
    is      => 'ro',
    isa     => Str,
    default => sub {'Runtime Error'},
);

has title => (
    is      => 'ro',
    isa     => Str,
    lazy    => 1,
    builder => '_build_title',
);

has censor => (
    is => 'ro',
    isa => CodeRef,
    lazy => 1,
    default => sub {
        my $self = shift;

        if( my $custom = $self->has_app && $self->app->setting('error_censor') ) {

            if( is_hashref $custom ) {
                die "only one key can be set for the 'error_censor' setting\n"
                    if 1 != keys %$custom;

                my( $class, $args ) = %$custom;

                my $censor = use_module($class)->new(%$args);

                return sub {
                    $censor->censor(@_);
                }
            }

            my $coderef = eval '\&'.$custom;

            # it's already defined? Nice! We're done
            return $coderef if $coderef;

            my $module = $custom =~ s/::[^:]*?$//r;

            require_module($module);

            return eval '\&'.$custom;
        }

        # reminder: update POD below if changing the config here
         my $data_censor = use_module('Data::Censor')->new(
             sensitive_fields => qr/pass|card.?num|pan|secret/i,
             replacement => "Hidden (looks potentially sensitive)",
         );

         return sub {
             $data_censor->censor(@_);
         };
    }
);

sub _build_title {
    my ($self) = @_;
    my $title = 'Error ' . $self->status;
    if ( my $msg = Dancer2::Core::HTTP->status_message($self->status) ) {
        $title .= ' - ' . $msg;
    }

    return $title;
}

has template => (
    is      => 'ro',
    lazy    => 1,
    builder => '_build_error_template',
);

sub _build_error_template {
    my ($self) = @_;

    # look for a template named after the status number.
    # E.g.: views/404.tt  for a TT template
    my $engine = $self->app->template_engine;
    return $self->status
      if $engine->pathname_exists( $engine->view_pathname( $self->status ) );

    return;
}

has static_page => (
    is      => 'ro',
    lazy    => 1,
    builder => '_build_static_page',
);

sub _build_static_page {
    my ($self) = @_;

    # TODO there must be a better way to get it
    my $public_dir = $ENV{DANCER_PUBLIC}
      || ( $self->has_app && $self->app->config->{public_dir} );

    my $filename = sprintf "%s/%d.html", $public_dir, $self->status;

    open my $fh, '<', $filename or return;

    local $/ = undef;    # slurp time

    return <$fh>;
}

sub default_error_page {
    my $self = shift;

    require_module('Template::Tiny');

    my $uri_base = $self->has_app && $self->app->has_request ?
        $self->app->request->uri_base : '';

    # GH#1001 stack trace if show_stacktrace is true and this is a 'server' error (5xx)
    my $show_fullmsg = $self->show_stacktrace && $self->status =~ /^5/;
    my $opts = {
        title    => $self->title,
        charset  => $self->charset,
        content  => $show_fullmsg ? $self->full_message : _html_encode($self->message) || 'Wooops, something went wrong',
        version  => Dancer2->VERSION,
        uri_base => $uri_base,
    };

    Template::Tiny->new->process( \<<"END_TEMPLATE", $opts, \my $output );





  [% title %]



[% title %]

[% content %]


Powered by Dancer2 [% version %]



END_TEMPLATE

    return $output;
}

# status and message are 'rw' to permit modification in core.error.before hooks
has status => (
    is      => 'rw',
    default => sub {500},
    isa     => Num,
);

has message => (
    is      => 'rw',
    isa     => Str,
    lazy    => 1,
    default => sub { '' },
);

sub full_message {
    my ($self) = @_;
    my $html_output = "" . $self->type . "";
    $html_output .= $self->backtrace;
    $html_output .= $self->environment;
    return $html_output;
}

has serializer => (
    is        => 'ro',
    isa       => Maybe[ConsumerOf['Dancer2::Core::Role::Serializer']],
    builder   => '_build_serializer',
);

sub _build_serializer {
    my ($self) = @_;

    $self->has_app && $self->app->has_serializer_engine
        and return $self->app->serializer_engine;

    return;
}

sub BUILD {
    my ($self) = @_;

    $self->has_app &&
      $self->app->execute_hook( 'core.error.init', $self );
}

has exception => (
    is        => 'ro',
    isa       => Str,
    predicate => 1,
    coerce    => sub {
        # Until we properly support exception objects, we shouldn't barf on
        # them because that hides the actual error, if object overloads "",
        # which most exception objects do, this will result in a nicer string.
        # other references will produce a meaningless error, but that is
        # better than a meaningless stacktrace
        return "$_[0]"
    }
);

has response => (
    is      => 'rw',
    lazy    => 1,
    default => sub {
        my $self = shift;
        my $serializer = $self->serializer;
        # include server tokens in response ?
        my $no_server_tokens = $self->has_app
            ? $self->app->config->{'no_server_tokens'}
            : defined $ENV{DANCER_NO_SERVER_TOKENS}
                ? $ENV{DANCER_NO_SERVER_TOKENS}
                : 0;
        return Dancer2::Core::Response->new(
            server_tokens => !$no_server_tokens,
            ( serializer => $serializer )x!! $serializer
        );
    }
);

has content_type => (
    is      => 'ro',
    lazy    => 1,
    default => sub {
        my $self = shift;
        $self->serializer
            ? $self->serializer->content_type
            : 'text/html'
    },
);

has content => (
    is      => 'ro',
    lazy    => 1,
    builder => '_build_content',
);

sub _build_content {
    my $self = shift;

    # return a hashref if a serializer is available
    if ( $self->serializer ) {
        my $content = {
            message => $self->message,
            title   => $self->title,
            status  => $self->status,
        };
        $content->{exception} = $self->exception
          if $self->has_exception;
        return $content;
    }

    # otherwise we check for a template, for a static file,
    # for configured error_template, and, if all else fails,
    # the default error page
    if ( $self->has_app and $self->template ) {
        # Render the template using apps' template engine.
        # This may well be what caused the initial error, in which
        # case we fall back to static page if any error was thrown.
        # Note: this calls before/after render hooks.
        my $content = eval {
            $self->app->template(
                $self->template,
                {   title     => $self->title,
                    content   => $self->message,
                    exception => $self->exception,
                    status    => $self->status,
                }
            );
        };
        $@ && $self->app->engine('logger')->log( warning => $@ );

        # return rendered content unless there was an error.
        return $content if defined $content;
    }

    # It doesn't make sense to return a static page for a 500 if show_stacktrace is on
    if ( !($self->show_stacktrace && $self->status eq '500') ) {
         if ( my $content = $self->static_page ) {
             return $content;
         }
    }

    if ($self->has_app && $self->app->config->{error_template}) {
        my $content = eval {
            $self->app->template(
                $self->app->config->{error_template},
                {   title     => $self->title,
                    content   => $self->message,
                    exception => $self->exception,
                    status    => $self->status,
                }
            );
        };
        $@ && $self->app->engine('logger')->log( warning => $@ );

        # return rendered content unless there was an error.
        return $content if defined $content;
    }

    return $self->default_error_page;
}

sub throw {
    my $self = shift;
    $self->response(shift) if @_;

    $self->response
        or croak "error has no response to throw at";

    $self->has_app &&
        $self->app->execute_hook( 'core.error.before', $self );

    my $message = $self->content;

    $self->response->status( $self->status );
    $self->response->content_type( $self->content_type );
    $self->response->content($message);

    $self->has_app &&
        $self->app->execute_hook('core.error.after', $self->response);

    $self->response->is_halted(1);
    return $self->response;
}

sub backtrace {
    my ($self) = @_;

    my $message = $self->message;
    if ($self->exception) {
        $message .= "\n" if $message;
        $message .= $self->exception;
    }
    $message ||= 'Wooops, something went wrong';

    my $html = '' . _html_encode($message) . "\n";

    # the default perl warning/error pattern
    my ($file, $line) = $message =~ /at (\S+) line (\d+)/;
    # the Devel::SimpleTrace pattern
    ($file, $line) = $message =~ /at.*\((\S+):(\d+)\)/ unless $file and $line;

    # no file/line found, cannot open a file for context
    return $html unless $file and $line;

    # file and line are located, let's read the source Luke!
    my $fh = eval { open_file('<', $file) } or return $html;
    my @lines = <$fh>;
    close $fh;

    $html .= qq|$file around line $line|;

    # get 5 lines of context
    my $start = $line - 5 > 1 ? $line - 5 : 1;
    my $stop = $line + 5 < @lines ? $line + 5 : @lines;

    $html .= qq|\n|; ' : ''; \n"; 




404




4





 





 





 





 





19



     for my $l ($start .. $stop) { 




405




44





 





 





 





 





95



         chomp $lines[$l - 1]; 




406




 





 





 





 





 





 



   




407




44




  
100
  




 





 





 





204



         $html .= $l == $line ? '




408




44





 





 





 





 





109



         $html .= "$l" . _html_encode($lines[$l - 1]) . "




409




 





 





 





 





 





 



     } 




410




4





 





 





 





 





14



     $html .= "\n";
    for my $l ($start .. $stop) {
        chomp $lines[$l - 1];

        $html .= $l == $line ? '
        $html .= "
    }
    $html .= "

    return $html;
}

sub dumper {
    my ($self,$obj) = @_;

    # Take a copy of the data, so we can mask sensitive-looking stuff:
    my $data     = clone($obj);
    my $censored = $self->censor->( $data );

    #use Data::Dumper;
    my $dd = Data::Dumper->new( [ $data ] );
    my $hash_separator = '  @@!%,+$$#._(--  '; # Very unlikely string to exist already
    my $prefix_padding = '  #+#+@%.,$_-!((  '; # Very unlikely string to exist already
    $dd->Terse(1)->Quotekeys(0)->Indent(1)->Sortkeys(1)->Pair($hash_separator)->Pad($prefix_padding);
    my $content = _html_encode( $dd->Dump );
    $content =~ s/^.+//;   # Remove the first line
    $content =~ s/\n.+$//; # Remove the last line
    $content =~ s/^\Q$prefix_padding\E  //gm; # Remove the padding
    $content =~ s{^(\s*)(.+)\Q$hash_separator}{$1$2 => }gm;
    if ($censored) {
        $content
          .= "\n\nNote: Values of $censored sensitive-looking keys hidden\n";
    }
    return $content;
}

sub environment {
    my ($self) = @_;

    my $stack = $self->get_caller;
    my $settings = $self->has_app && $self->app->settings;
    my $session = $self->has_app && $self->app->_has_session && $self->app->session->data;
    my $env = $self->has_app && $self->app->has_request && $self->app->request->env;

    # Get a sanitised dump of the settings, session and environment
    $_ = $_ ? $self->dumper($_) : 'undefined' for $settings, $session, $env;

    return <<"END_HTML";
Stack$stack
Settings$settings
Session$session
Environment$env
END_HTML
}

sub get_caller {
    my ($self) = @_;
    my @stack;

    my $deepness = 0;
    while ( my ( $package, $file, $line ) = caller( $deepness++ ) ) {
        push @stack, "$package in $file l. $line";
    }

    return join( "\n", reverse(@stack) );
}

# private

# Replaces the entities that are illegal in (X)HTML.
sub _html_encode {
    my $value = shift;

    return if !defined $value;

    $value =~ s/&/&/g;
    $value =~ s/
    $value =~ s/>/>/g;
    $value =~ s/'/'/g;
    $value =~ s/"/"/g;

    return $value;
}

1;

__END__