Configuration notes for Emacs
The smime-keys variable allows additional
certificates to be associated to each mail address,
but the function (mml-secure-message-sign-smime)
only prompts for a keyfile and ignores them.
(More informations about this problem here:
http://lists.gnu.org/archive/html/emacs-bug-tracker/2011-01/msg00118.html.)
The following code is a patch I use in my .gnus file
to change the semantics of the keyfile
argument of the MML tag <#secure>
for being a mail address and not a filename.
This mail address is resolved with
(smime-get-key-with-certs-by-email)
on sending to include the full certification chain.
;; Patch to smime-sign-buffer and mml-smime-openssl-sign-query to put
;; the email address in the keyfile argument of <#secure> tag instead
;; of the key filename to take additional certificates into account when
;; signing a message.
(require 'smime) ; smime-sign-buffer comes from here
(defun smime-sign-buffer (&optional keyfile buffer)
"S/MIME sign BUFFER with key in KEYFILE.
KEYFILE should contain a PEM encoded key and certificate."
(interactive)
(with-current-buffer (or buffer (current-buffer))
(unless (smime-sign-region
(point-min) (point-max)
(if keyfile
(smime-get-key-with-certs-by-email keyfile)
(smime-get-key-with-certs-by-email
(completing-read
(concat "Sign using key"
(if smime-keys
(concat " (default " (caar smime-keys) "): ")
": "))
smime-keys nil nil (car-safe (car-safe smime-keys))))))
(error "Signing failed"))))
(require 'mml-smime) ; mml-smime-openssl-sign-query comes from here
(defun mml-smime-openssl-sign-query ()
;; query information (what certificate) from user when MML tag is
;; added, for use later by the signing process
(when (null smime-keys)
(customize-variable 'smime-keys)
(error "No S/MIME keys configured, use customize to add your key"))
(list 'keyfile
(if (= (length smime-keys) 1)
(caar smime-keys)
(or (let ((from (cadr (funcall (if (boundp
'gnus-extract-address-components)
gnus-extract-address-components
'mail-extract-address-components)
(or (save-excursion
(save-restriction
(message-narrow-to-headers)
(message-fetch-field "from")))
"")))))
(and from from))
(completing-read "Sign this part with what signature? "
smime-keys nil nil
(and (listp (car-safe smime-keys))
(caar smime-keys)))))))
The TLS support of Gnus is twice broken on Windows:
first,
lines in the process output buffer end with ^M
and this character prevents smtpmail.el to
parse the supported extensions correctly;
second,
GnuTLS requires a signal (or EOF) to be send for handshaking,
and this signal never occurs since Win32 doesn't have Unix
signals.
(See http://lists.gnu.org/archive/html/bug-gnu-emacs/2011-01/msg00442.html for more informations.)
The following code is a patch I use in my .gnus file
to remove the ^M from extension names to
correctly recognize the STARTTLS extension,
and to replace the SIGALRM signal by
the ^Z character which corresponds to
EOF on Windows.
(if (eq system-type 'windows-nt)
(progn
;; Patch smtpmail-via-smtp to ignore the ^M characters at the end of
;; each line of the process buffer when reading extensions.
(setq starttls-use-gnutls t)
(require 'smtpmail) ; smtpmail-via-smtp comes from here
(defun smtpmail-via-smtp (recipient smtpmail-text-buffer)
(let ((process nil)
(host (or smtpmail-smtp-server
(error "`smtpmail-smtp-server' not defined")))
(port smtpmail-smtp-service)
;; `smtpmail-mail-address' should be set to the appropriate
;; buffer-local value by the caller, but in case not:
(envelope-from (or smtpmail-mail-address
(and mail-specify-envelope-from
(mail-envelope-from))
user-mail-address))
response-code
greeting
process-buffer
(supported-extensions '()))
(unwind-protect
(catch 'done
;; get or create the trace buffer
(setq process-buffer
(get-buffer-create (format "*trace of SMTP session to %s*" host)))
;; clear the trace buffer of old output
(with-current-buffer process-buffer
(setq buffer-undo-list t)
(erase-buffer))
;; open the connection to the server
(setq process (smtpmail-open-stream process-buffer host port))
(and (null process) (throw 'done nil))
;; set the send-filter
(set-process-filter process 'smtpmail-process-filter)
(with-current-buffer process-buffer
(set-buffer-process-coding-system 'raw-text-unix 'raw-text-unix)
(make-local-variable 'smtpmail-read-point)
(setq smtpmail-read-point (point-min))
(if (or (null (car (setq greeting (smtpmail-read-response process))))
(not (integerp (car greeting)))
(>= (car greeting) 400))
(throw 'done nil))
(let ((do-ehlo t)
(do-starttls t))
(while do-ehlo
;; EHLO
(smtpmail-send-command process (format "EHLO %s" (smtpmail-fqdn)))
(if (or (null (car (setq response-code
(smtpmail-read-response process))))
(not (integerp (car response-code)))
(>= (car response-code) 400))
(progn
;; HELO
(smtpmail-send-command
process (format "HELO %s" (smtpmail-fqdn)))
(if (or (null (car (setq response-code
(smtpmail-read-response process))))
(not (integerp (car response-code)))
(>= (car response-code) 400))
(throw 'done nil)))
(dolist (line (cdr (cdr response-code)))
(let ((name
(with-case-table ascii-case-table
(mapcar (lambda (s) (intern (downcase s)))
(split-string (substring line 4 (- (length line) 1)) "[ ]")))))
(and (eq (length name) 1)
(setq name (car name)))
(and name
(cond ((memq (if (consp name) (car name) name)
'(verb xvrb 8bitmime onex xone
expn size dsn etrn
enhancedstatuscodes
help xusr
auth=login auth starttls))
(setq supported-extensions
(cons name supported-extensions)))
(smtpmail-warn-about-unknown-extensions
(message "Unknown extension %s" name)))))))
(if (and do-starttls
(smtpmail-find-credentials smtpmail-starttls-credentials host port)
(member 'starttls supported-extensions)
(numberp (process-id process)))
(progn
(smtpmail-send-command process (format "STARTTLS"))
(if (or (null (car (setq response-code (smtpmail-read-response process))))
(not (integerp (car response-code)))
(>= (car response-code) 400))
(throw 'done nil))
(starttls-negotiate process)
(setq do-starttls nil))
(setq do-ehlo nil))))
(smtpmail-try-auth-methods process supported-extensions host port)
(if (or (member 'onex supported-extensions)
(member 'xone supported-extensions))
(progn
(smtpmail-send-command process (format "ONEX"))
(if (or (null (car (setq response-code (smtpmail-read-response process))))
(not (integerp (car response-code)))
(>= (car response-code) 400))
(throw 'done nil))))
(if (and smtpmail-debug-verb
(or (member 'verb supported-extensions)
(member 'xvrb supported-extensions)))
(progn
(smtpmail-send-command process (format "VERB"))
(if (or (null (car (setq response-code (smtpmail-read-response process))))
(not (integerp (car response-code)))
(>= (car response-code) 400))
(throw 'done nil))))
(if (member 'xusr supported-extensions)
(progn
(smtpmail-send-command process (format "XUSR"))
(if (or (null (car (setq response-code (smtpmail-read-response process))))
(not (integerp (car response-code)))
(>= (car response-code) 400))
(throw 'done nil))))
;; MAIL FROM:<sender>
(let ((size-part
(if (or (member 'size supported-extensions)
(assoc 'size supported-extensions))
(format " SIZE=%d"
(with-current-buffer smtpmail-text-buffer
;; size estimate:
(+ (- (point-max) (point-min))
;; Add one byte for each change-of-line
;; because of CR-LF representation:
(count-lines (point-min) (point-max)))))
""))
(body-part
(if (member '8bitmime supported-extensions)
;; FIXME:
;; Code should be added here that transforms
;; the contents of the message buffer into
;; something the receiving SMTP can handle.
;; For a receiver that supports 8BITMIME, this
;; may mean converting BINARY to BASE64, or
;; adding Content-Transfer-Encoding and the
;; other MIME headers. The code should also
;; return an indication of what encoding the
;; message buffer is now, i.e. ASCII or
;; 8BITMIME.
(if nil
" BODY=8BITMIME"
"")
"")))
;; (smtpmail-send-command process (format "MAIL FROM:%s@%s" (user-login-name) (smtpmail-fqdn)))
(smtpmail-send-command process (format "MAIL FROM:<%s>%s%s"
envelope-from
size-part
body-part))
(if (or (null (car (setq response-code (smtpmail-read-response process))))
(not (integerp (car response-code)))
(>= (car response-code) 400))
(throw 'done nil)))
;; RCPT TO:<recipient>
(let ((n 0))
(while (not (null (nth n recipient)))
(smtpmail-send-command process (format "RCPT TO:<%s>" (smtpmail-maybe-append-domain (nth n recipient))))
(setq n (1+ n))
(setq response-code (smtpmail-read-response process))
(if (or (null (car response-code))
(not (integerp (car response-code)))
(>= (car response-code) 400))
(throw 'done nil))))
;; DATA
(smtpmail-send-command process "DATA")
(if (or (null (car (setq response-code (smtpmail-read-response process))))
(not (integerp (car response-code)))
(>= (car response-code) 400))
(throw 'done nil))
;; Mail contents
(smtpmail-send-data process smtpmail-text-buffer)
;; DATA end "."
(smtpmail-send-command process ".")
(if (or (null (car (setq response-code (smtpmail-read-response process))))
(not (integerp (car response-code)))
(>= (car response-code) 400))
(throw 'done nil))
;; QUIT
;; (smtpmail-send-command process "QUIT")
;; (and (null (car (smtpmail-read-response process)))
;; (throw 'done nil))
t))
(if process
(with-current-buffer (process-buffer process)
(smtpmail-send-command process "QUIT")
(smtpmail-read-response process)
;; (if (or (null (car (setq response-code (smtpmail-read-response process))))
;; (not (integerp (car response-code)))
;; (>= (car response-code) 400))
;; (throw 'done nil))
(delete-process process)
(unless smtpmail-debug-info
(kill-buffer process-buffer)))))))
;; Patch starttls-negotiate-gnutls to send ^Z (Windows EOF) instead of
;; a signal.
(require 'starttls) ; starttls-negotiate-gnutls comes from here
(defun starttls-negotiate-gnutls (process)
"Negotiate TLS on PROCESS opened by `open-starttls-stream'.
This should typically only be done once. It typically returns a
multi-line informational message with information about the
handshake, or nil on failure."
(let (buffer info old-max done-ok done-bad)
(if (null (setq buffer (process-buffer process)))
;; XXX How to remove/extract the TLS negotiation junk?
; (signal-process (process-id process) 'SIGALRM)
(process-send-string process "\x1a") ; EOF for GnuTLS on Windows
(with-current-buffer buffer
(save-excursion
(setq old-max (goto-char (point-max)))
; (signal-process (process-id process) 'SIGALRM)
(process-send-string process "\x1a") ; EOF for GnuTLS on Windows
(while (and (processp process)
(eq (process-status process) 'run)
(save-excursion
(goto-char old-max)
(not (or (setq done-ok (re-search-forward
starttls-success nil t))
(setq done-bad (re-search-forward
starttls-failure nil t))))))
(accept-process-output process 1 100)
(sit-for 0.1))
(setq info (buffer-substring-no-properties old-max (point-max)))
(delete-region old-max (point-max))
(if (or (and done-ok (not done-bad))
;; Prevent mitm that fake success msg after failure msg.
(and done-ok done-bad (< done-ok done-bad)))
info
(message "STARTTLS negotiation failed: %s" info)
nil))))))
))