www: fix for running under mount paths

We try to avoid issues like these by using relative URLs
in hrefs, but we can't avoid the problem with Location:
for redirects and Atom feeds which are likely to be
rehosted elsewhere.

We also reorder some of the code to work around a weird
issue on the psgi-plack mailing list:
<20160516073750.GA11931@dcvr.yhbt.net>
(Somewhere on https://groups.google.com/group/psgi-plack
 but it's probably not bookmarkable)

3 files changed, 48 insertions, 23 deletions

diff --git a/lib/PublicInbox/Feed.pm b/lib/PublicInbox/Feed.pm
index 0d3bc81d..52fe0db4 100644
--- a/lib/PublicInbox/Feed.pm
+++ b/lib/PublicInbox/Feed.pm
@@ -61,9 +61,9 @@ sub atom_header {
 
 sub emit_atom {
         my ($cb, $ctx) = @_;
+        my $feed_opts = get_feedopts($ctx);
         my $fh = $cb->([ 200, ['Content-Type' => 'application/atom+xml']]);
         my $max = $ctx->{max} || MAX_PER_PAGE;
-        my $feed_opts = get_feedopts($ctx);
         my $x = atom_header($feed_opts);
         my $git = $ctx->{git} ||= PublicInbox::Git->new($ctx->{git_dir});
         each_recent_blob($ctx, sub {
@@ -95,8 +95,8 @@ sub emit_atom_thread {
         my ($cb, $ctx) = @_;
         my $res = $ctx->{srch}->get_thread($ctx->{mid});
         return _no_thread($cb) unless $res->{total};
-        my $fh = $cb->([200, ['Content-Type' => 'application/atom+xml']]);
         my $feed_opts = get_feedopts($ctx);
+        my $fh = $cb->([200, ['Content-Type' => 'application/atom+xml']]);
 
         my $html_url = $feed_opts->{atomurl} = $ctx->{self_url};
         $html_url =~ s!/t\.atom\z!/!;
@@ -112,10 +112,10 @@ sub emit_atom_thread {
 
 sub emit_html_index {
         my ($res, $ctx) = @_;
+        my $feed_opts = get_feedopts($ctx);
         my $fh = $res->([200,['Content-Type'=>'text/html; charset=UTF-8']]);
 
         my $max = $ctx->{max} || MAX_PER_PAGE;
-        my $feed_opts = get_feedopts($ctx);
 
         my $title = ascii_html($feed_opts->{description} || '');
         my ($footer, $param, $last);
@@ -261,15 +261,15 @@ sub get_feedopts {
         my ($ctx) = @_;
         my $pi_config = $ctx->{pi_config};
         my $inbox = $ctx->{inbox};
+        my $obj = $ctx->{-inbox};
         my $cgi = $ctx->{cgi};
-        my %rv;
-        if (open my $fh, '<', "$ctx->{git_dir}/description") {
-                chomp($rv{description} = <$fh>);
-        } else {
-                $rv{description} = '($GIT_DIR/description missing)';
-        }
+        my %rv = ( description => $obj ? $obj->description : 'FIXME' );
 
-        if ($pi_config && defined $inbox && $inbox ne '') {
+        if ($obj) {
+                $rv{address} = $obj->{address};
+                $rv{id_addr} = $obj->{-primary_address};
+        } elsif ($pi_config && defined $inbox && $inbox ne '') {
+                # TODO: remove
                 my $addr = $pi_config->get($inbox, 'address') || "";
                 $rv{address} = $addr;
                 $addr = $addr->[0] if ref($addr);
@@ -278,19 +278,19 @@ sub get_feedopts {
         $rv{id_addr} ||= 'public-inbox@example.com';
 
         my $url_base;
-        if ($cgi) {
-                $url_base = $cgi->base->as_string . $inbox;
+        if ($obj) {
+                $url_base = $obj->base_url($cgi); # CGI may be undef
                 if (my $mid = $ctx->{mid}) { # per-thread feed:
-                        $rv{atomurl} = "$url_base/$mid/t.atom";
+                        $rv{atomurl} = "$url_base$mid/t.atom";
                 } else {
-                        $rv{atomurl} = "$url_base/new.atom";
+                        $rv{atomurl} = $url_base."new.atom";
                 }
         } else {
-                $url_base = "http://example.com";
-                $rv{atomurl} = "$url_base/new.atom";
+                $url_base = 'http://example.com/';
+                $rv{atomurl} = $url_base.'new.atom';
         }
-        $rv{url} ||= "$url_base/";
-        $rv{midurl} = "$url_base/";
+        $rv{url} ||= $url_base;
+        $rv{midurl} = $url_base;
 
         \%rv;
 }
diff --git a/lib/PublicInbox/Inbox.pm b/lib/PublicInbox/Inbox.pm
index 5d9fdb36..4bcab96f 100644
--- a/lib/PublicInbox/Inbox.pm
+++ b/lib/PublicInbox/Inbox.pm
@@ -64,6 +64,7 @@ sub cloneurl {
         $self->{cloneurl} = \@url;
 }
 
+# TODO: can we remove this?
 sub footer_html {
         my ($self) = @_;
         my $footer = $self->{footer};
@@ -73,4 +74,23 @@ sub footer_html {
         $self->{footer} = $footer;
 }
 
+sub base_url {
+        my ($self, $prq) = @_; # Plack::Request
+        if (defined $prq) {
+                my $url = $prq->base->as_string;
+                $url .= '/' if $url !~ m!/\z!; # for mount in Plack::Builder
+                $url .= $self->{name} . '/';
+        } else {
+                # either called from a non-PSGI environment (e.g. NNTP/POP3)
+                $self->{-base_url} ||= do {
+                        my $url = $self->{url};
+                        # expand protocol-relative URLs to HTTPS if we're
+                        # not inside a web server
+                        $url = "https:$url" if $url =~ m!\A//!;
+                        $url .= '/' if $url !~ m!/\z!;
+                        $url;
+                };
+        }
+}
+
 1;
diff --git a/lib/PublicInbox/WWW.pm b/lib/PublicInbox/WWW.pm
index 94ab032f..95288a7b 100644
--- a/lib/PublicInbox/WWW.pm
+++ b/lib/PublicInbox/WWW.pm
@@ -39,7 +39,7 @@ sub run {
 sub call {
         my ($self, $env) = @_;
         my $cgi = Plack::Request->new($env);
-        my $ctx = { cgi => $cgi, pi_config => $self->{pi_config} };
+        my $ctx = {cgi => $cgi, pi_config => $self->{pi_config}, www => $self};
         my $path_info = $cgi->path_info;
 
         my $method = $cgi->method;
@@ -124,7 +124,7 @@ sub r { [ $_[0], ['Content-Type' => 'text/plain'], [ join(' ', @_, "\n") ] ] }
 
 # returns undef if valid, array ref response if invalid
 sub invalid_inbox {
-        my ($self, $ctx, $inbox, $mid) = @_;
+        my ($self, $ctx, $inbox) = @_;
         my $obj = $ctx->{pi_config}->lookup_name($inbox);
         if (defined $obj) {
                 $ctx->{git_dir} = $obj->{mainrepo};
@@ -144,7 +144,7 @@ sub invalid_inbox {
 # returns undef if valid, array ref response if invalid
 sub invalid_inbox_mid {
         my ($self, $ctx, $inbox, $mid) = @_;
-        my $ret = invalid_inbox($self, $ctx, $inbox, $mid);
+        my $ret = invalid_inbox($self, $ctx, $inbox);
         return $ret if $ret;
 
         $ctx->{mid} = $mid = uri_unescape($mid);
@@ -382,9 +382,14 @@ sub legacy_redirects {
 sub r301 {
         my ($ctx, $inbox, $mid, $suffix) = @_;
         my $cgi = $ctx->{cgi};
-        my $url;
+        my $obj = $ctx->{-inbox};
+        unless ($obj) {
+                my $r404 = invalid_inbox($ctx->{www}, $ctx, $inbox);
+                return $r404 if $r404;
+                $obj = $ctx->{-inbox};
+        }
+        my $url = $obj->base_url($cgi);
         my $qs = $cgi->env->{QUERY_STRING};
-        $url = $cgi->base->as_string . $inbox . '/';
         $url .= (uri_escape_utf8($mid) . '/') if (defined $mid);
         $url .= $suffix if (defined $suffix);
         $url .= "?$qs" if $qs ne '';