File Coverage

blib/lib/PAGI/App/Router.pm

Criterion	Covered	Total	%
statement	356	389	91.5
branch	117	134	87.3
condition	60	87	68.9
subroutine	31	35	88.5
pod	11	20	55.0
total	575	665	86.4

package PAGI::App::Router;
$PAGI::App::Router::VERSION = '0.002001';
use strict;
use warnings;
use Future::AsyncAwait;
use Scalar::Util qw(blessed);
use Carp qw(croak);
use PAGI::Utils ();

=encoding UTF-8

=head1 NAME

PAGI::App::Router - Unified routing for HTTP, WebSocket, and SSE

=head1 SYNOPSIS

    use PAGI::App::Router;

    my $router = PAGI::App::Router->new;

    # HTTP routes (method + path)
    $router->get('/users/:id' => $get_user);
    $router->post('/users' => $create_user);
    $router->delete('/users/:id' => $delete_user);

    # Routes with middleware
    $router->get('/admin' => [$auth_mw, $log_mw] => $admin_handler);
    $router->post('/api/data' => [$rate_limit] => $data_handler);

    # WebSocket routes (path only)
    $router->websocket('/ws/chat/:room' => $chat_handler);

    # SSE routes (path only)
    $router->sse('/events/:channel' => $events_handler);

    # Mount with middleware (applies to all sub-routes)
    $router->mount('/api' => [$auth_mw] => $api_router);

    # Mount from a package (auto-require + to_app)
    $router->mount('/admin' => 'MyApp::Admin');

    # Static files as fallback
    $router->mount('/' => $static_files);

    # Named routes for URL generation
    $router->get('/users/:id' => $get_user)->name('users.get');
    $router->post('/users' => $create_user)->name('users.create');

    my $url = $router->uri_for('users.get', { id => 42 });
    # Returns: "/users/42"

    # Namespace mounted routers
    $router->mount('/api/v1' => $api_router)->as('api');
    $router->uri_for('api.users.get', { id => 42 });
    # Returns: "/api/v1/users/42"

    # Match any HTTP method
    $router->any('/health' => $health_handler);
    $router->any('/resource' => $handler, method => ['GET', 'POST']);

    # Path constraints (inline)
    $router->get('/users/{id:\d+}' => $get_user);

    # Path constraints (chained)
    $router->get('/posts/:slug' => $get_post)
        ->constraints(slug => qr/^[a-z0-9-]+$/);

    # Route grouping (flattened into parent)
    $router->group('/api' => [$auth_mw] => sub {
        my ($r) = @_;
        $r->get('/users' => $list_users);
        $r->post('/users' => $create_user);
    });

    # Include routes from another router
    $router->group('/api/v2' => $v2_router);

    # Include routes from a package
    $router->group('/api/users' => 'MyApp::Routes::Users');

    my $app = $router->to_app;  # Handles all scope types

=cut

sub new {
    my ($class, %args) = @_;

    return bless {
        routes           => [],
        websocket_routes => [],
        sse_routes       => [],
        mounts           => [],
        not_found        => $args{not_found},
        _group_stack     => [],   # for group() prefix/middleware accumulation
        _named_routes    => {},   # name => route info
        _last_route      => undef, # for ->name() chaining
        _last_mount      => undef, # for ->as() chaining
    }, $class;
}

sub mount {
    my ($self, $prefix, @rest) = @_;
    $prefix =~ s{/$}{};  # strip trailing slash
    my ($middleware, $app_or_router) = $self->_parse_route_args(@rest);

    my $sub_router;
    if (blessed($app_or_router) && $app_or_router->isa('PAGI::App::Router')) {
        $sub_router = $app_or_router;  # Keep reference for ->as()
    }
    my $app = PAGI::Utils::to_app($app_or_router);

    my $mount = {
        prefix      => $prefix,
        app         => $app,
        middleware  => $middleware,
        sub_router  => $sub_router,  # Keep reference for ->as()
    };
    push @{$self->{mounts}}, $mount;
    $self->{_last_mount} = $mount;
    $self->{_last_route} = undef;  # Clear route tracking

    return $self;
}

