Send a redirect only to a path on this site

The dispatcher kept the path of a to, so that a link could not send a
visitor to another site.  A to with no path, such as https://$host or
//$host, has an empty path, and the dispatcher then kept the to as it was.
A to of ////$host has the path //$host, which a browser reads as a host.
So a link to the login page could send whoever followed it, once they had
logged in, to any site at all.

Now a to with no path is the root of this site, and a path starts with one
slash.

Co-Authored-By: Claude Opus 5.5 <noreply@anthropic.com>

lib/TCMS.pm

@@ -211,8 +211,9 @@ sub build_routes {
             # Some routes may just need to do serve()
             $query->{tpsgi} = $tpsgi;
 
-            # Redirecting somewhere naughty not allow
-            $query->{to} = URI->new( $query->{to} // '' )->path() || $query->{to} if $query->{to};
+            # Only ever a path on this site, so that no link can send a visitor to
+            # another one.  One slash, because a browser reads two as a host.
+            $query->{to} = ( URI->new( $query->{to} )->path() || '/' ) =~ s{\A/+}{/}r if $query->{to};
 
             # Now that we have firmed up the actual routing, let's validate.
             return $tpsgi->forbidden($query) if exists $query->{dispatcher}{'x-tcms-auth'} && !$active_user;

t/TCMS.t

@@ -60,7 +60,9 @@ $index->redefine(
 # What a post's route runs, which the routes of posts name.
 require_ok('Trog::Routes::HTML') or BAIL_OUT("Can't load the routes");
 my $html = Test::MockModule->new('Trog::Routes::HTML');
-$html->redefine( posts => sub { return [ 200, [], ['the post'] ] } );
+
+# It answers with where the request would be sent on, when it says.
+$html->redefine( posts => sub ($query) { return [ 200, [], [ exists $query->{to} ? $query->{to} : 'the post' ] ] } );
 
 require_ok('TCMS') or BAIL_OUT("Can't load the dispatcher");
 
@@ -107,6 +109,18 @@ subtest 'the routes of posts' => sub {
     ok( !exists $paths->{'/posts/{curly}'}, 'but a post whose path has a brace is not, since it would be a template' );
 };
 
+subtest 'where a redirect may send you' => sub {
+    my $operation = $paths->{'/posts/p-one'}{get};
+    my $to        = sub ($to) {
+        return $operation->{'x-tpsgi-callback'}->( { log_dir => "$ROOT/logs", verbose => 0 }, { route => '/posts/p-one', dispatcher => $operation, to => $to } )->[2][0];
+    };
+    is( $to->('/config'),              '/config',     'a path on this site is kept' );
+    is( $to->('https://bogus.test/x'), '/x',          'the path of another site is all that is kept of it' );
+    is( $to->('https://bogus.test'),   '/',           'and another site with no path is the root, not the other site' );
+    is( $to->('//bogus.test'),         '/',           'even without a scheme' );
+    is( $to->('////bogus.test'),       '/bogus.test', 'and a path that starts with two slashes, which names a site, starts with one' );
+};
+
 subtest 'the scripts of a route' => sub {
     my $post = $paths->{'/posts/p-one'}{get};
     is_deeply( $post->{'x-tcms-scripts'},                              [qw{highlight.min.js reveal.min.js}], 'a post page has the scripts of one' );