3 |
;; Copyright (C) 1995, 1996, 2001 Free Software Foundation, Inc. |
;; Copyright (C) 1995, 1996, 2001 Free Software Foundation, Inc. |
4 |
|
|
5 |
;; Author: Tomoji Kagatani <kagatani@rbc.ncl.omron.co.jp> |
;; Author: Tomoji Kagatani <kagatani@rbc.ncl.omron.co.jp> |
6 |
;; Maintainer: Brian D. Carlstrom <bdc@ai.mit.edu> |
;; Maintainer: Simon Josefsson <simon@josefsson.org> |
7 |
|
;; w32 Maintainer: Brian D. Carlstrom <bdc@ai.mit.edu> |
8 |
;; ESMTP support: Simon Leinen <simon@switch.ch> |
;; ESMTP support: Simon Leinen <simon@switch.ch> |
9 |
;; Hacked by Mike Taylor, 11th October 1999 to add support for |
;; Hacked by Mike Taylor, 11th October 1999 to add support for |
10 |
;; automatically appending a domain to RCPT TO: addresses. |
;; automatically appending a domain to RCPT TO: addresses. |
11 |
|
;; AUTH=LOGIN support: Stephen Cranefield <scranefield@infoscience.otago.ac.nz> |
12 |
;; Keywords: mail |
;; Keywords: mail |
13 |
|
|
14 |
;; This file is part of GNU Emacs. |
;; This file is part of GNU Emacs. |
40 |
;;(setq smtpmail-local-domain "YOUR DOMAIN NAME") |
;;(setq smtpmail-local-domain "YOUR DOMAIN NAME") |
41 |
;;(setq smtpmail-sendto-domain "YOUR DOMAIN NAME") |
;;(setq smtpmail-sendto-domain "YOUR DOMAIN NAME") |
42 |
;;(setq smtpmail-debug-info t) ; only to debug problems |
;;(setq smtpmail-debug-info t) ; only to debug problems |
43 |
|
;;(setq smtpmail-auth-credentials |
44 |
|
;; '(("YOUR SMTP HOST" 25 "username" "password"))) |
45 |
|
;;(setq smtpmail-starttls-credentials |
46 |
|
;; '(("YOUR SMTP HOST" 25 "~/.my_smtp_tls.key" "~/.my_smtp_tls.cert"))) |
47 |
|
|
48 |
;; To queue mail, set smtpmail-queue-mail to t and use |
;; To queue mail, set smtpmail-queue-mail to t and use |
49 |
;; smtpmail-send-queued-mail to send. |
;; smtpmail-send-queued-mail to send. |
50 |
|
|
51 |
|
;; Modified by Stephen Cranefield <scranefield@infoscience.otago.ac.nz>, |
52 |
|
;; 22/6/99, to support SMTP Authentication by the AUTH=LOGIN mechanism. |
53 |
|
;; See http://help.netscape.com/products/server/messaging/3x/info/smtpauth.html |
54 |
|
;; Rewritten by Simon Josefsson to use same credential variable as AUTH |
55 |
|
;; support below. |
56 |
|
|
57 |
|
;; Modified by Simon Josefsson <jas@pdc.kth.se>, 22/2/99, to support SMTP |
58 |
|
;; Authentication by the AUTH mechanism. |
59 |
|
;; See http://www.ietf.org/rfc/rfc2554.txt |
60 |
|
|
61 |
|
;; Modified by Simon Josefsson <simon@josefsson.org>, 2000-10-07, to support |
62 |
|
;; STARTTLS. Requires external program |
63 |
|
;; ftp://ftp.opaopa.org/pub/elisp/starttls-*.tar.gz. |
64 |
|
;; See http://www.ietf.org/rfc/rfc2246.txt, http://www.ietf.org/rfc/rfc2487.txt |
65 |
|
|
66 |
;;; Code: |
;;; Code: |
67 |
|
|
68 |
(require 'sendmail) |
(require 'sendmail) |
69 |
(require 'time-stamp) |
(require 'time-stamp) |
70 |
|
(autoload 'starttls-open-stream "starttls") |
71 |
|
(autoload 'starttls-negotiate "starttls") |
72 |
|
(autoload 'mail-strip-quoted-names "mail-utils") |
73 |
|
(autoload 'rfc2104-hash "rfc2104") |
74 |
|
|
75 |
;;; |
;;; |
76 |
(defgroup smtpmail nil |
(defgroup smtpmail nil |
90 |
:group 'smtpmail) |
:group 'smtpmail) |
91 |
|
|
92 |
(defcustom smtpmail-smtp-service 25 |
(defcustom smtpmail-smtp-service 25 |
93 |
"*SMTP service port number. smtp or 25 ." |
"*SMTP service port number. |
94 |
:type 'integer |
The default value would be \"smtp\" or 25 ." |
95 |
|
:type '(choice (integer :tag "Port") (string :tag "Service")) |
96 |
:group 'smtpmail) |
:group 'smtpmail) |
97 |
|
|
98 |
(defcustom smtpmail-local-domain nil |
(defcustom smtpmail-local-domain nil |
119 |
:group 'smtpmail) |
:group 'smtpmail) |
120 |
|
|
121 |
(defcustom smtpmail-debug-info nil |
(defcustom smtpmail-debug-info nil |
122 |
"*smtpmail debug info printout. messages and process buffer." |
"Whether to print info in buffer *trace of SMTP session to <somewhere>*. |
123 |
|
See also `smtpmail-debug-verb' which determines if the SMTP protocol should |
124 |
|
be verbose as well." |
125 |
|
:type 'boolean |
126 |
|
:group 'smtpmail) |
127 |
|
|
128 |
|
(defcustom smtpmail-debug-verb nil |
129 |
|
"Whether this library sends the SMTP VERB command or not. |
130 |
|
The commands enables verbose information from the SMTP server." |
131 |
:type 'boolean |
:type 'boolean |
132 |
:group 'smtpmail) |
:group 'smtpmail) |
133 |
|
|
148 |
:type 'directory |
:type 'directory |
149 |
:group 'smtpmail) |
:group 'smtpmail) |
150 |
|
|
151 |
|
(defcustom smtpmail-auth-credentials '(("" 25 "" nil)) |
152 |
|
"Specify username and password for servers. |
153 |
|
It is a list of four-element lists that contain, in order, |
154 |
|
`servername' (a string), `port' (an integer), `user' (a string) and |
155 |
|
`password' (a string, or nil to query the user when needed). |
156 |
|
If you need to enter a `realm' too, add it to the user string, so that |
157 |
|
it looks like `user@realm'." |
158 |
|
:type '(repeat (list (string :tag "Server") |
159 |
|
(integer :tag "Port") |
160 |
|
(string :tag "Username") |
161 |
|
(choice (const :tag "Query when needed" nil) |
162 |
|
(string :tag "Password")))) |
163 |
|
:version "21.1" |
164 |
|
:group 'smtpmail) |
165 |
|
|
166 |
|
(defcustom smtpmail-starttls-credentials '(("" 25 "" "")) |
167 |
|
"Specify STARTTLS keys and certificates for servers. |
168 |
|
This is a list of four-element list with `servername' (a string), |
169 |
|
`port' (an integer), `key' (a filename) and `certificate' (a filename)." |
170 |
|
:type '(repeat (list (string :tag "Server") |
171 |
|
(integer :tag "Port") |
172 |
|
(file :tag "Key") |
173 |
|
(file :tag "Certificate"))) |
174 |
|
:version "21.1" |
175 |
|
:group 'smtpmail) |
176 |
|
|
177 |
(defcustom smtpmail-warn-about-unknown-extensions nil |
(defcustom smtpmail-warn-about-unknown-extensions nil |
178 |
"*If set, print warnings about unknown SMTP extensions. |
"*If set, print warnings about unknown SMTP extensions. |
179 |
This is mainly useful for development purposes, to learn about |
This is mainly useful for development purposes, to learn about |
195 |
(defvar smtpmail-queue-index (concat smtpmail-queue-dir |
(defvar smtpmail-queue-index (concat smtpmail-queue-dir |
196 |
smtpmail-queue-index-file)) |
smtpmail-queue-index-file)) |
197 |
|
|
198 |
|
(defconst smtpmail-auth-supported '(cram-md5 login) |
199 |
|
"List of supported SMTP AUTH mechanisms.") |
200 |
|
|
201 |
;;; |
;;; |
202 |
;;; |
;;; |
203 |
;;; |
;;; |
204 |
|
|
205 |
;;;###autoload |
;;;###autoload |
206 |
(defun smtpmail-send-it () |
(defun smtpmail-send-it () |
|
(require 'mail-utils) |
|
207 |
(let ((errbuf (if mail-interactive |
(let ((errbuf (if mail-interactive |
208 |
(generate-new-buffer " smtpmail errors") |
(generate-new-buffer " smtpmail errors") |
209 |
0)) |
0)) |
393 |
(concat (system-name) "." smtpmail-local-domain) |
(concat (system-name) "." smtpmail-local-domain) |
394 |
(system-name))) |
(system-name))) |
395 |
|
|
396 |
|
(defsubst smtpmail-cred-server (cred) |
397 |
|
(nth 0 cred)) |
398 |
|
|
399 |
|
(defsubst smtpmail-cred-port (cred) |
400 |
|
(nth 1 cred)) |
401 |
|
|
402 |
|
(defsubst smtpmail-cred-key (cred) |
403 |
|
(nth 2 cred)) |
404 |
|
|
405 |
|
(defsubst smtpmail-cred-user (cred) |
406 |
|
(nth 2 cred)) |
407 |
|
|
408 |
|
(defsubst smtpmail-cred-cert (cred) |
409 |
|
(nth 3 cred)) |
410 |
|
|
411 |
|
(defsubst smtpmail-cred-passwd (cred) |
412 |
|
(nth 3 cred)) |
413 |
|
|
414 |
|
(defun smtpmail-find-credentials (cred server port) |
415 |
|
(catch 'done |
416 |
|
(let ((l cred) el) |
417 |
|
(while (setq el (pop l)) |
418 |
|
(when (and (equal server (smtpmail-cred-server el)) |
419 |
|
(equal port (smtpmail-cred-port el))) |
420 |
|
(throw 'done el)))))) |
421 |
|
|
422 |
(defun smtpmail-maybe-append-domain (recipient) |
(defun smtpmail-maybe-append-domain (recipient) |
423 |
(if (or (not smtpmail-sendto-domain) |
(if (or (not smtpmail-sendto-domain) |
424 |
(string-match "@" recipient)) |
(string-match "@" recipient)) |
425 |
recipient |
recipient |
426 |
(concat recipient "@" smtpmail-sendto-domain))) |
(concat recipient "@" smtpmail-sendto-domain))) |
427 |
|
|
428 |
|
(defun smtpmail-intersection (list1 list2) |
429 |
|
(let ((result nil)) |
430 |
|
(dolist (el2 list2) |
431 |
|
(when (memq el2 list1) |
432 |
|
(push el2 result))) |
433 |
|
(nreverse result))) |
434 |
|
|
435 |
|
(defun smtpmail-open-stream (process-buffer host port) |
436 |
|
(let ((cred (smtpmail-find-credentials |
437 |
|
smtpmail-starttls-credentials host port))) |
438 |
|
(if (null (and cred (condition-case () |
439 |
|
(call-process "starttls") |
440 |
|
(error nil)))) |
441 |
|
;; The normal case. |
442 |
|
(open-network-stream "SMTP" process-buffer host port) |
443 |
|
(let* ((cred-key (smtpmail-cred-key cred)) |
444 |
|
(cred-cert (smtpmail-cred-cert cred)) |
445 |
|
(starttls-extra-args |
446 |
|
(when (and (stringp cred-key) (stringp cred-cert) |
447 |
|
(file-regular-p |
448 |
|
(setq cred-key (expand-file-name cred-key))) |
449 |
|
(file-regular-p |
450 |
|
(setq cred-cert (expand-file-name cred-cert)))) |
451 |
|
(list "--key-file" cred-key "--cert-file" cred-cert)))) |
452 |
|
(starttls-open-stream "SMTP" process-buffer host port))))) |
453 |
|
|
454 |
|
(defun smtpmail-try-auth-methods (process supported-extensions host port) |
455 |
|
(let* ((mechs (cdr-safe (assoc 'auth supported-extensions))) |
456 |
|
(mech (car (smtpmail-intersection smtpmail-auth-supported mechs))) |
457 |
|
(cred (smtpmail-find-credentials smtpmail-auth-credentials host port)) |
458 |
|
(passwd (when cred |
459 |
|
(or (smtpmail-cred-passwd cred) |
460 |
|
(read-passwd |
461 |
|
(format "SMTP password for %s:%s: " |
462 |
|
(smtpmail-cred-server cred) |
463 |
|
(smtpmail-cred-port cred)))))) |
464 |
|
ret) |
465 |
|
(when cred |
466 |
|
(cond |
467 |
|
((eq mech 'cram-md5) |
468 |
|
(smtpmail-send-command process (format "AUTH %s" mech)) |
469 |
|
(if (or (null (car (setq ret (smtpmail-read-response process)))) |
470 |
|
(not (integerp (car ret))) |
471 |
|
(>= (car ret) 400)) |
472 |
|
(throw 'done nil)) |
473 |
|
(when (eq (car ret) 334) |
474 |
|
(let* ((challenge (substring (cadr ret) 4)) |
475 |
|
(decoded (base64-decode-string challenge)) |
476 |
|
(hash (rfc2104-hash 'md5 64 16 passwd decoded)) |
477 |
|
(response (concat (smtpmail-cred-user cred) " " hash)) |
478 |
|
(encoded (base64-encode-string response))) |
479 |
|
(smtpmail-send-command process (format "%s" encoded)) |
480 |
|
(if (or (null (car (setq ret (smtpmail-read-response process)))) |
481 |
|
(not (integerp (car ret))) |
482 |
|
(>= (car ret) 400)) |
483 |
|
(throw 'done nil))))) |
484 |
|
((eq mech 'login) |
485 |
|
(smtpmail-send-command process "AUTH LOGIN") |
486 |
|
(if (or (null (car (setq ret (smtpmail-read-response process)))) |
487 |
|
(not (integerp (car ret))) |
488 |
|
(>= (car ret) 400)) |
489 |
|
(throw 'done nil)) |
490 |
|
(smtpmail-send-command |
491 |
|
process (base64-encode-string (smtpmail-cred-user cred))) |
492 |
|
(if (or (null (car (setq ret (smtpmail-read-response process)))) |
493 |
|
(not (integerp (car ret))) |
494 |
|
(>= (car ret) 400)) |
495 |
|
(throw 'done nil)) |
496 |
|
(smtpmail-send-command process (base64-encode-string passwd)) |
497 |
|
(if (or (null (car (setq ret (smtpmail-read-response process)))) |
498 |
|
(not (integerp (car ret))) |
499 |
|
(>= (car ret) 400)) |
500 |
|
(throw 'done nil))) |
501 |
|
(t |
502 |
|
(error "Mechanism %s not implemented" mech))) |
503 |
|
;; Remember the password. |
504 |
|
(unless (smtpmail-cred-passwd cred) |
505 |
|
(setcar (cdr (cdr (cdr cred))) passwd))))) |
506 |
|
|
507 |
(defun smtpmail-via-smtp (recipient smtpmail-text-buffer) |
(defun smtpmail-via-smtp (recipient smtpmail-text-buffer) |
508 |
(let ((process nil) |
(let ((process nil) |
509 |
(host (or smtpmail-smtp-server |
(host (or smtpmail-smtp-server |
525 |
(erase-buffer)) |
(erase-buffer)) |
526 |
|
|
527 |
;; open the connection to the server |
;; open the connection to the server |
528 |
(setq process (open-network-stream "SMTP" process-buffer host port)) |
(setq process (smtpmail-open-stream process-buffer host port)) |
529 |
(and (null process) (throw 'done nil)) |
(and (null process) (throw 'done nil)) |
530 |
|
|
531 |
;; set the send-filter |
;; set the send-filter |
544 |
(throw 'done nil) |
(throw 'done nil) |
545 |
) |
) |
546 |
|
|
547 |
|
(let ((do-ehlo t) |
548 |
|
(do-starttls t)) |
549 |
|
(while do-ehlo |
550 |
;; EHLO |
;; EHLO |
551 |
(smtpmail-send-command process (format "EHLO %s" (smtpmail-fqdn))) |
(smtpmail-send-command process (format "EHLO %s" (smtpmail-fqdn))) |
552 |
|
|
553 |
(if (or (null (car (setq response-code (smtpmail-read-response process)))) |
(if (or (null (car (setq response-code |
554 |
|
(smtpmail-read-response process)))) |
555 |
(not (integerp (car response-code))) |
(not (integerp (car response-code))) |
556 |
(>= (car response-code) 400)) |
(>= (car response-code) 400)) |
557 |
(progn |
(progn |
558 |
;; HELO |
;; HELO |
559 |
(smtpmail-send-command process (format "HELO %s" (smtpmail-fqdn))) |
(smtpmail-send-command |
560 |
|
process (format "HELO %s" (smtpmail-fqdn))) |
561 |
|
|
562 |
(if (or (null (car (setq response-code (smtpmail-read-response process)))) |
(if (or (null (car (setq response-code |
563 |
|
(smtpmail-read-response process)))) |
564 |
(not (integerp (car response-code))) |
(not (integerp (car response-code))) |
565 |
(>= (car response-code) 400)) |
(>= (car response-code) 400)) |
566 |
(throw 'done nil))) |
(throw 'done nil))) |
567 |
(let ((extension-lines (cdr (cdr response-code)))) |
(dolist (line (cdr (cdr response-code))) |
568 |
(while extension-lines |
(let ((name (mapcar (lambda (s) (intern (downcase s))) |
569 |
(let ((name (intern (downcase (car (split-string (substring (car extension-lines) 4) "[ ]")))))) |
(split-string (substring line 4) "[ ]")))) |
570 |
|
(and (eq (length name) 1) |
571 |
|
(setq name (car name))) |
572 |
(and name |
(and name |
573 |
(cond ((memq name '(verb xvrb 8bitmime onex xone |
(cond ((memq (if (consp name) (car name) name) |
574 |
|
'(verb xvrb 8bitmime onex xone |
575 |
expn size dsn etrn |
expn size dsn etrn |
576 |
help xusr)) |
enhancedstatuscodes |
577 |
|
help xusr |
578 |
|
auth=login auth starttls)) |
579 |
(setq supported-extensions |
(setq supported-extensions |
580 |
(cons name supported-extensions))) |
(cons name supported-extensions))) |
581 |
(smtpmail-warn-about-unknown-extensions |
(smtpmail-warn-about-unknown-extensions |
582 |
(message "Unknown extension %s" name))))) |
(message "Unknown extension %s" name))))))) |
583 |
(setq extension-lines (cdr extension-lines))))) |
|
584 |
|
(if (and do-starttls |
585 |
|
(smtpmail-find-credentials smtpmail-starttls-credentials host port) |
586 |
|
(member 'starttls supported-extensions) |
587 |
|
(process-id process)) |
588 |
|
(progn |
589 |
|
(smtpmail-send-command process (format "STARTTLS")) |
590 |
|
(if (or (null (car (setq response-code (smtpmail-read-response process)))) |
591 |
|
(not (integerp (car response-code))) |
592 |
|
(>= (car response-code) 400)) |
593 |
|
(throw 'done nil)) |
594 |
|
(starttls-negotiate process) |
595 |
|
(setq do-starttls nil)) |
596 |
|
(setq do-ehlo nil)))) |
597 |
|
|
598 |
|
(smtpmail-try-auth-methods process supported-extensions host port) |
599 |
|
|
600 |
(if (or (member 'onex supported-extensions) |
(if (or (member 'onex supported-extensions) |
601 |
(member 'xone supported-extensions)) |
(member 'xone supported-extensions)) |
606 |
(>= (car response-code) 400)) |
(>= (car response-code) 400)) |
607 |
(throw 'done nil)))) |
(throw 'done nil)))) |
608 |
|
|
609 |
(if (and smtpmail-debug-info |
(if (and smtpmail-debug-verb |
610 |
(or (member 'verb supported-extensions) |
(or (member 'verb supported-extensions) |
611 |
(member 'xvrb supported-extensions))) |
(member 'xvrb supported-extensions))) |
612 |
(progn |
(progn |
626 |
|
|
627 |
;; MAIL FROM: <sender> |
;; MAIL FROM: <sender> |
628 |
(let ((size-part |
(let ((size-part |
629 |
(if (member 'size supported-extensions) |
(if (or (member 'size supported-extensions) |
630 |
|
(assoc 'size supported-extensions)) |
631 |
(format " SIZE=%d" |
(format " SIZE=%d" |
632 |
(save-excursion |
(save-excursion |
633 |
(set-buffer smtpmail-text-buffer) |
(set-buffer smtpmail-text-buffer) |
843 |
|
|
844 |
(defun smtpmail-deduce-address-list (smtpmail-text-buffer header-start header-end) |
(defun smtpmail-deduce-address-list (smtpmail-text-buffer header-start header-end) |
845 |
"Get address list suitable for smtp RCPT TO: <address>." |
"Get address list suitable for smtp RCPT TO: <address>." |
|
(require 'mail-utils) ;; pick up mail-strip-quoted-names |
|
|
|
|
846 |
(unwind-protect |
(unwind-protect |
847 |
(save-excursion |
(save-excursion |
848 |
(set-buffer smtpmail-address-buffer) (erase-buffer) |
(set-buffer smtpmail-address-buffer) (erase-buffer) |