sub get     { my ($self, $path, @rest) = @_; $self->route('GET', $path, @rest) }
sub post    { my ($self, $path, @rest) = @_; $self->route('POST', $path, @rest) }
sub put     { my ($self, $path, @rest) = @_; $self->route('PUT', $path, @rest) }
sub patch   { my ($self, $path, @rest) = @_; $self->route('PATCH', $path, @rest) }
sub delete  { my ($self, $path, @rest) = @_; $self->route('DELETE', $path, @rest) }
sub head    { my ($self, $path, @rest) = @_; $self->route('HEAD', $path, @rest) }
sub options { my ($self, $path, @rest) = @_; $self->route('OPTIONS', $path, @rest) }

sub any {
    my ($self, $path, @rest) = @_;

    # Parse optional trailing key-value args (method => [...])
    my %opts;
    if (@rest >= 2 && !ref($rest[-2]) && $rest[-2] eq 'method') {
        %opts = splice(@rest, -2);
    }

    my $method = $opts{method} // '*';
    if (ref($method) eq 'ARRAY') {
        $method = [map { uc($_) } @$method];
    }

    $self->route($method, $path, @rest);
}

sub group {
    my ($self, $prefix, @rest) = @_;
    $prefix =~ s{/$}{}; # strip trailing slash

    my ($middleware, $target) = $self->_parse_route_args(@rest);

    my %names_before = map { $_ => 1 } keys %{$self->{_named_routes}};

    if (ref($target) eq 'CODE') {
        push @{$self->{_group_stack}}, {
            prefix     => $prefix,
            middleware => [@$middleware],
        };
        $target->($self);
        pop @{$self->{_group_stack}};
    }
    elsif (blessed($target) && $target->isa('PAGI::App::Router')) {
        push @{$self->{_group_stack}}, {
            prefix     => $prefix,
            middleware => [@$middleware],
        };
        $self->_include_router($target);
        pop @{$self->{_group_stack}};
    }
    elsif (!ref($target)) {
        # String form: auto-require and call ->router
        my $pkg = $target;
        {
            local $@;
            eval "require $pkg; 1" or croak "Failed to load '$pkg': $@";
        }
        croak "'$pkg' does not have a router() method" unless $pkg->can('router');
        my $router_obj = $pkg->router;
        croak "'${pkg}->router()' must return a PAGI::App::Router, got "
            . (ref($router_obj) || 'scalar')
            unless blessed($router_obj) && $router_obj->isa('PAGI::App::Router');

        push @{$self->{_group_stack}}, {
            prefix     => $prefix,
            middleware => [@$middleware],
        };
        $self->_include_router($router_obj);
        pop @{$self->{_group_stack}};
    }
    else {
        croak "group() target must be a coderef, PAGI::App::Router, or package name, got "
            . (ref($target) || 'scalar');
    }

    my @new_names = grep { !$names_before{$_} } keys %{$self->{_named_routes}};
    $self->{_last_group_names} = @new_names ? \@new_names : undef;

    $self->{_last_route} = undef;
    $self->{_last_mount} = undef;

    return $self;
}

sub websocket {
    my ($self, $path, @rest) = @_;
    my ($middleware, $app) = $self->_parse_route_args(@rest);
    $app = PAGI::Utils::to_app($app);

    # Apply accumulated group context (reverse: innermost prefix first)
    for my $ctx (reverse @{$self->{_group_stack}}) {
        $path = $ctx->{prefix} . $path;
        unshift @$middleware, @{$ctx->{middleware}};
    }

    my ($regex, $names, $constraints) = $self->_compile_path($path);
    my $route = {
        path        => $path,
        regex       => $regex,
        names       => $names,
        constraints => $constraints,
        app         => $app,
        middleware  => $middleware,
    };
    push @{$self->{websocket_routes}}, $route;
    $self->{_last_route} = $route;
    $self->{_last_mount} = undef;

    return $self;
}

