;;; url-http.el --- HTTP retrieval routines
-;; Copyright (C) 1999, 2001, 2004, 2005, 2006 Free Software Foundation, Inc.
+;; Copyright (C) 1999, 2001, 2004-2011 Free Software Foundation, Inc.
;; Author: Bill Perry <wmperry@gnu.org>
;; Keywords: comm, data, processes
;; This file is part of GNU Emacs.
;;
-;; GNU Emacs is free software; you can redistribute it and/or modify
+;; GNU Emacs is free software: you can redistribute it and/or modify
;; it under the terms of the GNU General Public License as published by
-;; the Free Software Foundation; either version 2, or (at your option)
-;; any later version.
-;;
+;; the Free Software Foundation, either version 3 of the License, or
+;; (at your option) any later version.
+
;; GNU Emacs is distributed in the hope that it will be useful,
;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
;; GNU General Public License for more details.
-;;
+
;; You should have received a copy of the GNU General Public License
-;; along with GNU Emacs; see the file COPYING. If not, write to the
-;; Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,
-;; Boston, MA 02110-1301, USA.
+;; along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>.
;;; Commentary:
(eval-when-compile (require 'cl))
(defvar url-http-extra-headers)
(defvar url-http-target-url)
+(defvar url-http-proxy)
+(defvar url-http-connection-opened)
(require 'url-gw)
(require 'url-util)
(require 'url-parse)
nil will explicitly close the connection to the server after every
request.")
+(defconst url-http-codes
+ '((100 continue "Continue with request")
+ (101 switching-protocols "Switching protocols")
+ (102 processing "Processing (Added by DAV)")
+ (200 OK "OK")
+ (201 created "Created")
+ (202 accepted "Accepted")
+ (203 non-authoritative "Non-authoritative information")
+ (204 no-content "No content")
+ (205 reset-content "Reset content")
+ (206 partial-content "Partial content")
+ (207 multi-status "Multi-status (Added by DAV)")
+ (300 multiple-choices "Multiple choices")
+ (301 moved-permanently "Moved permanently")
+ (302 found "Found")
+ (303 see-other "See other")
+ (304 not-modified "Not modified")
+ (305 use-proxy "Use proxy")
+ (307 temporary-redirect "Temporary redirect")
+ (400 bad-request "Bad Request")
+ (401 unauthorized "Unauthorized")
+ (402 payment-required "Payment required")
+ (403 forbidden "Forbidden")
+ (404 not-found "Not found")
+ (405 method-not-allowed "Method not allowed")
+ (406 not-acceptable "Not acceptable")
+ (407 proxy-authentication-required "Proxy authentication required")
+ (408 request-timeout "Request time-out")
+ (409 conflict "Conflict")
+ (410 gone "Gone")
+ (411 length-required "Length required")
+ (412 precondition-failed "Precondition failed")
+ (413 request-entity-too-large "Request entity too large")
+ (414 request-uri-too-large "Request-URI too large")
+ (415 unsupported-media-type "Unsupported media type")
+ (416 requested-range-not-satisfiable "Requested range not satisfiable")
+ (417 expectation-failed "Expectation failed")
+ (422 unprocessable-entity "Unprocessable Entity (Added by DAV)")
+ (423 locked "Locked")
+ (424 failed-Dependency "Failed Dependency")
+ (500 internal-server-error "Internal server error")
+ (501 not-implemented "Not implemented")
+ (502 bad-gateway "Bad gateway")
+ (503 service-unavailable "Service unavailable")
+ (504 gateway-timeout "Gateway time-out")
+ (505 http-version-not-supported "HTTP version not supported")
+ (507 insufficient-storage "Insufficient storage")
+"The HTTP return codes and their text."))
+
;(eval-when-compile
;; These are all macros so that they are hidden from external sight
;; when the file is byte-compiled.
(defun url-http-mark-connection-as-busy (host port proc)
(url-http-debug "Marking connection as busy: %s:%d %S" host port proc)
+ (set-process-query-on-exit-flag proc t)
(puthash (cons host port)
(delq proc (gethash (cons host port) url-http-open-connections))
url-http-open-connections)
(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))
+ (when (memq (process-status proc) '(open run connect))
(set-process-buffer proc nil)
(set-process-sentinel proc 'url-http-idle-sentinel)
+ (set-process-query-on-exit-flag proc nil)
(puthash (cons host port)
(cons proc (gethash (cons host port) url-http-open-connections))
url-http-open-connections))
(let ((conns (gethash (cons host port) url-http-open-connections))
(found nil))
(while (and conns (not found))
- (if (not (memq (process-status (car conns)) '(run open)))
+ (if (not (memq (process-status (car conns)) '(run open connect)))
(progn
(url-http-debug "Cleaning up dead process: %s:%d %S"
host port (car conns))
(concat " (" (or url-system-type url-os-type) ")"))
(t "")))))
-(defun url-http-create-request (url &optional ref-url)
- "Create an HTTP request for URL, referred to by REF-URL."
- (declare (special proxy-object proxy-info
+(defun url-http-create-request (&optional ref-url)
+ "Create an HTTP request for `url-http-target-url', referred to by REF-URL."
+ (declare (special proxy-info
url-http-method url-http-data
url-http-extra-headers))
(let* ((extra-headers)
(request nil)
(no-cache (cdr-safe (assoc "Pragma" url-http-extra-headers)))
- (proxy-obj (and (boundp 'proxy-object) proxy-object))
+ (using-proxy url-http-proxy)
(proxy-auth (if (or (cdr-safe (assoc "Proxy-Authorization"
url-http-extra-headers))
- (not proxy-obj))
+ (not using-proxy))
nil
(let ((url-basic-auth-storage
'url-http-proxy-basic-auth-storage))
- (url-get-authentication url nil 'any nil))))
- (real-fname (concat (url-filename (or proxy-obj url))
- (url-recreate-url-attributes (or proxy-obj url))))
- (host (url-host (or proxy-obj url)))
+ (url-get-authentication url-http-target-url nil 'any nil))))
+ (real-fname (concat (url-filename url-http-target-url)
+ (url-recreate-url-attributes url-http-target-url)))
+ (host (url-host url-http-target-url))
(auth (if (cdr-safe (assoc "Authorization" url-http-extra-headers))
nil
(url-get-authentication (or
(and (boundp 'proxy-info)
proxy-info)
- url) nil 'any nil))))
+ url-http-target-url) nil 'any nil))))
(if (equal "" real-fname)
(setq real-fname "/"))
(setq no-cache (and no-cache (string-match "no-cache" no-cache)))
(list
;; The request
(or url-http-method "GET") " "
- (if proxy-obj (url-recreate-url proxy-obj) real-fname)
+ (if using-proxy (url-recreate-url url-http-target-url) real-fname)
" HTTP/" url-http-version "\r\n"
;; Version of MIME we speak
"MIME-Version: 1.0\r\n"
;; (maybe) Try to keep the connection open
- "Connection: " (if (or proxy-obj
+ "Connection: " (if (or using-proxy
(not url-http-attempt-keepalives))
"close" "keep-alive") "\r\n"
;; HTTP extensions we support
(format
"Extension: %s\r\n" url-extensions-header))
;; Who we want to talk to
- (if (/= (url-port (or proxy-obj url))
+ (if (/= (url-port url-http-target-url)
(url-scheme-get-property
- (url-type (or proxy-obj url)) 'default-port))
+ (url-type url-http-target-url) 'default-port))
(format
- "Host: %s:%d\r\n" host (url-port (or proxy-obj url)))
+ "Host: %s:%d\r\n" host (url-port url-http-target-url))
(format "Host: %s\r\n" host))
;; Who its from
(if url-personal-mail-address
auth
;; Cookies
(url-cookie-generate-header-lines host real-fname
- (equal "https" (url-type url)))
+ (equal "https" (url-type url-http-target-url)))
;; If-modified-since
(if (and (not no-cache)
(member url-http-method '("GET" nil)))
- (let ((tm (url-is-cached (or proxy-obj url))))
+ (let ((tm (url-is-cached url-http-target-url)))
(if tm
(concat "If-modified-since: "
(url-get-normalized-date tm) "\r\n"))))
;; End request
"\r\n"
;; Any data
- url-http-data))
+ url-http-data "\r\n"))
""))
(url-http-debug "Request is: \n%s" request)
request))
(declare (special status success url-http-method url-http-data
url-callback-function url-callback-arguments))
(url-http-debug "Handling %s authentication" (if proxy "proxy" "normal"))
- (let ((auth (or (mail-fetch-field (if proxy "proxy-authenticate" "www-authenticate"))
- "basic"))
+ (let ((auths (or (nreverse
+ (mail-fetch-field
+ (if proxy "proxy-authenticate" "www-authenticate")
+ nil nil t))
+ '("basic")))
(type nil)
(url (url-recreate-url url-current-object))
- (url-basic-auth-storage 'url-http-real-basic-auth-storage)
- )
-
- ;; Cheating, but who cares? :)
- (if proxy
- (setq url-basic-auth-storage 'url-http-proxy-basic-auth-storage))
-
- (setq auth (url-eat-trailing-space (url-strip-leading-spaces auth)))
- (if (string-match "[ \t]" auth)
- (setq type (downcase (substring auth 0 (match-beginning 0))))
- (setq type (downcase auth)))
+ (auth-url (url-recreate-url
+ (if (and proxy (boundp 'url-http-proxy))
+ url-http-proxy
+ url-current-object)))
+ (url-basic-auth-storage (if proxy
+ ;; Cheating, but who cares? :)
+ 'url-http-proxy-basic-auth-storage
+ 'url-http-real-basic-auth-storage))
+ auth
+ (strength 0))
+
+ ;; find strongest supported auth
+ (dolist (this-auth auths)
+ (setq this-auth (url-eat-trailing-space
+ (url-strip-leading-spaces
+ this-auth)))
+ (let* ((this-type
+ (if (string-match "[ \t]" this-auth)
+ (downcase (substring this-auth 0 (match-beginning 0)))
+ (downcase this-auth)))
+ (registered (url-auth-registered this-type))
+ (this-strength (cddr registered)))
+ (when (and registered (> this-strength strength))
+ (setq auth this-auth
+ type this-type
+ strength this-strength))))
(if (not (url-auth-registered type))
(progn
" send it to " url-bug-address ".<hr>")
(setq status t))
(let* ((args (url-parse-args (subst-char-in-string ?, ?\; auth)))
- (auth (url-get-authentication url (cdr-safe (assoc "realm" args))
+ (auth (url-get-authentication auth-url
+ (cdr-safe (assoc "realm" args))
type t args)))
(if (not auth)
(setq success t)
(defun url-http-parse-response ()
"Parse just the response code."
- (declare (special url-http-end-of-headers url-http-response-status))
+ (declare (special url-http-end-of-headers url-http-response-status
+ url-http-response-version))
(if (not url-http-end-of-headers)
(error "Trying to parse HTTP response code in odd buffer: %s" (buffer-name)))
(url-http-debug "url-http-parse-response called in (%s)" (buffer-name))
(goto-char (point-min))
(skip-chars-forward " \t\n") ; Skip any blank crap
(skip-chars-forward "HTTP/") ; Skip HTTP Version
- (read (current-buffer))
+ (setq url-http-response-version
+ (buffer-substring (point)
+ (progn
+ (skip-chars-forward "[0-9].")
+ (point))))
(setq url-http-response-status (read (current-buffer))))
(defun url-http-handle-cookies ()
"Handle all set-cookie / set-cookie2 headers in an HTTP response.
The buffer must already be narrowed to the headers, so `mail-fetch-field' will
work correctly."
- (let ((cookies (mail-fetch-field "Set-Cookie" nil nil t))
- (cookies2 (mail-fetch-field "Set-Cookie2" nil nil t))
- (url-current-object url-http-target-url))
+ (let ((cookies (nreverse (mail-fetch-field "Set-Cookie" nil nil t)))
+ (cookies2 (nreverse (mail-fetch-field "Set-Cookie2" nil nil t))))
(and cookies (url-http-debug "Found %d Set-Cookie headers" (length cookies)))
(and cookies2 (url-http-debug "Found %d Set-Cookie2 headers" (length cookies2)))
(while cookies
;; The comments after each status code handled are taken from RFC
;; 2616 (HTTP/1.1)
(declare (special url-http-end-of-headers url-http-response-status
+ url-http-response-version
url-http-method url-http-data url-http-process
url-callback-function url-callback-arguments))
(mail-narrow-to-head)
;;(narrow-to-region (point-min) url-http-end-of-headers)
(let ((connection (mail-fetch-field "Connection")))
- (if (and connection
- (string= (downcase connection) "close"))
+ ;; In HTTP 1.0, keep the connection only if there is a
+ ;; "Connection: keep-alive" header.
+ ;; In HTTP 1.1 (and greater), keep the connection unless there is a
+ ;; "Connection: close" header
+ (cond
+ ((string= url-http-response-version "1.0")
+ (unless (and connection
+ (string= (downcase connection) "keep-alive"))
(delete-process url-http-process)))
- (let ((class nil)
- (success nil))
+ (t
+ (when (and connection
+ (string= (downcase connection) "close"))
+ (delete-process url-http-process)))))
+ (let ((buffer (current-buffer))
+ (class nil)
+ (success nil)
+ ;; other status symbols: jewelry and luxury cars
+ (status-symbol (cadr (assq url-http-response-status url-http-codes)))
+ ;; The filename part of a URL could be in remote file syntax,
+ ;; see Bug#6717 for an example. We disable file name
+ ;; handlers, therefore.
+ (file-name-handler-alist nil))
(setq class (/ url-http-response-status 100))
(url-http-debug "Parsed HTTP headers: class=%d status=%d" class url-http-response-status)
(url-http-handle-cookies)
;; 100 = Continue with request
;; 101 = Switching protocols
;; 102 = Processing (Added by DAV)
- (url-mark-buffer-as-dead (current-buffer))
+ (url-mark-buffer-as-dead buffer)
(error "HTTP responses in class 1xx not supported (%d)" url-http-response-status))
(2 ; Success
;; 200 Ok
;; 205 Reset content
;; 206 Partial content
;; 207 Multi-status (Added by DAV)
- (case url-http-response-status
- ((204 205)
+ (case status-symbol
+ ((no-content reset-content)
;; No new data, just stay at the same document
- (url-mark-buffer-as-dead (current-buffer))
+ (url-mark-buffer-as-dead buffer)
(setq success t))
(otherwise
;; Generic success for all others. Store in the cache, and
;; mark it as successful.
(widen)
(if (and url-automatic-caching (equal url-http-method "GET"))
- (url-store-in-cache (current-buffer)))
+ (url-store-in-cache buffer))
(setq success t))))
(3 ; Redirection
;; 300 Multiple choices
;; 307 Temporary redirect
(let ((redirect-uri (or (mail-fetch-field "Location")
(mail-fetch-field "URI"))))
- (case url-http-response-status
- (300
+ (case status-symbol
+ (multiple-choices ; 300
;; Quoth the spec (section 10.3.1)
;; -------------------------------
;; The requested resource corresponds to any one of a set of
;; We do not support agent-driven negotiation, so we just
;; redirect to the preferred URI if one is provided.
nil)
- ((301 302 307)
+ ((moved-permanently found temporary-redirect) ; 301 302 307
;; If the 301|302 status code is received in response to a
;; request other than GET or HEAD, the user agent MUST NOT
;; automatically redirect the request unless it can be
url-http-method url-http-response-status)
(setq url-http-method "GET"
url-http-data nil)))
- (303
+ (see-other ; 303
;; The response to the request can be found under a different
;; URI and SHOULD be retrieved using a GET method on that
;; resource.
(setq url-http-method "GET"
url-http-data nil))
- (304
+ (not-modified ; 304
;; The 304 response MUST NOT contain a message-body.
(url-http-debug "Extracting document from cache... (%s)"
(url-cache-create-filename (url-view-url t)))
(url-cache-extract (url-cache-create-filename (url-view-url t)))
(setq redirect-uri nil
success t))
- (305
+ (use-proxy ; 305
;; The requested resource MUST be accessed through the
;; proxy given by the Location field. The Location field
;; gives the URI of the proxy. The recipient is expected
(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))))))
+ ;; Check existing number of redirects
+ (if (or (< url-max-redirections 0)
+ (and (> url-max-redirections 0)
+ (let ((events (car url-callback-arguments))
+ (old-redirects 0))
+ (while events
+ (if (eq (car events) :redirect)
+ (setq old-redirects (1+ old-redirects)))
+ (and (setq events (cdr events))
+ (setq events (cdr events))))
+ (< old-redirects url-max-redirections))))
+ ;; url-max-redirections hasn't been reached, so go
+ ;; ahead and redirect.
+ (progn
+ ;; 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-silent url-current-object)))
+ (url-mark-buffer-as-dead buffer))
+ ;; We hit url-max-redirections, so issue an error and
+ ;; stop redirecting.
+ (url-http-debug "Maximum redirections reached")
+ (setf (car url-callback-arguments)
+ (nconc (list :error (list 'error 'http-redirect-limit
+ redirect-uri))
+ (car url-callback-arguments)))
+ (setq success t))))))
(4 ; Client error
;; 400 Bad Request
;; 401 Unauthorized
;; 422 Unprocessable Entity (Added by DAV)
;; 423 Locked
;; 424 Failed Dependency
- (case url-http-response-status
- (401
+ (case status-symbol
+ (unauthorized ; 401
;; The request requires user authentication. The response
;; MUST include a WWW-Authenticate header field containing a
;; challenge applicable to the requested resource. The
;; client MAY repeat the request with a suitable
;; Authorization header field.
(url-http-handle-authentication nil))
- (402
+ (payment-required ; 402
;; This code is reserved for future use
- (url-mark-buffer-as-dead (current-buffer))
+ (url-mark-buffer-as-dead buffer)
(error "Somebody wants you to give them money"))
- (403
+ (forbidden ; 403
;; The server understood the request, but is refusing to
;; fulfill it. Authorization will not help and the request
;; SHOULD NOT be repeated.
(setq success t))
- (404
+ (not-found ; 404
;; Not found
(setq success t))
- (405
+ (method-not-allowed ; 405
;; The method specified in the Request-Line is not allowed
;; for the resource identified by the Request-URI. The
;; response MUST include an Allow header containing a list of
;; valid methods for the requested resource.
(setq success t))
- (406
+ (not-acceptable ; 406
;; The resource identified by the request is only capable of
;; generating response entities which have content
;; characteristics nota cceptable according to the accept
;; headers sent in the request.
(setq success t))
- (407
+ (proxy-authentication-required ; 407
;; This code is similar to 401 (Unauthorized), but indicates
;; that the client must first authenticate itself with the
;; proxy. The proxy MUST return a Proxy-Authenticate header
;; field containing a challenge applicable to the proxy for
;; the requested resource.
(url-http-handle-authentication t))
- (408
+ (request-timeout ; 408
;; The client did not produce a request within the time that
;; the server was prepared to wait. The client MAY repeat
;; the request without modifications at any later time.
(setq success t))
- (409
+ (conflict ; 409
;; The request could not be completed due to a conflict with
;; the current state of the resource. This code is only
;; allowed in situations where it is expected that the user
;; information for the user to recognize the source of the
;; conflict.
(setq success t))
- (410
+ (gone ; 410
;; The requested resource is no longer available at the
;; server and no forwarding address is known.
(setq success t))
- (411
+ (length-required ; 411
;; The server refuses to accept the request without a defined
;; Content-Length. The client MAY repeat the request if it
;; adds a valid Content-Length header field containing the
;; `url-http-create-request' automatically calculates the
;; content-length.
(setq success t))
- (412
+ (precondition-failed ; 412
;; The precondition given in one or more of the
;; request-header fields evaluated to false when it was
;; tested on the server.
(setq success t))
- ((413 414)
+ ((request-entity-too-large request-uri-too-large) ; 413 414
;; The server is refusing to process a request because the
;; request entity|URI is larger than the server is willing or
;; able to process.
(setq success t))
- (415
+ (unsupported-media-type ; 415
;; The server is refusing to service the request because the
;; entity of the request is in a format not supported by the
;; requested resource for the requested method.
(setq success t))
- (416
+ (requested-range-not-satisfiable ; 416
;; A server SHOULD return a response with this status code if
;; a request included a Range request-header field, and none
;; of the range-specifier values in this field overlap the
;; current extent of the selected resource, and the request
;; did not include an If-Range request-header field.
(setq success t))
- (417
+ (expectation-failed ; 417
;; The expectation given in an Expect request-header field
;; could not be met by this server, or, if the server is a
;; proxy, the server has unambiguous evidence that the
;; 507 Insufficient storage
(setq success t)
(case url-http-response-status
- (501
+ (not-implemented ; 501
;; The server does not support the functionality required to
;; fulfill the request.
nil)
- (502
+ (bad-gateway ; 502
;; The server, while acting as a gateway or proxy, received
;; an invalid response from the upstream server it accessed
;; in attempting to fulfill the request.
nil)
- (503
+ (service-unavailable ; 503
;; The server is currently unable to handle the request due
;; to a temporary overloading or maintenance of the server.
;; The implication is that this is a temporary condition
;; header. If no Retry-After is given, the client SHOULD
;; handle the response as it would for a 500 response.
nil)
- (504
+ (gateway-timeout ; 504
;; The server, while acting as a gateway or proxy, did not
;; receive a timely response from the upstream server
;; specified by the URI (e.g. HTTP, FTP, LDAP) or some other
;; auxiliary server (e.g. DNS) it needed to access in
;; attempting to complete the request.
nil)
- (505
+ (http-version-not-supported ; 505
;; The server does not support, or refuses to support, the
;; HTTP protocol version that was used in the request
;; message.
nil)
- (507 ; DAV
+ (insufficient-storage ; 507 (DAV)
;; The method could not be performed on the resource
;; because the server is unable to store the representation
;; needed to successfully complete the request. This
(error "Unknown class of HTTP response code: %d (%d)"
class url-http-response-status)))
(if (not success)
- (url-mark-buffer-as-dead (current-buffer)))
+ (url-mark-buffer-as-dead buffer))
(url-http-debug "Finished parsing HTTP headers: %S" success)
(widen)
success))
;; These unfortunately cannot be macros... please ignore them!
(defun url-http-idle-sentinel (proc why)
- "Remove this (now defunct) process PROC from the list of open connections."
+ "Remove (now defunct) process PROC from the list of open connections."
(maphash (lambda (key val)
(if (memq proc val)
(puthash key (delq proc val) url-http-open-connections)))
(url-http-debug "url-http-end-of-document-sentinel in buffer (%s)"
(process-buffer proc))
(url-http-idle-sentinel proc why)
- (with-current-buffer (process-buffer proc)
- (goto-char (point-min))
- (if (not (looking-at "HTTP/"))
- ;; HTTP/0.9 just gets passed back no matter what
- (url-http-activate-callback)
- (if (url-http-parse-headers)
- (url-http-activate-callback)))))
+ (when (buffer-name (process-buffer proc))
+ (with-current-buffer (process-buffer proc)
+ (goto-char (point-min))
+ (if (not (looking-at "HTTP/"))
+ ;; HTTP/0.9 just gets passed back no matter what
+ (url-http-activate-callback)
+ (if (url-http-parse-headers)
+ (url-http-activate-callback))))))
(defun url-http-simple-after-change-function (st nd length)
;; Function used when we do NOT know how long the document is going to be
(progn
;; Found the end of the document! Wheee!
(url-display-percentage nil nil)
- (message "Reading... done.")
+ (url-lazy-message "Reading... done.")
(if (url-http-parse-headers)
(url-http-activate-callback)))))
(url-http-debug "Saw end of stream chunk!")
(setq read-next-chunk nil)
(url-display-percentage nil nil)
- (goto-char (match-end 1))
+ ;; Every chunk, even the last 0-length one, is
+ ;; terminated by CRLF. Skip it.
+ (when (looking-at "\r?\n")
+ (url-http-debug "Removing terminator of last chunk")
+ (delete-region (match-beginning 0) (match-end 0)))
(if (re-search-forward "^\r*$" nil t)
(url-http-debug "Saw end of trailers..."))
(if (url-http-parse-headers)
url-http-response-status))
(url-http-debug "url-http-wait-for-headers-change-function (%s)"
(buffer-name))
- (if (not (bobp))
- (let ((end-of-headers nil)
- (old-http nil)
- (content-length nil))
- (goto-char (point-min))
- (if (not (looking-at "^HTTP/[1-9]\\.[0-9]"))
- ;; Not HTTP/x.y data, must be 0.9
- ;; God, I wish this could die.
- (setq end-of-headers t
- url-http-end-of-headers 0
- old-http t)
- (if (re-search-forward "^\r*$" nil t)
- ;; Saw the end of the headers
- (progn
- (url-http-debug "Saw end of headers... (%s)" (buffer-name))
- (setq url-http-end-of-headers (set-marker (make-marker)
- (point))
- end-of-headers t)
- (url-http-clean-headers))))
-
- (if (not end-of-headers)
- ;; Haven't seen the end of the headers yet, need to wait
- ;; for more data to arrive.
- nil
- (if old-http
- (message "HTTP/0.9 How I hate thee!")
- (progn
- (url-http-parse-response)
- (mail-narrow-to-head)
- ;;(narrow-to-region (point-min) url-http-end-of-headers)
- (setq url-http-transfer-encoding (mail-fetch-field
- "transfer-encoding")
- url-http-content-type (mail-fetch-field "content-type"))
- (if (mail-fetch-field "content-length")
- (setq url-http-content-length
- (string-to-number (mail-fetch-field "content-length"))))
- (widen)))
- (if url-http-transfer-encoding
- (setq url-http-transfer-encoding
- (downcase url-http-transfer-encoding)))
-
- (cond
- ((or (= url-http-response-status 204)
- (= url-http-response-status 205))
- (url-http-debug "%d response must have headers only (%s)."
- url-http-response-status (buffer-name))
- (if (url-http-parse-headers)
- (url-http-activate-callback)))
- ((string= "HEAD" url-http-method)
- ;; A HEAD request is _ALWAYS_ terminated by the header
- ;; information, regardless of any entity headers,
- ;; according to section 4.4 of the HTTP/1.1 draft.
- (url-http-debug "HEAD request must have headers only (%s)."
- (buffer-name))
- (if (url-http-parse-headers)
- (url-http-activate-callback)))
- ((string= "CONNECT" url-http-method)
- ;; A CONNECT request is finished, but we cannot stick this
- ;; back on the free connectin list
- (url-http-debug "CONNECT request must have headers only.")
- (if (url-http-parse-headers)
- (url-http-activate-callback)))
- ((equal url-http-response-status 304)
- ;; Only allowed to have a header section. We have to handle
- ;; this here instead of in url-http-parse-headers because if
- ;; you have a cached copy of something without a known
- ;; content-length, and try to retrieve it from the cache, we'd
- ;; fall into the 'being dumb' section and wait for the
- ;; connection to terminate, which means we'd wait for 10
- ;; seconds for the keep-alives to time out on some servers.
- (if (url-http-parse-headers)
- (url-http-activate-callback)))
- (old-http
- ;; HTTP/0.9 always signaled end-of-connection by closing the
- ;; connection.
+ (let ((end-of-headers nil)
+ (old-http nil)
+ (process-buffer (current-buffer))
+ (content-length nil))
+ (when (not (bobp))
+ (goto-char (point-min))
+ (if (and (looking-at ".*\n") ; have one line at least
+ (not (looking-at "^HTTP/[1-9]\\.[0-9]")))
+ ;; Not HTTP/x.y data, must be 0.9
+ ;; God, I wish this could die.
+ (setq end-of-headers t
+ url-http-end-of-headers 0
+ old-http t)
+ (when (re-search-forward "^\r*$" nil t)
+ ;; Saw the end of the headers
+ (url-http-debug "Saw end of headers... (%s)" (buffer-name))
+ (setq url-http-end-of-headers (set-marker (make-marker)
+ (point))
+ end-of-headers t)
+ (url-http-clean-headers)))
+
+ (if (not end-of-headers)
+ ;; Haven't seen the end of the headers yet, need to wait
+ ;; for more data to arrive.
+ nil
+ (if old-http
+ (message "HTTP/0.9 How I hate thee!")
+ (progn
+ (url-http-parse-response)
+ (mail-narrow-to-head)
+ ;;(narrow-to-region (point-min) url-http-end-of-headers)
+ (setq url-http-transfer-encoding (mail-fetch-field
+ "transfer-encoding")
+ url-http-content-type (mail-fetch-field "content-type"))
+ (if (mail-fetch-field "content-length")
+ (setq url-http-content-length
+ (string-to-number (mail-fetch-field "content-length"))))
+ (widen)))
+ (when url-http-transfer-encoding
+ (setq url-http-transfer-encoding
+ (downcase url-http-transfer-encoding)))
+
+ (cond
+ ((null url-http-response-status)
+ ;; We got back a headerless malformed response from the
+ ;; server.
+ (url-http-activate-callback))
+ ((or (= url-http-response-status 204)
+ (= url-http-response-status 205))
+ (url-http-debug "%d response must have headers only (%s)."
+ url-http-response-status (buffer-name))
+ (when (url-http-parse-headers)
+ (url-http-activate-callback)))
+ ((string= "HEAD" url-http-method)
+ ;; A HEAD request is _ALWAYS_ terminated by the header
+ ;; information, regardless of any entity headers,
+ ;; according to section 4.4 of the HTTP/1.1 draft.
+ (url-http-debug "HEAD request must have headers only (%s)."
+ (buffer-name))
+ (when (url-http-parse-headers)
+ (url-http-activate-callback)))
+ ((string= "CONNECT" url-http-method)
+ ;; A CONNECT request is finished, but we cannot stick this
+ ;; back on the free connectin list
+ (url-http-debug "CONNECT request must have headers only.")
+ (when (url-http-parse-headers)
+ (url-http-activate-callback)))
+ ((equal url-http-response-status 304)
+ ;; Only allowed to have a header section. We have to handle
+ ;; this here instead of in url-http-parse-headers because if
+ ;; you have a cached copy of something without a known
+ ;; content-length, and try to retrieve it from the cache, we'd
+ ;; fall into the 'being dumb' section and wait for the
+ ;; connection to terminate, which means we'd wait for 10
+ ;; seconds for the keep-alives to time out on some servers.
+ (when (url-http-parse-headers)
+ (url-http-activate-callback)))
+ (old-http
+ ;; HTTP/0.9 always signaled end-of-connection by closing the
+ ;; connection.
+ (url-http-debug
+ "Saw HTTP/0.9 response, connection closed means end of document.")
+ (setq url-http-after-change-function
+ 'url-http-simple-after-change-function))
+ ((equal url-http-transfer-encoding "chunked")
+ (url-http-debug "Saw chunked encoding.")
+ (setq url-http-after-change-function
+ 'url-http-chunked-encoding-after-change-function)
+ (when (> nd url-http-end-of-headers)
(url-http-debug
- "Saw HTTP/0.9 response, connection closed means end of document.")
- (setq url-http-after-change-function
- 'url-http-simple-after-change-function))
- ((equal url-http-transfer-encoding "chunked")
- (url-http-debug "Saw chunked encoding.")
- (setq url-http-after-change-function
- 'url-http-chunked-encoding-after-change-function)
- (if (> nd url-http-end-of-headers)
- (progn
- (url-http-debug
- "Calling initial chunked-encoding for extra data at end of headers")
- (url-http-chunked-encoding-after-change-function
- (marker-position url-http-end-of-headers) nd
- (- nd url-http-end-of-headers)))))
- ((integerp url-http-content-length)
+ "Calling initial chunked-encoding for extra data at end of headers")
+ (url-http-chunked-encoding-after-change-function
+ (marker-position url-http-end-of-headers) nd
+ (- nd url-http-end-of-headers))))
+ ((integerp url-http-content-length)
+ (url-http-debug
+ "Got a content-length, being smart about document end.")
+ (setq url-http-after-change-function
+ 'url-http-content-length-after-change-function)
+ (cond
+ ((= 0 url-http-content-length)
+ ;; We got a NULL body! Activate the callback
+ ;; immediately!
(url-http-debug
- "Got a content-length, being smart about document end.")
- (setq url-http-after-change-function
- 'url-http-content-length-after-change-function)
- (cond
- ((= 0 url-http-content-length)
- ;; We got a NULL body! Activate the callback
- ;; immediately!
- (url-http-debug
- "Got 0-length content-length, activating callback immediately.")
- (if (url-http-parse-headers)
- (url-http-activate-callback)))
- ((> nd url-http-end-of-headers)
- ;; Have some leftover data
- (url-http-debug "Calling initial content-length for extra data at end of headers")
- (url-http-content-length-after-change-function
- (marker-position url-http-end-of-headers)
- nd
- (- nd url-http-end-of-headers)))
- (t
- nil)))
+ "Got 0-length content-length, activating callback immediately.")
+ (when (url-http-parse-headers)
+ (url-http-activate-callback)))
+ ((> nd url-http-end-of-headers)
+ ;; Have some leftover data
+ (url-http-debug "Calling initial content-length for extra data at end of headers")
+ (url-http-content-length-after-change-function
+ (marker-position url-http-end-of-headers)
+ nd
+ (- nd url-http-end-of-headers)))
(t
- (url-http-debug "No content-length, being dumb.")
- (setq url-http-after-change-function
- 'url-http-simple-after-change-function)))))
+ nil)))
+ (t
+ (url-http-debug "No content-length, being dumb.")
+ (setq url-http-after-change-function
+ 'url-http-simple-after-change-function)))))
;; We are still at the beginning of the buffer... must just be
;; waiting for a response.
- (url-http-debug "Spinning waiting for headers..."))
- (goto-char (point-max)))
+ (url-http-debug "Spinning waiting for headers...")
+ (when (eq process-buffer (current-buffer))
+ (goto-char (point-max)))))
;;;###autoload
(defun url-http (url callback cbargs)
url-http-chunked-start
url-http-chunked-counter
url-http-process))
- (let ((connection (url-http-find-free-connection (url-host url)
- (url-port url)))
- (buffer (generate-new-buffer (format " *http %s:%d*"
- (url-host url)
- (url-port url)))))
+ (let* ((host (url-host (or url-using-proxy url)))
+ (port (url-port (or url-using-proxy url)))
+ (connection (url-http-find-free-connection host port))
+ (buffer (generate-new-buffer (format " *http %s:%d*" host port))))
(if (not connection)
;; Failed to open the connection for some reason
(progn
(kill-buffer buffer)
(setq buffer nil)
- (error "Could not create connection to %s:%d" (url-host url)
- (url-port url)))
+ (error "Could not create connection to %s:%d" host port))
(with-current-buffer buffer
(mm-disable-multibyte)
(setq url-current-object url
url-http-content-length
url-http-transfer-encoding
url-http-after-change-function
+ url-http-response-version
url-http-response-status
url-http-chunked-length
url-http-chunked-counter
url-http-method
url-http-extra-headers
url-http-data
- url-http-target-url))
+ url-http-target-url
+ url-http-connection-opened
+ url-http-proxy))
(set (make-local-variable var) nil))
(setq url-http-method (or url-request-method "GET")
url-callback-function callback
url-callback-arguments cbargs
url-http-after-change-function 'url-http-wait-for-headers-change-function
- url-http-target-url (if (boundp 'proxy-object)
- proxy-object
- url-current-object))
+ url-http-target-url url-current-object
+ url-http-connection-opened nil
+ url-http-proxy url-using-proxy)
(set-process-buffer connection buffer)
(set-process-filter connection 'url-http-generic-filter)
(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)))
+ (error "Could not create connection to %s:%d" host port))
(t
(set-process-sentinel connection 'url-http-end-of-document-sentinel)
- (process-send-string connection (url-http-create-request url)))))))
+ (process-send-string connection (url-http-create-request)))))))
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)))))
+ (when (buffer-name (process-buffer proc))
+ (with-current-buffer (process-buffer proc)
+ (cond
+ (url-http-connection-opened
+ (url-http-end-of-document-sentinel proc why))
+ ((string= (substring why 0 4) "open")
+ (setq url-http-connection-opened t)
+ (process-send-string proc (url-http-create-request)))
+ (t
+ (setf (car url-callback-arguments)
+ (nconc (list :error (list 'error 'connection-failed why
+ :host (url-host (or url-http-proxy url-current-object))
+ :service (url-port (or url-http-proxy 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
;; the data ourselves. This is slightly less efficient, but there
;; were tons of weird ways the after-change code was biting us in the
;; shorts.
+;; FIXME this can probably be simplified since the above is no longer true.
(defun url-http-generic-filter (proc data)
;; Sometimes we get a zero-length data chunk after the process has
;; been changed to 'free', which means it has no buffer associated
nil nil nil) ;whether gid would change ; inode ; device.
(kill-buffer buffer)))))
+(declare-function url-dav-file-attributes "url-dav" (url &optional id-format))
+
;;;###autoload
(defun url-http-file-attributes (url &optional id-format)
(if (url-dav-supported-p url)
(defconst url-https-default-port 443 "Default HTTPS port.")
;;;###autoload
(defconst url-https-asynchronous-p t "HTTPS retrievals are asynchronous.")
+
+;; FIXME what is the point of this alias being an autoload?
+;; Trying to use it will not cause url-http to be loaded,
+;; since the full alias just gets dumped into loaddefs.el.
+
+;;;###autoload (autoload 'url-default-expander "url-expand")
;;;###autoload
-(defalias 'url-https-expand-file-name 'url-http-expand-file-name)
+(defalias 'url-https-expand-file-name 'url-default-expander)
(defmacro url-https-create-secure-wrapper (method args)
`(defun ,(intern (format (if method "url-https-%s" "url-https") method)) ,args
(provide 'url-http)
-;; arch-tag: ba7c59ae-c0f4-4a31-9617-d85f221732ee
;;; url-http.el ends here
HCoop / bpt / emacs.git / blobdiff