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