sub sse {
    my ($self, $path, @rest) = @_;
    my ($middleware, $app) = $self->_parse_route_args(@rest);
    $app = PAGI::Utils::to_app($app);

    # Apply accumulated group context (reverse: innermost prefix first)
    for my $ctx (reverse @{$self->{_group_stack}}) {
        $path = $ctx->{prefix} . $path;
        unshift @$middleware, @{$ctx->{middleware}};
    }

    my ($regex, $names, $constraints) = $self->_compile_path($path);
    my $route = {
        path        => $path,
        regex       => $regex,
        names       => $names,
        constraints => $constraints,
        app         => $app,
        middleware  => $middleware,
    };
    push @{$self->{sse_routes}}, $route;
    $self->{_last_route} = $route;
    $self->{_last_mount} = undef;

    return $self;
}

sub route {
    my ($self, $method, $path, @rest) = @_;

    my ($middleware, $app) = $self->_parse_route_args(@rest);
    $app = PAGI::Utils::to_app($app);

    # Apply accumulated group context (reverse: innermost prefix first)
    for my $ctx (reverse @{$self->{_group_stack}}) {
        $path = $ctx->{prefix} . $path;
        unshift @$middleware, @{$ctx->{middleware}};
    }

    my ($regex, $names, $constraints) = $self->_compile_path($path);
    my $route = {
        method      => ref($method) eq 'ARRAY' ? $method : ($method eq '*' ? '*' : uc($method)),
        path        => $path,
        regex       => $regex,
        names       => $names,
        constraints => $constraints,
        app         => $app,
        middleware  => $middleware,
    };
    push @{$self->{routes}}, $route;
    $self->{_last_route} = $route;
    $self->{_last_mount} = undef;  # Clear mount tracking

    return $self;
}

sub _compile_path {
    my ($self, $path) = @_;

    my @names;
    my @constraints;
    my $regex = '';

    # Tokenize the path
    my $remaining = $path;
    while (length $remaining) {
        # {name:pattern} — constrained parameter
        if ($remaining =~ s/^\{(\w+):([^}]+)\}//) {
            push @names, $1;
            push @constraints, [$1, $2];
            $regex .= "([^/]+)";
        }
        # {name} — unconstrained parameter (same as :name)
        elsif ($remaining =~ s/^\{(\w+)\}//) {
            push @names, $1;
            $regex .= "([^/]+)";
        }
        # *name — wildcard/splat
        elsif ($remaining =~ s/^\*(\w+)//) {
            push @names, $1;
            $regex .= "(.+)";
        }
        # :name — named parameter (legacy syntax)
        elsif ($remaining =~ s/^:(\w+)//) {
            push @names, $1;
            $regex .= "([^/]+)";
        }
        # Literal text up to next special token
        elsif ($remaining =~ s/^([^{:*]+)//) {
            $regex .= quotemeta($1);
        }
        # Safety: consume one character to avoid infinite loop
        else {
            $regex .= quotemeta(substr($remaining, 0, 1, ''));
        }
    }

    return (qr{^$regex$}, \@names, \@constraints);
}

sub _check_constraints {
    my ($self, $route, $params) = @_;
    for my $constraints_list ($route->{constraints} // [], $route->{_user_constraints} // []) {
        for my $c (@$constraints_list) {
            my ($name, $pattern) = @$c;
            my $value = $params->{$name} // return 0;
            return 0 unless $value =~ m/^(?:$pattern)$/;
        }
    }
    return 1;
}

# ============================================================
# Named Routes
# ============================================================

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

    croak "name() called without a preceding route" unless $self->{_last_route};
    croak "Route name required" unless defined $name && length $name;
    croak "Named route '$name' already exists" if exists $self->{_named_routes}{$name};

    my $route = $self->{_last_route};
    $route->{name} = $name;
    $self->{_named_routes}{$name} = {
        path   => $route->{path},
        names  => $route->{names},
        prefix => '',
    };

    return $self;
}

sub constraints {
    my ($self, %new_constraints) = @_;

    croak "constraints() called without a preceding route" unless $self->{_last_route};

    my $route = $self->{_last_route};
    my $user_constraints = $route->{_user_constraints} //= [];

    for my $name (keys %new_constraints) {
        my $pattern = $new_constraints{$name};
        croak "Constraint for '$name' must be a Regexp (qr//), got " . ref($pattern)
            unless ref($pattern) eq 'Regexp';
        push @$user_constraints, [$name, $pattern];
    }

    return $self;
}

