(require 'tls)
(require 'parse-time)
(require 'nnmail)
+(require 'meta-stream)
(eval-when-compile
(require 'gnus-sum))
(push (current-buffer) nnimap-process-buffers)
(current-buffer)))
-(defun nnimap-open-shell-stream (name buffer host port)
- (let ((process-connection-type nil))
- (start-process name buffer shell-file-name
- shell-command-switch
- (format-spec
- nnimap-shell-program
- (format-spec-make
- ?s host
- ?p port)))))
-
(defun nnimap-credentials (address ports &optional inhibit-create)
(let (port credentials)
;; Request the credentials from all ports, but only query on the
(* 5 60)))
(nnimap-send-command "NOOP")))))))
-(declare-function gnutls-negotiate "gnutls"
- (proc type &optional priority-string trustfiles keyfiles))
-
(defun nnimap-open-connection (buffer)
(unless nnimap-keepalive-timer
(setq nnimap-keepalive-timer (run-at-time (* 60 15) (* 60 15)
'nnimap-keepalive)))
- (block nil
- (with-current-buffer (nnimap-make-process-buffer buffer)
- (let* ((coding-system-for-read 'binary)
- (coding-system-for-write 'binary)
- (port nil)
- (ports
- (cond
- ((or (eq nnimap-stream 'network)
- (and (eq nnimap-stream 'starttls)
- (fboundp 'open-gnutls-stream)))
- (nnheader-message 7 "Opening connection to %s..."
- nnimap-address)
- (open-network-stream
- "*nnimap*" (current-buffer) nnimap-address
- (setq port
- (or nnimap-server-port
- (if (netrc-find-service-number "imap")
- "imap"
- "143"))))
- '("143" "imap"))
- ((eq nnimap-stream 'shell)
- (nnheader-message 7 "Opening connection to %s via shell..."
- nnimap-address)
- (nnimap-open-shell-stream
- "*nnimap*" (current-buffer) nnimap-address
- (setq port (or nnimap-server-port "imap")))
- '("imap"))
- ((eq nnimap-stream 'starttls)
- (nnheader-message 7 "Opening connection to %s via starttls..."
- nnimap-address)
- (let ((tls-program
- '("openssl s_client -connect %h:%p -no_ssl2 -ign_eof -starttls imap")))
- (open-tls-stream
- "*nnimap*" (current-buffer) nnimap-address
- (setq port (or nnimap-server-port "imap"))))
- '("imap"))
- ((memq nnimap-stream '(ssl tls))
- (nnheader-message 7 "Opening connection to %s via tls..."
- nnimap-address)
- (funcall (if (fboundp 'open-gnutls-stream)
- 'open-gnutls-stream
- 'open-tls-stream)
- "*nnimap*" (current-buffer) nnimap-address
- (setq port
- (or nnimap-server-port
- (if (netrc-find-service-number "imaps")
- "imaps"
- "993"))))
- '("143" "993" "imap" "imaps"))
- (t
- (error "Unknown stream type: %s" nnimap-stream))))
- connection-result login-result credentials)
- (setf (nnimap-process nnimap-object)
- (get-buffer-process (current-buffer)))
- (if (not (and (nnimap-process nnimap-object)
- (memq (process-status (nnimap-process nnimap-object))
- '(open run))))
+ (with-current-buffer (nnimap-make-process-buffer buffer)
+ (let* ((coding-system-for-read 'binary)
+ (coding-system-for-write 'binary)
+ (port nil)
+ (ports
+ (cond
+ ((or (eq nnimap-stream 'network)
+ (eq nnimap-stream 'starttls))
+ (nnheader-message 7 "Opening connection to %s..."
+ nnimap-address)
+ '("143" "imap"))
+ ((eq nnimap-stream 'shell)
+ (nnheader-message 7 "Opening connection to %s via shell..."
+ nnimap-address)
+ '("imap"))
+ ((memq nnimap-stream '(ssl tls))
+ (nnheader-message 7 "Opening connection to %s via tls..."
+ nnimap-address)
+ '("143" "993" "imap" "imaps"))
+ (t
+ (error "Unknown stream type: %s" nnimap-stream))))
+ connection-result login-result credentials)
+ (destructuring-bind (stream greeting capabilities)
+ (open-proto-stream
+ "*nnimap*" (current-buffer) nnimap-address (car (last ports))
+ :type nnimap-stream
+ :shell-command nnimap-shell-program
+ :capability-command "1 CAPABILITY\r\n"
+ :starttls-function
+ (lambda (stream capabilities)
+ (if (not (string-match "STARTTLS" capabilities))
+ ;; Not a STARTTLS-capable server.
+ nil
+ "1 STARTTLS")))
+ (setf (nnimap-process nnimap-object) stream)
+ (if (not stream)
(nnheader-report 'nnimap "Unable to contact %s:%s via %s"
nnimap-address port nnimap-stream)
- (gnus-set-process-query-on-exit-flag
- (nnimap-process nnimap-object) nil)
- (if (not (setq connection-result (nnimap-wait-for-connection)))
- (nnheader-report 'nnimap
- "%s" (buffer-substring
- (point) (line-end-position)))
+ (gnus-set-process-query-on-exit-flag stream nil)
+ (if (not (string-match "[*.] \\([A-Z0-9]+\\)" greeting))
+ (nnheader-report 'nnimap "%s" greeting)
;; Store the greeting (for debugging purposes).
- (setf (nnimap-greeting nnimap-object)
- (buffer-substring (line-beginning-position)
- (line-end-position)))
- (nnimap-get-capabilities)
+ (setf (nnimap-greeting nnimap-object) greeting)
+ (setf (nnimap-capabilities nnimap-object)
+ (mapcar #'upcase
+ (split-string capabilities)))
(when nnimap-server-port
(push (format "%s" nnimap-server-port) ports))
- ;; If this is a STARTTLS-capable server, then sever the
- ;; connection and start a STARTTLS connection instead.
- (cond
- ((and (or (and (eq nnimap-stream 'network)
- (nnimap-capability "STARTTLS"))
- (eq nnimap-stream 'starttls))
- (fboundp 'open-gnutls-stream))
- (nnimap-command "STARTTLS")
- (gnutls-negotiate (nnimap-process nnimap-object) nil)
- ;; Get the capabilities again -- they may have changed
- ;; after doing STARTTLS.
- (nnimap-get-capabilities))
- ((and (eq nnimap-stream 'network)
- (nnimap-capability "STARTTLS"))
- (let ((nnimap-stream 'starttls))
- (let ((tls-process
- (nnimap-open-connection buffer)))
- ;; If the STARTTLS connection was successful, we
- ;; kill our first non-encrypted connection. If it
- ;; wasn't successful, we just use our unencrypted
- ;; connection.
- (when (memq (process-status tls-process) '(open run))
- (delete-process (nnimap-process nnimap-object))
- (kill-buffer (current-buffer))
- (return tls-process))))))
(unless (equal connection-result "PREAUTH")
(if (not (setq credentials
(if (eq nnimap-authenticator 'anonymous)
(nnimap-command "ENABLE QRESYNC"))
(nnimap-process nnimap-object))))))))
-(defun nnimap-get-capabilities ()
- (setf (nnimap-capabilities nnimap-object)
- (mapcar
- #'upcase
- (nnimap-find-parameter
- "CAPABILITY" (cdr (nnimap-command "CAPABILITY"))))))
-
(defun nnimap-quote-specials (string)
(with-temp-buffer
(insert string)
--- /dev/null
+;;; proto-stream.el --- negotiating TLS, STARTTLS and other connections
+;; Copyright (C) 2010 Free Software Foundation, Inc.
+
+;; Author: Lars Magne Ingebrigtsen <larsi@gnus.org>
+;; Keywords: network
+
+;; This file is part of GNU Emacs.
+
+;; GNU Emacs is free software; you can redistribute it and/or modify
+;; it under the terms of the GNU General Public License as published by
+;; the Free Software Foundation; either version 3, or (at your option)
+;; any later version.
+
+;; GNU Emacs is distributed in the hope that it will be useful,
+;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+;; GNU General Public License for more details.
+
+;; You should have received a copy of the GNU General Public License
+;; along with GNU Emacs; see the file COPYING. If not, write to the
+;; Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,
+;; Boston, MA 02110-1301, USA.
+
+;;; Commentary:
+
+;; This library is meant to provide the glue between modules that want
+;; to establish a network connection to a server for protocols such as
+;; IMAP, NNTP, SMTP and POP3.
+
+;; The main problem is that there's more than a couple of interfaces
+;; towards doing this. You have normal, plain connections, which are
+;; no trouble at all, but you also have TLS/SSL connections, and you
+;; have STARTTLS. Negotiating this for each protocol can be rather
+;; tedious, so this library provides a single entry point, and hides
+;; much of the ugliness.
+
+;;; Code:
+
+(eval-when-compile
+ (require 'cl))
+(require 'tls)
+(require 'starttls)
+(require 'format-spec)
+
+;;;###autoload
+(defun open-proto-stream (name buffer host service &rest parameters)
+ "Open a network stream to HOST.
+The first four parameters have the same meaning as in
+`open-network-stream'. The PARAMETERS is a keyword list that can
+have the following values:
+
+:type -- either `network', `tls', `shell' or `starttls'. If
+omitted, the default is `network'.
+
+:capability-command -- a function that takes a stream parameter"
+ (let ((type (or (cadr (memq :type parameters)) 'stream)))
+ (when (and (eq type 'starttls)
+ (fboundp 'open-gnutls-stream))
+ (setq type 'network))
+ (when (eq type 'ssl)
+ (setq type 'tls))
+ (destructuring-bind (stream greeting capabilities)
+ (funcall (intern (format "proto-stream-open-%s" type) obarray)
+ name buffer host service parameters)
+ (list (and stream
+ (memq (process-status stream)
+ '(open run))
+ stream)
+ greeting capabilities))))
+
+(defun proto-stream-open-network (name buffer host service parameters)
+ (let ((start (with-current-buffer buffer (point)))
+ (stream (open-network-stream name buffer host service))
+ (capability-command (cadr (memq :capability-command parameters)))
+ (greeting (proto-stream-get-response stream start)))
+ (if (not capability-command)
+ (list stream greeting nil)
+ (let* ((capabilities
+ (proto-stream-capabilities stream capability-command))
+ (starttls-command
+ (funcall (cadr (memq :starttls-function parameters))
+ stream capabilities)))
+ (cond
+ ((not starttls-command)
+ ;; If this server doesn't support STARTTLS, but we have
+ ;; requested it explicitly, then close the connection and
+ ;; return nil.
+ (if (eq (cadr (memq :type parameters)) 'starttls)
+ (progn
+ (delete-process stream)
+ nil)
+ ;; Otherwise, just return this plain network connection.
+ (list stream greeting capabilities)))
+ ((fboundp 'open-gnutls-stream)
+ (setq start (with-current-buffer buffer (point)))
+ (process-send-string stream starttls-command)
+ (proto-stream-get-response stream start)
+ (gnutls-negotiate stream nil)
+ ;; Re-get the capabilities, since they may have changed
+ ;; after switching to TLS.
+ (setq start (with-current-buffer buffer (point)))
+ (process-send-string stream capability-command)
+ (list stream greeting (proto-stream-get-response stream start)))
+ (t
+ (delete-process stream)
+ (proto-stream-open-starttls name buffer host service parameters)))))))
+
+(defun proto-stream-capabilities (stream command)
+ (let ((start (with-current-buffer buffer (point))))
+ (process-send-string stream command)
+ (proto-stream-get-response stream start)))
+
+(defun proto-stream-open-starttls (name buffer host service parameters)
+ (proto-stream-capability-open
+ (with-current-buffer buffer (point))
+ (starttls-open-stream name buffer host service)
+ parameters))
+
+(defun proto-stream-get-response (stream start)
+ (with-current-buffer (process-buffer stream)
+ (save-excursion
+ (goto-char start)
+ (while (and (memq (process-status stream)
+ '(open run))
+ (not (search-forward "\n" nil t)))
+ (accept-process-output stream 0 50)
+ (goto-char start))
+ (if (= start (point))
+ ;; The process died; return nil.
+ nil
+ ;; Return the data we got back.
+ (buffer-substring start (point))))))
+
+(defun proto-stream-open-tls (name buffer host service parameters)
+ (proto-stream-capability-open
+ (with-current-buffer buffer (point))
+ (funcall (if (fboundp 'open-gnutls-stream)
+ 'open-gnutls-stream
+ 'open-tls-stream)
+ name buffer host service)
+ parameters))
+
+(defun proto-stream-open-shell (name buffer host service parameters)
+ (proto-stream-capability-open
+ (with-current-buffer buffer (point))
+ (let ((process-connection-type nil))
+ (start-process name buffer shell-file-name
+ shell-command-switch
+ (format-spec
+ (cadr (memq :shell-command parameters))
+ (format-spec-make
+ ?s host
+ ?p port))))
+ parameters))
+
+(defun proto-stream-capability-open (start stream parameters)
+ (let ((capability-command (cadr (memq :capability-command parameters)))
+ (greeting (proto-stream-get-response stream start)))
+ (list stream greeting
+ (and capability-command
+ (proto-stream-capabilities stream capability-command)))))
+
+(provide 'proto-stream)
+
+;;; proto-stream.el ends here
projects / gnus / commitdiff