;; Usage example:
-;; (open-proto-stream
+;; (open-protocol-stream
;; "*nnimap*" buffer address port
;; :type 'network
;; :capability-command "1 CAPABILITY\r\n"
(require 'starttls)
(require 'format-spec)
-(defcustom proto-stream-always-use-starttls t
+(defcustom proto-stream-always-use-starttls (fboundp 'open-gnutls-stream)
"If non-nil, always try to upgrade network connections with STARTTLS."
:version "24.1"
:type 'boolean
(proc type &optional priority-string trustfiles keyfiles))
;;;###autoload
-(defun open-proto-stream (name buffer host service &rest parameters)
+(defun open-protocol-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 function returns a list where the
(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 (proto-stream-eoc parameters))))
+ (eoc (proto-stream-eoc parameters))
+ (type (cadr (memq :type parameters)))
+ (greeting (proto-stream-get-response stream start eoc)))
(if (not capability-command)
(list stream greeting nil)
(let* ((capabilities
- (proto-stream-capabilities stream capability-command
- (proto-stream-eoc parameters)))
+ (proto-stream-command stream capability-command eoc))
(starttls-command
(funcall (cadr (memq :starttls-function parameters))
capabilities)))
(cond
((or (not starttls-command)
- (not proto-stream-always-use-starttls))
+ (and (not (eq type 'starttls))
+ (not proto-stream-always-use-starttls)))
;; 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)
+ (if (eq type '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-max)))
- (process-send-string stream starttls-command)
- (proto-stream-get-response stream start (proto-stream-eoc parameters))
- (gnutls-negotiate stream nil)
+ ((or (fboundp 'open-gnutls-stream)
+ (executable-find "gnutls-cli"))
+ (unless (fboundp 'open-gnutls-stream)
+ (delete-process stream)
+ (let* ((starttls-use-gnutls t)
+ (starttls-extra-arguments
+ (if (eq type 'starttls)
+ ;; When doing opportunistic TLS upgrades we
+ ;; don't really care about the identity of the
+ ;; peer.
+ (cons "--insecure" starttls-extra-arguments)
+ starttls-extra-arguments)))
+ (setq stream (starttls-open-stream name buffer host service)))
+ (proto-stream-get-response stream start eoc))
+ (proto-stream-command stream starttls-command eoc)
+ (if (fboundp 'open-gnutls-stream)
+ (gnutls-negotiate stream nil)
+ (unless (starttls-negotiate stream)
+ (delete-process stream)
+ (setq stream nil)))
+ (when (or (null stream)
+ (not (memq (process-status stream)
+ '(open run))))
+ ;; It didn't successfully negotiate STARTTLS, so we reopen
+ ;; the connection.
+ (setq stream (open-network-stream name buffer host service))
+ (proto-stream-get-response stream start eoc))
;; Re-get the capabilities, since they may have changed
;; after switching to TLS.
- (setq start (with-current-buffer buffer (point-max)))
- (process-send-string stream capability-command)
- (list stream greeting (proto-stream-get-response
- stream start (proto-stream-eoc parameters))))
- ((executable-find "gnutls-cli")
- (delete-process stream)
- (proto-stream-open-starttls name buffer host service parameters))
+ (list stream greeting
+ (proto-stream-command stream capability-command eoc)))
((eq (cadr (memq :type parameters)) 'starttls)
(delete-process stream)
nil)
(t
(list stream greeting capabilities)))))))
-(defun proto-stream-capabilities (stream command end-of-command)
+(defun proto-stream-command (stream command eoc)
(let ((start (with-current-buffer (process-buffer stream) (point-max))))
(process-send-string stream command)
- (proto-stream-get-response stream start end-of-command)))
-
-(defun proto-stream-open-starttls (name buffer host service parameters)
- (let* ((start (with-current-buffer buffer (point-max)))
- (stream (starttls-open-stream name buffer host service))
- (greeting (proto-stream-get-response
- stream start (proto-stream-eoc parameters)))
- (capabilities
- (proto-stream-capabilities
- stream
- (cadr (memq :capability-command parameters))
- (proto-stream-eoc parameters)))
- (starttls-command
- (funcall (cadr (memq :starttls-function parameters))
- capabilities)))
- (setq start (with-current-buffer buffer (point-max)))
- (process-send-string stream starttls-command)
- (proto-stream-get-response stream start (proto-stream-eoc parameters))
- (starttls-negotiate stream)
- ;; Re-get the capabilities, since they may have changed
- ;; after switching to TLS.
- (setq start (with-current-buffer buffer (point-max)))
- (process-send-string stream capability-command)
- (list stream greeting (proto-stream-get-response
- stream start (proto-stream-eoc parameters)))))
+ (proto-stream-get-response stream start eoc)))
(defun proto-stream-get-response (stream start end-of-command)
(with-current-buffer (process-buffer stream)
stream start (proto-stream-eoc parameters))))
(list stream greeting
(and capability-command
- (proto-stream-capabilities
- stream capability-command
- (proto-stream-eoc parameters))))))
+ (proto-stream-command
+ stream capability-command (proto-stream-eoc parameters))))))
(defun proto-stream-eoc (parameters)
(or (cadr (memq :end-of-command parameters))
projects / gnus / blobdiff