| 1 | ;;; tls.el --- TLS/SSL support via wrapper around GnuTLS |
| 2 | |
| 3 | ;; Copyright (C) 1996, 1997, 1998, 1999, 2002, 2003, 2004, |
| 4 | ;; 2005, 2006 Free Software Foundation, Inc. |
| 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 |
| 23 | ;; Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, |
| 24 | ;; Boston, MA 02110-1301, USA. |
| 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 | "openssl s_client -connect %h:%p -no_ssl2") |
| 61 | "List of strings containing commands to start TLS stream to a host. |
| 62 | Each entry in the list is tried until a connection is successful. |
| 63 | %s is replaced with server hostname, %p with port to connect to. |
| 64 | The program should read input on stdin and write output to |
| 65 | stdout. Also see `tls-success' for what the program should output |
| 66 | after successful negotiation." |
| 67 | :type '(repeat string) |
| 68 | :version "22.1" |
| 69 | :group 'tls) |
| 70 | |
| 71 | (defcustom tls-process-connection-type nil |
| 72 | "*Value for `process-connection-type' to use when starting TLS process." |
| 73 | :version "22.1" |
| 74 | :type 'boolean |
| 75 | :group 'tls) |
| 76 | |
| 77 | (defcustom tls-success "- Handshake was completed\\|SSL handshake has read " |
| 78 | "*Regular expression indicating completed TLS handshakes. |
| 79 | The default is what GNUTLS's \"gnutls-cli\" or OpenSSL's |
| 80 | \"openssl s_client\" outputs." |
| 81 | :version "22.1" |
| 82 | :type 'regexp |
| 83 | :group 'tls) |
| 84 | |
| 85 | (defcustom tls-certtool-program (executable-find "certtool") |
| 86 | "Name of GnuTLS certtool. |
| 87 | Used by `tls-certificate-information'." |
| 88 | :version "22.1" |
| 89 | :type '(repeat string) |
| 90 | :group 'tls) |
| 91 | |
| 92 | (defun tls-certificate-information (der) |
| 93 | "Parse X.509 certificate in DER format into an assoc list." |
| 94 | (let ((certificate (concat "-----BEGIN CERTIFICATE-----\n" |
| 95 | (base64-encode-string der) |
| 96 | "\n-----END CERTIFICATE-----\n")) |
| 97 | (exit-code 0)) |
| 98 | (with-current-buffer (get-buffer-create " *certtool*") |
| 99 | (erase-buffer) |
| 100 | (insert certificate) |
| 101 | (setq exit-code (condition-case () |
| 102 | (call-process-region (point-min) (point-max) |
| 103 | tls-certtool-program |
| 104 | t (list (current-buffer) nil) t |
| 105 | "--certificate-info") |
| 106 | (error -1))) |
| 107 | (if (/= exit-code 0) |
| 108 | nil |
| 109 | (let ((vals nil)) |
| 110 | (goto-char (point-min)) |
| 111 | (while (re-search-forward "^\\([^:]+\\): \\(.*\\)" nil t) |
| 112 | (push (cons (match-string 1) (match-string 2)) vals)) |
| 113 | (nreverse vals)))))) |
| 114 | |
| 115 | (defun open-tls-stream (name buffer host port) |
| 116 | "Open a TLS connection for a port to a host. |
| 117 | Returns a subprocess-object to represent the connection. |
| 118 | Input and output work as for subprocesses; `delete-process' closes it. |
| 119 | Args are NAME BUFFER HOST PORT. |
| 120 | NAME is name for process. It is modified if necessary to make it unique. |
| 121 | BUFFER is the buffer (or buffer-name) to associate with the process. |
| 122 | Process output goes at end of that buffer, unless you specify |
| 123 | an output stream or filter function to handle the output. |
| 124 | BUFFER may be also nil, meaning that this process is not associated |
| 125 | with any buffer |
| 126 | Third arg is name of the host to connect to, or its IP address. |
| 127 | Fourth arg PORT is an integer specifying a port to connect to." |
| 128 | (let ((cmds tls-program) cmd done) |
| 129 | (message "Opening TLS connection to `%s'..." host) |
| 130 | (while (and (not done) (setq cmd (pop cmds))) |
| 131 | (message "Opening TLS connection with `%s'..." cmd) |
| 132 | (let* ((process-connection-type tls-process-connection-type) |
| 133 | (process (start-process |
| 134 | name buffer shell-file-name shell-command-switch |
| 135 | (format-spec |
| 136 | cmd |
| 137 | (format-spec-make |
| 138 | ?h host |
| 139 | ?p (if (integerp port) |
| 140 | (int-to-string port) |
| 141 | port))))) |
| 142 | response) |
| 143 | (while (and process |
| 144 | (memq (process-status process) '(open run)) |
| 145 | (save-excursion |
| 146 | (set-buffer buffer) ;; XXX "blue moon" nntp.el bug |
| 147 | (goto-char (point-min)) |
| 148 | (not (setq done (re-search-forward tls-success nil t))))) |
| 149 | (accept-process-output process 1) |
| 150 | (sit-for 1)) |
| 151 | (message "Opening TLS connection with `%s'...%s" cmd |
| 152 | (if done "done" "failed")) |
| 153 | (if done |
| 154 | (setq done process) |
| 155 | (delete-process process)))) |
| 156 | (message "Opening TLS connection to `%s'...%s" |
| 157 | host (if done "done" "failed")) |
| 158 | done)) |
| 159 | |
| 160 | (provide 'tls) |
| 161 | |
| 162 | ;;; arch-tag: 5596d1c4-facc-4bc4-94a9-9863b928d7ac |
| 163 | ;;; tls.el ends here |