The Perl Toolchain Summit needs more sponsors. If your company depends on Perl, please support this very important event.
use strict;
use warnings;
use Test::More import => ['!pass'];
use Plack::Test;
use HTTP::Request::Common;

use Dancer2::Core::App;
use Dancer2::Core::Response;
use Dancer2::Core::Request;
use Dancer2::Core::Error;

use JSON::MaybeXS qw/JSON/; # Error serialization

my $env = {
    'psgi.url_scheme' => 'http',
    REQUEST_METHOD    => 'GET',
    SCRIPT_NAME       => '/foo',
    PATH_INFO         => '/bar/baz',
    REQUEST_URI       => '/foo/bar/baz',
    QUERY_STRING      => 'foo=42&bar=12&bar=13&bar=14',
    SERVER_NAME       => 'localhost',
    SERVER_PORT       => 5000,
    SERVER_PROTOCOL   => 'HTTP/1.1',
    REMOTE_ADDR       => '127.0.0.1',
    HTTP_COOKIE =>
      'dancer.session=1234; fbs_102="access_token=xxxxxxxxxx%7Cffffff"',
    HTTP_X_FORWARDED_FOR => '127.0.0.2',
    REMOTE_HOST     => 'localhost',
    HTTP_USER_AGENT => 'Mozilla',
    REMOTE_USER     => 'sukria',
};

my $app     = Dancer2::Core::App->new( name => 'main' );
my $request = $app->build_request($env);

$app->set_request($request);

subtest 'basic defaults of Error object' => sub {
    my $err = Dancer2::Core::Error->new( app => $app );
    is $err->status,  500,                                 'code';
    is $err->title,   'Error 500 - Internal Server Error', 'title';
    is $err->message, '',                               'message';
    like $err->content, qr!http://localhost:5000/foo/css!,
        "error content contains css path relative to uri_base";
};

subtest "send_error in route" => sub {
    {

        package App;
        use Dancer2;

        set serializer => 'JSON';

        get '/error' => sub {
            send_error "This is a custom error message";
            return "send_error returns so this content is not processed";
        };
    }

    my $app = App->to_app;
    is( ref $app, 'CODE', 'Got app' );

    test_psgi $app, sub {
        my $cb = shift;
        my $r  = $cb->( GET '/error' );

        is( $r->code, 500, 'send_error sets the status to 500' );
        like(
            $r->content,
            qr{This is a custom error message},
            'Error message looks good',
        );

        is(
            $r->content_type,
            'application/json',
            'Response has appropriate content type after serialization',
        );
    };
};

subtest "send_error with custom stuff" => sub {
    {

        package App;
        use Dancer2;

        get '/error/:x' => sub {
            my $x = param('x');
            send_error "Error $x", "5$x";
        };
    }

    my $app = App->to_app;
    is( ref $app, 'CODE', 'Got app' );

    test_psgi $app, sub {
        my $cb = shift;
        my $r  = $cb->( GET '/error/42' );

        is( $r->code, 542, 'send_error sets the status to 542' );
        like( $r->content, qr{Error 42},  'Error message looks good' );
    };
};

subtest 'Response->error()' => sub {
    my $resp = Dancer2::Core::Response->new;

    isa_ok $resp->error( message => 'oops', status => 418 ),
      'Dancer2::Core::Error';

    is $resp->status    => 418,        'response code is 418';
    like $resp->content => qr/oops/,   'response content overriden by error';
    like $resp->content => qr/teapot/, 'error code title is present';
    ok $resp->is_halted, 'response is halted';
};

subtest 'Throwing an error with a response' => sub {
    my $resp = Dancer2::Core::Response->new;

    my $err = eval { Dancer2::Core::Error->new(
        exception   => 'our exception',
        show_errors => 1
    )->throw($resp) };
      
    isa_ok($err, 'Dancer2::Core::Response', "Error->throw() accepts a response");
};

subtest 'Error with show_errors: 0' => sub {
    my $err = Dancer2::Core::Error->new(
        exception   => 'our exception',
        show_errors => 0
    )->throw;
    unlike $err->content => qr/our exception/;
};

subtest 'Error with show_errors: 1' => sub {
    my $err = Dancer2::Core::Error->new(
        exception   => 'our exception',
        show_errors => 1
    )->throw;
    like $err->content => qr/our exception/;
};

subtest 'App dies with serialized error' => sub {
    {
        package AppDies;
        use Dancer2;
        set serializer => 'JSON';

        get '/die' => sub {
            die "oh no\n"; # I should serialize
        };
    }

    my $app = AppDies->to_app;
    isa_ok( $app, 'CODE', 'Got app' );

    test_psgi $app, sub {
        my $cb = shift;
        my $r  = $cb->( GET '/die' );

        is( $r->code, 500, '/die returns 500' );

        my $out = eval { JSON->new->utf8(0)->decode($r->decoded_content) };
        ok(!$@, 'JSON decoding serializer error produces no errors');
        isa_ok($out, 'HASH', 'Error deserializes to a hash');
        like($out->{exception}, qr/^oh no/, 'Get expected error message');
    };
};

subtest 'Error with exception object' => sub {
    local $@;
    eval { MyTestException->throw('a test exception object') };
    my $err = Dancer2::Core::Error->new(
        exception   => $@,
        show_errors => 1,
    )->throw;

    like $err->content, qr/a test exception object/, 'Error content contains exception message';
};

done_testing;


{   # Simple test exception class
    package MyTestException;

    use overload '""' => \&as_str;

    sub new {
        return bless {};
    }

    sub throw {
        my ( $class, $error ) = @_;
        my $self = ref($class) ? $class : $class->new;
        $self->{error} = $error;

        die $self;
    }

    sub as_str { return $_[0]->{error} }
}