;; Copyright (C) 1995, 1996, 1998, 1999 Free Software Foundation, Inc.
;; Author: Tomoji Kagatani <kagatani@rbc.ncl.omron.co.jp>
-;; Simon Leinen <simon@switch.ch> (ESMTP support)
-;; Shuhei KOBAYASHI <shuhei@aqua.ocn.ne.jp>
-;; Kenichi OKADA <okada@opaopa.org> (SASL support)
+;; Simon Leinen <simon@switch.ch> (ESMTP support)
+;; Shuhei KOBAYASHI <shuhei@aqua.ocn.ne.jp>
+;; Kenichi OKADA <okada@opaopa.org> (SASL support)
+;; Daiki Ueno <ueno@ueda.info.waseda.ac.jp>
+;; Maintainer: Kenichi OKADA <okada@opaopa.org>
;; Keywords: SMTP, mail, SASL
;; This file is part of FLIM (Faithful Library about Internet Message).
(require 'poem)
(require 'pcustom)
(require 'mail-utils) ; mail-strip-quoted-names
-(require 'sasl)
-(require 'starttls)
+(eval-when-compile (require 'sasl))
+(eval-and-compile
+ (autoload 'starttls-open-stream "starttls")
+ (autoload 'starttls-negotiate "starttls")
+ (autoload 'sasl-cram-md5 "sasl")
+ (autoload 'sasl-plain "sasl")
+ (autoload 'sasl-scram-md5-client-msg-1 "sasl")
+ (autoload 'sasl-scram-md5-client-msg-2 "sasl")
+ (autoload 'sasl-scram-md5-authenticate-server "sasl")
+ (autoload 'sasl-digest-md5-digest-response "sasl"))
+
(eval-when-compile (require 'cl)) ; push
(defgroup smtp nil
to user (RFC1891)."
:type 'boolean
:group 'smtp)
-
+
+(defcustom smtp-authenticate-type nil
+ "*SMTP authentication mechanism (RFC2554)."
+ :type 'symbol
+ :group 'smtp)
+
+(defvar smtp-authenticate-user nil)
+(defvar smtp-authenticate-passphrase nil)
+
+(defvar smtp-authenticate-method-alist
+ '((cram-md5 smtp-auth-cram-md5)
+ (plain smtp-auth-plain)
+ (login smtp-auth-login)
+ (anonymous smtp-auth-anonymous)
+ (scram-md5 smtp-auth-scram-md5)
+ (digest-md5 smtp-auth-digest-md5)))
+
+(defcustom smtp-connection-type nil
+ "*SMTP connection type."
+ :type '(choice (const nil) (const :tag "TLS" starttls))
+ :group 'smtp)
+
(defvar smtp-read-point nil)
(defun smtp-make-fqdn ()
(t
(error "Cannot generate valid FQDN. Set `smtp-local-domain' correctly.")))))
-(defun smtp-via-smtp (sender recipients smtp-text-buffer
- &optional auth user passphrase starttls)
+(defun smtp-via-smtp (sender recipients smtp-text-buffer)
(let ((server (if (functionp smtp-server)
(funcall smtp-server sender recipients)
smtp-server))
(erase-buffer)
(make-local-variable 'smtp-read-point)
(setq smtp-read-point (point-min))
-
+
(unwind-protect
(catch 'done
(setq process
- (if starttls
- (starttls-open-stream
- "SMTP" (current-buffer) server smtp-service)
+ (if smtp-connection-type
+ (as-binary-process
+ (starttls-open-stream
+ "SMTP" (current-buffer) server smtp-service))
(open-network-stream-as-binary
"SMTP" (current-buffer) server smtp-service)))
- (or process (throw 'done nil))
-
+
(set-process-filter process 'smtp-process-filter)
-
- (if (eq starttls 'force)
+
+ (if (eq smtp-connection-type 'force)
(starttls-negotiate process))
-
+
;; Greeting
(setq response (smtp-read-response process))
(if (or (null (car response))
(not (integerp (car response)))
(>= (car response) 400))
(throw 'done (car (cdr response))))
-
+
;; EHLO
(smtp-send-command process
(format "EHLO %s" (smtp-make-fqdn)))
(push (intern (match-string 1 extension)) extensions))
(push (intern extension) extensions))
(setq extension-lines (cdr extension-lines)))))
-
+
;; STARTTLS --- begin a TLS negotiation (RFC 2595)
- (when (and starttls
- (null (eq starttls 'force))
+ (when (and smtp-connection-type
+ (null (eq smtp-connection-type 'force))
(memq 'starttls extensions))
(smtp-send-command process "STARTTLS")
(setq response (smtp-read-response process))
(starttls-negotiate process))
;; AUTH --- SMTP Service Extension for Authentication (RFC2554)
- (when auth
- (if (null (memq (intern auth) extensions))
- (throw 'done
- (concat "AUTH mechanism " auth " not available")))
-
- (cond ((string= "cram-md5" auth)
- (smtp-send-command process "AUTH CRAM-MD5")
- (setq response (smtp-read-response process))
- (if (or (null (car response))
- (not (integerp (car response)))
- (>= (car response) 400))
- (throw 'done (car (cdr response))))
- (smtp-send-command
- process
- (base64-encode-string
- (sasl-cram-md5
- user passphrase
- (base64-decode-string
- (substring (car (cdr response)) 4)))))
- (setq response (smtp-read-response process))
- (if (or (null (car response))
- (not (integerp (car response)))
- (>= (car response) 400))
- (throw 'done (car (cdr response)))))
-
- ((string= "plain" auth)
- (let ((enc-word (copy-sequence passphrase)))
- (smtp-send-command
- process
- (setq enc-word (unwind-protect
- (sasl-plain "" user enc-word)
- (fillarray enc-word 0))
- enc-word (unwind-protect
- (base64-encode-string enc-word)
- (fillarray enc-word 0))
- enc-word (unwind-protect
- (concat "AUTH PLAIN " enc-word)
- (fillarray enc-word 0))))
- (fillarray enc-word 0))
- (setq response (smtp-read-response process))
- (if (or (null (car response))
- (not (integerp (car response)))
- (>= (car response) 400))
- (throw 'done (car (cdr response)))))
-
- ((string= "login" auth)
- (smtp-send-command
- process
- (concat "AUTH LOGIN " user))
- (setq response (smtp-read-response process))
- (if (or (null (car response))
- (not (integerp (car response)))
- (>= (car response) 400))
- (throw 'done (car (cdr response))))
- (smtp-send-command
- process
- (base64-encode-string passphrase))
- (setq response (smtp-read-response process))
- (if (or (null (car response))
- (not (integerp (car response)))
- (>= (car response) 400))
- (throw 'done (car (cdr response)))))
-
- (t
- (throw 'done (concat "AUTH " auth " not supported")))))
+ (when smtp-authenticate-type
+ (let ((auth smtp-authenticate-type) method)
+ (if (and
+ (memq auth extensions)
+ (setq method (nth 1 (assq auth smtp-authenticate-method-alist))))
+ (funcall method process)
+ (throw 'done
+ (format "AUTH mechanism %s not available" auth)))))
;; ONEX --- One message transaction only (sendmail extension?)
- (if (or (memq 'onex extensions)
- (memq 'xone extensions))
- (progn
- (smtp-send-command process "ONEX")
- (setq response (smtp-read-response process))
- (if (or (null (car response))
- (not (integerp (car response)))
- (>= (car response) 400))
- (throw 'done (car (cdr response))))))
+;;; (if (or (memq 'onex extensions)
+;;; (memq 'xone extensions))
+;;; (progn
+;;; (smtp-send-command process "ONEX")
+;;; (setq response (smtp-read-response process))
+;;; (if (or (null (car response))
+;;; (not (integerp (car response)))
+;;; (>= (car response) 400))
+;;; (throw 'done (car (cdr response))))))
;; VERB --- Verbose (sendmail extension?)
- (if (and smtp-debug-info
- (or (memq 'verb extensions)
- (memq 'xvrb extensions)))
- (progn
- (smtp-send-command process "VERB")
- (setq response (smtp-read-response process))
- (if (or (null (car response))
- (not (integerp (car response)))
- (>= (car response) 400))
- (throw 'done (car (cdr response))))))
+;;; (if (and smtp-debug-info
+;;; (or (memq 'verb extensions)
+;;; (memq 'xvrb extensions)))
+;;; (progn
+;;; (smtp-send-command process "VERB")
+;;; (setq response (smtp-read-response process))
+;;; (if (or (null (car response))
+;;; (not (integerp (car response)))
+;;; (>= (car response) 400))
+;;; (throw 'done (car (cdr response))))))
;; XUSR --- Initial (user) submission (sendmail extension?)
- (if (memq 'xusr extensions)
- (progn
- (smtp-send-command process "XUSR")
- (setq response (smtp-read-response process))
- (if (or (null (car response))
- (not (integerp (car response)))
- (>= (car response) 400))
- (throw 'done (car (cdr response))))))
+;;; (if (memq 'xusr extensions)
+;;; (progn
+;;; (smtp-send-command process "XUSR")
+;;; (setq response (smtp-read-response process))
+;;; (if (or (null (car response))
+;;; (not (integerp (car response)))
+;;; (>= (car response) 400))
+;;; (throw 'done (car (cdr response))))))
;; MAIL FROM:<sender>
(smtp-send-command
(not (integerp (car response)))
(>= (car response) 400))
(throw 'done (car (cdr response))))
-
+
t)
(if (and process
- (eq (process-status process) 'open))
- (progn
- ;; QUIT
- (smtp-send-command process "QUIT")
- (smtp-read-response process)
- (delete-process process)))))))
+ (memq (process-status process) '(open run)))
+ (progn
+ ;; QUIT
+ (smtp-send-command process "QUIT")
+ (smtp-read-response process)
+ (delete-process process)))))))
(defun smtp-process-filter (process output)
(save-excursion
(setq smtp-read-point match-end)
return-value))
-(defun smtp-send-command (process command)
+(defun smtp-send-command (process command &optional secure)
(goto-char (point-max))
- (insert command "\r\n")
+ (if secure
+ (insert "Here is insecure words.\r\n")
+ (insert command "\r\n"))
(setq smtp-read-point (point))
(process-send-string process command)
(process-send-string process "\r\n"))
recipient-address-list))
(kill-buffer smtp-address-buffer))))
+(defun smtp-auth-cram-md5 (process)
+ (let ((secure-word (copy-sequence smtp-authenticate-passphrase))
+ response)
+ (smtp-send-command process "AUTH CRAM-MD5")
+ (setq response (smtp-read-response process))
+ (if (or (null (car response))
+ (not (integerp (car response)))
+ (>= (car response) 400))
+ (throw 'done (car (cdr response))))
+ (smtp-send-command
+ process
+ (setq secure-word (unwind-protect
+ (sasl-cram-md5
+ smtp-authenticate-user secure-word
+ (base64-decode-string
+ (substring (car (cdr response)) 4)))
+ (fillarray secure-word 0))
+ secure-word (unwind-protect
+ (base64-encode-string secure-word)
+ (fillarray secure-word 0))) t)
+ (fillarray secure-word 0)
+ (setq response (smtp-read-response process))
+ (if (or (null (car response))
+ (not (integerp (car response)))
+ (>= (car response) 400))
+ (throw 'done (car (cdr response))))))
+
+(defun smtp-auth-plain (process)
+ (let ((secure-word (copy-sequence smtp-authenticate-passphrase))
+ response)
+ (smtp-send-command
+ process
+ (setq secure-word (unwind-protect
+ (sasl-plain "" smtp-authenticate-user secure-word)
+ (fillarray secure-word 0))
+ secure-word (unwind-protect
+ (base64-encode-string secure-word)
+ (fillarray secure-word 0))
+ secure-word (unwind-protect
+ (concat "AUTH PLAIN " secure-word)
+ (fillarray secure-word 0))) t)
+ (fillarray secure-word 0)
+ (setq response (smtp-read-response process))
+ (if (or (null (car response))
+ (not (integerp (car response)))
+ (>= (car response) 400))
+ (throw 'done (car (cdr response))))))
+
+(defun smtp-auth-login (process)
+ (let ((secure-word (copy-sequence smtp-authenticate-passphrase))
+ response)
+ (smtp-send-command process "AUTH LOGIN")
+ (setq response (smtp-read-response process))
+ (if (or (null (car response))
+ (not (integerp (car response)))
+ (>= (car response) 400))
+ (throw 'done (car (cdr response))))
+ (smtp-send-command
+ process
+ (base64-encode-string
+ smtp-authenticate-user))
+ (setq response (smtp-read-response process))
+ (if (or (null (car response))
+ (not (integerp (car response)))
+ (>= (car response) 400))
+ (throw 'done (car (cdr response))))
+ (smtp-send-command
+ process
+ (setq secure-word (unwind-protect
+ (base64-encode-string secure-word)
+ (fillarray secure-word 0))) t)
+ (fillarray secure-word 0)
+ (setq response (smtp-read-response process))
+ (if (or (null (car response))
+ (not (integerp (car response)))
+ (>= (car response) 400))
+ (throw 'done (car (cdr response))))))
+
+(defun smtp-auth-anonymous (process &optional token)
+ (let (response)
+ (smtp-send-command
+ process "AUTH ANONYMOUS")
+ (setq response (smtp-read-response process))
+ (if (or (null (car response))
+ (not (integerp (car response)))
+ (>= (car response) 400))
+ (throw 'done (car (cdr response))))
+ (smtp-send-command process
+ (base64-encode-string
+ (or token
+ user-mail-address
+ "")))
+ (setq response (smtp-read-response process))
+ (if (or (null (car response))
+ (not (integerp (car response)))
+ (>= (car response) 400))
+ (throw 'done (car (cdr response))))))
+
+(defun smtp-auth-scram-md5 (process)
+ ;; now tesing
+ (let (server-msg-1 server-msg-2 client-msg-1 salted-pass
+ response secure-word)
+ (smtp-send-command process "AUTH SCRAM-MD5")
+ (setq response (smtp-read-response process))
+ (if (or (null (car response))
+ (not (integerp (car response)))
+ (>= (car response) 400))
+ (throw 'done (car (cdr response))))
+ (unwind-protect
+ (smtp-send-command
+ process
+ (setq secure-word
+ (base64-encode-string
+ (setq client-msg-1
+ (sasl-scram-md5-client-msg-1
+ smtp-authenticate-user)))) t)
+ (fillarray secure-word 0))
+ (setq response (smtp-read-response process))
+ (if (or (null (car response))
+ (not (integerp (car response)))
+ (>= (car response) 400))
+ (progn
+ (fillarray client-msg-1 0)
+ (throw 'done (car (cdr response)))))
+ (setq secure-word
+ (unwind-protect
+ (substring (car (cdr response)) 4)
+ (fillarray (car (cdr response)) 0)))
+ (setq server-msg-1
+ (unwind-protect
+ (base64-decode-string secure-word)
+ (fillarray secure-word 0)))
+ (setq secure-word
+ (sasl-scram-md5-client-msg-2
+ server-msg-1 client-msg-1
+ (setq salted-pass
+ (sasl-scram-md5-make-salted-pass
+ smtp-authenticate-passphrase server-msg-1))))
+ (setq secure-word
+ (unwind-protect
+ (base64-encode-string secure-word)
+ (fillarray secure-word 0)))
+ (unwind-protect
+ (smtp-send-command process secure-word t)
+ (fillarray secure-word 0))
+ (setq response (smtp-read-response process))
+ (if (or (null (car response))
+ (not (integerp (car response)))
+ (>= (car response) 400))
+ (progn
+ (fillarray salted-pass 0)
+ (fillarray server-msg-1 0)
+ (fillarray client-msg-1 0)
+ (throw 'done (car (cdr response)))))
+ (setq server-msg-2
+ (unwind-protect
+ (base64-decode-string
+ (setq secure-word
+ (substring (car (cdr response)) 4)))
+ (fillarray secure-word 0)))
+ (if (null
+ (unwind-protect
+ (sasl-scram-md5-authenticate-server
+ server-msg-1
+ server-msg-2
+ client-msg-1
+ salted-pass)
+ (fillarray salted-pass 0)
+ (fillarray server-msg-1 0)
+ (fillarray server-msg-2 0)
+ (fillarray client-msg-1 0)))
+ (throw 'done nil))
+ (smtp-send-command process "")
+ (setq response (smtp-read-response process))
+ (if (or (null (car response))
+ (not (integerp (car response)))
+ (>= (car response) 400))
+ (throw 'done (car (cdr response)))) ))
+
+(defun smtp-auth-digest-md5 (process)
+ "Login to server using the AUTH DIGEST-MD5 method."
+ (let (user realm response)
+ (smtp-send-command process "AUTH DIGEST-MD5")
+ (setq response (smtp-read-response process))
+ (if (or (null (car response))
+ (not (integerp (car response)))
+ (>= (car response) 400))
+ (throw 'done (car (cdr response))))
+ (if (string-match "^\\([^@]*\\)@\\([^@]*\\)"
+ smtp-authenticate-user)
+ (setq user (match-string 1 smtp-authenticate-user)
+ realm (match-string 2 smtp-authenticate-user))
+ (setq user smtp-authenticate-user
+ realm nil))
+ (smtp-send-command process
+ (base64-encode-string
+ (sasl-digest-md5-digest-response
+ (base64-decode-string
+ (substring (car (cdr response)) 4))
+ user
+ smtp-authenticate-passphrase
+ "smtp" smtp-server realm)
+ 'no-line-break) t)
+ (setq response (smtp-read-response process))
+ (if (or (null (car response))
+ (not (integerp (car response)))
+ (>= (car response) 400))
+ (throw 'done (car (cdr response))))
+ (smtp-send-command process "")))
+
(provide 'smtp)
;;; smtp.el ends here