tPSGI/t/TPSGI-Router.t

#!/usr/bin/env perl
use 5.040;
use warnings FATAL => 'all';
use re '/aasx';

use Test2::V0;
use Test2::Plugin::NoWarnings;

use Mojo::JSON ();

use Cpanel::JSON::XS ();

use FindBin::libs;

use TPSGI::Router;

sub named { return 'named' }

sub coderef { return 'coderef' }

sub path_parameter {
    my ( $name, %schema ) = @_;
    return { name => $name, in => 'path', required => true, schema => { type => 'string', %schema } };
}

sub operation {
    my (%operation) = @_;
    return { 'x-tpsgi-callback' => \&coderef, responses => { 200 => { description => 'ok' } }, %operation };
}

sub document {
    my (%paths) = @_;
    return {
        openapi    => '3.0.3',
        info       => { title   => 'test', version => '1' },
        components => { schemas => { Count => { type => 'object', properties => { count => { type => 'integer' } } } } },
        paths      => \%paths,
    };
}

my $router = TPSGI::Router->new(
    'Test.pm' => document(
        '/sitemap/static.xml'    => { get => operation() },
        '/sitemap/{map}.xml'     => { get => operation( parameters => [ path_parameter('map') ] ) },
        '/sitemap/{map}.xml.gz'  => { get => operation( parameters => [ path_parameter('map') ] ) },
        '/lib/{module+}'         => { get => operation( parameters => [ path_parameter('module+') ] ) },
        '/lib/index'             => { get => operation() },
        '/{year}-{month}/{slug}' => { get => operation( parameters         => [ map { path_parameter($_) } qw{year month slug} ] ) },
        '/humans.txt'            => { get => operation( 'x-tpsgi-callback' => 'main::named' ) },
        '/post/{slug}'           => { get => operation( parameters         => [ path_parameter('slug') ] ) },
        '/form'                  => {
            post => operation(
                requestBody => {
                    content => {
                        'application/x-www-form-urlencoded' => {
                            schema => {
                                type                 => 'object',
                                additionalProperties => false,
                                properties           => { count => { type => 'integer' } },
                            },
                        },
                    },
                },
            ),
        },
        '/upload' => {
            post => operation(
                requestBody => {
                    content => {
                        'multipart/form-data' => {
                            schema => {
                                type       => 'object',
                                properties => { count => { type => 'integer' }, file => { type => 'string', format => 'binary' } },
                            },
                        },
                        'application/x-www-form-urlencoded' => { schema => { '$ref' => '#/components/schemas/Count' } },
                    },
                },
            ),
        },
        '/open' => {
            post => operation(
                requestBody => {
                    content => {
                        'application/x-www-form-urlencoded' => {
                            schema => { type => 'object', additionalProperties => true, properties => { count => { type => 'integer' } } },
                        },
                    },
                },
            ),
        },
        '/search' => {
            get => operation(
                parameters => [
                    { name => 'limit', in => 'query', schema => { type => 'integer' } },
                    { name => 'exact', in => 'query', schema => { type => 'boolean' } },
                ],
            ),
        },
        '/loose'            => { get => operation() },
        '/news/{slug}'      => { get => operation( parameters => [ path_parameter('slug') ] ) },
        '/{section}/latest' => { get => operation( parameters => [ path_parameter('section') ] ) },
    ),
);

subtest 'a literal template wins over a variable' => sub {
    is( $router->match( 'GET', '/sitemap/static.xml' )->{template}, '/sitemap/static.xml', 'the static sitemap is the static route' );
    my $route = $router->match( 'GET', '/sitemap/1.xml' );
    is( $route->{template},                                       '/sitemap/{map}.xml',    'and any other reaches the template' );
    is( $route->{path},                                           { map => 1 },            'with the variable' );
    is( $router->match( 'GET', '/sitemap/1.xml.gz' )->{template}, '/sitemap/{map}.xml.gz', 'and the compressed one its own template' );
    is( $router->match( 'GET', '/lib/index' )->{template},        '/lib/index',            'a literal path wins over {name+}' );
    is( $router->match( 'GET', '/news/latest' )->{template},      '/news/{slug}',          'and an earlier literal segment wins over more literal characters' );
};

subtest 'variables' => sub {
    my $route = $router->match( 'GET', '/2026-10/hello' );
    is( $route->{path}, { year => 2026, month => 10, slug => 'hello' }, 'two variables in one segment' );

    $route = $router->match( 'GET', '/lib/Trog/Auth.html' );
    is( $route->{path}, { module => 'Trog/Auth.html' }, '{module+} takes the rest of the path, slashes and all, as module' );

    my $cafe = "caf\N{LATIN SMALL LETTER E WITH ACUTE}";
    is( $router->match( 'GET', "/post/$cafe" )->{path}, { slug => $cafe }, 'a variable takes a letter outside ASCII' );
    is( $router->match( 'GET', "/post/a\nb" ),          undef,             'and no newline' );
    is( $router->match( 'GET', '/post/a/b' ),           undef,             'and no slash' );
    is( $router->match( 'GET', "/lib/a\nb" ),           undef,             'nor does {name+} take a newline' );
};

