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)).

   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)]).

 email_cleanup_db

Strip the email confirmation queue from outdated messages.

  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		 *******************************/

 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.

  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).

 generate_key(-Key) is det

Generate a random confirmation key

  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		 *******************************/

 dear(+Profile)//

Address user with the given ProfileID.

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

 signature//

Emit footer

  189signature -->
  190    { host_url(HostURL, []) },
  191    !,
  192    html(address(['SWISH at ', a(href(HostURL), HostURL)])).
  193signature -->
  194    html(address(['SWISH'])).

 profile_name(+Profile)//

Emit the name associated with Profile as unstyled HTML.

  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).

 mailto(+Address)//

Insert an email link, displaying the address itself.

  216mailto(Address) -->
  217    html(a(href('mailto:'+Address), Address)).
  218
  219
  220		 /*******************************
  221		 *         ACTIVE LINKS		*
  222		 *******************************/

 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.

  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)).

 on_mail_link(Request)

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

  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        ]).

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

True when URL is a link to handler To with Query

  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        ])