lisp/net/network-stream.el

   1 ;;; network-stream.el --- open network processes, possibly with encryption
   2
   3 ;; Copyright (C) 2010-2011 Free Software Foundation, Inc.
   4
   5 ;; Author: Lars Magne Ingebrigtsen <larsi@gnus.org>
   6 ;; Keywords: network
   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 3 of the License, or
  13 ;; (at your option) 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.  If not, see <http://www.gnu.org/licenses/>.
  22
  23 ;;; Commentary:
  24
  25 ;; This library provides the function `open-network-stream', which provides a
  26 ;; higher-level interface for opening TCP network processes than the built-in
  27 ;; function `make-network-process'.  In addition to plain connections, it
  28 ;; supports TLS/SSL and STARTTLS connections.
  29
  30 ;; Usage example:
  31
  32 ;; (open-network-stream
  33 ;;  "*nnimap*" buffer address port
  34 ;;  :type 'network
  35 ;;  :capability-command "1 CAPABILITY\r\n"
  36 ;;  :success " OK "
  37 ;;  :starttls-function
  38 ;;  (lambda (capabilities)
  39 ;;    (if (not (string-match "STARTTLS" capabilities))
  40 ;;        nil
  41 ;;      "1 STARTTLS\r\n")))
  42
  43 ;;; Code:
  44
  45 (require 'tls)
  46 (require 'starttls)
  47 (require 'auth-source)
  48
  49 (declare-function gnutls-negotiate "gnutls" t t) ; defun*
  50
  51 ;;;###autoload
  52 (defun open-network-stream (name buffer host service &rest parameters)
  53   "Open a TCP connection to HOST, optionally with encryption.
  54 Normally, return a network process object; with a non-nil
  55 :return-list parameter, return a list instead (see below).
  56 Input and output work as for subprocesses; `delete-process'
  57 closes it.
  58
  59 NAME is the name for the process.  It is modified if necessary to
  60  make it unique.
  61 BUFFER is a buffer or buffer name to associate with the process.
  62  Process output goes at end of that buffer.  BUFFER may be nil,
  63  meaning that the process is not associated with any buffer.
  64 HOST is the name or IP address of the host to connect to.
  65 SERVICE is the name of the service desired, or an integer specifying
  66  a port number to connect to.
  67
  68 The remaining PARAMETERS should be a sequence of keywords and
  69 values:
  70
  71 :type specifies the connection type, one of the following:
  72   nil or `network'
  73              -- Begin with an ordinary network connection, and if
  74                 the parameters :success and :capability-command
  75                 are also supplied, try to upgrade to an encrypted
  76                 connection via STARTTLS.  Even if that
  77                 fails (e.g. if HOST does not support TLS), retain
  78                 an unencrypted connection.
  79   `plain'    -- An ordinary, unencrypted network connection.
  80   `starttls' -- Begin with an ordinary connection, and try
  81                 upgrading via STARTTLS.  If that fails for any
  82                 reason, drop the connection; in that case the
  83                 returned object is a killed process.
  84   `tls'      -- A TLS connection.
  85   `ssl'      -- Equivalent to `tls'.
  86   `shell'    -- A shell connection.
  87
  88 :return-list specifies this function's return value.
  89   If omitted or nil, return a process object.  A non-nil means to
  90   return (PROC . PROPS), where PROC is a process object and PROPS
  91   is a plist of connection properties, with these keywords:
  92    :greeting -- the greeting returned by HOST (a string), or nil.
  93    :capabilities -- a string representing HOST's capabilities,
  94                     or nil if none could be found.
  95    :type -- the resulting connection type; `plain' (unencrypted)
  96             or `tls' (TLS-encrypted).
  97
  98 :end-of-command specifies a regexp matching the end of a command.
  99
 100 :success specifies a regexp matching a message indicating a
 101   successful STARTTLS negotiation.  For instance, the default
 102   should be \"^3\" for an NNTP connection.
 103
 104 :capability-command specifies a command used to query the HOST
 105   for its capabilities.  For instance, for IMAP this should be
 106   \"1 CAPABILITY\\r\\n\".
 107
 108 :starttls-function specifies a function for handling STARTTLS.
 109   This function should take one parameter, the response to the
 110   capability command, and should return the command to switch on
 111   STARTTLS if the server supports STARTTLS, and nil otherwise.
 112
 113 :always-query-capabilies says whether to query the server for
 114   capabilities, even if we're doing a `plain' network connection.
 115
 116 :client-certificate should either be a list where the first
 117   element is the certificate key file name, and the second
 118   element is the certificate file name itself, or `t', which
 119   means that `auth-source' will be queried for the key and the
 120   certificate.  This parameter will only be used when doing TLS
 121   or STARTTLS connections.
 122
 123 If :use-starttls-if-possible is non-nil, do opportunistic
 124 STARTTLS upgrades even if Emacs doesn't have built-in TLS
 125 functionality.
 126
 127 :nowait is a boolean that says the connection should be made
 128   asynchronously, if possible."
 129   (unless (featurep 'make-network-process)
 130     (error "Emacs was compiled without networking support"))
 131   (let ((type (plist-get parameters :type))
 132         (return-list (plist-get parameters :return-list)))
 133     (if (and (not return-list)
 134              (or (eq type 'plain)
 135                  (and (memq type '(nil network))
 136                       (not (and (plist-get parameters :success)
 137                                 (plist-get parameters :capability-command))))))
 138         ;; The simplest case: wrapper around `make-network-process'.
 139         (make-network-process :name name :buffer buffer
 140                               :host host :service service
 141                               :nowait (plist-get parameters :nowait))
 142       (let ((work-buffer (or buffer
 143                              (generate-new-buffer " *stream buffer*")))
 144             (fun (cond ((and (eq type 'plain)
 145                              (not (plist-get parameters
 146                                              :always-query-capabilities)))
 147                         'network-stream-open-plain)
 148                        ((memq type '(nil network starttls plain))
 149                         'network-stream-open-starttls)
 150                        ((memq type '(tls ssl)) 'network-stream-open-tls)
 151                        ((eq type 'shell) 'network-stream-open-shell)
 152                        (t (error "Invalid connection type %s" type))))
 153             result)
 154         (unwind-protect
 155             (setq result (funcall fun name work-buffer host service parameters))
 156           (unless buffer
 157             (and (processp (car result))
 158                  (set-process-buffer (car result) nil))
 159             (kill-buffer work-buffer)))
 160         (if return-list
 161             (list (car result)
 162                   :greeting     (nth 1 result)
 163                   :capabilities (nth 2 result)
 164                   :type         (nth 3 result))
 165           (car result))))))
 166
 167 (defun network-stream-certificate (host service parameters)
 168   (let ((spec (plist-get :client-certificate parameters)))
 169     (cond
 170      ((listp spec)
 171       ;; Either nil or a list with a key/certificate pair.
 172       spec)
 173      ((eq spec t)
 174       (let* ((auth-info
 175               (car (auth-source-search :max 1
 176                                        :host host
 177                                        :port service)))
 178              (key (plist-get auth-info :key))
 179              (cert (plist-get auth-info :cert)))
 180         (and key cert
 181              (list key cert)))))))
 182
 183 ;;;###autoload
 184 (defalias 'open-protocol-stream 'open-network-stream)
 185
 186 (defun network-stream-open-plain (name buffer host service parameters)
 187   (let ((start (with-current-buffer buffer (point)))
 188         (stream (make-network-process :name name :buffer buffer
 189                                       :host host :service service
 190                                       :nowait (plist-get parameters :nowait))))
 191     (list stream
 192           (network-stream-get-response stream start
 193                                        (plist-get parameters :end-of-command))
 194           nil
 195           'plain)))
 196
 197 (defun network-stream-open-starttls (name buffer host service parameters)
 198   (let* ((start (with-current-buffer buffer (point)))
 199          (require-tls    (eq (plist-get parameters :type) 'starttls))
 200          (starttls-function  (plist-get parameters :starttls-function))
 201          (success-string     (plist-get parameters :success))
 202          (capability-command (plist-get parameters :capability-command))
 203          (eoc                (plist-get parameters :end-of-command))
 204          ;; Return (STREAM GREETING CAPABILITIES RESULTING-TYPE)
 205          (stream (make-network-process :name name :buffer buffer
 206                                        :host host :service service))
 207          (greeting (network-stream-get-response stream start eoc))
 208          (capabilities (network-stream-command stream capability-command eoc))
 209          (resulting-type 'plain)
 210          starttls-command)
 211
 212     ;; If we have built-in STARTTLS support, try to upgrade the
 213     ;; connection.
 214     (when (and (or (fboundp 'open-gnutls-stream)
 215                    (and (or require-tls
 216                             (plist-get parameters :use-starttls-if-possible))
 217                         (executable-find "gnutls-cli")))
 218                capabilities success-string starttls-function
 219                (setq starttls-command
 220                      (funcall starttls-function capabilities))
 221                (not (eq (plist-get parameters :type) 'plain)))
 222       ;; If using external STARTTLS, drop this connection and start
 223       ;; anew with `starttls-open-stream'.
 224       (unless (fboundp 'open-gnutls-stream)
 225         (delete-process stream)
 226         (setq start (with-current-buffer buffer (point-max)))
 227         (let* ((starttls-use-gnutls t)
 228                (starttls-extra-arguments
 229                 (if require-tls
 230                     starttls-extra-arguments
 231                   ;; For opportunistic TLS upgrades, we don't really
 232                   ;; care about the identity of the peer.
 233                   (cons "--insecure" starttls-extra-arguments)))
 234                (cert (network-stream-certificate host service parameters)))
 235           ;; There are client certificates requested, so add them to
 236           ;; the command line.
 237           (when cert
 238             (setq starttls-extra-arguments
 239                   (nconc (list "--x509keyfile" (expand-file-name (nth 0 cert))
 240                                "--x509certfile" (expand-file-name (nth 1 cert)))
 241                          starttls-extra-arguments)))
 242           (setq stream (starttls-open-stream name buffer host service)))
 243         (network-stream-get-response stream start eoc))
 244       ;; Requery capabilities for protocols that require it; i.e.,
 245       ;; EHLO for SMTP.
 246       (when (plist-get parameters :always-query-capabilities)
 247         (network-stream-command stream capability-command eoc))
 248       (when (string-match success-string
 249                           (network-stream-command stream starttls-command eoc))
 250         ;; The server said it was OK to begin STARTTLS negotiations.
 251         (if (fboundp 'open-gnutls-stream)
 252             (let ((cert (network-stream-certificate host service parameters)))
 253               (gnutls-negotiate :process stream :hostname host
 254                                 :keylist (and cert (list cert))))
 255           (unless (starttls-negotiate stream)
 256             (delete-process stream)))
 257         (if (memq (process-status stream) '(open run))
 258             (setq resulting-type 'tls)
 259           ;; We didn't successfully negotiate STARTTLS; if TLS
 260           ;; isn't demanded, reopen an unencrypted connection.
 261           (unless require-tls
 262             (setq stream
 263                   (make-network-process :name name :buffer buffer
 264                                         :host host :service service))
 265             (network-stream-get-response stream start eoc)))
 266         ;; Re-get the capabilities, which may have now changed.
 267         (setq capabilities
 268               (network-stream-command stream capability-command eoc))))
 269
 270     ;; If TLS is mandatory, close the connection if it's unencrypted.
 271     (and require-tls
 272          (eq resulting-type 'plain)
 273          (delete-process stream))
 274     ;; Return value:
 275     (list stream greeting capabilities resulting-type)))
 276
 277 (defun network-stream-command (stream command eoc)
 278   (when command
 279     (let ((start (with-current-buffer (process-buffer stream) (point-max))))
 280       (process-send-string stream command)
 281       (network-stream-get-response stream start eoc))))
 282
 283 (defun network-stream-get-response (stream start end-of-command)
 284   (when end-of-command
 285     (with-current-buffer (process-buffer stream)
 286       (save-excursion
 287         (goto-char start)
 288         (while (and (memq (process-status stream) '(open run))
 289                     (not (re-search-forward end-of-command nil t)))
 290           (accept-process-output stream 0 50)
 291           (goto-char start))
 292         ;; Return the data we got back, or nil if the process died.
 293         (unless (= start (point))
 294           (buffer-substring start (point)))))))
 295
 296 (defun network-stream-open-tls (name buffer host service parameters)
 297   (with-current-buffer buffer
 298     (let* ((start (point-max))
 299            (use-builtin-gnutls (fboundp 'open-gnutls-stream))
 300            (stream
 301             (funcall (if use-builtin-gnutls
 302                          'open-gnutls-stream
 303                        'open-tls-stream)
 304                      name buffer host service))
 305            (eoc (plist-get parameters :end-of-command)))
 306       (if (null stream)
 307           (list nil nil nil 'plain)
 308         ;; If we're using tls.el, we have to delete the output from
 309         ;; openssl/gnutls-cli.
 310         (when (and (null use-builtin-gnutls) eoc)
 311           (network-stream-get-response stream start eoc)
 312           (goto-char (point-min))
 313           (when (re-search-forward eoc nil t)
 314             (goto-char (match-beginning 0))
 315             (delete-region (point-min) (line-beginning-position))))
 316         (let* ((capability-command (plist-get parameters :capability-command)))
 317           (list stream
 318                 (network-stream-get-response stream start eoc)
 319                 (network-stream-command stream capability-command eoc)
 320                 'tls))))))
 321
 322 (defun network-stream-open-shell (name buffer host service parameters)
 323   (require 'format-spec)
 324   (let* ((capability-command (plist-get parameters :capability-command))
 325          (eoc                (plist-get parameters :end-of-command))
 326          (start (with-current-buffer buffer (point)))
 327          (stream (let ((process-connection-type nil))
 328                    (start-process name buffer shell-file-name
 329                                   shell-command-switch
 330                                   (format-spec
 331                                    (plist-get parameters :shell-command)
 332                                    (format-spec-make
 333                                     ?s host
 334                                     ?p service))))))
 335     (list stream
 336           (network-stream-get-response stream start eoc)
 337           (network-stream-command stream capability-command eoc)
 338           'plain)))
 339
 340 (provide 'network-stream)
 341
 342 ;;; network-stream.el ends here