Mercurial > emacs
annotate lisp/net/tls.el @ 66424:86f81b226b02
*** empty log message ***
author | Stefan Monnier <monnier@iro.umontreal.ca> |
---|---|
date | Tue, 25 Oct 2005 04:58:35 +0000 |
parents | 34bd8e434dd7 |
children | 1c477099d3ac edf295560b5a |
rev | line source |
---|---|
50313 | 1 ;;; tls.el --- TLS/SSL support via wrapper around GnuTLS |
2 | |
64701
34bd8e434dd7
Update years in copyright notice; nfc.
Thien-Thi Nguyen <ttn@gnuvola.org>
parents:
64085
diff
changeset
|
3 ;; Copyright (C) 1996, 1997, 1998, 1999, 2002, 2003, 2004, |
34bd8e434dd7
Update years in copyright notice; nfc.
Thien-Thi Nguyen <ttn@gnuvola.org>
parents:
64085
diff
changeset
|
4 ;; 2005 Free Software Foundation, Inc. |
50313 | 5 |
6 ;; Author: Simon Josefsson <simon@josefsson.org> | |
7 ;; Keywords: comm, tls, gnutls, ssl | |
8 | |
9 ;; This file is part of GNU Emacs. | |
10 | |
11 ;; GNU Emacs is free software; you can redistribute it and/or modify | |
12 ;; it under the terms of the GNU General Public License as published by | |
13 ;; the Free Software Foundation; either version 2, or (at your option) | |
14 ;; any later version. | |
15 | |
16 ;; GNU Emacs is distributed in the hope that it will be useful, | |
17 ;; but WITHOUT ANY WARRANTY; without even the implied warranty of | |
18 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the | |
19 ;; GNU General Public License for more details. | |
20 | |
21 ;; You should have received a copy of the GNU General Public License | |
22 ;; along with GNU Emacs; see the file COPYING. If not, write to the | |
64085 | 23 ;; Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, |
24 ;; Boston, MA 02110-1301, USA. | |
50313 | 25 |
26 ;;; Commentary: | |
27 | |
28 ;; This package implements a simple wrapper around "gnutls-cli" to | |
29 ;; make Emacs support TLS/SSL. | |
30 ;; | |
31 ;; Usage is the same as `open-network-stream', i.e.: | |
32 ;; | |
33 ;; (setq tmp (open-tls-stream "test" (current-buffer) "news.mozilla.org" 563)) | |
34 ;; ... | |
35 ;; #<process test> | |
36 ;; (process-send-string tmp "mode reader\n") | |
37 ;; 200 secnews.netscape.com Netscape-Collabra/3.52 03615 NNRP ready ... | |
38 ;; nil | |
39 ;; (process-send-string tmp "quit\n") | |
40 ;; 205 | |
41 ;; nil | |
42 | |
43 ;; To use this package as a replacement for ssl.el by William M. Perry | |
44 ;; <wmperry@cs.indiana.edu>, you need to evaluate the following: | |
45 ;; | |
46 ;; (defalias 'open-ssl-stream 'open-tls-stream) | |
47 | |
48 ;;; Code: | |
49 | |
50 (eval-and-compile | |
51 (autoload 'format-spec "format-spec") | |
52 (autoload 'format-spec-make "format-spec")) | |
53 | |
54 (defgroup tls nil | |
55 "Transport Layer Security (TLS) parameters." | |
56 :group 'comm) | |
57 | |
58 (defcustom tls-program '("gnutls-cli -p %p %h" | |
59 "gnutls-cli -p %p %h --protocols ssl3") | |
60 "List of strings containing commands to start TLS stream to a host. | |
61 Each entry in the list is tried until a connection is successful. | |
62 %s is replaced with server hostname, %p with port to connect to. | |
63 The program should read input on stdin and write output to | |
64 stdout. Also see `tls-success' for what the program should output | |
65 after successful negotiation." | |
66 :type '(repeat string) | |
67 :group 'tls) | |
68 | |
69 (defcustom tls-process-connection-type nil | |
56927
55fd4f77387a
Revision: miles@gnu.org--gnu-2004/emacs--cvs-trunk--0--patch-523
Miles Bader <miles@gnu.org>
parents:
52401
diff
changeset
|
70 "*Value for `process-connection-type' to use when starting TLS process." |
59996
aac0a33f5772
Change release version from 21.4 to 22.1 throughout.
Kim F. Storm <storm@cua.dk>
parents:
57856
diff
changeset
|
71 :version "22.1" |
50313 | 72 :type 'boolean |
73 :group 'tls) | |
74 | |
75 (defcustom tls-success "- Handshake was completed" | |
76 "*Regular expression indicating completed TLS handshakes. | |
77 The default is what GNUTLS's \"gnutls-cli\" outputs." | |
59996
aac0a33f5772
Change release version from 21.4 to 22.1 throughout.
Kim F. Storm <storm@cua.dk>
parents:
57856
diff
changeset
|
78 :version "22.1" |
50313 | 79 :type 'regexp |
80 :group 'tls) | |
81 | |
57448
821d95294db5
(tls-certtool-program): New variable.
Simon Josefsson <jas@extundo.com>
parents:
56927
diff
changeset
|
82 (defcustom tls-certtool-program (executable-find "certtool") |
821d95294db5
(tls-certtool-program): New variable.
Simon Josefsson <jas@extundo.com>
parents:
56927
diff
changeset
|
83 "Name of GnuTLS certtool. |
821d95294db5
(tls-certtool-program): New variable.
Simon Josefsson <jas@extundo.com>
parents:
56927
diff
changeset
|
84 Used by `tls-certificate-information'." |
59996
aac0a33f5772
Change release version from 21.4 to 22.1 throughout.
Kim F. Storm <storm@cua.dk>
parents:
57856
diff
changeset
|
85 :version "22.1" |
57448
821d95294db5
(tls-certtool-program): New variable.
Simon Josefsson <jas@extundo.com>
parents:
56927
diff
changeset
|
86 :type '(repeat string) |
821d95294db5
(tls-certtool-program): New variable.
Simon Josefsson <jas@extundo.com>
parents:
56927
diff
changeset
|
87 :group 'tls) |
821d95294db5
(tls-certtool-program): New variable.
Simon Josefsson <jas@extundo.com>
parents:
56927
diff
changeset
|
88 |
821d95294db5
(tls-certtool-program): New variable.
Simon Josefsson <jas@extundo.com>
parents:
56927
diff
changeset
|
89 (defun tls-certificate-information (der) |
821d95294db5
(tls-certtool-program): New variable.
Simon Josefsson <jas@extundo.com>
parents:
56927
diff
changeset
|
90 "Parse X.509 certificate in DER format into an assoc list." |
821d95294db5
(tls-certtool-program): New variable.
Simon Josefsson <jas@extundo.com>
parents:
56927
diff
changeset
|
91 (let ((certificate (concat "-----BEGIN CERTIFICATE-----\n" |
821d95294db5
(tls-certtool-program): New variable.
Simon Josefsson <jas@extundo.com>
parents:
56927
diff
changeset
|
92 (base64-encode-string der) |
821d95294db5
(tls-certtool-program): New variable.
Simon Josefsson <jas@extundo.com>
parents:
56927
diff
changeset
|
93 "\n-----END CERTIFICATE-----\n")) |
821d95294db5
(tls-certtool-program): New variable.
Simon Josefsson <jas@extundo.com>
parents:
56927
diff
changeset
|
94 (exit-code 0)) |
821d95294db5
(tls-certtool-program): New variable.
Simon Josefsson <jas@extundo.com>
parents:
56927
diff
changeset
|
95 (with-current-buffer (get-buffer-create " *certtool*") |
821d95294db5
(tls-certtool-program): New variable.
Simon Josefsson <jas@extundo.com>
parents:
56927
diff
changeset
|
96 (erase-buffer) |
821d95294db5
(tls-certtool-program): New variable.
Simon Josefsson <jas@extundo.com>
parents:
56927
diff
changeset
|
97 (insert certificate) |
821d95294db5
(tls-certtool-program): New variable.
Simon Josefsson <jas@extundo.com>
parents:
56927
diff
changeset
|
98 (setq exit-code (condition-case () |
821d95294db5
(tls-certtool-program): New variable.
Simon Josefsson <jas@extundo.com>
parents:
56927
diff
changeset
|
99 (call-process-region (point-min) (point-max) |
821d95294db5
(tls-certtool-program): New variable.
Simon Josefsson <jas@extundo.com>
parents:
56927
diff
changeset
|
100 tls-certtool-program |
821d95294db5
(tls-certtool-program): New variable.
Simon Josefsson <jas@extundo.com>
parents:
56927
diff
changeset
|
101 t (list (current-buffer) nil) t |
821d95294db5
(tls-certtool-program): New variable.
Simon Josefsson <jas@extundo.com>
parents:
56927
diff
changeset
|
102 "--certificate-info") |
821d95294db5
(tls-certtool-program): New variable.
Simon Josefsson <jas@extundo.com>
parents:
56927
diff
changeset
|
103 (error -1))) |
821d95294db5
(tls-certtool-program): New variable.
Simon Josefsson <jas@extundo.com>
parents:
56927
diff
changeset
|
104 (if (/= exit-code 0) |
821d95294db5
(tls-certtool-program): New variable.
Simon Josefsson <jas@extundo.com>
parents:
56927
diff
changeset
|
105 nil |
821d95294db5
(tls-certtool-program): New variable.
Simon Josefsson <jas@extundo.com>
parents:
56927
diff
changeset
|
106 (let ((vals nil)) |
821d95294db5
(tls-certtool-program): New variable.
Simon Josefsson <jas@extundo.com>
parents:
56927
diff
changeset
|
107 (goto-char (point-min)) |
821d95294db5
(tls-certtool-program): New variable.
Simon Josefsson <jas@extundo.com>
parents:
56927
diff
changeset
|
108 (while (re-search-forward "^\\([^:]+\\): \\(.*\\)" nil t) |
821d95294db5
(tls-certtool-program): New variable.
Simon Josefsson <jas@extundo.com>
parents:
56927
diff
changeset
|
109 (push (cons (match-string 1) (match-string 2)) vals)) |
821d95294db5
(tls-certtool-program): New variable.
Simon Josefsson <jas@extundo.com>
parents:
56927
diff
changeset
|
110 (nreverse vals)))))) |
821d95294db5
(tls-certtool-program): New variable.
Simon Josefsson <jas@extundo.com>
parents:
56927
diff
changeset
|
111 |
50313 | 112 (defun open-tls-stream (name buffer host service) |
113 "Open a TLS connection for a service to a host. | |
114 Returns a subprocess-object to represent the connection. | |
115 Input and output work as for subprocesses; `delete-process' closes it. | |
116 Args are NAME BUFFER HOST SERVICE. | |
117 NAME is name for process. It is modified if necessary to make it unique. | |
118 BUFFER is the buffer (or buffer-name) to associate with the process. | |
119 Process output goes at end of that buffer, unless you specify | |
120 an output stream or filter function to handle the output. | |
121 BUFFER may be also nil, meaning that this process is not associated | |
122 with any buffer | |
123 Third arg is name of the host to connect to, or its IP address. | |
124 Fourth arg SERVICE is name of the service desired, or an integer | |
125 specifying a port number to connect to." | |
126 (let ((cmds tls-program) cmd done) | |
127 (message "Opening TLS connection to `%s'..." host) | |
128 (while (and (not done) (setq cmd (pop cmds))) | |
129 (message "Opening TLS connection with `%s'..." cmd) | |
130 (let* ((process-connection-type tls-process-connection-type) | |
131 (process (start-process | |
132 name buffer shell-file-name shell-command-switch | |
133 (format-spec | |
134 cmd | |
135 (format-spec-make | |
136 ?h host | |
137 ?p (if (integerp service) | |
138 (int-to-string service) | |
139 service))))) | |
140 response) | |
141 (while (and process | |
142 (memq (process-status process) '(open run)) | |
143 (save-excursion | |
144 (set-buffer buffer) ;; XXX "blue moon" nntp.el bug | |
145 (goto-char (point-min)) | |
146 (not (setq done (re-search-forward tls-success nil t))))) | |
147 (accept-process-output process 1) | |
148 (sit-for 1)) | |
149 (message "Opening TLS connection with `%s'...%s" cmd | |
150 (if done "done" "failed")) | |
151 (if done | |
152 (setq done process) | |
153 (delete-process process)))) | |
154 (message "Opening TLS connection to `%s'...%s" | |
155 host (if done "done" "failed")) | |
156 done)) | |
157 | |
158 (provide 'tls) | |
159 | |
52401 | 160 ;;; arch-tag: 5596d1c4-facc-4bc4-94a9-9863b928d7ac |
50313 | 161 ;;; tls.el ends here |