]> Sergey Matveev's repositories - public-inbox.git/blob - lib/PublicInbox/Unsubscribe.pm
ds: inline set_cloexec
[public-inbox.git] / lib / PublicInbox / Unsubscribe.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 # Standalone PSGI app to handle HTTP(s) unsubscribe links generated
5 # by milters like examples/unsubscribe.milter to mailing lists.
6 #
7 # This does not depend on any other modules in the PublicInbox::*
8 # and ought to be usable with any mailing list software.
9 package PublicInbox::Unsubscribe;
10 use strict;
11 use warnings;
12 use Crypt::CBC;
13 use Plack::Util;
14 use MIME::Base64 qw(decode_base64url);
15 my @CODE_URL = qw(http://7fh6tueqddpjyxjmgtdiueylzoqt6pt7hec3pukyptlmohoowvhde4yd.onion/public-inbox.git
16         https://public-inbox.org/public-inbox.git);
17 my @CT_HTML = ('Content-Type', 'text/html; charset=UTF-8');
18
19 sub new {
20         my ($class, %opt) = @_;
21         my $key_file = $opt{key_file};
22         defined $key_file or die "`key_file' needed";
23         open my $fh, '<', $key_file or die
24                 "failed to open key_file=$key_file: $!\n";
25         my ($key, $iv);
26         if (read($fh, $key, 8) != 8 || read($fh, $iv, 8) != 8 ||
27                                 read($fh, my $end, 8) != 0) {
28                 die "key_file must be 16 bytes\n";
29         }
30
31         # these parameters were chosen to generate shorter parameters
32         # to reduce the possibility of copy+paste errors
33         my $cipher = Crypt::CBC->new(-key => $key,
34                         -iv => $iv,
35                         -header => 'none',
36                         -cipher => 'Blowfish');
37
38         my $e = $opt{owner_email} or die "`owner_email' not specified\n";
39         my $unsubscribe = $opt{unsubscribe} or
40                 die "`unsubscribe' callback not given\n";
41
42         my $code_url = $opt{code_url} || \@CODE_URL;
43         $code_url = [ $code_url ] if ref($code_url) ne 'ARRAY';
44         bless {
45                 pi_cfg => $opt{pi_config}, # PublicInbox::Config
46                 owner_email => $opt{owner_email},
47                 cipher => $cipher,
48                 unsubscribe => $unsubscribe,
49                 contact => qq(<a\nhref="mailto:$e">$e</a>),
50                 code_url => $code_url,
51                 confirm => $opt{confirm},
52         }, $class;
53 }
54
55 # entry point for PSGI
56 sub call {
57         my ($self, $env) = @_;
58         my $m = $env->{REQUEST_METHOD};
59         if ($m eq 'GET' || $m eq 'HEAD') {
60                 $self->{confirm} ? confirm_prompt($self, $env)
61                                  : finalize_unsub($self, $env);
62         } elsif ($m eq 'POST') {
63                 finalize_unsub($self, $env);
64         } else {
65                 r($self, 405,
66                         Plack::Util::encode_html($m).' method not allowed');
67         }
68 }
69
70 sub _user_list_addr {
71         my ($self, $env) = @_;
72         my ($blank, $u, $list) = split('/', $env->{PATH_INFO});
73
74         if (!defined $u || $u eq '') {
75                 return r($self, 400, 'Bad request',
76                         'Missing encrypted email address in path component');
77         }
78         if (!defined $list && $list eq '') {
79                 return r($self, 400, 'Bad request',
80                         'Missing mailing list name in path component');
81         }
82         my $user = eval { $self->{cipher}->decrypt(decode_base64url($u)) };
83         if (!defined $user || index($user, '@') < 1) {
84                 my $err = quotemeta($@);
85                 my $errors = $env->{'psgi.errors'};
86                 $errors->print("error decrypting: $u\n");
87                 $errors->print("$_\n") for split("\n", $err);
88                 $u = Plack::Util::encode_html($u);
89                 return r($self, 400, 'Bad request', "Failed to decrypt: $u");
90         }
91
92         # The URLs are too damn long if we have the encrypted domain
93         # name in the PATH_INFO
94         if (index($list, '@') < 0) {
95                 my $host = (split(':', $env->{HTTP_HOST}))[0];
96                 $list .= '@'.$host;
97         }
98         ($user, $list);
99 }
100
101 sub confirm_prompt { # on GET
102         my ($self, $env) = @_;
103         my ($user_addr, $list_addr) = _user_list_addr($self, $env);
104         return $user_addr if ref $user_addr;
105
106         my $xl = Plack::Util::encode_html($list_addr);
107         my $xu = Plack::Util::encode_html($user_addr);
108         my @body = (
109                 "Confirmation required to remove", '',
110                 "\t$xu", '',
111                 "from the mailing list at", '',
112                 "\t$xl", '',
113                 'You will get one last email once you hit "Confirm" below:',
114                 qq(</pre><form\nmethod=post\naction="">) .
115                 qq(<input\ntype=submit\nvalue="Confirm" />) .
116                 '</form><pre>');
117
118         push @body, archive_info($self, $env, $list_addr);
119
120         r($self, 200, "Confirm unsubscribe for $xl", @body);
121 }
122
123 sub finalize_unsub { # on POST
124         my ($self, $env) = @_;
125         my ($user_addr, $list_addr) = _user_list_addr($self, $env);
126         return $user_addr if ref $user_addr;
127
128         my @archive = archive_info($self, $env, $list_addr);
129         if (my $err = $self->{unsubscribe}->($user_addr, $list_addr)) {
130                 return r($self, 500, Plack::Util::encode_html($err), @archive);
131         }
132
133         my $xl = Plack::Util::encode_html($list_addr);
134         r($self, 200, "Unsubscribed from $xl",
135                 'You may get one final goodbye message', @archive);
136 }
137
138 sub r {
139         my ($self, $code, $title, @body) = @_;
140         [ $code, [ @CT_HTML ], [
141                 "<html><head><title>$title</title></head><body><pre>".
142                 join("\n", "<b>$title</b>\n", @body) . '</pre><hr>'.
143                 "<pre>This page is available under AGPL-3.0+\n" .
144                 join('', map { "git clone $_\n" } @{$self->{code_url}}) .
145                 qq(Email $self->{contact} if you have any questions).
146                 '</pre></body></html>'
147         ] ];
148 }
149
150 sub archive_info {
151         my ($self, $env, $list_addr) = @_;
152         my $archive_url = $self->{archive_urls}->{$list_addr};
153
154         unless ($archive_url) {
155                 if (my $cfg = $self->{pi_cfg}) {
156                         # PublicInbox::Config::lookup
157                         my $ibx = $cfg->lookup($list_addr);
158                         # PublicInbox::Inbox::base_url
159                         $archive_url = $ibx->base_url if $ibx;
160                 }
161         }
162
163         # protocol-relative URL:  "//example.com/" => "https://example.com/"
164         if ($archive_url && $archive_url =~ m!\A//!) {
165                 $archive_url = "$env->{'psgi.url_scheme'}:$archive_url";
166         }
167
168         # maybe there are other places where we could map
169         # list_addr => archive_url without ~/.public-inbox/config
170         if ($archive_url) {
171                 $archive_url = Plack::Util::encode_html($archive_url);
172                 ('',
173                 'HTML and git clone-able archives are available at:',
174                 qq(<a\nhref="$archive_url">$archive_url</a>))
175         } else {
176                 ('',
177                 'There ought to be archives for this list,',
178                 'but unfortunately the admin did not configure '.
179                 __PACKAGE__. ' to show you the URL');
180         }
181 }
182
183 1;