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(, , ).
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(,,).
smtp(+Host)
the name or ip address for smtp host, eg. swi-prolog.orgfrom(+FromAddress)
atomic identifies sender address. Provides the default
for header(from(From)).date(+Date)
Set the date header. Default is to use the current time.subject(+Subject)
atomic: text for 'Subject:' email headerauth(User-Password)
authentication credentials, as atoms or strings.auth_method(+PlainOrLoginOrNone)
type of authentication. Default is default, alternatives
are plain and loginsecurity(Security)
one of: none, ssl, tls, starttlscontent_type(+ContentType)
sets Content-Type headermailed_by(By)
add X-Mailer: SWI-Prolog <version>, pack(smtp) to header
iff By == trueheader(from('My name,
me@server.org')) adds header "From: My name, my@server.org"
and header('FOO'(bar)) adds "FOO: bar"Defaults are provided by settings associated to this module.
Listens to debug(smtp) which for instance reports failure to
connect, (computation fails as per non-debug execution).
142smtp_send_mail(Recipients, Goal, Options) :- 143 setting(security, DefSecurity), 144 setting(host, DefHost), 145 setting(port, DefPort0), 146 option(security(Security), Options, DefSecurity), 147 default_port(Security, DefPort0, DefPort), 148 option(smtp(Host), Options, DefHost), 149 option(port(Port), Options, DefPort), 150 hostname(HostName, Options), 151 DefOptions0 = [ security(Security), 152 port(Port), 153 host(Host), 154 hostname(HostName) 155 ], 156 add_auth_method(DefOptions0, DefOptions1), 157 add_from(DefOptions1, DefOptions), 158 merge_options(DefOptions, Options, Options1), 159 debug( smtp, 'Starting smtp with options: ~w', [Options] ), 160 setup_call_cleanup( 161 smtp_open(Host:Port, In, Out, Options1), 162 do_send_mail(In, Out, Recipients, Goal, Options1), 163 smtp_close(In, Out)). 164 165add_auth_method(Options0, Options) :- 166 ( setting(auth_method, AuthMethod), 167 AuthMethod \== default 168 -> Options = [auth_method(AuthMethod)|Options0] 169 ; Options = Options0 170 ). 171 172add_from(Options0, Options) :- 173 ( setting(from, From), 174 From \== '' 175 -> Options = [from(From)|Options0] 176 ; Options = Options0 177 ).
183hostname(HostName, Options) :- 184 option(hostname(HostName), Options), 185 !. 186hostname(HostName, _) :- 187 setting(hostname, HostName), HostName \== '', 188 !. 189hostname(HostName, _) :- 190 gethostname(HostName). 191 192default_port(_, DefPort, DefPort) :- 193 DefPort > 0, 194 !. 195default_port(none, _, 25). 196default_port(ssl, _, 465). 197default_port(tls, _, 465). 198default_port(starttls, _, 587). 199 200smtp_open(Address, In, Out, Options) :- 201 setup_call_error_cleanup( 202 tcp_socket(Socket), 203 tcp_connect(Socket, Address), 204 tcp_close_socket(Socket)), 205 setup_call_error_cleanup( 206 tcp_open_socket(Socket, In0, Out0), 207 setup_ssl(Address, In0, Out0, In, Out, Options), 208 smtp_close(In0, Out0)), 209 !. 210smtp_open(Address, _In, _Out, Options) :- 211 debug(smtp, 'Failed to open connection at address: ~w, \c 212 with options: ~w', [Address,Options] ), 213 fail. 214 215setup_ssl(Address, In0, Out0, In, Out, Options) :- 216 option(security(Security), Options), 217 ssl_security(Security), 218 !, 219 Address = Host:_Port, 220 ssl_context(client, SSL, 221 [ host(Host), 222 cert_verify_hook(cert_accept_any), 223 close_parent(true) 224 ]), 225 ssl_negotiate(SSL, In0, Out0, In, Out). 226setup_ssl(_, In, Out, In, Out, _Options). 227 228ssl_security(ssl). 229ssl_security(tls). 230 231smtp_close(In, Out) :- 232 call_cleanup(close(Out), close(In)). 233 234setup_call_error_cleanup(Setup, Goal, Cleanup) :- 235 setup_call_catcher_cleanup( 236 Setup, Goal, Catcher, error_cleanup(Catcher, Cleanup)). 237 238error_cleanup(exit, _) :- !. 239error_cleanup(!, _) :- !. 240error_cleanup(_, Cleanup) :- 241 call(Cleanup).
Note that HELO is the old SMTP greeting. Modern systems greet using EHLO, telling the other side they want to speak RFC 1870 rather than the old RFC 821.
255do_send_mail(In, Out, Recipients, Goal, Options) :- 256 read_ok(In, 220), 257 option(hostname(Me), Options), 258 sock_send(Out, 'EHLO ~w\r\n', [Me]), 259 read_ok(In, 250, Lines), 260 setup_call_cleanup( 261 starttls(In, Out, In1, Out1, Lines, Lines1, Options), 262 do_send_mail_cont(In1, Out1, Recipients, Goal, Lines1, Options), 263 close_tls(In, Out, In1, Out1)). 264 265close_tls(In, Out, In, Out) :- !. 266close_tls(_, _, In, Out) :- 267 smtp_close(In, Out). 268 269do_send_mail_cont(In, Out, Recipients, Goal, Lines, Options) :- 270 ( option(from(From), Options) 271 -> true 272 ; existence_error(smtp_option, from) 273 ), 274 auth(In, Out, From, Lines, Options), 275 sock_send(Out, 'MAIL FROM:<~w>\r\n', [From]), 276 read_ok(In, 250), 277 add_recipients(In, Out, Recipients, To), 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 292add_recipients(In, Out, Recipients, To) :- 293 is_list(Recipients), 294 !, 295 atomics_to_string(Recipients, ", ", To), 296 maplist(add_recipient(In, Out), Recipients). 297add_recipients(In, Out, Recipients, To) :- 298 To = Recipients, 299 add_recipient(In, Out, Recipients). 300 301add_recipient(In, Out, To) :- 302 must_be(atomic, To), 303 sock_send(Out, 'RCPT TO:<~w>\r\n', [To]), 304 read_ok(In, 250).
311starttls(In0, Out0, In, Out, _Lines, Lines, Options) :- 312 option(security(starttls), Options), 313 !, 314 option(host(Host), Options), 315 option(port(Port), Options), 316 sock_send(Out0, 'STARTTLS\r\n', []), 317 read_ok(In0, 220), 318 ssl_context(client, SSL, 319 [ host(Host), 320 port(Port), 321 cert_verify_hook(cert_accept_any) 322 ]), 323 ssl_negotiate(SSL, In0, Out0, In, Out), 324 option(hostname(Me), Options), 325 sock_send(Out, 'EHLO ~w\r\n', [Me]), 326 read_ok(In, 250, Lines). 327starttls(In, Out, In, Out, Lines, Lines, _).
plain and login authentication methods. Authorization is
sent if the option auth is given or the settings user and
password are not the empty atom ('').
340auth(In, Out, From, Lines, Options) :- 341 ( option(auth(Auth), Options) 342 ; setting(user, User), User \== '', 343 setting(password, Password), Password \== '', 344 Auth = User-Password 345 ), 346 !, 347 auth_supported(Lines, Supported), 348 debug( smtp, 'Authentications supported: ~w, with options: ~w', [Supported,Options] ), 349 auth_p(In, Out, From, Auth, Supported, Options). 350auth(_, _, _, _, _). 351 352auth_p(In, Out, From, User-Password, Protocols, Options) :- 353 memberchk(plain, Protocols), 354 \+ option(auth_method(login), Options), 355 !, 356 atom_codes(From, FromCodes), 357 atom_codes(User, UserCodes), 358 atom_codes(Password, PwdCodes), 359 append([FromCodes, [0], UserCodes, [0], PwdCodes], Plain), 360 phrase(base64(Plain), Encoded), 361 sock_send(Out, 'AUTH PLAIN ~s\r\n', [Encoded]), 362 read_ok(In, 235). 363auth_p(In, Out, _From, User-Password, Protocols, _Options) :- 364 memberchk(login, Protocols), 365 !, 366 sock_send(Out, 'AUTH LOGIN\r\n', []), 367 read_ok(In, 334), 368 base64(User, User64), 369 sock_send(Out, '~w\r\n', [User64]), 370 read_ok(In, 334), 371 base64(Password, Password64), 372 sock_send(Out, '~w\r\n', [Password64]), 373 read_ok(In, 235). 374auth_p(_In, _Out, _From, _Auth, _Protocols, _Options) :- 375 representation_error(smtp_auth).
382auth_supported(Lines, Supported) :- 383 member(Line, Lines), 384 downcase_atom(Line, Lower), 385 atom_codes(Lower, Codes), 386 phrase(auth(Supported), Codes), 387 !. 388 389auth(Supported) --> 390 "auth", white, whites, 391 !, 392 auth_list(Supported). 393 394auth_list([H|T]) --> 395 nonblanks(Protocol), {Protocol \== []}, 396 !, 397 whites, 398 { atom_codes(H, Protocol) 399 }, 400 auth_list(T). 401auth_list([]) --> 402 whites.
format(Format, Args) to Stream and flush the
stream.
409sock_send(Stream, Fmt, Args) :-
410 format(Stream, Fmt, Args),
411 flush_output(Stream).header(from(From)) it uses the from(From)
from Options.date(Spec) it adds date(Date).422header_options(Out, Options) :- 423 add_default_header(Options, Options1), 424 emit_header(Options1, Out). 425 426add_default_header(Options0, Options) :- 427 add_date_header(Options0, Options1), 428 add_from_header(Options1, Options2), 429 add_content_type_header(Options2, Options). 430 431add_from_header(Options0, Options) :- 432 ( option(header(from(_)), Options0) 433 -> Options = Options0 434 ; option(from(From), Options0) 435 -> Options = [header(from(From))|Options0] 436 ; Options = Options0 437 ). 438 439add_date_header(Options0, Options) :- 440 ( option(date(_), Options0) 441 -> Options = Options0 442 ; Options = [date(now)|Options0] 443 ). 444 445add_content_type_header(Options0, Options) :- 446 ( option(content_type(_), Options0) 447 -> Options = Options0 448 ; Options = [content_type(text/plain)|Options0] 449 ). 450 451 452emit_header([], _). 453emit_header([H|T], Out) :- 454 header_option(H, Out), 455 emit_header(T, Out). 456 457header_option(H, Out) :- 458 H =.. [Name, Value], 459 header(Name, Label), 460 !, 461 format(Out, '~w: ~w\r\n', [Label, Value]). 462header_option(mailed_by(true), Out) :- 463 current_prolog_flag( version_data, swi(Maj,Min,Pat,_) ), 464 atomic_list_concat( [Maj,Min,Pat], '.', Vers ), 465 !, 466 format(Out, 'X-Mailer: SWI-Prolog ~a, pack(smtp)\r\n', [Vers]). 467header_option(date(Date), Out) :- 468 ( Date == now 469 -> get_time(Time) 470 ; Time = Date 471 ), 472 format_time(string(String), '%a, %d %b %Y %T %z', Time, posix), 473 format(Out, 'Date: ~w\r\n', [String]). 474header_option(header(Hdr), Out) :- 475 Hdr =.. [HdrName, Value], 476 header_key_upcase(HdrName, HdrAtom), 477 !, 478 format(Out, '~w: ~w\r\n', [HdrAtom, Value]). 479header_option(_, _). 480 481header(subject, 'Subject'). 482header(content_type, 'Content-Type'). 483 484header_key_upcase(Name, Atom) :- 485 sub_atom( Name, 0, 1, _, FirstOfName), 486 upcase_atom(FirstOfName, FirstOfAtom), 487 FirstOfAtom \== FirstOfName, 488 !, 489 sub_atom(Name, 1, _, 0, Unchanged), 490 atom_concat(FirstOfAtom, Unchanged, Atom). 491header_key_upcase(Name, Name).
501read_ok(Stream, Code) :- 502 read_ok(Stream, Code, _Reply). 503 504read_ok(Stream, Code, [Line|Rest]) :- 505 read_line_to_codes(Stream, Codes), 506 parse_line(Codes, Code, Line, Cont), 507 ( Cont == true 508 -> read_reply_cont(Stream, Code, Rest) 509 ; Rest = [] 510 ). 511 512read_reply_cont(Stream, Code, [Line|Rest]) :- 513 read_line_to_codes(Stream, Codes), 514 parse_line(Codes, Code1, Line, Cont), 515 assertion(Code == Code1), 516 ( Cont == true 517 -> read_reply_cont(Stream, Code, Rest) 518 ; Rest = [] 519 ). 520 521parse_line(Codes, Code, Line, Cont) :- 522 phrase(reply_line(Code,Line,Cont), Codes), 523 !. 524parse_line(Codes, _, _, _) :- 525 atom_codes(Atom, Codes), 526 throw(error(smtp_error(unexpected_reply(Atom)), _)). 527 528reply_line(Code, Line, Cont) --> 529 integer(Code), 530 ( "-" 531 -> {Cont = true} 532 ; " " 533 -> {Cont = false} 534 ), 535 remainder(LineCodes), 536 { atom_codes(Line, LineCodes) }
Send E-mail through SMTP
This module provides a simple means to send E-mail from a Prolog application. Here is a simple example:
send_message(Out) :- format(Out, 'Hi Alice,\n\n', []), format(Out, 'Want to go out tonight?\n\n', []), format(Out, '\tCheers, Bob\n', []). ?- smtp_send_mail('alice@wonderland.com', send_message, [ subject('Tonight'), from('bob@wonderland.com') ]). This library currently supports good old SMTP, encrypted and authorized ESMTP. Both SSL/TLS and STARTTLS encryption is supported. Authorization is supported using =PLAIN= and =LOGIN= methods. Data is currently being sent using the =DATA= keyword. @tbd Support more advanced data transport extensions such as sending MIME messages.*/