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