sub as {
    my ($self, $namespace) = @_;

    croak "Namespace required" unless defined $namespace && length $namespace;

    # Handle group namespacing
    if ($self->{_last_group_names} && @{$self->{_last_group_names}}) {
        for my $name (@{$self->{_last_group_names}}) {
            my $info = delete $self->{_named_routes}{$name};
            my $full_name = "$namespace.$name";
            croak "Named route '$full_name' already exists"
                if exists $self->{_named_routes}{$full_name};
            $self->{_named_routes}{$full_name} = $info;
        }
        $self->{_last_group_names} = undef;
        return $self;
    }

    # Handle mount namespacing
    croak "as() called without a preceding mount or group"
        unless $self->{_last_mount};

    my $mount = $self->{_last_mount};
    my $sub_router = $mount->{sub_router};

    croak "as() requires mounting a router object, not an app coderef"
        unless $sub_router;

    # Import all named routes from sub-router with namespace prefix
    my $prefix = $mount->{prefix};
    for my $name (keys %{$sub_router->{_named_routes}}) {
        my $info = $sub_router->{_named_routes}{$name};
        my $full_name = "$namespace.$name";
        $self->{_named_routes}{$full_name} = {
            path   => $info->{path},
            names  => $info->{names},
            prefix => $prefix . ($info->{prefix} // ''),
        };
    }

    return $self;
}

sub named_routes {
    my ($self) = @_;
    return { %{$self->{_named_routes}} };
}

sub uri_for {
    my ($self, $name, $path_params, $query_params) = @_;

    $path_params  //= {};
    $query_params //= {};

    my $info = $self->{_named_routes}{$name}
        or croak "Unknown route name: '$name'";

    my $path = $info->{path};
    my $prefix = $info->{prefix} // '';

    # Substitute path parameters
    for my $param_name (@{$info->{names}}) {
        unless (exists $path_params->{$param_name}) {
            croak "Missing required path parameter '$param_name' for route '$name'";
        }
        my $value = $path_params->{$param_name};
        $path =~ s/:$param_name\b/$value/
            || $path =~ s/\{$param_name(?::[^}]*)?\}/$value/
            || $path =~ s/\*$param_name\b/$value/;
    }

    # Prepend mount prefix
    $path = $prefix . $path if $prefix;

    # Add query string if any
    if (%$query_params) {
        my @pairs;
        for my $key (sort keys %$query_params) {
            my $value = $query_params->{$key};
            # Simple URL encoding
            $key   =~ s/([^A-Za-z0-9\-_.~])/sprintf("%%%02X", ord($1))/ge;
            $value =~ s/([^A-Za-z0-9\-_.~])/sprintf("%%%02X", ord($1))/ge;
            push @pairs, "$key=$value";
        }
        $path .= '?' . join('&', @pairs);
    }

    return $path;
}

sub _include_router {
    my ($self, $source) = @_;

    # Re-register HTTP routes through route() (stack applies prefix/middleware)
    # Re-registered apps are already compiled coderefs; to_app is identity on coderefs
    for my $route (@{$source->{routes}}) {
        $self->route(
            $route->{method},
            $route->{path},
            [@{$route->{middleware}}],
            $route->{app},
        );
        if ($route->{name}) {
            $self->name($route->{name});
        }
        if ($route->{_user_constraints} && @{$route->{_user_constraints}}) {
            my %uc = map { $_->[0] => $_->[1] } @{$route->{_user_constraints}};
            $self->constraints(%uc);
        }
    }

    # Re-register WebSocket routes
    for my $route (@{$source->{websocket_routes}}) {
        $self->websocket(
            $route->{path},
            [@{$route->{middleware}}],
            $route->{app},
        );
        if ($route->{name}) {
            $self->name($route->{name});
        }
        if ($route->{_user_constraints} && @{$route->{_user_constraints}}) {
            my %uc = map { $_->[0] => $_->[1] } @{$route->{_user_constraints}};
            $self->constraints(%uc);
        }
    }

    # Re-register SSE routes
    for my $route (@{$source->{sse_routes}}) {
        $self->sse(
            $route->{path},
            [@{$route->{middleware}}],
            $route->{app},
        );
        if ($route->{name}) {
            $self->name($route->{name});
        }
        if ($route->{_user_constraints} && @{$route->{_user_constraints}}) {
            my %uc = map { $_->[0] => $_->[1] } @{$route->{_user_constraints}};
            $self->constraints(%uc);
        }
    }
}

