Re: url-retrieve may cause hang

[Magnus Henoch]

Stefan Monnier <address@hidden> writes:

> Yes, this is a basic flaw in the design.  It would be good to fix it before
> the release.  Your suggestion of extending the :redirect to include other
> info sounds good.  Basically, the callback should be called with 2 args: the
> list CBARGS, and a "status" which can be nil (indicating the absence of
> anything noteworthy), or (:redirect URL), or (:error ERROR) where ERROR is
> of the form such that it can be used in (signal (car ERROR) (cdr ERROR)).

I made "status" an extra argument at the beginning of the argument
list (so if CBARGS has N elements, the callback is called with N+1
arguments).  I described this in the docstring of url-retrieve in my
patch below (not yet committed).

I'm not sure what the errors should be; I have two different ones:
(error connection-failed REASON :host HOST :service PORT)
(error http STATUS-CODE)
Should they be more specific?

I wrote some notes about dynamically bound variables in url-retrieve;
I haven't found any code in Emacs whose behaviour should be changed by
this patch.  However, programs are no longer able to bind variables
that affect the creation of the HTTP request.  That could be fixed by
making the appropriate variables buffer-local in url-http.

What do you think about my changes?

Magnus

cvs diff: Diffing .
Index: ChangeLog
===================================================================
RCS file: /sources/emacs/emacs/lisp/url/ChangeLog,v
retrieving revision 1.86
diff -c -r1.86 ChangeLog
*** ChangeLog   16 Oct 2006 14:28:46 -0000      1.86
--- ChangeLog   23 Oct 2006 01:54:56 -0000
***************
*** 1,3 ****
--- 1,21 ----
+ 2006-10-23  Magnus Henoch  <address@hidden>
+ 
+       * url-http.el (url-http-mark-connection-as-free): Verify that
+       connection is open before saving it.
+       (url-http-handle-authentication): Use url-retrieve-internal
+       instead of url-retrieve.
+       (url-http-parse-headers): Adapt to new callback interface.
+       (url-http): Handle non-blocking connections.
+       (url-http-async-sentinel): Create.
+ 
+       * url.el (url-redirect-buffer): Remove.
+       (url-retrieve): Update docstring for new callback interface.
+       Remove all code.
+       (url-retrieve-internal): Move code from url-retrieve here.
+ 
+       * url-gw.el (url-open-stream): Use a non-blocking socket for
+       `native' gateway method, if available.
+ 
  2006-10-16  Magnus Henoch  <address@hidden>
  
        * url-http.el (url-https-create-secure-wrapper): Always use tls
Index: url-gw.el
===================================================================
RCS file: /sources/emacs/emacs/lisp/url/url-gw.el,v
retrieving revision 1.13
diff -c -r1.13 url-gw.el
*** url-gw.el   26 Apr 2006 20:40:18 -0000      1.13
--- url-gw.el   23 Oct 2006 01:54:57 -0000
***************
*** 210,216 ****
  (defun url-open-stream (name buffer host service)
    "Open a stream to HOST, possibly via a gateway.
  Args per `open-network-stream'.
! Will not make a connection if `url-gateway-unplugged' is non-nil."
    (unless url-gateway-unplugged
      (let ((gw-method (if (and url-gateway-local-host-regexp
                              (not (eq 'tls url-gateway-method))
--- 210,217 ----
  (defun url-open-stream (name buffer host service)
    "Open a stream to HOST, possibly via a gateway.
  Args per `open-network-stream'.
