mail.pl 16 KB

123456789101112131415161718192021222324252627282930313233343536373839404142434445464748495051525354555657585960616263646566676869707172737475767778798081828384858687888990919293949596979899100101102103104105106107108109110111112113114115116117118119120121122123124125126127128129130131132133134135136137138139140141142143144145146147148149150151152153154155156157158159160161162163164165166167168169170171172173174175176177178179180181182183184185186187188189190191192193194195196197198199200201202203204205206207208209210211212213214215216217218219220221222223224225226227228229230231232233234235236237238239240241242243244245246247248249250251252253254255256257258259260261262263264265266267268269270271272273274275276277278279280281282283284285286287288289290291292293294295296297298299300301302303304305306307308309310311312313314315316317318319320321322323324325326327328329330331332333334335336337338339340341342343344345346347348349350351352353354355356357358359360361362363364365366367368369370371372373374375376377378379380381382383384385386387388389390391392393394395396397398399400401402403404405406407408409410411412413414415416417418419420421422423424425426427428429430431432433434435436437438439440441442443444445446447448449450451452453454455456457458459460461462463464465466467468469470471472473474475476477478479480481482483484485486487488489490491492493494495496497498499500501502503504505506507508509510511512513514515516517518519520521522523524525526527528529530531532533534535536537538539540541542543544545546547
  1. # Copyright (C) 2009–2022 Alex Schroeder <alex@gnu.org>
  2. # Copyright (C) 2015 Aleks-Daniel Jakimenko <alex.jakimenko@gmail.com>
  3. #
  4. # This program is free software; you can redistribute it and/or modify it under
  5. # the terms of the GNU General Public License as published by the Free Software
  6. # Foundation; either version 3 of the License, or (at your option) any later
  7. # version.
  8. #
  9. # This program is distributed in the hope that it will be useful, but WITHOUT
  10. # ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS
  11. # FOR A PARTICULAR PURPOSE. See the GNU General Public License for more details.
  12. #
  13. # You should have received a copy of the GNU General Public License along with
  14. # this program. If not, see <http://www.gnu.org/licenses/>.
  15. use strict;
  16. use v5.10;
  17. =head1 NAME
  18. tags - an Oddmuse module that implements email subscription to pages
  19. =head1 SYNOPSIS
  20. Visitors can add their email address and click a checkbox to subscribe
  21. to changes when they edit a page. The requirement to successfully edit
  22. a page acts as a defense mechanism against spammers and vandals.
  23. Email addresses are stored in a file. Each mail contains an
  24. unsubscribe link, and from there users can see (and unsubscribe from)
  25. all other pages they are subscribed to. The link contains a hash of
  26. the email address which prevents others from guessing what email
  27. addresses have subscriptions.
  28. There is also an admin interface that shows which email addresses are
  29. subscribed to which pages, allowing the easy removal of email
  30. addresses from the database.
  31. =head1 INSTALLATION
  32. Installing a module is easy: Create a modules subdirectory in your
  33. data directory, and put the Perl file in there. It will be loaded
  34. automatically.
  35. =cut
  36. AddModuleDescription('mail.pl', 'Mail Extension');
  37. our ($q, %Action, %IndexHash, $FS, $DataDir, %CookieParameters,
  38. @MyInitVariables, @MyAdminCode, $Message, @MyFormChanges);
  39. our ($MailFile, $MailPattern);
  40. push (@MyInitVariables, sub {
  41. $MailFile = "$DataDir/mail.db";
  42. });
  43. # May contain neither space nor @; I'm too scared to put
  44. # Mail::RFC822::Address here.
  45. $MailPattern = '^[^ ]+@[^ ]+$';
  46. =head1 Commenting
  47. When commenting, users are presented with a form where they can
  48. provide username and homepage. With this extension, users can also
  49. provide their mail address and choose to subscribe to comment pages.
  50. In order to get caching right, we also use an invisible cookie
  51. parameter to make sure that visitors will get a new page when they
  52. subscribe or unsubscribe. The alternative would have been to touch the
  53. index file at the end of the subscribe and unsubscribe function.
  54. =cut
  55. *MailOldInitCookie = \&InitCookie;
  56. *InitCookie = \&MailNewInitCookie;
  57. $CookieParameters{mail} = '';
  58. $CookieParameters{sub} = '';
  59. sub MailNewInitCookie {
  60. MailOldInitCookie(@_);
  61. my $mail = GetParam('mail', '');
  62. $q->delete('mail');
  63. if (!$mail) {
  64. # do nothing
  65. } elsif (!($mail =~ /$MailPattern/)) {
  66. $Message .= $q->p(Ts('Invalid Mail %s: not saved.', $mail));
  67. } else {
  68. SetParam('mail', $mail);
  69. }
  70. }
  71. push(@MyFormChanges, \&MailFormAddition);
  72. sub MailFormAddition {
  73. my $html = shift;
  74. my $id = GetId();
  75. my $mail = GetParam('mail', '');
  76. my $addition;
  77. if (MailIsSubscribed($id, $mail)) {
  78. $addition = ' ' . ScriptLink("action=unsubscribe;pages=$id",
  79. T('unsubscribe'), 'unsubscribe');
  80. } else {
  81. $addition = $q->input({-type=>'checkbox', -name=>'notify', -value=>'1'})
  82. . ScriptLink("action=subscribe;pages=$id", T('subscribe'), 'subscribe');
  83. }
  84. $addition = $q->span({-class=>'mail'},
  85. $q->label({-for=>'mail'}, T('Email:') . ' ')
  86. . ' ' . $q->textfield(-name=>'mail', -id=>'mail',
  87. -default=>GetParam('mail', ''))
  88. . $addition);
  89. $html =~ s!(name="homepage".*?)</p>!$1 $addition</p>!i;
  90. return $html;
  91. }
  92. sub MailIsSubscribed {
  93. # is not called within a lock
  94. my ($id, $mail) = @_;
  95. return 0 unless $mail;
  96. # open the DB file
  97. require DB_File;
  98. tie my %h, "DB_File", encode_utf8($MailFile);
  99. my %subscribers = map {$_=>1} split(/$FS/, UrlDecode($h{UrlEncode($id)}));
  100. untie %h;
  101. return $subscribers{$mail};
  102. }
  103. *MailOldGetFooterTimestamp = \&GetFooterTimestamp;
  104. *GetFooterTimestamp = \&MailNewGetFooterTimestamp;
  105. sub MailNewGetFooterTimestamp {
  106. my $html = MailOldGetFooterTimestamp(@_);
  107. my $id = shift;
  108. my $mail = GetParam('mail', '');
  109. my $addition;
  110. if (MailIsSubscribed($id, $mail)) {
  111. $addition = ScriptLink("action=unsubscribe;pages=$id",
  112. T('unsubscribe'), 'unsubscribe');
  113. } else {
  114. $addition = ScriptLink("action=subscribe;pages=$id",
  115. T('subscribe'), 'subscribe');
  116. }
  117. $html =~ s!(.*)(<br /></span>)!$1 $addition$2!i;
  118. return $html;
  119. }
  120. =head1 Saving
  121. When saving a comment page users can subscribe using a checkbox. To do
  122. this via an URL you need to provide the parameters id, mail, aftertext
  123. (a new comment), and notify (1).
  124. =cut
  125. *MailOldSave = \&Save;
  126. *Save = \&MailNewSave;
  127. sub MailNewSave {
  128. # is called within a lock! :)
  129. MailOldSave(@_);
  130. my $id = shift;
  131. my $mail = GetParam('mail', '');
  132. my $comment = GetParam('aftertext', '');
  133. # Compare to GetId() in order to prevent subscription to LocalNames
  134. # page and other automatic saves.
  135. if ($id and $id eq GetId() and $comment and $mail
  136. and GetParam('notify', '')) {
  137. my $valid = 1;
  138. eval {
  139. local $SIG{__DIE__};
  140. require Mail::RFC822::Address;
  141. $valid = Mail::RFC822::Address::valid($mail);
  142. SetParam('msg', Ts('%s appears to be an invalid mail address', $mail))
  143. unless $valid;
  144. };
  145. MailSubscribe($mail, $id) if $valid;
  146. }
  147. }
  148. *OldMailDeletePage = \&DeletePage;
  149. *DeletePage = \&NewMailDeletePage;
  150. =head1 Deleting
  151. When a page is deleted, the appropriate subscriptions have to be
  152. deleted as well.
  153. =cut
  154. sub NewMailDeletePage {
  155. my $id = shift;
  156. MailDeletePage($id);
  157. return OldMailDeletePage($id, @_);
  158. }
  159. sub MailDeletePage {
  160. my $id = shift;
  161. require DB_File;
  162. tie my %h, "DB_File", encode_utf8($MailFile);
  163. foreach my $mail (split(/$FS/, UrlDecode(delete $h{UrlEncode($id)}))) {
  164. my %subscriptions = map {$_=>1} split(/$FS/, UrlDecode($h{UrlEncode($mail)}));
  165. delete $subscriptions{$id};
  166. if (%subscriptions) {
  167. $h{UrlEncode($mail)} = UrlEncode(join($FS, keys %subscriptions));
  168. } else {
  169. delete $h{UrlEncode($mail)};
  170. }
  171. }
  172. untie %h;
  173. }
  174. =head1 Administration menu
  175. The Administration page will have a list to your subscriptions, and if
  176. you are an administrator, it will also have a link to all
  177. subscriptions.
  178. =cut
  179. push(@MyAdminCode, \&MailMenu);
  180. sub MailMenu {
  181. my ($id, $menuref, $restref) = @_;
  182. push(@$menuref,
  183. ScriptLink('action=subscriptions',
  184. T('Your mail subscriptions'),
  185. 'subscriptions'));
  186. push(@$menuref,
  187. ScriptLink('action=subscriptionlist',
  188. T('All mail subscriptions'),
  189. 'subscriptionlist')) if UserIsAdmin();
  190. push(@$menuref,
  191. ScriptLink('action=subscribers',
  192. T('All mail subscribers'),
  193. 'subscribers')) if UserIsAdmin();
  194. }
  195. =head1 Your subscriptions
  196. The subscriptions action will show you subscriptions and offer to
  197. unsubscribe.
  198. =cut
  199. $Action{subscriptions} = \&DoMailSubscriptions;
  200. sub DoMailSubscriptions {
  201. my $mail = GetParam('mail', '');
  202. print GetHeader('', T('Subscriptions')),
  203. $q->start_div({-class=>'content subscriptions'}),
  204. GetFormStart(undef, 'get', 'mail');
  205. if (not $mail) {
  206. print $q->p($q->span($q->label({-for=>'mail'}, T('Email: '))
  207. . ' ' . $q->textfield(-name=>'mail', -id=>'mail'))),
  208. $q->input({-type=>'hidden',-name=>'action',-value=>'subscriptions'}),
  209. ' ', $q->submit(-name=>'Show', -value=>T('Show'));
  210. } else {
  211. my @subscriptions = MailSubscription($mail);
  212. if (@subscriptions) {
  213. print $q->p(Ts('Subscriptions for %s:', $mail),
  214. $q->input({-type=>'hidden',-name=>'action',-value=>'unsubscribe'}));
  215. print $q->p(join($q->br(),
  216. map { $q->input({-type=>'checkbox', -name=>'pages', -value=>"$_"})
  217. . GetPageLink($_) } @subscriptions));
  218. print $q->p($q->submit(-name=>'Unsubscribe', -value=>T('Unsubscribe')));
  219. } else {
  220. print $q->p(Ts('There are no subscriptions for %s.', $mail));
  221. }
  222. print $q->p(ScriptLink('action=subscriptions;mail=', T('Change email address'),
  223. 'change subscriptions'));
  224. }
  225. print $q->end_form(), $q->end_div();
  226. PrintFooter();
  227. }
  228. sub MailSubscription {
  229. my $mail = shift;
  230. return unless $mail;
  231. require DB_File;
  232. tie my %h, "DB_File", encode_utf8($MailFile);
  233. my @result = split(/$FS/, UrlDecode($h{UrlEncode($mail)}));
  234. untie %h;
  235. @result = sort @result;
  236. return @result;
  237. }
  238. =head1 Administrator Access
  239. The C<subscriptionlist> action will show you the subscription database, if
  240. you're an administrator. With the C<raw> parameter set it's a plain text file of
  241. the data, which you can use for debugging and scripting purposes.
  242. =cut
  243. $Action{subscriptionlist} = \&DoMailSubscriptionList;
  244. sub DoMailSubscriptionList {
  245. UserIsAdminOrError();
  246. my $raw = GetParam('raw', 0);
  247. if ($raw) {
  248. print GetHttpHeader('text/plain');
  249. } else {
  250. print GetHeader('', T('Subscriptions')),
  251. $q->start_div({-class=>'content subscribtionlist'}),
  252. $q->p(T('Mail addresses are linked to unsubscription links.')),
  253. '<ul>';
  254. }
  255. require DB_File;
  256. tie my %h, "DB_File", encode_utf8($MailFile);
  257. foreach my $encodedkey (sort keys %h) {
  258. my @values = sort split(/$FS/, UrlDecode($h{$encodedkey}));
  259. my $key = UrlDecode($encodedkey);
  260. if ($raw) {
  261. print join(' ', $key, @values) . "\n";
  262. } else {
  263. print $q->li(Ts('%s:', MailLink($key, @values)) . ' '
  264. . join(' ', map { MailLink($_, $key) } @values));
  265. }
  266. }
  267. print '</ul></div>' unless $raw;
  268. PrintFooter() unless $raw;
  269. untie %h;
  270. }
  271. sub MailLink {
  272. my ($str, @pages) = @_;
  273. # The @ is not a legal character for pagenames.
  274. return GetPageLink($str) if index($str, '@') == -1;
  275. return ScriptLink("action=unsubscribe;who=$str;"
  276. . join(';', map { "pages=$_" } @pages), $str);
  277. }
  278. =pod
  279. The C<subscribers> action lists each unique email address for easier mass
  280. unsubscribing of email addresses after a wave of wiki spam.
  281. =cut
  282. $Action{subscribers} = \&DoMailSubscribers;
  283. sub DoMailSubscribers {
  284. UserIsAdminOrError();
  285. my $raw = GetParam('raw', 0);
  286. if ($raw) {
  287. print GetHttpHeader('text/plain');
  288. } else {
  289. print GetHeader('', T('Subscriptions')),
  290. $q->start_div({-class=>'content subscribtionlist'}),
  291. $q->p(T('Mail addresses are linked to unsubscription links.')),
  292. '<ul>';
  293. }
  294. my %authors;
  295. require DB_File;
  296. tie my %h, "DB_File", encode_utf8($MailFile);
  297. for my $author (sort grep /\@/, map { UrlDecode($_) } keys %h) {
  298. if ($raw) {
  299. print "$author\n";
  300. } else {
  301. print $q->li(ScriptLink("action=unsubscribe;who=$author", $author));
  302. }
  303. }
  304. print '</ul></div>' unless $raw;
  305. PrintFooter() unless $raw;
  306. untie %h;
  307. }
  308. =head1 Subscription
  309. The subscribe action will subscribe you to pages. The mail parameter
  310. contains the mail address to use and defaults to the value store in
  311. your cookie. Multiple pages parameters contain the pages to subscribe.
  312. =cut
  313. $Action{subscribe} = \&DoMailSubscribe;
  314. sub DoMailSubscribe {
  315. local $CGI::LIST_CONTEXT_WARN = 0;
  316. my @pages = $q->param('pages');
  317. return DoMailSubscriptions(@_) unless @pages;
  318. my $mail = GetParam('mail', '');
  319. if (not $mail) {
  320. print GetHeader('', T('Subscriptions')),
  321. $q->start_div({-class=>'content subscribe'}),
  322. GetFormStart(undef, 'get', 'subscribe');
  323. print $q->p(Ts('Subscribe to %s.',
  324. join(', ', map { GetPageLink($_) } @pages)));
  325. print $q->p($q->span($q->label({-for=>'mail'}, T('Email: '))
  326. . ' ' . $q->textfield(-name=>'mail', -id=>'mail')));
  327. print $q->hidden('pages', @pages);
  328. print $q->input({-type=>'hidden',-name=>'action',-value=>'subscribe'}),
  329. ' ', $q->submit(-name=>'Subscribe', -value=>T('Subscribe'));
  330. } else {
  331. my @real = ();
  332. foreach my $id (@pages) {
  333. push @real, $id if $IndexHash{$id};
  334. }
  335. # subscriptions have to be added in a lock
  336. RequestLockOrError();
  337. MailSubscribe($mail, @real);
  338. ReleaseLock();
  339. # MailSubscribe will set a parameter and must run before printing
  340. # the header.
  341. print GetHeader('', T('Subscriptions')),
  342. $q->start_div({-class=>'content subscribe'});
  343. print $q->p(Ts('Subscribed %s to the following pages:', $mail));
  344. print $q->ul($q->li([map { GetPageLink($_) } @real]));
  345. print $q->p(T('The remaining pages do not exist.')) if $#real < $#pages;
  346. print $q->p(ScriptLink('action=subscriptions', T('Your mail subscriptions'),
  347. 'subscriptions') . '.');
  348. }
  349. print $q->end_div();
  350. PrintFooter();
  351. }
  352. sub MailSubscribe {
  353. # is called within a lock! :)
  354. my ($mail, @pages) = @_;
  355. return unless $mail and @pages;
  356. # open the DB file
  357. require DB_File;
  358. tie my %h, "DB_File", encode_utf8($MailFile);
  359. # add to the mail entry
  360. my %subscriptions = map {$_=>1} split(/$FS/, UrlDecode($h{UrlEncode($mail)}));
  361. for my $id (@pages) {
  362. $subscriptions{$id} = 1;
  363. }
  364. $h{UrlEncode($mail)} = UrlEncode(join($FS, keys %subscriptions));
  365. # add to the page entries
  366. for my $id (@pages) {
  367. my %subscribers = map {$_=>1} split(/$FS/, UrlDecode($h{UrlEncode($id)}));
  368. $subscribers{$mail} = 1;
  369. $h{UrlEncode($id)} = UrlEncode(join($FS, keys %subscribers));
  370. }
  371. untie %h;
  372. # changes made will affect how pages look
  373. SetParam('sub', GetParam('sub', 0) + 1);
  374. }
  375. =head1 Unsubscription
  376. The unsubscribe action will unsubscribe you from pages. The mail parameter
  377. contains the mail address to use and defaults to the value store in your cookie.
  378. Multiple pages parameters contain the pages to unsubscribe. Without naming
  379. pages, you will be unsubscribed from all pages.
  380. The who parameter overrides the mail parameter and is used for administrator
  381. unsubscription from the subscriptionlist action.
  382. =cut
  383. $Action{unsubscribe} = \&DoMailUnsubscribe;
  384. sub DoMailUnsubscribe {
  385. my $mail = GetParam('who', GetParam('mail', ''));
  386. return DoMailSubscriptions(@_) unless $mail;
  387. local $CGI::LIST_CONTEXT_WARN = 0;
  388. my @pages = $q->param('pages');
  389. MailUnsubscribe($mail, @pages);
  390. # MailUnsubscribe will set a parameter and must run before printing
  391. # the header.
  392. print GetHeader('', T('Subscriptions')),
  393. $q->start_div({-class=>'content unsubscribe'});
  394. if (@pages) {
  395. print $q->p(Ts('Unsubscribed %s from the following pages:', $mail));
  396. print $q->ul($q->li([map { GetPageLink($_) } @pages]));
  397. } else {
  398. print $q->p(Ts('Unsubscribed %s from all pages.', $mail));
  399. }
  400. print $q->p(ScriptLink('action=subscriptions', T('Your mail subscriptions'),
  401. 'subscriptions') . '.');
  402. print $q->end_div();
  403. PrintFooter();
  404. }
  405. sub MailUnsubscribe {
  406. my ($mail, @pages) = @_;
  407. return unless $mail;
  408. require DB_File;
  409. tie my %h, "DB_File", encode_utf8($MailFile);
  410. my %subscriptions = map {$_=>1} split(/$FS/, UrlDecode($h{UrlEncode($mail)}));
  411. @pages = keys %subscriptions unless @pages;
  412. foreach my $id (@pages) {
  413. delete $subscriptions{$id};
  414. # take care of reverse lookup
  415. my %subscribers = map {$_=>1} split(/$FS/, UrlDecode($h{UrlEncode($id)}));
  416. delete $subscribers{$mail};
  417. if (%subscribers) {
  418. $h{UrlEncode($id)} = UrlEncode(join($FS, keys %subscribers));
  419. } else {
  420. delete $h{UrlEncode($id)};
  421. }
  422. }
  423. if (%subscriptions) {
  424. $h{UrlEncode($mail)} = UrlEncode(join($FS, keys %subscriptions));
  425. } else {
  426. delete $h{UrlEncode($mail)} unless %subscriptions;
  427. }
  428. untie %h;
  429. # changes made will affect how pages look
  430. SetParam('sub', GetParam('sub', 0) + 1);
  431. }
  432. =head1 Migrate
  433. The mailmigrate action will migrate your subscription list from the old format
  434. to the new format. This is necessary because these days the keys and values of
  435. the DB_File are URL encoded.
  436. =cut
  437. $Action{'migrate-subscriptions'} = \&DoMailMigration;
  438. sub DoMailMigration {
  439. UserIsAdminOrError();
  440. print GetHeader('', T('Migrating Subscriptions')),
  441. $q->start_div({-class=>'content mailmigrate'});
  442. require DB_File;
  443. tie my %h, "DB_File", encode_utf8($MailFile);
  444. my $found = 0;
  445. foreach my $key (keys %h) {
  446. if (index($key, '@') != -1) {
  447. $found = 1;
  448. last;
  449. }
  450. }
  451. if (not $found) {
  452. print $q->p(T('No non-migrated email addresses found, migration not necessary.'));
  453. } else {
  454. my %n;
  455. foreach my $key (sort keys %h) {
  456. my $value = $h{$key};
  457. my @values = sort split(/$FS/, $value);
  458. $n{UrlEncode($key)} = join($FS, map { UrlEncode($_) } @values);
  459. }
  460. %h = %n;
  461. print $q->p(Ts('Migrated %s rows.', scalar(keys %n)));
  462. }
  463. print '</div>';
  464. untie %h;
  465. PrintFooter();
  466. }