X-Git-Url: https://cgit.sxemacs.org/?a=blobdiff_plain;ds=sidebyside;f=lisp%2Fproto-stream.el;h=9117ac9f4e37f6333a4cd29b5e6df78df2da1083;hb=38514cc0cc2016d69948f2cf103cc9742421278c;hp=fe764dcf01dd03bf6271b0f6c3cf43ae41ea32dd;hpb=258689b5503a0ce97b98b8de30468946ee8fd36b;p=gnus diff --git a/lisp/proto-stream.el b/lisp/proto-stream.el index fe764dcf0..9117ac9f4 100644 --- a/lisp/proto-stream.el +++ b/lisp/proto-stream.el @@ -1,6 +1,6 @@ ;;; proto-stream.el --- negotiating TLS, STARTTLS and other connections -;; Copyright (C) 2010 Free Software Foundation, Inc. +;; Copyright (C) 2010-2011 Free Software Foundation, Inc. ;; Author: Lars Magne Ingebrigtsen ;; Keywords: network @@ -75,10 +75,11 @@ is a string representing the capabilities of the server (if any). 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'. `network' will be -opportunistically upgraded to STARTTLS if both the server and -Emacs supports it. +:type -- either `network', `network-only, `tls', `shell' or +`starttls'. If omitted, the default is `network'. `network' +will be opportunistically upgraded to STARTTLS if both the server +and Emacs supports it. If you don't want STARTTLS upgrades, use +`network-only'. :end-of-command -- a regexp saying what the end of a command is. This defaults to \"\\n\". @@ -100,14 +101,28 @@ command to switch on STARTTLS otherwise." (setq type 'network)) ((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)))) + (let ((open-result + (funcall (intern (format "proto-stream-open-%s" type) obarray) + name buffer host service parameters))) + (if (null open-result) + (list nil nil nil type) + (let ((stream (car open-result))) + (list (and stream + (memq (process-status stream) + '(open run)) + stream) + (nth 1 open-result) + (nth 2 open-result) + (nth 3 open-result))))))) + +(defun proto-stream-open-network-only (name buffer host service parameters) + (let ((start (with-current-buffer buffer (point))) + (stream (open-network-stream name buffer host service))) + (list stream + (proto-stream-get-response + stream start (proto-stream-eoc parameters)) + nil + 'network))) (defun proto-stream-open-network (name buffer host service parameters) (let* ((start (with-current-buffer buffer (point))) @@ -118,7 +133,7 @@ command to switch on STARTTLS otherwise." (greeting (proto-stream-get-response stream start eoc)) success) (if (not capability-command) - (list stream greeting nil) + (list stream greeting nil 'network) (let* ((capabilities (proto-stream-command stream capability-command eoc)) (starttls-command @@ -136,7 +151,7 @@ command to switch on STARTTLS otherwise." (delete-process stream) nil) ;; Otherwise, just return this plain network connection. - (list stream greeting capabilities))) + (list stream greeting capabilities 'network))) ;; We have some kind of STARTTLS support, so we try to ;; upgrade the connection opportunistically. ((or (fboundp 'open-gnutls-stream) @@ -164,7 +179,7 @@ command to switch on STARTTLS otherwise." (progn (delete-process stream) nil) - (list stream greeting capabilities))) + (list stream greeting capabilities 'network))) ;; The server said it was OK to start doing STARTTLS negotiations. (if (fboundp 'open-gnutls-stream) (gnutls-negotiate stream nil) @@ -181,7 +196,7 @@ command to switch on STARTTLS otherwise." ;; Re-get the capabilities, since they may have changed ;; after switching to TLS. (list stream greeting - (proto-stream-command stream capability-command eoc)))) + (proto-stream-command stream capability-command eoc) 'tls))) ;; We don't have STARTTLS support available, but the caller ;; requested a STARTTLS connection, so we give up. ((eq (cadr (memq :type parameters)) 'starttls) @@ -189,7 +204,7 @@ command to switch on STARTTLS otherwise." nil) ;; Fall back on using a plain network stream. (t - (list stream greeting capabilities))))))) + (list stream greeting capabilities 'network))))))) (defun proto-stream-command (stream command eoc) (let ((start (with-current-buffer (process-buffer stream) (point-max)))) @@ -219,16 +234,18 @@ command to switch on STARTTLS otherwise." 'open-gnutls-stream 'open-tls-stream) name buffer host service))) - ;; If we're using tls.el, we have to delete the output from - ;; openssl/gnutls-cli. - (unless (fboundp 'open-gnutls-stream) - (proto-stream-get-response - stream start (proto-stream-eoc parameters)) - (goto-char (point-min)) - (when (re-search-forward (proto-stream-eoc parameters) nil t) - (goto-char (match-beginning 0)) - (delete-region (point-min) (line-beginning-position)))) - (proto-stream-capability-open start stream parameters)))) + (if (null stream) + nil + ;; If we're using tls.el, we have to delete the output from + ;; openssl/gnutls-cli. + (unless (fboundp 'open-gnutls-stream) + (proto-stream-get-response + stream start (proto-stream-eoc parameters)) + (goto-char (point-min)) + (when (re-search-forward (proto-stream-eoc parameters) nil t) + (goto-char (match-beginning 0)) + (delete-region (point-min) (line-beginning-position)))) + (proto-stream-capability-open start stream parameters 'tls))))) (defun proto-stream-open-shell (name buffer host service parameters) (proto-stream-capability-open @@ -241,16 +258,17 @@ command to switch on STARTTLS otherwise." (format-spec-make ?s host ?p service)))) - parameters)) + parameters 'network)) -(defun proto-stream-capability-open (start stream parameters) +(defun proto-stream-capability-open (start stream parameters stream-type) (let ((capability-command (cadr (memq :capability-command parameters))) (greeting (proto-stream-get-response stream start (proto-stream-eoc parameters)))) (list stream greeting (and capability-command (proto-stream-command - stream capability-command (proto-stream-eoc parameters)))))) + stream capability-command (proto-stream-eoc parameters))) + stream-type))) (defun proto-stream-eoc (parameters) (or (cadr (memq :end-of-command parameters))