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-2020, VU University Amsterdam
    7			      CWI Amsterdam
    8                              SWI-Prolog Solutions b.v.
    9    All rights reserved.
   10
   11    Redistribution and use in source and binary forms, with or without
   12    modification, are permitted provided that the following conditions
   13    are met:
   14
   15    1. Redistributions of source code must retain the above copyright
   16       notice, this list of conditions and the following disclaimer.
   17
   18    2. Redistributions in binary form must reproduce the above copyright
   19       notice, this list of conditions and the following disclaimer in
   20       the documentation and/or other materials provided with the
   21       distribution.
   22
   23    THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
   24    "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
   25    LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS
   26    FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE
   27    COPYRIGHT OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT,
   28    INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING,
   29    BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES;
   30    LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER
   31    CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT
   32    LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN
   33    ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
   34    POSSIBILITY OF SUCH DAMAGE.
   35*/
   36
   37:- module(swish_email,
   38          [ smtp_send_mail/3,           % +To, :Goal, +Options
   39            smtp_send_html/3,           % +To, :Content, +Options
   40
   41            dear//1,                    % +ProfileID
   42            signature//0,
   43            profile_name//1,            % +ProfileID
   44            email_action_link//4,	% :Label, :Reply, :Action, +Options
   45
   46            email_style//0,             % Inline style sheet
   47
   48            email_cleanup_db/0,
   49
   50            public_url/4                % +To, +Query, -URL, +Options
   51          ]).   52:- use_module(library(smtp)).           % from pack smtp
   53:- use_module(library(option)).   54:- use_module(library(settings)).   55:- use_module(library(base64)).   56:- use_module(library(http/http_dispatch)).   57:- use_module(library(http/http_host)).   58:- use_module(library(http/html_write)).   59:- use_module(library(apply)).   60:- use_module(library(random)).   61:- use_module(library(persistency)).   62:- use_module(library(broadcast)).   63:- use_module(library(user_profile)).   64
   65:- use_module('../config').

   73:- html_meta
   74    smtp_send_html(+, html, +),
   75    email_action_link(html, 1, 0, +, ?, ?).   76
   77:- setting(timeout, integer, 24*3600*7,
   78           "Timeout for handling email reply").   79:- setting(database, callable, data('confirm.db'),
   80           "File specification for E-mail confirmations").   81:- setting(subject_prefix, atom, '[SWISH] ',
   82           "Prefix for the subject of emails sent").   83
   84:- http_handler(swish('mail/action/'), on_mail_link,
   85                [prefix, id(on_mail_link)]).   86
   87
   88		 /*******************************
   89		 *            DATABASE		*
   90		 *******************************/

 redis_db(+Id, -Server, -Key) is semidet

Get the Redis server and for a specific request.

   96redis_key(Id, Server, Key) :-
   97    swish_config(redis, Server),
   98    swish_config(redis_prefix, Prefix),
   99    atomic_list_concat([Prefix, confirm, Id], :, Key).
  100
  101use_redis :-
  102    swish_config(redis, _).
  103
  104:- persistent
  105        request(key:string,
  106                deadline:integer,
  107                action:callable,
  108                reply:callable).  109
  110email_open_db :-
  111    use_redis,
  112    !.
  113email_open_db :-
  114    db_attached(_),
  115    !.
  116email_open_db :-
  117    setting(database, Spec),
  118    absolute_file_name(Spec, Path, [access(write)]),
  119    db_attach(Path, [sync(close)]).

 email_cleanup_db

