/[emacs]/emacs/lisp/gnus/starttls.el
ViewVC logotype

Diff of /emacs/lisp/gnus/starttls.el

Parent Directory Parent Directory | Revision Log Revision Log | View Patch Patch

revision 1.2.18.1 by miles, Tue Oct 14 23:34:51 2003 UTC revision 1.2.18.2 by miles, Tue Jul 6 09:31:51 2004 UTC
# Line 1  Line 1 
1  ;;; starttls.el --- STARTTLS functions  ;;; starttls.el --- STARTTLS functions
2    
3  ;; Copyright (C) 1999, 2000 Free Software Foundation, Inc.  ;; Copyright (C) 1999, 2000, 2003, 2004 Free Software Foundation, Inc.
4    
5  ;; Author: Daiki Ueno <ueno@unixuser.org>  ;; Author: Daiki Ueno <ueno@unixuser.org>
6    ;; Author: Simon Josefsson <simon@josefsson.org>
7  ;; Created: 1999/11/20  ;; Created: 1999/11/20
8  ;; Keywords: TLS, SSL, OpenSSL, mail, news  ;; Keywords: TLS, SSL, OpenSSL, GNUTLS, mail, news
9    
10  ;; This file is part of GNU Emacs.  ;; This file is part of GNU Emacs.
11    
# Line 30  Line 31 
31  ;; [RFC 2595] "Using TLS with IMAP, POP3 and ACAP"  ;; [RFC 2595] "Using TLS with IMAP, POP3 and ACAP"
32  ;;      by Chris Newman <chris.newman@innosoft.com> (1999/06)  ;;      by Chris Newman <chris.newman@innosoft.com> (1999/06)
33    
34    ;; This file now contain a combination of the two previous
35    ;; implementations both called "starttls.el".  The first one is Daiki
36    ;; Ueno's starttls.el which uses his own "starttls" command line tool,
37    ;; and the second one is Simon Josefsson's starttls.el which uses
38    ;; "gnutls-cli" from GNUTLS.
39    ;;
40    ;; If "starttls" is available, it is prefered by the code over
41    ;; "gnutls-cli", for backwards compatibility.  Use
42    ;; `starttls-use-gnutls' to toggle between implementations if you have
43    ;; both tools installed.  It is recommended to use GNUTLS, though, as
44    ;; it performs more verification of the certificates.
45    
46    ;; The GNUTLS support require GNUTLS 0.9.90 (released 2003-10-08) or
47    ;; later, from <http://www.gnu.org/software/gnutls/>, or "starttls"
48    ;; from <ftp://ftp.opaopa.org/pub/elisp/>.
49    
50    ;; Usage is similar to `open-network-stream'.  For example:
51    ;;
52    ;; (when (setq tmp (starttls-open-stream
53    ;;                      "test" (current-buffer) "yxa.extundo.com" 25))
54    ;;   (accept-process-output tmp 15)
55    ;;   (process-send-string tmp "STARTTLS\n")
56    ;;   (accept-process-output tmp 15)
57    ;;   (message "STARTTLS output:\n%s" (starttls-negotiate tmp))
58    ;;   (process-send-string tmp "EHLO foo\n"))
59    
60    ;; An example run yield the following output:
61    ;;
62    ;; 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]
63    ;; 220 2.0.0 Ready to start TLS
64    ;; 250-yxa.extundo.com Hello c494102a.s-bi.bostream.se [217.215.27.65], pleased to meet you
65    ;; 250-ENHANCEDSTATUSCODES
66    ;; 250-PIPELINING
67    ;; 250-EXPN
68    ;; 250-VERB
69    ;; 250-8BITMIME
70    ;; 250-SIZE
71    ;; 250-DSN
72    ;; 250-ETRN
73    ;; 250-AUTH DIGEST-MD5 CRAM-MD5 PLAIN LOGIN
74    ;; 250-DELIVERBY
75    ;; 250 HELP
76    ;; nil
77    ;;
78    ;; With the message buffer containing:
79    ;;
80    ;; STARTTLS output:
81    ;; *** Starting TLS handshake
82    ;; - Server's trusted authorities:
83    ;;    [0]: C=SE,ST=Stockholm,L=Stockholm,O=YXA,OU=CA,CN=yxa.extundo.com,EMAIL=staff@yxa.extundo.com
84    ;; - Certificate type: X.509
85    ;;  - Got a certificate list of 2 certificates.
86    ;;
87    ;;  - Certificate[0] info:
88    ;;  # The hostname in the certificate matches 'yxa.extundo.com'.
89    ;;  # valid since: Wed May 26 12:16:00 CEST 2004
90    ;;  # expires at: Wed Jul 26 12:16:00 CEST 2023
91    ;;  # serial number: 04
92    ;;  # fingerprint: 7c 04 4b c1 fa 26 9b 5d 90 22 52 3c 65 3d 85 3a
93    ;;  # version: #1
94    ;;  # public key algorithm: RSA
95    ;;  #   Modulus: 1024 bits
96    ;;  # Subject's DN: C=SE,ST=Stockholm,L=Stockholm,O=YXA,OU=Mail server,CN=yxa.extundo.com,EMAIL=staff@yxa.extundo.com
97    ;;  # Issuer's DN: C=SE,ST=Stockholm,L=Stockholm,O=YXA,OU=CA,CN=yxa.extundo.com,EMAIL=staff@yxa.extundo.com
98    ;;
99    ;;  - Certificate[1] info:
100    ;;  # valid since: Sun May 23 11:35:00 CEST 2004
101    ;;  # expires at: Sun Jul 23 11:35:00 CEST 2023
102    ;;  # serial number: 00
103    ;;  # fingerprint: fc 76 d8 63 1a c9 0b 3b fa 40 fe ed 47 7a 58 ae
104    ;;  # version: #3
105    ;;  # public key algorithm: RSA
106    ;;  #   Modulus: 1024 bits
107    ;;  # Subject's DN: C=SE,ST=Stockholm,L=Stockholm,O=YXA,OU=CA,CN=yxa.extundo.com,EMAIL=staff@yxa.extundo.com
108    ;;  # Issuer's DN: C=SE,ST=Stockholm,L=Stockholm,O=YXA,OU=CA,CN=yxa.extundo.com,EMAIL=staff@yxa.extundo.com
109    ;;
110    ;; - Peer's certificate issuer is unknown
111    ;; - Peer's certificate is NOT trusted
112    ;; - Version: TLS 1.0
113    ;; - Key Exchange: RSA
114    ;; - Cipher: ARCFOUR 128
115    ;; - MAC: SHA
116    ;; - Compression: NULL
117    
118  ;;; Code:  ;;; Code:
119    
120  (defgroup starttls nil  (defgroup starttls nil
# Line 37  Line 122 
122    :version "21.1"    :version "21.1"
123    :group 'mail)    :group 'mail)
124    
125    (defcustom starttls-gnutls-program "gnutls-cli"
126      "Name of GNUTLS command line tool.
127    This program is used when GNUTLS is used, i.e. when
128    `starttls-use-gnutls' is non-nil."
129      :type 'string
130      :group 'starttls)
131    
132  (defcustom starttls-program "starttls"  (defcustom starttls-program "starttls"
133    "The program to run in a subprocess to open an TLSv1 connection."    "The program to run in a subprocess to open an TLSv1 connection.
134    This program is used when the `starttls' command is used,
135    i.e. when `starttls-use-gnutls' is nil."
136    :type 'string    :type 'string
137    :group 'starttls)    :group 'starttls)
138    
139    (defcustom starttls-use-gnutls (not (executable-find starttls-program))
140      "*Whether to use GNUTLS instead of the `starttls' command."
141      :type 'boolean
142      :group 'starttls)
143    
144  (defcustom starttls-extra-args nil  (defcustom starttls-extra-args nil
145    "Extra arguments to `starttls-program'."    "Extra arguments to `starttls-program'.
146    This program is used when the `starttls' command is used,
147    i.e. when `starttls-use-gnutls' is nil."
148    :type '(repeat string)    :type '(repeat string)
149    :group 'starttls)    :group 'starttls)
150    
151    (defcustom starttls-extra-arguments nil
152      "Extra arguments to `starttls-program'.
153    This program is used when GNUTLS is used, i.e. when
154    `starttls-use-gnutls' is non-nil.
155    
156    For example, non-TLS compliant servers may require
157    '(\"--protocols\" \"ssl3\").  Invoke \"gnutls-cli --help\" to
158    find out which parameters are available."
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      :type 'boolean
165      :group 'starttls)
166    
167    (defcustom starttls-connect "- Simple Client Mode:\n\n"
168      "*Regular expression indicating successful connection.
169    The default is what GNUTLS's \"gnutls-cli\" outputs."
170      ;; GNUTLS cli.c:main() print this string when it is starting to run
171      ;; in the application read/write phase.  If the logic, or the string
172      ;; itself, is modified, this must be updated.
173      :type 'regexp
174      :group 'starttls)
175    
176    (defcustom starttls-failure "\\*\\*\\* Handshake has failed"
177      "*Regular expression indicating failed TLS handshake.
178    The default is what GNUTLS's \"gnutls-cli\" outputs."
179      ;; GNUTLS cli.c:do_handshake() print this string on failure.  If the
180      ;; logic, or the string itself, is modified, this must be updated.
181      :type 'regexp
182      :group 'starttls)
183    
184    (defcustom starttls-success "- Compression: "
185      "*Regular expression indicating completed TLS handshakes.
186    The default is what GNUTLS's \"gnutls-cli\" outputs."
187      ;; GNUTLS cli.c:do_handshake() calls, on success,
188      ;; common.c:print_info(), that unconditionally print this string
189      ;; last.  If that logic, or the string itself, is modified, this
190      ;; must be updated.
191      :type 'regexp
192      :group 'starttls)
193    
194    (defun starttls-negotiate-gnutls (process)
195      "Negotiate TLS on process opened by `open-starttls-stream'.
196    This should typically only be done once.  It typically return a
197    multi-line informational message with information about the
198    handshake, or NIL on failure."
199      (let (buffer info old-max done-ok done-bad)
200        (if (null (setq buffer (process-buffer process)))
201            ;; XXX How to remove/extract the TLS negotiation junk?
202            (signal-process (process-id process) 'SIGALRM)
203          (with-current-buffer buffer
204            (save-excursion
205              (setq old-max (goto-char (point-max)))
206              (signal-process (process-id process) 'SIGALRM)
207              (while (and (processp process)
208                          (eq (process-status process) 'run)
209                          (save-excursion
210                            (goto-char old-max)
211                            (not (or (setq done-ok (re-search-forward
212                                                    starttls-success nil t))
213                                     (setq done-bad (re-search-forward
214                                                     starttls-failure nil t))))))
215                (accept-process-output process 1 100)
216                (sit-for 0.1))
217              (setq info (buffer-substring-no-properties old-max (point-max)))
218              (delete-region old-max (point-max))
219              (if (or (and done-ok (not done-bad))
220                      ;; Prevent mitm that fake success msg after failure msg.
221                      (and done-ok done-bad (< done-ok done-bad)))
222                  info
223                (message "STARTTLS negotiation failed: %s" info)
224                nil))))))
225    
226  (defun starttls-negotiate (process)  (defun starttls-negotiate (process)
227    (signal-process (process-id process) 'SIGALRM))    (if starttls-use-gnutls
228          (starttls-negotiate-gnutls process)
229        (signal-process (process-id process) 'SIGALRM)))
230    
231    (defun starttls-open-stream-gnutls (name buffer host service)
232      (message "Opening STARTTLS connection to `%s'..." host)
233      (let* (done
234             (old-max (with-current-buffer buffer (point-max)))
235             (process-connection-type starttls-process-connection-type)
236             (process (apply #'start-process name buffer
237                             starttls-gnutls-program "-s" host
238                             "-p" (if (integerp service)
239                                      (int-to-string service)
240                                    service)
241                             starttls-extra-arguments)))
242        (process-kill-without-query process)
243        (while (and (processp process)
244                    (eq (process-status process) 'run)
245                    (save-excursion
246                      (set-buffer buffer)
247                      (goto-char old-max)
248                      (not (setq done (re-search-forward
249                                       starttls-connect nil t)))))
250          (accept-process-output process 0 100)
251          (sit-for 0.1))
252        (if done
253            (with-current-buffer buffer
254              (delete-region old-max done))
255          (delete-process process)
256          (setq process nil))
257        (message "Opening STARTTLS connection to `%s'...%s"
258                 host (if done "done" "failed"))
259        process))
260    
261  (defun starttls-open-stream (name buffer host service)  (defun starttls-open-stream (name buffer host service)
262    "Open a TLS connection for a service to a host.    "Open a TLS connection for a service to a host.
# Line 64  BUFFER is the buffer (or `buffer-name') Line 272  BUFFER is the buffer (or `buffer-name')
272  Third arg is name of the host to connect to, or its IP address.  Third arg is name of the host to connect to, or its IP address.
273  Fourth arg SERVICE is name of the service desired, or an integer  Fourth arg SERVICE is name of the service desired, or an integer
274  specifying a port number to connect to."  specifying a port number to connect to."
275    (let* ((process-connection-type nil)    (if starttls-use-gnutls
276           (process (apply #'start-process        (starttls-open-stream-gnutls name buffer host service)
277                           name buffer starttls-program      (let* ((process-connection-type starttls-process-connection-type)
278                           host (format "%s" service)             (process (apply #'start-process
279                           starttls-extra-args)))                             name buffer starttls-program
280      (process-kill-without-query process)                             host (format "%s" service)
281      process))                             starttls-extra-args)))
282          (process-kill-without-query process)
283          process)))
284    
285  (provide 'starttls)  (provide 'starttls)
286    

Legend:
Removed from v.1.2.18.1  
changed lines
  Added in v.1.2.18.2

savannah-hackers-public@gnu.org
ViewVC Help
Powered by ViewVC 1.1.26