1 ;;; smtp.el --- basic functions to send mail with SMTP server
3 ;; Copyright (C) 1995, 1996, 1998, 1999 Free Software Foundation, Inc.
5 ;; Author: Tomoji Kagatani <kagatani@rbc.ncl.omron.co.jp>
6 ;; Simon Leinen <simon@switch.ch> (ESMTP support)
7 ;; Shuhei KOBAYASHI <shuhei@aqua.ocn.ne.jp>
8 ;; Kenichi OKADA <okada@opaopa.org> (SASL support)
9 ;; Daiki Ueno <ueno@ueda.info.waseda.ac.jp>
10 ;; Maintainer: Kenichi OKADA <okada@opaopa.org>
11 ;; Keywords: SMTP, mail, SASL
13 ;; This file is part of FLIM (Faithful Library about Internet Message).
15 ;; This program is free software; you can redistribute it and/or
16 ;; modify it under the terms of the GNU General Public License as
17 ;; published by the Free Software Foundation; either version 2, or (at
18 ;; your option) any later version.
20 ;; This program is distributed in the hope that it will be useful, but
21 ;; WITHOUT ANY WARRANTY; without even the implied warranty of
22 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
23 ;; General Public License for more details.
25 ;; You should have received a copy of the GNU General Public License
26 ;; along with this program; see the file COPYING. If not, write to the
27 ;; Free Software Foundation, Inc., 59 Temple Place - Suite 330,
28 ;; Boston, MA 02111-1307, USA.
35 (require 'mail-utils) ; mail-strip-quoted-names
37 (eval-when-compile (require 'sasl))
39 (autoload 'starttls-open-stream "starttls")
40 (autoload 'starttls-negotiate "starttls")
41 (autoload 'sasl-cram-md5 "sasl")
42 (autoload 'sasl-plain "sasl")
43 (autoload 'sasl-scram-md5-client-msg-1 "sasl")
44 (autoload 'sasl-scram-md5-client-msg-2 "sasl")
45 (autoload 'sasl-scram-md5-authenticate-server "sasl")
46 (autoload 'sasl-digest-md5-digest-response "sasl"))
48 (eval-when-compile (require 'cl)) ; push
51 "SMTP protocol for sending mail."
54 (defcustom smtp-default-server nil
55 "*Specify default SMTP server."
56 :type '(choice (const nil) string)
59 (defcustom smtp-server (or (getenv "SMTPSERVER") smtp-default-server)
60 "*The name of the host running SMTP server. It can also be a function
61 called from `smtp-via-smtp' with arguments SENDER and RECIPIENTS."
62 :type '(choice (string :tag "Name")
63 (function :tag "Function"))
66 (defcustom smtp-service "smtp"
67 "*SMTP service port number. \"smtp\" or 25."
68 :type '(choice (integer :tag "25" 25)
69 (string :tag "smtp" "smtp"))
72 (defcustom smtp-use-8bitmime t
73 "*If non-nil, use ESMTP 8BITMIME if available."
77 (defcustom smtp-local-domain nil
78 "*Local domain name without a host name.
79 If the function (system-name) returns the full internet address,
80 don't define this value."
81 :type '(choice (const nil) string)
84 (defcustom smtp-debug-info nil
85 "*smtp debug info printout. messages and process buffer."
89 (defcustom smtp-notify-success nil
90 "*If non-nil, notification for successful mail delivery is returned
95 (defcustom smtp-authenticate-type nil
96 "*SMTP authentication mechanism (RFC2554)."
100 (defvar smtp-authenticate-user nil)
101 (defvar smtp-authenticate-passphrase nil)
103 (defvar smtp-authenticate-method-alist
104 '((cram-md5 smtp-auth-cram-md5)
105 (plain smtp-auth-plain)
106 (login smtp-auth-login)
107 (anonymous smtp-auth-anonymous)
108 (scram-md5 smtp-auth-scram-md5)
109 (digest-md5 smtp-auth-digest-md5)))
111 (defcustom smtp-connection-type nil
112 "*SMTP connection type."
113 :type '(choice (const nil) (const :tag "TLS" starttls))
116 (defvar smtp-read-point nil)
118 (defun smtp-make-fqdn ()
119 "Return user's fully qualified domain name."
120 (let ((system-name (system-name)))
123 (concat system-name "." smtp-local-domain))
124 ((string-match "[^.]\\.[^.]" system-name)
127 (error "Cannot generate valid FQDN. Set `smtp-local-domain' correctly.")))))
129 (defun smtp-via-smtp (sender recipients smtp-text-buffer)
130 (let ((server (if (functionp smtp-server)
131 (funcall smtp-server sender recipients)
133 process response extensions)
137 (format "*trace of SMTP session to %s*" server)))
139 (make-local-variable 'smtp-read-point)
140 (setq smtp-read-point (point-min))
145 (if smtp-connection-type
147 (starttls-open-stream
148 "SMTP" (current-buffer) server smtp-service))
149 (open-network-stream-as-binary
150 "SMTP" (current-buffer) server smtp-service)))
152 (set-process-filter process 'smtp-process-filter)
154 (if (eq smtp-connection-type 'force)
155 (starttls-negotiate process))
158 (setq response (smtp-read-response process))
159 (if (or (null (car response))
160 (not (integerp (car response)))
161 (>= (car response) 400))
162 (throw 'done (car (cdr response))))
165 (smtp-send-command process
166 (format "EHLO %s" (smtp-make-fqdn)))
167 (setq response (smtp-read-response process))
168 (if (or (null (car response))
169 (not (integerp (car response)))
170 (>= (car response) 400))
173 (smtp-send-command process
174 (format "HELO %s" (smtp-make-fqdn)))
175 (setq response (smtp-read-response process))
176 (if (or (null (car response))
177 (not (integerp (car response)))
178 (>= (car response) 400))
179 (throw 'done (car (cdr response)))))
180 (let ((extension-lines (cdr (cdr response)))
182 (while extension-lines
186 (downcase (substring (car extension-lines) 4))))
187 (while (string-match "\\([^ ]+\\)" extension (match-end 1))
188 (push (intern (match-string 1 extension)) extensions))
189 (push (intern extension) extensions))
190 (setq extension-lines (cdr extension-lines)))))
192 ;; STARTTLS --- begin a TLS negotiation (RFC 2595)
193 (when (and smtp-connection-type
194 (null (eq smtp-connection-type 'force))
195 (memq 'starttls extensions))
196 (smtp-send-command process "STARTTLS")
197 (setq response (smtp-read-response process))
198 (if (or (null (car response))
199 (not (integerp (car response)))
200 (>= (car response) 400))
201 (throw 'done (car (cdr response))))
202 (starttls-negotiate process)
203 ;; for sendmail warning XXX
204 (smtp-send-command process (format "HELO %s" (smtp-make-fqdn)))
205 (setq response (smtp-read-response process)))
207 ;; AUTH --- SMTP Service Extension for Authentication (RFC2554)
208 (when smtp-authenticate-type
209 (let ((auth smtp-authenticate-type) method)
211 (memq auth extensions)
212 (setq method (nth 1 (assq auth smtp-authenticate-method-alist))))
213 (funcall method process)
215 (format "AUTH mechanism %s not available" auth)))))
217 ;; ONEX --- One message transaction only (sendmail extension?)
218 ;;; (if (or (memq 'onex extensions)
219 ;;; (memq 'xone extensions))
221 ;;; (smtp-send-command process "ONEX")
222 ;;; (setq response (smtp-read-response process))
223 ;;; (if (or (null (car response))
224 ;;; (not (integerp (car response)))
225 ;;; (>= (car response) 400))
226 ;;; (throw 'done (car (cdr response))))))
228 ;; VERB --- Verbose (sendmail extension?)
229 ;;; (if (and smtp-debug-info
230 ;;; (or (memq 'verb extensions)
231 ;;; (memq 'xvrb extensions)))
233 ;;; (smtp-send-command process "VERB")
234 ;;; (setq response (smtp-read-response process))
235 ;;; (if (or (null (car response))
236 ;;; (not (integerp (car response)))
237 ;;; (>= (car response) 400))
238 ;;; (throw 'done (car (cdr response))))))
240 ;; XUSR --- Initial (user) submission (sendmail extension?)
241 ;;; (if (memq 'xusr extensions)
243 ;;; (smtp-send-command process "XUSR")
244 ;;; (setq response (smtp-read-response process))
245 ;;; (if (or (null (car response))
246 ;;; (not (integerp (car response)))
247 ;;; (>= (car response) 400))
248 ;;; (throw 'done (car (cdr response))))))
250 ;; MAIL FROM:<sender>
253 (format "MAIL FROM:<%s>%s%s"
255 ;; SIZE --- Message Size Declaration (RFC1870)
256 (if (memq 'size extensions)
259 (set-buffer smtp-text-buffer)
260 (+ (- (point-max) (point-min))
261 ;; Add one byte for each change-of-line
262 ;; because or CR-LF representation:
263 (count-lines (point-min) (point-max))
264 ;; For some reason, an empty line is
265 ;; added to the message. Maybe this
266 ;; is a bug, but it can't hurt to add
267 ;; those two bytes anyway:
270 ;; 8BITMIME --- 8bit-MIMEtransport (RFC1652)
271 (if (and (memq '8bitmime extensions)
275 (setq response (smtp-read-response process))
276 (if (or (null (car response))
277 (not (integerp (car response)))
278 (>= (car response) 400))
279 (throw 'done (car (cdr response))))
281 ;; RCPT TO:<recipient>
283 (smtp-send-command process
285 (if smtp-notify-success
286 "RCPT TO:<%s> NOTIFY=SUCCESS"
289 (setq recipients (cdr recipients))
290 (setq response (smtp-read-response process))
291 (if (or (null (car response))
292 (not (integerp (car response)))
293 (>= (car response) 400))
294 (throw 'done (car (cdr response)))))
297 (smtp-send-command process "DATA")
298 (setq response (smtp-read-response process))
299 (if (or (null (car response))
300 (not (integerp (car response)))
301 (>= (car response) 400))
302 (throw 'done (car (cdr response))))
305 (smtp-send-data process smtp-text-buffer)
308 (smtp-send-command process ".")
309 (setq response (smtp-read-response process))
310 (if (or (null (car response))
311 (not (integerp (car response)))
312 (>= (car response) 400))
313 (throw 'done (car (cdr response))))
318 (memq (process-status process) '(open run)))
321 (smtp-send-command process "QUIT")
322 (smtp-read-response process)
323 (delete-process process)))))))
325 (defun smtp-process-filter (process output)
327 (set-buffer (process-buffer process))
328 (goto-char (point-max))
331 (defun smtp-read-response (process)
332 (let ((case-fold-search nil)
333 (response-strings nil)
334 (response-continue t)
335 (return-value '(nil ()))
338 (while response-continue
339 (goto-char smtp-read-point)
340 (while (not (search-forward "\r\n" nil t))
341 (accept-process-output process)
342 (goto-char smtp-read-point))
344 (setq match-end (point))
345 (setq response-strings
346 (cons (buffer-substring smtp-read-point (- match-end 2))
349 (goto-char smtp-read-point)
350 (if (looking-at "[0-9]+ ")
351 (let ((begin (match-beginning 0))
354 (message "%s" (car response-strings)))
356 (setq smtp-read-point match-end)
358 ;; ignore lines that start with "0"
359 (if (looking-at "0[0-9]+ ")
361 (setq response-continue nil)
364 (buffer-substring begin end))
365 (nreverse response-strings)))))
367 (if (looking-at "[0-9]+-")
368 (progn (if smtp-debug-info
369 (message "%s" (car response-strings)))
370 (setq smtp-read-point match-end)
371 (setq response-continue t))
373 (setq smtp-read-point match-end)
374 (setq response-continue nil)
376 (cons nil (nreverse response-strings)))))))
377 (setq smtp-read-point match-end)
380 (defun smtp-send-command (process command &optional secure)
381 (goto-char (point-max))
383 (insert "Here is insecure words.\r\n")
384 (insert command "\r\n"))
385 (setq smtp-read-point (point))
386 (process-send-string process command)
387 (process-send-string process "\r\n"))
389 (defun smtp-send-data-1 (process data)
390 (goto-char (point-max))
392 (insert data "\r\n"))
393 (setq smtp-read-point (point))
394 ;; Escape "." at start of a line.
395 (if (eq (string-to-char data) ?.)
396 (process-send-string process "."))
397 (process-send-string process data)
398 (process-send-string process "\r\n"))
400 (defun smtp-send-data (process buffer)
401 (let ((data-continue t)
408 (goto-char (point-min)))
414 (setq this-line (point))
416 (setq this-line-end (point))
417 (setq sending-data nil)
418 (setq sending-data (buffer-substring this-line this-line-end))
419 (if (or (/= (forward-line 1) 0) (eobp))
420 (setq data-continue nil)))
422 (smtp-send-data-1 process sending-data))))
424 (defun smtp-deduce-address-list (smtp-text-buffer header-start header-end)
425 "Get address list suitable for smtp RCPT TO:<address>."
426 (let ((simple-address-list "")
430 (smtp-address-buffer (generate-new-buffer " *smtp-mail*")))
434 (set-buffer smtp-address-buffer)
435 (setq case-fold-search t)
437 (insert (save-excursion
438 (set-buffer smtp-text-buffer)
439 (buffer-substring-no-properties header-start header-end)))
440 (goto-char (point-min))
441 ;; RESENT-* fields should stop processing of regular fields.
443 (if (re-search-forward "^RESENT-TO:" header-end t)
445 "^\\(RESENT-TO:\\|RESENT-CC:\\|RESENT-BCC:\\)")
446 (setq addr-regexp "^\\(TO:\\|CC:\\|BCC:\\)")))
448 (while (re-search-forward addr-regexp header-end t)
450 (setq this-line (match-beginning 0))
452 ;; get any continuation lines.
453 (while (and (looking-at "^[ \t]+") (< (point) header-end))
455 (setq this-line-end (point-marker))
456 (setq simple-address-list
457 (concat simple-address-list " "
458 (mail-strip-quoted-names
459 (buffer-substring this-line this-line-end)))))
462 (insert-string simple-address-list)
465 (subst-char-in-region (point-min) (point-max) 10 ? t)
467 (subst-char-in-region (point-min) (point-max) ?, ? t)
469 (subst-char-in-region (point-min) (point-max) 9 ? t)
471 (goto-char (point-min))
472 ;; tidyness in case hook is not robust when it looks at this
473 (while (re-search-forward "[ \t]+" header-end t) (replace-match " "))
475 (goto-char (point-min))
476 (let (recipient-address-list)
477 (while (re-search-forward " \\([^ ]+\\) " (point-max) t)
479 (setq recipient-address-list
480 (cons (buffer-substring (match-beginning 1) (match-end 1))
481 recipient-address-list)))
482 recipient-address-list))
483 (kill-buffer smtp-address-buffer))))
485 (defun smtp-auth-cram-md5 (process)
486 (let ((secure-word (copy-sequence smtp-authenticate-passphrase))
488 (smtp-send-command process "AUTH CRAM-MD5")
489 (setq response (smtp-read-response process))
490 (if (or (null (car response))
491 (not (integerp (car response)))
492 (>= (car response) 400))
493 (throw 'done (car (cdr response))))
496 (setq secure-word (unwind-protect
498 smtp-authenticate-user secure-word
499 (base64-decode-string
500 (substring (car (cdr response)) 4)))
501 (fillarray secure-word 0))
502 secure-word (unwind-protect
503 (base64-encode-string secure-word)
504 (fillarray secure-word 0))) t)
505 (fillarray secure-word 0)
506 (setq response (smtp-read-response process))
507 (if (or (null (car response))
508 (not (integerp (car response)))
509 (>= (car response) 400))
510 (throw 'done (car (cdr response))))))
512 (defun smtp-auth-plain (process)
513 (let ((secure-word (copy-sequence smtp-authenticate-passphrase))
517 (setq secure-word (unwind-protect
518 (sasl-plain "" smtp-authenticate-user secure-word)
519 (fillarray secure-word 0))
520 secure-word (unwind-protect
521 (base64-encode-string secure-word)
522 (fillarray secure-word 0))
523 secure-word (unwind-protect
524 (concat "AUTH PLAIN " secure-word)
525 (fillarray secure-word 0))) t)
526 (fillarray secure-word 0)
527 (setq response (smtp-read-response process))
528 (if (or (null (car response))
529 (not (integerp (car response)))
530 (>= (car response) 400))
531 (throw 'done (car (cdr response))))))
533 (defun smtp-auth-login (process)
534 (let ((secure-word (copy-sequence smtp-authenticate-passphrase))
536 (smtp-send-command process "AUTH LOGIN")
537 (setq response (smtp-read-response process))
538 (if (or (null (car response))
539 (not (integerp (car response)))
540 (>= (car response) 400))
541 (throw 'done (car (cdr response))))
544 (base64-encode-string
545 smtp-authenticate-user))
546 (setq response (smtp-read-response process))
547 (if (or (null (car response))
548 (not (integerp (car response)))
549 (>= (car response) 400))
550 (throw 'done (car (cdr response))))
553 (setq secure-word (unwind-protect
554 (base64-encode-string secure-word)
555 (fillarray secure-word 0))) t)
556 (fillarray secure-word 0)
557 (setq response (smtp-read-response process))
558 (if (or (null (car response))
559 (not (integerp (car response)))
560 (>= (car response) 400))
561 (throw 'done (car (cdr response))))))
563 (defun smtp-auth-anonymous (process &optional token)
566 process "AUTH ANONYMOUS")
567 (setq response (smtp-read-response process))
568 (if (or (null (car response))
569 (not (integerp (car response)))
570 (>= (car response) 400))
571 (throw 'done (car (cdr response))))
572 (smtp-send-command process
573 (base64-encode-string
577 (setq response (smtp-read-response process))
578 (if (or (null (car response))
579 (not (integerp (car response)))
580 (>= (car response) 400))
581 (throw 'done (car (cdr response))))))
583 (defun smtp-auth-scram-md5 (process)
585 (let (server-msg-1 server-msg-2 client-msg-1 salted-pass
586 response secure-word)
587 (smtp-send-command process "AUTH SCRAM-MD5")
588 (setq response (smtp-read-response process))
589 (if (or (null (car response))
590 (not (integerp (car response)))
591 (>= (car response) 400))
592 (throw 'done (car (cdr response))))
597 (base64-encode-string
599 (sasl-scram-md5-client-msg-1
600 smtp-authenticate-user)))) t)
601 (fillarray secure-word 0))
602 (setq response (smtp-read-response process))
603 (if (or (null (car response))
604 (not (integerp (car response)))
605 (>= (car response) 400))
607 (fillarray client-msg-1 0)
608 (throw 'done (car (cdr response)))))
611 (substring (car (cdr response)) 4)
612 (fillarray (car (cdr response)) 0)))
615 (base64-decode-string secure-word)
616 (fillarray secure-word 0)))
618 (sasl-scram-md5-client-msg-2
619 server-msg-1 client-msg-1
621 (sasl-scram-md5-make-salted-pass
622 smtp-authenticate-passphrase server-msg-1))))
625 (base64-encode-string secure-word)
626 (fillarray secure-word 0)))
628 (smtp-send-command process secure-word t)
629 (fillarray secure-word 0))
630 (setq response (smtp-read-response process))
631 (if (or (null (car response))
632 (not (integerp (car response)))
633 (>= (car response) 400))
635 (fillarray salted-pass 0)
636 (fillarray server-msg-1 0)
637 (fillarray client-msg-1 0)
638 (throw 'done (car (cdr response)))))
641 (base64-decode-string
643 (substring (car (cdr response)) 4)))
644 (fillarray secure-word 0)))
647 (sasl-scram-md5-authenticate-server
652 (fillarray salted-pass 0)
653 (fillarray server-msg-1 0)
654 (fillarray server-msg-2 0)
655 (fillarray client-msg-1 0)))
657 (smtp-send-command process "")
658 (setq response (smtp-read-response process))
659 (if (or (null (car response))
660 (not (integerp (car response)))
661 (>= (car response) 400))
662 (throw 'done (car (cdr response)))) ))
664 (defun smtp-auth-digest-md5 (process)
665 "Login to server using the AUTH DIGEST-MD5 method."
666 (let (user realm response)
667 (smtp-send-command process "AUTH DIGEST-MD5")
668 (setq response (smtp-read-response process))
669 (if (or (null (car response))
670 (not (integerp (car response)))
671 (>= (car response) 400))
672 (throw 'done (car (cdr response))))
673 (if (string-match "^\\([^@]*\\)@\\([^@]*\\)"
674 smtp-authenticate-user)
675 (setq user (match-string 1 smtp-authenticate-user)
676 realm (match-string 2 smtp-authenticate-user))
677 (setq user smtp-authenticate-user
679 (smtp-send-command process
680 (base64-encode-string
681 (sasl-digest-md5-digest-response
682 (base64-decode-string
683 (substring (car (cdr response)) 4))
685 smtp-authenticate-passphrase
686 "smtp" smtp-server realm)
688 (setq response (smtp-read-response process))
689 (if (or (null (car response))
690 (not (integerp (car response)))
691 (>= (car response) 400))
692 (throw 'done (car (cdr response))))
693 (smtp-send-command process "")))
697 ;;; smtp.el ends here