cc7192b1aea35de8c8d76578c986fa1af99d891b
[gnus] / lisp / starttls.el
1 ;;; starttls.el --- STARTTLS functions
2
3 ;; Copyright (C) 1999-2015 Free Software Foundation, Inc.
4
5 ;; Author: Daiki Ueno <ueno@unixuser.org>
6 ;; Author: Simon Josefsson <simon@josefsson.org>
7 ;; Created: 1999/11/20
8 ;; Keywords: TLS, SSL, OpenSSL, GnuTLS, mail, news
9
10 ;; This file is part of GNU Emacs.
11
12 ;; GNU Emacs is free software: you can redistribute it and/or modify
13 ;; it under the terms of the GNU General Public License as published by
14 ;; the Free Software Foundation, either version 3 of the License, or
15 ;; (at your option) any later version.
16
17 ;; GNU Emacs is distributed in the hope that it will be useful,
18 ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
19 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
20 ;; GNU General Public License for more details.
21
22 ;; You should have received a copy of the GNU General Public License
23 ;; along with GNU Emacs.  If not, see <http://www.gnu.org/licenses/>.
24
25 ;;; Commentary:
26
27 ;; This module defines some utility functions for STARTTLS profiles.
28
29 ;; [RFC 2595] "Using TLS with IMAP, POP3 and ACAP"
30 ;;      by Chris Newman <chris.newman@innosoft.com> (1999/06)
31
32 ;; This file now contains a combination of the two previous
33 ;; implementations both called "starttls.el".  The first one is Daiki
34 ;; Ueno's starttls.el which uses his own "starttls" command line tool,
35 ;; and the second one is Simon Josefsson's starttls.el which uses
36 ;; "gnutls-cli" from GnuTLS.
37 ;;
38 ;; If "starttls" is available, it is preferred by the code over
39 ;; "gnutls-cli", for backwards compatibility.  Use
40 ;; `starttls-use-gnutls' to toggle between implementations if you have
41 ;; both tools installed.  It is recommended to use GnuTLS, though, as
42 ;; it performs more verification of the certificates.
43
44 ;; The GnuTLS support requires GnuTLS 0.9.90 (released 2003-10-08) or
45 ;; later, from <http://www.gnu.org/software/gnutls/>, or "starttls"
46 ;; from <ftp://ftp.opaopa.org/pub/elisp/>.
47
48 ;; Usage is similar to `open-network-stream'.  For example:
49 ;;
50 ;; (when (setq tmp (starttls-open-stream
51 ;;                      "test" (current-buffer) "yxa.extundo.com" 25))
52 ;;   (accept-process-output tmp 15)
53 ;;   (process-send-string tmp "STARTTLS\n")
54 ;;   (accept-process-output tmp 15)
55 ;;   (message "STARTTLS output:\n%s" (starttls-negotiate tmp))
56 ;;   (process-send-string tmp "EHLO foo\n"))
57
58 ;; An example run yields the following output:
59 ;;
60 ;; 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]
61 ;; 220 2.0.0 Ready to start TLS
62 ;; 250-yxa.extundo.com Hello c494102a.s-bi.bostream.se [217.215.27.65], pleased to meet you
63 ;; 250-ENHANCEDSTATUSCODES
64 ;; 250-PIPELINING
65 ;; 250-EXPN
66 ;; 250-VERB
67 ;; 250-8BITMIME
68 ;; 250-SIZE
69 ;; 250-DSN
70 ;; 250-ETRN
71 ;; 250-AUTH DIGEST-MD5 CRAM-MD5 PLAIN LOGIN
72 ;; 250-DELIVERBY
73 ;; 250 HELP
74 ;; nil
75 ;;
76 ;; With the message buffer containing:
77 ;;
78 ;; STARTTLS output:
79 ;; *** Starting TLS handshake
80 ;; - Server's trusted authorities:
81 ;;    [0]: C=SE,ST=Stockholm,L=Stockholm,O=YXA,OU=CA,CN=yxa.extundo.com,EMAIL=staff@yxa.extundo.com
82 ;; - Certificate type: X.509
83 ;;  - Got a certificate list of 2 certificates.
84 ;;
85 ;;  - Certificate[0] info:
86 ;;  # The hostname in the certificate matches 'yxa.extundo.com'.
87 ;;  # valid since: Wed May 26 12:16:00 CEST 2004
88 ;;  # expires at: Wed Jul 26 12:16:00 CEST 2023
89 ;;  # serial number: 04
90 ;;  # fingerprint: 7c 04 4b c1 fa 26 9b 5d 90 22 52 3c 65 3d 85 3a
91 ;;  # version: #1
92 ;;  # public key algorithm: RSA
93 ;;  #   Modulus: 1024 bits
94 ;;  # Subject's DN: C=SE,ST=Stockholm,L=Stockholm,O=YXA,OU=Mail server,CN=yxa.extundo.com,EMAIL=staff@yxa.extundo.com
95 ;;  # Issuer's DN: C=SE,ST=Stockholm,L=Stockholm,O=YXA,OU=CA,CN=yxa.extundo.com,EMAIL=staff@yxa.extundo.com
96 ;;
97 ;;  - Certificate[1] info:
98 ;;  # valid since: Sun May 23 11:35:00 CEST 2004
99 ;;  # expires at: Sun Jul 23 11:35:00 CEST 2023
100 ;;  # serial number: 00
101 ;;  # fingerprint: fc 76 d8 63 1a c9 0b 3b fa 40 fe ed 47 7a 58 ae
102 ;;  # version: #3
103 ;;  # public key algorithm: RSA
104 ;;  #   Modulus: 1024 bits
105 ;;  # Subject's DN: C=SE,ST=Stockholm,L=Stockholm,O=YXA,OU=CA,CN=yxa.extundo.com,EMAIL=staff@yxa.extundo.com
106 ;;  # Issuer's DN: C=SE,ST=Stockholm,L=Stockholm,O=YXA,OU=CA,CN=yxa.extundo.com,EMAIL=staff@yxa.extundo.com
107 ;;
108 ;; - Peer's certificate issuer is unknown
109 ;; - Peer's certificate is NOT trusted
110 ;; - Version: TLS 1.0
111 ;; - Key Exchange: RSA
112 ;; - Cipher: ARCFOUR 128
113 ;; - MAC: SHA
114 ;; - Compression: NULL
115
116 ;;; Code:
117
118 (defgroup starttls nil
119   "Support for `Transport Layer Security' protocol."
120   :version "21.1"
121   :group 'mail)
122
123 (defcustom starttls-gnutls-program "gnutls-cli"
124   "Name of GnuTLS command line tool.
125 This program is used when GnuTLS is used, i.e. when
126 `starttls-use-gnutls' is non-nil."
127   :version "22.1"
128   :type 'string
129   :group 'starttls)
130
131 (defcustom starttls-program "starttls"
132   "The program to run in a subprocess to open an TLSv1 connection.
133 This program is used when the `starttls' command is used,
134 i.e. when `starttls-use-gnutls' is nil."
135   :type 'string
136   :group 'starttls)
137
138 (defcustom starttls-use-gnutls (not (executable-find starttls-program))
139   "*Whether to use GnuTLS instead of the `starttls' command."
140   :version "22.1"
141   :type 'boolean
142   :group 'starttls)
143
144 (defcustom starttls-extra-args nil
145   "Extra arguments to `starttls-program'.
146 These apply when the `starttls' command is used, i.e. when
147 `starttls-use-gnutls' is nil."
148   :type '(repeat string)
149   :group 'starttls)
150
151 (defcustom starttls-extra-arguments nil
152   "Extra arguments to `starttls-gnutls-program'.
153 These apply when GnuTLS is used, i.e. when `starttls-use-gnutls' is non-nil.
154
155 For example, non-TLS compliant servers may require
156 '(\"--protocols\" \"ssl3\").  Invoke \"gnutls-cli --help\" to
157 find out which parameters are available."
158   :version "22.1"
159   :type '(repeat string)
160   :group 'starttls)
161
162 (defcustom starttls-process-connection-type nil
163   "*Value for `process-connection-type' to use when starting STARTTLS process."
164   :version "22.1"
165   :type 'boolean
166   :group 'starttls)
167
168 (defcustom starttls-connect "- Simple Client Mode:\n\n"
169   "*Regular expression indicating successful connection.
170 The default is what GnuTLS's \"gnutls-cli\" outputs."
171   ;; GnuTLS cli.c:main() prints this string when it is starting to run
172   ;; in the application read/write phase.  If the logic, or the string
173   ;; itself, is modified, this must be updated.
174   :version "22.1"
175   :type 'regexp
176   :group 'starttls)
177
178 (defcustom starttls-failure "\\*\\*\\* Handshake has failed"
179   "*Regular expression indicating failed TLS handshake.
180 The default is what GnuTLS's \"gnutls-cli\" outputs."
181   ;; GnuTLS cli.c:do_handshake() prints this string on failure.  If the
182   ;; logic, or the string itself, is modified, this must be updated.
183   :version "22.1"
184   :type 'regexp
185   :group 'starttls)
186
187 (defcustom starttls-success "- Compression: "
188   "*Regular expression indicating completed TLS handshakes.
189 The default is what GnuTLS's \"gnutls-cli\" outputs."
190   ;; GnuTLS cli.c:do_handshake() calls, on success,
191   ;; common.c:print_info(), that unconditionally print this string
192   ;; last.  If that logic, or the string itself, is modified, this
193   ;; must be updated.
194   :version "22.1"
195   :type 'regexp
196   :group 'starttls)
197
198 (defun starttls-negotiate-gnutls (process)
199   "Negotiate TLS on PROCESS opened by `open-starttls-stream'.
200 This should typically only be done once.  It typically returns a
201 multi-line informational message with information about the
202 handshake, or nil on failure."
203   (let (buffer info old-max done-ok done-bad)
204     (if (null (setq buffer (process-buffer process)))
205         ;; XXX How to remove/extract the TLS negotiation junk?
206         (signal-process (process-id process) 'SIGALRM)
207       (with-current-buffer buffer
208         (save-excursion
209           (setq old-max (goto-char (point-max)))
210           (signal-process (process-id process) 'SIGALRM)
211           (while (and (processp process)
212                       (eq (process-status process) 'run)
213                       (save-excursion
214                         (goto-char old-max)
215                         (not (or (setq done-ok (re-search-forward
216                                                 starttls-success nil t))
217                                  (setq done-bad (re-search-forward
218                                                  starttls-failure nil t))))))
219             (accept-process-output process 1 100)
220             (sit-for 0.1))
221           (setq info (buffer-substring-no-properties old-max (point-max)))
222           (delete-region old-max (point-max))
223           (if (or (and done-ok (not done-bad))
224                   ;; Prevent mitm that fake success msg after failure msg.
225                   (and done-ok done-bad (< done-ok done-bad)))
226               info
227             (message "STARTTLS negotiation failed: %s" info)
228             nil))))))
229
230 (defun starttls-negotiate (process)
231   (if starttls-use-gnutls
232       (starttls-negotiate-gnutls process)
233     (signal-process (process-id process) 'SIGALRM)))
234
235 (eval-and-compile
236   (if (fboundp 'set-process-query-on-exit-flag)
237       (defalias 'starttls-set-process-query-on-exit-flag
238         'set-process-query-on-exit-flag)
239     (defalias 'starttls-set-process-query-on-exit-flag
240       'process-kill-without-query)))
241
242 (defun starttls-open-stream-gnutls (name buffer host port)
243   (message "Opening STARTTLS connection to `%s:%s'..." host port)
244   (let* (done
245          (old-max (with-current-buffer buffer (point-max)))
246          (process-connection-type starttls-process-connection-type)
247          (process (apply #'start-process name buffer
248                          starttls-gnutls-program "-s" host
249                          "-p" (if (integerp port)
250                                   (int-to-string port)
251                                 port)
252                          starttls-extra-arguments)))
253     (starttls-set-process-query-on-exit-flag process nil)
254     (while (and (processp process)
255                 (eq (process-status process) 'run)
256                 (with-current-buffer buffer
257                   (goto-char old-max)
258                   (not (setq done (re-search-forward
259                                    starttls-connect nil t)))))
260       (accept-process-output process 0 100)
261       (sit-for 0.1))
262     (if done
263         (with-current-buffer buffer
264           (delete-region old-max done))
265       (delete-process process)
266       (setq process nil))
267     (message "Opening STARTTLS connection to `%s:%s'...%s"
268              host port (if done "done" "failed"))
269     process))
270
271 ;;;###autoload
272 (defun starttls-open-stream (name buffer host port)
273   "Open a TLS connection for a port to a host.
274 Returns a subprocess object to represent the connection.
275 Input and output work as for subprocesses; `delete-process' closes it.
276 Args are NAME BUFFER HOST PORT.
277 NAME is name for process.  It is modified if necessary to make it unique.
278 BUFFER is the buffer (or `buffer-name') to associate with the process.
279  Process output goes at end of that buffer, unless you specify
280  an output stream or filter function to handle the output.
281  BUFFER may be also nil, meaning that this process is not associated
282  with any buffer
283 Third arg is name of the host to connect to, or its IP address.
284 Fourth arg PORT is an integer specifying a port to connect to.
285 If `starttls-use-gnutls' is nil, this may also be a service name, but
286 GnuTLS requires a port number."
287   (if starttls-use-gnutls
288       (starttls-open-stream-gnutls name buffer host port)
289     (message "Opening STARTTLS connection to `%s:%s'" host (format "%s" port))
290     (let* ((process-connection-type starttls-process-connection-type)
291            (process (apply #'start-process
292                            name buffer starttls-program
293                            host (format "%s" port)
294                            starttls-extra-args)))
295       (starttls-set-process-query-on-exit-flag process nil)
296       process)))
297
298 (defun starttls-available-p ()
299   "Say whether the STARTTLS programs are available."
300   (and (not (memq system-type '(windows-nt ms-dos)))
301        (executable-find (if starttls-use-gnutls
302                             starttls-gnutls-program
303                           starttls-program))))
304
305 (defalias 'starttls-any-program-available 'starttls-available-p)
306 (make-obsolete 'starttls-any-program-available 'starttls-available-p
307                "2011-08-02")
308
309 (provide 'starttls)
310
311 ;;; starttls.el ends here