]> Sergey Matveev's repositories - public-inbox.git/blob - lib/PublicInbox/NewsWWW.pm
thread: avoid Perl5 internal scratchpad target cache
[public-inbox.git] / lib / PublicInbox / NewsWWW.pm
1 # Copyright (C) 2016-2021 all contributors <meta@public-inbox.org>
2 # License: AGPL-3.0+ <https://www.gnu.org/licenses/agpl-3.0.txt>
3 #
4 # Plack app redirector for mapping /$NEWSGROUP requests to
5 # the appropriate /$INBOX in PublicInbox::WWW because some
6 # auto-linkifiers cannot handle nntp:// redirects properly.
7 # This is also used directly by PublicInbox::WWW
8 package PublicInbox::NewsWWW;
9 use strict;
10 use warnings;
11 use PublicInbox::Config;
12 use PublicInbox::MID qw(mid_escape);
13 use PublicInbox::Hval qw(prurl);
14
15 sub new {
16         my ($class, $pi_cfg) = @_;
17         bless { pi_cfg => $pi_cfg // PublicInbox::Config->new }, $class;
18 }
19
20 sub redirect ($$) {
21         my ($code, $url) = @_;
22         [ $code,
23           [ Location => $url, 'Content-Type' => 'text/plain' ],
24           [ "Redirecting to $url\n" ] ]
25 }
26
27 sub try_inbox {
28         my ($ibx, $arg) = @_;
29         return if scalar(@$arg) > 1;
30
31         # do not pass $env since HTTP_HOST may differ
32         my $url = $ibx->base_url or return;
33
34         my ($mid) = @$arg;
35         eval { $ibx->mm->num_for($mid) } or return;
36
37         # 302 since the same message may show up on
38         # multiple inboxes and inboxes can be added/reordered
39         $arg->[1] = redirect(302, $url .= mid_escape($mid) . '/');
40 }
41
42 sub call {
43         my ($self, $env) = @_;
44
45         # some links may have the article number in them:
46         # /inbox.foo.bar/123456
47         my (undef, @parts) = split(m!/!, $env->{PATH_INFO});
48         @parts or return
49                 [ 404, [qw(Content-Type text/plain)], ["404 Not Found\n"] ];
50         my ($ng, $article) = @parts;
51         my $pi_cfg = $self->{pi_cfg};
52         if (my $ibx = $pi_cfg->lookup_newsgroup($ng)) {
53                 my $url = prurl($env, $ibx->{url});
54                 my $code = 301;
55                 if (defined $article && $article =~ /\A[0-9]+\z/) {
56                         my $mid = eval { $ibx->mm->mid_for($article) };
57                         if (defined $mid) {
58                                 # article IDs are not stable across clones,
59                                 # do not encourage caching/bookmarking them
60                                 $code = 302;
61                                 $url .= mid_escape($mid) . '/';
62                         }
63                 }
64                 return redirect($code, $url);
65         }
66
67         my @try = (join('/', @parts));
68
69         # trailing slash is in the rest of our WWW, so maybe some users
70         # will assume it:
71         if ($parts[-1] eq '') {
72                 pop @parts;
73                 push @try, join('/', @parts);
74         }
75         my $ALL = $pi_cfg->ALL;
76         if (my $over = $ALL ? $ALL->over : undef) {
77                 my $by_eidx_key = $pi_cfg->{-by_eidx_key};
78                 for my $mid (@try) {
79                         my ($id, $prev);
80                         while (my $x = $over->next_by_mid($mid, \$id, \$prev)) {
81                                 my $xr3 = $over->get_xref3($x->{num});
82                                 for (@$xr3) {
83                                         s/:[0-9]+:$x->{blob}\z// or next;
84                                         my $ibx = $by_eidx_key->{$_} // next;
85                                         my $url = $ALL->base_url($env) //
86                                                         $ibx->base_url // next;
87                                         $url .= mid_escape($mid) . '/';
88                                         return redirect(302, $url);
89                                 }
90                         }
91                 }
92         } else { # slow path, scan every inbox
93                 for my $mid (@try) {
94                         my $arg = [ $mid ]; # [1] => result
95                         $pi_cfg->each_inbox(\&try_inbox, $arg);
96                         return $arg->[1] if $arg->[1];
97                 }
98         }
99         [ 404, [qw(Content-Type text/plain)], ["404 Not Found\n"] ];
100 }
101
102 1;