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