;;; url-http.el --- HTTP retrieval routines
-;; Copyright (C) 1999, 2001, 2004, 2005, 2006 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,
(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)
(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))
;; like authentication. But we use another buffer afterwards.
(unwind-protect
(let ((proc (url-open-stream host buf host port)))
- ;; Drop the temp buffer link before killing the buffer.
- (set-process-buffer proc nil)
+ ;; 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)))))))
(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 (url-filename (or proxy-obj 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")))
(delq nil
(list
;; The request
- (or url-request-method "GET") " "
- (if proxy-obj (url-recreate-url proxy-obj) real-fname)
+ (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 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-request-method '("GET" nil)))
- (let ((tm (url-is-cached (or proxy-obj url))))
+ (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"))))
"Referer: " ref-url "\r\n"))
extra-headers
;; Length of data
- (if url-request-data
+ (if url-http-data
(concat
"Content-length: " (number-to-string
- (length url-request-data))
+ (length url-http-data))
"\r\n"))
;; End request
"\r\n"
;; Any data
- url-request-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
(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
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)
+ (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
(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))))))
+ ;; 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))
(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-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)))
+ (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-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
(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)
(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