Strip the email confirmation queue from outdated messages.

  125email_cleanup_db :-
  126    use_redis,
  127    !.
  128email_cleanup_db :-
  129    with_mutex(swish_email, email_cleanup_db_sync).
  130
  131email_cleanup_db_sync :-
  132    get_time(Now),
  133    forall(( request(Key, Deadline, _, _),
  134             Now > Deadline
  135           ),
  136           retract_request(Key, Deadline, _, _)),
  137    db_sync(gc).
  138
  139add_request(Id, Deadline, Action, Reply) :-
  140    redis_key(Id, Server, Key),
  141    !,
  142    get_time(Now),
  143    TTL is integer(Deadline-Now),
  144    redis(Server, set(Key, request(Action, Reply) as prolog, ex, TTL)).
  145add_request(Id, Deadline, Action, Reply) :-
  146    with_mutex(swish_email,
  147               assert_request(Id, Deadline, Action, Reply)).
  148
  149get_and_del_request(Id, Deadline, Action, Reply) :-
  150    redis_key(Id, Server, Key),
  151    !,
  152    redis(Server,
  153          [ ttl(Key) -> TTL,
  154            get(Key) -> request(Action, Reply),
  155            del(Key)
  156          ]),
  157    get_time(Now),
  158    Deadline is Now+TTL.
  159get_and_del_request(Id, Deadline, Action, Reply) :-
  160    with_mutex(swish_email,
  161               retract_request(Id, Deadline, Action, Reply)).
  162
  163
  164
  165		 /*******************************
  166		 *           EMAIL		*
  167		 *******************************/

 smtp_send_html(+To, :Content, +Options)

Send an HTML mail to To using HTML content Content. Options are passed to smtp_send_mail/3, passing as default content-type text/html.

  175smtp_send_html(To, Content, Options) :-
  176    select_option(subject(Subject), Options, Options1, "<no subject>"),
  177    setting(subject_prefix, Prefix),
  178    string_concat(Prefix, Subject, Subject1),
  179    merge_options(Options1,
  180                  [ header('MIME-Version'('1.0')),
  181                    content_type(text/html)
  182                  ], Options2),
  183    smtp_send_mail(To, html_body(Content),
  184                   [ subject(Subject1)
  185                   | Options2
  186                   ]).
  187
  188html_body(Content, Out) :-
  189    phrase(html(html([ head([]),
  190                       body(Content)
  191                     ])), Tokens),
  192    print_html(Out, Tokens).

 generate_key(-Key) is det

