diff options
Diffstat (limited to '')
| -rw-r--r-- | emacs.d/lisp/rudel/rudel-tls.el | 201 |
1 files changed, 201 insertions, 0 deletions
diff --git a/emacs.d/lisp/rudel/rudel-tls.el b/emacs.d/lisp/rudel/rudel-tls.el new file mode 100644 index 0000000..a770851 --- /dev/null +++ b/emacs.d/lisp/rudel/rudel-tls.el @@ -0,0 +1,201 @@ +;;; rudel-tls.el --- Start TLS protocol. +;; +;; Copyright (C) 2008, 2009 Jan Moringen +;; +;; Author: Jan Moringen <scymtym@users.sourceforge.net> +;; Keywords: Rudel, TLS, encryption, starttls, gnutls +;; X-RCS: $Id:$ +;; +;; This file is part of Rudel. +;; +;; Rudel is free software: you can redistribute it and/or modify it +;; under the terms of the GNU General Public License as published by +;; the Free Software Foundation, either version 3 of the License, or +;; (at your option) any later version. +;; +;; Rudel is distributed in the hope that it will be useful, but +;; WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU +;; General Public License for more details. +;; +;; You should have received a copy of the GNU General Public License +;; along with rudel. If not, see <http://www.gnu.org/licenses>. + + +;;; Commentary: +;; +;; This contains a simple implementation of the so calls Start TLS +;; protocol, which means enabling TLS encryption for an existing +;; network connection. + + +;;; History: +;; +;; 0.1 - Initial revision. + + +;;; Code: +;; + +(require 'format-spec) + +(require 'rudel) +(require 'rudel-util) + + +;;; Customization +;; + +(defcustom rudel-tls-client-program + "gnutls-cli" + "The gnutls client program to use for encrypted connections." + :group 'rudel + :type 'file) + +(defcustom rudel-tls-client-arguments + "--starttls --kx ANON_DH --port %p %h" + "Arguments passed to the gnutls client program." + :group 'rudel + :type 'string) + + +;;; TLS functions +;; + +(defun rudel-tls-make-process (&rest args) + "Make a network process with keyword arguments ARGS. +This function works similar to `make-network-process'. Supported +keyword arguments are :name (ignore), :host, :port, :filter +and :sentinel. The returned process object is suitable for +start-TLS. Once the enclosing protocol indicates TLS encryption +should start, `rudel-tls-start-tls' can be called to enabled TLS +for the network connection." + (let* ((host (plist-get args :host)) ;; TODO clumsy + (port (plist-get args :service)) + (filter (plist-get args :filter)) + (sentinel (plist-get args :sentinel)) + ;; Compile the command to start the TLS binary. + (arguments (format-spec rudel-tls-client-arguments + (format-spec-make + ?h host + ?p (number-to-string port)))) + ;; Start the TLS program. + (process (apply #'start-process + (format "*tls-%s*" host) nil + rudel-tls-client-program + (split-string arguments " ")))) + + ;; Store filter function and attach proxy filter to handle TLS + ;; handshake. + (when filter + (rudel-set-process-object process filter :old-filter)) + (set-process-filter process #'rudel-tls-wait-init) + + ;; Attach sentinel function. + (when sentinel + (set-process-sentinel process sentinel)) + + ;; Mark the process as supporting TLS encryption + (rudel-set-process-object process t :supports-tls) + + process) + ) + +(defun rudel-tls-start-tls (process) + "Enable TLS encryption for the network connection PROCESS. +This only works if PROCESS has been created by +`rudel-tls-make-process'." + ;; Save current filter function. + (rudel-set-process-object + process (process-filter process) :old-filter) + ;; Install TLS handshake filter function and signal program to start + ;; TLS handshake. + (message "tls-start-tls: switching to \"handshake\" filter") + (set-process-filter process #'rudel-tls-wait-handshake) + (signal-process process 'sigalrm) + ) + +(defun rudel-tls-wait-init (process data) + "Is installed as process filter on PROCESS until gnutls is done printing messages." + ;; Retrieve complete lines. + (let ((buffer (rudel-process-object process :buffer))) + (rudel-assemble-line-fragments data buffer) + (rudel-set-process-object process buffer :buffer)) + + (let ((client-data) + (old-filter (rudel-process-object process :old-filter)) + (client-mode)) + + ;; Assemble lines that were not generated by gnutls. It is very + ;; brittle to wait for last line of gnutls output like, but it + ;; cannot be helped. + (rudel-loop-lines data line + (if client-mode + (setq client-data (concat client-data line "\n")) + (when (string-match-p "- Simple Client Mode.*" line) + (setq client-mode t)))) + + ;; When there are any lines not generated by gnutls, + ;; initialization is over. Process the data and install the old + ;; filter function. + (when client-data + (funcall old-filter process client-data)) + (when client-mode + (message "tls-wait-init: switching back to old filter") + (set-process-filter process old-filter))) + ) + +(defun rudel-tls-wait-handshake (process data) + "Is installed as process filter on PROCESS while gnutls is doing the TLS handshake." + ;; Retrieve complete lines. + (let ((buffer (rudel-process-object process :buffer))) + (rudel-assemble-line-fragments data buffer) + (rudel-set-process-object process buffer :buffer)) + + (let ((client-data) + (old-filter (rudel-process-object process :old-filter)) + (client-mode)) + + ;; Assemble lines that were not generated by gnutls. It is very + ;; brittle to wait for last line of gnutls output like, but it + ;; cannot be helped. + (rudel-loop-lines data line + (if client-mode + (setq client-data (concat client-data line "\n")) + (when (string-match-p "- Compression.*" line) + (setq client-mode t)))) + + ;; When there are any lines not generated by gnutls, handshake is + ;; over. Process the data and install `established' filter + ;; function. + (when client-data + (funcall old-filter process client-data)) + (when client-mode + (message "tls-wait-handshake: switching to \"established\" filter") + (set-process-filter process #'rudel-tls-established) + (rudel-set-process-object process t :encryption))) + ) + +(defun rudel-tls-established (process data) + "Is installed as process filter on PROCESS after gnutls has established TLS encryption." + ;; Retrieve complete lines. + (let ((buffer (rudel-process-object process :buffer))) + (rudel-assemble-line-fragments data buffer) + (rudel-set-process-object process buffer :buffer)) + + (let ((client-data) + (old-filter (rudel-process-object process :old-filter))) + + ;; Assemble lines that were not generated by gnutls. + (rudel-loop-lines data line + (unless (string-match-p "- Peer has closed the GNUTLS connection" line) + (setq client-data (concat client-data line "\n")))) + + ;; When there are any lines not generated by gnutls, pass those to + ;; the old filter function. + (when client-data + (funcall old-filter process client-data))) + ) + +(provide 'rudel-tls) +;;; rudel-tls.el ends here |