1 |
;;; smtpmail.el --- simple SMTP protocol (RFC 821) for sending mail |
2 |
|
3 |
;; Copyright (C) 1995, 1996, 2001, 2002, 2003, 2004, 2005, 2006, 2007, |
4 |
;; 2008, 2009 Free Software Foundation, Inc. |
5 |
|
6 |
;; Author: Tomoji Kagatani <kagatani@rbc.ncl.omron.co.jp> |
7 |
;; Maintainer: Simon Josefsson <simon@josefsson.org> |
8 |
;; w32 Maintainer: Brian D. Carlstrom <bdc@ai.mit.edu> |
9 |
;; ESMTP support: Simon Leinen <simon@switch.ch> |
10 |
;; Hacked by Mike Taylor, 11th October 1999 to add support for |
11 |
;; automatically appending a domain to RCPT TO: addresses. |
12 |
;; AUTH=LOGIN support: Stephen Cranefield <scranefield@infoscience.otago.ac.nz> |
13 |
;; Keywords: mail |
14 |
|
15 |
;; This file is part of GNU Emacs. |
16 |
|
17 |
;; GNU Emacs is free software: you can redistribute it and/or modify |
18 |
;; it under the terms of the GNU General Public License as published by |
19 |
;; the Free Software Foundation, either version 3 of the License, or |
20 |
;; (at your option) any later version. |
21 |
|
22 |
;; GNU Emacs is distributed in the hope that it will be useful, |
23 |
;; but WITHOUT ANY WARRANTY; without even the implied warranty of |
24 |
;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the |
25 |
;; GNU General Public License for more details. |
26 |
|
27 |
;; You should have received a copy of the GNU General Public License |
28 |
;; along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>. |
29 |
|
30 |
;;; Commentary: |
31 |
|
32 |
;; Send Mail to smtp host from smtpmail temp buffer. |
33 |
|
34 |
;; Please add these lines in your .emacs(_emacs) or use customize. |
35 |
;; |
36 |
;;(setq send-mail-function 'smtpmail-send-it) ; if you use `mail' |
37 |
;;(setq message-send-mail-function 'smtpmail-send-it) ; if you use message/Gnus |
38 |
;;(setq smtpmail-default-smtp-server "YOUR SMTP HOST") |
39 |
;;(setq smtpmail-local-domain "YOUR DOMAIN NAME") |
40 |
;;(setq smtpmail-sendto-domain "YOUR DOMAIN NAME") |
41 |
;;(setq smtpmail-debug-info t) ; only to debug problems |
42 |
;;(setq smtpmail-auth-credentials ; or use ~/.authinfo |
43 |
;; '(("YOUR SMTP HOST" 25 "username" "password"))) |
44 |
;;(setq smtpmail-starttls-credentials |
45 |
;; '(("YOUR SMTP HOST" 25 "~/.my_smtp_tls.key" "~/.my_smtp_tls.cert"))) |
46 |
;; Where the 25 equals the value of `smtpmail-smtp-service', it can be an |
47 |
;; integer or a string, just as long as they match (eq). |
48 |
|
49 |
;; To queue mail, set `smtpmail-queue-mail' to t and use |
50 |
;; `smtpmail-send-queued-mail' to send. |
51 |
|
52 |
;; Modified by Stephen Cranefield <scranefield@infoscience.otago.ac.nz>, |
53 |
;; 22/6/99, to support SMTP Authentication by the AUTH=LOGIN mechanism. |
54 |
;; See http://help.netscape.com/products/server/messaging/3x/info/smtpauth.html |
55 |
;; Rewritten by Simon Josefsson to use same credential variable as AUTH |
56 |
;; support below. |
57 |
|
58 |
;; Modified by Simon Josefsson <jas@pdc.kth.se>, 22/2/99, to support SMTP |
59 |
;; Authentication by the AUTH mechanism. |
60 |
;; See http://www.ietf.org/rfc/rfc2554.txt |
61 |
|
62 |
;; Modified by Simon Josefsson <simon@josefsson.org>, 2000-10-07, to support |
63 |
;; STARTTLS. Requires external program |
64 |
;; ftp://ftp.opaopa.org/pub/elisp/starttls-*.tar.gz. |
65 |
;; See http://www.ietf.org/rfc/rfc2246.txt, http://www.ietf.org/rfc/rfc2487.txt |
66 |
|
67 |
;;; Code: |
68 |
|
69 |
(require 'sendmail) |
70 |
(autoload 'starttls-any-program-available "starttls") |
71 |
(autoload 'starttls-open-stream "starttls") |
72 |
(autoload 'starttls-negotiate "starttls") |
73 |
(autoload 'mail-strip-quoted-names "mail-utils") |
74 |
(autoload 'message-make-date "message") |
75 |
(autoload 'message-make-message-id "message") |
76 |
(autoload 'rfc2104-hash "rfc2104") |
77 |
(autoload 'netrc-parse "netrc") |
78 |
(autoload 'netrc-machine "netrc") |
79 |
(autoload 'netrc-get "netrc") |
80 |
(autoload 'password-read "password-cache") |
81 |
(autoload 'auth-source-user-or-password "auth-source") |
82 |
|
83 |
;;; |
84 |
(defgroup smtpmail nil |
85 |
"SMTP protocol for sending mail." |
86 |
:group 'mail) |
87 |
|
88 |
|
89 |
(defcustom smtpmail-default-smtp-server nil |
90 |
"Specify default SMTP server. |
91 |
This only has effect if you specify it before loading the smtpmail library." |
92 |
:type '(choice (const nil) string) |
93 |
:group 'smtpmail) |
94 |
|
95 |
(defcustom smtpmail-smtp-server |
96 |
(or (getenv "SMTPSERVER") smtpmail-default-smtp-server) |
97 |
"The name of the host running SMTP server." |
98 |
:type '(choice (const nil) string) |
99 |
:group 'smtpmail) |
100 |
|
101 |
(defcustom smtpmail-smtp-service 25 |
102 |
"SMTP service port number. |
103 |
The default value would be \"smtp\" or 25." |
104 |
:type '(choice (integer :tag "Port") (string :tag "Service")) |
105 |
:group 'smtpmail) |
106 |
|
107 |
(defcustom smtpmail-local-domain nil |
108 |
"Local domain name without a host name. |
109 |
If the function `system-name' returns the full internet address, |
110 |
don't define this value." |
111 |
:type '(choice (const nil) string) |
112 |
:group 'smtpmail) |
113 |
|
114 |
(defcustom smtpmail-sendto-domain nil |
115 |
"Local domain name without a host name. |
116 |
This is appended (with an @-sign) to any specified recipients which do |
117 |
not include an @-sign, so that each RCPT TO address is fully qualified. |
118 |
\(Some configurations of sendmail require this.) |
119 |
|
120 |
Don't bother to set this unless you have get an error like: |
121 |
Sending failed; SMTP protocol error |
122 |
when sending mail, and the *trace of SMTP session to <somewhere>* |
123 |
buffer includes an exchange like: |
124 |
RCPT TO: <someone> |
125 |
501 <someone>: recipient address must contain a domain." |
126 |
:type '(choice (const nil) string) |
127 |
:group 'smtpmail) |
128 |
|
129 |
(defcustom smtpmail-debug-info nil |
130 |
"Whether to print info in buffer *trace of SMTP session to <somewhere>*. |
131 |
See also `smtpmail-debug-verb' which determines if the SMTP protocol should |
132 |
be verbose as well." |
133 |
:type 'boolean |
134 |
:group 'smtpmail) |
135 |
|
136 |
(defcustom smtpmail-debug-verb nil |
137 |
"Whether this library sends the SMTP VERB command or not. |
138 |
The commands enables verbose information from the SMTP server." |
139 |
:type 'boolean |
140 |
:group 'smtpmail) |
141 |
|
142 |
(defcustom smtpmail-code-conv-from nil |
143 |
"Coding system for encoding outgoing mail. |
144 |
Used for the value of `sendmail-coding-system' when |
145 |
`select-message-coding-system' is called. " |
146 |
:type 'coding-system |
147 |
:group 'smtpmail) |
148 |
|
149 |
(defcustom smtpmail-queue-mail nil |
150 |
"Non-nil means mail is queued; otherwise it is sent immediately. |
151 |
If queued, it is stored in the directory `smtpmail-queue-dir' |
152 |
and sent with `smtpmail-send-queued-mail'." |
153 |
:type 'boolean |
154 |
:group 'smtpmail) |
155 |
|
156 |
(defcustom smtpmail-queue-dir "~/Mail/queued-mail/" |
157 |
"Directory where `smtpmail.el' stores queued mail." |
158 |
:type 'directory |
159 |
:group 'smtpmail) |
160 |
|
161 |
(defcustom smtpmail-auth-credentials "~/.authinfo" |
162 |
"Specify username and password for servers, directly or via .netrc file. |
163 |
This variable can either be a filename pointing to a file in netrc(5) |
164 |
format, or list of four-element lists that contain, in order, |
165 |
`servername' (a string), `port' (an integer), `user' (a string) and |
166 |
`password' (a string, or nil to query the user when needed). If you |
167 |
need to enter a `realm' too, add it to the user string, so that it |
168 |
looks like `user@realm'." |
169 |
:type '(choice file |
170 |
(repeat (list (string :tag "Server") |
171 |
(integer :tag "Port") |
172 |
(string :tag "Username") |
173 |
(choice (const :tag "Query when needed" nil) |
174 |
(string :tag "Password"))))) |
175 |
:version "22.1" |
176 |
:group 'smtpmail) |
177 |
|
178 |
(defcustom smtpmail-starttls-credentials '(("" 25 "" "")) |
179 |
"Specify STARTTLS keys and certificates for servers. |
180 |
This is a list of four-element list with `servername' (a string), |
181 |
`port' (an integer), `key' (a filename) and `certificate' (a |
182 |
filename). |
183 |
If you do not have a certificate/key pair, leave the `key' and |
184 |
`certificate' fields as `nil'. A key/certificate pair is only |
185 |
needed if you want to use X.509 client authenticated |
186 |
connections." |
187 |
:type '(repeat (list (string :tag "Server") |
188 |
(integer :tag "Port") |
189 |
(file :tag "Key") |
190 |
(file :tag "Certificate"))) |
191 |
:version "21.1" |
192 |
:group 'smtpmail) |
193 |
|
194 |
(defcustom smtpmail-warn-about-unknown-extensions nil |
195 |
"If set, print warnings about unknown SMTP extensions. |
196 |
This is mainly useful for development purposes, to learn about |
197 |
new SMTP extensions that might be useful to support." |
198 |
:type 'boolean |
199 |
:version "21.1" |
200 |
:group 'smtpmail) |
201 |
|
202 |
(defcustom smtpmail-queue-index-file "index" |
203 |
"File name of queued mail index. |
204 |
This is relative to `smtpmail-queue-dir'." |
205 |
:type 'string |
206 |
:group 'smtpmail) |
207 |
|
208 |
;; End of customizable variables. |
209 |
|
210 |
|
211 |
(defvar smtpmail-address-buffer) |
212 |
(defvar smtpmail-recipient-address-list) |
213 |
|
214 |
(defvar smtpmail-queue-counter 0) |
215 |
|
216 |
;; Buffer-local variable. |
217 |
(defvar smtpmail-read-point) |
218 |
|
219 |
(defconst smtpmail-auth-supported '(cram-md5 plain login) |
220 |
"List of supported SMTP AUTH mechanisms. |
221 |
The list is in preference order.") |
222 |
|
223 |
(defvar smtpmail-mail-address nil |
224 |
"Value to use for envelope-from address for mail from ambient buffer.") |
225 |
|
226 |
;;;###autoload |
227 |
(defun smtpmail-send-it () |
228 |
(let ((errbuf (if mail-interactive |
229 |
(generate-new-buffer " smtpmail errors") |
230 |
0)) |
231 |
(tembuf (generate-new-buffer " smtpmail temp")) |
232 |
(case-fold-search nil) |
233 |
delimline |
234 |
(mailbuf (current-buffer)) |
235 |
;; Examine this variable now, so that |
236 |
;; local binding in the mail buffer will take effect. |
237 |
(smtpmail-mail-address |
238 |
(or (and mail-specify-envelope-from (mail-envelope-from)) |
239 |
user-mail-address)) |
240 |
(smtpmail-code-conv-from |
241 |
(if enable-multibyte-characters |
242 |
(let ((sendmail-coding-system smtpmail-code-conv-from)) |
243 |
(select-message-coding-system))))) |
244 |
(unwind-protect |
245 |
(with-current-buffer tembuf |
246 |
(erase-buffer) |
247 |
;; Use the same `buffer-file-coding-system' as in the mail |
248 |
;; buffer, otherwise any `write-region' invocations (e.g., in |
249 |
;; mail-do-fcc below) will annoy with asking for a suitable |
250 |
;; encoding. |
251 |
(set-buffer-file-coding-system smtpmail-code-conv-from nil t) |
252 |
(insert-buffer-substring mailbuf) |
253 |
(goto-char (point-max)) |
254 |
;; require one newline at the end. |
255 |
(or (= (preceding-char) ?\n) |
256 |
(insert ?\n)) |
257 |
;; Change header-delimiter to be what sendmail expects. |
258 |
(mail-sendmail-undelimit-header) |
259 |
(setq delimline (point-marker)) |
260 |
;; (sendmail-synch-aliases) |
261 |
(if mail-aliases |
262 |
(expand-mail-aliases (point-min) delimline)) |
263 |
(goto-char (point-min)) |
264 |
;; ignore any blank lines in the header |
265 |
(while (and (re-search-forward "\n\n\n*" delimline t) |
266 |
(< (point) delimline)) |
267 |
(replace-match "\n")) |
268 |
(let ((case-fold-search t)) |
269 |
;; We used to process Resent-... headers here, |
270 |
;; but it was not done properly, and the job |
271 |
;; is done correctly in `smtpmail-deduce-address-list'. |
272 |
;; Don't send out a blank subject line |
273 |
(goto-char (point-min)) |
274 |
(if (re-search-forward "^Subject:\\([ \t]*\n\\)+\\b" delimline t) |
275 |
(replace-match "") |
276 |
;; This one matches a Subject just before the header delimiter. |
277 |
(if (and (re-search-forward "^Subject:\\([ \t]*\n\\)+" delimline t) |
278 |
(= (match-end 0) delimline)) |
279 |
(replace-match ""))) |
280 |
;; Put the "From:" field in unless for some odd reason |
281 |
;; they put one in themselves. |
282 |
(goto-char (point-min)) |
283 |
(if (not (re-search-forward "^From:" delimline t)) |
284 |
(let* ((login smtpmail-mail-address) |
285 |
(fullname (user-full-name))) |
286 |
(cond ((eq mail-from-style 'angles) |
287 |
(insert "From: " fullname) |
288 |
(let ((fullname-start (+ (point-min) 6)) |
289 |
(fullname-end (point-marker))) |
290 |
(goto-char fullname-start) |
291 |
;; Look for a character that cannot appear unquoted |
292 |
;; according to RFC 822. |
293 |
(if (re-search-forward "[^- !#-'*+/-9=?A-Z^-~]" |
294 |
fullname-end 1) |
295 |
(progn |
296 |
;; Quote fullname, escaping specials. |
297 |
(goto-char fullname-start) |
298 |
(insert "\"") |
299 |
(while (re-search-forward "[\"\\]" |
300 |
fullname-end 1) |
301 |
(replace-match "\\\\\\&" t)) |
302 |
(insert "\"")))) |
303 |
(insert " <" login ">\n")) |
304 |
((eq mail-from-style 'parens) |
305 |
(insert "From: " login " (") |
306 |
(let ((fullname-start (point))) |
307 |
(insert fullname) |
308 |
(let ((fullname-end (point-marker))) |
309 |
(goto-char fullname-start) |
310 |
;; RFC 822 says \ and nonmatching parentheses |
311 |
;; must be escaped in comments. |
312 |
;; Escape every instance of ()\ ... |
313 |
(while (re-search-forward "[()\\]" fullname-end 1) |
314 |
(replace-match "\\\\\\&" t)) |
315 |
;; ... then undo escaping of matching parentheses, |
316 |
;; including matching nested parentheses. |
317 |
(goto-char fullname-start) |
318 |
(while (re-search-forward |
319 |
"\\(\\=\\|[^\\]\\(\\\\\\\\\\)*\\)\\\\(\\(\\([^\\]\\|\\\\\\\\\\)*\\)\\\\)" |
320 |
fullname-end 1) |
321 |
(replace-match "\\1(\\3)" t) |
322 |
(goto-char fullname-start)))) |
323 |
(insert ")\n")) |
324 |
((null mail-from-style) |
325 |
(insert "From: " login "\n"))))) |
326 |
;; Insert a `Message-Id:' field if there isn't one yet. |
327 |
(goto-char (point-min)) |
328 |
(unless (re-search-forward "^Message-Id:" delimline t) |
329 |
(insert "Message-Id: " (message-make-message-id) "\n")) |
330 |
;; Insert a `Date:' field if there isn't one yet. |
331 |
(goto-char (point-min)) |
332 |
(unless (re-search-forward "^Date:" delimline t) |
333 |
(insert "Date: " (message-make-date) "\n")) |
334 |
;; Possibly add a MIME header for the current coding system |
335 |
(let (charset) |
336 |
(goto-char (point-min)) |
337 |
(and (eq mail-send-nonascii 'mime) |
338 |
(not (re-search-forward "^MIME-version:" delimline t)) |
339 |
(progn (skip-chars-forward "\0-\177") |
340 |
(/= (point) (point-max))) |
341 |
smtpmail-code-conv-from |
342 |
(setq charset |
343 |
(coding-system-get smtpmail-code-conv-from |
344 |
'mime-charset)) |
345 |
(goto-char delimline) |
346 |
(insert "MIME-version: 1.0\n" |
347 |
"Content-type: text/plain; charset=" |
348 |
(symbol-name charset) |
349 |
"\nContent-Transfer-Encoding: 8bit\n"))) |
350 |
;; Insert an extra newline if we need it to work around |
351 |
;; Sun's bug that swallows newlines. |
352 |
(goto-char (1+ delimline)) |
353 |
(if (eval mail-mailer-swallows-blank-line) |
354 |
(newline)) |
355 |
;; Find and handle any FCC fields. |
356 |
(goto-char (point-min)) |
357 |
(if (re-search-forward "^FCC:" delimline t) |
358 |
;; Force `mail-do-fcc' to use the encoding of the mail |
359 |
;; buffer to encode outgoing messages on FCC files. |
360 |
(let ((coding-system-for-write smtpmail-code-conv-from)) |
361 |
(mail-do-fcc delimline))) |
362 |
(if mail-interactive |
363 |
(with-current-buffer errbuf |
364 |
(erase-buffer)))) |
365 |
;; |
366 |
(setq smtpmail-address-buffer (generate-new-buffer "*smtp-mail*")) |
367 |
(setq smtpmail-recipient-address-list |
368 |
(smtpmail-deduce-address-list tembuf (point-min) delimline)) |
369 |
(kill-buffer smtpmail-address-buffer) |
370 |
|
371 |
(smtpmail-do-bcc delimline) |
372 |
;; Send or queue |
373 |
(if (not smtpmail-queue-mail) |
374 |
(if (not (null smtpmail-recipient-address-list)) |
375 |
(if (not (smtpmail-via-smtp |
376 |
smtpmail-recipient-address-list tembuf)) |
377 |
(error "Sending failed; SMTP protocol error")) |
378 |
(error "Sending failed; no recipients")) |
379 |
(let* ((file-data |
380 |
(expand-file-name |
381 |
(format "%s_%i" |
382 |
(format-time-string "%Y-%m-%d_%H:%M:%S") |
383 |
(setq smtpmail-queue-counter |
384 |
(1+ smtpmail-queue-counter))) |
385 |
smtpmail-queue-dir)) |
386 |
(file-data (convert-standard-filename file-data)) |
387 |
(file-elisp (concat file-data ".el")) |
388 |
(buffer-data (create-file-buffer file-data)) |
389 |
(buffer-elisp (create-file-buffer file-elisp)) |
390 |
(buffer-scratch "*queue-mail*")) |
391 |
(unless (file-exists-p smtpmail-queue-dir) |
392 |
(make-directory smtpmail-queue-dir t)) |
393 |
(with-current-buffer buffer-data |
394 |
(erase-buffer) |
395 |
(set-buffer-file-coding-system smtpmail-code-conv-from nil t) |
396 |
(insert-buffer-substring tembuf) |
397 |
(write-file file-data) |
398 |
(set-buffer buffer-elisp) |
399 |
(erase-buffer) |
400 |
(insert (concat |
401 |
"(setq smtpmail-recipient-address-list '" |
402 |
(prin1-to-string smtpmail-recipient-address-list) |
403 |
")\n")) |
404 |
(write-file file-elisp) |
405 |
(set-buffer (generate-new-buffer buffer-scratch)) |
406 |
(insert (concat file-data "\n")) |
407 |
(append-to-file (point-min) |
408 |
(point-max) |
409 |
(expand-file-name smtpmail-queue-index-file |
410 |
smtpmail-queue-dir))) |
411 |
(kill-buffer buffer-scratch) |
412 |
(kill-buffer buffer-data) |
413 |
(kill-buffer buffer-elisp)))) |
414 |
(kill-buffer tembuf) |
415 |
(if (bufferp errbuf) |
416 |
(kill-buffer errbuf))))) |
417 |
|
418 |
;;;###autoload |
419 |
(defun smtpmail-send-queued-mail () |
420 |
"Send mail that was queued as a result of setting `smtpmail-queue-mail'." |
421 |
(interactive) |
422 |
(with-temp-buffer |
423 |
;; Get index, get first mail, send it, update index, get second |
424 |
;; mail, send it, etc... |
425 |
(let ((file-msg "") |
426 |
(qfile (expand-file-name smtpmail-queue-index-file |
427 |
smtpmail-queue-dir))) |
428 |
(insert-file-contents qfile) |
429 |
(goto-char (point-min)) |
430 |
(while (not (eobp)) |
431 |
(setq file-msg (buffer-substring (point) (line-end-position))) |
432 |
(load file-msg) |
433 |
;; Insert the message literally: it is already encoded as per |
434 |
;; the MIME headers, and code conversions might guess the |
435 |
;; encoding wrongly. |
436 |
(with-temp-buffer |
437 |
(let ((coding-system-for-read 'no-conversion)) |
438 |
(insert-file-contents file-msg)) |
439 |
(let ((smtpmail-mail-address |
440 |
(or (and mail-specify-envelope-from (mail-envelope-from)) |
441 |
user-mail-address))) |
442 |
(if (not (null smtpmail-recipient-address-list)) |
443 |
(if (not (smtpmail-via-smtp smtpmail-recipient-address-list |
444 |
(current-buffer))) |
445 |
(error "Sending failed; SMTP protocol error")) |
446 |
(error "Sending failed; no recipients")))) |
447 |
(delete-file file-msg) |
448 |
(delete-file (concat file-msg ".el")) |
449 |
(delete-region (point-at-bol) (point-at-bol 2))) |
450 |
(write-region (point-min) (point-max) qfile)))) |
451 |
|
452 |
;; (defun smtpmail-via-smtp (host,port,sender,destination,smtpmail-text-buffer) |
453 |
|
454 |
(defun smtpmail-fqdn () |
455 |
(if smtpmail-local-domain |
456 |
(concat (system-name) "." smtpmail-local-domain) |
457 |
(system-name))) |
458 |
|
459 |
(defsubst smtpmail-cred-server (cred) |
460 |
(nth 0 cred)) |
461 |
|
462 |
(defsubst smtpmail-cred-port (cred) |
463 |
(nth 1 cred)) |
464 |
|
465 |
(defsubst smtpmail-cred-key (cred) |
466 |
(nth 2 cred)) |
467 |
|
468 |
(defsubst smtpmail-cred-user (cred) |
469 |
(nth 2 cred)) |
470 |
|
471 |
(defsubst smtpmail-cred-cert (cred) |
472 |
(nth 3 cred)) |
473 |
|
474 |
(defsubst smtpmail-cred-passwd (cred) |
475 |
(nth 3 cred)) |
476 |
|
477 |
(defun smtpmail-find-credentials (cred server port) |
478 |
(catch 'done |
479 |
(let ((l cred) el) |
480 |
(while (setq el (pop l)) |
481 |
(when (and (equal server (smtpmail-cred-server el)) |
482 |
(equal port (smtpmail-cred-port el))) |
483 |
(throw 'done el)))))) |
484 |
|
485 |
(defun smtpmail-maybe-append-domain (recipient) |
486 |
(if (or (not smtpmail-sendto-domain) |
487 |
(string-match "@" recipient)) |
488 |
recipient |
489 |
(concat recipient "@" smtpmail-sendto-domain))) |
490 |
|
491 |
(defun smtpmail-intersection (list1 list2) |
492 |
(let ((result nil)) |
493 |
(dolist (el2 list2) |
494 |
(when (memq el2 list1) |
495 |
(push el2 result))) |
496 |
(nreverse result))) |
497 |
|
498 |
(defvar starttls-extra-args) |
499 |
(defvar starttls-extra-arguments) |
500 |
|
501 |
(defun smtpmail-open-stream (process-buffer host port) |
502 |
(let ((cred (smtpmail-find-credentials |
503 |
smtpmail-starttls-credentials host port))) |
504 |
(if (null (and cred (starttls-any-program-available))) |
505 |
;; The normal case. |
506 |
(open-network-stream "SMTP" process-buffer host port) |
507 |
(let* ((cred-key (smtpmail-cred-key cred)) |
508 |
(cred-cert (smtpmail-cred-cert cred)) |
509 |
(starttls-extra-args |
510 |
(append |
511 |
starttls-extra-args |
512 |
(when (and (stringp cred-key) (stringp cred-cert) |
513 |
(file-regular-p |
514 |
(setq cred-key (expand-file-name cred-key))) |
515 |
(file-regular-p |
516 |
(setq cred-cert (expand-file-name cred-cert)))) |
517 |
(list "--key-file" cred-key "--cert-file" cred-cert)))) |
518 |
(starttls-extra-arguments |
519 |
(append |
520 |
starttls-extra-arguments |
521 |
(when (and (stringp cred-key) (stringp cred-cert) |
522 |
(file-regular-p |
523 |
(setq cred-key (expand-file-name cred-key))) |
524 |
(file-regular-p |
525 |
(setq cred-cert (expand-file-name cred-cert)))) |
526 |
(list "--x509keyfile" cred-key "--x509certfile" cred-cert))))) |
527 |
(starttls-open-stream "SMTP" process-buffer host port))))) |
528 |
|
529 |
;; `password-read' autoloads password-cache. |
530 |
(declare-function password-cache-add "password-cache" (key password)) |
531 |
|
532 |
(defun smtpmail-try-auth-methods (process supported-extensions host port) |
533 |
(let* ((mechs (cdr-safe (assoc 'auth supported-extensions))) |
534 |
(mech (car (smtpmail-intersection mechs smtpmail-auth-supported))) |
535 |
(auth-user (auth-source-user-or-password |
536 |
"login" host (or port "smtp"))) |
537 |
(auth-pass (auth-source-user-or-password |
538 |
"password" host (or port "smtp"))) |
539 |
(cred (if (and auth-user auth-pass) ; try user-auth-* before netrc-* |
540 |
(list host port auth-user auth-pass) |
541 |
;; else, if auth-source didn't return them... |
542 |
(if (stringp smtpmail-auth-credentials) |
543 |
(let* ((netrc (netrc-parse smtpmail-auth-credentials)) |
544 |
(port-name (format "%s" (or port "smtp"))) |
545 |
(hostentry (netrc-machine netrc host port-name |
546 |
port-name))) |
547 |
(when hostentry |
548 |
(list host port |
549 |
(netrc-get hostentry "login") |
550 |
(netrc-get hostentry "password")))) |
551 |
;; else, try `smtpmail-find-credentials' since |
552 |
;; `smtpmail-auth-credentials' is not a string |
553 |
(smtpmail-find-credentials |
554 |
smtpmail-auth-credentials host port)))) |
555 |
(prompt (when cred (format "SMTP password for %s:%s: " |
556 |
(smtpmail-cred-server cred) |
557 |
(smtpmail-cred-port cred)))) |
558 |
(passwd (when cred |
559 |
(or (smtpmail-cred-passwd cred) |
560 |
(password-read prompt prompt)))) |
561 |
ret) |
562 |
(when (and cred mech) |
563 |
(cond |
564 |
((eq mech 'cram-md5) |
565 |
(smtpmail-send-command process (upcase (format "AUTH %s" mech))) |
566 |
(if (or (null (car (setq ret (smtpmail-read-response process)))) |
567 |
(not (integerp (car ret))) |
568 |
(>= (car ret) 400)) |
569 |
(throw 'done nil)) |
570 |
(when (eq (car ret) 334) |
571 |
(let* ((challenge (substring (cadr ret) 4)) |
572 |
(decoded (base64-decode-string challenge)) |
573 |
(hash (rfc2104-hash 'md5 64 16 passwd decoded)) |
574 |
(response (concat (smtpmail-cred-user cred) " " hash)) |
575 |
;; Osamu Yamane <yamane@green.ocn.ne.jp>: |
576 |
;; SMTP auth fails because the SMTP server identifies |
577 |
;; only the first part of the string (delimited by |
578 |
;; new line characters) as a response from the |
579 |
;; client, and the rest as distinct commands. |
580 |
|
581 |
;; In my case, the response string is 80 characters |
582 |
;; long. Without the no-line-break option for |
583 |
;; `base64-encode-string', only the first 76 characters |
584 |
;; are taken as a response to the server, and the |
585 |
;; authentication fails. |
586 |
(encoded (base64-encode-string response t))) |
587 |
(smtpmail-send-command process (format "%s" encoded)) |
588 |
(if (or (null (car (setq ret (smtpmail-read-response process)))) |
589 |
(not (integerp (car ret))) |
590 |
(>= (car ret) 400)) |
591 |
(throw 'done nil))))) |
592 |
((eq mech 'login) |
593 |
(smtpmail-send-command process "AUTH LOGIN") |
594 |
(if (or (null (car (setq ret (smtpmail-read-response process)))) |
595 |
(not (integerp (car ret))) |
596 |
(>= (car ret) 400)) |
597 |
(throw 'done nil)) |
598 |
(smtpmail-send-command |
599 |
process (base64-encode-string (smtpmail-cred-user cred) t)) |
600 |
(if (or (null (car (setq ret (smtpmail-read-response process)))) |
601 |
(not (integerp (car ret))) |
602 |
(>= (car ret) 400)) |
603 |
(throw 'done nil)) |
604 |
(smtpmail-send-command process (base64-encode-string passwd t)) |
605 |
(if (or (null (car (setq ret (smtpmail-read-response process)))) |
606 |
(not (integerp (car ret))) |
607 |
(>= (car ret) 400)) |
608 |
(throw 'done nil))) |
609 |
((eq mech 'plain) |
610 |
;; We used to send an empty initial request, and wait for an |
611 |
;; empty response, and then send the password, but this |
612 |
;; violate a SHOULD in RFC 2222 paragraph 5.1. Note that this |
613 |
;; is not sent if the server did not advertise AUTH PLAIN in |
614 |
;; the EHLO response. See RFC 2554 for more info. |
615 |
(smtpmail-send-command process |
616 |
(concat "AUTH PLAIN " |
617 |
(base64-encode-string |
618 |
(concat "\0" |
619 |
(smtpmail-cred-user cred) |
620 |
"\0" |
621 |
passwd) t))) |
622 |
(if (or (null (car (setq ret (smtpmail-read-response process)))) |
623 |
(not (integerp (car ret))) |
624 |
(not (equal (car ret) 235))) |
625 |
(throw 'done nil))) |
626 |
|
627 |
(t |
628 |
(error "Mechanism %s not implemented" mech))) |
629 |
;; Remember the password. |
630 |
(when (null (smtpmail-cred-passwd cred)) |
631 |
(password-cache-add prompt passwd))))) |
632 |
|
633 |
(defun smtpmail-via-smtp (recipient smtpmail-text-buffer) |
634 |
(let ((process nil) |
635 |
(host (or smtpmail-smtp-server |
636 |
(error "`smtpmail-smtp-server' not defined"))) |
637 |
(port smtpmail-smtp-service) |
638 |
;; `smtpmail-mail-address' should be set to the appropriate |
639 |
;; buffer-local value by the caller, but in case not: |
640 |
(envelope-from (or smtpmail-mail-address |
641 |
(and mail-specify-envelope-from |
642 |
(mail-envelope-from)) |
643 |
user-mail-address)) |
644 |
response-code |
645 |
greeting |
646 |
process-buffer |
647 |
(supported-extensions '())) |
648 |
(unwind-protect |
649 |
(catch 'done |
650 |
;; get or create the trace buffer |
651 |
(setq process-buffer |
652 |
(get-buffer-create (format "*trace of SMTP session to %s*" host))) |
653 |
|
654 |
;; clear the trace buffer of old output |
655 |
(with-current-buffer process-buffer |
656 |
(setq buffer-undo-list t) |
657 |
(erase-buffer)) |
658 |
|
659 |
;; open the connection to the server |
660 |
(setq process (smtpmail-open-stream process-buffer host port)) |
661 |
(and (null process) (throw 'done nil)) |
662 |
|
663 |
;; set the send-filter |
664 |
(set-process-filter process 'smtpmail-process-filter) |
665 |
|
666 |
(with-current-buffer process-buffer |
667 |
(set-buffer-process-coding-system 'raw-text-unix 'raw-text-unix) |
668 |
(make-local-variable 'smtpmail-read-point) |
669 |
(setq smtpmail-read-point (point-min)) |
670 |
|
671 |
|
672 |
(if (or (null (car (setq greeting (smtpmail-read-response process)))) |
673 |
(not (integerp (car greeting))) |
674 |
(>= (car greeting) 400)) |
675 |
(throw 'done nil)) |
676 |
|
677 |
(let ((do-ehlo t) |
678 |
(do-starttls t)) |
679 |
(while do-ehlo |
680 |
;; EHLO |
681 |
(smtpmail-send-command process (format "EHLO %s" (smtpmail-fqdn))) |
682 |
|
683 |
(if (or (null (car (setq response-code |
684 |
(smtpmail-read-response process)))) |
685 |
(not (integerp (car response-code))) |
686 |
(>= (car response-code) 400)) |
687 |
(progn |
688 |
;; HELO |
689 |
(smtpmail-send-command |
690 |
process (format "HELO %s" (smtpmail-fqdn))) |
691 |
|
692 |
(if (or (null (car (setq response-code |
693 |
(smtpmail-read-response process)))) |
694 |
(not (integerp (car response-code))) |
695 |
(>= (car response-code) 400)) |
696 |
(throw 'done nil))) |
697 |
(dolist (line (cdr (cdr response-code))) |
698 |
(let ((name |
699 |
(with-case-table ascii-case-table |
700 |
(mapcar (lambda (s) (intern (downcase s))) |
701 |
(split-string (substring line 4) "[ ]"))))) |
702 |
(and (eq (length name) 1) |
703 |
(setq name (car name))) |
704 |
(and name |
705 |
(cond ((memq (if (consp name) (car name) name) |
706 |
'(verb xvrb 8bitmime onex xone |
707 |
expn size dsn etrn |
708 |
enhancedstatuscodes |
709 |
help xusr |
710 |
auth=login auth starttls)) |
711 |
(setq supported-extensions |
712 |
(cons name supported-extensions))) |
713 |
(smtpmail-warn-about-unknown-extensions |
714 |
(message "Unknown extension %s" name))))))) |
715 |
|
716 |
(if (and do-starttls |
717 |
(smtpmail-find-credentials smtpmail-starttls-credentials host port) |
718 |
(member 'starttls supported-extensions) |
719 |
(numberp (process-id process))) |
720 |
(progn |
721 |
(smtpmail-send-command process (format "STARTTLS")) |
722 |
(if (or (null (car (setq response-code (smtpmail-read-response process)))) |
723 |
(not (integerp (car response-code))) |
724 |
(>= (car response-code) 400)) |
725 |
(throw 'done nil)) |
726 |
(starttls-negotiate process) |
727 |
(setq do-starttls nil)) |
728 |
(setq do-ehlo nil)))) |
729 |
|
730 |
(smtpmail-try-auth-methods process supported-extensions host port) |
731 |
|
732 |
(if (or (member 'onex supported-extensions) |
733 |
(member 'xone supported-extensions)) |
734 |
(progn |
735 |
(smtpmail-send-command process (format "ONEX")) |
736 |
(if (or (null (car (setq response-code (smtpmail-read-response process)))) |
737 |
(not (integerp (car response-code))) |
738 |
(>= (car response-code) 400)) |
739 |
(throw 'done nil)))) |
740 |
|
741 |
(if (and smtpmail-debug-verb |
742 |
(or (member 'verb supported-extensions) |
743 |
(member 'xvrb supported-extensions))) |
744 |
(progn |
745 |
(smtpmail-send-command process (format "VERB")) |
746 |
(if (or (null (car (setq response-code (smtpmail-read-response process)))) |
747 |
(not (integerp (car response-code))) |
748 |
(>= (car response-code) 400)) |
749 |
(throw 'done nil)))) |
750 |
|
751 |
(if (member 'xusr supported-extensions) |
752 |
(progn |
753 |
(smtpmail-send-command process (format "XUSR")) |
754 |
(if (or (null (car (setq response-code (smtpmail-read-response process)))) |
755 |
(not (integerp (car response-code))) |
756 |
(>= (car response-code) 400)) |
757 |
(throw 'done nil)))) |
758 |
|
759 |
;; MAIL FROM:<sender> |
760 |
(let ((size-part |
761 |
(if (or (member 'size supported-extensions) |
762 |
(assoc 'size supported-extensions)) |
763 |
(format " SIZE=%d" |
764 |
(with-current-buffer smtpmail-text-buffer |
765 |
;; size estimate: |
766 |
(+ (- (point-max) (point-min)) |
767 |
;; Add one byte for each change-of-line |
768 |
;; because of CR-LF representation: |
769 |
(count-lines (point-min) (point-max))))) |
770 |
"")) |
771 |
(body-part |
772 |
(if (member '8bitmime supported-extensions) |
773 |
;; FIXME: |
774 |
;; Code should be added here that transforms |
775 |
;; the contents of the message buffer into |
776 |
;; something the receiving SMTP can handle. |
777 |
;; For a receiver that supports 8BITMIME, this |
778 |
;; may mean converting BINARY to BASE64, or |
779 |
;; adding Content-Transfer-Encoding and the |
780 |
;; other MIME headers. The code should also |
781 |
;; return an indication of what encoding the |
782 |
;; message buffer is now, i.e. ASCII or |
783 |
;; 8BITMIME. |
784 |
(if nil |
785 |
" BODY=8BITMIME" |
786 |
"") |
787 |
""))) |
788 |
;; (smtpmail-send-command process (format "MAIL FROM:%s@%s" (user-login-name) (smtpmail-fqdn))) |
789 |
(smtpmail-send-command process (format "MAIL FROM:<%s>%s%s" |
790 |
envelope-from |
791 |
size-part |
792 |
body-part)) |
793 |
|
794 |
(if (or (null (car (setq response-code (smtpmail-read-response process)))) |
795 |
(not (integerp (car response-code))) |
796 |
(>= (car response-code) 400)) |
797 |
(throw 'done nil))) |
798 |
|
799 |
;; RCPT TO:<recipient> |
800 |
(let ((n 0)) |
801 |
(while (not (null (nth n recipient))) |
802 |
(smtpmail-send-command process (format "RCPT TO:<%s>" (smtpmail-maybe-append-domain (nth n recipient)))) |
803 |
(setq n (1+ n)) |
804 |
|
805 |
(setq response-code (smtpmail-read-response process)) |
806 |
(if (or (null (car response-code)) |
807 |
(not (integerp (car response-code))) |
808 |
(>= (car response-code) 400)) |
809 |
(throw 'done nil)))) |
810 |
|
811 |
;; DATA |
812 |
(smtpmail-send-command process "DATA") |
813 |
|
814 |
(if (or (null (car (setq response-code (smtpmail-read-response process)))) |
815 |
(not (integerp (car response-code))) |
816 |
(>= (car response-code) 400)) |
817 |
(throw 'done nil)) |
818 |
|
819 |
;; Mail contents |
820 |
(smtpmail-send-data process smtpmail-text-buffer) |
821 |
|
822 |
;; DATA end "." |
823 |
(smtpmail-send-command process ".") |
824 |
|
825 |
(if (or (null (car (setq response-code (smtpmail-read-response process)))) |
826 |
(not (integerp (car response-code))) |
827 |
(>= (car response-code) 400)) |
828 |
(throw 'done nil)) |
829 |
|
830 |
;; QUIT |
831 |
;; (smtpmail-send-command process "QUIT") |
832 |
;; (and (null (car (smtpmail-read-response process))) |
833 |
;; (throw 'done nil)) |
834 |
t)) |
835 |
(if process |
836 |
(with-current-buffer (process-buffer process) |
837 |
(smtpmail-send-command process "QUIT") |
838 |
(smtpmail-read-response process) |
839 |
|
840 |
;; (if (or (null (car (setq response-code (smtpmail-read-response process)))) |
841 |
;; (not (integerp (car response-code))) |
842 |
;; (>= (car response-code) 400)) |
843 |
;; (throw 'done nil)) |
844 |
(delete-process process) |
845 |
(unless smtpmail-debug-info |
846 |
(kill-buffer process-buffer))))))) |
847 |
|
848 |
|
849 |
(defun smtpmail-process-filter (process output) |
850 |
(with-current-buffer (process-buffer process) |
851 |
(goto-char (point-max)) |
852 |
(insert output))) |
853 |
|
854 |
(defun smtpmail-read-response (process) |
855 |
(let ((case-fold-search nil) |
856 |
(response-strings nil) |
857 |
(response-continue t) |
858 |
(return-value '(nil ())) |
859 |
match-end) |
860 |
(catch 'done |
861 |
(while response-continue |
862 |
(goto-char smtpmail-read-point) |
863 |
(while (not (search-forward "\r\n" nil t)) |
864 |
(unless (memq (process-status process) '(open run)) |
865 |
(throw 'done nil)) |
866 |
(accept-process-output process) |
867 |
(goto-char smtpmail-read-point)) |
868 |
|
869 |
(setq match-end (point)) |
870 |
(setq response-strings |
871 |
(cons (buffer-substring smtpmail-read-point (- match-end 2)) |
872 |
response-strings)) |
873 |
|
874 |
(goto-char smtpmail-read-point) |
875 |
(if (looking-at "[0-9]+ ") |
876 |
(let ((begin (match-beginning 0)) |
877 |
(end (match-end 0))) |
878 |
(if smtpmail-debug-info |
879 |
(message "%s" (car response-strings))) |
880 |
|
881 |
(setq smtpmail-read-point match-end) |
882 |
|
883 |
;; ignore lines that start with "0" |
884 |
(if (looking-at "0[0-9]+ ") |
885 |
nil |
886 |
(setq response-continue nil) |
887 |
(setq return-value |
888 |
(cons (string-to-number |
889 |
(buffer-substring begin end)) |
890 |
(nreverse response-strings))))) |
891 |
|
892 |
(if (looking-at "[0-9]+-") |
893 |
(progn (if smtpmail-debug-info |
894 |
(message "%s" (car response-strings))) |
895 |
(setq smtpmail-read-point match-end) |
896 |
(setq response-continue t)) |
897 |
(progn |
898 |
(setq smtpmail-read-point match-end) |
899 |
(setq response-continue nil) |
900 |
(setq return-value |
901 |
(cons nil (nreverse response-strings))))))) |
902 |
(setq smtpmail-read-point match-end)) |
903 |
return-value)) |
904 |
|
905 |
|
906 |
(defun smtpmail-send-command (process command) |
907 |
(goto-char (point-max)) |
908 |
(if (= (aref command 0) ?P) |
909 |
(insert "PASS <omitted>\r\n") |
910 |
(insert command "\r\n")) |
911 |
(setq smtpmail-read-point (point)) |
912 |
(process-send-string process command) |
913 |
(process-send-string process "\r\n")) |
914 |
|
915 |
(defun smtpmail-send-data-1 (process data) |
916 |
(goto-char (point-max)) |
917 |
|
918 |
(if (and (multibyte-string-p data) |
919 |
smtpmail-code-conv-from) |
920 |
(setq data (string-as-multibyte |
921 |
(encode-coding-string data smtpmail-code-conv-from)))) |
922 |
|
923 |
(if smtpmail-debug-info |
924 |
(insert data "\r\n")) |
925 |
|
926 |
(setq smtpmail-read-point (point)) |
927 |
;; Escape "." at start of a line |
928 |
(if (eq (string-to-char data) ?.) |
929 |
(process-send-string process ".")) |
930 |
(process-send-string process data) |
931 |
(process-send-string process "\r\n")) |
932 |
|
933 |
(defun smtpmail-send-data (process buffer) |
934 |
(let ((data-continue t) sending-data) |
935 |
(with-current-buffer buffer |
936 |
(goto-char (point-min))) |
937 |
(while data-continue |
938 |
(with-current-buffer buffer |
939 |
(setq sending-data (buffer-substring (point-at-bol) (point-at-eol))) |
940 |
(end-of-line 2) |
941 |
(setq data-continue (not (eobp)))) |
942 |
(smtpmail-send-data-1 process sending-data)))) |
943 |
|
944 |
(defun smtpmail-deduce-address-list (smtpmail-text-buffer header-start header-end) |
945 |
"Get address list suitable for smtp RCPT TO: <address>." |
946 |
(unwind-protect |
947 |
(with-current-buffer smtpmail-address-buffer |
948 |
(erase-buffer) |
949 |
(let ((case-fold-search t) |
950 |
(simple-address-list "") |
951 |
this-line |
952 |
this-line-end |
953 |
addr-regexp) |
954 |
(insert-buffer-substring smtpmail-text-buffer header-start header-end) |
955 |
(goto-char (point-min)) |
956 |
;; RESENT-* fields should stop processing of regular fields. |
957 |
(save-excursion |
958 |
(setq addr-regexp |
959 |
(if (re-search-forward "^Resent-\\(to\\|cc\\|bcc\\):" |
960 |
header-end t) |
961 |
"^Resent-\\(to\\|cc\\|bcc\\):" |
962 |
"^\\(To:\\|Cc:\\|Bcc:\\)"))) |
963 |
|
964 |
(while (re-search-forward addr-regexp header-end t) |
965 |
(replace-match "") |
966 |
(setq this-line (match-beginning 0)) |
967 |
(forward-line 1) |
968 |
;; get any continuation lines |
969 |
(while (and (looking-at "^[ \t]+") (< (point) header-end)) |
970 |
(forward-line 1)) |
971 |
(setq this-line-end (point-marker)) |
972 |
(setq simple-address-list |
973 |
(concat simple-address-list " " |
974 |
(mail-strip-quoted-names (buffer-substring this-line this-line-end))))) |
975 |
(erase-buffer) |
976 |
(insert " " simple-address-list "\n") |
977 |
(subst-char-in-region (point-min) (point-max) 10 ? t) ; newline --> blank |
978 |
(subst-char-in-region (point-min) (point-max) ?, ? t) ; comma --> blank |
979 |
(subst-char-in-region (point-min) (point-max) 9 ? t) ; tab --> blank |
980 |
|
981 |
(goto-char (point-min)) |
982 |
;; tidyness in case hook is not robust when it looks at this |
983 |
(while (re-search-forward "[ \t]+" header-end t) (replace-match " ")) |
984 |
|
985 |
(goto-char (point-min)) |
986 |
(let (recipient-address-list) |
987 |
(while (re-search-forward " \\([^ ]+\\) " (point-max) t) |
988 |
(backward-char 1) |
989 |
(setq recipient-address-list (cons (buffer-substring (match-beginning 1) (match-end 1)) |
990 |
recipient-address-list))) |
991 |
(setq smtpmail-recipient-address-list recipient-address-list)))))) |
992 |
|
993 |
(defun smtpmail-do-bcc (header-end) |
994 |
"Delete [Resent-]BCC: and their continuation lines from the header area. |
995 |
There may be multiple BCC: lines, and each may have arbitrarily |
996 |
many continuation lines." |
997 |
(let ((case-fold-search t)) |
998 |
(save-excursion |
999 |
(goto-char (point-min)) |
1000 |
;; iterate over all BCC: lines |
1001 |
(while (re-search-forward "^\\(RESENT-\\)?BCC:" header-end t) |
1002 |
(delete-region (match-beginning 0) |
1003 |
(progn (forward-line 1) (point))) |
1004 |
;; get rid of any continuation lines |
1005 |
(while (and (looking-at "^[ \t].*\n") (< (point) header-end)) |
1006 |
(replace-match "")))))) |
1007 |
|
1008 |
(provide 'smtpmail) |
1009 |
|
1010 |
;; arch-tag: a76992df-6d71-43b7-9e72-4bacc6c05466 |
1011 |
;;; smtpmail.el ends here |