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

   1 ;;; starttls.el --- STARTTLS functions
   2
   3 ;; Copyright (C) 1999, 2000, 2001, 2002, 2003, 2004,
   4 ;;   2005, 2006, 2007, 2008, 2009, 2010 Free Software Foundation, Inc.
   5
   6 ;; Author: Daiki Ueno <ueno@unixuser.org>
   7 ;; Author: Simon Josefsson <simon@josefsson.org>
   8 ;; Created: 1999/11/20
   9 ;; Keywords: TLS, SSL, OpenSSL, GNUTLS, mail, news
  10
  11 ;; This file is part of GNU Emacs.
  12
  13 ;; GNU Emacs is free software: you can redistribute it and/or modify
  14 ;; it under the terms of the GNU General Public License as published by
  15 ;; the Free Software Foundation, either version 3 of the License, or
  16 ;; (at your option) any later version.
  17
  18 ;; GNU Emacs is distributed in the hope that it will be useful,
  19 ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
  20 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  21 ;; GNU General Public License for more details.
  22
  23 ;; You should have received a copy of the GNU General Public License
  24 ;; along with GNU Emacs.  If not, see <http://www.gnu.org/licenses/>.
  25
  26 ;;; Commentary:
  27
  28 ;; This module defines some utility functions for STARTTLS profiles.
  29
  30 ;; [RFC 2595] "Using TLS with IMAP, POP3 and ACAP"
  31 ;;      by Chris Newman <chris.newman@innosoft.com> (1999/06)
  32
  33 ;; This file now contains a combination of the two previous
  34 ;; implementations both called "starttls.el".  The first one is Daiki
  35 ;; Ueno's starttls.el which uses his own "starttls" command line tool,
  36 ;; and the second one is Simon Josefsson's starttls.el which uses
  37 ;; "gnutls-cli" from GNUTLS.
  38 ;;
  39 ;; If "starttls" is available, it is prefered by the code over
  40 ;; "gnutls-cli", for backwards compatibility.  Use
  41 ;; `starttls-use-gnutls' to toggle between implementations if you have
  42 ;; both tools installed.  It is recommended to use GNUTLS, though, as
  43 ;; it performs more verification of the certificates.
  44
  45 ;; The GNUTLS support requires GNUTLS 0.9.90 (released 2003-10-08) or
  46 ;; later, from <http://www.gnu.org/software/gnutls/>, or "starttls"
  47 ;; from <ftp://ftp.opaopa.org/pub/elisp/>.
  48
  49 ;; Usage is similar to `open-network-stream'.  For example:
  50 ;;
  51 ;; (when (setq tmp (starttls-open-stream
  52 ;;                      "test" (current-buffer) "yxa.extundo.com" 25))
  53 ;;   (accept-process-output tmp 15)
  54 ;;   (process-send-string tmp "STARTTLS\n")
  55 ;;   (accept-process-output tmp 15)
  56 ;;   (message "STARTTLS output:\n%s" (starttls-negotiate tmp))
  57 ;;   (process-send-string tmp "EHLO foo\n"))
  58
  59 ;; An example run yields the following output:
  60 ;;
  61 ;; 220 yxa.extundo.com ESMTP Sendmail 8.12.11/8.12.11/Debian-3; Wed, 26 May 2004 19:12:29 +0200; (No UCE/UBE) logging access from: c494102a.s-bi.bostream.se(OK)-c494102a.s-bi.bostream.se [217.215.27.65]
  62 ;; 220 2.0.0 Ready to start TLS
  63 ;; 250-yxa.extundo.com Hello c494102a.s-bi.bostream.se [217.215.27.65], pleased to meet you
  64 ;; 250-ENHANCEDSTATUSCODES
  65 ;; 250-PIPELINING
  66 ;; 250-EXPN
  67 ;; 250-VERB
  68 ;; 250-8BITMIME
  69 ;; 250-SIZE
  70 ;; 250-DSN
  71 ;; 250-ETRN
  72 ;; 250-AUTH DIGEST-MD5 CRAM-MD5 PLAIN LOGIN
  73 ;; 250-DELIVERBY
  74 ;; 250 HELP
  75 ;; nil
  76 ;;
  77 ;; With the message buffer containing:
  78 ;;
  79 ;; STARTTLS output:
  80 ;; *** Starting TLS handshake
  81 ;; - Server's trusted authorities:
  82 ;;    [0]: C=SE,ST=Stockholm,L=Stockholm,O=YXA,OU=CA,CN=yxa.extundo.com,EMAIL=staff@yxa.extundo.com
  83 ;; - Certificate type: X.509
  84 ;;  - Got a certificate list of 2 certificates.
  85 ;;
  86 ;;  - Certificate[0] info:
  87 ;;  # The hostname in the certificate matches 'yxa.extundo.com'.
  88 ;;  # valid since: Wed May 26 12:16:00 CEST 2004
  89 ;;  # expires at: Wed Jul 26 12:16:00 CEST 2023
  90 ;;  # serial number: 04
  91 ;;  # fingerprint: 7c 04 4b c1 fa 26 9b 5d 90 22 52 3c 65 3d 85 3a
  92 ;;  # version: #1
  93 ;;  # public key algorithm: RSA
  94 ;;  #   Modulus: 1024 bits
  95 ;;  # Subject's DN: C=SE,ST=Stockholm,L=Stockholm,O=YXA,OU=Mail server,CN=yxa.extundo.com,EMAIL=staff@yxa.extundo.com
  96 ;;  # Issuer's DN: C=SE,ST=Stockholm,L=Stockholm,O=YXA,OU=CA,CN=yxa.extundo.com,EMAIL=staff@yxa.extundo.com
  97 ;;
  98 ;;  - Certificate[1] info:
  99 ;;  # valid since: Sun May 23 11:35:00 CEST 2004
 100 ;;  # expires at: Sun Jul 23 11:35:00 CEST 2023
 101 ;;  # serial number: 00
 102 ;;  # fingerprint: fc 76 d8 63 1a c9 0b 3b fa 40 fe ed 47 7a 58 ae
 103 ;;  # version: #3
 104 ;;  # public key algorithm: RSA
 105 ;;  #   Modulus: 1024 bits
 106 ;;  # Subject's DN: C=SE,ST=Stockholm,L=Stockholm,O=YXA,OU=CA,CN=yxa.extundo.com,EMAIL=staff@yxa.extundo.com
 107 ;;  # Issuer's DN: C=SE,ST=Stockholm,L=Stockholm,O=YXA,OU=CA,CN=yxa.extundo.com,EMAIL=staff@yxa.extundo.com
 108 ;;
 109 ;; - Peer's certificate issuer is unknown
 110 ;; - Peer's certificate is NOT trusted
 111 ;; - Version: TLS 1.0
 112 ;; - Key Exchange: RSA
 113 ;; - Cipher: ARCFOUR 128
 114 ;; - MAC: SHA
 115 ;; - Compression: NULL
 116
 117 ;;; Code:
 118
 119 (defgroup starttls nil
 120   "Support for `Transport Layer Security' protocol."
 121   :version "21.1"
 122   :group 'mail)
 123
 124 (defcustom starttls-gnutls-program "gnutls-cli"
 125   "Name of GNUTLS command line tool.
 126 This program is used when GNUTLS is used, i.e. when
 127 `starttls-use-gnutls' is non-nil."
 128   :version "22.1"
 129   :type 'string
 130   :group 'starttls)
 131
 132 (defcustom starttls-program "starttls"
 133   "The program to run in a subprocess to open an TLSv1 connection.
 134 This program is used when the `starttls' command is used,
 135 i.e. when `starttls-use-gnutls' is nil."
 136   :type 'string
 137   :group 'starttls)
 138
 139 (defcustom starttls-use-gnutls (not (executable-find starttls-program))
 140   "*Whether to use GNUTLS instead of the `starttls' command."
 141   :version "22.1"
 142   :type 'boolean
 143   :group 'starttls)
 144
 145 (defcustom starttls-extra-args nil
 146   "Extra arguments to `starttls-program'.
 147 These apply when the `starttls' command is used, i.e. when
 148 `starttls-use-gnutls' is nil."
 149   :type '(repeat string)
 150   :group 'starttls)
 151
 152 (defcustom starttls-extra-arguments nil
 153   "Extra arguments to `starttls-program'.
 154 These apply when GNUTLS is used, i.e. when `starttls-use-gnutls' is non-nil.
 155
 156 For example, non-TLS compliant servers may require
 157 '(\"--protocols\" \"ssl3\").  Invoke \"gnutls-cli --help\" to
 158 find out which parameters are available."
 159   :version "22.1"
 160   :type '(repeat string)
 161   :group 'starttls)
 162
 163 (defcustom starttls-process-connection-type nil
 164   "*Value for `process-connection-type' to use when starting STARTTLS process."
 165   :version "22.1"
 166   :type 'boolean
 167   :group 'starttls)
 168
 169 (defcustom starttls-connect "- Simple Client Mode:\n\n"
 170   "*Regular expression indicating successful connection.
 171 The default is what GNUTLS's \"gnutls-cli\" outputs."
 172   ;; GNUTLS cli.c:main() prints this string when it is starting to run
 173   ;; in the application read/write phase.  If the logic, or the string
 174   ;; itself, is modified, this must be updated.
 175   :version "22.1"
 176   :type 'regexp
 177   :group 'starttls)
 178
 179 (defcustom starttls-failure "\\*\\*\\* Handshake has failed"
 180   "*Regular expression indicating failed TLS handshake.
 181 The default is what GNUTLS's \"gnutls-cli\" outputs."
 182   ;; GNUTLS cli.c:do_handshake() prints this string on failure.  If the
 183   ;; logic, or the string itself, is modified, this must be updated.
 184   :version "22.1"
 185   :type 'regexp
 186   :group 'starttls)
 187
 188 (defcustom starttls-success "- Compression: "
 189   "*Regular expression indicating completed TLS handshakes.
 190 The default is what GNUTLS's \"gnutls-cli\" outputs."
 191   ;; GNUTLS cli.c:do_handshake() calls, on success,
 192   ;; common.c:print_info(), that unconditionally print this string
 193   ;; last.  If that logic, or the string itself, is modified, this
 194   ;; must be updated.
 195   :version "22.1"
 196   :type 'regexp
 197   :group 'starttls)
 198
 199 (defun starttls-negotiate-gnutls (process)
 200   "Negotiate TLS on PROCESS opened by `open-starttls-stream'.
 201 This should typically only be done once.  It typically returns a
 202 multi-line informational message with information about the
 203 handshake, or nil on failure."
 204   (let (buffer info old-max done-ok done-bad)
 205     (if (null (setq buffer (process-buffer process)))
 206         ;; XXX How to remove/extract the TLS negotiation junk?
 207         (signal-process (process-id process) 'SIGALRM)
 208       (with-current-buffer buffer
 209         (save-excursion
 210           (setq old-max (goto-char (point-max)))
 211           (signal-process (process-id process) 'SIGALRM)
 212           (while (and (processp process)
 213                       (eq (process-status process) 'run)
 214                       (save-excursion