sub _parse_route_args {
    my ($self, @args) = @_;

    if (@args == 2 && ref($args[0]) eq 'ARRAY') {
        # (\@middleware, $app)
        my ($middleware, $app) = @args;
        $self->_validate_middleware($middleware);
        return ($middleware, $app);
    }
    elsif (@args == 1) {
        # ($app) - no middleware
        return ([], $args[0]);
    }
    else {
        croak 'Invalid route arguments: expected ($app) or (\@middleware => $app)';
    }
}

sub _validate_middleware {
    my ($self, $middleware) = @_;

    for my $mw (@$middleware) {
        if (ref($mw) eq 'CODE') {
            next;
        }
        elsif (blessed($mw) && $mw->can('wrap')) {
            next;
        }
        else {
            my $type = ref($mw) || 'scalar';
            croak "Invalid middleware: expected coderef factory or object with ->wrap method, got $type";
        }
    }
}

sub _build_middleware_chain {
    my ($self, $middlewares, $app) = @_;

    return $app unless $middlewares && @$middlewares;

    my $chain = $app;
    for my $mw (reverse @$middlewares) {
        $chain = ref($mw) eq 'CODE' ? $mw->($chain) : $mw->wrap($chain);
    }
    return $chain;
}

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

    my @routes           = @{$self->{routes}};
    my @websocket_routes = @{$self->{websocket_routes}};
    my @sse_routes       = @{$self->{sse_routes}};
    my @mounts           = @{$self->{mounts}};
    my $not_found        = $self->{not_found};

    # Pre-build middleware chains for efficiency
    for my $route (@routes, @websocket_routes, @sse_routes) {
        $route->{_handler} = $self->_build_middleware_chain($route->{middleware}, $route->{app});
    }
    for my $m (@mounts) {
        $m->{_handler} = $self->_build_middleware_chain($m->{middleware}, $m->{app});
    }

    # Helper to check mounts
    my $check_mounts = async sub {
        my ($scope, $receive, $send, $path) = @_;
        for my $m (sort { length($b->{prefix}) <=> length($a->{prefix}) } @mounts) {
            my $prefix = $m->{prefix};
            if ($path eq $prefix || $path =~ m{^\Q$prefix\E(/.*)$}) {
                my $sub_path = $1 // '/';
                my $new_scope = {
                    %$scope,
                    path      => $sub_path,
                    root_path => ($scope->{root_path} // '') . $prefix,
                };
                await $m->{_handler}->($new_scope, $receive, $send);
                return 1;  # Matched
            }
        }
        return 0;  # No match
    };

    # Emit an unmatched-route response using the event family that matches the
    # scope. HTTP uses plain http.response.*; SSE and WebSocket scopes only
    # accept their namespaced decline events (sse.http.response.* /
    # websocket.http.response.*) before a stream/handshake starts — a plain
    # http.response.* on those scopes raises on a conforming server. A custom
    # not_found app, if configured, takes over for every scope type.
    my $send_not_found = async sub {
        my ($scope, $receive, $send) = @_;
        if ($not_found) {
            await $not_found->($scope, $receive, $send);
            return;
        }
        my $type   = $scope->{type} // 'http';
        my $prefix = $type eq 'http' ? 'http.response' : "$type.http.response";
        await $send->({
            type    => "$prefix.start",
            status  => 404,
            headers => [['content-type', 'text/plain']],
        });
        await $send->({ type => "$prefix.body", body => 'Not Found', more => 0 });
    };

    return async sub {
        my ($scope, $receive, $send) = @_;
        my $type   = $scope->{type} // 'http';
        my $method = uc($scope->{method} // '');
        my $path   = $scope->{path} // '/';

        # Ignore lifespan events
        return if $type eq 'lifespan';

        # WebSocket routes (path-only matching) - check before mounts
        if ($type eq 'websocket') {
            for my $route (@websocket_routes) {
                if (my @captures = ($path =~ $route->{regex})) {
                    my %params;
                    for my $i (0 .. $#{$route->{names}}) {
                        $params{$route->{names}[$i]} = $captures[$i];
                    }

                    # Check constraints — skip route if any fail
                    next unless $self->_check_constraints($route, \%params);

                    my $new_scope = {
                        %$scope,
                        path_params => \%params,
                        'pagi.router' => { route => $route->{path} },
                    };
                    await $route->{_handler}->($new_scope, $receive, $send);
                    return;
                }
            }
            # No websocket route matched - try mounts as fallback
            if (await $check_mounts->($scope, $receive, $send, $path)) {
                return;
            }
            # No mount matched either - 404
            await $send_not_found->($scope, $receive, $send);
            return;
        }

        # SSE routes (path-only matching) - check before mounts
        if ($type eq 'sse') {
            for my $route (@sse_routes) {
                if (my @captures = ($path =~ $route->{regex})) {
                    my %params;
                    for my $i (0 .. $#{$route->{names}}) {
                        $params{$route->{names}[$i]} = $captures[$i];
                    }

                    # Check constraints — skip route if any fail
                    next unless $self->_check_constraints($route, \%params);

                    my $new_scope = {
                        %$scope,
                        path_params => \%params,
                        'pagi.router' => { route => $route->{path} },
                    };
                    await $route->{_handler}->($new_scope, $receive, $send);
                    return;
                }
            }
            # No SSE route matched - try mounts as fallback
            if (await $check_mounts->($scope, $receive, $send, $path)) {
                return;
            }
            # No mount matched either - 404
            await $send_not_found->($scope, $receive, $send);
            return;
        }

        # HTTP routes (method + path matching) - check routes first
        # HEAD should match GET routes
        my $match_method = $method eq 'HEAD' ? 'GET' : $method;

        my @method_matches;

        for my $route (@routes) {
            if (my @captures = ($path =~ $route->{regex})) {

                # Build params FIRST (needed for constraint checking)
                my %params;
                for my $i (0 .. $#{$route->{names}}) {
                    $params{$route->{names}[$i]} = $captures[$i];
                }

                # Check constraints — skip route if any fail
                next unless $self->_check_constraints($route, \%params);

                # Check method
                my $route_method = $route->{method};
                my $method_match = ref($route_method) eq 'ARRAY'
                    ? (grep { $_ eq $match_method || $_ eq $method } @$route_method)
                    : ($route_method eq '*' || $route_method eq $match_method || $route_method eq $method);

                if ($method_match) {
                    my $new_scope = {
                        %$scope,
                        path_params => \%params,
                        'pagi.router' => { route => $route->{path} },
                    };

                    return await $route->{_handler}->($new_scope, $receive, $send);
                }

                if (ref($route->{method}) eq 'ARRAY') {
                    push @method_matches, @{$route->{method}};
                } elsif ($route->{method} ne '*') {
                    push @method_matches, $route->{method};
                }
            }
        }

        # Path matched but method didn't - 405
        if (@method_matches) {
            my $allowed = join ', ', sort keys %{{ map { $_ => 1 } @method_matches }};
            await $send->({
                type => 'http.response.start',
                status => 405,
                headers => [
                    ['content-type', 'text/plain'],
                    ['allow', $allowed],
                ],
            });
            await $send->({ type => 'http.response.body', body => 'Method Not Allowed', more => 0 });
            return;
        }

        # No HTTP route matched - try mounts as fallback
        if (await $check_mounts->($scope, $receive, $send, $path)) {
            return;
        }

        # No mount matched either - 404
        await $send_not_found->($scope, $receive, $send);
    };
}

1;

__END__