1 --- starttls.el 2006-03-08 09:59:10.000000000 +0000
2 +++ starttls.el.mod 2007-08-15 21:04:34.000000000 +0000
4 ;;; starttls.el --- STARTTLS functions
5 +;;; in fact this file pretends to be starttls.el!
7 ;; Copyright (C) 1999, 2000, 2002, 2003, 2004,
8 ;; 2005, 2006 Free Software Foundation, Inc.
11 (defcustom starttls-gnutls-program "gnutls-cli"
12 "Name of GNUTLS command line tool.
13 -This program is used when GNUTLS is used, i.e. when
14 -`starttls-use-gnutls' is non-nil."
15 +This program is not used at all, so ... :)"
19 (defcustom starttls-program "starttls"
20 "The program to run in a subprocess to open an TLSv1 connection.
21 -This program is used when the `starttls' command is used,
22 -i.e. when `starttls-use-gnutls' is nil."
23 +This program is not used at all, so ... :)"
27 -(defcustom starttls-use-gnutls (not (executable-find starttls-program))
28 - "*Whether to use GNUTLS instead of the `starttls' command."
29 +(defcustom starttls-use-gnutls t
30 + "*Set whatever you want. I will not care anyway."
34 (defcustom starttls-extra-args nil
35 - "Extra arguments to `starttls-program'.
36 -These apply when the `starttls' command is used, i.e. when
37 -`starttls-use-gnutls' is nil."
38 + "Extra arguments to `starttls-program'. ;)"
39 :type '(repeat string)
42 (defcustom starttls-extra-arguments nil
43 - "Extra arguments to `starttls-program'.
44 -These apply when GNUTLS is used, i.e. when `starttls-use-gnutls' is non-nil.
46 -For example, non-TLS compliant servers may require
47 -'(\"--protocols\" \"ssl3\"). Invoke \"gnutls-cli --help\" to
48 -find out which parameters are available."
49 + "Extra arguments to `starttls-program'. ;)"
50 :type '(repeat string)
57 +(defcustom starttls-ca-list nil
58 + "*List of certificate authorities to add to every tls connection
60 + :type '(repeat string)
63 (defun starttls-negotiate-gnutls (process)
64 "Negotiate TLS on PROCESS opened by `open-starttls-stream'.
65 This should typically only be done once. It typically returns a
66 multi-line informational message with information about the
67 handshake, or nil on failure."
68 - (let (buffer info old-max done-ok done-bad)
69 - (if (null (setq buffer (process-buffer process)))
70 - ;; XXX How to remove/extract the TLS negotiation junk?
71 - (signal-process (process-id process) 'SIGALRM)
72 - (with-current-buffer buffer
74 - (setq old-max (goto-char (point-max)))
75 - (signal-process (process-id process) 'SIGALRM)
76 - (while (and (processp process)
77 - (eq (process-status process) 'run)
80 - (not (or (setq done-ok (re-search-forward
81 - starttls-success nil t))
82 - (setq done-bad (re-search-forward
83 - starttls-failure nil t))))))
84 - (accept-process-output process 1 100)
86 - (setq info (buffer-substring-no-properties old-max (point-max)))
87 - (delete-region old-max (point-max))
88 - (if (or (and done-ok (not done-bad))
89 - ;; Prevent mitm that fake success msg after failure msg.
90 - (and done-ok done-bad (< done-ok done-bad)))
92 - (message "STARTTLS negotiation failed: %s" info)
95 -(defun starttls-negotiate (process)
96 - (if starttls-use-gnutls
97 - (starttls-negotiate-gnutls process)
98 - (signal-process (process-id process) 'SIGALRM)))
100 + ;; we just snarf what we need from the extra arguments
103 + (member "--x509certfile" starttls-extra-arguments))))
106 + (member "--x509keyfile" starttls-extra-arguments))))
109 + (member "--x509cafile" starttls-extra-arguments)))))
110 + (ossl-ssl-handshake process 'tls1 ca cert key)
113 +(defalias 'starttls-negotiate #'starttls-negotiate-gnutls)
116 - (if (fboundp 'set-process-query-on-exit-flag)
117 - (defalias 'starttls-set-process-query-on-exit-flag
118 - 'set-process-query-on-exit-flag)
119 - (defalias 'starttls-set-process-query-on-exit-flag
120 - 'process-kill-without-query)))
121 + (defalias 'starttls-set-process-query-on-exit-flag
122 + 'process-kill-without-query))
124 (defun starttls-open-stream-gnutls (name buffer host port)
125 - (message "Opening STARTTLS connection to `%s'..." host)
127 - (old-max (with-current-buffer buffer (point-max)))
128 - (process-connection-type starttls-process-connection-type)
129 - (process (apply #'start-process name buffer
130 - starttls-gnutls-program "-s" host
131 - "-p" (if (integerp port)
132 - (int-to-string port)
134 - starttls-extra-arguments)))
135 - (starttls-set-process-query-on-exit-flag process nil)
136 - (while (and (processp process)
137 - (eq (process-status process) 'run)
139 - (set-buffer buffer)
140 - (goto-char old-max)
141 - (not (setq done (re-search-forward
142 - starttls-connect nil t)))))
143 - (accept-process-output process 0 100)
146 - (with-current-buffer buffer
147 - (delete-region old-max done))
148 - (delete-process process)
149 - (setq process nil))
150 - (message "Opening STARTTLS connection to `%s'...%s"
151 - host (if done "done" "failed"))
154 -(defun starttls-open-stream (name buffer host port)
155 "Open a TLS connection for a port to a host.
156 Returns a subprocess object to represent the connection.
157 Input and output work as for subprocesses; `delete-process' closes it.
158 @@ -277,18 +226,28 @@
159 BUFFER may be also nil, meaning that this process is not associated
161 Third arg is name of the host to connect to, or its IP address.
162 -Fourth arg PORT is an integer specifying a port to connect to.
163 -If `starttls-use-gnutls' is nil, this may also be a service name, but
164 -GNUTLS requires a port number."
165 - (if starttls-use-gnutls
166 - (starttls-open-stream-gnutls name buffer host port)
167 - (let* ((process-connection-type starttls-process-connection-type)
168 - (process (apply #'start-process
169 - name buffer starttls-program
170 - host (format "%s" port)
171 - starttls-extra-args)))
172 - (starttls-set-process-query-on-exit-flag process nil)
174 +Fourth arg PORT is an integer specifying a port to connect to."
175 + (message "Opening STARTTLS connection to `%s'..." host)
177 + (old-max (with-current-buffer buffer (point-max)))
178 + (process-connection-type starttls-process-connection-type)
179 + (process (open-network-stream name buffer host port)))
180 + (starttls-set-process-query-on-exit-flag process nil)
181 + (when (and (processp process)
182 + (or (eq (process-status process) 'open)
183 + (eq (process-status process) 'run)))
184 +;; ;; how 'bout a STARTTLS?
185 +;; (process-send-string process "STARTTLS\r\n")
186 +;; (when (and (processp process)
187 +;; (or (eq (process-status process) 'open)
188 +;; (eq (process-status process) 'run)))
189 + (setq done (starttls-negotiate-gnutls process))) ;;)
190 + (message "Opening STARTTLS connection to `%s'...%s"
191 + host (if done "done" "failed"))
194 +(defalias 'starttls-open-stream #'starttls-open-stream-gnutls)