cgit.sxemacs.org Git - gnus/blob - contrib/starttls.el

   1 ;;; starttls.el --- STARTTLS support via wrapper around GNU TLS
   2
   3 ;; Copyright (C) 2003, 2004 Free Software Foundation, Inc.
   4
   5 ;; Author: Simon Josefsson <simon@josefsson.org>
   6 ;; Keywords: comm, tls, gnutls, ssl
   7
   8 ;; This file is part of GNU Emacs.
   9
  10 ;; GNU Emacs is free software; you can redistribute it and/or modify
  11 ;; it under the terms of the GNU General Public License as published by
  12 ;; the Free Software Foundation; either version 2, or (at your option)
  13 ;; any later version.
  14
  15 ;; GNU Emacs is distributed in the hope that it will be useful,
  16 ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
  17 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  18 ;; GNU General Public License for more details.
  19
  20 ;; You should have received a copy of the GNU General Public License
  21 ;; along with GNU Emacs; see the file COPYING.  If not, write to the
  22 ;; Free Software Foundation, Inc., 59 Temple Place - Suite 330,
  23 ;; Boston, MA 02111-1307, USA.
  24
  25 ;;; Commentary:
  26
  27 ;; This package implements a simple wrapper around the GNU TLS command
  28 ;; line application "gnutls-cli" to make Emacs support STARTTLS.  It
  29 ;; is backwards compatible (same API functions) with the "starttls.el"
  30 ;; that is part of Emacs 21 written by Daiki Ueno <ueno@unixuser.org>.
  31 ;; (That version used an external program "starttls" that isn't widely
  32 ;; installed, and was based on OpenSSL.)
  33
  34 ;; This package require GNUTLS 0.9.90 (released 2003-10-08) or later.
  35
  36 ;; Usage is similar to `open-network-stream'.  Evaluating the following:
  37 ;;
  38 ;; (progn
  39 ;;   (setq tmp (open-starttls-stream "test" (current-buffer) "mail.example.com" 143))
  40 ;;   (process-send-string tmp ". starttls\n")
  41 ;;   (sit-for 4)
  42 ;;   (message "STARTTLS output:\n%s" (negotiate-starttls tmp))
  43 ;;   (process-send-string tmp ". capability\n"))
  44 ;;
  45 ;; in, e.g., the *scratch* buffer, yields the following output:
  46 ;;
  47 ;; * OK imap.example.com Cyrus IMAP4 v2.1.15 server ready\r
  48 ;; . OK Begin TLS negotiation now\r
  49 ;; * CAPABILITY IMAP4 IMAP4rev1 ACL QUOTA ...
  50 ;; . OK Completed\r
  51 ;; nil
  52 ;;
  53 ;; And the message buffer contains:
  54 ;;
  55 ;; STARTTLS output:
  56 ;; *** Starting TLS handshake
  57 ;; - Server's trusted authorities:
  58 ;;    [0]: O=Sendmail,OU=Sendmail Server,CN=imap.example.com,EMAIL=admin@imap.example.com
  59 ;; - Certificate type: X.509
  60 ;;  - Got a certificate list of 1 certificates.
  61 ;;
  62 ;;  - Certificate[0] info:
  63 ;;  # The hostname in the certificate matches 'imap.example.com'.
  64 ;;  # valid since: Wed Aug 28 12:47:00 CEST 2002
  65 ;;  # expires at: Thu Aug 28 12:47:00 CEST 2003
  66 ;;  # serial number: 00
  67 ;;  # fingerprint: 06 3f 25 cb 44 aa 5c 1e 79 d7 63 86 f8 b1 9a cf
  68 ;;  # version: #3
  69 ;;  # public key algorithm: RSA
  70 ;;  #   Modulus: 1024 bits
  71 ;;  # Subject's DN: O=Sendmail,OU=Sendmail Server,CN=imap.example.com,EMAIL=admin@imap.example.com
  72 ;;  # Issuer's DN: O=Sendmail,OU=Sendmail Server,CN=imap.example.com,EMAIL=admin@imap.example.com
  73 ;;
  74 ;;
  75 ;; - Peer's certificate issuer is unknown
  76 ;; - Peer's certificate is NOT trusted
  77 ;; - Version: TLS 1.0
  78 ;; - Key Exchange: RSA
  79 ;; - Cipher: ARCFOUR 128
  80 ;; - MAC: SHA
  81 ;; - Compression: NULL
  82
  83 ;; Revision history:
  84 ;;
  85 ;; 2003-09-20: Added to Gnus CVS.
  86 ;; 2003-10-02: Minor fixes.
  87 ;; 2003-11-15: Cleanup, and posted to gnu.emacs.sources.
  88 ;; 2003-11-28: Fixes variable name conflicts, various other fixes, posted g.e.s.
  89
  90 ;;; Code:
  91
  92 (defgroup starttls nil
  93   "Negotiated Transport Layer Security (STARTTLS) parameters."
  94   :group 'comm)
  95
  96 (defcustom starttls-file-name "gnutls-cli"
  97   "Name of the program to run in a subprocess to open an STARTTLS connection.
  98 The program should read input on stdin, write output to stdout,
  99 and initiate TLS negotiation when receiving the SIGALRM signal.
 100 Also see `starttls-connect', `starttls-failure', and
 101 `starttls-success' for what the program should output after
 102 initial connection and successful negotiation respectively."
 103   :type 'string
 104   :group 'starttls)
 105
 106 (defcustom starttls-extra-arguments nil
 107   "List of extra arguments to `starttls-file-name'.
 108 E.g., (\"--protocols\" \"ssl3\")."
 109   :type '(repeat string)
 110   :group 'starttls)
 111
 112 (defcustom starttls-process-connection-type nil
 113   "*Value for `process-connection-type' to use when starting STARTTLS process."
 114   :type 'boolean
 115   :group 'starttls)
 116
 117 (defcustom starttls-connect "- Simple Client Mode:\n\n"
 118   "*Regular expression indicating successful connection.
 119 The default is what GNUTLS's \"gnutls-cli\" outputs."
 120   ;; GNUTLS cli.c:main() print this string when it is starting to run
 121   ;; in the application read/write phase.  If the logic, or the string
 122   ;; itself, is modified, this must be updated.
 123   :type 'regexp
 124   :group 'starttls)
 125
 126 (defcustom starttls-failure "\\*\\*\\* Handshake has failed"
 127   "*Regular expression indicating failed TLS handshake.
 128 The default is what GNUTLS's \"gnutls-cli\" outputs."
 129   ;; GNUTLS cli.c:do_handshake() print this string on failure.  If the
 130   ;; logic, or the string itself, is modified, this must be updated.
 131   :type 'regexp
 132   :group 'starttls)
 133
 134 (defcustom starttls-success "- Compression: "
 135   "*Regular expression indicating completed TLS handshakes.
 136 The default is what GNUTLS's \"gnutls-cli\" outputs."
 137   ;; GNUTLS cli.c:do_handshake() calls, on success,
 138   ;; common.c:print_info(), that unconditionally print this string
 139   ;; last.  If that logic, or the string itself, is modified, this
 140   ;; must be updated.
 141   :type 'regexp
 142   :group 'starttls)
 143
 144 (defun negotiate-starttls (process)
 145   "Negotiate TLS on process opened by `open-starttls-stream'.
 146 This should typically only be done once.  It typically return a
 147 multi-line informational message with information about the
 148 handshake, or NIL on failure."
 149   (let (buffer info old-max done-ok done-bad)
 150     (if (null (setq buffer (process-buffer process)))
 151         ;; XXX How to remove/extract the TLS negotiation junk?
 152         (signal-process (process-id process) 'SIGALRM)
 153       (with-current-buffer buffer
 154         (save-excursion
 155           (setq old-max (goto-char (point-max)))
 156           (signal-process (process-id process) 'SIGALRM)
 157           (while (and (processp process)
 158                       (eq (process-status process) 'run)
 159                       (save-excursion
 160                         (goto-char old-max)
 161                         (not (or (setq done-ok (re-search-forward
 162                                                 starttls-success nil t))
 163                                  (setq done-bad (re-search-forward
 164                                                  starttls-failure nil t))))))
 165             (accept-process-output process 1 100)
 166             (sit-for 0.1))
 167           (setq info (buffer-substring-no-properties old-max (point-max)))
 168           (delete-region old-max (point-max))
 169           (if (or (and done-ok (not done-bad))
 170                   ;; Prevent mitm that fake success msg after failure msg.
 171                   (and done-ok done-bad (< done-ok done-bad)))
 172               info
 173             (message "STARTTLS negotiation failed: %s" info)
 174             nil))))))
 175
 176 (defun open-starttls-stream (name buffer host service)
 177   "Open a TLS connection for a service to a host.
 178 Returns a subprocess-object to represent the connection.
 179 Input and output work as for subprocesses; `delete-process' closes it.
 180 Args are NAME BUFFER HOST SERVICE.
 181 NAME is name for process.  It is modified if necessary to make it unique.
 182 BUFFER is the buffer (or buffer-name) to associate with the process.
 183  Process output goes at end of that buffer, unless you specify
 184  an output stream or filter function to handle the output.
 185 Third arg is name of the host to connect to, or its IP address.
 186 Fourth arg SERVICE is name of the service desired, or an integer
 187 specifying a port number to connect to."
 188   (message "Opening STARTTLS connection to `%s'..." host)
 189   (let* (done
 190          (old-max (with-current-buffer buffer (point-max)))
 191          (process-connection-type starttls-process-connection-type)
 192          (process (apply #'start-process name buffer
 193                          starttls-file-name "-s" host
 194                          "-p" (if (integerp service)
 195                                   (int-to-string service)
 196                                 service)
 197                          starttls-extra-arguments)))
 198     (process-kill-without-query process)
 199     (while (and (processp process)
 200                 (eq (process-status process) 'run)
 201                 (save-excursion
 202                   (set-buffer buffer)
 203                   (goto-char old-max)
 204                   (not (setq done (re-search-forward
 205                                    starttls-connect nil t)))))
 206       (accept-process-output process 0 100)
 207       (sit-for 0.1))
 208     (if done
 209         (with-current-buffer buffer
 210           (delete-region old-max done))
 211       (delete-process process)
 212       (setq process nil))
 213     (message "Opening STARTTLS connection to `%s'...%s"
 214              host (if done "done" "failed"))
 215     process))
 216
 217 ;; Compatibility with starttls.el by Daiki Ueno <ueno@unixuser.org>:
 218 (defvaralias 'starttls-program 'starttls-file-name)
 219 (make-obsolete-variable 'starttls-program 'starttls-file-name)
 220 (defvaralias 'starttls-extra-args 'starttls-extra-arguments)
 221 (make-obsolete-variable 'starttls-extra-args 'starttls-extra-arguments)
 222 (defalias 'starttls-open-stream 'open-starttls-stream)
 223 (defalias 'starttls-negotiate 'negotiate-starttls)
 224
 225 (provide 'starttls)
 226
 227 ;;; arch-tag: 1955b2ca-0cb2-47ad-bb95-47b43e5a15f5
 228 ;;; starttls.el ends here