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 Carp 'croak';

use Dancer2;
use Dancer2::Core::App;
use Dancer2::Core::Route;
use Dancer2::Core::Dispatcher;
use Dancer2::Core::Hook;
use Dancer2::Core::Response;

set logger => 'Null';

# init our test fixture
my $buffer = {};
my $app = Dancer2::Core::App->new( name => 'main' );

$app->setting( logger      => engine('logger') );
$app->setting( show_errors => 1 );

# a simple / route
$app->add_route(
    method => 'get',
    regexp => '/',
    code   => sub {"home"},
);

# an error route
$app->add_route(
    method => 'get',
    regexp => '/error',
    code   => sub { Fail->fail },
);

# A chain of two route for /user/$foo
$app->add_route(
    method => 'get',
    regexp => '/user/:name',
    code   => sub {
        my $app = shift;
        $buffer->{user} = $app->request->params->{'name'};
        $app->response->has_passed(1);
    },
);

$app->add_route(
    method => 'get',
    regexp => '/user/*?',
    code   => sub {
        my $app = shift;
        "Hello " . $app->request->params->{'name'};
    },
);

# a route with a 204 response
$app->add_route(
    method => 'get',
    regexp => '/twoohfour',
    code   => sub {
        my $app = shift;
        $app->response->status(204);
        "This content should be removed";
    },
);

# the tests
my @tests = (
    {   env => {
            REQUEST_METHOD => 'GET',
            PATH_INFO      => '/',
        },
        expected => [
            200,
            [   'Content-Length' => 4,
                'Content-Type'   => 'text/html; charset=UTF-8',
                'Server'         => "Perl Dancer2 $Dancer2::VERSION",
            ],
            ["home"]
        ]
    },
    {   env => {
            REQUEST_METHOD => 'GET',
            PATH_INFO      => '/user/Johnny',
        },
        expected => [
            200,
            [   'Content-Length' => 12,
                'Content-Type'   => 'text/html; charset=UTF-8',
                'Server'         => "Perl Dancer2 $Dancer2::VERSION",
            ],
            ["Hello Johnny"]
        ]
    },
    {   env => {
            REQUEST_METHOD => 'GET',
            PATH_INFO      => '/twoohfour',
        },
        expected => [
            204,
            [   'Content-Type'   => 'text/html; charset=UTF-8',
                'Server'         => "Perl Dancer2 $Dancer2::VERSION",
            ],
            []
        ]
    },
    {   env => {
            REQUEST_METHOD => 'GET',
            PATH_INFO      => '/haltme',
        },
        expected => [
            302,
            [   'Location'       => 'http://perldancer.org',
                'Content-Length' => '305',
                'Content-Type'   => 'text/html; charset=utf-8',
                'Server'         => "Perl Dancer2 $Dancer2::VERSION",
            ],
            qr/This item has moved/
        ]
    },

# NOT SUPPORTED YET
#    {   env => {
#            REQUEST_METHOD => 'GET',
#            PATH_INFO      => '/admin',
#        },
#        expected => [200, [], ["home"]]
#    },


);

# simulates a redirect with halt
$app->add_hook(
    Dancer2::Core::Hook->new(
        name => 'before',
        code => sub {
            my $app = shift;
            if ( $app->request->path_info eq '/haltme' ) {
                $app->response->header( Location => 'http://perldancer.org' );
                $app->response->status(302);
                $app->response->is_halted(1);
            }
        },
    )
);

my $was_in_second_filter = 0;
$app->add_hook(
    Dancer2::Core::Hook->new(
        name => 'before',
        code => sub {
            my $app = shift;
            if ( $app->request->path_info eq '/haltme' ) {
                $was_in_second_filter =
                  1;   # should not happen because first filter halted the flow
            }
        },
    )
);

$app->add_route(
    method => 'get',
    regexp => '/haltme',
    code   => sub {"should not get there"},
);
$app->compile_hooks;

plan tests => 16;

my $dispatcher = Dancer2::Core::Dispatcher->new( apps => [$app] );
my $counter = 0;
foreach my $test (@tests) {
    my $env      = $test->{env};
    my $expected = $test->{expected};
    my $path     = $env->{'PATH_INFO'};

    my $resp = $dispatcher->dispatch($env);

    is( $resp->[0], $expected->[0], "[$path] Return code ok" );

    my %got_headers = @{ $resp->[1] };
    my %exp_headers = @{ $expected->[1] };
    is_deeply( \%got_headers, \%exp_headers, "[$path] Correct headers" );

    if ( ref( $expected->[2] ) eq "Regexp" ) {
        like $resp->[2][0] => $expected->[2], "[$path] Contents ok. (test $counter)";
    }
    else {
        is_deeply $resp->[2] => $expected->[2], "[$path] Contents ok. (test $counter)";
    }
    $counter++;
}

foreach my $test (
    {   env => {
            REQUEST_METHOD    => 'GET',
            PATH_INFO         => '/error',
            'psgi.uri_scheme' => 'http',
            SERVER_NAME       => 'localhost',
            SERVER_PORT       => 5000,
            SERVER_PROTOCOL   => 'HTTP/1.1',
        },
        expected => [
            500,
            [ 'Content-Length', "Content-Type", 'text/html' ],
            qr{Internal Server Error.*Can't locate object method "fail" via package "Fail" \(perhaps you forgot to load "Fail"\?\) at t[\\/]dispatcher\.t line \d+.*$}ms
        ]
    }
  )
{
    my $env      = $test->{env};
    my $expected = $test->{expected};

    my $psgi_response = $dispatcher->dispatch($env);
    my $resp          = Dancer2::Core::Response->new(
        status  => $psgi_response->[0],
        headers => $psgi_response->[1],
        content => $psgi_response->[2][0],
    );

    is $resp->status => $expected->[0], "Return code ok.";
    ok( $resp->header('Content-Length') >= 140, "Length ok." );
    like $resp->content, $expected->[2], "contents ok";
}


is $was_in_second_filter, 0, "didnt enter the second filter, because of halt";