subtest 'a literal character is only itself' => sub {
    is( $router->match( 'GET', '/humans.txt' )->{template}, '/humans.txt', 'the dot matches a dot' );
    is( $router->match( 'GET', '/humansXtxt' ),             undef,         'and nothing else' );
    is( $router->match( 'GET', '/sitemap/1Xxml' ),          undef,         'in a segment with a variable as well' );
};

subtest 'callbacks' => sub {
    is( $router->match( 'GET', '/loose' )->{callback}->(),      'coderef', 'a CODE reference is the callback' );
    is( $router->match( 'GET', '/humans.txt' )->{callback}->(), 'named',   'and a name is resolved to its sub' );

    like(
        dies { TPSGI::Router->new( 'Bad.pm' => document( '/x' => { get => { responses => { 200 => { description => 'ok' } } } } ) ) },
        qr/Bad[.]pm:[ ]GET[ ]\/x[ ]has[ ]no[ ]x-tpsgi-callback/,
        'an operation without a callback dies'
    );
    like(
        dies { TPSGI::Router->new( 'Bad.pm' => document( '/x' => { get => operation( 'x-tpsgi-callback' => 'main::no_such_sub' ) } ) ) },
        qr/no_such_sub,[ ]which[ ]is[ ]not[ ]a[ ]defined/,
        'and so does a name that is not a sub'
    );
};

subtest 'booleans' => sub {
    my $json = { %{ path_parameter('x') }, required => Cpanel::JSON::XS::true };
    ok(
        lives { TPSGI::Router->new( 'Json.pm' => document( '/j/{x}' => { get => operation( parameters => [$json] ) } ) ) },
        'a JSON boolean is a boolean'
    ) or note $@;

    # $router's own document marks its path parameters required with perl's own true.
    is( $router->match( 'GET', '/post/a' )->{template}, '/post/{slug}', "and so is perl's own, which every document above uses" );

    my $document = document( '/n/{x}' => { get => operation( parameters => [ path_parameter('x') ] ) } );
    TPSGI::Router->new( 'Native.pm' => $document );
    ok( !ref $document->{paths}{'/n/{x}'}{get}{parameters}[0]{required}, 'and the router leaves the document it was given as it was' );
};

subtest 'documents that are refused' => sub {
    like(
        dies { TPSGI::Router->new( 'Bad.pm' => { openapi => '3.0.3', paths => {} } ) },
        qr/is[ ]not[ ]a[ ]valid[ ]OpenAPI[ ]3[ ]document/,
        'an invalid document dies with the reason'
    );
    like(
        dies { TPSGI::Router->new( 'Bad.pm' => document( '/a/{x}' => { get => operation() }, '/a/{y}' => { post => operation() } ) ) },
        qr/[}][ ]and[ ]\/a\/[{].[}][ ]match[ ]the[ ]same/,
        'two templates that differ only in their variable names die'
    );
    like(
        dies { TPSGI::Router->new( 'One.pm' => document( '/a' => { get => operation() } ), 'Two.pm' => document( '/a' => { get => operation() } ) ) },
        qr/Two[.]pm:[ ]GET[ ]\/a[ ]is[ ]also[ ]a[ ]route/,
        'one template and method in two routers dies'
    );
    ok(
        lives { TPSGI::Router->new( 'One.pm' => document( '/a' => { get => operation() } ), 'Two.pm' => document( '/a' => { post => operation() } ) ) },
        'but two methods of one template in two routers do not'
    ) or note $@;
    like( dies { TPSGI::Router::compile_template('/a/{x+}/b') }, qr/not[ ]the[ ]whole[ ]last[ ]segment/, '{name+} before the last segment dies' );
    like( dies { TPSGI::Router::compile_template('/a/b{x+}') },  qr/not[ ]the[ ]whole[ ]last[ ]segment/, 'and so does {name+} with text beside it' );
    like( dies { TPSGI::Router::compile_template('/a/{x') },     qr/a[ ]brace[ ]that[ ]is[ ]not/,        'and a brace that is not a variable' );
};

subtest 'methods' => sub {
    is( $router->match( 'HEAD', '/loose' )->{method}, 'get', 'HEAD falls back to get' );

    my $route = $router->match( 'POST', '/loose' );
    is( $route->{status},                    405,            'a path whose template has no operation for the method is a 405' );
    is( $route->{allow},                     [qw{GET HEAD}], 'which names the methods it does have' );
    is( $router->match( 'GET', '/nowhere' ), undef,          'and a path that no template matches is nothing at all' );
};

