-;;; starttls.el --- STARTTLS support via wrapper around GNU TLS
+;;; starttls.el --- STARTTLS functions
-;; Copyright (C) 2003 Free Software Foundation, Inc.
+;; Copyright (C) 1999, 2000, 2003, 2004 Free Software Foundation, Inc.
+;; Author: Daiki Ueno <ueno@unixuser.org>
;; Author: Simon Josefsson <simon@josefsson.org>
-;; Keywords: comm, tls, gnutls, ssl
+;; Created: 1999/11/20
+;; Keywords: TLS, SSL, OpenSSL, GNUTLS, mail, news
;; This file is part of GNU Emacs.
;;; Commentary:
-;; This package implements a simple wrapper around the GNU TLS command
-;; line application "gnutls-cli" to make Emacs support STARTTLS.
+;; This module defines some utility functions for STARTTLS profiles.
+
+;; [RFC 2595] "Using TLS with IMAP, POP3 and ACAP"
+;; by Chris Newman <chris.newman@innosoft.com> (1999/06)
+
+;; This file now contain a combination of the two previous
+;; implementations both called "starttls.el". The first one is Daiki
+;; Ueno's starttls.el which uses his own "starttls" command line tool,
+;; and the second one is Simon Josefsson's starttls.el which uses
+;; "gnutls-cli" from GNUTLS.
;;
-;; Usage is similar to `open-network-stream', i.e.:
+;; If "gnutls-cli" is available, it is prefered by the code over
+;; "starttls". Use `starttls-use-gnutls' to toggle between
+;; implementations if you have both tools installed.
+
+;; The GNUTLS support require GNUTLS 0.9.90 (released 2003-10-08) or
+;; later, from <http://www.gnu.org/software/gnutls/>, or "starttls"
+;; from <ftp://ftp.opaopa.org/pub/elisp/>.
+
+;; Usage is similar to `open-network-stream'. For example:
;;
-;; (setq tmp (open-starttls-stream "test" (current-buffer) "cyrus.andrew.cmu.edu" 143))
-;; #<process test<9>>
-;; (process-send-string tmp ". starttls\n")
+;; (when (setq tmp (starttls-open-stream
+;; "test" (current-buffer) "yxa.extundo.com" 25))
+;; (accept-process-output tmp 15)
+;; (process-send-string tmp "STARTTLS\n")
+;; (accept-process-output tmp 15)
+;; (message "STARTTLS output:\n%s" (starttls-negotiate tmp))
+;; (process-send-string tmp "EHLO foo\n"))
+
+;; An example run yield the following output:
+;;
+;; 220 yxa.extundo.com ESMTP Sendmail 8.12.11/8.12.11/Debian-3; Wed, 26 May 2004 19:12:29 +0200; (No UCE/UBE) logging access from: c494102a.s-bi.bostream.se(OK)-c494102a.s-bi.bostream.se [217.215.27.65]
+;; 220 2.0.0 Ready to start TLS
+;; 250-yxa.extundo.com Hello c494102a.s-bi.bostream.se [217.215.27.65], pleased to meet you
+;; 250-ENHANCEDSTATUSCODES
+;; 250-PIPELINING
+;; 250-EXPN
+;; 250-VERB
+;; 250-8BITMIME
+;; 250-SIZE
+;; 250-DSN
+;; 250-ETRN
+;; 250-AUTH DIGEST-MD5 CRAM-MD5 PLAIN LOGIN
+;; 250-DELIVERBY
+;; 250 HELP
;; nil
-;; (negotiate-starttls tmp)
-;; "*** Starting TLS handshake
+;;
+;; With the message buffer containing:
+;;
+;; STARTTLS output:
+;; *** Starting TLS handshake
+;; - Server's trusted authorities:
+;; [0]: C=SE,ST=Stockholm,L=Stockholm,O=YXA,OU=CA,CN=yxa.extundo.com,EMAIL=staff@yxa.extundo.com
;; - Certificate type: X.509
-;; - Certificate info:
-;; # Certificate is valid since: Thu Jun 26 19:00:00 CEST 2003
-;; # Certificate expires: Sat Jun 26 19:00:00 CEST 2004
-;; # Certificate fingerprint: 8d 59 d6 e1 c9 91 dc 5a bb 38 47 8c ec 85 1b 99
-;; # Certificate serial number: 3e fb 52 ce
-;; # Certificate version: #3
-;; # Certificate public key algorithm: RSA
+;; - Got a certificate list of 2 certificates.
+;;
+;; - Certificate[0] info:
+;; # The hostname in the certificate matches 'yxa.extundo.com'.
+;; # valid since: Wed May 26 12:16:00 CEST 2004
+;; # expires at: Wed Jul 26 12:16:00 CEST 2023
+;; # serial number: 04
+;; # fingerprint: 7c 04 4b c1 fa 26 9b 5d 90 22 52 3c 65 3d 85 3a
+;; # version: #1
+;; # public key algorithm: RSA
+;; # Modulus: 1024 bits
+;; # Subject's DN: C=SE,ST=Stockholm,L=Stockholm,O=YXA,OU=Mail server,CN=yxa.extundo.com,EMAIL=staff@yxa.extundo.com
+;; # Issuer's DN: C=SE,ST=Stockholm,L=Stockholm,O=YXA,OU=CA,CN=yxa.extundo.com,EMAIL=staff@yxa.extundo.com
+;;
+;; - Certificate[1] info:
+;; # valid since: Sun May 23 11:35:00 CEST 2004
+;; # expires at: Sun Jul 23 11:35:00 CEST 2023
+;; # serial number: 00
+;; # fingerprint: fc 76 d8 63 1a c9 0b 3b fa 40 fe ed 47 7a 58 ae
+;; # version: #3
+;; # public key algorithm: RSA
;; # Modulus: 1024 bits
-;; # CN=cyrus.andrew.cmu.edu,OU=Computing Services,O=Carnegie Mellon University,L=Pittsburgh,ST=Pennsylvania,C=US
-;; # Certificate Issuer's info:
-;; # CN=CMU CA mail 1,OU=Computing Services,O=Carnegie Mellon University,L=Pittsburgh,ST=Pennsylvania,C=US
+;; # Subject's DN: C=SE,ST=Stockholm,L=Stockholm,O=YXA,OU=CA,CN=yxa.extundo.com,EMAIL=staff@yxa.extundo.com
+;; # Issuer's DN: C=SE,ST=Stockholm,L=Stockholm,O=YXA,OU=CA,CN=yxa.extundo.com,EMAIL=staff@yxa.extundo.com
;;
+;; - Peer's certificate issuer is unknown
;; - Peer's certificate is NOT trusted
;; - Version: TLS 1.0
;; - Key Exchange: RSA
;; - Cipher: ARCFOUR 128
;; - MAC: SHA
;; - Compression: NULL
-;; "
-;; (process-send-string tmp ". capability\n")
-;; nil
-;; (process-send-string tmp ". logout\n")
-;; nil
-;;
-;; Resolving 'cyrus.andrew.cmu.edu'...
-;; Connecting to '128.2.10.174:143'...
-;;
-;; - Simple Client Mode:
-;;
-;; * OK mail-fe4.andrew.cmu.edu Cyrus IMAP4 Murder v2.1.15-077 server ready\r
-;; . OK Begin TLS negotiation now\r
-;; * CAPABILITY IMAP4 IMAP4rev1 ACL QUOTA LITERAL+ MAILBOX-REFERRALS NAMESPACE UIDPLUS ID NO_ATOMIC_RENAME UNSELECT CHILDREN MULTIAPPEND SORT THREAD=ORDEREDSUBJECT THREAD=REFERENCES AUTH=PLAIN AUTH=KERBEROS_V4 AUTH=GSSAPI AUTH=ANONYMOUS ANNOTATEMORE\r
-;; . OK Completed\r
-;; * BYE LOGOUT received\r
-;; . OK Completed\r
-;; *** Received corrupted data(-9) - server has terminated the connection abnormally
-;;
-;; Process test<9> finished
;;; Code:
-(eval-and-compile
- (autoload 'format-spec "format-spec")
- (autoload 'format-spec-make "format-spec"))
-
(defgroup starttls nil
- "Negotiated Transport Layer Security (STARTTLS) parameters."
- :group 'comm)
-
-(defcustom starttls-program "gnutls-cli"
- "The program to run in a subprocess to open an STARTTLS connection.
-The program should read input on stdin and write output to
-stdout. Also see `starttls-connect' and `starttls-success' for
-what the program should output after initial connection and
-successful negotiation respectively."
+ "Support for `Transport Layer Security' protocol."
+ :version "21.1"
+ :group 'mail)
+
+(defcustom starttls-gnutls-program "gnutls-cli"
+ "Name of GNUTLS command line tool.
+This program is used when GNUTLS is used, i.e. when
+`starttls-use-gnutls' is non-nil."
:type 'string
:group 'starttls)
+(defcustom starttls-program "starttls"
+ "The program to run in a subprocess to open an TLSv1 connection.
+This program is used when the `starttls' command is used,
+i.e. when `starttls-use-gnutls' is nil."
+ :type 'string
+ :group 'starttls)
+
+(defcustom starttls-use-gnutls (not (executable-find starttls-program))
+ "*Whether to use GNUTLS instead of the `starttls' command."
+ :type 'boolean
+ :group 'starttls)
+
(defcustom starttls-extra-args nil
- "List of extra arguments to `starttls-program'.
-E.g., (\"--protocols\" \"ssl3\")."
+ "Extra arguments to `starttls-program'.
+This program is used when the `starttls' command is used,
+i.e. when `starttls-use-gnutls' is nil."
+ :type '(repeat string)
+ :group 'starttls)
+
+(defcustom starttls-extra-arguments nil
+ "Extra arguments to `starttls-program'.
+This program is used when GNUTLS is used, i.e. when
+`starttls-use-gnutls' is non-nil.
+
+For example, non-TLS compliant servers may require
+'(\"--protocols\" \"ssl3\"). Invoke \"gnutls-cli --help\" to
+find out which parameters are available."
:type '(repeat string)
:group 'starttls)
(defcustom starttls-connect "- Simple Client Mode:\n\n"
"*Regular expression indicating successful connection.
The default is what GNUTLS's \"gnutls-cli\" outputs."
- ;; cli.c:main() print this string when it is starting to run in the
- ;; application read/write phase. If the logic, or the string
- ;; itself, is modified, this have to be updated.
+ ;; GNUTLS cli.c:main() print this string when it is starting to run
+ ;; in the application read/write phase. If the logic, or the string
+ ;; itself, is modified, this must be updated.
:type 'regexp
:group 'starttls)
-(defcustom starttls-failure "*** Handshake has failed"
+(defcustom starttls-failure "\\*\\*\\* Handshake has failed"
"*Regular expression indicating failed TLS handshake.
The default is what GNUTLS's \"gnutls-cli\" outputs."
- ;; cli.c:do_handshake() print this string on failure. If the logic,
- ;; or the string itself, is modified, this have to be updated.
+ ;; GNUTLS cli.c:do_handshake() print this string on failure. If the
+ ;; logic, or the string itself, is modified, this must be updated.
:type 'regexp
:group 'starttls)
(defcustom starttls-success "- Compression: "
"*Regular expression indicating completed TLS handshakes.
The default is what GNUTLS's \"gnutls-cli\" outputs."
- ;; cli.c:do_handshake() calls, on success, common.c:print_info(),
- ;; that unconditionally print this string last. If that logic, or
- ;; the string itself, is modified, this have to be updated.
+ ;; GNUTLS cli.c:do_handshake() calls, on success,
+ ;; common.c:print_info(), that unconditionally print this string
+ ;; last. If that logic, or the string itself, is modified, this
+ ;; must be updated.
:type 'regexp
:group 'starttls)
-(defun negotiate-starttls (process)
+(defun starttls-negotiate-gnutls (process)
"Negotiate TLS on process opened by `open-starttls-stream'.
This should typically only be done once. It typically return a
multi-line informational message with information about the
handshake, or NIL on failure."
- (let (buffer response old-max done-ok done-bad)
+ (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?
+ ;; XXX How to remove/extract the TLS negotiation junk?
(signal-process (process-id process) 'SIGALRM)
(with-current-buffer buffer
(save-excursion
- (goto-char (point-max))
- (setq old-max (point))
+ (setq old-max (goto-char (point-max)))
(signal-process (process-id process) 'SIGALRM)
- (while (and process
- (memq (process-status process) '(open run))
+ (while (and (processp process)
+ (eq (process-status process) 'run)
(save-excursion
- (set-buffer buffer) ;; XXX "blue moon" nntp.el bug
(goto-char old-max)
- (progn
- (setq
- done-ok (re-search-forward starttls-success nil t)
- done-bad (re-search-forward starttls-failure nil t))
- (not (or done-ok done-bad)))))
+ (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.
+ ;; 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))))))
-(defun open-starttls-stream (name buffer host service)
- "Open a TLS connection for a service to a host.
-Returns a subprocess-object to represent the connection.
-Input and output work as for subprocesses; `delete-process' closes it.
-Args are NAME BUFFER HOST SERVICE.
-NAME is name for process. It is modified if necessary to make it unique.
-BUFFER is the buffer (or buffer-name) to associate with the process.
- Process output goes at end of that buffer, unless you specify
- an output stream or filter function to handle the output.
-Third arg is name of the host to connect to, or its IP address.
-Fourth arg SERVICE is name of the service desired, or an integer
-specifying a port number to connect to."
+(defun starttls-negotiate (process)
+ (if starttls-use-gnutls
+ (starttls-negotiate-gnutls process)
+ (signal-process (process-id process) 'SIGALRM)))
+
+(defun starttls-open-stream-gnutls (name buffer host service)
(message "Opening STARTTLS connection to `%s'..." host)
(let* (done
(old-max (with-current-buffer buffer (point-max)))
(process-connection-type starttls-process-connection-type)
(process (apply #'start-process name buffer
- starttls-program "-s" host
+ starttls-gnutls-program "-s" host
"-p" (if (integerp service)
(int-to-string service)
service)
- starttls-extra-args))
- response)
+ starttls-extra-arguments)))
(process-kill-without-query process)
- (while (and process
- (memq (process-status process) '(open run))
+ (while (and (processp process)
+ (eq (process-status process) 'run)
(save-excursion
- (set-buffer buffer) ;; XXX "blue moon" nntp.el bug
- (goto-char (point-min))
+ (set-buffer buffer)
+ (goto-char old-max)
(not (setq done (re-search-forward
starttls-connect nil t)))))
(accept-process-output process 0 100)
(sit-for 0.1))
(if done
- (progn
- (with-current-buffer buffer
- (delete-region old-max done))
- (setq done process))
- (delete-process process))
+ (with-current-buffer buffer
+ (delete-region old-max done))
+ (delete-process process)
+ (setq process nil))
(message "Opening STARTTLS connection to `%s'...%s"
host (if done "done" "failed"))
- done))
+ process))
-;; Compatibility with starttls.el by Daiki Ueno <ueno@unixuser.org>:
-(defalias 'starttls-open-stream 'open-starttls-stream)
-(defalias 'starttls-negotiate 'negotiate-starttls)
+(defun starttls-open-stream (name buffer host service)
+ "Open a TLS connection for a service to a host.
+Returns a subprocess-object to represent the connection.
+Input and output work as for subprocesses; `delete-process' closes it.
+Args are NAME BUFFER HOST SERVICE.
+NAME is name for process. It is modified if necessary to make it unique.
+BUFFER is the buffer (or `buffer-name') to associate with the process.
+ Process output goes at end of that buffer, unless you specify
+ an output stream or filter function to handle the output.
+ BUFFER may be also nil, meaning that this process is not associated
+ with any buffer
+Third arg is name of the host to connect to, or its IP address.
+Fourth arg SERVICE is name of the service desired, or an integer
+specifying a port number to connect to."
+ (if starttls-use-gnutls
+ (starttls-open-stream-gnutls name buffer host service)
+ (let* ((process-connection-type starttls-process-connection-type)
+ (process (apply #'start-process
+ name buffer starttls-program
+ host (format "%s" service)
+ starttls-extra-args)))
+ (process-kill-without-query process)
+ process)))
(provide 'starttls)
+;;; arch-tag: 648b3bd8-63bd-47f5-904c-7c819aea2297
;;; starttls.el ends here
projects / gnus / blobdiff