From: yamaoka Date: Sat, 20 Sep 2003 13:37:28 +0000 (+0000) Subject: Synch to Gnus 20030920123. X-Git-Url: http://git.chise.org/gitweb/?a=commitdiff_plain;h=d887af4abff4cb8d72622be544d901cc43b13b65;p=elisp%2Fgnus.git- Synch to Gnus 20030920123. --- diff --git a/contrib/starttls.el b/contrib/starttls.el new file mode 100644 index 0000000..f7562aa --- /dev/null +++ b/contrib/starttls.el @@ -0,0 +1,226 @@ +;;; starttls.el --- STARTTLS support via wrapper around GNU TLS + +;; Copyright (C) 2003 Free Software Foundation, Inc. + +;; Author: Simon Josefsson +;; Keywords: comm, tls, gnutls, ssl + +;; This file is part of GNU Emacs. + +;; GNU Emacs 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 2, or (at your option) +;; any later version. + +;; GNU Emacs 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 GNU Emacs; see the file COPYING. If not, write to the +;; Free Software Foundation, Inc., 59 Temple Place - Suite 330, +;; Boston, MA 02111-1307, USA. + +;;; Commentary: + +;; This package implements a simple wrapper around the GNU TLS command +;; line application "gnutls-cli" to make Emacs support STARTTLS. +;; +;; Usage is similar to `open-network-stream', i.e.: +;; +;; (setq tmp (open-starttls-stream "test" (current-buffer) "cyrus.andrew.cmu.edu" 143)) +;; #> +;; (process-send-string tmp ". starttls\n") +;; nil +;; (negotiate-starttls tmp) +;; "*** Starting TLS handshake +;; - Certificate type: X.509 +;; - Certificate info: +;; # Certificate is valid since: Thu Jun 26 19:00:00 CEST 2003 +;; # Certificate expires: Sat Jun 26 19:00:00 CEST 2004 +;; # Certificate fingerprint: 8d 59 d6 e1 c9 91 dc 5a bb 38 47 8c ec 85 1b 99 +;; # Certificate serial number: 3e fb 52 ce +;; # Certificate version: #3 +;; # Certificate public key algorithm: RSA +;; # Modulus: 1024 bits +;; # CN=cyrus.andrew.cmu.edu,OU=Computing Services,O=Carnegie Mellon University,L=Pittsburgh,ST=Pennsylvania,C=US +;; # Certificate Issuer's info: +;; # CN=CMU CA mail 1,OU=Computing Services,O=Carnegie Mellon University,L=Pittsburgh,ST=Pennsylvania,C=US +;; +;; - Peer's certificate is NOT trusted +;; - Version: TLS 1.0 +;; - Key Exchange: RSA +;; - Cipher: ARCFOUR 128 +;; - MAC: SHA +;; - Compression: NULL +;; " +;; (process-send-string tmp ". capability\n") +;; nil +;; (process-send-string tmp ". logout\n") +;; nil +;; +;; Resolving 'cyrus.andrew.cmu.edu'... +;; Connecting to '128.2.10.174:143'... +;; +;; - Simple Client Mode: +;; +;; * OK mail-fe4.andrew.cmu.edu Cyrus IMAP4 Murder v2.1.15-077 server ready +;; . OK Begin TLS negotiation now +;; * CAPABILITY IMAP4 IMAP4rev1 ACL QUOTA LITERAL+ MAILBOX-REFERRALS NAMESPACE UIDPLUS ID NO_ATOMIC_RENAME UNSELECT CHILDREN MULTIAPPEND SORT THREAD=ORDEREDSUBJECT THREAD=REFERENCES AUTH=PLAIN AUTH=KERBEROS_V4 AUTH=GSSAPI AUTH=ANONYMOUS ANNOTATEMORE +;; . OK Completed +;; * BYE LOGOUT received +;; . OK Completed +;; *** Received corrupted data(-9) - server has terminated the connection abnormally +;; +;; Process test<9> finished + +;;; Code: + +(eval-and-compile + (autoload 'format-spec "format-spec") + (autoload 'format-spec-make "format-spec")) + +(defgroup starttls nil + "Negotiated Transport Layer Security (STARTTLS) parameters." + :group 'comm) + +(defcustom starttls-programs '("gnutls-cli -s -p %p %h" + "gnutls-cli -s -p %p %h --protocols ssl3") + "List of strings containing commands to open STARTTLS stream to a host. +Each entry in the list is tried until a connection is successful. +%s is replaced with server hostname, %p with port to connect to. +The program should read input on stdin and write output to +stdout. Also see `starttls-connect' and `starttls-success' for +what the program should output after initial connection and +successful negotiation respectively." + :type '(repeat string) + :group 'starttls) + +(defcustom starttls-process-connection-type t + "*Value for `process-connection-type' to use when starting STARTTLS process. +Note that setting this to nil likely does not work, as +`process-send-eof' used in `negotiate-starttls' behave +differently depending on this setting, and it closes the +sub-process if this variable is set to nil." + :type 'boolean + :group 'starttls) + +(defcustom starttls-connect "- Simple Client Mode:" + "*Regular expression indicating successful connection. +The default is what GNUTLS's \"gnutls-cli\" outputs." + ;; cli.c:main() print this string when it is starting to run in the + ;; application read/write phase. If the logic, or the string + ;; itself, is modified, this have to be updated. + :type 'regexp + :group 'starttls) + +(defcustom starttls-failure "*** Handshake has failed" + "*Regular expression indicating failed TLS handshake. +The default is what GNUTLS's \"gnutls-cli\" outputs." + ;; cli.c:do_handshake() print this string on failure. If the logic, + ;; or the string itself, is modified, this have to be updated. + :type 'regexp + :group 'starttls) + +(defcustom starttls-success "- Compression: " + "*Regular expression indicating completed TLS handshakes. +The default is what GNUTLS's \"gnutls-cli\" outputs." + ;; cli.c:do_handshake() calls, on success, common.c:print_info(), + ;; that unconditionally print this string last. If that logic, or + ;; the string itself, is modified, this have to be updated. + :type 'regexp + :group 'starttls) + +(defun negotiate-starttls (process) + "Negotiate TLS on process opened by `open-starttls-stream'. +This should typically only be done once. It typically return a +multi-line informational message with information about the +handshake, or NIL on failure." + (let (buffer response old-max done-ok done-bad) + (if (null (setq buffer (process-buffer process))) + ;; XXX how to remove/extract the TLS negotiation junk? + (process-send-eof process) + (with-current-buffer buffer + (save-excursion + (goto-char (point-max)) + (setq old-max (point)) + ;; `process-send-eof' closes sub-process unless we force + ;; `process-connection-type' to non-nil. A cleaner solution + ;; would be to use: + ;; (process-send-string process (string-as-unibyte (format "%c" 4))) + ;; or something, but I could not get that to work. + (process-send-eof process) + (while (and process + (memq (process-status process) '(open run)) + (save-excursion + (set-buffer buffer) ;; XXX "blue moon" nntp.el bug + (goto-char old-max) + (progn + (setq + done-ok (re-search-forward starttls-success nil t) + done-bad (re-search-forward starttls-failure nil t)) + (not (or done-ok done-bad))))) + (accept-process-output process 1 100) + (sit-for 0.1)) + (setq info (buffer-substring-no-properties old-max (point-max))) + (delete-region old-max (point-max)) + (if (or (and done-ok (not done-bad)) + ;; prevent mitm that fake success msg after failure msg. + (and done-ok done-bad (< done-ok done-bad))) + info)))))) + +(defun open-starttls-stream (name buffer host service) + "Open a TLS connection for a service to a host. +Returns a subprocess-object to represent the connection. +Input and output work as for subprocesses; `delete-process' closes it. +Args are NAME BUFFER HOST SERVICE. +NAME is name for process. It is modified if necessary to make it unique. +BUFFER is the buffer (or buffer-name) to associate with the process. + Process output goes at end of that buffer, unless you specify + an output stream or filter function to handle the output. + BUFFER may be also nil, meaning that this process is not associated + with any buffer +Third arg is name of the host to connect to, or its IP address. +Fourth arg SERVICE is name of the service desired, or an integer +specifying a port number to connect to." + (let ((cmds starttls-programs) cmd done) + (message "Opening STARTTLS connection to `%s'..." host) + (while (and (not done) (setq cmd (pop cmds))) + (message "Opening STARTTLS connection with `%s'..." cmd) + (let* ((process-connection-type starttls-process-connection-type) + (process (start-process + name buffer shell-file-name shell-command-switch + (format-spec + cmd + (format-spec-make + ?h host + ?p (if (integerp service) + (int-to-string service) + service))))) + response) + (while (and process + (memq (process-status process) '(open run)) + (save-excursion + (set-buffer buffer) ;; XXX "blue moon" nntp.el bug + (goto-char (point-min)) + (not (setq done (re-search-forward + starttls-connect nil t))))) + (accept-process-output process 0 100) + (sit-for 0.1)) + (message "Opening STARTTLS connection with `%s'...%s" cmd + (if done "done" "failed")) + (if done + (setq done process) + (delete-process process)))) + (message "Opening STARTTLS connection to `%s'...%s" + host (if done "done" "failed")) + done)) + +;; Compatibility with starttls.el by Daiki Ueno : +(defalias 'starttls-open-stream 'open-starttls-stream) +(defalias 'starttls-negotiate 'negotiate-starttls) + +(provide 'starttls) + +;;; starttls.el ends here