1/*  Author:        Jan Wielemaker
    2    E-mail:        J.Wielemaker@vu.nl
    3    WWW:           http://www.swi-prolog.org
    4    Copyright (C): 2012-2017, VU University Amsterdam
    5                              CWI Amsterdam
    6    All rights reserved.
    7
    8    Redistribution and use in source and binary forms, with or without
    9    modification, are permitted provided that the following conditions
   10    are met:
   11
   12    1. Redistributions of source code must retain the above copyright
   13       notice, this list of conditions and the following disclaimer.
   14
   15    2. Redistributions in binary form must reproduce the above copyright
   16       notice, this list of conditions and the following disclaimer in
   17       the documentation and/or other materials provided with the
   18       distribution.
   19
   20    THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
   21    "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
   22    LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS
   23    FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE
   24    COPYRIGHT OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT,
   25    INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING,
   26    BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES;
   27    LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER
   28    CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT
   29    LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN
   30    ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
   31    POSSIBILITY OF SUCH DAMAGE.
   32*/
   33
   34:- module(smtp,
   35          [ smtp_send_mail/3            % +To, :Goal, +Options
   36          ]).   37:- use_module(library(socket)).   38:- use_module(library(ssl)).   39:- use_module(library(readutil)).   40:- use_module(library(settings)).   41:- use_module(library(option)).   42:- use_module(library(lists)).   43:- use_module(library(debug)).   44:- use_module(library(error)).   45:- use_module(library(dcg/basics)).   46
   47:- meta_predicate
   48    smtp_send_mail(+, 1, +).   49
   50/** <module> Send E-mail through SMTP
   51
   52This module provides a  simple  means  to   send  E-mail  from  a Prolog
   53application.  Here is a simple example:
   54
   55==
   56send_message(Out) :-
   57        format(Out, 'Hi Alice,\n\n', []),
   58        format(Out, 'Want to go out tonight?\n\n', []),
   59        format(Out, '\tCheers, Bob\n', []).
   60
   61
   62?- smtp_send_mail('alice@wonderland.com',
   63                  send_message,
   64                  [ subject('Tonight'),
   65                    from('bob@wonderland.com')
   66                  ]).
   67
   68This library currently supports good old  SMTP, encrypted and authorized
   69ESMTP. Both SSL/TLS and STARTTLS  encryption is supported. Authorization
   70is supported using =PLAIN= and =LOGIN= methods.
   71
   72Data is currently being sent using the =DATA= keyword.
   73
   74@tbd    Support more advanced data transport extensions such as sending
   75        MIME messages.
   76==
   77*/
   78
   79:- setting(host, atom, localhost,
   80           'Name of the SMTP host for relaying the mail').   81:- setting(port, integer, 0,
   82           'Port on which the SMTP host listens (0: default)').   83:- setting(security, oneof([none,ssl,tls,starttls]), none,
   84           'Security system to use').   85:- setting(from, atom, '',
   86           'Default from-address').   87:- setting(user, atom, '',
   88           'Default user to authenticate').   89:- setting(password, atom, '',
   90           'Default password for smtp:user').   91:- setting(auth_method, oneof([plain,login,default]), default,
   92           'Default authorization to use').   93:- setting(hostname, atom, '',
   94           'Default hostname').   95
   96:- meta_predicate
   97    setup_call_error_cleanup(0,0,0).   98
   99%!  smtp_send_mail(+To, :Goal, +Options)
  100%
  101%   Send mail using SMTP.  To is the e-mail address of the receiver.
  102%   Options:
  103%
  104%     * smtp(+Host)
  105%       the name or ip address for smtp host, eg. swi-prolog.org
  106%     * from(+FromAddress)
  107%       atomic identifies sender address.  Provides the default
  108%       for header(from(From)).
  109%     * date(+Date)
  110%       Set the date header.  Default is to use the current time.
  111%     * subject(+Subject)
  112%       atomic: text for 'Subject:' email header
  113%     * auth(User-Password)
  114%       authentication credentials, as atoms or strings.
  115%     * auth_method(+PlainOrLoginOrNone)
  116%       type of authentication. Default is =default=, alternatives
  117%       are =plain= and =login=
  118%     * security(Security)
  119%       one of: `none`, `ssl`, `tls`, `starttls`
  120%     * content_type(+ContentType)
  121%       sets =|Content-Type|= header
  122%     * mailed_by(By)
  123%       add X-Mailer: SWI-Prolog <version>, pack(smtp) to header
  124%       iff By == true
  125%     * header(Name(Val))
  126%       add HName: Val to headers. HName is Name if Name's first
  127%       letter is a capital, and it is Name after capitalising its
  128%       first letter otherwise. For instance header(from('My name,
  129%       me@server.org')) adds header "From: My name, my@server.org"
  130%       and header('FOO'(bar)) adds "FOO: bar"
  131%
  132%   Defaults are provided by settings associated to this module.
  133%
  134%   Listens to debug(smtp) which  for   instance  reports failure to
  135%   connect, (computation fails as per non-debug execution).
  136%
  137%   @arg To is an atom holding the target address
  138%   @arg Goal is called as call(Goal, Stream) and must provide
  139%        the body of the message.
  140
  141smtp_send_mail(To, Goal, Options) :-
  142    setting(security, DefSecurity),
  143    setting(host, DefHost),
  144    setting(port, DefPort0),
  145    option(security(Security), Options, DefSecurity),
  146    default_port(Security, DefPort0, DefPort),
  147    option(smtp(Host), Options, DefHost),
  148    option(port(Port), Options, DefPort),
  149    hostname(HostName, Options),
  150    DefOptions0 = [ security(Security),
  151                    port(Port),
  152                    host(Host),
  153                    hostname(HostName)
  154                  ],
  155    add_auth_method(DefOptions0, DefOptions1),
  156    add_from(DefOptions1, DefOptions),
  157    merge_options(DefOptions, Options, Options1),
  158    debug( smtp, 'Starting smtp with options: ~w', [Options] ),
  159    setup_call_cleanup(
  160        smtp_open(Host:Port, In, Out, Options1),
  161        do_send_mail(In, Out, To, Goal, Options1),
  162        smtp_close(In, Out)).
  163
  164add_auth_method(Options0, Options) :-
  165    (   setting(auth_method, AuthMethod),
  166        AuthMethod \== default
  167    ->  Options = [auth_method(AuthMethod)|Options0]
  168    ;   Options = Options0
  169    ).
  170
  171add_from(Options0, Options) :-
  172    (   setting(from, From),
  173        From \== ''
  174    ->  Options = [from(From)|Options0]
  175    ;   Options = Options0
  176    ).
  177
  178%!  hostname(-HostName, +Options) is det.
  179%
  180%   Get the hostname used to identify me.
  181
  182hostname(HostName, Options) :-
  183    option(hostname(HostName), Options),
  184    !.
  185hostname(HostName, _) :-
  186    setting(hostname, HostName), HostName \== '',
  187    !.
  188hostname(HostName, _) :-
  189    gethostname(HostName).
  190
  191default_port(_, DefPort, DefPort) :-
  192    DefPort > 0,
  193    !.
  194default_port(none,      _,  25).
  195default_port(ssl,       _, 465).
  196default_port(tls,       _, 465).
  197default_port(starttls,  _, 587).
  198
  199smtp_open(Address, In, Out, Options) :-
  200    setup_call_error_cleanup(
  201        tcp_socket(Socket),
  202        tcp_connect(Socket, Address),
  203        tcp_close_socket(Socket)),
  204    setup_call_error_cleanup(
  205        tcp_open_socket(Socket, In0, Out0),
  206        setup_ssl(Address, In0, Out0, In, Out, Options),
  207        smtp_close(In0, Out0)),
  208    !.
  209smtp_open(Address, _In, _Out, Options) :-
  210    debug(smtp, 'Failed to open connection at address: ~w, \c
  211                     with options: ~w', [Address,Options] ),
  212    fail.
  213
  214setup_ssl(Address, In0, Out0, In, Out, Options) :-
  215    option(security(Security), Options),
  216    ssl_security(Security),
  217    !,
  218    Address = Host:_Port,
  219    ssl_context(client, SSL,
  220                [ host(Host),
  221                  cert_verify_hook(cert_accept_any),
  222                  close_parent(true)
  223                ]),
  224    ssl_negotiate(SSL, In0, Out0, In, Out).
  225setup_ssl(_, In, Out, In, Out, _Options).
  226
  227ssl_security(ssl).
  228ssl_security(tls).
  229
  230smtp_close(In, Out) :-
  231    call_cleanup(close(Out), close(In)).
  232
  233setup_call_error_cleanup(Setup, Goal, Cleanup) :-
  234    setup_call_catcher_cleanup(
  235        Setup, Goal, Catcher, error_cleanup(Catcher, Cleanup)).
  236
  237error_cleanup(exit, _) :- !.
  238error_cleanup(!, _) :- !.
  239error_cleanup(_, Cleanup) :-
  240    call(Cleanup).
  241
  242%!  do_send_mail(+In, +Out, +To, :Goal, +Options) is det.
  243%
  244%   Perform the greeting and possibly upgrade   to TLS. Then proceed
  245%   using do_send_mail_cont/5.
  246%
  247%   Note that HELO is the old   SMTP  greeting. Modern systems greet
  248%   using EHLO, telling the other side they   want to speak RFC 1870
  249%   rather than the old RFC 821.
  250%
  251%   @tbd    Fall back to RFC 821 if the server does not understand
  252%           EHLO.  Probably not needed anymore?
  253
  254do_send_mail(In, Out, To, Goal, Options) :-
  255    read_ok(In, 220),
  256    option(hostname(Me), Options),
  257    sock_send(Out, 'EHLO ~w\r\n', [Me]),
  258    read_ok(In, 250, Lines),
  259    setup_call_cleanup(
  260        starttls(In, Out, In1, Out1, Lines, Lines1, Options),
  261        do_send_mail_cont(In1, Out1, To, Goal, Lines1, Options),
  262        close_tls(In, Out, In1, Out1)).
  263
  264close_tls(In, Out, In, Out) :- !.
  265close_tls(_, _, In, Out) :-
  266    smtp_close(In, Out).
  267
  268do_send_mail_cont(In, Out, To, Goal, Lines, Options) :-
  269    (   option(from(From), Options)
  270    ->  true
  271    ;   existence_error(smtp_option, from)
  272    ),
  273    auth(In, Out, From, Lines, Options),
  274    sock_send(Out, 'MAIL FROM:<~w>\r\n', [From]),
  275    read_ok(In, 250),
  276    sock_send(Out, 'RCPT TO:<~w>\r\n', [To]),
  277    read_ok(In, 250),
  278    sock_send(Out, 'DATA\r\n', []),
  279    read_ok(In, 354),
  280    format(Out, 'To: ~w\r\n', [To]),
  281    header_options(Out, Options),
  282    sock_send(Out, '\r\n', []),
  283    call(Goal, Out),
  284    sock_send(Out, '\r\n.\r\n', []),
  285    read_ok(In, 250),
  286    !.
  287do_send_mail_cont(_In, _Out, To, _Goal, _Lines, Options ) :-
  288    debug(smtp, 'Failed to sent email To: ~w, with options: ~w',
  289          [To,Options]),
  290    fail.
  291
  292%!  starttls(+In0, +Out0, -In, -Out, +LinesIn, -LinesOut, +Options)
  293%
  294%   @tbd    Verify starttls is in Lines.
  295
  296starttls(In0, Out0, In, Out, _Lines, Lines, Options) :-
  297    option(security(starttls), Options),
  298    !,
  299    option(host(Host), Options),
  300    option(port(Port), Options),
  301    sock_send(Out0, 'STARTTLS\r\n', []),
  302    read_ok(In0, 220),
  303    ssl_context(client, SSL,
  304                [ host(Host),
  305                  port(Port),
  306                  cert_verify_hook(cert_accept_any)
  307                ]),
  308    ssl_negotiate(SSL, In0, Out0, In, Out),
  309    option(hostname(Me), Options),
  310    sock_send(Out, 'EHLO ~w\r\n', [Me]),
  311    read_ok(In, 250, Lines).
  312starttls(In, Out, In, Out, Lines, Lines, _).
  313
  314
  315%!  auth(+In, +Out, +From, +Lines, +Options)
  316%
  317%   Negotiate authentication with the server. Currently supports the
  318%   =plain= and =login=  authentication   methods.  Authorization is
  319%   sent if the option =auth= is given   or  the settings =user= and
  320%   =password= are not the empty atom ('').
  321%
  322%   @param  Lines is the result of read_ok/3 on the EHLO command,
  323%           which tells us which authorizations are supported.
  324
  325auth(In, Out, From, Lines, Options) :-
  326    (   option(auth(Auth), Options)
  327    ;   setting(user, User), User \== '',
  328        setting(password, Password), Password \== '',
  329        Auth = User-Password
  330    ),
  331    !,
  332    auth_supported(Lines, Supported),
  333    debug( smtp, 'Authentications supported: ~w, with options: ~w', [Supported,Options] ),
  334    auth_p(In, Out, From, Auth, Supported, Options).
  335auth(_, _, _, _, _).
  336
  337auth_p(In, Out, From, User-Password, Protocols, Options) :-
  338    memberchk(plain, Protocols),
  339    \+ option(auth_method(login), Options),
  340    !,
  341    atom_codes(From, FromCodes),
  342    atom_codes(User, UserCodes),
  343    atom_codes(Password, PwdCodes),
  344    append([FromCodes, [0], UserCodes, [0], PwdCodes], Plain),
  345    phrase(base64(Plain), Encoded),
  346    sock_send(Out, 'AUTH PLAIN ~s\r\n', [Encoded]),
  347    read_ok(In, 235).
  348auth_p(In, Out, _From, User-Password, Protocols, _Options) :-
  349    memberchk(login, Protocols),
  350    !,
  351    sock_send(Out, 'AUTH LOGIN\r\n', []),
  352    read_ok(In, 334),
  353    base64(User, User64),
  354    sock_send(Out, '~w\r\n', [User64]),
  355    read_ok(In, 334),
  356    base64(Password, Password64),
  357    sock_send(Out, '~w\r\n', [Password64]),
  358    read_ok(In, 235).
  359auth_p(_In, _Out, _From, _Auth, _Protocols, _Options) :-
  360    representation_error(smtp_auth).
  361
  362%!  auth_supported(+Lines, -Supported)
  363%
  364%   True  when  Supported  is  a  list  of  supported  authorization
  365%   protocols.
  366
  367auth_supported(Lines, Supported) :-
  368    member(Line, Lines),
  369    downcase_atom(Line, Lower),
  370    atom_codes(Lower, Codes),
  371    phrase(auth(Supported), Codes),
  372    !.
  373
  374auth(Supported) -->
  375    "auth", white, whites,
  376    !,
  377    auth_list(Supported).
  378
  379auth_list([H|T]) -->
  380    nonblanks(Protocol), {Protocol \== []},
  381    !,
  382    whites,
  383    { atom_codes(H, Protocol)
  384    },
  385    auth_list(T).
  386auth_list([]) -->
  387    whites.
  388
  389%!  sock_send(+Stream, +Format, +Args) is det.
  390%
  391%   Send the output of format(Format, Args)  to Stream and flush the
  392%   stream.
  393
  394sock_send(Stream, Fmt, Args) :-
  395    format(Stream, Fmt, Args),
  396    flush_output(Stream).
  397
  398%!  header_options(+Out, +Options) is det.
  399%
  400%   Send  SMTP  headers  from  provided  Options.  First  adds  some
  401%   defaults, notably:
  402%
  403%     - If there is no header(from(From)) it uses the from(From)
  404%       from Options.
  405%     - If there is no date(Spec) it adds date(Date).
  406
  407header_options(Out, Options) :-
  408    add_default_header(Options, Options1),
  409    emit_header(Options1, Out).
  410
  411add_default_header(Options0, Options) :-
  412    add_date_header(Options0, Options1),
  413    add_from_header(Options1, Options2),
  414    add_content_type_header(Options2, Options).
  415
  416add_from_header(Options0, Options) :-
  417    (   option(header(from(_)), Options0)
  418    ->  Options = Options0
  419    ;   option(from(From), Options0)
  420    ->  Options = [header(from(From))|Options0]
  421    ;   Options = Options0
  422    ).
  423
  424add_date_header(Options0, Options) :-
  425    (   option(date(_), Options0)
  426    ->  Options = Options0
  427    ;   Options = [date(now)|Options0]
  428    ).
  429
  430add_content_type_header(Options0, Options) :-
  431    (   option(content_type(_), Options0)
  432    ->  Options = Options0
  433    ;   Options = [content_type(text/plain)|Options0]
  434    ).
  435
  436
  437emit_header([], _).
  438emit_header([H|T], Out) :-
  439    header_option(H, Out),
  440    emit_header(T, Out).
  441
  442header_option(H, Out) :-
  443    H =.. [Name, Value],
  444    header(Name, Label),
  445    !,
  446    format(Out, '~w: ~w\r\n', [Label, Value]).
  447header_option(mailed_by(true), Out) :-
  448    current_prolog_flag( version_data, swi(Maj,Min,Pat,_) ),
  449    atomic_list_concat( [Maj,Min,Pat], '.', Vers ),
  450    !,
  451    format(Out, 'X-Mailer: SWI-Prolog ~a, pack(smtp)\r\n', [Vers]).
  452header_option(date(Date), Out) :-
  453    (   Date == now
  454    ->  get_time(Time)
  455    ;   Time = Date
  456    ),
  457    format_time(string(String), '%a, %d %b %Y %T %z', Time),
  458    format(Out, 'Date: ~w\r\n', [String]).
  459header_option(header(Hdr), Out) :-
  460    Hdr =.. [HdrName, Value],
  461    header_key_upcase(HdrName, HdrAtom),
  462    !,
  463    format(Out, '~w: ~w\r\n', [HdrAtom, Value]).
  464header_option(_, _).
  465
  466header(subject, 'Subject').
  467header(content_type, 'Content-Type').
  468
  469header_key_upcase(Name, Atom) :-
  470    sub_atom( Name, 0, 1, _, FirstOfName),
  471    upcase_atom(FirstOfName, FirstOfAtom),
  472    FirstOfAtom \== FirstOfName,
  473    !,
  474    sub_atom(Name, 1, _, 0, Unchanged),
  475    atom_concat(FirstOfAtom, Unchanged, Atom).
  476header_key_upcase(Name, Name).
  477
  478
  479%!  read_ok(+Stream, ?Code) is semidet.
  480%!  read_ok(+Stream, ?Code, -Lines) is semidet.
  481%
  482%   True if the server replies  with   Code.  The  version read_ok/3
  483%   returns the server comment lines, one atom per line. The numeric
  484%   code has been stripped from the lines.
  485
  486read_ok(Stream, Code) :-
  487    read_ok(Stream, Code, _Reply).
  488
  489read_ok(Stream, Code, [Line|Rest]) :-
  490    read_line_to_codes(Stream, Codes),
  491    parse_line(Codes, Code, Line, Cont),
  492    (   Cont == true
  493    ->  read_reply_cont(Stream, Code, Rest)
  494    ;   Rest = []
  495    ).
  496
  497read_reply_cont(Stream, Code, [Line|Rest]) :-
  498    read_line_to_codes(Stream, Codes),
  499    parse_line(Codes, Code1, Line, Cont),
  500    assertion(Code == Code1),
  501    (   Cont == true
  502    ->  read_reply_cont(Stream, Code, Rest)
  503    ;   Rest = []
  504    ).
  505
  506parse_line(Codes, Code, Line, Cont) :-
  507    phrase(reply_line(Code,Line,Cont), Codes),
  508    !.
  509parse_line(Codes, _, _, _) :-
  510    atom_codes(Atom, Codes),
  511    throw(error(smtp_error(unexpected_reply(Atom)), _)).
  512
  513reply_line(Code, Line, Cont) -->
  514    integer(Code),
  515    (   "-"
  516    ->  {Cont = true}
  517    ;   " "
  518    ->  {Cont = false}
  519    ),
  520    remainder(LineCodes),
  521    { atom_codes(Line, LineCodes) }