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

   1 ;;; starttls.el --- STARTTLS functions
   2
   3 ;; Copyright (C) 1999, 2000, 2003, 2004, 2005
   4 ;;        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 2, or (at your option)
  16 ;; 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; see the file COPYING.  If not, write to the
  25 ;; Free Software Foundation, Inc., 59 Temple Place - Suite 330,
  26 ;; Boston, MA 02111-1307, USA.
  27
  28 ;;; Commentary:
  29
  30 ;; This module defines some utility functions for STARTTLS profiles.
  31
  32 ;; [RFC 2595] "Using TLS with IMAP, POP3 and ACAP"
  33 ;;      by Chris Newman <chris.newman@innosoft.com> (1999/06)
  34
  35 ;; This file now contain a combination of the two previous
  36 ;; implementations both called "starttls.el".  The first one is Daiki
  37 ;; Ueno's starttls.el which uses his own "starttls" command line tool,
  38 ;; and the second one is Simon Josefsson's starttls.el which uses
  39 ;; "gnutls-cli" from GNUTLS.
  40 ;;
  41 ;; If "starttls" is available, it is prefered by the code over
  42 ;; "gnutls-cli", for backwards compatibility.  Use
  43 ;; `starttls-use-gnutls' to toggle between implementations if you have
  44 ;; both tools installed.  It is recommended to use GNUTLS, though, as
  45 ;; it performs more verification of the certificates.
  46
  47 ;; The GNUTLS support require GNUTLS 0.9.90 (released 2003-10-08) or
  48 ;; later, from <http://www.gnu.org/software/gnutls/>, or "starttls"
  49 ;; from <ftp://ftp.opaopa.org/pub/elisp/>.
  50
  51 ;; Usage is similar to `open-network-stream'.  For example:
  52 ;;
  53 ;; (when (setq tmp (starttls-open-stream
  54 ;;                      "test" (current-buffer) "yxa.extundo.com" 25))
  55 ;;   (accept-process-output tmp 15)
  56 ;;   (process-send-string tmp "STARTTLS\n")
  57 ;;   (accept-process-output tmp 15)
  58 ;;   (message "STARTTLS output:\n%s" (starttls-negotiate tmp))
  59 ;;   (process-send-string tmp "EHLO foo\n"))
  60
  61 ;; An example run yield the following output:
  62 ;;
  63 ;; 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]
  64 ;; 220 2.0.0 Ready to start TLS
  65 ;; 250-yxa.extundo.com Hello c494102a.s-bi.bostream.se [217.215.27.65], pleased to meet you
  66 ;; 250-ENHANCEDSTATUSCODES
  67 ;; 250-PIPELINING
  68 ;; 250-EXPN
  69 ;; 250-VERB
  70 ;; 250-8BITMIME
  71 ;; 250-SIZE
  72 ;; 250-DSN
  73 ;; 250-ETRN
  74 ;; 250-AUTH DIGEST-MD5 CRAM-MD5 PLAIN LOGIN
  75 ;; 250-DELIVERBY
  76 ;; 250 HELP
  77 ;; nil
  78 ;;
  79 ;; With the message buffer containing:
  80 ;;
  81 ;; STARTTLS output:
  82 ;; *** Starting TLS handshake
  83 ;; - Server's trusted authorities:
  84 ;;    [0]: C=SE,ST=Stockholm,L=Stockholm,O=YXA,OU=CA,CN=yxa.extundo.com,EMAIL=staff@yxa.extundo.com
  85 ;; - Certificate type: X.509
  86 ;;  - Got a certificate list of 2 certificates.
  87 ;;
  88 ;;  - Certificate[0] info:
  89 ;;  # The hostname in the certificate matches 'yxa.extundo.com'.
  90 ;;  # valid since: Wed May 26 12:16:00 CEST 2004
  91 ;;  # expires at: Wed Jul 26 12:16:00 CEST 2023
  92 ;;  # serial number: 04
  93 ;;  # fingerprint: 7c 04 4b c1 fa 26 9b 5d 90 22 52 3c 65 3d 85 3a
  94 ;;  # version: #1
  95 ;;  # public key algorithm: RSA
  96 ;;  #   Modulus: 1024 bits
  97 ;;  # Subject's DN: C=SE,ST=Stockholm,L=Stockholm,O=YXA,OU=Mail server,CN=yxa.extundo.com,EMAIL=staff@yxa.extundo.com
  98 ;;  # Issuer's DN: C=SE,ST=Stockholm,L=Stockholm,O=YXA,OU=CA,CN=yxa.extundo.com,EMAIL=staff@yxa.extundo.com
  99 ;;
 100 ;;  - Certificate[1] info:
 101 ;;  # valid since: Sun May 23 11:35:00 CEST 2004
 102 ;;  # expires at: Sun Jul 23 11:35:00 CEST 2023
 103 ;;  # serial number: 00
 104 ;;  # fingerprint: fc 76 d8 63 1a c9 0b 3b fa 40 fe ed 47 7a 58 ae
 105 ;;  # version: #3
 106 ;;  # public key algorithm: RSA
 107 ;;  #   Modulus: 1024 bits
 108 ;;  # Subject's DN: C=SE,ST=Stockholm,L=Stockholm,O=YXA,OU=CA,CN=yxa.extundo.com,EMAIL=staff@yxa.extundo.com
 109 ;;  # Issuer's DN: C=SE,ST=Stockholm,L=Stockholm,O=YXA,OU=CA,CN=yxa.extundo.com,EMAIL=staff@yxa.extundo.com
 110 ;;
 111 ;; - Peer's certificate issuer is unknown
 112 ;; - Peer's certificate is NOT trusted
 113 ;; - Version: TLS 1.0
 114 ;; - Key Exchange: RSA
 115 ;; - Cipher: ARCFOUR 128
 116 ;; - MAC: SHA
 117 ;; - Compression: NULL
 118
 119 ;;; Code:
 120
 121 (defgroup starttls nil
 122   "Support for `Transport Layer Security' protocol."
 123   :version "21.1"
 124   :group 'mail)
 125
 126 (defcustom starttls-gnutls-program "gnutls-cli"
 127   "Name of GNUTLS command line tool.
 128 This program is used when GNUTLS is used, i.e. when
 129 `starttls-use-gnutls' is non-nil."
 130   :version "22.1"
 131   :type 'string
 132   :group 'starttls)
 133
 134 (defcustom starttls-program "starttls"
 135   "The program to run in a subprocess to open an TLSv1 connection.
 136 This program is used when the `starttls' command is used,
 137 i.e. when `starttls-use-gnutls' is nil."
 138   :type 'string
 139   :group 'starttls)
 140
 141 (defcustom starttls-use-gnutls (not (executable-find starttls-program))
 142   "*Whether to use GNUTLS instead of the `starttls' command."
 143   :version "22.1"
 144   :type 'boolean
 145   :group 'starttls)
 146
 147 (defcustom starttls-extra-args nil
 148   "Extra arguments to `starttls-program'.
 149 This program is used when the `starttls' command is used,
 150 i.e. when `starttls-use-gnutls' is nil."
 151   :type '(repeat string)
 152   :group 'starttls)
 153
 154 (defcustom starttls-extra-arguments nil
 155   "Extra arguments to `starttls-program'.
 156 This program is used when GNUTLS is used, i.e. when
 157 `starttls-use-gnutls' is non-nil.
 158
 159 For example, non-TLS compliant servers may require
 160 '(\"--protocols\" \"ssl3\").  Invoke \"gnutls-cli --help\" to
 161 find out which parameters are available."
 162   :version "22.1"
 163   :type '(repeat string)
 164   :group 'starttls)
 165
 166 (defcustom starttls-process-connection-type nil
 167   "*Value for `process-connection-type' to use when starting STARTTLS process."
 168   :version "22.1"
 169   :type 'boolean
 170   :group 'starttls)
 171
 172 (defcustom starttls-connect "- Simple Client Mode:\n\n"
 173   "*Regular expression indicating successful connection.
 174 The default is what GNUTLS's \"gnutls-cli\" outputs."
 175   ;; GNUTLS cli.c:main() print this string when it is starting to run
 176   ;; in the application read/write phase.  If the logic, or the string
 177   ;; itself, is modified, this must be updated.
 178   :version "22.1"
 179   :type 'regexp
 180   :group 'starttls)
 181
 182 (defcustom starttls-failure "\\*\\*\\* Handshake has failed"
 183   "*Regular expression indicating failed TLS handshake.
 184 The default is what GNUTLS's \"gnutls-cli\" outputs."
 185   ;; GNUTLS cli.c:do_handshake() print this string on failure.  If the
 186   ;; logic, or the string itself, is modified, this must be updated.
 187   :version "22.1"
 188   :type 'regexp
 189   :group 'starttls)
 190
 191 (defcustom starttls-success "- Compression: "
 192   "*Regular expression indicating completed TLS handshakes.
 193 The default is what GNUTLS's \"gnutls-cli\" outputs."
 194   ;; GNUTLS cli.c:do_handshake() calls, on success,
 195   ;; common.c:print_info(), that unconditionally print this string
 196   ;; last.  If that logic, or the string itself, is modified, this
 197   ;; must be updated.
 198   :version "22.1"
 199   :type 'regexp
 200   :group 'starttls)
 201
 202 (defun starttls-negotiate-gnutls (process)
 203   "Negotiate TLS on process opened by `open-starttls-stream'.
 204 This should typically only be done once.  It typically return a
 205 multi-line informational message with information about the
 206 handshake, or NIL on failure."
 207   (let (buffer info old-max done-ok done-bad)
 208     (if (null (setq buffer (process-buffer process)))
 209         ;; XXX How to remove/extract the TLS negotiation junk?
 210         (signal-process (process-id process) 'SIGALRM)
 211       (with-current-buffer buffer
 212         (save-excursion
 213           (setq old-max (goto-char (point-max)))
 214           (signal-process (process-id process) 'SIGALRM)
 215           (while (and (processp process)
 216                       (eq (process-status process) 'run)
 217                       (save-excursion
 218                         (goto-char old-max)
 219                         (not (or (setq done-ok (re-search-forward
 220                                                 starttls-success nil t))
 221                                  (setq done-bad (re-search-forward
 222                                                  starttls-failure nil t))))))
 223             (accept-process-output process 1 100)
 224             (sit-for 0.1))
 225           (setq info (buffer-substring-no-properties old-max (point-max)))
 226           (delete-region old-max (point-max))
 227           (if (or (and done-ok (not done-bad))
 228                   ;; Prevent mitm that fake success msg after failure msg.
 229                   (and done-ok done-bad (< done-ok done-bad)))
 230               info
 231             (message "STARTTLS negotiation failed: %s" info)
 232             nil))))))
 233
 234 (defun starttls-negotiate (process)
 235   (if starttls-use-gnutls
 236       (starttls-negotiate-gnutls process)
 237     (signal-process (process-id process) 'SIGALRM)))
 238
 239 (defun starttls-set-process-query-on-exit-flag (process flag)
 240   "Run `set-process-query-on-exit-flag' if it is available.
 241 Otherwise, run `process-kill-without-query'."
 242   (let ((fn (if (fboundp 'set-process-query-on-exit-flag)
 243                 'set-process-query-on-exit-flag
 244               'process-kill-without-query)))
 245     (funcall fn process flag)))
 246
 247 (defun starttls-open-stream-gnutls (name buffer host service)
 248   (message "Opening STARTTLS connection to `%s'..." host)
 249   (let* (done
 250          (old-max (with-current-buffer buffer (point-max)))
 251          (process-connection-type starttls-process-connection-type)
 252          (process (apply #'start-process name buffer
 253                          starttls-gnutls-program "-s" host
 254                          "-p" (if (integerp service)
 255                                   (int-to-string service)
 256                                 service)
 257                          starttls-extra-arguments)))
 258     (starttls-set-process-query-on-exit-flag process nil)
 259     (while (and (processp process)
 260                 (eq (process-status process) 'run)
 261                 (save-excursion
 262                   (set-buffer buffer)
 263                   (goto-char old-max)
 264                   (not (setq done (re-search-forward
 265                                    starttls-connect nil t)))))
 266       (accept-process-output process 0 100)
 267       (sit-for 0.1))
 268     (if done
 269         (with-current-buffer buffer
 270           (delete-region old-max done))
 271       (delete-process process)
 272       (setq process nil))
 273     (message "Opening STARTTLS connection to `%s'...%s"
 274              host (if done "done" "failed"))
 275     process))
 276
 277 (defun starttls-open-stream (name buffer host service)
 278   "Open a TLS connection for a service to a host.
 279 Returns a subprocess-object to represent the connection.
 280 Input and output work as for subprocesses; `delete-process' closes it.
 281 Args are NAME BUFFER HOST SERVICE.
 282 NAME is name for process.  It is modified if necessary to make it unique.
 283 BUFFER is the buffer (or `buffer-name') to associate with the process.
 284  Process output goes at end of that buffer, unless you specify
 285  an output stream or filter function to handle the output.
 286  BUFFER may be also nil, meaning that this process is not associated
 287  with any buffer
 288 Third arg is name of the host to connect to, or its IP address.
 289 Fourth arg SERVICE is name of the service desired, or an integer
 290 specifying a port number to connect to."
 291   (if starttls-use-gnutls
 292       (starttls-open-stream-gnutls name buffer host service)
 293     (let* ((process-connection-type starttls-process-connection-type)
 294            (process (apply #'start-process
 295                            name buffer starttls-program
 296                            host (format "%s" service)
 297                            starttls-extra-args)))
 298       (starttls-set-process-query-on-exit-flag process nil)
 299       process)))
 300
 301 (provide 'starttls)
 302
 303 ;;; arch-tag: 648b3bd8-63bd-47f5-904c-7c819aea2297
 304 ;;; starttls.el ends here