! Will not make a connection if `url-gateway-unplugged' is non-nil.
! Might do a non-blocking connection; use `process-status' to check."
    (unless url-gateway-unplugged
      (let ((gw-method (if (and url-gateway-local-host-regexp
                              (not (eq 'tls url-gateway-method))
***************
*** 249,255 ****
                         (ssl
                          (open-ssl-stream name buffer host service))
                         ((native)
!                         (open-network-stream name buffer host service))
                         (socks
                          (socks-open-network-stream name buffer host service))
                         (telnet
--- 250,260 ----
                         (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 
!                                               (and nil (featurep 
'make-network-process '(:nowait t)))))
                         (socks
                          (socks-open-network-stream name buffer host service))
                         (telnet
Index: url-http.el
===================================================================
RCS file: /sources/emacs/emacs/lisp/url/url-http.el,v
retrieving revision 1.35
diff -c -r1.35 url-http.el
*** url-http.el 16 Oct 2006 14:28:46 -0000      1.35
--- url-http.el 23 Oct 2006 01:54:57 -0000
***************
*** 92,102 ****
  
  (defun url-http-mark-connection-as-free (host port proc)
    (url-http-debug "Marking connection as free: %s:%d %S" host port proc)
!   (set-process-buffer proc nil)
!   (set-process-sentinel proc 'url-http-idle-sentinel)
!   (puthash (cons host port)
!             (cons proc (gethash (cons host port) url-http-open-connections))
!             url-http-open-connections)
    nil)
  
  (defun url-http-find-free-connection (host port)
--- 92,103 ----
  
  (defun url-http-mark-connection-as-free (host port proc)
    (url-http-debug "Marking connection as free: %s:%d %S" host port proc)
!   (when (memq (process-status proc) '(open run))
!     (set-process-buffer proc nil)
!     (set-process-sentinel proc 'url-http-idle-sentinel)
!     (puthash (cons host port)
!            (cons proc (gethash (cons host port) url-http-open-connections))
!            url-http-open-connections))
    nil)
  
  (defun url-http-find-free-connection (host port)
***************
*** 336,343 ****
          (let ((url-request-method url-http-method)
                (url-request-data url-http-data)
                (url-request-extra-headers url-http-extra-headers))
!           (url-retrieve url url-callback-function
!                           url-callback-arguments)))))))
  
  (defun url-http-parse-response ()
    "Parse just the response code."
--- 337,344 ----
          (let ((url-request-method url-http-method)
                (url-request-data url-http-data)
                (url-request-extra-headers url-http-extra-headers))
!           (url-retrieve-internal url url-callback-function
!                                  url-callback-arguments)))))))
  
  (defun url-http-parse-response ()
    "Parse just the response code."
***************
*** 520,536 ****
             (let ((url-request-method url-http-method)
                 (url-request-data url-http-data)
                 (url-request-extra-headers url-http-extra-headers))
!              ;; Put in the current buffer a forwarding pointer to the new
!              ;; destination buffer.
!              ;; FIXME: This is a hack to fix url-retrieve-synchronously
!              ;; without changing the API.  Instead url-retrieve should
!              ;; either simply not return the "destination" buffer, or it
!              ;; should take an optional `dest-buf' argument.
!              (set (make-local-variable 'url-redirect-buffer)
!                   (url-retrieve redirect-uri url-callback-function
!                                 (cons :redirect
!                                       (cons redirect-uri
!                                             url-callback-arguments))))
             (url-mark-buffer-as-dead (current-buffer))))))
        (4                              ; Client error
         ;; 400 Bad Request
--- 521,533 ----
             (let ((url-request-method url-http-method)
                 (url-request-data url-http-data)
                 (url-request-extra-headers url-http-extra-headers))
!            ;; Remember that the request was redirected.
!            (setf (car url-callback-arguments)
!                  (nconc (list :redirect redirect-uri)
!                         (car url-callback-arguments)))
!            (url-retrieve-internal
!             redirect-uri url-callback-function
!             url-callback-arguments)
             (url-mark-buffer-as-dead (current-buffer))))))
        (4                              ; Client error
         ;; 400 Bad Request
***************
*** 653,659 ****
          ;; The request could not be understood by the server due to
          ;; malformed syntax.  The client SHOULD NOT repeat the
          ;; request without modifications.
!         (setq success t))))
        (5
         ;; 500 Internal server error
         ;; 501 Not implemented
--- 650,662 ----
          ;; The request could not be understood by the server due to
          ;; malformed syntax.  The client SHOULD NOT repeat the
          ;; request without modifications.
!         (setq success t)))
!        ;; Tell the callback that an error occurred, and what the
!        ;; status code was.
!        (when success
!        (setf (car url-callback-arguments)
!              (nconc (list :error (list 'error 'http url-http-response-status))
!                     (car url-callback-arguments)))))
        (5
         ;; 500 Internal server error
         ;; 501 Not implemented
***************
*** 702,708 ****
          ;; which received this status code was the result of a user
          ;; action, the request MUST NOT be repeated until it is
          ;; requested by a separate user action.
!         nil)))
        (otherwise
         (error "Unknown class of HTTP response code: %d (%d)"
              class url-http-response-status)))
--- 705,717 ----
          ;; which received this status code was the result of a user
          ;; action, the request MUST NOT be repeated until it is
          ;; requested by a separate user action.
!         nil))
!        ;; Tell the callback that an error occurred, and what the
!        ;; status code was.
!        (when success
!        (setf (car url-callback-arguments)
!              (nconc (list :error (list 'error 'http url-http-response-status))
!                     (car url-callback-arguments)))))
        (otherwise
         (error "Unknown class of HTTP response code: %d (%d)"
              class url-http-response-status)))
***************
*** 1089,1099 ****
                                      url-current-object))
  
        (set-process-buffer connection buffer)
-       (set-process-sentinel connection 'url-http-end-of-document-sentinel)
        (set-process-filter connection 'url-http-generic-filter)
!       (process-send-string connection (url-http-create-request url))))
      buffer))
  
  ;; Since Emacs 19/20 does not allow you to change the
  ;; `after-change-functions' hook in the midst of running them, we fake
  ;; an after change by hooking into the process filter and inserting
--- 1098,1135 ----
                                      url-current-object))
  
        (set-process-buffer connection buffer)
        (set-process-filter connection 'url-http-generic-filter)
!       (let ((status (process-status connection)))
!         (cond
!          ((eq status 'connect)
!           ;; Asynchronous connection
!           (set-process-sentinel connection 'url-http-async-sentinel))
!          ((eq status 'failed)
!           ;; Asynchronous connection failed
!           (error "Could not create connection to %s:%d" (url-host url)
!                  (url-port url)))
!          (t
!           (set-process-sentinel connection 'url-http-end-of-document-sentinel)
!           (process-send-string connection (url-http-create-request url)))))))
      buffer))
  
+ (defun url-http-async-sentinel (proc why)
+   (declare (special url-callback-arguments))
+   ;; We are performing an asynchronous connection, and a status change
+   ;; has occurred.
+   (with-current-buffer (process-buffer proc)
+     (cond
+      ((string= (substring why 0 4) "open")
+       (set-process-sentinel proc 'url-http-end-of-document-sentinel)
+       (process-send-string proc (url-http-create-request url-current-object)))
+      (t
+       (setf (car url-callback-arguments)
+           (nconc (list :error (list 'error 'connection-failed why
+                                     :host (url-host url-current-object)
+                                     :service (url-port url-current-object)))
+                  (car url-callback-arguments)))
+       (url-http-activate-callback)))))
+ 
  ;; Since Emacs 19/20 does not allow you to change the
  ;; `after-change-functions' hook in the midst of running them, we fake
  ;; an after change by hooking into the process filter and inserting
Index: url.el
===================================================================
RCS file: /sources/emacs/emacs/lisp/url/url.el,v
retrieving revision 1.21
diff -c -r1.21 url.el
*** url.el      20 Feb 2006 21:54:08 -0000      1.21
--- url.el      23 Oct 2006 01:54:57 -0000
***************
*** 115,126 ****
  ;;; Retrieval functions
  
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  
- (defvar url-redirect-buffer nil
-   "New buffer into which the retrieval will take place.
- Sometimes while retrieving a URL, the URL library needs to use another buffer
- than the one returned initially by `url-retrieve'.  In this case, it sets this
- variable in the original buffer as a forwarding pointer.")
- 
  ;;;###autoload
  (defun url-retrieve (url callback &optional cbargs)
    "Retrieve URL asynchronously and call CALLBACK with CBARGS when finished.
--- 115,120 ----
***************
*** 128,140 ****
  
  CALLBACK is called when the object has been completely retrieved, with
  the current buffer containing the object, and any MIME headers associated
! with it.  Normally it gets the arguments in the list CBARGS.
! However, if what we find is a redirect, CALLBACK is given
! two additional args, `:redirect' and the redirected URL,
! followed by CBARGS.
  
  Return the buffer URL will load into, or nil if the process has
! already completed."
    (url-do-setup)
    (url-gc-dead-buffers)
    (if (stringp url)
--- 122,160 ----
  
  CALLBACK is called when the object has been completely retrieved, with
  the current buffer containing the object, and any MIME headers associated
! with it.  It is called as (apply CALLBACK STATUS CBARGS), where STATUS
! is a list with an even number of elements representing what happened
! during the request, with most recent events first.  Each pair is one
! of:
! 
! \(:redirect REDIRECTED-TO) - the request was redirected to this URL
! \(:error (ERROR-SYMBOL . DATA)) - an error occurred.  The error can be
! signaled with (signal ERROR-SYMBOL DATA).
  
  Return the buffer URL will load into, or nil if the process has
! already completed (i.e. URL was a mailto URL or similar; in this case
! the callback is not called).
! 
! The variables `url-request-data', `url-request-method' and
! `url-request-extra-headers' can be dynamically bound around the
! request; dynamic binding of other variables doesn't necessarily
! take effect."
! ;;; XXX: There is code in Emacs, Gnus and W3 that does dynamic binding
! ;;; of the following variables around url-retrieve:
! ;;; url-standalone-mode, url-gateway-unplugged, w3-honor-stylesheets,
! ;;; url-confirmation-func, url-cookie-multiple-line,
! ;;; url-cookie-{{,secure-}storage,confirmation}
! ;;; url-standalone-mode and url-gateway-unplugged should work as
! ;;; usual.  url-confirmation-func is only used in nnwarchive.el and
! ;;; webmail.el; the latter should be updated.  Is
! ;;; url-cookie-multiple-line needed anymore?  The other url-cookie-*
! ;;; are (for now) only used in synchronous retrievals.
!   (url-retrieve-internal url callback (cons nil cbargs)))
! 
! (defun url-retrieve-internal (url callback cbargs)
!   "Internal function; external interface is `url-retrieve'.
! CBARGS is what the callback will actually receive - the first item is
! the list of events, as described in the docstring of `url-retrieve'."
    (url-do-setup)
    (url-gc-dead-buffers)
    (if (stringp url)
***************
*** 211,216 ****
--- 231,239 ----
                  ;; clear that it's a bug, but even then we need to decide how
                  ;; url-http can then warn us that the download has completed.
                  ;; In the mean time, we use this here workaround.
+               ;; XXX: The callback must always be called.  Any
+               ;; exception is a bug that should be fixed, not worked
+               ;; around.
                  (setq retrieval-done t))
              ;; We used to use `sit-for' here, but in some cases it wouldn't
              ;; work because apparently pending keyboard input would always