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