Merge pull request #22 from Troglodyne-Internet-Widgets/openapi-routing

Route by an OpenAPI 3 document, rather than a list of regexes

.pod_stopwords

@@ -40,6 +40,7 @@ basename
 bashrc
 Baugh
 BOOL
+booleans
 bugtracker
 cetera
 cgi
@@ -173,11 +174,13 @@ namespace
 nginx
 NIC
 NONINFRINGEMENT
+notallowed
 notfound
 NTP
 OAuth
 ok
 OOM
+OpenAPI
 overcommit
 overcommits
 overcommitted

Changes

@@ -2,3 +2,8 @@ Revision history for TPSGI
 
 0.001 2026-10-23 TEODESIAN
     - Initial Release
+    - Route by an OpenAPI 3 document: a router exports %openapi in place of
+      @routes, and a router that still has @routes dies as it loads.
+      Templates take {name} and a final {name+}, the most concrete template
+      wins, and parameters are validated and coerced by JSON::Validator.
+      A path with a method that it has no route for is a 405, not a 400.

README.md

@@ -12,11 +12,18 @@ A router module, which `routers` in `~/.tpsgi.ini` names:
 
 ```perl
 package My::Routes;
-
-our @routes = (
-    '/hello' => {
-        method    => 'GET',
-        callbacks => { 'text/html' => \&hello },
+use 5.040;
+
+our %openapi = (
+    openapi => '3.0.3',
+    info    => { title => 'My routes', version => '1' },
+    paths   => {
+        '/hello' => {
+            get => {
+                'x-tpsgi-callback' => \&hello,
+                responses          => { 200 => { description => 'A greeting' } },
+            },
+        },
     },
 );
 
@@ -69,9 +76,18 @@ the user.  FATAL logs at the emergency level and then dies with the line.
 
 ## new(%options)
 
-Load the routers and build the routing table.  It dies unless it runs as
-`user`, and `http_user` and `tpsgi_dir` are set.  get\_config() returns the
-options, and among them are:
+Load the routers, and build the TPSGI::Router of their `%openapi` documents.
+It dies unless it runs as `user`, and `http_user` and `tpsgi_dir` are set.
+It also dies when a router does not load, when its document is not one that
+TPSGI::Router accepts, and when a router still defines `@routes` instead of
+`%openapi`.
+
+new() runs for every request, and compiling a document takes much longer than
+answering one.  So the router is built once in each worker, for each list of
+router files, and kept.  A HUP replaces the workers, so a changed router is
+compiled again.
+
+get\_config() returns the options, and among them are:
 
 ```
 custom_log
@@ -86,10 +102,9 @@ auth
 The directory index files, in the order they are tried: the `indices` option,
 then `index.html`, `index.htm` and `index.cgi`.
 
-## routes() = ARRAYREF
+## routes() = TPSGI::Router
 
-The routing table: each route's pattern, then its definition, for every router
-in the order they were loaded.
+The router that new() built from the `%openapi` of every router.
 
 ## serve($fullpath, $path, $start, $streaming, $ranges, $last\_fetch, $deflate)
 
@@ -111,7 +126,7 @@ Redirects to the provided page.
 
 Return a generic HTTP 200 OK
 
-## notfound, forbidden, badrequest, toolong, error, unavailable
+## notfound, forbidden, badrequest, notallowed, unsupported, toolong, error, unavailable
 
 If you need to return these HTTP errors, return these within a route:
 
@@ -153,7 +168,9 @@ ever serves.  A fresh worker tries again from nothing.
 ## respond($env) = PSGI response
 
 Answer one request: from a route when one matches, by running a CGI when the
-file under `www/` is executable, and otherwise by serving the file.
+file under `www/` is executable, and otherwise by serving the file.  A path
+that a route matches, with a method that no route of it has, gets
+notallowed().
 
 ## mangle\_filename($path) = STRING
 
@@ -172,17 +189,19 @@ and it has no extension or one of `cgi`, `sh`, `exe`, `pl`, `php` and `py`.
 
 ## route($route, $env, %request) = PSGI response
 
-Run the callback of $route that answers the request's content type, with the
-query that extract\_query() builds.  respond() calls it, with %request holding
-`fullpath`, `path`, `start`, `last_fetch`, `deflate`, `domain` and
-`port`.
+Run the callback of $route, which TPSGI::Router::match() returned, with the
+query that extract\_query() builds.  In CGI mode, which `x-tpsgi-env` asks
+for, the query is not built, and the callback gets the request as %ENV
+instead.  respond() calls route(), with %request holding `fullpath`, `path`,
+`start`, `last_fetch`, `deflate`, `domain` and `port`.
 
 ## extract\_query($path, $route, $env) = HASHREF
 
 The query a route's callback is given: the query string, then the POST body,
-then the route's captures and its `data`, each over the last.  When the route
-names `parameters`, a parameter that fails its validator, or one it does not
-name, gets a badrequest() instead.
+then the path parameters of $route and the operation's `x-tpsgi-data`, each
+over the last.  First TPSGI::Router::validate() checks the request against the
+operation.  A request that fails gets unsupported() for a 415 and badrequest()
+for a 400, and the reasons go to the log at the debug level.
 
 ## cgi($env, $fullpath, $file\_actual, $last\_fetch) = PSGI response
 
@@ -358,33 +377,109 @@ All the CPAN deps should be updated out-of-band and the service manually restart
 
 # CUSTOM ROUTING
 
-All passed routing modules will be required, and combined to form a routing table so you have an analogue to rewrite rules.
-
-Routing Modules look like so:
+tPSGI requires each router module, and routes requests by the OpenAPI 3
+document that each one exports as `%openapi`.  A router can also export
+`%aliases`, `%watches` and `generic_route()`.
 
 ```perl
-our @routes = (
-    '/foo/(\w+)/save' => {
-        method    => 'GET',
-        callbacks => { # Run these subroutines to execute the appropriate handler given the content-type.  Expects normal PSGI output.
-            'text/html'        => \&render,
-            'application/json' => \&dump,
+package My::Routes;
+use 5.040;
+
+our %openapi = (
+    openapi => '3.0.3',
+    info    => { title => 'My routes', version => '1' },
+    paths   => {
+        '/sitemap/{map}.xml' => {
+            get => {
+                'x-tpsgi-callback' => \&sitemap,
+                'x-myapp-nomap'    => true,
+                parameters         => [
+                    {
+                        name     => 'map',
+                        in       => 'path',
+                        required => true,
+                        schema   => { type => 'integer' },
+                    },
+                ],
+                responses => { 200 => { description => 'One page of the sitemap' } },
+            },
+        },
+        '/lib/{module+}' => {
+            get => {
+                'x-tpsgi-callback' => 'My::Routes::manual',
+                'x-tpsgi-data'     => { section => 'manual' },
+                parameters         => [
+                    {
+                        name     => 'module+',
+                        in       => 'path',
+                        required => true,
+                        schema   => { type => 'string' },
+                    },
+                ],
+                responses => { 200 => { description => 'The manual of a module' } },
+            },
         },
-        noindex   => 0, # Explicitly exclude this in robots.txt
-        nomap     => 0, # Don't put this in the sitemap
-        acls      => ['admin'], # Route requires both authentication by auth handler and the auth'd user to have the provided ACLs.
-        data      => { baz => 'throb' }, # Arbitrary data to inject into the GET/POST data hashref
-        captures  => ['name','parameter'], # Name parameters of the capture groups in the route key.  Suppose we want /foo/don/keys here.
-        static    => 1, # Whether we can save a static render of this
-        invalidates => ['/foo/(\w+)'], # Static renders which are invalidated by this route returning a successful response code.
     },
-    ...
 );
 ```
 
