www: fix absolute URLs when mounted under a subdir

While we avoid generating absolute URLs in most cases, our
"git clone" instructions and URL headers in mboxrd files
contain full URLs.

So do the same thing we do for WwwAtomStream and pre-generate
the full URL before Plack::App::URLMap changes $env->{PATH_INFO}
and $env->{SCRIPT_NAME} back to their original values.

Reported-by: edef <edef@edef.eu>
Link: https://public-inbox.org/meta/cover.0f97c47bb88db8b875be7497289d8fedd3b11991.1569296942.git-series.edef@edef.eu/

diff --git a/lib/PublicInbox/Mbox.pm b/lib/PublicInbox/Mbox.pm
index 6d902e6ce25b722d6a79420a8378dc9bd2964129..67b671f5f4a8f31aa3bfca611ae78cc5001c10cf 100644 (file)
--- a/lib/PublicInbox/Mbox.pm
+++ b/lib/PublicInbox/Mbox.pm
@@ -60,10 +60,12 @@ sub getline {
 
 sub close {} # noop
 
+# /$INBOX/$MESSAGE_ID/raw
 sub emit_raw {
        my ($ctx) = @_;
        my $mid = $ctx->{mid};
        my $ibx = $ctx->{-inbox};
+       $ctx->{base_url} = $ibx->base_url($ctx->{env});
        my ($mref, $more, $id, $prev, $next);
        if (my $over = $ibx->over) {
                my $smsg = $over->next_by_mid($mid, \$id, \$prev) or return;
@@ -97,7 +99,7 @@ sub msg_hdr ($$;$) {
                $header_obj->header_set($d);
        }
        my $ibx = $ctx->{-inbox};
-       my $base = $ibx->base_url($ctx->{env});
+       my $base = $ctx->{base_url};
        $mid = $ctx->{mid} unless defined $mid;
        $mid = mid_escape($mid);
        my @append = (
@@ -246,6 +248,7 @@ use PublicInbox::Hval qw/to_filename/;
 sub new {
        my ($class, $ctx, $cb) = @_;
        my $buf = '';
+       $ctx->{base_url} = $ctx->{-inbox}->base_url($ctx->{env});
        bless {
                buf => \$buf,
                gz => IO::Compress::Gzip->new(\$buf, Time => 0),

diff --git a/lib/PublicInbox/WwwStream.pm b/lib/PublicInbox/WwwStream.pm
index 7399b0ad314dce3ed2adae9e059bdd9fb1488381..f5338c39a67486d3569993d182b639c5ec6516bb 100644 (file)
--- a/lib/PublicInbox/WwwStream.pm
+++ b/lib/PublicInbox/WwwStream.pm
@@ -19,7 +19,15 @@ sub close {}
 
 sub new {
        my ($class, $ctx, $cb) = @_;
-       bless { nr => 0, cb => $cb || *close, ctx => $ctx }, $class;
+
+       my $base_url = $ctx->{-inbox}->base_url($ctx->{env});
+       chop $base_url; # no trailing slash for clone
+       bless {
+               nr => 0,
+               cb => $cb || *close,
+               ctx => $ctx,
+               base_url => $base_url,
+       }, $class;
 }
 
 sub response {
@@ -83,8 +91,7 @@ sub _html_end {
        my $desc = ascii_html($ibx->description);
 
        my (%seen, @urls);
-       my $http = $ibx->base_url($ctx->{env});
-       chop $http; # no trailing slash for clone
+       my $http = $self->{base_url};
        my $max = $ibx->max_git_epoch;
        my $dir = (split(m!/!, $http))[-1];
        if (defined($max)) { # v2

diff --git a/t/psgi_mount.t b/t/psgi_mount.t
index 05dbd7365d614c64e0d317dfe1203f4e42f40244..8da2bc8937bc140a72de2c1e92a97b04f5fb6bc6 100644 (file)
--- a/t/psgi_mount.t
+++ b/t/psgi_mount.t
@@ -60,11 +60,24 @@ test_psgi($app, sub {
        unlike($res->content, qr!\b\Qhttp://[^/]+/test/\E!,
                'No URLs which are not mount-aware');
 
-       # redirects
+       $res = $cb->(GET('/a/test/new.html'));
+       like($res->content, qr!git clone --mirror http://[^/]+/a/test\b!,
+               'clone URL in new.html is mount-aware');
+
        $res = $cb->(GET('/a/test/blah%40example.com/'));
        is($res->code, 200, 'OK with URLMap mount');
+       like($res->content, qr!git clone --mirror http://[^/]+/a/test\b!,
+               'clone URL in /$INBOX/$MESSAGE_ID/ is mount-aware');
+
        $res = $cb->(GET('/a/test/blah%40example.com/raw'));
        is($res->code, 200, 'OK with URLMap mount');
+       like($res->content, qr!^List-Archive: <http://[^/]+/a/test/>!m,
+               'List-Archive set in /raw mboxrd');
+       like($res->content,
+               qr!^Archived-At: <http://[^/]+/a/test/blah\@example\.com/>!m,
+               'Archived-At set in /raw mboxrd');
+
+       # redirects
        $res = $cb->(GET('/a/test/m/blah%40example.com.html'));
        is($res->header('Location'),
                'http://localhost/a/test/blah@example.com/',
@@ -72,7 +85,28 @@ test_psgi($app, sub {
 
        $res = $cb->(GET('/test/blah%40example.com/'));
        is($res->code, 404, 'intentional 404 with URLMap mount');
-
 });
 
+SKIP: {
+       my @mods = qw(DBI DBD::SQLite Search::Xapian IO::Uncompress::Gunzip);
+       foreach my $mod (@mods) {
+               eval "require $mod" or skip "$mod not available: $@", 2;
+       }
+       my $ibx = $config->lookup_name('test');
+       PublicInbox::SearchIdx->new($ibx, 1)->index_sync;
+       test_psgi($app, sub {
+               my ($cb) = @_;
+               my $res = $cb->(GET('/a/test/blah@example.com/t.mbox.gz'));
+               my $gz = $res->content;
+               my $raw;
+               IO::Uncompress::Gunzip::gunzip(\$gz => \$raw);
+               like($raw, qr!^List-Archive: <http://[^/]+/a/test/>!m,
+                       'List-Archive set in /t.mbox.gz mboxrd');
+               like($raw,
+                       qr!^Archived-At:\x20
+                               <http://[^/]+/a/test/blah\@example\.com/>!mx,
+                       'Archived-At set in /t.mbox.gz mboxrd');
+       });
+}
+
 done_testing();