subtest 'validation' => sub {
    my $route = $router->match( 'GET', '/search' );
    my %query = ( limit => '5', exact => 'true' );
    is( [ $router->validate( $route, query => \%query ) ], [],                         'a valid query passes' );
    is( Mojo::JSON::encode_json( \%query ),                '{"exact":true,"limit":5}', 'and arrives coerced: a number and a boolean, not two strings' );

    my ( $status, @errors ) = $router->validate( $route, query => { limit => 'many' } );
    is( $status, 400, 'a value that its schema refuses is a 400' );
    like( \@errors, [qr/\/limit:[ ]Expected[ ]integer/], 'for that reason' );

    ( $status, @errors ) = $router->validate( $route, query => { limit => 1, junk => 1 } );
    is( $status, 400, 'an undeclared query key is a 400' );
    like( \@errors, [qr/\/junk:/], 'and named' );
    is( [ $router->validate( $route, query => { limit => 1, route => '/x' } ) ], [], 'except a key that tPSGI sets itself' );
    ( $status, @errors ) = $router->validate( $router->match( 'GET', '/loose' ), query => { anything => 1 } );
    is( $status, 400, 'and so is any key of the query, for an operation that declares nothing' );
    like( \@errors, [qr/\/anything:/], 'named too' );
    is( [ $router->validate( $router->match( 'GET', '/loose' ), query => {} ) ], [], 'which takes an empty query' );

    $route = $router->match( 'POST', '/form' );
    my $form_type = 'application/x-www-form-urlencoded';
    is( [ $router->validate( $route, body => { count => '3' }, content_type => $form_type ) ], [], 'a form that its schema takes passes' );
    ( $status, @errors ) = $router->validate( $route, body => { count => 3, junk => 1 }, content_type => $form_type );
    is( $status, 400, 'a form key that additionalProperties refuses is a 400' );
    like( \@errors, [qr/Properties[ ]not[ ]allowed:[ ]junk/], 'for that reason' );
    ( $status, @errors ) = $router->validate( $route, body => { count => 3 }, content_type => 'text/plain' );
    is( $status,                                                                                              415, 'a body of a media type the operation does not take is a 415' );
    is( [ $router->validate( $route, body => { count => 3 }, content_type => "$form_type; charset=UTF-8" ) ], [],  'and parameters of the media type do not count' );
};

subtest 'the names of a body' => sub {
    my $form_type = 'application/x-www-form-urlencoded';
    my $multipart = 'multipart/form-data; boundary=x';

    my ( $status, @errors ) = $router->validate( $router->match( 'GET', '/loose' ), body => { count => 3 }, content_type => $form_type );
    is( $status, 400, 'a field, to an operation with no requestBody, is a 400' );
    like( \@errors, [qr/\/body\/count:[ ]the[ ]operation[ ]takes[ ]no[ ]body/], 'for that reason' );
    ( $status, @errors ) = $router->validate( $router->match( 'GET', '/loose' ), body => {}, uploads => ['file'], content_type => $multipart );
    is( $status, 400, 'and so is a file' );
    like( \@errors, [qr/\/body\/file:/], 'named' );
    is( [ $router->validate( $router->match( 'GET', '/loose' ), body => {}, content_type => $form_type ) ], [], 'but an empty body is not' );

    my $route = $router->match( 'POST', '/upload' );
    is( [ $router->validate( $route, body => { count => 3 }, uploads => ['file'], content_type => $multipart ) ], [], 'a field and a file that the schema names pass' );
    ( $status, @errors ) = $router->validate( $route, body => { count => 3, junk => 1 }, content_type => $multipart );
    is( $status, 400, 'a field that a schema without additionalProperties does not name is a 400' );
    like( \@errors, [qr/\/body\/junk:[ ]the[ ]schema[ ]of[ ]multipart\/form-data/], 'which names the media type' );
    ( $status, @errors ) = $router->validate( $route, body => { count => 3 }, uploads => ['other'], content_type => $multipart );
    is( $status, 400, 'and so is a file that it does not name' );
    like( \@errors, [qr/\/body\/other:/], 'named' );

    ( $status, @errors ) = $router->validate( $route, body => { count => 3, file => 'x' }, content_type => $form_type );
    is( $status, 400, 'the names are those of the media type that was sent, here a $ref' );
    like( \@errors, [qr/\/body\/file:[ ]the[ ]schema[ ]of[ ]\Q$form_type\E/], 'which does not name the file' );
    is( [ $router->validate( $route, body => { count => 3 }, content_type => $form_type ) ], [], 'and does name the count' );

    is( [ $router->validate( $router->match( 'POST', '/open' ), body => { count => 3, junk => 1 }, content_type => $form_type ) ], [], 'a schema with additionalProperties takes what it says it takes' );
};

subtest 'precedence' => sub {
    my @order = map { $_->{template} } grep { index( $_->{template}, '/sitemap/' ) == 0 || index( $_->{template}, '/lib/' ) == 0 } $router->routes();
    is( \@order, [qw{/lib/index /sitemap/static.xml /sitemap/{map}.xml.gz /sitemap/{map}.xml /lib/{module+}}], 'literal routes first, then by segment, then by literal length' );
};

done_testing();