1/*  Part of SWISH
    2
    3    Author:        Jan Wielemaker
    4    E-mail:        J.Wielemaker@cs.vu.nl
    5    WWW:           http://www.swi-prolog.org
    6    Copyright (C): 2017, VU University Amsterdam
    7			 CWI Amsterdam
    8    All rights reserved.
    9
   10    Redistribution and use in source and binary forms, with or without
   11    modification, are permitted provided that the following conditions
   12    are met:
   13
   14    1. Redistributions of source code must retain the above copyright
   15       notice, this list of conditions and the following disclaimer.
   16
   17    2. Redistributions in binary form must reproduce the above copyright
   18       notice, this list of conditions and the following disclaimer in
   19       the documentation and/or other materials provided with the
   20       distribution.
   21
   22    THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
   23    "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
   24    LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS
   25    FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE
   26    COPYRIGHT OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT,
   27    INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING,
   28    BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES;
   29    LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER
   30    CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT
   31    LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN
   32    ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
   33    POSSIBILITY OF SUCH DAMAGE.
   34*/
   35
   36:- module(swish_email,
   37          [ smtp_send_mail/3,           % +To, :Goal, +Options
   38            smtp_send_html/3,           % +To, :Content, +Options
   39
   40            dear//1,                    % +ProfileID
   41            signature//0,
   42            profile_name//1,            % +ProfileID
   43            email_action_link//4,	% :Label, :Reply, :Action, +Options
   44
   45            email_style//0,             % Inline style sheet
   46
   47            email_cleanup_db/0,
   48
   49            public_url/4                % +To, +Query, -URL, +Options
   50          ]).   51:- use_module(library(smtp)).           % from pack smtp
   52:- use_module(library(option)).   53:- use_module(library(settings)).   54:- use_module(library(base64)).   55:- use_module(library(http/http_dispatch)).   56:- use_module(library(http/http_host)).   57:- use_module(library(http/html_write)).   58:- use_module(library(apply)).   59:- use_module(library(random)).   60:- use_module(library(persistency)).   61:- use_module(library(broadcast)).   62:- use_module(library(user_profile)).   63
   64/** <module> Email plugin for SWISH
   65
   66This module deals with sending  email  from   SWISH.  Email  is sent for
   67confirmation (of the email address) as well as for notifications.
   68*/
   69
   70:- html_meta
   71    smtp_send_html(+, html, +),
   72    email_action_link(html, 1, 0, +, ?, ?).   73
   74:- setting(timeout, integer, 24*3600*7,
   75           "Timeout for handling email reply").   76:- setting(database, callable, data('confirm.db'),
   77           "File specification for E-mail confirmations").   78:- setting(subject_prefix, atom, '[SWISH] ',
   79           "Prefix for the subject of emails sent").   80
   81:- http_handler(swish('mail/action/'), on_mail_link,
   82                [prefix, id(on_mail_link)]).   83
   84
   85		 /*******************************
   86		 *            DATABASE		*
   87		 *******************************/
   88
   89:- persistent
   90        request(key:string,
   91                deadline:integer,
   92                action:callable,
   93                reply:callable).   94
   95email_open_db :-
   96    db_attached(_),
   97    !.
   98email_open_db :-
   99    setting(database, Spec),
  100    absolute_file_name(Spec, Path, [access(write)]),
  101    db_attach(Path, [sync(close)]).
  102
  103%!  email_cleanup_db
  104%
  105%   Strip the email confirmation queue from outdated messages.
  106
  107email_cleanup_db :-
  108    with_mutex(swish_email, email_cleanup_db_sync).
  109
  110email_cleanup_db_sync :-
  111    get_time(Now),
  112    forall(( request(Key, Deadline, _, _),
  113             Now > Deadline
  114           ),
  115           retract_request(Key, Deadline, _, _)),
  116    db_sync(gc).
  117
  118
  119
  120		 /*******************************
  121		 *           EMAIL		*
  122		 *******************************/
  123
  124%!  smtp_send_html(+To, :Content, +Options)
  125%
  126%   Send an HTML mail to To  using   HTML  content  Content. Options are
  127%   passed  to  smtp_send_mail/3,  passing    as   default  content-type
  128%   `text/html`.
  129
  130smtp_send_html(To, Content, Options) :-
  131    select_option(subject(Subject), Options, Options1, "<no subject>"),
  132    setting(subject_prefix, Prefix),
  133    string_concat(Prefix, Subject, Subject1),
  134    merge_options(Options1,
  135                  [ header('MIME-Version'('1.0')),
  136                    content_type(text/html)
  137                  ], Options2),
  138    smtp_send_mail(To, html_body(Content),
  139                   [ subject(Subject1)
  140                   | Options2
  141                   ]).
  142
  143html_body(Content, Out) :-
  144    phrase(html(html([ head([]),
  145                       body(Content)
  146                     ])), Tokens),
  147    print_html(Out, Tokens).
  148
  149%!  generate_key(-Key) is det.
  150%
  151%   Generate a random confirmation key
  152
  153generate_key(Key) :-
  154    length(Codes, 16),
  155    maplist(random_between(0,255), Codes),
  156    phrase(base64url(Codes), Encoded),
  157    string_codes(Key, Encoded).
  158
  159
  160		 /*******************************
  161		 *            STYLE		*
  162		 *******************************/
  163
  164email_style -->
  165    html({|html||
  166<style>
  167address { width: 80%; text-align: right;
  168          margin-left: 18%; margin-top: 2em; border-top: 1px solid #888;}
  169</style>
  170         |}).
  171
  172
  173
  174		 /*******************************
  175		 *         PAGE ELEMENTS	*
  176		 *******************************/
  177
  178%!  dear(+Profile)//
  179%
  180%   Address user with the given ProfileID.
  181
  182dear(Profile) -->
  183    html(p(['Dear ', \profile_name(Profile), ','])).
  184
  185%!  signature//
  186%
  187%   Emit footer
  188
  189signature -->
  190    { host_url(HostURL, []) },
  191    !,
  192    html(address(['SWISH at ', a(href(HostURL), HostURL)])).
  193signature -->
  194    html(address(['SWISH'])).
  195
  196%!  profile_name(+Profile)//
  197%
  198%   Emit the name associated with Profile as unstyled HTML.
  199
  200profile_name(User) -->
  201    { user_field(Field),
  202      Term =.. [Field, Name],
  203      profile_property(User, Term)
  204    },
  205    html(Name).
  206
  207user_field(name).
  208user_field(given_name).
  209user_field(nick_name).
  210user_field(family_name).
  211
  212%!  mailto(+Address)//
  213%
  214%   Insert an email link, displaying the address itself.
  215
  216mailto(Address) -->
  217    html(a(href('mailto:'+Address), Address)).
  218
  219
  220		 /*******************************
  221		 *         ACTIVE LINKS		*
  222		 *******************************/
  223
  224%!  email_action_link(:Label, :Reply, :Action, +Options)//
  225%
  226%   Generate a link in an HTML mail   page  that, when clicked, executes
  227%   Action and if successful replies to the request using Reply.
  228
  229email_action_link(Label, Reply, Action, Options) -->
  230    { email_open_db,
  231      generate_key(Key),
  232      public_url(on_mail_link, path_postfix(Key), HREF, Options),
  233      setting(timeout, TMODef),
  234      option(timeout(TMO), Options, TMODef),
  235      get_time(Now),
  236      Deadline is round(Now+TMO),
  237      with_mutex(swish_email,
  238                 assert_request(Key, Deadline, Action, Reply))
  239    },
  240    html(a(href(HREF), Label)).
  241
  242%!  on_mail_link(Request)
  243%
  244%   React on a clicked link generated by email_action_link//4.
  245
  246on_mail_link(Request) :-
  247    email_open_db,
  248    option(path_info(Path), Request),
  249    atom_string(Path, Key),
  250    with_mutex(swish_email,
  251               retract_request(Key, Deadline, Action, Reply)),
  252    !,
  253    (   get_time(Now),
  254        Now =< Deadline
  255    ->  call(Action),
  256        call(Reply, Request)
  257    ;   reply_expired(Request)
  258    ).
  259on_mail_link(Request) :-
  260    email_open_db,
  261    option(path_info(Path), Request),
  262    atom_string(Path, Key),
  263    reply_html_page(
  264        email_confirmation,
  265        title('Unknown request'),
  266        [ \email_style,
  267          p([ 'Cannot find request ~w.'-[Key], ' This typically means the \c
  268               request has already been executed, is expired or the link \c
  269               is invalid.'
  270            ]),
  271          \signature
  272        ]).
  273on_mail_link(_Request) :-
  274    throw(http_reply(bad_request(missing_key))).
  275
  276reply_expired(_Request) :-
  277    reply_html_page(
  278        email_confirmation,
  279        title('Request expired'),
  280        [ \email_style,
  281          p([ 'Your request has expired.'
  282            ]),
  283          \signature
  284        ]).
  285
  286
  287%!  public_url(+To, +Query, -URL, +Options) is det.
  288%
  289%   True when URL is a link to handler To with Query
  290
  291public_url(To, Query, URL, Options) :-
  292    http_link_to_id(To, Query, RequestURI),
  293    host_url(HostURL, Options),
  294    atom_concat(HostURL, RequestURI, URL).
  295
  296host_url(HostURL, Options) :-
  297    option(host_url(HostURL), Options),
  298    !.
  299host_url(HostURL, _Options) :-
  300    http_public_host_url(_Request, HostURL).
  301
  302
  303		 /*******************************
  304		 *             EVENTS		*
  305		 *******************************/
  306
  307:- listen(user_profile(modified(User, email, Old, New)),
  308          email_verify(User, Old, New)).  309
  310email_verify(_User, _Old, "") :-
  311    !.
  312email_verify(User, Old, Email) :-
  313    smtp_send_html(Email, \email_verify(User, Old, Email),
  314                   [ subject("Please verify email")
  315                   ]).
  316
  317
  318email_verify(User, "", New) -->
  319    html([ \email_style,
  320           \dear(User),
  321           p(['We have received a request to set the email account \c
  322               for SWISH to ', \mailto(New), '.' ]),
  323           ul([ li(\confirm_link(User, New))
  324              ]),
  325           \signature
  326         ]).
  327email_verify(User, Old, New) -->
  328    html([ \email_style,
  329           \dear(User),
  330           p(['We have received a request to change the email account \c
  331               for SWISH from ', \mailto(Old), ' to ', \mailto(New), '.' ]),
  332           ul([ li(\confirm_link(User, New))
  333              ]),
  334           \signature
  335         ]).
  336
  337confirm_link(User, New) -->
  338    email_action_link(["Verify email as ", New], verified_email(User, New),
  339                      verify_email(User), []).
  340
  341verify_email(User) :-
  342    set_profile(User, email_verified(true)).
  343
  344verified_email(User, NewEmail, _Request) :-
  345    reply_html_page(
  346        email_confirmation,
  347        title('SWISH -- Email verified'),
  348        [ \email_style,
  349          \dear(User),
  350          p(['Your email address ', \mailto(NewEmail), ' has been verified.']),
  351          \signature
  352        ])