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