From da91b5f294f8ec77f48f1bbe27707a0d33d981e9 Mon Sep 17 00:00:00 2001 From: Chong Yidong Date: Sat, 2 Apr 2011 19:41:03 -0400 Subject: [PATCH] Merge open-protocol-stream into open-network-stream. * lisp/subr.el (open-network-stream): Move to net/network-stream.el. * lisp/gnus/proto-stream.el: Move to net/network-stream.el. * lisp/net/network-stream.el: Move from gnus/proto-stream.el. Change prefix to network-stream throughout. (open-protocol-stream): Merge into open-network-stream, leaving open-protocol-stream as an alias. Handle nil BUFFER args. * lisp/gnus/nnimap.el (nnimap-open-connection-1): Pass explicit :end-of-command parameter to open-protocol-stream. * lisp/emacs-lisp/package.el (package--with-work-buffer): Recognize https URLs. * lisp/url/url-gw.el (url-open-stream): Use new open-network-stream functionality to perform encryption. --- etc/NEWS | 6 + lisp/ChangeLog | 28 ++- lisp/emacs-lisp/package.el | 2 +- lisp/gnus/ChangeLog | 7 + lisp/gnus/nnimap.el | 8 +- lisp/gnus/nntp.el | 7 +- .../proto-stream.el => net/network-stream.el} | 210 +++++++++--------- lisp/subr.el | 22 -- lisp/url/url-gw.el | 39 +--- 9 files changed, 166 insertions(+), 163 deletions(-) rename lisp/{gnus/proto-stream.el => net/network-stream.el} (57%) diff --git a/etc/NEWS b/etc/NEWS index 521741100f1..a1b0896a643 100644 --- a/etc/NEWS +++ b/etc/NEWS @@ -773,6 +773,12 @@ sc.el, x-menu.el, rnews.el, rnewspost.el * Lisp changes in Emacs 24.1 +** `open-network-stream' can now be used to open an encrypted stream. +It now accepts an optional `:type' parameter for initiating a TLS +connection, directly or via STARTTLS. To do STARTTLS, additional +parameters (`:end-of-command', `:success', `:capabilities-command') +must also be supplied. + ** Code can now use lexical scoping by default instead of dynamic scoping. The `lexical-binding' variable lets code use lexical scoping for local variables. It is typically set via file-local variables, in which case it diff --git a/lisp/ChangeLog b/lisp/ChangeLog index 9a5b1fd6cc4..04353b9137c 100644 --- a/lisp/ChangeLog +++ b/lisp/ChangeLog @@ -1,3 +1,15 @@ +2011-04-02 Chong Yidong + + * emacs-lisp/package.el (package--with-work-buffer): Recognize + https URLs. + + * net/network-stream.el: Move from gnus/proto-stream.el. Change + prefix to network-stream throughout. + (open-protocol-stream): Merge into open-network-stream, leaving + open-protocol-stream as an alias. Handle nil BUFFER args. + + * subr.el (open-network-stream): Move to net/network-stream.el. + 2011-04-02 Glenn Morris * find-dired.el (find-exec-terminator): New option. @@ -210,14 +222,14 @@ * textmodes/css.el: * startup.el: * uniquify.el: - * minibuffer.el: - * newcomment.el: - * reveal.el: - * server.el: - * mpc.el: - * emacs-lisp/smie.el: - * doc-view.el: - * dired.el: + * minibuffer.el: + * newcomment.el: + * reveal.el: + * server.el: + * mpc.el: + * emacs-lisp/smie.el: + * doc-view.el: + * dired.el: * abbrev.el: Use lexical binding. 2011-04-01 Eli Zaretskii diff --git a/lisp/emacs-lisp/package.el b/lisp/emacs-lisp/package.el index 5dc2938fe08..6aecc3615f3 100644 --- a/lisp/emacs-lisp/package.el +++ b/lisp/emacs-lisp/package.el @@ -652,7 +652,7 @@ FILE is the name of a file relative to that base location. This macro retrieves FILE from LOCATION into a temporary buffer, and evaluates BODY while that buffer is current. This work buffer is killed afterwards. Return the last value in BODY." - `(let* ((http (string-match "\\`http:" ,location)) + `(let* ((http (string-match "\\`https?:" ,location)) (buffer (if http (url-retrieve-synchronously (concat ,location ,file)) diff --git a/lisp/gnus/ChangeLog b/lisp/gnus/ChangeLog index 37faf83fd12..44c29256b7c 100644 --- a/lisp/gnus/ChangeLog +++ b/lisp/gnus/ChangeLog @@ -1,3 +1,10 @@ +2011-04-02 Chong Yidong + + * proto-stream.el: Move to Emacs core, at net/network-stream.el. + + * nnimap.el (nnimap-open-connection-1): Pass explicit :end-of-command + parameter to open-protocol-stream. + 2011-04-01 Julien Danjou * mm-view.el (mm-display-inline-fontify): Do not fontify with diff --git a/lisp/gnus/nnimap.el b/lisp/gnus/nnimap.el index fa09c7ff165..afdea185dd3 100644 --- a/lisp/gnus/nnimap.el +++ b/lisp/gnus/nnimap.el @@ -31,7 +31,11 @@ (unless (fboundp 'declare-function) (defmacro declare-function (&rest r)))) (eval-and-compile - (require 'nnheader)) + (require 'nnheader) + ;; In Emacs 24, `open-protocol-stream' is an autoloaded alias for + ;; `make-network-stream'. + (unless (fboundp 'open-protocol-stream) + (require 'proto-stream))) (eval-when-compile (require 'cl)) @@ -45,7 +49,6 @@ (require 'tls) (require 'parse-time) (require 'nnmail) -(require 'proto-stream) (autoload 'auth-source-forget+ "auth-source") (autoload 'auth-source-search "auth-source") @@ -365,6 +368,7 @@ textual parts.") :return-list t :shell-command nnimap-shell-program :capability-command "1 CAPABILITY\r\n" + :end-of-command "\r\n" :success " OK " :starttls-function (lambda (capabilities) diff --git a/lisp/gnus/nntp.el b/lisp/gnus/nntp.el index fa765e17463..3285da513e8 100644 --- a/lisp/gnus/nntp.el +++ b/lisp/gnus/nntp.el @@ -27,13 +27,16 @@ ;; For Emacs <22.2 and XEmacs. (eval-and-compile - (unless (fboundp 'declare-function) (defmacro declare-function (&rest r)))) + (unless (fboundp 'declare-function) (defmacro declare-function (&rest r))) + ;; In Emacs 24, `open-protocol-stream' is an autoloaded alias for + ;; `make-network-stream'. + (unless (fboundp 'open-protocol-stream) + (require 'proto-stream))) (require 'nnheader) (require 'nnoo) (require 'gnus-util) (require 'gnus) -(require 'proto-stream) (require 'gnus-group) ;; gnus-group-name-charset (nnoo-declare nntp) diff --git a/lisp/gnus/proto-stream.el b/lisp/net/network-stream.el similarity index 57% rename from lisp/gnus/proto-stream.el rename to lisp/net/network-stream.el index 45cc974e7a9..070cd2641db 100644 --- a/lisp/gnus/proto-stream.el +++ b/lisp/net/network-stream.el @@ -1,4 +1,4 @@ -;;; proto-stream.el --- negotiating TLS, STARTTLS and other connections +;;; network-stream.el --- open network processes, possibly with encryption ;; Copyright (C) 2010-2011 Free Software Foundation, Inc. @@ -22,20 +22,14 @@ ;;; 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. +;; This library provides the function `open-network-stream', which provides a +;; higher-level interface for opening TCP network processes than the built-in +;; function `make-network-process'. In addition to plain connections, it +;; supports TLS/SSL and STARTTLS connections. ;; Usage example: -;; (open-protocol-stream +;; (open-network-stream ;; "*nnimap*" buffer address port ;; :type 'network ;; :capability-command "1 CAPABILITY\r\n" @@ -55,14 +49,24 @@ (proc type &optional priority-string trustfiles keyfiles)) ;;;###autoload -(defun open-protocol-stream (name buffer host service &rest parameters) - "Open a network stream to HOST, possibly with encryption. +(defun open-network-stream (name buffer host service &rest parameters) + "Open a TCP connection to HOST, optionally with encryption. Normally, return a network process object; with a non-nil :return-list parameter, return a list instead (see below). +Input and output work as for subprocesses; `delete-process' +closes it. + +NAME is the name for the process. It is modified if necessary to + make it unique. +BUFFER is a buffer or buffer name to associate with the process. + Process output goes at end of that buffer. BUFFER may be nil, + meaning that the process is not associated with any buffer. +HOST is the name or IP address of the host to connect to. +SERVICE is the name of the service desired, or an integer specifying + a port number to connect to. -The first four parameters, NAME, BUFFER, HOST, and SERVICE, have -the same meanings as in `open-network-stream'. The remaining -PARAMETERS should be a sequence of keywords and values: +The remaining PARAMETERS should be a sequence of keywords and +values: :type specifies the connection type, one of the following: nil or `network' @@ -92,7 +96,6 @@ PARAMETERS should be a sequence of keywords and values: or `tls' (TLS-encrypted). :end-of-command specifies a regexp matching the end of a command. - If non-nil, it defaults to \"\\n\". :success specifies a regexp matching a message indicating a successful STARTTLS negotiation. For instance, the default @@ -106,6 +109,8 @@ PARAMETERS should be a sequence of keywords and values: This function should take one parameter, the response to the capability command, and should return the command to switch on STARTTLS if the server supports STARTTLS, and nil otherwise." + (unless (featurep 'make-network-process) + (error "Emacs was compiled without networking support")) (let ((type (plist-get parameters :type)) (return-list (plist-get parameters :return-list))) (if (and (not return-list) @@ -113,21 +118,24 @@ PARAMETERS should be a sequence of keywords and values: (and (memq type '(nil network)) (not (and (plist-get parameters :success) (plist-get parameters :capability-command)))))) - ;; The simplest case is equivalent to `open-network-stream'. - (open-network-stream name buffer host service) - ;; For everything else, refer to proto-stream-open-*. - (unless (plist-get parameters :end-of-command) - (setq parameters (append '(:end-of-command "\r\n") parameters))) - (let* ((connection-function - (cond - ((eq type 'plain) 'proto-stream-open-plain) - ((memq type '(nil network starttls)) - 'proto-stream-open-starttls) - ((memq type '(tls ssl)) 'proto-stream-open-tls) - ((eq type 'shell) 'proto-stream-open-shell) - (t (error "Invalid connection type %s" type)))) - (result (funcall connection-function - name buffer host service parameters))) + ;; The simplest case: wrapper around `make-network-process'. + (make-network-process :name name :buffer buffer + :host host :service service) + (let ((work-buffer (or buffer + (generate-new-buffer " *stream buffer*"))) + (fun (cond ((eq type 'plain) 'network-stream-open-plain) + ((memq type '(nil network starttls)) + 'network-stream-open-starttls) + ((memq type '(tls ssl)) 'network-stream-open-tls) + ((eq type 'shell) 'network-stream-open-shell) + (t (error "Invalid connection type %s" type)))) + result) + (unwind-protect + (setq result (funcall fun name work-buffer host service parameters)) + (unless buffer + (and (processp (car result)) + (set-process-buffer (car result) nil)) + (kill-buffer work-buffer))) (if return-list (list (car result) :greeting (nth 1 result) @@ -135,16 +143,20 @@ PARAMETERS should be a sequence of keywords and values: :type (nth 3 result)) (car result)))))) -(defun proto-stream-open-plain (name buffer host service parameters) +;;;###autoload +(defalias 'open-protocol-stream 'open-network-stream) + +(defun network-stream-open-plain (name buffer host service parameters) (let ((start (with-current-buffer buffer (point))) - (stream (open-network-stream name buffer host service))) + (stream (make-network-process :name name :buffer buffer + :host host :service service))) (list stream - (proto-stream-get-response stream start + (network-stream-get-response stream start (plist-get parameters :end-of-command)) nil 'plain))) -(defun proto-stream-open-starttls (name buffer host service parameters) +(defun network-stream-open-starttls (name buffer host service parameters) (let* ((start (with-current-buffer buffer (point))) (require-tls (eq (plist-get parameters :type) 'starttls)) (starttls-function (plist-get parameters :starttls-function)) @@ -152,11 +164,10 @@ PARAMETERS should be a sequence of keywords and values: (capability-command (plist-get parameters :capability-command)) (eoc (plist-get parameters :end-of-command)) ;; Return (STREAM GREETING CAPABILITIES RESULTING-TYPE) - (stream (open-network-stream name buffer host service)) - (greeting (proto-stream-get-response stream start eoc)) - (capabilities (when capability-command - (proto-stream-command stream - capability-command eoc))) + (stream (make-network-process :name name :buffer buffer + :host host :service service)) + (greeting (network-stream-get-response stream start eoc)) + (capabilities (network-stream-command stream capability-command eoc)) (resulting-type 'plain) starttls-command) @@ -179,9 +190,9 @@ PARAMETERS should be a sequence of keywords and values: ;; care about the identity of the peer. (cons "--insecure" starttls-extra-arguments)))) (setq stream (starttls-open-stream name buffer host service))) - (proto-stream-get-response stream start eoc)) + (network-stream-get-response stream start eoc)) (when (string-match success-string - (proto-stream-command stream starttls-command eoc)) + (network-stream-command stream starttls-command eoc)) ;; The server said it was OK to begin STARTTLS negotiations. (if (fboundp 'open-gnutls-stream) (gnutls-negotiate stream nil) @@ -192,11 +203,13 @@ PARAMETERS should be a sequence of keywords and values: ;; We didn't successfully negotiate STARTTLS; if TLS ;; isn't demanded, reopen an unencrypted connection. (unless require-tls - (setq stream (open-network-stream name buffer host service)) - (proto-stream-get-response stream start eoc))) + (setq stream + (make-network-process :name name :buffer buffer + :host host :service service)) + (network-stream-get-response stream start eoc))) ;; Re-get the capabilities, which may have now changed. (setq capabilities - (proto-stream-command stream capability-command eoc)))) + (network-stream-command stream capability-command eoc)))) ;; If TLS is mandatory, close the connection if it's unencrypted. (and require-tls @@ -205,70 +218,69 @@ PARAMETERS should be a sequence of keywords and values: ;; Return value: (list stream greeting capabilities resulting-type))) -(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 eoc))) - -(defun proto-stream-get-response (stream start end-of-command) - (with-current-buffer (process-buffer stream) - (save-excursion - (goto-char start) - (while (and (memq (process-status stream) - '(open run)) - (not (re-search-forward end-of-command 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) +(defun network-stream-command (stream command eoc) + (when command + (let ((start (with-current-buffer (process-buffer stream) (point-max)))) + (process-send-string stream command) + (network-stream-get-response stream start eoc)))) + +(defun network-stream-get-response (stream start end-of-command) + (when end-of-command + (with-current-buffer (process-buffer stream) + (save-excursion + (goto-char start) + (while (and (memq (process-status stream) '(open run)) + (not (re-search-forward end-of-command nil t))) + (accept-process-output stream 0 50) + (goto-char start)) + ;; Return the data we got back, or nil if the process died. + (unless (= start (point)) + (buffer-substring start (point))))))) + +(defun network-stream-open-tls (name buffer host service parameters) (with-current-buffer buffer - (let ((start (point-max)) - (stream - (funcall (if (fboundp 'open-gnutls-stream) - 'open-gnutls-stream - 'open-tls-stream) - name buffer host service)) - (eoc (plist-get parameters :end-of-command))) + (let* ((start (point-max)) + (use-builtin-gnutls (fboundp 'open-gnutls-stream)) + (stream + (funcall (if use-builtin-gnutls + 'open-gnutls-stream + 'open-tls-stream) + name buffer host service)) + (eoc (plist-get parameters :end-of-command))) (if (null stream) (list nil nil nil 'plain) ;; 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 eoc) + (when (and (null use-builtin-gnutls) eoc) + (network-stream-get-response stream start eoc) (goto-char (point-min)) (when (re-search-forward eoc nil t) (goto-char (match-beginning 0)) (delete-region (point-min) (line-beginning-position)))) - (proto-stream-capability-open start stream parameters 'tls))))) + (let* ((capability-command (plist-get parameters :capability-command))) + (list stream + (network-stream-get-response stream start eoc) + (network-stream-command stream capability-command eoc) + 'tls)))))) -(defun proto-stream-open-shell (name buffer host service parameters) +(defun network-stream-open-shell (name buffer host service parameters) (require 'format-spec) - (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 - (plist-get parameters :shell-command) - (format-spec-make - ?s host - ?p service)))) - parameters 'plain)) - -(defun proto-stream-capability-open (start stream parameters stream-type) (let* ((capability-command (plist-get parameters :capability-command)) (eoc (plist-get parameters :end-of-command)) - (greeting (proto-stream-get-response stream start eoc))) - (list stream greeting - (and capability-command - (proto-stream-command stream capability-command eoc)) - stream-type))) + (start (with-current-buffer buffer (point))) + (stream (let ((process-connection-type nil)) + (start-process name buffer shell-file-name + shell-command-switch + (format-spec + (plist-get parameters :shell-command) + (format-spec-make + ?s host + ?p service)))))) + (list stream + (network-stream-get-response stream start eoc) + (network-stream-command stream capability-command eoc) + 'plain))) -(provide 'proto-stream) +(provide 'network-stream) -;;; proto-stream.el ends here +;;; network-stream.el ends here diff --git a/lisp/subr.el b/lisp/subr.el index e6e0c62e0b4..387d538b69d 100644 --- a/lisp/subr.el +++ b/lisp/subr.el @@ -1792,28 +1792,6 @@ Signal an error if the program returns with a non-zero exit status." (forward-line 1)) (nreverse lines))))) -;; open-network-stream is a wrapper around make-network-process. - -(when (featurep 'make-network-process) - (defun open-network-stream (name buffer host service) - "Open a TCP connection for a service to a host. -Returns a subprocess-object to represent the connection. -Input and output work as for subprocesses; `delete-process' closes it. - -NAME is the name for the process. It is modified if necessary to make - it unique. -BUFFER is the buffer (or buffer name) to associate with the - process. Process output goes at end of that buffer. BUFFER may - be nil, meaning that this process is not associated with any buffer. -HOST is the name or IP address of the host to connect to. -SERVICE is the name of the service desired, or an integer specifying - a port number to connect to. - -This is a wrapper around `make-network-process', and only offers a -subset of its functionality." - (make-network-process :name name :buffer buffer - :host host :service service))) - ;; compatibility (make-obsolete diff --git a/lisp/url/url-gw.el b/lisp/url/url-gw.el index 2ba23583528..7d80f2f6725 100644 --- a/lisp/url/url-gw.el +++ b/lisp/url/url-gw.el @@ -28,8 +28,6 @@ ;; Fixme: support SSH explicitly or via a url-gateway-rlogin-program? (autoload 'socks-open-network-stream "socks") -(autoload 'open-ssl-stream "ssl") -(autoload 'open-tls-stream "tls") (defgroup url-gateway nil "URL gateway variables." @@ -219,13 +217,6 @@ Might do a non-blocking connection; use `process-status' to check." host)) 'native url-gateway-method)) -;;; ;; This hack is for OS/2 Emacs so that it will not do bogus CRLF -;;; ;; conversions while trying to be 'helpful' -;;; (tcp-binary-process-output-services (if (stringp service) -;;; (list service) -;;; (list service -;;; (int-to-string service)))) - ;; An attempt to deal with denied connections, and attempt ;; to reconnect (cur-retries 0) @@ -243,19 +234,15 @@ Might do a non-blocking connection; use `process-status' to check." (let ((coding-system-for-read 'binary) (coding-system-for-write 'binary)) (setq conn (case gw-method - (tls - (funcall (if (fboundp 'open-gnutls-stream) - 'open-gnutls-stream - 'open-tls-stream) - name buffer host service)) - (ssl - (open-ssl-stream name buffer host service)) - ((native) - ;; Use non-blocking socket if we can. - (make-network-process :name name :buffer buffer - :host host :service service - :nowait - (featurep 'make-network-process '(:nowait t)))) + ((tls ssl native) + (if (eq gw-method 'native) + (setq gw-method 'plain)) + (open-network-stream + name buffer host service + :type gw-method + ;; Use non-blocking socket if we can. + :nowait (featurep 'make-network-process + '(:nowait t)))) (socks (socks-open-network-stream name buffer host service)) (telnet @@ -264,13 +251,7 @@ Might do a non-blocking connection; use `process-status' to check." (url-open-rlogin name buffer host service)) (otherwise (error "Bad setting of url-gateway-method: %s" - url-gateway-method))))) - ;; Ignoring errors here seems wrong. E.g. it'll throw away the - ;; error signaled two lines above. It was also found inconvenient - ;; during debugging. - ;; (error - ;; (setq conn nil)) - ) + url-gateway-method)))))) conn))) (provide 'url-gw) -- 2.39.2