Re: url-retrieve may cause hang

[Magnus Henoch]

Sorry about my delay in answering...

Chong Yidong <address@hidden> writes:

> Richard Stallman <address@hidden> writes:
>
>>     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).
>>
>> Is this new argument _unconditionally_ present?
>
>>From my reading of the code, it is unconditionally present (though it
> can be an empty list).

Exactly.

>> I can't tell, and I see comments that seem to suggest
>> that it might not be so:
>>
>> +       (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)))
>
> The car of url-callback-arguments is the new STATUS argument, so this
> is correct.

Yes.

>> And this:
>>
>>       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).
>
> This is pretty clear: it says there is a STATUS argument; it
> definitely doesn't say that argument can be elided (and it isn't).

Yes, that's what I wanted to say.

>> I don't like that variability, and it is easy to avoid.  If we are to
>> change the API of these callbacks now, let's change it to something
>> more consistent: add a single argument unconditionally.  That added
>> argument can be a property list in which :redirect and :error may
>> occur.
>
> I don't see anything wrong with the patch.  I suggest checking it in
> and beginning the pretest.  OK?

I found that the patch breaks url-retrieve-synchronously, because of
the removal of url-redirect-buffer.  It would be cleaner to remove it
and fix url-retrieve-synchronously to use something else, but now is
not the time, I think.  The attached patch replaces my previous one.
Should I commit it?

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   25 Oct 2006 22:50:23 -0000
***************
*** 1,3 ****
--- 1,20 ----
+ 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-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   25 Oct 2006 22:50:23 -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 25 Oct 2006 22:50:23 -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,537 ****
             (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
         ;; 401 Unauthorized
--- 521,541 ----
             (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)))
!               ;; 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-internal
!                   redirect-uri url-callback-function
!                   url-callback-arguments)
!                  (url-mark-buffer-as-dead (current-buffer)))))))
        (4                              ; Client error
         ;; 400 Bad Request
         ;; 401 Unauthorized
***************
*** 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
--- 657,669 ----
          ;; 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)))
--- 712,724 ----
          ;; 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
--- 1105,1142 ----
                                      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      25 Oct 2006 22:50:23 -0000
***************
*** 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)
--- 128,166 ----
  
  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 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 ****
--- 237,245 ----
                  ;; 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