Generate a random confirmation key

  198generate_key(Key) :-
  199    length(Codes, 16),
  200    maplist(random_between(0,255), Codes),
  201    phrase(base64url(Codes), Encoded),
  202    string_codes(Key, Encoded).
  203
  204
  205		 /*******************************
  206		 *            STYLE		*
  207		 *******************************/
  208
  209email_style -->
  210    html({|html||
  211<style>
  212address { width: 80%; text-align: right;
  213          margin-left: 18%; margin-top: 2em; border-top: 1px solid #888;}
  214</style>
  215         |}).
  216
  217
  218
  219		 /*******************************
  220		 *         PAGE ELEMENTS	*
  221		 *******************************/

 dear(+Profile)//

Address user with the given ProfileID.

  227dear(Profile) -->
  228    html(p(['Dear ', \profile_name(Profile), ','])).

 signature//

Emit footer

  234signature -->
  235    { host_url(HostURL, []) },
  236    !,
  237    html(address(['SWISH at ', a(href(HostURL), HostURL)])).
  238signature -->
  239    html(address(['SWISH'])).

 profile_name(+Profile)//

Emit the name associated with Profile as unstyled HTML.

  245profile_name(User) -->
  246    { user_field(Field),
  247      Term =.. [Field, Name],
  248      profile_property(User, Term)
  249    },
  250    html(Name).
  251
  252user_field(name).
  253user_field(given_name).
  254user_field(nick_name).
  255user_field(family_name).

 mailto(+Address)//

Insert an email link, displaying the address itself.

  261mailto(Address) -->
  262    html(a(href('mailto:'+Address), Address)).
  263
  264
  265		 /*******************************
  266		 *         ACTIVE LINKS		*
  267		 *******************************/

 email_action_link(:Label, :Reply, :Action, +Options)//

Generate a link in an HTML mail page that, when clicked, executes Action and if successful replies to the request using Reply.

  274email_action_link(Label, Reply, Action, Options) -->
  275    { email_open_db,
  276      generate_key(Key),
  277      public_url(on_mail_link, path_postfix(Key), HREF, Options),
  278      setting(timeout, TMODef),
  279      option(timeout(TMO), Options, TMODef),
  280      get_time(Now),
  281      Deadline is round(Now+TMO),
  282      add_request(Key, Deadline, Action, Reply)
  283    },
  284    html(a(href(HREF), Label)).

 on_mail_link(Request)

React on a clicked link generated by email_action_link//4.

  290on_mail_link(Request) :-
  291    email_open_db,
  292    option(path_info(Path), Request),
  293    atom_string(Path, Key),
  294    get_and_del_request(Key, Deadline, Action, Reply),
  295    !,
  296    (   get_time(Now),
  297        Now =< Deadline
  298    ->  call(Action),
  299        call(Reply, Request)
  300    ;   reply_expired(Request)
  301    ).
  302on_mail_link(Request) :-
  303    email_open_db,
  304    option(path_info(Path), Request),
  305    atom_string(Path, Key),
  306    reply_html_page(
  307        email_confirmation,
  308        title('Unknown request'),
  309        [ \email_style,
  310          p([ 'Cannot find request ~w.'-[Key], ' This typically means the \c
  311               request has already been executed, is expired or the link \c
  312               is invalid.'
  313            ]),
  314          \signature
  315        ]).
  316on_mail_link(_Request) :-
  317    throw(http_reply(bad_request(missing_key))).
  318
  319reply_expired(_Request) :-
  320    reply_html_page(
  321        email_confirmation,
  322        title('Request expired'),
  323        [ \email_style,
  324          p([ 'Your request has expired.'
  325            ]),
  326          \signature
  327        ]).

 public_url(+To, +Query, -URL, +Options) is det

True when URL is a link to handler To with Query

  334public_url(To, Query, URL, Options) :-
  335    http_link_to_id(To, Query, RequestURI),
  336    host_url(HostURL, Options),
  337    atom_concat(HostURL, RequestURI, URL).
  338
  339host_url(HostURL, Options) :-
  340    option(host_url(HostURL), Options),
  341    !.
  342host_url(HostURL, _Options) :-
  343    http_public_host_url(_Request, HostURL).
  344
  345
  346		 /*******************************
  347		 *             EVENTS		*
  348		 *******************************/
  349
  350:- listen(user_profile(modified(User, email, Old, New)),
  351          email_verify(User, Old, New)).  352
  353email_verify(_User, _Old, "") :-
  354    !.
  355email_verify(User, Old, Email) :-
  356    smtp_send_html(Email, \email_verify(User, Old, Email),
  357                   [ subject("Please verify email")
  358                   ]).
  359
  360
  361email_verify(User, "", New) -->
  362    html([ \email_style,
  363           \dear(User),
  364           p(['We have received a request to set the email account \c
  365               for SWISH to ', \mailto(New), '.' ]),
  366           ul([ li(\confirm_link(User, New))
  367              ]),
  368           \signature
  369         ]).
  370email_verify(User, Old, New) -->
  371    html([ \email_style,
  372           \dear(User),
  373           p(['We have received a request to change the email account \c
  374               for SWISH from ', \mailto(Old), ' to ', \mailto(New), '.' ]),
  375           ul([ li(\confirm_link(User, New))
  376              ]),
  377           \signature
  378         ]).
  379
  380confirm_link(User, New) -->
  381    email_action_link(["Verify email as ", New], verified_email(User, New),
  382                      verify_email(User), []).
  383
  384verify_email(User) :-
  385    set_profile(User, email_verified(true)).
  386
  387verified_email(User, NewEmail, _Request) :-
  388    reply_html_page(
  389        email_confirmation,
  390        title('SWISH -- Email verified'),
  391        [ \email_style,
  392          \dear(User),
  393          p(['Your email address ', \mailto(NewEmail), ' has been verified.']),
  394          \signature
  395        ])