-Note that this is an array, as we want this to preserve order. Fat commas are used to hint that this is in fact a tuple.
+The document is Perl data.  A boolean in it is perl's own `true` or `false`,
+which `use 5.040` imports, or a JSON boolean such as `Cpanel::JSON::XS::true`.
+`\1` is not a boolean, and fails the check against the OpenAPI schema.
+
+new() dies when a document is not valid, so a broken router fails as it loads,
+and not at the first request.  A router that still defines `@routes` and no
+`%openapi` dies the same way.
+
+## Templates
+
+Each key of `paths` is a template.  `{name}` matches any text up to the next
+slash, and one segment can hold several variables and literal text, as in
+`{map}.xml`.  `{name+}` matches the rest of the path, slashes and all, and it
+must be the whole last segment.  Its parameter is named `name+`, and the query
+gives its value as `name`.  Any other character matches only itself.  No
+variable matches a newline.
+
+When more than one template matches, the most concrete one wins.  Literal
+segments win over segments with variables, segments that mix text and
+variables win over a lone `{name}`, and `{name+}` comes last.  Then the
+template with more literal characters wins, and then the one that sorts first.
+[TPSGI::Router](https://metacpan.org/pod/TPSGI%3A%3ARouter) says this in full.
+
+A path that a template matches, with a method that no matching template has,
+gets a 405 with an `Allow` header.  HEAD uses the `get` operation when there
+is no `head` one.
+
+## Operations
+
+The `x-tpsgi-` keys of an operation are tPSGI's:
+
+```perl
+x-tpsgi-callback  The sub that answers the request: a CODE reference, or
+                  the fully qualified name of a sub.  Required.
+x-tpsgi-data      A HASH, which is merged over the query.
+x-tpsgi-env       True for CGI mode: the callback gets the request as a
+                  CGI %ENV, and no query is built.
+```
+
+Any other `x-` key is the application's.  The callback finds the whole
+operation in `$query->{dispatcher}`, and the template that matched in
+`$query->{route_template}`.
+
+## Validation
+
+Before the callback runs, tPSGI checks the request against the operation's
+`parameters` and `requestBody`.  Values are coerced to their schema, so an
+integer arrives as a number.  A request that fails gets a 400, and the reasons
+go to the log at the debug level, not into the page.  The 400 is also the
+answer to a query key that the operation does not declare, when the operation
+declares a query parameter or a request body.  A form body is as strict as the
+`additionalProperties` of its schema.  A body whose media type is not among
+the `content` of the `requestBody` gets a 415.
+
+## Callbacks
 
-Router callbacks are passed the TPSGI object and the raw query, which means you can do:
+A callback is passed the TPSGI object and the query, which means you can do:
 
 ```perl
 sub route {
@@ -393,7 +488,8 @@ sub route {
     $self->ERROR("eeee");
     $self->DEBUG("blah");
 
-    # Either from the GET or POST data, POST is preferred when both are present.
+    # From the query string, the POST body, the path or x-tpsgi-data, in
+    # that order: a later one wins.
     my $param = $query->{param};
 
     my %headers = ...;

lib/TPSGI.pm

@@ -36,6 +36,7 @@ use Log::Dispatch;
 use Log::Dispatch::Screen;
 use Log::Dispatch::FileRotate;
 use TPSGI::Startup;
+use TPSGI::Router;
 
 # We have a DEBUG var which is plus ultra for extra sensitive stuff beyond just passing verbose
 our $debug = $ENV{TPSGI_DEBUG};
@@ -222,9 +223,18 @@ sub FATAL {
 
 =head2 new(%options)
 
-Load the routers and build the routing table.  It dies unless it runs as
-C<user>, and C<http_user> and C<tpsgi_dir> are set.  get_config() returns the
-options, and among them are:
+Load the routers, and build the TPSGI::Router of their C<%openapi> documents.
+It dies unless it runs as C<user>, and C<http_user> and C<tpsgi_dir> are set.
+It also dies when a router does not load, when its document is not one that
+TPSGI::Router accepts, and when a router still defines C<@routes> instead of
+C<%openapi>.
+
+new() runs for every request, and compiling a document takes much longer than
+answering one.  So the router is built once in each worker, for each list of
+router files, and kept.  A HUP replaces the workers, so a changed router is
+compiled again.
+
+get_config() returns the options, and among them are:
 
     custom_log
     verbose
@@ -250,7 +260,7 @@ sub new {
     my $self = bless( \%options, $class );
     $self->{ip} = '0.0.0.0';
 
-    my @routes;
+    my @documents;
     my %aliases;
 
     # XXX TODO make these routes able to be fully qualified namespaces (::)!
@@ -269,15 +279,14 @@ sub new {
         $self->DEBUG("require $options{tpsgi_dir}/$route");
         my $success = eval { require "$options{tpsgi_dir}/$route"; 1; };    ## no critic (RequireBarewordIncludes) -- a router is named by its file
         if ($success) {
-            my ( $pkg_routes, $pkg_aliases, $pkg_watches ) = do {
+            my ( $pkg_openapi, $pkg_routes, $pkg_aliases, $pkg_watches ) = do {
                 no strict 'refs';                                           # the router's own package variables, by name
-                ( \@{"${package}::routes"}, \%{"${package}::aliases"}, \%{"${package}::watches"} );
+                ( \%{"${package}::openapi"}, \@{"${package}::routes"}, \%{"${package}::aliases"}, \%{"${package}::watches"} );
             };
 
-            for ( my $i = 0; $i < @$pkg_routes; $i += 2 ) {
-                $self->DEBUG("Registered route $pkg_routes->[$i]");
-            }
-            push( @routes, @$pkg_routes );
+            die "$route defines \@routes and no %openapi.  tPSGI routes by an OpenAPI 3 document now: see CUSTOM ROUTING in perldoc TPSGI.\n"
+              if @$pkg_routes && !%$pkg_openapi;
+            push( @documents, $route => $pkg_openapi ) if %$pkg_openapi;
 
             foreach my $al ( keys(%$pkg_aliases) ) {
                 $self->DEBUG("aliased route $al to $pkg_aliases->{$al}");
@@ -302,15 +311,17 @@ sub new {
         }
     }
 
-    # Set the pattern used to discover the route if needed later.
-    for ( my $i = 0; $i < scalar(@routes); $i += 2 ) {
-        $routes[ $i + 1 ]{pattern} = $routes[$i];
-    }
+    state %routers;
+    my $router_key = join( "\0", $options{tpsgi_dir}, @{ $self->{routers} } );
+    $self->{router} = $routers{$router_key} //= do {
+        my $router = TPSGI::Router->new(@documents);
+        $self->DEBUG("Registered route \U$_->{method}\E $_->{template}") foreach $router->routes();
+        $router;
+    };
 
     $self->{indices} //= [];
     $self->{indices} = [ @{ $self->{indices} }, qw{index.html index.htm index.cgi} ];
 
-    $self->{routes}    = \@routes;
     $self->{aliases}   = \%aliases;
     $self->{callbacks} = [];
 
@@ -329,16 +340,15 @@ sub indices {
     return $self->{indices};
 }
 
-=head2 routes() = ARRAYREF
+=head2 routes() = TPSGI::Router
 
-The routing table: each route's pattern, then its definition, for every router
-in the order they were loaded.
+The router that new() built from the C<%openapi> of every router.
 
 =cut
 
 sub routes {
     my $self = shift;
-    return $self->{routes};
+    return $self->{router};
 }
 
 =head2 serve($fullpath, $path, $start, $streaming, $ranges, $last_fetch, $deflate)
@@ -570,7 +580,7 @@ sub ok {
     return generic( $body, 200, $query );
 }
 
-=head2 notfound, forbidden, badrequest, toolong, error, unavailable
+=head2 notfound, forbidden, badrequest, notallowed, unsupported, toolong, error, unavailable
 
 If you need to return these HTTP errors, return these within a route:
 
@@ -603,6 +613,21 @@ sub badrequest {
     return generic( $body, 400, $query );
 }
 
+sub notallowed {
+    my ( $self, $query, @allow ) = @_;
+    $self->INFO("$query->{method} 405 $query->{fullpath}");
+    my $res = generic( 'Method Not Allowed', 405, $query );
+    push( @{ $res->[1] }, Allow => join( ', ', @allow ) ) if ref $res eq 'ARRAY';
+    return $res;
+}
+
+sub unsupported {
+    my ( $self, $query, $body ) = @_;
+    $self->INFO("$query->{method} 415 $query->{fullpath}");
+    $body //= 'Unsupported Media Type';
+    return generic( $body, 415, $query );
+}
+
 sub toolong {
     my ( $self, $query, $body ) = @_;
     $self->INFO("$query->{method} 419 $query->{fullpath}");
@@ -701,19 +726,12 @@ sub cannot_start {
 
 my %etags;
 
-# A router's pattern means what the router wrote, so none of this file's
-# default flags apply to it: /aa would make \w ASCII only, /x would drop its
-# spaces, and /s would change what a dot matches.
-my sub match_route {
-    my ( $path, $pattern ) = @_;
-    no re '/aasx';
-    return $path =~ m/^$pattern$/;    ## no critic (RequireDefault RequireExtendedFormatting RequireDotMatchAnything)
-}
-
 =head2 respond($env) = PSGI response
 
 Answer one request: from a route when one matches, by running a CGI when the
-file under F<www/> is executable, and otherwise by serving the file.
+file under F<www/> is executable, and otherwise by serving the file.  A path
+that a route matches, with a method that no route of it has, gets
+notallowed().
 
 =cut
 
@@ -804,24 +822,8 @@ sub respond {
 
     my $streaming = $env->{'psgi.streaming'};
 
-    # If we have an actual route, just use it.
-    my $r           = $self->routes;
-    my $route_index = List::Util::first { ( $r->[$_] // '' ) eq $path } 0 .. scalar(@$r);
-
-    my $route_actual;
-    $route_actual = $r->[ $route_index + 1 ] if defined($route_index);
-
-    # Might be a regexed route. Sort reversed so we try the longest routes first.
-    if ( !$route_actual && @$r ) {
-        my $matched = List::Util::first {
-
-            # Here's where you want to use Regexp::Debugger in the context of call.pl to debug routes... EX:
-            # perl ./call.pl GET /path/to/route
-            match_route( $path, $r->[$_] );
-        }
-        0 .. scalar(@$r) - 1;
-        $route_actual = $r->[ $matched + 1 ] if defined($matched);
-    }
+    my $route_actual = $self->routes->match( $method, $path );
+    return $self->notallowed( $cur_query, @{ $route_actual->{allow} } ) if $route_actual && $route_actual->{status};
 
     if ($route_actual) {
         return $self->route(
@@ -924,10 +926,11 @@ sub appears_executable {
 
 =head2 route($route, $env, %request) = PSGI response
 
-Run the callback of $route that answers the request's content type, with the
-query that extract_query() builds.  respond() calls it, with %request holding
-C<fullpath>, C<path>, C<start>, C<last_fetch>, C<deflate>, C<domain> and
-C<port>.
+Run the callback of $route, which TPSGI::Router::match() returned, with the
+query that extract_query() builds.  In CGI mode, which C<x-tpsgi-env> asks
+for, the query is not built, and the callback gets the request as %ENV
+instead.  respond() calls route(), with %request holding C<fullpath>, C<path>,
+C<start>, C<last_fetch>, C<deflate>, C<domain> and C<port>.
 
 =cut
 
@@ -935,29 +938,18 @@ sub route {
     my ( $self, $route, $env, %request ) = @_;
     my ( $fullpath, $path, $start ) = @request{qw{fullpath path start}};
 
-    $self->DEBUG( 'Executing route ' . $route->{pattern} );
-
-    $route->{method} = $env->{REQUEST_METHOD} if $route->{method} eq '*';
-    my $content_type = $env->{CONTENT_TYPE} || 'text/html';    # If not set, that's the assumption.
-    return $self->badrequest($cur_query) unless List::Util::any { $_ eq $env->{REQUEST_METHOD} } grep { defined $_ } ( 'HEAD', $route->{method} );
-
-    my $callback;
-    if ( exists $route->{callbacks}{'*'} ) {
-        $callback = $route->{callbacks}{'*'};
-    }
-    else {
-        return $self->badrequest($cur_query) unless exists $route->{callbacks}{$content_type};
-        $callback = $route->{callbacks}{$content_type};
-    }
+    $self->DEBUG("Executing route \U$route->{method}\E $route->{template}");
 
+    my $operation = $route->{operation};
+    my $cgi_mode  = $operation->{'x-tpsgi-env'};
     my $streaming = $env->{'psgi.streaming'};
 
     # Build the query data for passing to a route.
-    # GET, POST, URI captures, then explicit data overrides.
+    # GET, POST, path parameters, then explicit data overrides.
     my $query = {};
 
     # If we're running in CGI mode, leave everything as-is.
-    $query = $self->extract_query( $path, $route, $env ) unless $route->{env};
+    $query = $self->extract_query( $path, $route, $env ) unless $cgi_mode;
 
     # We failed validation if $query isn't a hashref.
     return $query if ref $query eq 'ARRAY';
@@ -971,37 +963,37 @@ sub route {
     $query->{start}  = $start;
 
     # Put things to tv_interval in here for Server-Timing
-    $query->{fullpath}   = $fullpath;
-    $query->{method}     = $route->{method};
-    $query->{route}      = $path;
-    $query->{cookies}    = $env->{HTTP_COOKIE};
-    $query->{dnt}        = $env->{HTTP_DNT};
-    $query->{nosellinfo} = $env->{HTTP_SEC_GPC};
-    $query->{port}       = $request{port};
-    $query->{scheme}     = $env->{'psgi.url_scheme'} // 'http';
-    $query->{method}     = $env->{REQUEST_METHOD};
-    $query->{lang}       = $env->{HTTP_ACCEPT_LANGUAGE};
-    $query->{accept}     = $env->{HTTP_ACCEPT};
-    $query->{has_query}  = !!$env->{QUERY_STRING};
-    $query->{domain}     = $request{domain};
-    $query->{dispatcher} = $route;
-    $query->{ip}         = $cur_query->{ip};
-    $query->{ua}         = $cur_query->{ua};
-    $query->{referer}    = $cur_query->{referer};
+    $query->{fullpath}       = $fullpath;
+    $query->{route}          = $path;
+    $query->{route_template} = $route->{template};
+    $query->{cookies}        = $env->{HTTP_COOKIE};
+    $query->{dnt}            = $env->{HTTP_DNT};
+    $query->{nosellinfo}     = $env->{HTTP_SEC_GPC};
+    $query->{port}           = $request{port};
+    $query->{scheme}         = $env->{'psgi.url_scheme'} // 'http';
+    $query->{method}         = $env->{REQUEST_METHOD};
+    $query->{lang}           = $env->{HTTP_ACCEPT_LANGUAGE};
+    $query->{accept}         = $env->{HTTP_ACCEPT};
+    $query->{has_query}      = !!$env->{QUERY_STRING};
+    $query->{domain}         = $request{domain};
+    $query->{dispatcher}     = $operation;
+    $query->{ip}             = $cur_query->{ip};
+    $query->{ua}             = $cur_query->{ua};
+    $query->{referer}        = $cur_query->{referer};
 
     # This allows for better error handlers if we die in the route.
     $cur_query = $query;
 
     # Setup the CGI vars they expect IF requested
-    local %ENV = ( %ENV, CGI::Emulate::PSGI->emulate_environment($env) ) if $route->{env};
+    local %ENV = ( %ENV, CGI::Emulate::PSGI->emulate_environment($env) ) if $cgi_mode;
 
     # Emulate mod_unique_id
-    local $ENV{UNIQUE_ID} = UUID::uuid() if $route->{env};
+    local $ENV{UNIQUE_ID} = UUID::uuid() if $cgi_mode;
 
     # Run any watch callbacks, and make this a truly 'dynamic' application if requested.
     $self->handle_changes();
 
-    my $output = $callback->( $self, $query );
+    my $output = $route->{callback}->( $self, $query );
 
     # If it's streaming, just hand it off.
     # It's up to the caller to handle things like running post-close callbacks in this event.
@@ -1026,19 +1018,21 @@ sub route {
 =head2 extract_query($path, $route, $env) = HASHREF
 
 The query a route's callback is given: the query string, then the POST body,
-then the route's captures and its C<data>, each over the last.  When the route
-names C<parameters>, a parameter that fails its validator, or one it does not
-name, gets a badrequest() instead.
+then the path parameters of $route and the operation's C<x-tpsgi-data>, each
+over the last.  First TPSGI::Router::validate() checks the request against the
+operation.  A request that fails gets unsupported() for a 415 and badrequest()
+for a 400, and the reasons go to the log at the debug level.
 
 =cut
 
 sub extract_query {
     my ( $self, $path, $route, $env ) = @_;
 
-    my $query;
+    my $query = {};
     $query = URL::Encode::url_params_mixed( $env->{QUERY_STRING} ) if $env->{QUERY_STRING};
 
-    #Actually parse the POSTDATA and dump it into the QUERY object if this is a POST
+    #Actually parse the POSTDATA if this is a POST
+    my ( $form, $uploads );
     if ( $env->{REQUEST_METHOD} eq 'POST' ) {
 
         my $body = HTTP::Body->new( $env->{CONTENT_TYPE}, $env->{CONTENT_LENGTH} );
@@ -1046,45 +1040,33 @@ sub extract_query {
             $body->add($buf);
         }
 
-        @$query{ keys( %{ $body->param } ) }  = values( %{ $body->param } );
-        @$query{ keys( %{ $body->upload } ) } = values( %{ $body->upload } );
+        # A POST with no body has nothing for a requestBody schema to judge.
+        $form    = { %{ $body->param } } if $env->{CONTENT_TYPE} || $env->{CONTENT_LENGTH};
+        $uploads = $body->upload;
     }
 
-    if ( ref $route->{captures} eq 'ARRAY' ) {
-        my @captures = match_route( $path, $route->{pattern} );
-        @$query{ @{ $route->{captures} } } = @captures;
-    }
+    my ( $status, @errors ) = $self->routes->validate(
+        $route,
+        query        => $query,
+        body         => $form,
+        content_type => $env->{CONTENT_TYPE},
+        env          => $env,
+    );
+    if ($status) {
+        $self->DEBUG("Rejected $path: $_") foreach @errors;
 
-    if ( ref $route->{data} eq 'HASH' ) {
-        @$query{ keys( %{ $route->{data} } ) } = values( %{ $route->{data} } );
+        # What respond() knows of the request, which the log line and the
+        # error page need.  The query has neither the method nor the path.
+        my $request = { method => $env->{REQUEST_METHOD}, fullpath => $path, %$cur_query };
+        return $status == 415 ? $self->unsupported($request) : $self->badrequest($request);
     }
 
-    # Now that we've parsed the query and know where we want to go,
-    # we should (optionally) murder everything the route does not explicitly want, and validate what it does
-    my $parameters = $route->{parameters};
-    if ( ref $parameters eq 'HASH' && %$parameters ) {
-        my @known_params = keys(%$parameters);
-        for my $param (@known_params) {
-            die "Invalid route definition for $path: parameter $param must correspond to a validation CODEREF." unless ref $parameters->{$param} eq 'CODE';
+    @$query{ keys(%$form) }                = values(%$form)    if $form;
+    @$query{ keys(%$uploads) }             = values(%$uploads) if $uploads;
+    @$query{ keys( %{ $route->{path} } ) } = values( %{ $route->{path} } );
 
-            # A missing parameter is not necessarily a problem.
-            next unless $query->{$param};
-
-            # But if we have it, and it's bad, nack it, so that scanners get fail2banned.
-            $self->DEBUG("Rejected $path for bad query param $param");
-            return $self->badrequest($query) unless $parameters->{$param}->( $query->{$param} );
-        }
-
-        # Without this logging will break.
-        push( @known_params, qw{tpsgi ip ua user referer route dispatcher} );
-
-        # Smack down passing of unnecessary fields; this catches bugs
-        foreach my $field ( keys(%$query) ) {
-            next if List::Util::any { $field eq $_ } @known_params;
-            $self->WARN("Unexpected parameter $field passed");
-            return $self->badrequest($query);
-        }
-    }
+    my $data = $route->{operation}{'x-tpsgi-data'};
+    @$query{ keys(%$data) } = values(%$data) if ref $data eq 'HASH';
 
     return $query;
 }
@@ -1676,11 +1658,18 @@ __END__
 A router module, which C<routers> in F<~/.tpsgi.ini> names:
 
     package My::Routes;
-
-    our @routes = (
-        '/hello' => {
-            method    => 'GET',
-            callbacks => { 'text/html' => \&hello },
+    use 5.040;
+
+    our %openapi = (
+        openapi => '3.0.3',
+        info    => { title => 'My routes', version => '1' },
+        paths   => {
+            '/hello' => {
+                get => {
+                    'x-tpsgi-callback' => \&hello,
+                    responses          => { 200 => { description => 'A greeting' } },
+                },
+            },
         },
     );
 
@@ -1731,31 +1720,105 @@ All the CPAN deps should be updated out-of-band and the service manually restart
 
 =head1 CUSTOM ROUTING
 
-All passed routing modules will be required, and combined to form a routing table so you have an analogue to rewrite rules.
-
-Routing Modules look like so:
+tPSGI requires each router module, and routes requests by the OpenAPI 3
+document that each one exports as C<%openapi>.  A router can also export
+C<%aliases>, C<%watches> and C<generic_route()>.
 
-    our @routes = (
-        '/foo/(\w+)/save' => {
-            method    => 'GET',
-            callbacks => { # Run these subroutines to execute the appropriate handler given the content-type.  Expects normal PSGI output.
-                'text/html'        => \&render,
-                'application/json' => \&dump,
+    package My::Routes;
+    use 5.040;
+
+    our %openapi = (
+        openapi => '3.0.3',
+        info    => { title => 'My routes', version => '1' },
+        paths   => {
+            '/sitemap/{map}.xml' => {
+                get => {
+                    'x-tpsgi-callback' => \&sitemap,
+                    'x-myapp-nomap'    => true,
+                    parameters         => [
+                        {
+                            name     => 'map',
+                            in       => 'path',
+                            required => true,
+                            schema   => { type => 'integer' },
+                        },
+                    ],
+                    responses => { 200 => { description => 'One page of the sitemap' } },
+                },
+            },
+            '/lib/{module+}' => {
+                get => {
+                    'x-tpsgi-callback' => 'My::Routes::manual',
+                    'x-tpsgi-data'     => { section => 'manual' },
+                    parameters         => [
+                        {
+                            name     => 'module+',
+                            in       => 'path',
+                            required => true,
+                            schema   => { type => 'string' },
+                        },
+                    ],
+                    responses => { 200 => { description => 'The manual of a module' } },
+                },
             },
-            noindex   => 0, # Explicitly exclude this in robots.txt
-            nomap     => 0, # Don't put this in the sitemap
-            acls      => ['admin'], # Route requires both authentication by auth handler and the auth'd user to have the provided ACLs.
-            data      => { baz => 'throb' }, # Arbitrary data to inject into the GET/POST data hashref
-            captures  => ['name','parameter'], # Name parameters of the capture groups in the route key.  Suppose we want /foo/don/keys here.
-            static    => 1, # Whether we can save a static render of this
-            invalidates => ['/foo/(\w+)'], # Static renders which are invalidated by this route returning a successful response code.
         },
-        ...
     );
 
-Note that this is an array, as we want this to preserve order. Fat commas are used to hint that this is in fact a tuple.
+The document is Perl data.  A boolean in it is perl's own C<true> or C<false>,
+which C<use 5.040> imports, or a JSON boolean such as C<Cpanel::JSON::XS::true>.
+C<\1> is not a boolean, and fails the check against the OpenAPI schema.
+
+new() dies when a document is not valid, so a broken router fails as it loads,
+and not at the first request.  A router that still defines C<@routes> and no
+C<%openapi> dies the same way.
+
+=head2 Templates
+
+Each key of C<paths> is a template.  C<{name}> matches any text up to the next
+slash, and one segment can hold several variables and literal text, as in
+C<{map}.xml>.  C<{name+}> matches the rest of the path, slashes and all, and it
+must be the whole last segment.  Its parameter is named C<name+>, and the query
+gives its value as C<name>.  Any other character matches only itself.  No
+variable matches a newline.
+
+When more than one template matches, the most concrete one wins.  Literal
+segments win over segments with variables, segments that mix text and
+variables win over a lone C<{name}>, and C<{name+}> comes last.  Then the
+template with more literal characters wins, and then the one that sorts first.
+L<TPSGI::Router> says this in full.
+
+A path that a template matches, with a method that no matching template has,
+gets a 405 with an C<Allow> header.  HEAD uses the C<get> operation when there
+is no C<head> one.
+
+=head2 Operations
+
+The C<x-tpsgi-> keys of an operation are tPSGI's:
+
+    x-tpsgi-callback  The sub that answers the request: a CODE reference, or
+                      the fully qualified name of a sub.  Required.
+    x-tpsgi-data      A HASH, which is merged over the query.
+    x-tpsgi-env       True for CGI mode: the callback gets the request as a
+                      CGI %ENV, and no query is built.
+
+Any other C<x-> key is the application's.  The callback finds the whole
+operation in C<< $query->{dispatcher} >>, and the template that matched in
+C<< $query->{route_template} >>.
+
+=head2 Validation
+
+Before the callback runs, tPSGI checks the request against the operation's
+C<parameters> and C<requestBody>.  Values are coerced to their schema, so an
+integer arrives as a number.  A request that fails gets a 400, and the reasons
+go to the log at the debug level, not into the page.  The 400 is also the
+answer to a query key that the operation does not declare, when the operation
+declares a query parameter or a request body.  A form body is as strict as the
+C<additionalProperties> of its schema.  A body whose media type is not among
+the C<content> of the C<requestBody> gets a 415.
+
+=head2 Callbacks
 
-Router callbacks are passed the TPSGI object and the raw query, which means you can do:
+A callback is passed the TPSGI object and the query, which means you can do:
 
     sub route {
         my ($self, $query) = @_;
@@ -1763,7 +1826,8 @@ Router callbacks are passed the TPSGI object and the raw query, which means you
         $self->ERROR("eeee");
         $self->DEBUG("blah");
 
-        # Either from the GET or POST data, POST is preferred when both are present.
+        # From the query string, the POST body, the path or x-tpsgi-data, in
+        # that order: a later one wins.
         my $param = $query->{param};
 
         my %headers = ...;

lib/TPSGI/Router.pm

@@ -0,0 +1,467 @@
+package TPSGI::Router;
+
+# ABSTRACT: Match requests to the operations of OpenAPI 3 documents, and validate them
+
+use 5.040;
+use warnings FATAL => 'all';
+use re '/aasx';
+
+use List::Util ();
+use JSON::Validator::Schema::OpenAPIv3;
+use JSON::Validator::Util ();
+use Cpanel::JSON::XS      ();
+
+=head1 SYNOPSIS
+
+    my $router = TPSGI::Router->new( 'lib/My/Routes.pm' => \%My::Routes::openapi );
+
+    sub answer {
+        my ( $tpsgi, $method, $path, %query ) = @_;
+
+        my $request = { method => $method, fullpath => $path };
+        my $route   = $router->match( $method, $path );
+        return $tpsgi->notfound($request) unless $route;
+        return $tpsgi->notallowed( $request, @{ $route->{allow} } ) if $route->{status};
+
+        my ( $status, @errors ) = $router->validate( $route, query => \%query );
+        return $tpsgi->badrequest($request) if $status;
+        return $route->{callback}->( $tpsgi, { %query, %{ $route->{path} } } );
+    }
+
+=head1 DESCRIPTION
+
+TPSGI::Router compiles the C<%openapi> document of each router once.  Then it
+answers which operation a request is for, and whether the request is valid for
+that operation.
+
+Each key of C<paths> is a template.  A template is a list of segments, which
+slashes separate.  A segment is made of literal text and variables:
+
+=over
+
+=item C<{name}> is any text up to the next slash.  One segment can hold several
+variables and literal text, for example C<{map}.xml>.
+
+=item C<{name+}> is the rest of the path, slashes and all.  It must be the whole
+last segment, as in C</lib/{module+}>.  Declare its parameter with the name
+C<name+>.  The query gives its value to the callback as C<name>.
+
+=back
+
+A literal character matches only itself, so the C<.> of C</humans.txt> matches
+only a dot.  No variable matches a newline.
+
+When more than one template matches a path, the most concrete one wins.  The
+segments are compared in order.  A literal segment comes first, then a segment
+of literal text and variables, then a lone C<{name}>, then a C<{name+}>.  If
+that does not decide, the template with more literal characters wins, and then
+the template that sorts first as a string.  So the order never depends on the
+order of a hash.
+
+=cut
+
+my @methods = qw{get put post delete options head patch trace};
+
+# The keys of the query that tPSGI sets itself.  The query string can hold
+# them without a 400, because route() replaces them anyway.
+my @reserved = qw{tpsgi ip ua user referer route dispatcher};
+
+# How concrete a segment is.  A lower rank wins.
+my %rank = (
+    literal => 0,
+    mixed   => 1,
+    single  => 2,
+    rest    => 3,
+);
+
+=head1 METHODS
+
+=head2 new(@pairs) = TPSGI::Router
+
+Compile the documents.  @pairs is a list of names and documents, for example
+the file of each router and its C<%openapi>.  The name goes into each error.
+
+new() dies with the reason when a document is not valid OpenAPI 3, when an
+operation has no C<x-tpsgi-callback>, or when its callback is a name that is
+not a defined sub.  It also dies on two templates that differ only in the names
+of their variables, and on one template and method in two documents.
+
+=cut
+
+sub new {
+    my ( $class, @pairs ) = @_;
+
+    my $self = bless( { by_template => {}, shapes => {}, exact => {} }, $class );
+    while ( my ( $name, $document ) = splice( @pairs, 0, 2 ) ) {
+        $self->add_document( $name, $document );
+    }
+
+    my @templated = grep { !$_->{literal} } values( %{ $self->{by_template} } );
+    $self->{templated} = [ sort { by_precedence( $a, $b ) } @templated ];
+    $self->{exact}{ $_->{template} } = $_ for grep { $_->{literal} } values( %{ $self->{by_template} } );
+
+    return $self;
+}
+
+=head2 json_booleans($data) = copy
+
+A copy of $data in which each of perl's own booleans, such as the C<true> that
+C<use 5.040> gives a router, is a Cpanel::JSON::XS boolean.  JSON::Validator
+5.19 compares C<enum> values by a checksum, so a native true does not equal
+the true of the OpenAPI schema, and C<required =E<gt> true> fails.  Hashes and
+arrays are copied.  Every other reference is kept, so a callback stays the
+same sub.
+
+=cut
+
+sub json_booleans {
+    my ($data) = @_;
+    no warnings qw{experimental::builtin};
+
+    # Each job is the place a copy goes, and what to copy there.
+    my $copy;
+    my @todo = ( [ \$copy, $data ] );
+    while ( my $job = shift @todo ) {
+        my ( $slot, $value ) = @$job;
+        if ( ref $value eq 'HASH' ) {
+            $$slot = {};
+            push( @todo, map { [ \$$slot->{$_}, $value->{$_} ] } keys(%$value) );
+        }
+        elsif ( ref $value eq 'ARRAY' ) {
+            $$slot = [];
+            push( @todo, map { [ \$$slot->[$_], $value->[$_] ] } 0 .. $#$value );
+        }
+        elsif ( !ref $value && builtin::is_bool($value) ) {
+            $$slot = $value ? Cpanel::JSON::XS::true : Cpanel::JSON::XS::false;
+        }
+        else {
+            $$slot = $value;
+        }
+    }
+    return $copy;
+}
+
+=head2 add_document($name, $document)
+
+Check $document as OpenAPI 3, and add each of its operations.  new() calls it
+for each pair.
+
+=cut
+
+sub add_document {
+    my ( $self, $name, $document ) = @_;
+
+    die "$name: the router's %openapi is not a HASH reference\n" unless ref $document eq 'HASH';
+
+    my $schema = JSON::Validator::Schema::OpenAPIv3->new( json_booleans($document) );
+    my @errors = @{ $schema->errors };
+    die "$name: %openapi is not a valid OpenAPI 3 document:\n" . join( "\n", map { "  $_" } @errors ) . "\n" if @errors;
+
+    my $paths = $schema->get( ['paths'] ) // {};
+    foreach my $template ( sort keys(%$paths) ) {
+        my $matcher = $self->matcher_for( $name, $template );
+        foreach my $method ( grep { exists $paths->{$template}{$_} } @methods ) {
+            die "$name: \U$method\E $template is also a route of $matcher->{methods}{$method}{router}\n" if $matcher->{methods}{$method};
+
+            my $operation = $paths->{$template}{$method};
+            $matcher->{methods}{$method} = {
+                router    => $name,
+                template  => $template,
+                method    => $method,
+                operation => $operation,
+                schema    => $schema,
+                callback  => resolve_callback( "$name: \U$method\E $template", $operation->{'x-tpsgi-callback'} ),
+                %{ $self->rules_for( $schema, $method, $template ) },
+            };
+        }
+    }
+    return;
+}
+
+=head2 matcher_for($name, $template) = HASHREF
+
+The compiled form of $template, made the first time it is asked for.  It dies
+when $template is not a template, and when another template differs from it
+only in the names of its variables.
+
+=cut
+
+sub matcher_for {
+    my ( $self, $name, $template ) = @_;
+
+    return $self->{by_template}{$template} if $self->{by_template}{$template};
+
+    my $matcher = compile_template($template);
+    my $twin    = $self->{shapes}{ $matcher->{shape} };
+    die "$name: $template and $twin match the same paths, and differ only in the names of their variables\n" if $twin;
+    $self->{shapes}{ $matcher->{shape} } = $template;
+
+    return $self->{by_template}{$template} = $matcher;
+}
+
+=head2 compile_template($template) = HASHREF
+
+A function.  The compiled form of $template: its regular expression, the names of
+its variables, the rank of each segment, its count of literal characters, and
+its shape, which is the template with every variable name left out.  It dies
+when the template does not start with a slash, when a brace is not part of a
+variable, and when a C<{name+}> is not the whole last segment.
+
+=cut
+
+sub compile_template {
+    my ($template) = @_;
+
+    die "The template $template does not start with a slash\n" unless index( $template, '/' ) == 0;
+
+    my @segments = split( m{/}, substr( $template, 1 ), -1 );
+    my ( @regex, @ranks, @variables );
+    my $literal_length = 0;
+    my $shape          = '';
+
+    foreach my $i ( 0 .. $#segments ) {
+        my $segment = $segments[$i];
+        my @parts   = $segment =~ m/ ( \{ [^{}]* \} | [^{}]+ ) /g;
+        die "The template $template has a brace that is not part of a {variable}\n" unless join( '', @parts ) eq $segment;
+
+        my ( $regex, $variables ) = ( '', 0 );
+        foreach my $part (@parts) {
+            my ($variable) = $part =~ m/ \A \{ ( [^{}]+ ) \} \z /;
+            if ( !defined $variable ) {
+                $regex .= quotemeta($part);
+                $shape .= $part;
+                $literal_length += length($part);
+                next;
+            }
+            $variables++;
+            my $is_rest = $variable =~ s/ [+] \z //;
+            die "The template $template has an empty {variable}\n"                        if $variable eq '';
+            die "In the template $template, {$variable+} is not the whole last segment\n" if $is_rest && ( @parts > 1 || $i < $#segments );
+
+            # \N, so that no variable takes a newline that a %0A decoded to.
+            $regex .= $is_rest ? '(\N+)' : '([^/\n]+?)';
+            $shape .= $is_rest ? '{+}'   : '{}';
+            push( @variables, $variable );
+        }
+        $shape .= '/' if $i < $#segments;
+
+        my $kind = !$variables ? 'literal' : @parts > 1 ? 'mixed' : $regex eq '(\N+)' ? 'rest' : 'single';
+        push( @ranks, $rank{$kind} );
+        push( @regex, $regex );
+    }
+
+    my $source = '\A/' . join( '/', @regex ) . '\z';
+    return {
+        template       => $template,
+        regex          => qr/$source/,
+        variables      => \@variables,
+        ranks          => \@ranks,
+        literal_length => $literal_length,
+        literal        => !@variables,
+        shape          => "/$shape",
+        methods        => {},
+    };
+}
+
+=head2 by_precedence($a, $b) = INTEGER
+
+A function, for sort.  Below zero when the compiled template $a is tried
+before $b, as DESCRIPTION says.
+
+=cut
+
+sub by_precedence {
+    my ( $left, $right ) = @_;
+
+    my @l = @{ $left->{ranks} };
+    my @r = @{ $right->{ranks} };
+    foreach my $i ( 0 .. List::Util::min( $#l, $#r ) ) {
+        return $l[$i] <=> $r[$i] if $l[$i] != $r[$i];
+    }
+    return @l <=> @r || $right->{literal_length} <=> $left->{literal_length} || $left->{template} cmp $right->{template};
+}
+
+=head2 resolve_callback($what, $callback) = CODE
+
+A function.  $callback when it is a CODE reference, and the sub that it names
+when it is a fully qualified name.  It dies, and names $what, when there is no
+callback or no such sub.
+
+=cut
+
+sub resolve_callback {
+    my ( $what, $callback ) = @_;
+
+    die "$what has no x-tpsgi-callback\n" unless defined $callback;
+    return $callback                                                                  if ref $callback eq 'CODE';
+    die "$what: x-tpsgi-callback is neither a CODE reference nor the name of a sub\n" if ref $callback;
+
+    my $code = do {
+        no strict 'refs';    # a sub that the router names
+        defined &{$callback} ? \&{$callback} : undef;
+    };
+    die "$what: x-tpsgi-callback names $callback, which is not a defined sub\n" unless $code;
+    return $code;
+}
+
+=head2 rules_for($schema, $method, $template) = HASHREF
+
+What validate() checks of one operation beyond its schema: the names of its
+query parameters, whether an undeclared key in the query is a 400, and the
+media types of its request body.
+
+=cut
+
+sub rules_for {
+    my ( $self, $schema, $method, $template ) = @_;
+
+    my @parameters = @{ $schema->parameters_for_request( [ $method, $template ] ) };
+    my %declared   = map  { $_->{name} => 1 } grep { $_->{in} eq 'query' } @parameters;
+    my ($body)     = grep { $_->{in} eq 'body' } @parameters;
+
+    return {
+        query_names => \%declared,
+        strict      => ( %declared || $body ) ? 1                                            : 0,
+        body_types  => $body                  ? [ sort keys( %{ $body->{content} // {} } ) ] : undef,
+    };
+}
+
+=head2 match($method, $path) = HASHREF
+
+The route of a request, or undef when no template matches $path.
+
+The route holds C<template>, C<method>, C<operation>, C<callback>, C<schema>
+and C<path>, which maps each variable to its value.  The names in C<path> have
+no C<+>.
+
+When a template matches and none of the matching templates has an operation
+for $method, the HASH holds C<status>, which is 405, and C<allow>, the methods
+that they do have.  A HEAD request falls back to C<get>.
+
+=cut
+
+sub match {
+    my ( $self, $method, $path ) = @_;
+
+    $method = lc($method);
+    my @tried;
+    foreach my $matcher ( grep { defined } $self->{exact}{$path}, @{ $self->{templated} } ) {
+        my @values = $matcher->{literal} ? () : $path =~ $matcher->{regex};
+        next unless $matcher->{literal} || @values;
+        push( @tried, $matcher );
+
+        my $route = $matcher->{methods}{$method};
+        $route //= $matcher->{methods}{get} if $method eq 'head';
+        next unless $route;
+
+        my %values;
+        @values{ @{ $matcher->{variables} } } = @values;
+        return { %$route, path => \%values };
+    }
+    return unless @tried;
+
+    my %allow = map {
+        map { uc($_) => 1 }
+          keys( %{ $_->{methods} } )
+    } @tried;
+    $allow{HEAD} = 1 if $allow{GET};
+    return { status => 405, allow => [ sort keys(%allow) ] };
+}
+
+=head2 validate($route, %request) = LIST
+
+Check a request against the operation of the $route that match() returned.
+%request holds C<query> and C<body>, each a HASH reference, C<content_type>,
+and C<env>, the PSGI environment, from which the headers and cookies come.
+
+It returns an empty list when the request is valid.  Otherwise it returns a
+status and the reasons.  The status is 415 when the operation has a request
+body and the media type of the request is not among its C<content>.  It is 400
+when a parameter or the body does not match its schema, and when the query
+holds a key that the operation does not declare.  The last rule holds only for
+an operation that declares a query parameter or a request body.
+
+The values of C<path>, C<query> and C<body> are coerced in place, so a parameter
+of type integer arrives as a number.
+
+=cut
+
+sub validate {
+    my ( $self, $route, %request ) = @_;
+
+    my $query = $request{query} // {};
+    my $body  = $request{body};
+    my $env   = $request{env} // {};
+
+    if ( $route->{body_types} && defined $body ) {
+        my $type = $request{content_type} // '';
+        return ( 415, "/body: '$type' is not one of @{ $route->{body_types} }" ) unless JSON::Validator::Util::negotiate_content_type( $route->{body_types}, $type );
+    }
+
+    if ( $route->{strict} ) {
+        my %known      = ( %{ $route->{query_names} }, map { $_ => 1 } @reserved );
+        my @undeclared = grep { !$known{$_} } sort keys(%$query);
+        return ( 400, map { "/$_: the operation does not declare this parameter" } @undeclared ) if @undeclared;
+    }
+
+    my %cookies = map { split( m/=/, $_, 2 ) } split( m/ ; [ ]* /, $env->{HTTP_COOKIE} // '' );
+    my %headers = map {
+        my $name = lc( substr( $_, 5 ) );
+        $name =~ tr/_/-/;
+        ( $name => $env->{$_} )
+    } grep { index( $_, 'HTTP_' ) == 0 } keys(%$env);
+
+    my @seen;
+    my $getter = sub {
+        my ( $values, $fold ) = @_;
+        return sub {
+            my ($name) = @_;
+            my $key    = $fold->($name);
+            my $value  = { exists => exists $values->{$key}, value => $values->{$key} };
+            push( @seen, [ $values, $key, $value ] );
+            return $value;
+        };
+    };
+    my $as_is = sub { return $_[0] };
+
+    my @errors = $route->{schema}->validate_request(
+        [ $route->{method}, $route->{template} ],
+        {
+            path   => $getter->( $route->{path}, sub { my $name = shift; $name =~ s/ [+] \z //; return $name } ),
+            query  => $getter->( $query,         $as_is ),
+            header => $getter->( \%headers,      sub { return lc( $_[0] ) } ),
+            cookie => $getter->( \%cookies,      $as_is ),
+            body   => sub {
+                return { exists => defined $body, value => $body, content_type => $request{content_type} };
+            },
+        }
+    );
+
+    # validate_request() coerces its copy of each value, not the caller's.
+    foreach my $seen (@seen) {
+        my ( $values, $key, $value ) = @$seen;
+        $values->{$key} = $value->{value} if $value->{exists};
+    }
+
+    return unless @errors;
+    return ( 400, map { "$_" } @errors );
+}
+
+=head2 routes() = LIST
+
+Each route as a HASH reference with C<template> and C<method>, in the order
+match() tries them, for a caller that lists them.
+
+=cut
+
+sub routes {
+    my ($self) = @_;
+    my @matchers = ( map { $self->{exact}{$_} } sort keys( %{ $self->{exact} } ) );
+    push( @matchers, @{ $self->{templated} } );
+    return map {
+        my $matcher = $_;
+        map { $matcher->{methods}{$_} } grep { $matcher->{methods}{$_} } @methods
+    } @matchers;
+}
+
+1;

t/TPSGI-Router.t

@@ -0,0 +1,202 @@
+#!/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' }, 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' } },
+                            },
+                        },
+                    },
+                },
+            ),
+        },
+        '/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' );
+    is( [ $router->validate( $router->match( 'GET', '/loose' ), query => { anything => 1 } ) ],                [], 'and an operation that declares nothing takes anything' );
+
+    $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 '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();

t/TPSGI.t

@@ -141,20 +141,83 @@ subtest 'serve_ranges' => sub {
     close($fh) or die "Cannot close: $!";
 };
 
-# A router's pattern is matched as the router wrote it, whatever flags this
-# distribution's own regexes carry.
+# Writes a router module into $dir, and returns its name relative to $dir.
+sub write_router {
+    my ( $package, $body ) = @_;
+    Mojo::File->new("$dir/$package.pm")->spew("package $package;\nuse 5.040;\n$body\n1;\n");
+    return "$package.pm";
+}
+
+my %new_options = (
+    %options,
+    user      => scalar getpwuid($>),
+    http_user => scalar getgrgid( ( getpwuid($>) )[3] ),
+    tpsgi_dir => $dir,
+);
+
+subtest 'new' => sub {
+    my $stale = write_router( 'StaleRouter', q{our @routes = ( '/x' => { method => 'GET', callbacks => { '*' => sub { } } } );} );
+    like(
+        dies { TPSGI->new( %new_options, routers => [$stale] ) },
+        qr/StaleRouter[.]pm[ ]defines[ ]\@routes[ ]and[ ]no/,
+        'a router that still has @routes dies as it loads'
+    );
+
+    my $router = write_router( 'GoodRouter', <<~'ROUTER' );
+        our %openapi = (
+            openapi => '3.0.3',
+            info    => { title => 'good', version => '1' },
+            paths   => {
+                '/post/{slug}' => {
+                    get => {
+                        'x-tpsgi-callback' => sub { },
+                        'x-tpsgi-data'     => { from => 'data' },
+                        parameters         => [
+                            { name => 'slug',  in => 'path',  required => true, schema => { type => 'string' } },
+                            { name => 'limit', in => 'query', schema   => { type => 'integer' } },
+                        ],
+                        responses => { 200 => { description => 'ok' } },
+                    },
+                },
+            },
+        );
+        ROUTER
+    my $first = TPSGI->new( %new_options, routers => [$router] );
+    is( $first->routes->match( 'GET', '/post/hello' )->{template}, '/post/{slug}', 'a router with %openapi routes' );
+    ref_is( TPSGI->new( %new_options, routers => [$router] )->routes, $first->routes, 'and the next request in the worker reuses the router' );
+};
+
 subtest 'extract_query' => sub {
-    my $tpsgi = bless( { %options, ip => '0.0.0.0' }, 'TPSGI' );
+    my $tpsgi = TPSGI->new( %new_options, routers => ['GoodRouter.pm'] );
     my $env   = { REQUEST_METHOD => 'GET' };
+    my $cafe  = "caf\N{LATIN SMALL LETTER E WITH ACUTE}";
+
+    my $query = $tpsgi->extract_query( "/post/$cafe", $tpsgi->routes->match( 'GET', "/post/$cafe" ), $env );
+    is( $query->{slug}, $cafe,  'a path parameter, outside ASCII too, is in the query' );
+    is( $query->{from}, 'data', 'and so is x-tpsgi-data' );
+
+    $query = $tpsgi->extract_query( '/post/x', $tpsgi->routes->match( 'GET', '/post/x' ), { %$env, QUERY_STRING => 'limit=5' } );
+    is( $query->{limit}, 5,   'the query string is in the query' );
+    is( $query->{slug},  'x', 'beside the path parameter' );
 
-    my $query = $tpsgi->extract_query( "/post/caf\N{LATIN SMALL LETTER E WITH ACUTE}", { pattern => '/post/(\w+)', captures => ['slug'] }, $env );
-    is( $query->{slug}, "caf\N{LATIN SMALL LETTER E WITH ACUTE}", 'a \\w in a route matches a letter outside ASCII' );
+    local @Test::Logger::Capture::lines;
+    my $res = $tpsgi->extract_query( '/post/x', $tpsgi->routes->match( 'GET', '/post/x' ), { %$env, QUERY_STRING => 'limit=many' } );
+    is( ref $res,  'ARRAY', 'a query that fails validation is an answer, not a query' );
+    is( $res->[0], 400,     'a 400' );
+    unlike( $res->[2][0], qr/integer/, 'which does not say why' );
+
+    $res = $tpsgi->extract_query( '/post/x', $tpsgi->routes->match( 'GET', '/post/x' ), { %$env, QUERY_STRING => 'junk=1' } );
+    is( $res->[0], 400, 'and so is one with a key that the operation does not declare' );
 
-    $query = $tpsgi->extract_query( '/a b/c', { pattern => '/a b/(\w+)', captures => ['name'] }, $env );
-    is( $query->{name}, 'c', 'and a space in a route is a space' );
+    $res = $tpsgi->extract_query( '/post/x', $tpsgi->routes->match( 'GET', '/post/x' ), { %$env, QUERY_STRING => 'slug=y' } );
+    is( $res->[0], 400, 'even when the path declares it' );
+};
 
-    $query = $tpsgi->extract_query( "/note/x\ny", { pattern => '/note/(.+)', captures => ['text'] }, $env );
-    is( $query->{text}, undef, 'and a dot does not match a newline' );
+subtest 'respond, with a method that the path does not have' => sub {
+    my $tpsgi = TPSGI->new( %new_options, routers => ['GoodRouter.pm'] );
+    my $res   = $tpsgi->respond( { REQUEST_METHOD => 'POST', PATH_INFO => '/post/x', REQUEST_URI => '/post/x', HTTP_HOST => 'test.test' } );
+    is( $res->[0],                   405,         'is a 405' );
+    is( { @{ $res->[1] } }->{Allow}, 'GET, HEAD', 'which names the methods it has' );
 };
 
 done_testing();