;;; url-http.el --- HTTP retrieval routines
-;; Copyright (c) 1999, 2001, 2004 Free Software Foundation, Inc.
+;; Copyright (C) 1999, 2001, 2004, 2005, 2006, 2007, 2008 Free Software Foundation, Inc.
;; Author: Bill Perry <wmperry@gnu.org>
;; Keywords: comm, data, processes
;;
;; 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)
+;; the Free Software Foundation; either version 3, or (at your option)
;; any later version.
;;
;; GNU Emacs is distributed in the hope that it will be useful,
;;
;; 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., 59 Temple Place - Suite 330,
-;; Boston, MA 02111-1307, USA.
+;; Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,
+;; Boston, MA 02110-1301, USA.
;;; Commentary:
;;; Code:
-(eval-when-compile
- (require 'cl)
- (defvar url-http-extra-headers))
+(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)
(require 'url-cookie)
(require 'mail-parse)
(require 'url-auth)
-(autoload 'url-retrieve-synchronously "url")
-(autoload 'url-retrieve "url")
+(require 'url)
(autoload 'url-cache-create-filename "url-cache")
-(autoload 'url-mark-buffer-as-dead "url")
(defconst url-http-default-port 80 "Default HTTP port.")
(defconst url-http-asynchronous-p t "HTTP retrievals are asynchronous.")
This is only useful when debugging the HTTP subsystem.
Setting this to 1.0 will tell servers not to send chunked encoding,
-and other HTTP/1.1 specific features.
-")
+and other HTTP/1.1 specific features.")
(defvar url-http-attempt-keepalives t
"Whether to use a single TCP connection multiple times in HTTP.
This is only useful when debugging the HTTP subsystem. Setting to
-`nil' will explicitly close the connection to the server after every
-request.
-")
+nil will explicitly close the connection to the server after every
+request.")
;(eval-when-compile
;; These are all macros so that they are hidden from external sight
(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)
- (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)
+ (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))
nil)
(defun url-http-find-free-connection (host port)
(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))
(url-http-debug "Reusing existing connection: %s:%d" host port)
(url-http-debug "Contacting host: %s:%d" host port))
(url-lazy-message "Contacting host: %s:%d" host port)
- (url-http-mark-connection-as-busy host port
- (or found
- (url-open-stream host nil host
- port)))))
+ (url-http-mark-connection-as-busy
+ host port
+ (or found
+ (let ((buf (generate-new-buffer " *url-http-temp*")))
+ ;; `url-open-stream' needs a buffer in which to do things
+ ;; like authentication. But we use another buffer afterwards.
+ (unwind-protect
+ (let ((proc (url-open-stream host buf host port)))
+ ;; url-open-stream might return nil.
+ (when (processp proc)
+ ;; Drop the temp buffer link before killing the buffer.
+ (set-process-buffer proc nil))
+ proc)
+ (kill-buffer buf)))))))
;; Building an HTTP request
(defun url-http-user-agent-string ()
(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-request-extra-headers)))
- (proxy-obj (and (boundp 'proxy-object) proxy-object))
+ (no-cache (cdr-safe (assoc "Pragma" url-http-extra-headers)))
+ (using-proxy url-http-proxy)
(proxy-auth (if (or (cdr-safe (assoc "Proxy-Authorization"
- url-request-extra-headers))
- (not proxy-obj))
+ url-http-extra-headers))
+ (not using-proxy))
nil
(let ((url-basic-auth-storage
'url-http-proxy-basic-auth-storage))
- (url-get-authentication url nil 'any nil))))
- (real-fname (if proxy-obj (url-recreate-url proxy-obj)
- (url-filename url)))
- (host (url-host (or proxy-obj url)))
- (auth (if (cdr-safe (assoc "Authorization" url-request-extra-headers))
+ (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)))
(memq 'lastloc url-privacy-level)))
(setq ref-url nil))
- ;; url-request-extra-headers contains an assoc-list of
+ ;; url-http-extra-headers contains an assoc-list of
;; header/value pairs that we need to put into the request.
(setq extra-headers (mapconcat
(lambda (x)
(concat (car x) ": " (cdr x)))
- url-request-extra-headers "\r\n"))
+ url-http-extra-headers "\r\n"))
(if (not (equal extra-headers ""))
(setq extra-headers (concat extra-headers "\r\n")))
;; This was done with a call to `format'. Concatting parts has
- ;; the advantage of keeping the parts of each header togther and
+ ;; the advantage of keeping the parts of each header together and
;; allows us to elide null lines directly, at the cost of making
;; the layout less clear.
(setq request
- (concat
- ;; The request
- (or url-request-method "GET") " " 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
- (not url-http-attempt-keepalives))
- "close" "keep-alive") "\r\n"
- ;; HTTP extensions we support
- (if url-extensions-header
- (format
- "Extension: %s\r\n" url-extensions-header))
- ;; Who we want to talk to
- (if (/= (url-port (or proxy-obj url))
- (url-scheme-get-property
- (url-type (or proxy-obj url)) 'default-port))
- (format
- "Host: %s:%d\r\n" host (url-port (or proxy-obj url)))
- (format "Host: %s\r\n" host))
- ;; Who its from
- (if url-personal-mail-address
- (concat
- "From: " url-personal-mail-address "\r\n"))
- ;; Encodings we understand
- (if url-mime-encoding-string
- (concat
- "Accept-encoding: " url-mime-encoding-string "\r\n"))
- (if url-mime-charset-string
- (concat
- "Accept-charset: " url-mime-charset-string "\r\n"))
- ;; Languages we understand
- (if url-mime-language-string
- (concat
- "Accept-language: " url-mime-language-string "\r\n"))
- ;; Types we understand
- "Accept: " (or url-mime-accept-string "*/*") "\r\n"
- ;; User agent
- (url-http-user-agent-string)
- ;; Proxy Authorization
- proxy-auth
- ;; Authorization
- auth
- ;; Cookies
- (url-cookie-generate-header-lines host real-fname
- (equal "https" (url-type url)))
- ;; If-modified-since
- (if (and (not no-cache)
- (member url-request-method '("GET" nil)))
- (let ((tm (url-is-cached (or proxy-obj url))))
- (if tm
- (concat "If-modified-since: "
- (url-get-normalized-date tm) "\r\n"))))
- ;; Whence we came
- (if ref-url (concat
- "Referer: " ref-url "\r\n"))
- extra-headers
- ;; Length of data
- (if url-request-data
- (concat
- "Content-length: " (number-to-string
- (length url-request-data))
- "\r\n"))
- ;; End request
- "\r\n"
- ;; Any data
- url-request-data))
+ ;; We used to concat directly, but if one of the strings happens
+ ;; to being multibyte (even if it only contains pure ASCII) then
+ ;; every string gets converted with `string-MAKE-multibyte' which
+ ;; turns the 127-255 codes into things like latin-1 accented chars
+ ;; (it would work right if it used `string-TO-multibyte' instead).
+ ;; So to avoid the problem we force every string to be unibyte.
+ (mapconcat
+ ;; FIXME: Instead of `string-AS-unibyte' we'd want
+ ;; `string-to-unibyte', so as to properly signal an error if one
+ ;; of the strings contains a multibyte char.
+ 'string-as-unibyte
+ (delq nil
+ (list
+ ;; The request
+ (or url-http-method "GET") " "
+ (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 using-proxy
+ (not url-http-attempt-keepalives))
+ "close" "keep-alive") "\r\n"
+ ;; HTTP extensions we support
+ (if url-extensions-header
+ (format
+ "Extension: %s\r\n" url-extensions-header))
+ ;; Who we want to talk to
+ (if (/= (url-port url-http-target-url)
+ (url-scheme-get-property
+ (url-type url-http-target-url) 'default-port))
+ (format
+ "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
+ (concat
+ "From: " url-personal-mail-address "\r\n"))
+ ;; Encodings we understand
+ (if url-mime-encoding-string
+ (concat
+ "Accept-encoding: " url-mime-encoding-string "\r\n"))
+ (if url-mime-charset-string
+ (concat
+ "Accept-charset: " url-mime-charset-string "\r\n"))
+ ;; Languages we understand
+ (if url-mime-language-string
+ (concat
+ "Accept-language: " url-mime-language-string "\r\n"))
+ ;; Types we understand
+ "Accept: " (or url-mime-accept-string "*/*") "\r\n"
+ ;; User agent
+ (url-http-user-agent-string)
+ ;; Proxy Authorization
+ proxy-auth
+ ;; Authorization
+ auth
+ ;; Cookies
+ (url-cookie-generate-header-lines host real-fname
+ (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 url-http-target-url)))
+ (if tm
+ (concat "If-modified-since: "
+ (url-get-normalized-date tm) "\r\n"))))
+ ;; Whence we came
+ (if ref-url (concat
+ "Referer: " ref-url "\r\n"))
+ extra-headers
+ ;; Length of data
+ (if url-http-data
+ (concat
+ "Content-length: " (number-to-string
+ (length url-http-data))
+ "\r\n"))
+ ;; End request
+ "\r\n"
+ ;; Any data
+ url-http-data))
+ ""))
(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)
- )
-
+ auth
+ (strength 0))
;; 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)))
+ ;; 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
" authentication. If you'd like to write it,"
" send it to " url-bug-address ".<hr>")
(setq status t))
- (let* ((args auth)
- (ctr (1- (length args)))
- auth)
- (while (/= 0 ctr)
- (if (char-equal ?, (aref args ctr))
- (aset args ctr ?\;))
- (setq ctr (1- ctr)))
- (setq args (url-parse-args args)
- auth (url-get-authentication url (cdr-safe (assoc "realm" args))
- type t args))
+ (let* ((args (url-parse-args (subst-char-in-string ?, ?\; auth)))
+ (auth (url-get-authentication url (cdr-safe (assoc "realm" args))
+ type t args)))
(if (not auth)
(setq success t)
(push (cons (if proxy "Proxy-Authorization" "Authorization") auth)
(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)))))))
+ (url-retrieve-internal url url-callback-function
+ url-callback-arguments)))))))
(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
+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-cookies-sources))
+ (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))
(url-http-parse-response)
(mail-narrow-to-head)
;;(narrow-to-region (point-min) url-http-end-of-headers)
- (let ((class nil)
+ (let ((connection (mail-fetch-field "Connection")))
+ ;; 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)))
+ (t
+ (when (and connection
+ (string= (downcase connection) "close"))
+ (delete-process url-http-process)))))
+ (let ((buffer (current-buffer))
+ (class nil)
(success nil))
(setq class (/ url-http-response-status 100))
(url-http-debug "Parsed HTTP headers: class=%d status=%d" class url-http-response-status)
;; 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
(case url-http-response-status
((204 205)
;; 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
;; non-fully-qualified URL (ie: /), which royally confuses
;; the URL library.
(if (not (string-match url-nonrelative-link redirect-uri))
- (setq redirect-uri (url-expand-file-name redirect-uri)))
- (let ((url-request-method url-http-method)
+ ;; Be careful to use the real target URL, otherwise we may
+ ;; compute the redirection relative to the URL of the proxy.
+ (setq redirect-uri
+ (url-expand-file-name redirect-uri url-http-target-url)))
+ (let ((url-request-method url-http-method)
(url-request-data url-http-data)
(url-request-extra-headers url-http-extra-headers))
- (url-retrieve 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-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
(url-http-handle-authentication nil))
(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
;; The server understood the request, but is refusing to
;; 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))))
+ (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
;; 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)))
+ 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)))
(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))
(url-http-debug "url-http-end-of-document-sentinel in buffer (%s)"
(process-buffer proc))
(url-http-idle-sentinel proc why)
- (save-excursion
- (set-buffer (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
(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)))))
(list 'start-open t
'end-open t
'chunked-encoding t
- 'face (if (featurep 'xemacs)
- 'text-cursor
- 'cursor)
+ 'face 'cursor
'invisible t))
(setq url-http-chunked-length (string-to-number (buffer-substring
(match-beginning 1)
(url-display-percentage nil nil)
(goto-char (match-end 1))
(if (re-search-forward "^\r*$" nil t)
- (message "Saw end of trailers..."))
+ (url-http-debug "Saw end of trailers..."))
(if (url-http-parse-headers)
(url-http-activate-callback))))))))))
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.
+ (when (not (bobp))
+ (let ((end-of-headers nil)
+ (old-http nil)
+ (content-length nil))
+ (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
+ ((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..."))
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)))
- (save-excursion
- (set-buffer buffer)
+ (error "Could not create connection to %s:%d" host port))
+ (with-current-buffer buffer
(mm-disable-multibyte)
(setq url-current-object url
mode-line-format "%b [%s]")
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-cookies-sources))
+ 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-cookies-sources (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-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))))
+ (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" host port))
+ (t
+ (set-process-sentinel connection 'url-http-end-of-document-sentinel)
+ (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
+ (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
;; an after change by hooking into the process filter and inserting
(declare (special url-http-after-change-function))
(and (process-buffer proc)
(/= (length data) 0)
- (save-excursion
- (set-buffer (process-buffer proc))
+ (with-current-buffer (process-buffer proc)
(url-http-debug "Calling after change function `%s' for `%S'" url-http-after-change-function proc)
(funcall url-http-after-change-function
(point-max)
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; file-name-handler stuff from here on out
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-(if (not (fboundp 'symbol-value-in-buffer))
- (defun url-http-symbol-value-in-buffer (symbol buffer
- &optional unbound-value)
+(defalias 'url-http-symbol-value-in-buffer
+ (if (fboundp 'symbol-value-in-buffer)
+ 'symbol-value-in-buffer
+ (lambda (symbol buffer &optional unbound-value)
"Return the value of SYMBOL in BUFFER, or UNBOUND-VALUE if it is unbound."
- (save-excursion
- (set-buffer buffer)
- (if (not (boundp symbol))
- unbound-value
- (symbol-value symbol))))
- (defalias 'url-http-symbol-value-in-buffer 'symbol-value-in-buffer))
+ (with-current-buffer buffer
+ (if (not (boundp symbol))
+ unbound-value
+ (symbol-value symbol))))))
(defun url-http-head (url)
(let ((url-request-method "HEAD")
(setq exists nil)
(setq status (url-http-symbol-value-in-buffer 'url-http-response-status
buffer 500)
- exists (and (>= status 200) (< status 300)))
+ exists (and (integerp status)
+ (>= status 200) (< status 300)))
(kill-buffer buffer))
exists))
(defalias 'url-http-file-readable-p 'url-http-file-exists-p)
(defun url-http-head-file-attributes (url &optional id-format)
- (let ((buffer (url-http-head url))
- (attributes nil))
+ (let ((buffer (url-http-head url)))
(when buffer
- (setq attributes (make-list 11 nil))
- (setf (nth 1 attributes) 1) ; Number of links to file
- (setf (nth 2 attributes) 0) ; file uid
- (setf (nth 3 attributes) 0) ; file gid
- (setf (nth 7 attributes) ; file size
- (url-http-symbol-value-in-buffer 'url-http-content-length
- buffer -1))
- (setf (nth 8 attributes) (eval-when-compile (make-string 10 ?-)))
- (kill-buffer buffer))
- attributes))
+ (prog1
+ (list
+ nil ;dir / link / normal file
+ 1 ;number of links to file.
+ 0 0 ;uid ; gid
+ nil nil nil ;atime ; mtime ; ctime
+ (url-http-symbol-value-in-buffer 'url-http-content-length
+ buffer -1)
+ (eval-when-compile (make-string 10 ?-))
+ nil nil nil) ;whether gid would change ; inode ; device.
+ (kill-buffer buffer)))))
;;;###autoload
(defun url-http-file-attributes (url &optional id-format)
;;;###autoload
(defun url-http-options (url)
- "Returns a property list describing options available for URL.
+ "Return a property list describing options available for URL.
This list is retrieved using the `OPTIONS' HTTP method.
Property list members:
The `Platform For Privacy Protection' description for the resource.
Currently this is just the raw header contents. This is likely to
change once P3P is formally supported by the URL package or
- Emacs/W3.
-"
+ Emacs/W3."
(let* ((url-request-method "OPTIONS")
(url-request-data nil)
(buffer (url-retrieve-synchronously url))
(when (and buffer (= 2 (/ (url-http-symbol-value-in-buffer
'url-http-response-status buffer 0) 100)))
;; Only parse the options if we got a 2xx response code!
- (save-excursion
+ (with-current-buffer buffer
(save-restriction
(save-match-data
- (set-buffer buffer)
(mail-narrow-to-head)
;; Figure out what methods are supported.
(if buffer (kill-buffer buffer))
options))
+;; HTTPS. This used to be in url-https.el, but that file collides
+;; with url-http.el on systems with 8-character file names.
+(require 'tls)
+
+;;;###autoload
+(defconst url-https-default-port 443 "Default HTTPS port.")
+;;;###autoload
+(defconst url-https-asynchronous-p t "HTTPS retrievals are asynchronous.")
+;;;###autoload
+(defalias 'url-https-expand-file-name 'url-http-expand-file-name)
+
+(defmacro url-https-create-secure-wrapper (method args)
+ `(defun ,(intern (format (if method "url-https-%s" "url-https") method)) ,args
+ ,(format "HTTPS wrapper around `%s' call." (or method "url-http"))
+ (let ((url-gateway-method 'tls))
+ (,(intern (format (if method "url-http-%s" "url-http") method))
+ ,@(remove '&rest (remove '&optional args))))))
+
+;;;###autoload (autoload 'url-https "url-http")
+(url-https-create-secure-wrapper nil (url callback cbargs))
+;;;###autoload (autoload 'url-https-file-exists-p "url-http")
+(url-https-create-secure-wrapper file-exists-p (url))
+;;;###autoload (autoload 'url-https-file-readable-p "url-http")
+(url-https-create-secure-wrapper file-readable-p (url))
+;;;###autoload (autoload 'url-https-file-attributes "url-http")
+(url-https-create-secure-wrapper file-attributes (url &optional id-format))
+
(provide 'url-http)
;; arch-tag: ba7c59ae-c0f4-4a31-9617-d85f221732ee