Spelling fixes.
[emacs.git] / lisp / url / url-http.el
bloba9ff042d681a993a0985c0bde4ee10c2e981206a
1 ;;; url-http.el --- HTTP retrieval routines
3 ;; Copyright (C) 1999, 2001, 2004-2011 Free Software Foundation, Inc.
5 ;; Author: Bill Perry <wmperry@gnu.org>
6 ;; Keywords: comm, data, processes
8 ;; This file is part of GNU Emacs.
9 ;;
10 ;; GNU Emacs is free software: you can redistribute it and/or modify
11 ;; it under the terms of the GNU General Public License as published by
12 ;; the Free Software Foundation, either version 3 of the License, or
13 ;; (at your option) any later version.
15 ;; GNU Emacs is distributed in the hope that it will be useful,
16 ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
17 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
18 ;; GNU General Public License for more details.
20 ;; You should have received a copy of the GNU General Public License
21 ;; along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>.
23 ;;; Commentary:
25 ;;; Code:
27 (eval-when-compile (require 'cl))
28 (defvar url-http-extra-headers)
29 (defvar url-http-target-url)
30 (defvar url-http-proxy)
31 (defvar url-http-connection-opened)
32 (require 'url-gw)
33 (require 'url-util)
34 (require 'url-parse)
35 (require 'url-cookie)
36 (require 'mail-parse)
37 (require 'url-auth)
38 (require 'url)
39 (autoload 'url-cache-create-filename "url-cache")
41 (defconst url-http-default-port 80 "Default HTTP port.")
42 (defconst url-http-asynchronous-p t "HTTP retrievals are asynchronous.")
43 (defalias 'url-http-expand-file-name 'url-default-expander)
45 (defvar url-http-real-basic-auth-storage nil)
46 (defvar url-http-proxy-basic-auth-storage nil)
48 (defvar url-http-open-connections (make-hash-table :test 'equal
49 :size 17)
50 "A hash table of all open network connections.")
52 (defvar url-http-version "1.1"
53 "What version of HTTP we advertise, as a string.
54 Valid values are 1.1 and 1.0.
55 This is only useful when debugging the HTTP subsystem.
57 Setting this to 1.0 will tell servers not to send chunked encoding,
58 and other HTTP/1.1 specific features.")
60 (defvar url-http-attempt-keepalives t
61 "Whether to use a single TCP connection multiple times in HTTP.
62 This is only useful when debugging the HTTP subsystem. Setting to
63 nil will explicitly close the connection to the server after every
64 request.")
66 (defconst url-http-codes
67 '((100 continue "Continue with request")
68 (101 switching-protocols "Switching protocols")
69 (102 processing "Processing (Added by DAV)")
70 (200 OK "OK")
71 (201 created "Created")
72 (202 accepted "Accepted")
73 (203 non-authoritative "Non-authoritative information")
74 (204 no-content "No content")
75 (205 reset-content "Reset content")
76 (206 partial-content "Partial content")
77 (207 multi-status "Multi-status (Added by DAV)")
78 (300 multiple-choices "Multiple choices")
79 (301 moved-permanently "Moved permanently")
80 (302 found "Found")
81 (303 see-other "See other")
82 (304 not-modified "Not modified")
83 (305 use-proxy "Use proxy")
84 (307 temporary-redirect "Temporary redirect")
85 (400 bad-request "Bad Request")
86 (401 unauthorized "Unauthorized")
87 (402 payment-required "Payment required")
88 (403 forbidden "Forbidden")
89 (404 not-found "Not found")
90 (405 method-not-allowed "Method not allowed")
91 (406 not-acceptable "Not acceptable")
92 (407 proxy-authentication-required "Proxy authentication required")
93 (408 request-timeout "Request time-out")
94 (409 conflict "Conflict")
95 (410 gone "Gone")
96 (411 length-required "Length required")
97 (412 precondition-failed "Precondition failed")
98 (413 request-entity-too-large "Request entity too large")
99 (414 request-uri-too-large "Request-URI too large")
100 (415 unsupported-media-type "Unsupported media type")
101 (416 requested-range-not-satisfiable "Requested range not satisfiable")
102 (417 expectation-failed "Expectation failed")
103 (422 unprocessable-entity "Unprocessable Entity (Added by DAV)")
104 (423 locked "Locked")
105 (424 failed-Dependency "Failed Dependency")
106 (500 internal-server-error "Internal server error")
107 (501 not-implemented "Not implemented")
108 (502 bad-gateway "Bad gateway")
109 (503 service-unavailable "Service unavailable")
110 (504 gateway-timeout "Gateway time-out")
111 (505 http-version-not-supported "HTTP version not supported")
112 (507 insufficient-storage "Insufficient storage")
113 "The HTTP return codes and their text."))
115 ;(eval-when-compile
116 ;; These are all macros so that they are hidden from external sight
117 ;; when the file is byte-compiled.
119 ;; This allows us to expose just the entry points we want.
121 ;; These routines will allow us to implement persistent HTTP
122 ;; connections.
123 (defsubst url-http-debug (&rest args)
124 (if quit-flag
125 (let ((proc (get-buffer-process (current-buffer))))
126 ;; The user hit C-g, honor it! Some things can get in an
127 ;; incredibly tight loop (chunked encoding)
128 (if proc
129 (progn
130 (set-process-sentinel proc nil)
131 (set-process-filter proc nil)))
132 (error "Transfer interrupted!")))
133 (apply 'url-debug 'http args))
135 (defun url-http-mark-connection-as-busy (host port proc)
136 (url-http-debug "Marking connection as busy: %s:%d %S" host port proc)
137 (set-process-query-on-exit-flag proc t)
138 (puthash (cons host port)
139 (delq proc (gethash (cons host port) url-http-open-connections))
140 url-http-open-connections)
141 proc)
143 (defun url-http-mark-connection-as-free (host port proc)
144 (url-http-debug "Marking connection as free: %s:%d %S" host port proc)
145 (when (memq (process-status proc) '(open run connect))
146 (set-process-buffer proc nil)
147 (set-process-sentinel proc 'url-http-idle-sentinel)
148 (set-process-query-on-exit-flag proc nil)
149 (puthash (cons host port)
150 (cons proc (gethash (cons host port) url-http-open-connections))
151 url-http-open-connections))
152 nil)
154 (defun url-http-find-free-connection (host port)
155 (let ((conns (gethash (cons host port) url-http-open-connections))
156 (found nil))
157 (while (and conns (not found))
158 (if (not (memq (process-status (car conns)) '(run open connect)))
159 (progn
160 (url-http-debug "Cleaning up dead process: %s:%d %S"
161 host port (car conns))
162 (url-http-idle-sentinel (car conns) nil))
163 (setq found (car conns))
164 (url-http-debug "Found existing connection: %s:%d %S" host port found))
165 (pop conns))
166 (if found
167 (url-http-debug "Reusing existing connection: %s:%d" host port)
168 (url-http-debug "Contacting host: %s:%d" host port))
169 (url-lazy-message "Contacting host: %s:%d" host port)
170 (url-http-mark-connection-as-busy
171 host port
172 (or found
173 (let ((buf (generate-new-buffer " *url-http-temp*")))
174 ;; `url-open-stream' needs a buffer in which to do things
175 ;; like authentication. But we use another buffer afterwards.
176 (unwind-protect
177 (let ((proc (url-open-stream host buf host port)))
178 ;; url-open-stream might return nil.
179 (when (processp proc)
180 ;; Drop the temp buffer link before killing the buffer.
181 (set-process-buffer proc nil))
182 proc)
183 ;; If there was an error on connect, make sure we don't
184 ;; get queried.
185 (when (get-buffer-process buf)
186 (set-process-query-on-exit-flag (get-buffer-process buf) nil))
187 (kill-buffer buf)))))))
189 ;; Building an HTTP request
190 (defun url-http-user-agent-string ()
191 (if (or (eq url-privacy-level 'paranoid)
192 (and (listp url-privacy-level)
193 (memq 'agent url-privacy-level)))
195 (format "User-Agent: %sURL/%s%s\r\n"
196 (if url-package-name
197 (concat url-package-name "/" url-package-version " ")
199 url-version
200 (cond
201 ((and url-os-type url-system-type)
202 (concat " (" url-os-type "; " url-system-type ")"))
203 ((or url-os-type url-system-type)
204 (concat " (" (or url-system-type url-os-type) ")"))
205 (t "")))))
207 (defun url-http-create-request (&optional ref-url)
208 "Create an HTTP request for `url-http-target-url', referred to by REF-URL."
209 (declare (special proxy-info
210 url-http-method url-http-data
211 url-http-extra-headers))
212 (let* ((extra-headers)
213 (request nil)
214 (no-cache (cdr-safe (assoc "Pragma" url-http-extra-headers)))
215 (using-proxy url-http-proxy)
216 (proxy-auth (if (or (cdr-safe (assoc "Proxy-Authorization"
217 url-http-extra-headers))
218 (not using-proxy))
220 (let ((url-basic-auth-storage
221 'url-http-proxy-basic-auth-storage))
222 (url-get-authentication url-http-target-url nil 'any nil))))
223 (real-fname (concat (url-filename url-http-target-url)
224 (url-recreate-url-attributes url-http-target-url)))
225 (host (url-host url-http-target-url))
226 (auth (if (cdr-safe (assoc "Authorization" url-http-extra-headers))
228 (url-get-authentication (or
229 (and (boundp 'proxy-info)
230 proxy-info)
231 url-http-target-url) nil 'any nil))))
232 (if (equal "" real-fname)
233 (setq real-fname "/"))
234 (setq no-cache (and no-cache (string-match "no-cache" no-cache)))
235 (if auth
236 (setq auth (concat "Authorization: " auth "\r\n")))
237 (if proxy-auth
238 (setq proxy-auth (concat "Proxy-Authorization: " proxy-auth "\r\n")))
240 ;; Protection against stupid values in the referer
241 (if (and ref-url (stringp ref-url) (or (string= ref-url "file:nil")
242 (string= ref-url "")))
243 (setq ref-url nil))
245 ;; We do not want to expose the referer if the user is paranoid.
246 (if (or (memq url-privacy-level '(low high paranoid))
247 (and (listp url-privacy-level)
248 (memq 'lastloc url-privacy-level)))
249 (setq ref-url nil))
251 ;; url-http-extra-headers contains an assoc-list of
252 ;; header/value pairs that we need to put into the request.
253 (setq extra-headers (mapconcat
254 (lambda (x)
255 (concat (car x) ": " (cdr x)))
256 url-http-extra-headers "\r\n"))
257 (if (not (equal extra-headers ""))
258 (setq extra-headers (concat extra-headers "\r\n")))
260 ;; This was done with a call to `format'. Concatenating parts has
261 ;; the advantage of keeping the parts of each header together and
262 ;; allows us to elide null lines directly, at the cost of making
263 ;; the layout less clear.
264 (setq request
265 ;; We used to concat directly, but if one of the strings happens
266 ;; to being multibyte (even if it only contains pure ASCII) then
267 ;; every string gets converted with `string-MAKE-multibyte' which
268 ;; turns the 127-255 codes into things like latin-1 accented chars
269 ;; (it would work right if it used `string-TO-multibyte' instead).
270 ;; So to avoid the problem we force every string to be unibyte.
271 (mapconcat
272 ;; FIXME: Instead of `string-AS-unibyte' we'd want
273 ;; `string-to-unibyte', so as to properly signal an error if one
274 ;; of the strings contains a multibyte char.
275 'string-as-unibyte
276 (delq nil
277 (list
278 ;; The request
279 (or url-http-method "GET") " "
280 (if using-proxy (url-recreate-url url-http-target-url) real-fname)
281 " HTTP/" url-http-version "\r\n"
282 ;; Version of MIME we speak
283 "MIME-Version: 1.0\r\n"
284 ;; (maybe) Try to keep the connection open
285 "Connection: " (if (or using-proxy
286 (not url-http-attempt-keepalives))
287 "close" "keep-alive") "\r\n"
288 ;; HTTP extensions we support
289 (if url-extensions-header
290 (format
291 "Extension: %s\r\n" url-extensions-header))
292 ;; Who we want to talk to
293 (if (/= (url-port url-http-target-url)
294 (url-scheme-get-property
295 (url-type url-http-target-url) 'default-port))
296 (format
297 "Host: %s:%d\r\n" host (url-port url-http-target-url))
298 (format "Host: %s\r\n" host))
299 ;; Who its from
300 (if url-personal-mail-address
301 (concat
302 "From: " url-personal-mail-address "\r\n"))
303 ;; Encodings we understand
304 (if url-mime-encoding-string
305 (concat
306 "Accept-encoding: " url-mime-encoding-string "\r\n"))
307 (if url-mime-charset-string
308 (concat
309 "Accept-charset: " url-mime-charset-string "\r\n"))
310 ;; Languages we understand
311 (if url-mime-language-string
312 (concat
313 "Accept-language: " url-mime-language-string "\r\n"))
314 ;; Types we understand
315 "Accept: " (or url-mime-accept-string "*/*") "\r\n"
316 ;; User agent
317 (url-http-user-agent-string)
318 ;; Proxy Authorization
319 proxy-auth
320 ;; Authorization
321 auth
322 ;; Cookies
323 (url-cookie-generate-header-lines host real-fname
324 (equal "https" (url-type url-http-target-url)))
325 ;; If-modified-since
326 (if (and (not no-cache)
327 (member url-http-method '("GET" nil)))
328 (let ((tm (url-is-cached url-http-target-url)))
329 (if tm
330 (concat "If-modified-since: "
331 (url-get-normalized-date tm) "\r\n"))))
332 ;; Whence we came
333 (if ref-url (concat
334 "Referer: " ref-url "\r\n"))
335 extra-headers
336 ;; Length of data
337 (if url-http-data
338 (concat
339 "Content-length: " (number-to-string
340 (length url-http-data))
341 "\r\n"))
342 ;; End request
343 "\r\n"
344 ;; Any data
345 url-http-data
346 ;; If `url-http-data' is nil, avoid two CRLFs (Bug#8931).
347 (if url-http-data "\r\n")))
348 ""))
349 (url-http-debug "Request is: \n%s" request)
350 request))
352 ;; Parsing routines
353 (defun url-http-clean-headers ()
354 "Remove trailing \r from header lines.
355 This allows us to use `mail-fetch-field', etc."
356 (declare (special url-http-end-of-headers))
357 (goto-char (point-min))
358 (while (re-search-forward "\r$" url-http-end-of-headers t)
359 (replace-match "")))
361 (defun url-http-handle-authentication (proxy)
362 (declare (special status success url-http-method url-http-data
363 url-callback-function url-callback-arguments))
364 (url-http-debug "Handling %s authentication" (if proxy "proxy" "normal"))
365 (let ((auths (or (nreverse
366 (mail-fetch-field
367 (if proxy "proxy-authenticate" "www-authenticate")
368 nil nil t))
369 '("basic")))
370 (type nil)
371 (url (url-recreate-url url-current-object))
372 (auth-url (url-recreate-url
373 (if (and proxy (boundp 'url-http-proxy))
374 url-http-proxy
375 url-current-object)))
376 (url-basic-auth-storage (if proxy
377 ;; Cheating, but who cares? :)
378 'url-http-proxy-basic-auth-storage
379 'url-http-real-basic-auth-storage))
380 auth
381 (strength 0))
383 ;; find strongest supported auth
384 (dolist (this-auth auths)
385 (setq this-auth (url-eat-trailing-space
386 (url-strip-leading-spaces
387 this-auth)))
388 (let* ((this-type
389 (if (string-match "[ \t]" this-auth)
390 (downcase (substring this-auth 0 (match-beginning 0)))
391 (downcase this-auth)))
392 (registered (url-auth-registered this-type))
393 (this-strength (cddr registered)))
394 (when (and registered (> this-strength strength))
395 (setq auth this-auth
396 type this-type
397 strength this-strength))))
399 (if (not (url-auth-registered type))
400 (progn
401 (widen)
402 (goto-char (point-max))
403 (insert "<hr>Sorry, but I do not know how to handle " type
404 " authentication. If you'd like to write it,"
405 " send it to " url-bug-address ".<hr>")
406 (setq status t))
407 (let* ((args (url-parse-args (subst-char-in-string ?, ?\; auth)))
408 (auth (url-get-authentication auth-url
409 (cdr-safe (assoc "realm" args))
410 type t args)))
411 (if (not auth)
412 (setq success t)
413 (push (cons (if proxy "Proxy-Authorization" "Authorization") auth)
414 url-http-extra-headers)
415 (let ((url-request-method url-http-method)
416 (url-request-data url-http-data)
417 (url-request-extra-headers url-http-extra-headers))
418 (url-retrieve-internal url url-callback-function
419 url-callback-arguments)))))))
421 (defun url-http-parse-response ()
422 "Parse just the response code."
423 (declare (special url-http-end-of-headers url-http-response-status
424 url-http-response-version))
425 (if (not url-http-end-of-headers)
426 (error "Trying to parse HTTP response code in odd buffer: %s" (buffer-name)))
427 (url-http-debug "url-http-parse-response called in (%s)" (buffer-name))
428 (goto-char (point-min))
429 (skip-chars-forward " \t\n") ; Skip any blank crap
430 (skip-chars-forward "HTTP/") ; Skip HTTP Version
431 (setq url-http-response-version
432 (buffer-substring (point)
433 (progn
434 (skip-chars-forward "[0-9].")
435 (point))))
436 (setq url-http-response-status (read (current-buffer))))
438 (defun url-http-handle-cookies ()
439 "Handle all set-cookie / set-cookie2 headers in an HTTP response.
440 The buffer must already be narrowed to the headers, so `mail-fetch-field' will
441 work correctly."
442 (let ((cookies (nreverse (mail-fetch-field "Set-Cookie" nil nil t)))
443 (cookies2 (nreverse (mail-fetch-field "Set-Cookie2" nil nil t))))
444 (and cookies (url-http-debug "Found %d Set-Cookie headers" (length cookies)))
445 (and cookies2 (url-http-debug "Found %d Set-Cookie2 headers" (length cookies2)))
446 (while cookies
447 (url-cookie-handle-set-cookie (pop cookies)))
448 ;;; (while cookies2
449 ;;; (url-cookie-handle-set-cookie2 (pop cookies)))
453 (defun url-http-parse-headers ()
454 "Parse and handle HTTP specific headers.
455 Return t if and only if the current buffer is still active and
456 should be shown to the user."
457 ;; The comments after each status code handled are taken from RFC
458 ;; 2616 (HTTP/1.1)
459 (declare (special url-http-end-of-headers url-http-response-status
460 url-http-response-version
461 url-http-method url-http-data url-http-process
462 url-callback-function url-callback-arguments))
464 (url-http-mark-connection-as-free (url-host url-current-object)
465 (url-port url-current-object)
466 url-http-process)
468 (if (or (not (boundp 'url-http-end-of-headers))
469 (not url-http-end-of-headers))
470 (error "Trying to parse headers in odd buffer: %s" (buffer-name)))
471 (goto-char (point-min))
472 (url-http-debug "url-http-parse-headers called in (%s)" (buffer-name))
473 (url-http-parse-response)
474 (mail-narrow-to-head)
475 ;;(narrow-to-region (point-min) url-http-end-of-headers)
476 (let ((connection (mail-fetch-field "Connection")))
477 ;; In HTTP 1.0, keep the connection only if there is a
478 ;; "Connection: keep-alive" header.
479 ;; In HTTP 1.1 (and greater), keep the connection unless there is a
480 ;; "Connection: close" header
481 (cond
482 ((string= url-http-response-version "1.0")
483 (unless (and connection
484 (string= (downcase connection) "keep-alive"))
485 (delete-process url-http-process)))
487 (when (and connection
488 (string= (downcase connection) "close"))
489 (delete-process url-http-process)))))
490 (let ((buffer (current-buffer))
491 (class nil)
492 (success nil)
493 ;; other status symbols: jewelry and luxury cars
494 (status-symbol (cadr (assq url-http-response-status url-http-codes)))
495 ;; The filename part of a URL could be in remote file syntax,
496 ;; see Bug#6717 for an example. We disable file name
497 ;; handlers, therefore.
498 (file-name-handler-alist nil))
499 (setq class (/ url-http-response-status 100))
500 (url-http-debug "Parsed HTTP headers: class=%d status=%d" class url-http-response-status)
501 (url-http-handle-cookies)
503 (case class
504 ;; Classes of response codes
506 ;; 5xx = Server Error
507 ;; 4xx = Client Error
508 ;; 3xx = Redirection
509 ;; 2xx = Successful
510 ;; 1xx = Informational
511 (1 ; Information messages
512 ;; 100 = Continue with request
513 ;; 101 = Switching protocols
514 ;; 102 = Processing (Added by DAV)
515 (url-mark-buffer-as-dead buffer)
516 (error "HTTP responses in class 1xx not supported (%d)" url-http-response-status))
517 (2 ; Success
518 ;; 200 Ok
519 ;; 201 Created
520 ;; 202 Accepted
521 ;; 203 Non-authoritative information
522 ;; 204 No content
523 ;; 205 Reset content
524 ;; 206 Partial content
525 ;; 207 Multi-status (Added by DAV)
526 (case status-symbol
527 ((no-content reset-content)
528 ;; No new data, just stay at the same document
529 (url-mark-buffer-as-dead buffer)
530 (setq success t))
531 (otherwise
532 ;; Generic success for all others. Store in the cache, and
533 ;; mark it as successful.
534 (widen)
535 (if (and url-automatic-caching (equal url-http-method "GET"))
536 (url-store-in-cache buffer))
537 (setq success t))))
538 (3 ; Redirection
539 ;; 300 Multiple choices
540 ;; 301 Moved permanently
541 ;; 302 Found
542 ;; 303 See other
543 ;; 304 Not modified
544 ;; 305 Use proxy
545 ;; 307 Temporary redirect
546 (let ((redirect-uri (or (mail-fetch-field "Location")
547 (mail-fetch-field "URI"))))
548 (case status-symbol
549 (multiple-choices ; 300
550 ;; Quoth the spec (section 10.3.1)
551 ;; -------------------------------
552 ;; The requested resource corresponds to any one of a set of
553 ;; representations, each with its own specific location and
554 ;; agent-driven negotiation information is being provided so
555 ;; that the user can select a preferred representation and
556 ;; redirect its request to that location.
557 ;; [...]
558 ;; If the server has a preferred choice of representation, it
559 ;; SHOULD include the specific URI for that representation in
560 ;; the Location field; user agents MAY use the Location field
561 ;; value for automatic redirection.
562 ;; -------------------------------
563 ;; We do not support agent-driven negotiation, so we just
564 ;; redirect to the preferred URI if one is provided.
565 nil)
566 ((moved-permanently found temporary-redirect) ; 301 302 307
567 ;; If the 301|302 status code is received in response to a
568 ;; request other than GET or HEAD, the user agent MUST NOT
569 ;; automatically redirect the request unless it can be
570 ;; confirmed by the user, since this might change the
571 ;; conditions under which the request was issued.
572 (unless (member url-http-method '("HEAD" "GET"))
573 (setq redirect-uri nil)))
574 (see-other ; 303
575 ;; The response to the request can be found under a different
576 ;; URI and SHOULD be retrieved using a GET method on that
577 ;; resource.
578 (setq url-http-method "GET"
579 url-http-data nil))
580 (not-modified ; 304
581 ;; The 304 response MUST NOT contain a message-body.
582 (url-http-debug "Extracting document from cache... (%s)"
583 (url-cache-create-filename (url-view-url t)))
584 (url-cache-extract (url-cache-create-filename (url-view-url t)))
585 (setq redirect-uri nil
586 success t))
587 (use-proxy ; 305
588 ;; The requested resource MUST be accessed through the
589 ;; proxy given by the Location field. The Location field
590 ;; gives the URI of the proxy. The recipient is expected
591 ;; to repeat this single request via the proxy. 305
592 ;; responses MUST only be generated by origin servers.
593 (error "Redirection thru a proxy server not supported: %s"
594 redirect-uri))
595 (otherwise
596 ;; Treat everything like '300'
597 nil))
598 (when redirect-uri
599 ;; Clean off any whitespace and/or <...> cruft.
600 (if (string-match "\\([^ \t]+\\)[ \t]" redirect-uri)
601 (setq redirect-uri (match-string 1 redirect-uri)))
602 (if (string-match "^<\\(.*\\)>$" redirect-uri)
603 (setq redirect-uri (match-string 1 redirect-uri)))
605 ;; Some stupid sites (like sourceforge) send a
606 ;; non-fully-qualified URL (ie: /), which royally confuses
607 ;; the URL library.
608 (if (not (string-match url-nonrelative-link redirect-uri))
609 ;; Be careful to use the real target URL, otherwise we may
610 ;; compute the redirection relative to the URL of the proxy.
611 (setq redirect-uri
612 (url-expand-file-name redirect-uri url-http-target-url)))
613 (let ((url-request-method url-http-method)
614 (url-request-data url-http-data)
615 (url-request-extra-headers url-http-extra-headers))
616 ;; Check existing number of redirects
617 (if (or (< url-max-redirections 0)
618 (and (> url-max-redirections 0)
619 (let ((events (car url-callback-arguments))
620 (old-redirects 0))
621 (while events
622 (if (eq (car events) :redirect)
623 (setq old-redirects (1+ old-redirects)))
624 (and (setq events (cdr events))
625 (setq events (cdr events))))
626 (< old-redirects url-max-redirections))))
627 ;; url-max-redirections hasn't been reached, so go
628 ;; ahead and redirect.
629 (progn
630 ;; Remember that the request was redirected.
631 (setf (car url-callback-arguments)
632 (nconc (list :redirect redirect-uri)
633 (car url-callback-arguments)))
634 ;; Put in the current buffer a forwarding pointer to the new
635 ;; destination buffer.
636 ;; FIXME: This is a hack to fix url-retrieve-synchronously
637 ;; without changing the API. Instead url-retrieve should
638 ;; either simply not return the "destination" buffer, or it
639 ;; should take an optional `dest-buf' argument.
640 (set (make-local-variable 'url-redirect-buffer)
641 (url-retrieve-internal
642 redirect-uri url-callback-function
643 url-callback-arguments
644 (url-silent url-current-object)))
645 (url-mark-buffer-as-dead buffer))
646 ;; We hit url-max-redirections, so issue an error and
647 ;; stop redirecting.
648 (url-http-debug "Maximum redirections reached")
649 (setf (car url-callback-arguments)
650 (nconc (list :error (list 'error 'http-redirect-limit
651 redirect-uri))
652 (car url-callback-arguments)))
653 (setq success t))))))
654 (4 ; Client error
655 ;; 400 Bad Request
656 ;; 401 Unauthorized
657 ;; 402 Payment required
658 ;; 403 Forbidden
659 ;; 404 Not found
660 ;; 405 Method not allowed
661 ;; 406 Not acceptable
662 ;; 407 Proxy authentication required
663 ;; 408 Request time-out
664 ;; 409 Conflict
665 ;; 410 Gone
666 ;; 411 Length required
667 ;; 412 Precondition failed
668 ;; 413 Request entity too large
669 ;; 414 Request-URI too large
670 ;; 415 Unsupported media type
671 ;; 416 Requested range not satisfiable
672 ;; 417 Expectation failed
673 ;; 422 Unprocessable Entity (Added by DAV)
674 ;; 423 Locked
675 ;; 424 Failed Dependency
676 (case status-symbol
677 (unauthorized ; 401
678 ;; The request requires user authentication. The response
679 ;; MUST include a WWW-Authenticate header field containing a
680 ;; challenge applicable to the requested resource. The
681 ;; client MAY repeat the request with a suitable
682 ;; Authorization header field.
683 (url-http-handle-authentication nil))
684 (payment-required ; 402
685 ;; This code is reserved for future use
686 (url-mark-buffer-as-dead buffer)
687 (error "Somebody wants you to give them money"))
688 (forbidden ; 403
689 ;; The server understood the request, but is refusing to
690 ;; fulfill it. Authorization will not help and the request
691 ;; SHOULD NOT be repeated.
692 (setq success t))
693 (not-found ; 404
694 ;; Not found
695 (setq success t))
696 (method-not-allowed ; 405
697 ;; The method specified in the Request-Line is not allowed
698 ;; for the resource identified by the Request-URI. The
699 ;; response MUST include an Allow header containing a list of
700 ;; valid methods for the requested resource.
701 (setq success t))
702 (not-acceptable ; 406
703 ;; The resource identified by the request is only capable of
704 ;; generating response entities which have content
705 ;; characteristics not acceptable according to the accept
706 ;; headers sent in the request.
707 (setq success t))
708 (proxy-authentication-required ; 407
709 ;; This code is similar to 401 (Unauthorized), but indicates
710 ;; that the client must first authenticate itself with the
711 ;; proxy. The proxy MUST return a Proxy-Authenticate header
712 ;; field containing a challenge applicable to the proxy for
713 ;; the requested resource.
714 (url-http-handle-authentication t))
715 (request-timeout ; 408
716 ;; The client did not produce a request within the time that
717 ;; the server was prepared to wait. The client MAY repeat
718 ;; the request without modifications at any later time.
719 (setq success t))
720 (conflict ; 409
721 ;; The request could not be completed due to a conflict with
722 ;; the current state of the resource. This code is only
723 ;; allowed in situations where it is expected that the user
724 ;; might be able to resolve the conflict and resubmit the
725 ;; request. The response body SHOULD include enough
726 ;; information for the user to recognize the source of the
727 ;; conflict.
728 (setq success t))
729 (gone ; 410
730 ;; The requested resource is no longer available at the
731 ;; server and no forwarding address is known.
732 (setq success t))
733 (length-required ; 411
734 ;; The server refuses to accept the request without a defined
735 ;; Content-Length. The client MAY repeat the request if it
736 ;; adds a valid Content-Length header field containing the
737 ;; length of the message-body in the request message.
739 ;; NOTE - this will never happen because
740 ;; `url-http-create-request' automatically calculates the
741 ;; content-length.
742 (setq success t))
743 (precondition-failed ; 412
744 ;; The precondition given in one or more of the
745 ;; request-header fields evaluated to false when it was
746 ;; tested on the server.
747 (setq success t))
748 ((request-entity-too-large request-uri-too-large) ; 413 414
749 ;; The server is refusing to process a request because the
750 ;; request entity|URI is larger than the server is willing or
751 ;; able to process.
752 (setq success t))
753 (unsupported-media-type ; 415
754 ;; The server is refusing to service the request because the
755 ;; entity of the request is in a format not supported by the
756 ;; requested resource for the requested method.
757 (setq success t))
758 (requested-range-not-satisfiable ; 416
759 ;; A server SHOULD return a response with this status code if
760 ;; a request included a Range request-header field, and none
761 ;; of the range-specifier values in this field overlap the
762 ;; current extent of the selected resource, and the request
763 ;; did not include an If-Range request-header field.
764 (setq success t))
765 (expectation-failed ; 417
766 ;; The expectation given in an Expect request-header field
767 ;; could not be met by this server, or, if the server is a
768 ;; proxy, the server has unambiguous evidence that the
769 ;; request could not be met by the next-hop server.
770 (setq success t))
771 (otherwise
772 ;; The request could not be understood by the server due to
773 ;; malformed syntax. The client SHOULD NOT repeat the
774 ;; request without modifications.
775 (setq success t)))
776 ;; Tell the callback that an error occurred, and what the
777 ;; status code was.
778 (when success
779 (setf (car url-callback-arguments)
780 (nconc (list :error (list 'error 'http url-http-response-status))
781 (car url-callback-arguments)))))
783 ;; 500 Internal server error
784 ;; 501 Not implemented
785 ;; 502 Bad gateway
786 ;; 503 Service unavailable
787 ;; 504 Gateway time-out
788 ;; 505 HTTP version not supported
789 ;; 507 Insufficient storage
790 (setq success t)
791 (case url-http-response-status
792 (not-implemented ; 501
793 ;; The server does not support the functionality required to
794 ;; fulfill the request.
795 nil)
796 (bad-gateway ; 502
797 ;; The server, while acting as a gateway or proxy, received
798 ;; an invalid response from the upstream server it accessed
799 ;; in attempting to fulfill the request.
800 nil)
801 (service-unavailable ; 503
802 ;; The server is currently unable to handle the request due
803 ;; to a temporary overloading or maintenance of the server.
804 ;; The implication is that this is a temporary condition
805 ;; which will be alleviated after some delay. If known, the
806 ;; length of the delay MAY be indicated in a Retry-After
807 ;; header. If no Retry-After is given, the client SHOULD
808 ;; handle the response as it would for a 500 response.
809 nil)
810 (gateway-timeout ; 504
811 ;; The server, while acting as a gateway or proxy, did not
812 ;; receive a timely response from the upstream server
813 ;; specified by the URI (e.g. HTTP, FTP, LDAP) or some other
814 ;; auxiliary server (e.g. DNS) it needed to access in
815 ;; attempting to complete the request.
816 nil)
817 (http-version-not-supported ; 505
818 ;; The server does not support, or refuses to support, the
819 ;; HTTP protocol version that was used in the request
820 ;; message.
821 nil)
822 (insufficient-storage ; 507 (DAV)
823 ;; The method could not be performed on the resource
824 ;; because the server is unable to store the representation
825 ;; needed to successfully complete the request. This
826 ;; condition is considered to be temporary. If the request
827 ;; which received this status code was the result of a user
828 ;; action, the request MUST NOT be repeated until it is
829 ;; requested by a separate user action.
830 nil))
831 ;; Tell the callback that an error occurred, and what the
832 ;; status code was.
833 (when success
834 (setf (car url-callback-arguments)
835 (nconc (list :error (list 'error 'http url-http-response-status))
836 (car url-callback-arguments)))))
837 (otherwise
838 (error "Unknown class of HTTP response code: %d (%d)"
839 class url-http-response-status)))
840 (if (not success)
841 (url-mark-buffer-as-dead buffer))
842 (url-http-debug "Finished parsing HTTP headers: %S" success)
843 (widen)
844 success))
846 ;; Miscellaneous
847 (defun url-http-activate-callback ()
848 "Activate callback specified when this buffer was created."
849 (declare (special url-http-process
850 url-callback-function
851 url-callback-arguments))
852 (url-http-mark-connection-as-free (url-host url-current-object)
853 (url-port url-current-object)
854 url-http-process)
855 (url-http-debug "Activating callback in buffer (%s)" (buffer-name))
856 (apply url-callback-function url-callback-arguments))
858 ;; )
860 ;; These unfortunately cannot be macros... please ignore them!
861 (defun url-http-idle-sentinel (proc why)
862 "Remove (now defunct) process PROC from the list of open connections."
863 (maphash (lambda (key val)
864 (if (memq proc val)
865 (puthash key (delq proc val) url-http-open-connections)))
866 url-http-open-connections))
868 (defun url-http-end-of-document-sentinel (proc why)
869 ;; Sentinel used for old HTTP/0.9 or connections we know are going
870 ;; to die as the 'end of document' notifier.
871 (url-http-debug "url-http-end-of-document-sentinel in buffer (%s)"
872 (process-buffer proc))
873 (url-http-idle-sentinel proc why)
874 (when (buffer-name (process-buffer proc))
875 (with-current-buffer (process-buffer proc)
876 (goto-char (point-min))
877 (if (not (looking-at "HTTP/"))
878 ;; HTTP/0.9 just gets passed back no matter what
879 (url-http-activate-callback)
880 (if (url-http-parse-headers)
881 (url-http-activate-callback))))))
883 (defun url-http-simple-after-change-function (st nd length)
884 ;; Function used when we do NOT know how long the document is going to be
885 ;; Just _very_ simple 'downloaded %d' type of info.
886 (declare (special url-http-end-of-headers))
887 (url-lazy-message "Reading %s..." (url-pretty-length nd)))
889 (defun url-http-content-length-after-change-function (st nd length)
890 "Function used when we DO know how long the document is going to be.
891 More sophisticated percentage downloaded, etc.
892 Also does minimal parsing of HTTP headers and will actually cause
893 the callback to be triggered."
894 (declare (special url-current-object
895 url-http-end-of-headers
896 url-http-content-length
897 url-http-content-type
898 url-http-process))
899 (if url-http-content-type
900 (url-display-percentage
901 "Reading [%s]... %s of %s (%d%%)"
902 (url-percentage (- nd url-http-end-of-headers)
903 url-http-content-length)
904 url-http-content-type
905 (url-pretty-length (- nd url-http-end-of-headers))
906 (url-pretty-length url-http-content-length)
907 (url-percentage (- nd url-http-end-of-headers)
908 url-http-content-length))
909 (url-display-percentage
910 "Reading... %s of %s (%d%%)"
911 (url-percentage (- nd url-http-end-of-headers)
912 url-http-content-length)
913 (url-pretty-length (- nd url-http-end-of-headers))
914 (url-pretty-length url-http-content-length)
915 (url-percentage (- nd url-http-end-of-headers)
916 url-http-content-length)))
918 (if (> (- nd url-http-end-of-headers) url-http-content-length)
919 (progn
920 ;; Found the end of the document! Wheee!
921 (url-display-percentage nil nil)
922 (url-lazy-message "Reading... done.")
923 (if (url-http-parse-headers)
924 (url-http-activate-callback)))))
926 (defun url-http-chunked-encoding-after-change-function (st nd length)
927 "Function used when dealing with 'chunked' encoding.
928 Cannot give a sophisticated percentage, but we need a different
929 function to look for the special 0-length chunk that signifies
930 the end of the document."
931 (declare (special url-current-object
932 url-http-end-of-headers
933 url-http-content-type
934 url-http-chunked-length
935 url-http-chunked-counter
936 url-http-process url-http-chunked-start))
937 (save-excursion
938 (goto-char st)
939 (let ((read-next-chunk t)
940 (case-fold-search t)
941 (regexp nil)
942 (no-initial-crlf nil))
943 ;; We need to loop thru looking for more chunks even within
944 ;; one after-change-function call.
945 (while read-next-chunk
946 (setq no-initial-crlf (= 0 url-http-chunked-counter))
947 (if url-http-content-type
948 (url-display-percentage nil
949 "Reading [%s]... chunk #%d"
950 url-http-content-type url-http-chunked-counter)
951 (url-display-percentage nil
952 "Reading... chunk #%d"
953 url-http-chunked-counter))
954 (url-http-debug "Reading chunk %d (%d %d %d)"
955 url-http-chunked-counter st nd length)
956 (setq regexp (if no-initial-crlf
957 "\\([0-9a-z]+\\).*\r?\n"
958 "\r?\n\\([0-9a-z]+\\).*\r?\n"))
960 (if url-http-chunked-start
961 ;; We know how long the chunk is supposed to be, skip over
962 ;; leading crap if possible.
963 (if (> nd (+ url-http-chunked-start url-http-chunked-length))
964 (progn
965 (url-http-debug "Got to the end of chunk #%d!"
966 url-http-chunked-counter)
967 (goto-char (+ url-http-chunked-start
968 url-http-chunked-length)))
969 (url-http-debug "Still need %d bytes to hit end of chunk"
970 (- (+ url-http-chunked-start
971 url-http-chunked-length)
972 nd))
973 (setq read-next-chunk nil)))
974 (if (not read-next-chunk)
975 (url-http-debug "Still spinning for next chunk...")
976 (if no-initial-crlf (skip-chars-forward "\r\n"))
977 (if (not (looking-at regexp))
978 (progn
979 ;; Must not have received the entirety of the chunk header,
980 ;; need to spin some more.
981 (url-http-debug "Did not see start of chunk @ %d!" (point))
982 (setq read-next-chunk nil))
983 (add-text-properties (match-beginning 0) (match-end 0)
984 (list 'start-open t
985 'end-open t
986 'chunked-encoding t
987 'face 'cursor
988 'invisible t))
989 (setq url-http-chunked-length (string-to-number (buffer-substring
990 (match-beginning 1)
991 (match-end 1))
993 url-http-chunked-counter (1+ url-http-chunked-counter)
994 url-http-chunked-start (set-marker
995 (or url-http-chunked-start
996 (make-marker))
997 (match-end 0)))
998 ; (if (not url-http-debug)
999 (delete-region (match-beginning 0) (match-end 0));)
1000 (url-http-debug "Saw start of chunk %d (length=%d, start=%d"
1001 url-http-chunked-counter url-http-chunked-length
1002 (marker-position url-http-chunked-start))
1003 (if (= 0 url-http-chunked-length)
1004 (progn
1005 ;; Found the end of the document! Wheee!
1006 (url-http-debug "Saw end of stream chunk!")
1007 (setq read-next-chunk nil)
1008 (url-display-percentage nil nil)
1009 ;; Every chunk, even the last 0-length one, is
1010 ;; terminated by CRLF. Skip it.
1011 (when (looking-at "\r?\n")
1012 (url-http-debug "Removing terminator of last chunk")
1013 (delete-region (match-beginning 0) (match-end 0)))
1014 (if (re-search-forward "^\r*$" nil t)
1015 (url-http-debug "Saw end of trailers..."))
1016 (if (url-http-parse-headers)
1017 (url-http-activate-callback))))))))))
1019 (defun url-http-wait-for-headers-change-function (st nd length)
1020 ;; This will wait for the headers to arrive and then splice in the
1021 ;; next appropriate after-change-function, etc.
1022 (declare (special url-current-object
1023 url-http-end-of-headers
1024 url-http-content-type
1025 url-http-content-length
1026 url-http-transfer-encoding
1027 url-callback-function
1028 url-callback-arguments
1029 url-http-process
1030 url-http-method
1031 url-http-after-change-function
1032 url-http-response-status))
1033 (url-http-debug "url-http-wait-for-headers-change-function (%s)"
1034 (buffer-name))
1035 (let ((end-of-headers nil)
1036 (old-http nil)
1037 (process-buffer (current-buffer))
1038 (content-length nil))
1039 (when (not (bobp))
1040 (goto-char (point-min))
1041 (if (and (looking-at ".*\n") ; have one line at least
1042 (not (looking-at "^HTTP/[1-9]\\.[0-9]")))
1043 ;; Not HTTP/x.y data, must be 0.9
1044 ;; God, I wish this could die.
1045 (setq end-of-headers t
1046 url-http-end-of-headers 0
1047 old-http t)
1048 (when (re-search-forward "^\r*$" nil t)
1049 ;; Saw the end of the headers
1050 (url-http-debug "Saw end of headers... (%s)" (buffer-name))
1051 (setq url-http-end-of-headers (set-marker (make-marker)
1052 (point))
1053 end-of-headers t)
1054 (url-http-clean-headers)))
1056 (if (not end-of-headers)
1057 ;; Haven't seen the end of the headers yet, need to wait
1058 ;; for more data to arrive.
1060 (unless old-http
1061 (url-http-parse-response)
1062 (mail-narrow-to-head)
1063 (setq url-http-transfer-encoding (mail-fetch-field
1064 "transfer-encoding")
1065 url-http-content-type (mail-fetch-field "content-type"))
1066 (if (mail-fetch-field "content-length")
1067 (setq url-http-content-length
1068 (string-to-number (mail-fetch-field "content-length"))))
1069 (widen))
1070 (when url-http-transfer-encoding
1071 (setq url-http-transfer-encoding
1072 (downcase url-http-transfer-encoding)))
1074 (cond
1075 ((null url-http-response-status)
1076 ;; We got back a headerless malformed response from the
1077 ;; server.
1078 (url-http-activate-callback))
1079 ((or (= url-http-response-status 204)
1080 (= url-http-response-status 205))
1081 (url-http-debug "%d response must have headers only (%s)."
1082 url-http-response-status (buffer-name))
1083 (when (url-http-parse-headers)
1084 (url-http-activate-callback)))
1085 ((string= "HEAD" url-http-method)
1086 ;; A HEAD request is _ALWAYS_ terminated by the header
1087 ;; information, regardless of any entity headers,
1088 ;; according to section 4.4 of the HTTP/1.1 draft.
1089 (url-http-debug "HEAD request must have headers only (%s)."
1090 (buffer-name))
1091 (when (url-http-parse-headers)
1092 (url-http-activate-callback)))
1093 ((string= "CONNECT" url-http-method)
1094 ;; A CONNECT request is finished, but we cannot stick this
1095 ;; back on the free connection list
1096 (url-http-debug "CONNECT request must have headers only.")
1097 (when (url-http-parse-headers)
1098 (url-http-activate-callback)))
1099 ((equal url-http-response-status 304)
1100 ;; Only allowed to have a header section. We have to handle
1101 ;; this here instead of in url-http-parse-headers because if
1102 ;; you have a cached copy of something without a known
1103 ;; content-length, and try to retrieve it from the cache, we'd
1104 ;; fall into the 'being dumb' section and wait for the
1105 ;; connection to terminate, which means we'd wait for 10
1106 ;; seconds for the keep-alives to time out on some servers.
1107 (when (url-http-parse-headers)
1108 (url-http-activate-callback)))
1109 (old-http
1110 ;; HTTP/0.9 always signaled end-of-connection by closing the
1111 ;; connection.
1112 (url-http-debug
1113 "Saw HTTP/0.9 response, connection closed means end of document.")
1114 (setq url-http-after-change-function
1115 'url-http-simple-after-change-function))
1116 ((equal url-http-transfer-encoding "chunked")
1117 (url-http-debug "Saw chunked encoding.")
1118 (setq url-http-after-change-function
1119 'url-http-chunked-encoding-after-change-function)
1120 (when (> nd url-http-end-of-headers)
1121 (url-http-debug
1122 "Calling initial chunked-encoding for extra data at end of headers")
1123 (url-http-chunked-encoding-after-change-function
1124 (marker-position url-http-end-of-headers) nd
1125 (- nd url-http-end-of-headers))))
1126 ((integerp url-http-content-length)
1127 (url-http-debug
1128 "Got a content-length, being smart about document end.")
1129 (setq url-http-after-change-function
1130 'url-http-content-length-after-change-function)
1131 (cond
1132 ((= 0 url-http-content-length)
1133 ;; We got a NULL body! Activate the callback
1134 ;; immediately!
1135 (url-http-debug
1136 "Got 0-length content-length, activating callback immediately.")
1137 (when (url-http-parse-headers)
1138 (url-http-activate-callback)))
1139 ((> nd url-http-end-of-headers)
1140 ;; Have some leftover data
1141 (url-http-debug "Calling initial content-length for extra data at end of headers")
1142 (url-http-content-length-after-change-function
1143 (marker-position url-http-end-of-headers)
1145 (- nd url-http-end-of-headers)))
1147 nil)))
1149 (url-http-debug "No content-length, being dumb.")
1150 (setq url-http-after-change-function
1151 'url-http-simple-after-change-function)))))
1152 ;; We are still at the beginning of the buffer... must just be
1153 ;; waiting for a response.
1154 (url-http-debug "Spinning waiting for headers...")
1155 (when (eq process-buffer (current-buffer))
1156 (goto-char (point-max)))))
1158 ;;;###autoload
1159 (defun url-http (url callback cbargs)
1160 "Retrieve URL via HTTP asynchronously.
1161 URL must be a parsed URL. See `url-generic-parse-url' for details.
1162 When retrieval is completed, the function CALLBACK is executed with
1163 CBARGS as the arguments."
1164 (check-type url vector "Need a pre-parsed URL.")
1165 (declare (special url-current-object
1166 url-http-end-of-headers
1167 url-http-content-type
1168 url-http-content-length
1169 url-http-transfer-encoding
1170 url-http-after-change-function
1171 url-callback-function
1172 url-callback-arguments
1173 url-show-status
1174 url-http-method
1175 url-http-extra-headers
1176 url-http-data
1177 url-http-chunked-length
1178 url-http-chunked-start
1179 url-http-chunked-counter
1180 url-http-process))
1181 (let* ((host (url-host (or url-using-proxy url)))
1182 (port (url-port (or url-using-proxy url)))
1183 (connection (url-http-find-free-connection host port))
1184 (buffer (generate-new-buffer (format " *http %s:%d*" host port))))
1185 (if (not connection)
1186 ;; Failed to open the connection for some reason
1187 (progn
1188 (kill-buffer buffer)
1189 (setq buffer nil)
1190 (error "Could not create connection to %s:%d" host port))
1191 (with-current-buffer buffer
1192 (mm-disable-multibyte)
1193 (setq url-current-object url
1194 mode-line-format "%b [%s]")
1196 (dolist (var '(url-http-end-of-headers
1197 url-http-content-type
1198 url-http-content-length
1199 url-http-transfer-encoding
1200 url-http-after-change-function
1201 url-http-response-version
1202 url-http-response-status
1203 url-http-chunked-length
1204 url-http-chunked-counter
1205 url-http-chunked-start
1206 url-callback-function
1207 url-callback-arguments
1208 url-show-status
1209 url-http-process
1210 url-http-method
1211 url-http-extra-headers
1212 url-http-data
1213 url-http-target-url
1214 url-http-connection-opened
1215 url-http-proxy))
1216 (set (make-local-variable var) nil))
1218 (setq url-http-method (or url-request-method "GET")
1219 url-http-extra-headers url-request-extra-headers
1220 url-http-data url-request-data
1221 url-http-process connection
1222 url-http-chunked-length nil
1223 url-http-chunked-start nil
1224 url-http-chunked-counter 0
1225 url-callback-function callback
1226 url-callback-arguments cbargs
1227 url-http-after-change-function 'url-http-wait-for-headers-change-function
1228 url-http-target-url url-current-object
1229 url-http-connection-opened nil
1230 url-http-proxy url-using-proxy)
1232 (set-process-buffer connection buffer)
1233 (set-process-filter connection 'url-http-generic-filter)
1234 (let ((status (process-status connection)))
1235 (cond
1236 ((eq status 'connect)
1237 ;; Asynchronous connection
1238 (set-process-sentinel connection 'url-http-async-sentinel))
1239 ((eq status 'failed)
1240 ;; Asynchronous connection failed
1241 (error "Could not create connection to %s:%d" host port))
1243 (set-process-sentinel connection 'url-http-end-of-document-sentinel)
1244 (process-send-string connection (url-http-create-request)))))))
1245 buffer))
1247 (defun url-http-async-sentinel (proc why)
1248 (declare (special url-callback-arguments))
1249 ;; We are performing an asynchronous connection, and a status change
1250 ;; has occurred.
1251 (when (buffer-name (process-buffer proc))
1252 (with-current-buffer (process-buffer proc)
1253 (cond
1254 (url-http-connection-opened
1255 (url-http-end-of-document-sentinel proc why))
1256 ((string= (substring why 0 4) "open")
1257 (setq url-http-connection-opened t)
1258 (condition-case error
1259 (process-send-string proc (url-http-create-request))
1260 (file-error
1261 (setq url-http-connection-opened nil)
1262 (message "HTTP error: %s" error))))
1264 (setf (car url-callback-arguments)
1265 (nconc (list :error (list 'error 'connection-failed why
1266 :host (url-host (or url-http-proxy url-current-object))
1267 :service (url-port (or url-http-proxy url-current-object))))
1268 (car url-callback-arguments)))
1269 (url-http-activate-callback))))))
1271 ;; Since Emacs 19/20 does not allow you to change the
1272 ;; `after-change-functions' hook in the midst of running them, we fake
1273 ;; an after change by hooking into the process filter and inserting
1274 ;; the data ourselves. This is slightly less efficient, but there
1275 ;; were tons of weird ways the after-change code was biting us in the
1276 ;; shorts.
1277 ;; FIXME this can probably be simplified since the above is no longer true.
1278 (defun url-http-generic-filter (proc data)
1279 ;; Sometimes we get a zero-length data chunk after the process has
1280 ;; been changed to 'free', which means it has no buffer associated
1281 ;; with it. Do nothing if there is no buffer, or 0 length data.
1282 (declare (special url-http-after-change-function))
1283 (and (process-buffer proc)
1284 (/= (length data) 0)
1285 (with-current-buffer (process-buffer proc)
1286 (url-http-debug "Calling after change function `%s' for `%S'" url-http-after-change-function proc)
1287 (funcall url-http-after-change-function
1288 (point-max)
1289 (progn
1290 (goto-char (point-max))
1291 (insert data)
1292 (point-max))
1293 (length data)))))
1295 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
1296 ;;; file-name-handler stuff from here on out
1297 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
1298 (defalias 'url-http-symbol-value-in-buffer
1299 (if (fboundp 'symbol-value-in-buffer)
1300 'symbol-value-in-buffer
1301 (lambda (symbol buffer &optional unbound-value)
1302 "Return the value of SYMBOL in BUFFER, or UNBOUND-VALUE if it is unbound."
1303 (with-current-buffer buffer
1304 (if (not (boundp symbol))
1305 unbound-value
1306 (symbol-value symbol))))))
1308 (defun url-http-head (url)
1309 (let ((url-request-method "HEAD")
1310 (url-request-data nil))
1311 (url-retrieve-synchronously url)))
1313 ;;;###autoload
1314 (defun url-http-file-exists-p (url)
1315 (let ((status nil)
1316 (exists nil)
1317 (buffer (url-http-head url)))
1318 (if (not buffer)
1319 (setq exists nil)
1320 (setq status (url-http-symbol-value-in-buffer 'url-http-response-status
1321 buffer 500)
1322 exists (and (integerp status)
1323 (>= status 200) (< status 300)))
1324 (kill-buffer buffer))
1325 exists))
1327 ;;;###autoload
1328 (defalias 'url-http-file-readable-p 'url-http-file-exists-p)
1330 (defun url-http-head-file-attributes (url &optional id-format)
1331 (let ((buffer (url-http-head url)))
1332 (when buffer
1333 (prog1
1334 (list
1335 nil ;dir / link / normal file
1336 1 ;number of links to file.
1337 0 0 ;uid ; gid
1338 nil nil nil ;atime ; mtime ; ctime
1339 (url-http-symbol-value-in-buffer 'url-http-content-length
1340 buffer -1)
1341 (eval-when-compile (make-string 10 ?-))
1342 nil nil nil) ;whether gid would change ; inode ; device.
1343 (kill-buffer buffer)))))
1345 (declare-function url-dav-file-attributes "url-dav" (url &optional id-format))
1347 ;;;###autoload
1348 (defun url-http-file-attributes (url &optional id-format)
1349 (if (url-dav-supported-p url)
1350 (url-dav-file-attributes url id-format)
1351 (url-http-head-file-attributes url id-format)))
1353 ;;;###autoload
1354 (defun url-http-options (url)
1355 "Return a property list describing options available for URL.
1356 This list is retrieved using the `OPTIONS' HTTP method.
1358 Property list members:
1360 methods
1361 A list of symbols specifying what HTTP methods the resource
1362 supports.
1365 A list of numbers specifying what DAV protocol/schema versions are
1366 supported.
1368 dasl
1369 A list of supported DASL search types supported (string form)
1371 ranges
1372 A list of the units available for use in partial document fetches.
1375 The `Platform For Privacy Protection' description for the resource.
1376 Currently this is just the raw header contents. This is likely to
1377 change once P3P is formally supported by the URL package or
1378 Emacs/W3."
1379 (let* ((url-request-method "OPTIONS")
1380 (url-request-data nil)
1381 (buffer (url-retrieve-synchronously url))
1382 (header nil)
1383 (options nil))
1384 (when (and buffer (= 2 (/ (url-http-symbol-value-in-buffer
1385 'url-http-response-status buffer 0) 100)))
1386 ;; Only parse the options if we got a 2xx response code!
1387 (with-current-buffer buffer
1388 (save-restriction
1389 (save-match-data
1390 (mail-narrow-to-head)
1392 ;; Figure out what methods are supported.
1393 (when (setq header (mail-fetch-field "allow"))
1394 (setq options (plist-put
1395 options 'methods
1396 (mapcar 'intern (split-string header "[ ,]+")))))
1398 ;; Check for DAV
1399 (when (setq header (mail-fetch-field "dav"))
1400 (setq options (plist-put
1401 options 'dav
1402 (delq 0
1403 (mapcar 'string-to-number
1404 (split-string header "[, ]+"))))))
1406 ;; Now for DASL
1407 (when (setq header (mail-fetch-field "dasl"))
1408 (setq options (plist-put
1409 options 'dasl
1410 (split-string header "[, ]+"))))
1412 ;; P3P - should get more detailed here. FIXME
1413 (when (setq header (mail-fetch-field "p3p"))
1414 (setq options (plist-put options 'p3p header)))
1416 ;; Check for whether they accept byte-range requests.
1417 (when (setq header (mail-fetch-field "accept-ranges"))
1418 (setq options (plist-put
1419 options 'ranges
1420 (delq 'none
1421 (mapcar 'intern
1422 (split-string header "[, ]+"))))))
1423 ))))
1424 (if buffer (kill-buffer buffer))
1425 options))
1427 ;; HTTPS. This used to be in url-https.el, but that file collides
1428 ;; with url-http.el on systems with 8-character file names.
1429 (require 'tls)
1431 ;;;###autoload
1432 (defconst url-https-default-port 443 "Default HTTPS port.")
1433 ;;;###autoload
1434 (defconst url-https-asynchronous-p t "HTTPS retrievals are asynchronous.")
1436 ;; FIXME what is the point of this alias being an autoload?
1437 ;; Trying to use it will not cause url-http to be loaded,
1438 ;; since the full alias just gets dumped into loaddefs.el.
1440 ;;;###autoload (autoload 'url-default-expander "url-expand")
1441 ;;;###autoload
1442 (defalias 'url-https-expand-file-name 'url-default-expander)
1444 (defmacro url-https-create-secure-wrapper (method args)
1445 `(defun ,(intern (format (if method "url-https-%s" "url-https") method)) ,args
1446 ,(format "HTTPS wrapper around `%s' call." (or method "url-http"))
1447 (let ((url-gateway-method 'tls))
1448 (,(intern (format (if method "url-http-%s" "url-http") method))
1449 ,@(remove '&rest (remove '&optional args))))))
1451 ;;;###autoload (autoload 'url-https "url-http")
1452 (url-https-create-secure-wrapper nil (url callback cbargs))
1453 ;;;###autoload (autoload 'url-https-file-exists-p "url-http")
1454 (url-https-create-secure-wrapper file-exists-p (url))
1455 ;;;###autoload (autoload 'url-https-file-readable-p "url-http")
1456 (url-https-create-secure-wrapper file-readable-p (url))
1457 ;;;###autoload (autoload 'url-https-file-attributes "url-http")
1458 (url-https-create-secure-wrapper file-attributes (url &optional id-format))
1460 (provide 'url-http)
1462 ;;; url-http.el ends here