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

use strict;
use warnings;
use LWP::UserAgent;

eval "use Test::TCP";
plan skip_all => "need Test::TCP" if $@;

use Dancer::Core::Server::Standalone;

my @tests = (
    $] >= 5.010
    ? [ [get => '/usr/delete/234'],
        [200, [], [join(':', sort (qw'class usr action delete id 234'))]]
      ]
    : (),


    [   [get => '/'],
        [200, ['Content-Type' => 'text/html'], ['t::lib::TestApp']]
    ],
    [[get => '/mime/f'],         [200, [], ['text/foo']]],
    [[get => '/mime/foo'],       [200, [], ['text/foo']]],
    [[get => '/mime/something'], [200, [], ['text/bar']]],
    [[get => '/haltme'],         [200, [], ['t::lib::TestApp']]],
    [   [get => '/content_type/svg'],
        [200, ['Content-Type' => 'image/svg+xml'], ['1']]
    ],
    [[get => '/content_type/f'], [200, ['Content-Type' => 'text/foo'], ['1']]],
    [[get  => '/rewrite_me'],       [200, [], ['rewritten!']]],
    [[post => '/dirname'],          [200, [], ['/etc']]],
    [[get  => '/user/sukria/home'], [200, [], ['hello sukria']]],
    [[get  => '/config'],           [200, [], ['1 1 and 42']]],
    [[get => '/header/X-Test/42'],    [200, ['X-Test' => 42],       ['1']]],
    [[get => '/header/X-Test/42/21'], [200, ['X-Test' => '42, 21'], ['1']]],
    [[get => '/header_twice/X-Test/42/21'], [200, ['X-Test' => '21'], ['1']]],
    [[get  => '/booleans'],           [200, [], ['1:0']]],
    [[get  => '/any'],                [200, [], ['Called with method GET']]],
    [[post => '/any'],                [200, [], ['Called with method POST']]],
    [[head => '/any'],                [200, [], ['']]],
    [[get  => '/prefix/bar'],         [200, [], ['/prefix/bar']]],
    [[get  => '/prefix/prefix1/bar'], [200, [], ['/prefix/prefix1/bar']]],

    # - # FIXME : this is not supported yet, and wasnt neither in dancer 1
    #             branch topic/prefix_nightmare has a fix for it
    #[
    #[ get => '/prefix/prefix2/foo' ],
    #[ 200, [ ], ['/prefix/prefix2/foo'] ]
    #],
);

test_tcp(
    client => sub {
        my $port = shift;

        for my $t (@tests) {
            my $req      = $t->[0];
            my $expected = $t->[1];

            # Using this approach it is not possible to test get/put
            my $method = $req->[0];
            my $path   = $req->[1];
            my $ua     = LWP::UserAgent->new;
            my $res    = $ua->$method("http://localhost:${port}${path}");

            is $res->code, $expected->[0], "status is ok for $method $path";
            is $res->content, $expected->[2][0],
              "content is ok for $method $path";

            # headers
            my $headers = $expected->[1];
            for (my $i = 0; $i < scalar(@$headers); $i += 2) {
                my $header = $headers->[$i];
                my $value  = $headers->[$i + 1];
                is $res->header($header), $value,
                  "header $header is $value for $method $path";
            }
        }
    },
    server => sub {
        my $port = shift;

        use Dancer;
        use t::lib::TestApp;

        set server_port => $port;
        start;
    },
);


done_testing;