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

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