Mercurial > emacs
annotate src/gnutls.c @ 110611:6c735824d0c1
Add gnutls logging and clean up various gnutls bits.
From: Teodor Zlatanov <tzz@lifelogs.com>
author | Lars Magne Ingebrigtsen <larsi@gnus.org> |
---|---|
date | Mon, 27 Sep 2010 18:44:31 +0200 |
parents | 06497cf3e920 |
children | 31e098898561 |
rev | line source |
---|---|
110584 | 1 /* GnuTLS glue for GNU Emacs. |
2 Copyright (C) 2010 Free Software Foundation, Inc. | |
3 | |
4 This file is part of GNU Emacs. | |
5 | |
6 GNU Emacs is free software: you can redistribute it and/or modify | |
7 it under the terms of the GNU General Public License as published by | |
8 the Free Software Foundation, either version 3 of the License, or | |
9 (at your option) any later version. | |
10 | |
11 GNU Emacs is distributed in the hope that it will be useful, | |
12 but WITHOUT ANY WARRANTY; without even the implied warranty of | |
13 MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the | |
14 GNU General Public License for more details. | |
15 | |
16 You should have received a copy of the GNU General Public License | |
17 along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>. */ | |
18 | |
19 #include <config.h> | |
20 #include <errno.h> | |
21 #include <setjmp.h> | |
22 | |
23 #include "lisp.h" | |
24 #include "process.h" | |
25 | |
26 #ifdef HAVE_GNUTLS | |
27 #include <gnutls/gnutls.h> | |
28 | |
29 Lisp_Object Qgnutls_code; | |
30 Lisp_Object Qgnutls_anon, Qgnutls_x509pki; | |
31 Lisp_Object Qgnutls_e_interrupted, Qgnutls_e_again, | |
32 Qgnutls_e_invalid_session, Qgnutls_e_not_ready_for_handshake; | |
33 int global_initialized; | |
34 | |
35 int | |
36 emacs_gnutls_write (int fildes, gnutls_session_t state, char *buf, | |
37 unsigned int nbyte) | |
38 { | |
39 register int rtnval, bytes_written; | |
40 | |
41 bytes_written = 0; | |
42 | |
43 while (nbyte > 0) | |
44 { | |
45 rtnval = gnutls_write (state, buf, nbyte); | |
46 | |
47 if (rtnval == -1) | |
48 { | |
49 if (errno == EINTR) | |
50 continue; | |
51 else | |
52 return (bytes_written ? bytes_written : -1); | |
53 } | |
54 | |
55 buf += rtnval; | |
56 nbyte -= rtnval; | |
57 bytes_written += rtnval; | |
58 } | |
59 fsync (STDOUT_FILENO); | |
60 | |
61 return (bytes_written); | |
62 } | |
63 | |
64 int | |
65 emacs_gnutls_read (int fildes, gnutls_session_t state, char *buf, | |
66 unsigned int nbyte) | |
67 { | |
68 register int rtnval; | |
69 | |
110608
06497cf3e920
(emacs_gnutls_read): Don't infloop while reading.
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
110606
diff
changeset
|
70 rtnval = gnutls_read (state, buf, nbyte); |
06497cf3e920
(emacs_gnutls_read): Don't infloop while reading.
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
110606
diff
changeset
|
71 if (rtnval >= 0) |
06497cf3e920
(emacs_gnutls_read): Don't infloop while reading.
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
110606
diff
changeset
|
72 return rtnval; |
06497cf3e920
(emacs_gnutls_read): Don't infloop while reading.
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
110606
diff
changeset
|
73 else |
06497cf3e920
(emacs_gnutls_read): Don't infloop while reading.
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
110606
diff
changeset
|
74 return -1; |
110584 | 75 } |
76 | |
77 /* convert an integer error to a Lisp_Object; it will be either a | |
78 known symbol like `gnutls_e_interrupted' and `gnutls_e_again' or | |
79 simply the integer value of the error. GNUTLS_E_SUCCESS is mapped | |
80 to Qt. */ | |
81 Lisp_Object gnutls_make_error (int error) | |
82 { | |
83 switch (error) | |
84 { | |
85 case GNUTLS_E_SUCCESS: | |
86 return Qt; | |
87 case GNUTLS_E_AGAIN: | |
88 return Qgnutls_e_again; | |
89 case GNUTLS_E_INTERRUPTED: | |
90 return Qgnutls_e_interrupted; | |
91 case GNUTLS_E_INVALID_SESSION: | |
92 return Qgnutls_e_invalid_session; | |
93 } | |
94 | |
95 return make_number (error); | |
96 } | |
97 | |
98 DEFUN ("gnutls-get-initstage", Fgnutls_get_initstage, Sgnutls_get_initstage, 1, 1, 0, | |
99 doc: /* Return the GnuTLS init stage of PROCESS. | |
100 See also `gnutls-boot'. */) | |
101 (Lisp_Object proc) | |
102 { | |
103 CHECK_PROCESS (proc); | |
104 | |
105 return make_number (GNUTLS_INITSTAGE (proc)); | |
106 } | |
107 | |
108 DEFUN ("gnutls-errorp", Fgnutls_errorp, Sgnutls_errorp, 1, 1, 0, | |
109 doc: /* Returns t if ERROR (as generated by gnutls_make_error) | |
110 indicates a GnuTLS problem. */) | |
111 (Lisp_Object error) | |
112 { | |
113 if (EQ (error, Qt)) return Qnil; | |
114 | |
115 return Qt; | |
116 } | |
117 | |
118 DEFUN ("gnutls-error-fatalp", Fgnutls_error_fatalp, Sgnutls_error_fatalp, 1, 1, 0, | |
119 doc: /* Checks if ERROR is fatal. | |
120 ERROR is an integer or a symbol with an integer `gnutls-code' property. */) | |
121 (Lisp_Object err) | |
122 { | |
123 Lisp_Object code; | |
124 | |
125 if (EQ (err, Qt)) return Qnil; | |
126 | |
127 if (SYMBOLP (err)) | |
128 { | |
129 code = Fget (err, Qgnutls_code); | |
130 if (NUMBERP (code)) | |
131 { | |
132 err = code; | |
133 } | |
134 else | |
135 { | |
136 error ("Symbol has no numeric gnutls-code property"); | |
137 } | |
138 } | |
139 | |
140 if (!NUMBERP (err)) | |
141 error ("Not an error symbol or code"); | |
142 | |
143 if (0 == gnutls_error_is_fatal (XINT (err))) | |
144 return Qnil; | |
145 | |
146 return Qt; | |
147 } | |
148 | |
149 DEFUN ("gnutls-error-string", Fgnutls_error_string, Sgnutls_error_string, 1, 1, 0, | |
150 doc: /* Returns a description of ERROR. | |
151 ERROR is an integer or a symbol with an integer `gnutls-code' property. */) | |
152 (Lisp_Object err) | |
153 { | |
154 Lisp_Object code; | |
155 | |
156 if (EQ (err, Qt)) return build_string ("Not an error"); | |
157 | |
158 if (SYMBOLP (err)) | |
159 { | |
160 code = Fget (err, Qgnutls_code); | |
161 if (NUMBERP (code)) | |
162 { | |
163 err = code; | |
164 } | |
165 else | |
166 { | |
167 return build_string ("Symbol has no numeric gnutls-code property"); | |
168 } | |
169 } | |
170 | |
171 if (!NUMBERP (err)) | |
172 return build_string ("Not an error symbol or code"); | |
173 | |
174 return build_string (gnutls_strerror (XINT (err))); | |
175 } | |
176 | |
177 DEFUN ("gnutls-deinit", Fgnutls_deinit, Sgnutls_deinit, 1, 1, 0, | |
178 doc: /* Deallocate GNU TLS resources associated with PROCESS. | |
179 See also `gnutls-init'. */) | |
180 (Lisp_Object proc) | |
181 { | |
182 gnutls_session_t state; | |
183 | |
184 CHECK_PROCESS (proc); | |
185 state = XPROCESS (proc)->gnutls_state; | |
186 | |
187 if (GNUTLS_INITSTAGE (proc) >= GNUTLS_STAGE_INIT) | |
188 { | |
189 gnutls_deinit (state); | |
190 GNUTLS_INITSTAGE (proc) = GNUTLS_STAGE_INIT - 1; | |
191 } | |
192 | |
193 return Qt; | |
194 } | |
195 | |
196 /* Initializes global GNU TLS state to defaults. | |
197 Call `gnutls-global-deinit' when GNU TLS usage is no longer needed. | |
198 Returns zero on success. */ | |
199 Lisp_Object gnutls_emacs_global_init (void) | |
200 { | |
201 int ret = GNUTLS_E_SUCCESS; | |
202 | |
203 if (!global_initialized) | |
204 ret = gnutls_global_init (); | |
205 | |
206 global_initialized = 1; | |
207 | |
208 return gnutls_make_error (ret); | |
209 } | |
210 | |
211 /* Deinitializes global GNU TLS state. | |
212 See also `gnutls-global-init'. */ | |
213 Lisp_Object gnutls_emacs_global_deinit (void) | |
214 { | |
215 if (global_initialized) | |
216 gnutls_global_deinit (); | |
217 | |
218 global_initialized = 0; | |
219 | |
220 return gnutls_make_error (GNUTLS_E_SUCCESS); | |
221 } | |
222 | |
110611
6c735824d0c1
Add gnutls logging and clean up various gnutls bits.
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
110608
diff
changeset
|
223 static void gnutls_log_function (int level, const char* string) |
6c735824d0c1
Add gnutls logging and clean up various gnutls bits.
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
110608
diff
changeset
|
224 { |
6c735824d0c1
Add gnutls logging and clean up various gnutls bits.
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
110608
diff
changeset
|
225 message("gnutls.c: [%d] %s", level, string); |
110606
b4f4c3e9b976
Add debugging to the gnutls library, and finish handshaking when it's done.
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
110584
diff
changeset
|
226 } |
b4f4c3e9b976
Add debugging to the gnutls library, and finish handshaking when it's done.
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
110584
diff
changeset
|
227 |
110611
6c735824d0c1
Add gnutls logging and clean up various gnutls bits.
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
110608
diff
changeset
|
228 DEFUN ("gnutls-boot", Fgnutls_boot, Sgnutls_boot, 3, 7, 0, |
110584 | 229 doc: /* Initializes client-mode GnuTLS for process PROC. |
230 Currently only client mode is supported. Returns a success/failure | |
231 value you can check with `gnutls-errorp'. | |
232 | |
233 PRIORITY_STRING is a string describing the priority. | |
234 TYPE is either `gnutls-anon' or `gnutls-x509pki'. | |
235 TRUSTFILE is a PEM encoded trust file for `gnutls-x509pki'. | |
236 KEYFILE is ... for `gnutls-x509pki' (TODO). | |
237 CALLBACK is ... for `gnutls-x509pki' (TODO). | |
110611
6c735824d0c1
Add gnutls logging and clean up various gnutls bits.
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
110608
diff
changeset
|
238 LOGLEVEL is the debug level requested from GnuTLS, try 4. |
6c735824d0c1
Add gnutls logging and clean up various gnutls bits.
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
110608
diff
changeset
|
239 |
6c735824d0c1
Add gnutls logging and clean up various gnutls bits.
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
110608
diff
changeset
|
240 LOGLEVEL will be set for this process AND globally for GnuTLS. So if |
6c735824d0c1
Add gnutls logging and clean up various gnutls bits.
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
110608
diff
changeset
|
241 you set it higher or lower at any point, it affects global debugging. |
110584 | 242 |
243 Note that the priority is set on the client. The server does not use | |
244 the protocols's priority except for disabling protocols that were not | |
245 specified. | |
246 | |
247 Processes must be initialized with this function before other GNU TLS | |
248 functions are used. This function allocates resources which can only | |
249 be deallocated by calling `gnutls-deinit' or by calling it again. | |
250 | |
251 Each authentication type may need additional information in order to | |
252 work. For X.509 PKI (`gnutls-x509pki'), you need TRUSTFILE and | |
253 KEYFILE and optionally CALLBACK. */) | |
254 (Lisp_Object proc, Lisp_Object priority_string, Lisp_Object type, | |
110611
6c735824d0c1
Add gnutls logging and clean up various gnutls bits.
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
110608
diff
changeset
|
255 Lisp_Object trustfile, Lisp_Object keyfile, Lisp_Object callback, |
6c735824d0c1
Add gnutls logging and clean up various gnutls bits.
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
110608
diff
changeset
|
256 Lisp_Object loglevel) |
110584 | 257 { |
258 int ret = GNUTLS_E_SUCCESS; | |
259 | |
110611
6c735824d0c1
Add gnutls logging and clean up various gnutls bits.
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
110608
diff
changeset
|
260 int max_log_level = 0; |
6c735824d0c1
Add gnutls logging and clean up various gnutls bits.
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
110608
diff
changeset
|
261 |
110584 | 262 /* TODO: GNUTLS_X509_FMT_DER is also an option. */ |
263 int file_format = GNUTLS_X509_FMT_PEM; | |
264 | |
265 gnutls_session_t state; | |
266 gnutls_certificate_credentials_t x509_cred; | |
267 gnutls_anon_client_credentials_t anon_cred; | |
268 gnutls_srp_client_credentials_t srp_cred; | |
269 gnutls_datum_t data; | |
270 Lisp_Object global_init; | |
271 | |
272 CHECK_PROCESS (proc); | |
273 CHECK_SYMBOL (type); | |
274 CHECK_STRING (priority_string); | |
275 | |
276 state = XPROCESS (proc)->gnutls_state; | |
277 | |
110611
6c735824d0c1
Add gnutls logging and clean up various gnutls bits.
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
110608
diff
changeset
|
278 if (NUMBERP (loglevel)) |
6c735824d0c1
Add gnutls logging and clean up various gnutls bits.
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
110608
diff
changeset
|
279 { |
6c735824d0c1
Add gnutls logging and clean up various gnutls bits.
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
110608
diff
changeset
|
280 message ("setting up log level %d", XINT (loglevel)); |
6c735824d0c1
Add gnutls logging and clean up various gnutls bits.
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
110608
diff
changeset
|
281 gnutls_global_set_log_function (gnutls_log_function); |
6c735824d0c1
Add gnutls logging and clean up various gnutls bits.
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
110608
diff
changeset
|
282 gnutls_global_set_log_level (XINT (loglevel)); |
6c735824d0c1
Add gnutls logging and clean up various gnutls bits.
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
110608
diff
changeset
|
283 max_log_level = XINT (loglevel); |
6c735824d0c1
Add gnutls logging and clean up various gnutls bits.
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
110608
diff
changeset
|
284 XPROCESS (proc)->gnutls_log_level = max_log_level; |
6c735824d0c1
Add gnutls logging and clean up various gnutls bits.
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
110608
diff
changeset
|
285 } |
110606
b4f4c3e9b976
Add debugging to the gnutls library, and finish handshaking when it's done.
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
110584
diff
changeset
|
286 |
110584 | 287 /* always initialize globals. */ |
288 global_init = gnutls_emacs_global_init (); | |
289 if (! NILP (Fgnutls_errorp (global_init))) | |
290 return global_init; | |
291 | |
292 /* deinit and free resources. */ | |
293 if (GNUTLS_INITSTAGE (proc) >= GNUTLS_STAGE_CRED_ALLOC) | |
294 { | |
110611
6c735824d0c1
Add gnutls logging and clean up various gnutls bits.
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
110608
diff
changeset
|
295 GNUTLS_LOG (1, max_log_level, "deallocating credentials"); |
6c735824d0c1
Add gnutls logging and clean up various gnutls bits.
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
110608
diff
changeset
|
296 |
110584 | 297 if (EQ (type, Qgnutls_x509pki)) |
298 { | |
110611
6c735824d0c1
Add gnutls logging and clean up various gnutls bits.
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
110608
diff
changeset
|
299 GNUTLS_LOG (2, max_log_level, "deallocating x509 credentials"); |
6c735824d0c1
Add gnutls logging and clean up various gnutls bits.
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
110608
diff
changeset
|
300 x509_cred = XPROCESS (proc)->gnutls_x509_cred; |
110584 | 301 gnutls_certificate_free_credentials (x509_cred); |
302 } | |
303 else if (EQ (type, Qgnutls_anon)) | |
304 { | |
110611
6c735824d0c1
Add gnutls logging and clean up various gnutls bits.
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
110608
diff
changeset
|
305 GNUTLS_LOG (2, max_log_level, "deallocating anon credentials"); |
6c735824d0c1
Add gnutls logging and clean up various gnutls bits.
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
110608
diff
changeset
|
306 anon_cred = XPROCESS (proc)->gnutls_anon_cred; |
110584 | 307 gnutls_anon_free_client_credentials (anon_cred); |
308 } | |
309 else | |
310 { | |
311 error ("unknown credential type"); | |
312 ret = GNUTLS_EMACS_ERROR_INVALID_TYPE; | |
313 } | |
314 | |
315 if (GNUTLS_INITSTAGE (proc) >= GNUTLS_STAGE_INIT) | |
316 { | |
110611
6c735824d0c1
Add gnutls logging and clean up various gnutls bits.
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
110608
diff
changeset
|
317 GNUTLS_LOG (1, max_log_level, "deallocating x509 credentials"); |
110584 | 318 Fgnutls_deinit (proc); |
319 } | |
320 } | |
321 | |
322 GNUTLS_INITSTAGE (proc) = GNUTLS_STAGE_EMPTY; | |
323 | |
110611
6c735824d0c1
Add gnutls logging and clean up various gnutls bits.
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
110608
diff
changeset
|
324 GNUTLS_LOG (1, max_log_level, "allocating credentials"); |
6c735824d0c1
Add gnutls logging and clean up various gnutls bits.
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
110608
diff
changeset
|
325 |
110584 | 326 if (EQ (type, Qgnutls_x509pki)) |
327 { | |
110611
6c735824d0c1
Add gnutls logging and clean up various gnutls bits.
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
110608
diff
changeset
|
328 GNUTLS_LOG (2, max_log_level, "allocating x509 credentials"); |
6c735824d0c1
Add gnutls logging and clean up various gnutls bits.
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
110608
diff
changeset
|
329 x509_cred = XPROCESS (proc)->gnutls_x509_cred; |
110584 | 330 if (gnutls_certificate_allocate_credentials (&x509_cred) < 0) |
331 memory_full (); | |
332 } | |
333 else if (EQ (type, Qgnutls_anon)) | |
334 { | |
110611
6c735824d0c1
Add gnutls logging and clean up various gnutls bits.
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
110608
diff
changeset
|
335 GNUTLS_LOG (2, max_log_level, "allocating anon credentials"); |
6c735824d0c1
Add gnutls logging and clean up various gnutls bits.
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
110608
diff
changeset
|
336 anon_cred = XPROCESS (proc)->gnutls_anon_cred; |
110584 | 337 if (gnutls_anon_allocate_client_credentials (&anon_cred) < 0) |
338 memory_full (); | |
339 } | |
340 else | |
341 { | |
342 error ("unknown credential type"); | |
343 ret = GNUTLS_EMACS_ERROR_INVALID_TYPE; | |
344 } | |
345 | |
346 if (ret < GNUTLS_E_SUCCESS) | |
347 return gnutls_make_error (ret); | |
348 | |
349 GNUTLS_INITSTAGE (proc) = GNUTLS_STAGE_CRED_ALLOC; | |
350 | |
351 if (EQ (type, Qgnutls_x509pki)) | |
352 { | |
353 if (STRINGP (trustfile)) | |
354 { | |
110611
6c735824d0c1
Add gnutls logging and clean up various gnutls bits.
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
110608
diff
changeset
|
355 GNUTLS_LOG (1, max_log_level, "setting the trustfile"); |
110584 | 356 ret = gnutls_certificate_set_x509_trust_file |
357 (x509_cred, | |
358 XSTRING (trustfile)->data, | |
359 file_format); | |
360 | |
361 if (ret < GNUTLS_E_SUCCESS) | |
362 return gnutls_make_error (ret); | |
363 } | |
364 | |
365 if (STRINGP (keyfile)) | |
366 { | |
110611
6c735824d0c1
Add gnutls logging and clean up various gnutls bits.
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
110608
diff
changeset
|
367 GNUTLS_LOG (1, max_log_level, "setting the keyfile"); |
110584 | 368 ret = gnutls_certificate_set_x509_crl_file |
369 (x509_cred, | |
370 XSTRING (keyfile)->data, | |
371 file_format); | |
372 | |
373 if (ret < GNUTLS_E_SUCCESS) | |
374 return gnutls_make_error (ret); | |
375 } | |
376 } | |
377 | |
378 GNUTLS_INITSTAGE (proc) = GNUTLS_STAGE_FILES; | |
379 | |
110611
6c735824d0c1
Add gnutls logging and clean up various gnutls bits.
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
110608
diff
changeset
|
380 GNUTLS_LOG (1, max_log_level, "gnutls_init"); |
6c735824d0c1
Add gnutls logging and clean up various gnutls bits.
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
110608
diff
changeset
|
381 |
110584 | 382 ret = gnutls_init (&state, GNUTLS_CLIENT); |
383 | |
384 if (ret < GNUTLS_E_SUCCESS) | |
385 return gnutls_make_error (ret); | |
386 | |
387 XPROCESS (proc)->gnutls_state = state; | |
388 | |
389 GNUTLS_INITSTAGE (proc) = GNUTLS_STAGE_INIT; | |
390 | |
110611
6c735824d0c1
Add gnutls logging and clean up various gnutls bits.
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
110608
diff
changeset
|
391 GNUTLS_LOG (1, max_log_level, "setting the priority string"); |
6c735824d0c1
Add gnutls logging and clean up various gnutls bits.
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
110608
diff
changeset
|
392 |
110584 | 393 ret = gnutls_priority_set_direct(state, |
394 (char*) SDATA (priority_string), | |
395 NULL); | |
396 | |
397 if (ret < GNUTLS_E_SUCCESS) | |
398 return gnutls_make_error (ret); | |
399 | |
400 GNUTLS_INITSTAGE (proc) = GNUTLS_STAGE_PRIORITY; | |
401 | |
402 message ("gnutls: setting the credentials"); | |
403 | |
404 if (EQ (type, Qgnutls_x509pki)) | |
405 { | |
406 message ("gnutls: setting the x509 credentials"); | |
407 | |
408 ret = gnutls_cred_set (state, GNUTLS_CRD_CERTIFICATE, x509_cred); | |
409 } | |
410 else if (EQ (type, Qgnutls_anon)) | |
411 { | |
412 message ("gnutls: setting the anon credentials"); | |
413 | |
414 ret = gnutls_cred_set (state, GNUTLS_CRD_ANON, anon_cred); | |
415 } | |
416 else | |
417 { | |
418 error ("unknown credential type"); | |
419 ret = GNUTLS_EMACS_ERROR_INVALID_TYPE; | |
420 } | |
421 | |
422 if (ret < GNUTLS_E_SUCCESS) | |
423 return gnutls_make_error (ret); | |
424 | |
110611
6c735824d0c1
Add gnutls logging and clean up various gnutls bits.
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
110608
diff
changeset
|
425 XPROCESS (proc)->gnutls_anon_cred = anon_cred; |
6c735824d0c1
Add gnutls logging and clean up various gnutls bits.
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
110608
diff
changeset
|
426 XPROCESS (proc)->gnutls_x509_cred = x509_cred; |
110584 | 427 XPROCESS (proc)->gnutls_cred_type = type; |
428 | |
429 GNUTLS_INITSTAGE (proc) = GNUTLS_STAGE_CRED_SET; | |
430 | |
431 return gnutls_make_error (GNUTLS_E_SUCCESS); | |
432 } | |
433 | |
434 DEFUN ("gnutls-bye", Fgnutls_bye, | |
435 Sgnutls_bye, 2, 2, 0, | |
436 doc: /* Terminate current GNU TLS connection for PROCESS. | |
437 The connection should have been initiated using `gnutls-handshake'. | |
438 | |
439 If CONT is not nil the TLS connection gets terminated and further | |
440 receives and sends will be disallowed. If the return value is zero you | |
441 may continue using the connection. If CONT is nil, GnuTLS actually | |
442 sends an alert containing a close request and waits for the peer to | |
443 reply with the same message. In order to reuse the connection you | |
444 should wait for an EOF from the peer. | |
445 | |
446 This function may also return `gnutls-e-again', or | |
447 `gnutls-e-interrupted'. */) | |
448 (Lisp_Object proc, Lisp_Object cont) | |
449 { | |
450 gnutls_session_t state; | |
451 int ret; | |
452 | |
453 CHECK_PROCESS (proc); | |
454 | |
455 state = XPROCESS (proc)->gnutls_state; | |
456 | |
457 ret = gnutls_bye (state, | |
458 NILP (cont) ? GNUTLS_SHUT_RDWR : GNUTLS_SHUT_WR); | |
459 | |
460 return gnutls_make_error (ret); | |
461 } | |
462 | |
463 DEFUN ("gnutls-handshake", Fgnutls_handshake, | |
464 Sgnutls_handshake, 1, 1, 0, | |
465 doc: /* Perform GNU TLS handshake for PROCESS. | |
466 The identity of the peer is checked automatically. This function will | |
467 fail if any problem is encountered, and will return a negative error | |
468 code. In case of a client, if it has been asked to resume a session, | |
469 but the server didn't, then a full handshake will be performed. | |
470 | |
471 If the error `gnutls-e-not-ready-for-handshake' is returned, you | |
472 didn't call `gnutls-boot' first. | |
473 | |
474 This function may also return the non-fatal errors `gnutls-e-again', | |
475 or `gnutls-e-interrupted'. In that case you may resume the handshake | |
476 (by calling this function again). */) | |
477 (Lisp_Object proc) | |
478 { | |
479 gnutls_session_t state; | |
480 int ret; | |
110611
6c735824d0c1
Add gnutls logging and clean up various gnutls bits.
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
110608
diff
changeset
|
481 int max_log_level = XPROCESS (proc)->gnutls_log_level; |
110584 | 482 |
483 CHECK_PROCESS (proc); | |
484 state = XPROCESS (proc)->gnutls_state; | |
485 | |
486 if (GNUTLS_INITSTAGE (proc) < GNUTLS_STAGE_HANDSHAKE_CANDO) | |
487 return Qgnutls_e_not_ready_for_handshake; | |
488 | |
489 | |
490 if (GNUTLS_INITSTAGE (proc) < GNUTLS_STAGE_TRANSPORT_POINTERS_SET) | |
491 { | |
492 /* for a network process in Emacs infd and outfd are the same | |
493 but this shows our intent more clearly. */ | |
494 message ("gnutls: handshake: setting the transport pointers to %d/%d", | |
495 XPROCESS (proc)->infd, XPROCESS (proc)->outfd); | |
496 | |
497 gnutls_transport_set_ptr2 (state, XPROCESS (proc)->infd, | |
498 XPROCESS (proc)->outfd); | |
499 | |
500 GNUTLS_INITSTAGE (proc) = GNUTLS_STAGE_TRANSPORT_POINTERS_SET; | |
501 } | |
502 | |
503 ret = gnutls_handshake (state); | |
504 GNUTLS_INITSTAGE (proc) = GNUTLS_STAGE_HANDSHAKE_TRIED; | |
505 | |
110611
6c735824d0c1
Add gnutls logging and clean up various gnutls bits.
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
110608
diff
changeset
|
506 if (GNUTLS_E_SUCCESS == ret) |
110584 | 507 { |
508 /* here we're finally done. */ | |
509 GNUTLS_INITSTAGE (proc) = GNUTLS_STAGE_READY; | |
510 } | |
511 | |
512 return gnutls_make_error (ret); | |
513 } | |
514 | |
515 void | |
516 syms_of_gnutls (void) | |
517 { | |
518 global_initialized = 0; | |
519 | |
520 Qgnutls_code = intern_c_string ("gnutls-code"); | |
521 staticpro (&Qgnutls_code); | |
522 | |
523 Qgnutls_anon = intern_c_string ("gnutls-anon"); | |
524 staticpro (&Qgnutls_anon); | |
525 | |
526 Qgnutls_x509pki = intern_c_string ("gnutls-x509pki"); | |
527 staticpro (&Qgnutls_x509pki); | |
528 | |
529 Qgnutls_e_interrupted = intern_c_string ("gnutls-e-interrupted"); | |
530 staticpro (&Qgnutls_e_interrupted); | |
531 Fput (Qgnutls_e_interrupted, Qgnutls_code, | |
532 make_number (GNUTLS_E_INTERRUPTED)); | |
533 | |
534 Qgnutls_e_again = intern_c_string ("gnutls-e-again"); | |
535 staticpro (&Qgnutls_e_again); | |
536 Fput (Qgnutls_e_again, Qgnutls_code, | |
537 make_number (GNUTLS_E_AGAIN)); | |
538 | |
539 Qgnutls_e_invalid_session = intern_c_string ("gnutls-e-invalid-session"); | |
540 staticpro (&Qgnutls_e_invalid_session); | |
541 Fput (Qgnutls_e_invalid_session, Qgnutls_code, | |
542 make_number (GNUTLS_E_INVALID_SESSION)); | |
543 | |
544 Qgnutls_e_not_ready_for_handshake = | |
545 intern_c_string ("gnutls-e-not-ready-for-handshake"); | |
546 staticpro (&Qgnutls_e_not_ready_for_handshake); | |
547 Fput (Qgnutls_e_not_ready_for_handshake, Qgnutls_code, | |
548 make_number (GNUTLS_E_APPLICATION_ERROR_MIN)); | |
549 | |
550 defsubr (&Sgnutls_get_initstage); | |
551 defsubr (&Sgnutls_errorp); | |
552 defsubr (&Sgnutls_error_fatalp); | |
553 defsubr (&Sgnutls_error_string); | |
554 defsubr (&Sgnutls_boot); | |
555 defsubr (&Sgnutls_deinit); | |
556 defsubr (&Sgnutls_handshake); | |
557 defsubr (&Sgnutls_bye); | |
558 } | |
559 #endif |