(require 'pcustom)
(require 'mail-utils) ; mail-strip-quoted-names
+(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-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
:type 'boolean
:group 'smtp)
-(defcustom smtp-authentication-type nil
+(defcustom smtp-authenticate-type nil
"*SMTP authentication mechanism (RFC2554)."
:type 'symbol
:group 'smtp)
-(defvar smtp-authentication-user nil)
-(defvar smtp-authentication-passphrase nil)
+(defvar smtp-authenticate-user nil)
+(defvar smtp-authenticate-passphrase nil)
-(defvar smtp-authentication-method-alist
+(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 ()
smtp-server))
process response extensions)
(save-excursion
- (as-binary-process
- (set-buffer
- (get-buffer-create
- (format "*trace of SMTP session to %s*" server)))
- (erase-buffer)
- (make-local-variable 'smtp-read-point)
- (setq smtp-read-point (point-min))
-
- (unwind-protect
+ (set-buffer
+ (get-buffer-create
+ (format "*trace of SMTP session to %s*" server)))
+ (erase-buffer)
+ (make-local-variable 'smtp-read-point)
+ (setq smtp-read-point (point-min))
+
+ (unwind-protect
(catch 'done
(setq process
(if smtp-connection-type
- (starttls-open-stream
- "SMTP" (current-buffer) server smtp-service)
+ (as-binary-process
+ (starttls-open-stream
+ "SMTP" (current-buffer) server smtp-service))
(open-network-stream-as-binary
"SMTP" (current-buffer) server smtp-service)))
-
+
(set-process-filter process 'smtp-process-filter)
-
+
(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))
+ (not (integerp (car response)))
+ (>= (car response) 400))
(throw 'done (car (cdr response))))
;; EHLO
(format "EHLO %s" (smtp-make-fqdn)))
(setq response (smtp-read-response process))
(if (or (null (car response))
- (not (integerp (car response)))
- (>= (car response) 400))
+ (not (integerp (car response)))
+ (>= (car response) 400))
(progn
;; HELO
(smtp-send-command process
(throw 'done (car (cdr response)))))
(let ((extension-lines (cdr (cdr response)))
extension)
- (while extension-lines
- (if (string-match
- "^auth "
- (setq extension
- (downcase (substring (car extension-lines) 4))))
- (while (string-match "\\([^ ]+\\)" extension (match-end 1))
- (push (intern (match-string 1 extension)) extensions))
- (push (intern extension) extensions))
- (setq extension-lines (cdr extension-lines)))))
+ (while extension-lines
+ (if (string-match
+ "^auth "
+ (setq extension
+ (downcase (substring (car extension-lines) 4))))
+ (while (string-match "\\([^ ]+\\)" extension (match-end 1))
+ (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 smtp-connection-type
- (null (eq smtp-connection-type 'force))
- (memq 'starttls extensions))
+ (null (eq smtp-connection-type 'force))
+ (memq 'starttls extensions))
(smtp-send-command process "STARTTLS")
(setq response (smtp-read-response process))
(if (or (null (car response))
(not (integerp (car response)))
(>= (car response) 400))
- (throw 'done (car (cdr response))))
+ (throw 'done (car (cdr response))))
(starttls-negotiate process))
;; AUTH --- SMTP Service Extension for Authentication (RFC2554)
- (when smtp-authentication-type
- (let ((auth (intern smtp-authentication-type)) method)
- (if (and
- (memq auth extensions)
- (setq method (nth 1 (assq auth smtp-authentication-method-alist))))
- (funcall method process)
- (throw 'smtp-error
- (format "AUTH mechanism %s not available" auth)))))
+ (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)
(smtp-send-command
process
(format "MAIL FROM:<%s>%s%s"
- sender
- ;; SIZE --- Message Size Declaration (RFC1870)
- (if (memq 'size extensions)
- (format " SIZE=%d"
- (save-excursion
- (set-buffer smtp-text-buffer)
- (+ (- (point-max) (point-min))
- ;; Add one byte for each change-of-line
- ;; because or CR-LF representation:
- (count-lines (point-min) (point-max))
- ;; For some reason, an empty line is
- ;; added to the message. Maybe this
- ;; is a bug, but it can't hurt to add
- ;; those two bytes anyway:
- 2)))
- "")
- ;; 8BITMIME --- 8bit-MIMEtransport (RFC1652)
- (if (and (memq '8bitmime extensions)
- smtp-use-8bitmime)
- " BODY=8BITMIME"
- "")))
+ sender
+ ;; SIZE --- Message Size Declaration (RFC1870)
+ (if (memq 'size extensions)
+ (format " SIZE=%d"
+ (save-excursion
+ (set-buffer smtp-text-buffer)
+ (+ (- (point-max) (point-min))
+ ;; Add one byte for each change-of-line
+ ;; because or CR-LF representation:
+ (count-lines (point-min) (point-max))
+ ;; For some reason, an empty line is
+ ;; added to the message. Maybe this
+ ;; is a bug, but it can't hurt to add
+ ;; those two bytes anyway:
+ 2)))
+ "")
+ ;; 8BITMIME --- 8bit-MIMEtransport (RFC1652)
+ (if (and (memq '8bitmime extensions)
+ smtp-use-8bitmime)
+ " BODY=8BITMIME"
+ "")))
(setq response (smtp-read-response process))
(if (or (null (car response))
- (not (integerp (car response)))
- (>= (car response) 400))
+ (not (integerp (car response)))
+ (>= (car response) 400))
(throw 'done (car (cdr response))))
;; RCPT TO:<recipient>
(while recipients
(smtp-send-command process
- (format
- (if smtp-notify-success
- "RCPT TO:<%s> NOTIFY=SUCCESS"
- "RCPT TO:<%s>")
- (car recipients)))
+ (format
+ (if smtp-notify-success
+ "RCPT TO:<%s> NOTIFY=SUCCESS"
+ "RCPT TO:<%s>")
+ (car recipients)))
(setq recipients (cdr recipients))
(setq response (smtp-read-response process))
(if (or (null (car response))
(not (integerp (car response)))
(>= (car response) 400))
- (throw 'done (car (cdr response)))))
+ (throw 'done (car (cdr response)))))
;; DATA
(smtp-send-command process "DATA")
(setq response (smtp-read-response process))
(if (or (null (car response))
- (not (integerp (car response)))
- (>= (car response) 400))
+ (not (integerp (car response)))
+ (>= (car response) 400))
(throw 'done (car (cdr response))))
;; Mail contents
(smtp-send-command process ".")
(setq response (smtp-read-response process))
(if (or (null (car response))
- (not (integerp (car response)))
- (>= (car response) 400))
+ (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))))))))
+ (if (and 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
(kill-buffer smtp-address-buffer))))
(defun smtp-auth-cram-md5 (process)
- (let ((secure-word (copy-sequence smtp-authentication-passphrase))
+ (let ((secure-word (copy-sequence smtp-authenticate-passphrase))
response)
(smtp-send-command process "AUTH CRAM-MD5")
(setq response (smtp-read-response process))
process
(setq secure-word (unwind-protect
(sasl-cram-md5
- smtp-authentication-user secure-word
+ smtp-authenticate-user secure-word
(base64-decode-string
(substring (car (cdr response)) 4)))
(fillarray secure-word 0))
(throw 'done (car (cdr response))))))
(defun smtp-auth-plain (process)
- (let ((secure-word (copy-sequence smtp-authentication-passphrase))
+ (let ((secure-word (copy-sequence smtp-authenticate-passphrase))
response)
(smtp-send-command
process
(setq secure-word (unwind-protect
- (sasl-plain "" smtp-authentication-user secure-word)
+ (sasl-plain "" smtp-authenticate-user secure-word)
(fillarray secure-word 0))
secure-word (unwind-protect
(base64-encode-string secure-word)
(throw 'done (car (cdr response))))))
(defun smtp-auth-login (process)
- (let ((secure-word (copy-sequence smtp-authentication-passphrase))
+ (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
- (concat "AUTH LOGIN " smtp-authentication-user))
+ (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))))))
+(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
projects / elisp / flim.git / blobdiff