cgit.sxemacs.org Git - gnus/blob - lisp/proto-stream.el

   1 ;;; proto-stream.el --- negotiating TLS, STARTTLS and other connections
   2 ;; Copyright (C) 2010 Free Software Foundation, Inc.
   3
   4 ;; Author: Lars Magne Ingebrigtsen <larsi@gnus.org>
   5 ;; Keywords: network
   6
   7 ;; This file is part of GNU Emacs.
   8
   9 ;; GNU Emacs is free software; you can redistribute it and/or modify
  10 ;; it under the terms of the GNU General Public License as published by
  11 ;; the Free Software Foundation; either version 3, or (at your option)
  12 ;; any later version.
  13
  14 ;; GNU Emacs is distributed in the hope that it will be useful,
  15 ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
  16 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  17 ;; GNU General Public License for more details.
  18
  19 ;; You should have received a copy of the GNU General Public License
  20 ;; along with GNU Emacs; see the file COPYING.  If not, write to the
  21 ;; Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,
  22 ;; Boston, MA 02110-1301, USA.
  23
  24 ;;; Commentary:
  25
  26 ;; This library is meant to provide the glue between modules that want
  27 ;; to establish a network connection to a server for protocols such as
  28 ;; IMAP, NNTP, SMTP and POP3.
  29
  30 ;; The main problem is that there's more than a couple of interfaces
  31 ;; towards doing this.  You have normal, plain connections, which are
  32 ;; no trouble at all, but you also have TLS/SSL connections, and you
  33 ;; have STARTTLS.  Negotiating this for each protocol can be rather
  34 ;; tedious, so this library provides a single entry point, and hides
  35 ;; much of the ugliness.
  36
  37 ;;; Code:
  38
  39 (eval-when-compile
  40   (require 'cl))
  41 (require 'tls)
  42 (require 'starttls)
  43 (require 'format-spec)
  44
  45 ;;;###autoload
  46 (defun open-proto-stream (name buffer host service &rest parameters)
  47   "Open a network stream to HOST.
  48 The first four parameters have the same meaning as in
  49 `open-network-stream'.  The PARAMETERS is a keyword list that can
  50 have the following values:
  51
  52 :type -- either `network', `tls', `shell' or `starttls'.  If
  53 omitted, the default is `network'.
  54
  55 :capability-command -- a function that takes a stream parameter"
  56   (let ((type (or (cadr (memq :type parameters)) 'stream)))
  57     (when (and (eq type 'starttls)
  58                (fboundp 'open-gnutls-stream))
  59       (setq type 'network))
  60     (when (eq type 'ssl)
  61       (setq type 'tls))
  62     (destructuring-bind (stream greeting capabilities)
  63         (funcall (intern (format "proto-stream-open-%s" type) obarray)
  64                  name buffer host service parameters)
  65       (list (and stream
  66                  (memq (process-status stream)
  67                        '(open run))
  68                  stream)
  69             greeting capabilities))))
  70
  71 (defun proto-stream-open-network (name buffer host service parameters)
  72   (let ((start (with-current-buffer buffer (point)))
  73         (stream (open-network-stream name buffer host service))
  74         (capability-command (cadr (memq :capability-command parameters)))
  75         (greeting (proto-stream-get-response stream start)))
  76     (if (not capability-command)
  77         (list stream greeting nil)
  78       (let* ((capabilities
  79               (proto-stream-capabilities stream capability-command))
  80              (starttls-command
  81               (funcall (cadr (memq :starttls-function parameters))
  82                        stream capabilities)))
  83         (cond
  84          ((not starttls-command)
  85           ;; If this server doesn't support STARTTLS, but we have
  86           ;; requested it explicitly, then close the connection and
  87           ;; return nil.
  88           (if (eq (cadr (memq :type parameters)) 'starttls)
  89               (progn
  90                 (delete-process stream)
  91                 nil)
  92             ;; Otherwise, just return this plain network connection.
  93             (list stream greeting capabilities)))
  94          ((fboundp 'open-gnutls-stream)
  95           (setq start (with-current-buffer buffer (point)))
  96           (process-send-string stream starttls-command)
  97           (proto-stream-get-response stream start)
  98           (gnutls-negotiate stream nil)
  99           ;; Re-get the capabilities, since they may have changed
 100           ;; after switching to TLS.
 101           (setq start (with-current-buffer buffer (point)))
 102           (process-send-string stream capability-command)
 103           (list stream greeting (proto-stream-get-response stream start)))
 104          (t
 105           (delete-process stream)
 106           (proto-stream-open-starttls name buffer host service parameters)))))))
 107
 108 (defun proto-stream-capabilities (stream command)
 109   (let ((start (with-current-buffer buffer (point))))
 110     (process-send-string stream command)
 111     (proto-stream-get-response stream start)))
 112
 113 (defun proto-stream-open-starttls (name buffer host service parameters)
 114   (proto-stream-capability-open
 115    (with-current-buffer buffer (point))
 116    (starttls-open-stream name buffer host service)
 117    parameters))
 118
 119 (defun proto-stream-get-response (stream start)
 120   (with-current-buffer (process-buffer stream)
 121     (save-excursion
 122       (goto-char start)
 123       (while (and (memq (process-status stream)
 124                         '(open run))
 125                   (not (search-forward "\n" nil t)))
 126         (accept-process-output stream 0 50)
 127         (goto-char start))
 128       (if (= start (point))
 129           ;; The process died; return nil.
 130           nil
 131         ;; Return the data we got back.
 132         (buffer-substring start (point))))))
 133
 134 (defun proto-stream-open-tls (name buffer host service parameters)
 135   (proto-stream-capability-open
 136    (with-current-buffer buffer (point))
 137    (funcall (if (fboundp 'open-gnutls-stream)
 138                 'open-gnutls-stream
 139               'open-tls-stream)
 140             name buffer host service)
 141    parameters))
 142
 143 (defun proto-stream-open-shell (name buffer host service parameters)
 144   (proto-stream-capability-open
 145    (with-current-buffer buffer (point))
 146    (let ((process-connection-type nil))
 147      (start-process name buffer shell-file-name
 148                     shell-command-switch
 149                     (format-spec
 150                      (cadr (memq :shell-command parameters))
 151                      (format-spec-make
 152                       ?s host
 153                       ?p port))))
 154    parameters))
 155
 156 (defun proto-stream-capability-open (start stream parameters)
 157   (let ((capability-command (cadr (memq :capability-command parameters)))
 158         (greeting (proto-stream-get-response stream start)))
 159     (list stream greeting
 160           (and capability-command
 161                (proto-stream-capabilities stream capability-command)))))
 162
 163 (provide 'proto-stream)
 164
 165 ;;; proto-stream.el ends here