Commit | Line | Data |
---|---|---|
01b2d1dd SJ |
1 | ;;; tls.el --- TLS/SSL support via wrapper around GnuTLS |
2 | ||
18965008 | 3 | ;; Copyright (C) 1996-1999, 2003, 2004 Free Software Foundation, Inc. |
01b2d1dd SJ |
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 | |
23f87bed | 69 | "*Value for `process-connection-type' to use when starting TLS process." |
bf247b6e | 70 | :version "22.1" |
01b2d1dd SJ |
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." | |
bf247b6e | 77 | :version "22.1" |
01b2d1dd SJ |
78 | :type 'regexp |
79 | :group 'tls) | |
80 | ||
18965008 SJ |
81 | (defcustom tls-certtool-program (executable-find "certtool") |
82 | "Name of GnuTLS certtool. | |
83 | Used by `tls-certificate-information'." | |
bf247b6e | 84 | :version "22.1" |
18965008 SJ |
85 | :type '(repeat string) |
86 | :group 'tls) | |
87 | ||
88 | (defun tls-certificate-information (der) | |
89 | "Parse X.509 certificate in DER format into an assoc list." | |
90 | (let ((certificate (concat "-----BEGIN CERTIFICATE-----\n" | |
91 | (base64-encode-string der) | |
92 | "\n-----END CERTIFICATE-----\n")) | |
93 | (exit-code 0)) | |
94 | (with-current-buffer (get-buffer-create " *certtool*") | |
95 | (erase-buffer) | |
96 | (insert certificate) | |
97 | (setq exit-code (condition-case () | |
98 | (call-process-region (point-min) (point-max) | |
99 | tls-certtool-program | |
100 | t (list (current-buffer) nil) t | |
101 | "--certificate-info") | |
102 | (error -1))) | |
103 | (if (/= exit-code 0) | |
104 | nil | |
105 | (let ((vals nil)) | |
106 | (goto-char (point-min)) | |
107 | (while (re-search-forward "^\\([^:]+\\): \\(.*\\)" nil t) | |
108 | (push (cons (match-string 1) (match-string 2)) vals)) | |
109 | (nreverse vals)))))) | |
110 | ||
01b2d1dd SJ |
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 | ||
ab5796a9 | 159 | ;;; arch-tag: 5596d1c4-facc-4bc4-94a9-9863b928d7ac |
01b2d1dd | 160 | ;;; tls.el ends here |