| 1 | ;;; url-http.el --- HTTP retrieval routines |
| 2 | |
| 3 | ;; Copyright (C) 1999, 2001, 2004-2013 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 3 of the License, or |
| 13 | ;; (at your option) 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. If not, see <http://www.gnu.org/licenses/>. |
| 22 | |
| 23 | ;;; Commentary: |
| 24 | |
| 25 | ;;; Code: |
| 26 | |
| 27 | (eval-when-compile (require 'cl-lib)) |
| 28 | |
| 29 | (defvar url-callback-arguments) |
| 30 | (defvar url-callback-function) |
| 31 | (defvar url-current-object) |
| 32 | (defvar url-http-after-change-function) |
| 33 | (defvar url-http-chunked-counter) |
| 34 | (defvar url-http-chunked-length) |
| 35 | (defvar url-http-chunked-start) |
| 36 | (defvar url-http-connection-opened) |
| 37 | (defvar url-http-content-length) |
| 38 | (defvar url-http-content-type) |
| 39 | (defvar url-http-data) |
| 40 | (defvar url-http-end-of-headers) |
| 41 | (defvar url-http-extra-headers) |
| 42 | (defvar url-http-method) |
| 43 | (defvar url-http-no-retry) |
| 44 | (defvar url-http-process) |
| 45 | (defvar url-http-proxy) |
| 46 | (defvar url-http-response-status) |
| 47 | (defvar url-http-response-version) |
| 48 | (defvar url-http-target-url) |
| 49 | (defvar url-http-transfer-encoding) |
| 50 | (defvar url-http-end-of-headers) |
| 51 | (defvar url-show-status) |
| 52 | |
| 53 | (require 'url-gw) |
| 54 | (require 'url-util) |
| 55 | (require 'url-parse) |
| 56 | (require 'url-cookie) |
| 57 | (require 'mail-parse) |
| 58 | (require 'url-auth) |
| 59 | (require 'url) |
| 60 | (autoload 'url-cache-create-filename "url-cache") |
| 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, |
| 79 | and other HTTP/1.1 specific features.") |
| 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 |
| 84 | nil will explicitly close the connection to the server after every |
| 85 | request.") |
| 86 | |
| 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") |
| 133 | (507 insufficient-storage "Insufficient storage")) |
| 134 | "The HTTP return codes and their text.") |
| 135 | |
| 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) |
| 158 | (set-process-query-on-exit-flag proc t) |
| 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) |
| 166 | (when (memq (process-status proc) '(open run connect)) |
| 167 | (set-process-buffer proc nil) |
| 168 | (set-process-sentinel proc 'url-http-idle-sentinel) |
| 169 | (set-process-query-on-exit-flag proc nil) |
| 170 | (puthash (cons host port) |
| 171 | (cons proc (gethash (cons host port) url-http-open-connections)) |
| 172 | url-http-open-connections)) |
| 173 | nil) |
| 174 | |
| 175 | (defun url-http-find-free-connection (host port) |
| 176 | (let ((conns (gethash (cons host port) url-http-open-connections)) |
| 177 | (connection nil)) |
| 178 | (while (and conns (not connection)) |
| 179 | (if (not (memq (process-status (car conns)) '(run open connect))) |
| 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)) |
| 184 | (setq connection (car conns)) |
| 185 | (url-http-debug "Found existing connection: %s:%d %S" host port connection)) |
| 186 | (pop conns)) |
| 187 | (if connection |
| 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) |
| 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)))) |
| 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 | "" |
| 218 | (format "User-Agent: %sURL/%s\r\n" |
| 219 | (if url-package-name |
| 220 | (concat url-package-name "/" url-package-version " ") |
| 221 | "") |
| 222 | url-version))) |
| 223 | |
| 224 | (defun url-http-create-request (&optional ref-url) |
| 225 | "Create an HTTP request for `url-http-target-url', referred to by REF-URL." |
| 226 | (let* ((extra-headers) |
| 227 | (request nil) |
| 228 | (no-cache (cdr-safe (assoc "Pragma" url-http-extra-headers))) |
| 229 | (using-proxy url-http-proxy) |
| 230 | (proxy-auth (if (or (cdr-safe (assoc "Proxy-Authorization" |
| 231 | url-http-extra-headers)) |
| 232 | (not using-proxy)) |
| 233 | nil |
| 234 | (let ((url-basic-auth-storage |
| 235 | 'url-http-proxy-basic-auth-storage)) |
| 236 | (url-get-authentication url-http-proxy nil 'any nil)))) |
| 237 | (real-fname (url-filename url-http-target-url)) |
| 238 | (host (url-host url-http-target-url)) |
| 239 | (auth (if (cdr-safe (assoc "Authorization" url-http-extra-headers)) |
| 240 | nil |
| 241 | (url-get-authentication (or |
| 242 | (and (boundp 'proxy-info) |
| 243 | proxy-info) |
| 244 | url-http-target-url) nil 'any nil)))) |
| 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 | |
| 253 | ;; Protection against stupid values in the referrer |
| 254 | (if (and ref-url (stringp ref-url) (or (string= ref-url "file:nil") |
| 255 | (string= ref-url ""))) |
| 256 | (setq ref-url nil)) |
| 257 | |
| 258 | ;; We do not want to expose the referrer if the user is paranoid. |
| 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 | |
| 264 | ;; url-http-extra-headers contains an assoc-list of |
| 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))) |
| 269 | url-http-extra-headers "\r\n")) |
| 270 | (if (not (equal extra-headers "")) |
| 271 | (setq extra-headers (concat extra-headers "\r\n"))) |
| 272 | |
| 273 | ;; This was done with a call to `format'. Concatenating parts has |
| 274 | ;; the advantage of keeping the parts of each header together and |
| 275 | ;; allows us to elide null lines directly, at the cost of making |
| 276 | ;; the layout less clear. |
| 277 | (setq request |
| 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 |
| 292 | (or url-http-method "GET") " " |
| 293 | (if using-proxy (url-recreate-url url-http-target-url) real-fname) |
| 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 |
| 298 | "Connection: " (if (or using-proxy |
| 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 |
| 306 | (if (/= (url-port url-http-target-url) |
| 307 | (url-scheme-get-property |
| 308 | (url-type url-http-target-url) 'default-port)) |
| 309 | (format |
| 310 | "Host: %s:%d\r\n" host (url-port url-http-target-url)) |
| 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 |
| 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)))) |
| 340 | ;; If-modified-since |
| 341 | (if (and (not no-cache) |
| 342 | (member url-http-method '("GET" nil))) |
| 343 | (let ((tm (url-is-cached url-http-target-url))) |
| 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 |
| 352 | (if url-http-data |
| 353 | (concat |
| 354 | "Content-length: " (number-to-string |
| 355 | (length url-http-data)) |
| 356 | "\r\n")) |
| 357 | ;; End request |
| 358 | "\r\n" |
| 359 | ;; Any data |
| 360 | url-http-data |
| 361 | ;; If `url-http-data' is nil, avoid two CRLFs (Bug#8931). |
| 362 | (if url-http-data "\r\n"))) |
| 363 | "")) |
| 364 | (url-http-debug "Request is: \n%s" request) |
| 365 | request)) |
| 366 | |
| 367 | ;; Parsing routines |
| 368 | (defun url-http-clean-headers () |
| 369 | "Remove trailing \r from header lines. |
| 370 | This allows us to use `mail-fetch-field', etc. |
| 371 | Return the number of characters removed." |
| 372 | (let ((end (marker-position url-http-end-of-headers))) |
| 373 | (goto-char (point-min)) |
| 374 | (while (re-search-forward "\r$" url-http-end-of-headers t) |
| 375 | (replace-match "")) |
| 376 | (- end url-http-end-of-headers))) |
| 377 | |
| 378 | (defvar status) |
| 379 | (defvar success) |
| 380 | |
| 381 | (defun url-http-handle-authentication (proxy) |
| 382 | (url-http-debug "Handling %s authentication" (if proxy "proxy" "normal")) |
| 383 | (let ((auths (or (nreverse |
| 384 | (mail-fetch-field |
| 385 | (if proxy "proxy-authenticate" "www-authenticate") |
| 386 | nil nil t)) |
| 387 | '("basic"))) |
| 388 | (type nil) |
| 389 | (url (url-recreate-url url-current-object)) |
| 390 | (auth-url (url-recreate-url |
| 391 | (if (and proxy (boundp 'url-http-proxy)) |
| 392 | url-http-proxy |
| 393 | url-current-object))) |
| 394 | (url-basic-auth-storage (if proxy |
| 395 | ;; Cheating, but who cares? :) |
| 396 | 'url-http-proxy-basic-auth-storage |
| 397 | 'url-http-real-basic-auth-storage)) |
| 398 | auth |
| 399 | (strength 0)) |
| 400 | |
| 401 | ;; find strongest supported auth |
| 402 | (dolist (this-auth auths) |
| 403 | (setq this-auth (url-eat-trailing-space |
| 404 | (url-strip-leading-spaces |
| 405 | this-auth))) |
| 406 | (let* ((this-type |
| 407 | (if (string-match "[ \t]" this-auth) |
| 408 | (downcase (substring this-auth 0 (match-beginning 0))) |
| 409 | (downcase this-auth))) |
| 410 | (registered (url-auth-registered this-type)) |
| 411 | (this-strength (cddr registered))) |
| 412 | (when (and registered (> this-strength strength)) |
| 413 | (setq auth this-auth |
| 414 | type this-type |
| 415 | strength this-strength)))) |
| 416 | |
| 417 | (if (not (url-auth-registered type)) |
| 418 | (progn |
| 419 | (widen) |
| 420 | (goto-char (point-max)) |
| 421 | (insert "<hr>Sorry, but I do not know how to handle " type |
| 422 | " authentication. If you'd like to write it," |
| 423 | " send it to " url-bug-address ".<hr>") |
| 424 | (setq status t)) |
| 425 | (let* ((args (url-parse-args (subst-char-in-string ?, ?\; auth))) |
| 426 | (auth (url-get-authentication auth-url |
| 427 | (cdr-safe (assoc "realm" args)) |
| 428 | type t args))) |
| 429 | (if (not auth) |
| 430 | (setq success t) |
| 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)) |
| 436 | (url-retrieve-internal url url-callback-function |
| 437 | url-callback-arguments))))))) |
| 438 | |
| 439 | (defun url-http-parse-response () |
| 440 | "Parse just the response code." |
| 441 | (if (not url-http-end-of-headers) |
| 442 | (error "Trying to parse HTTP response code in odd buffer: %s" (buffer-name))) |
| 443 | (url-http-debug "url-http-parse-response called in (%s)" (buffer-name)) |
| 444 | (goto-char (point-min)) |
| 445 | (skip-chars-forward " \t\n") ; Skip any blank crap |
| 446 | (skip-chars-forward "HTTP/") ; Skip HTTP Version |
| 447 | (setq url-http-response-version |
| 448 | (buffer-substring (point) |
| 449 | (progn |
| 450 | (skip-chars-forward "[0-9].") |
| 451 | (point)))) |
| 452 | (setq url-http-response-status (read (current-buffer)))) |
| 453 | |
| 454 | (defun url-http-handle-cookies () |
| 455 | "Handle all set-cookie / set-cookie2 headers in an HTTP response. |
| 456 | The buffer must already be narrowed to the headers, so `mail-fetch-field' will |
| 457 | work correctly." |
| 458 | (let ((cookies (nreverse (mail-fetch-field "Set-Cookie" nil nil t))) |
| 459 | (cookies2 (nreverse (mail-fetch-field "Set-Cookie2" nil nil t)))) |
| 460 | (and cookies (url-http-debug "Found %d Set-Cookie headers" (length cookies))) |
| 461 | (and cookies2 (url-http-debug "Found %d Set-Cookie2 headers" (length cookies2))) |
| 462 | (while cookies |
| 463 | (url-cookie-handle-set-cookie (pop cookies))) |
| 464 | ;;; (while cookies2 |
| 465 | ;;; (url-cookie-handle-set-cookie2 (pop cookies))) |
| 466 | ) |
| 467 | ) |
| 468 | |
| 469 | (defun url-http-parse-headers () |
| 470 | "Parse and handle HTTP specific headers. |
| 471 | Return t if and only if the current buffer is still active and |
| 472 | should be shown to the user." |
| 473 | ;; The comments after each status code handled are taken from RFC |
| 474 | ;; 2616 (HTTP/1.1) |
| 475 | (url-http-mark-connection-as-free (url-host url-current-object) |
| 476 | (url-port url-current-object) |
| 477 | url-http-process) |
| 478 | |
| 479 | (if (or (not (boundp 'url-http-end-of-headers)) |
| 480 | (not url-http-end-of-headers)) |
| 481 | (error "Trying to parse headers in odd buffer: %s" (buffer-name))) |
| 482 | (goto-char (point-min)) |
| 483 | (url-http-debug "url-http-parse-headers called in (%s)" (buffer-name)) |
| 484 | (url-http-parse-response) |
| 485 | (mail-narrow-to-head) |
| 486 | ;;(narrow-to-region (point-min) url-http-end-of-headers) |
| 487 | (let ((connection (mail-fetch-field "Connection"))) |
| 488 | ;; In HTTP 1.0, keep the connection only if there is a |
| 489 | ;; "Connection: keep-alive" header. |
| 490 | ;; In HTTP 1.1 (and greater), keep the connection unless there is a |
| 491 | ;; "Connection: close" header |
| 492 | (cond |
| 493 | ((string= url-http-response-version "1.0") |
| 494 | (unless (and connection |
| 495 | (string= (downcase connection) "keep-alive")) |
| 496 | (delete-process url-http-process))) |
| 497 | (t |
| 498 | (when (and connection |
| 499 | (string= (downcase connection) "close")) |
| 500 | (delete-process url-http-process))))) |
| 501 | (let ((buffer (current-buffer)) |
| 502 | (class nil) |
| 503 | (success nil) |
| 504 | ;; other status symbols: jewelry and luxury cars |
| 505 | (status-symbol (cadr (assq url-http-response-status url-http-codes)))) |
| 506 | (setq class (/ url-http-response-status 100)) |
| 507 | (url-http-debug "Parsed HTTP headers: class=%d status=%d" |
| 508 | class url-http-response-status) |
| 509 | (when (url-use-cookies url-http-target-url) |
| 510 | (url-http-handle-cookies)) |
| 511 | |
| 512 | (pcase class |
| 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) |
| 524 | (url-mark-buffer-as-dead buffer) |
| 525 | (error "HTTP responses in class 1xx not supported (%d)" |
| 526 | url-http-response-status)) |
| 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) |
| 536 | (pcase status-symbol |
| 537 | ((or `no-content `reset-content) |
| 538 | ;; No new data, just stay at the same document |
| 539 | (url-mark-buffer-as-dead buffer) |
| 540 | (setq success t)) |
| 541 | (_ |
| 542 | ;; Generic success for all others. Store in the cache, and |
| 543 | ;; mark it as successful. |
| 544 | (widen) |
| 545 | (if (and url-automatic-caching (equal url-http-method "GET")) |
| 546 | (url-store-in-cache buffer)) |
| 547 | (setq success t)))) |
| 548 | (3 ; Redirection |
| 549 | ;; 300 Multiple choices |
| 550 | ;; 301 Moved permanently |
| 551 | ;; 302 Found |
| 552 | ;; 303 See other |
| 553 | ;; 304 Not modified |
| 554 | ;; 305 Use proxy |
| 555 | ;; 307 Temporary redirect |
| 556 | (let ((redirect-uri (or (mail-fetch-field "Location") |
| 557 | (mail-fetch-field "URI")))) |
| 558 | (pcase status-symbol |
| 559 | (`multiple-choices ; 300 |
| 560 | ;; Quoth the spec (section 10.3.1) |
| 561 | ;; ------------------------------- |
| 562 | ;; The requested resource corresponds to any one of a set of |
| 563 | ;; representations, each with its own specific location and |
| 564 | ;; agent-driven negotiation information is being provided so |
| 565 | ;; that the user can select a preferred representation and |
| 566 | ;; redirect its request to that location. |
| 567 | ;; [...] |
| 568 | ;; If the server has a preferred choice of representation, it |
| 569 | ;; SHOULD include the specific URI for that representation in |
| 570 | ;; the Location field; user agents MAY use the Location field |
| 571 | ;; value for automatic redirection. |
| 572 | ;; ------------------------------- |
| 573 | ;; We do not support agent-driven negotiation, so we just |
| 574 | ;; redirect to the preferred URI if one is provided. |
| 575 | nil) |
| 576 | ((or `moved-permanently `found `temporary-redirect) ; 301 302 307 |
| 577 | ;; If the 301|302 status code is received in response to a |
| 578 | ;; request other than GET or HEAD, the user agent MUST NOT |
| 579 | ;; automatically redirect the request unless it can be |
| 580 | ;; confirmed by the user, since this might change the |
| 581 | ;; conditions under which the request was issued. |
| 582 | (unless (member url-http-method '("HEAD" "GET")) |
| 583 | (setq redirect-uri nil))) |
| 584 | (`see-other ; 303 |
| 585 | ;; The response to the request can be found under a different |
| 586 | ;; URI and SHOULD be retrieved using a GET method on that |
| 587 | ;; resource. |
| 588 | (setq url-http-method "GET" |
| 589 | url-http-data nil)) |
| 590 | (`not-modified ; 304 |
| 591 | ;; The 304 response MUST NOT contain a message-body. |
| 592 | (url-http-debug "Extracting document from cache... (%s)" |
| 593 | (url-cache-create-filename (url-view-url t))) |
| 594 | (url-cache-extract (url-cache-create-filename (url-view-url t))) |
| 595 | (setq redirect-uri nil |
| 596 | success t)) |
| 597 | (`use-proxy ; 305 |
| 598 | ;; The requested resource MUST be accessed through the |
| 599 | ;; proxy given by the Location field. The Location field |
| 600 | ;; gives the URI of the proxy. The recipient is expected |
| 601 | ;; to repeat this single request via the proxy. 305 |
| 602 | ;; responses MUST only be generated by origin servers. |
| 603 | (error "Redirection thru a proxy server not supported: %s" |
| 604 | redirect-uri)) |
| 605 | (_ |
| 606 | ;; Treat everything like '300' |
| 607 | nil)) |
| 608 | (when redirect-uri |
| 609 | ;; Clean off any whitespace and/or <...> cruft. |
| 610 | (if (string-match "\\([^ \t]+\\)[ \t]" redirect-uri) |
| 611 | (setq redirect-uri (match-string 1 redirect-uri))) |
| 612 | (if (string-match "^<\\(.*\\)>$" redirect-uri) |
| 613 | (setq redirect-uri (match-string 1 redirect-uri))) |
| 614 | |
| 615 | ;; Some stupid sites (like sourceforge) send a |
| 616 | ;; non-fully-qualified URL (ie: /), which royally confuses |
| 617 | ;; the URL library. |
| 618 | (if (not (string-match url-nonrelative-link redirect-uri)) |
| 619 | ;; Be careful to use the real target URL, otherwise we may |
| 620 | ;; compute the redirection relative to the URL of the proxy. |
| 621 | (setq redirect-uri |
| 622 | (url-expand-file-name redirect-uri url-http-target-url))) |
| 623 | (let ((url-request-method url-http-method) |
| 624 | (url-request-data url-http-data) |
| 625 | (url-request-extra-headers url-http-extra-headers)) |
| 626 | ;; Check existing number of redirects |
| 627 | (if (or (< url-max-redirections 0) |
| 628 | (and (> url-max-redirections 0) |
| 629 | (let ((events (car url-callback-arguments)) |
| 630 | (old-redirects 0)) |
| 631 | (while events |
| 632 | (if (eq (car events) :redirect) |
| 633 | (setq old-redirects (1+ old-redirects))) |
| 634 | (and (setq events (cdr events)) |
| 635 | (setq events (cdr events)))) |
| 636 | (< old-redirects url-max-redirections)))) |
| 637 | ;; url-max-redirections hasn't been reached, so go |
| 638 | ;; ahead and redirect. |
| 639 | (progn |
| 640 | ;; Remember that the request was redirected. |
| 641 | (setf (car url-callback-arguments) |
| 642 | (nconc (list :redirect redirect-uri) |
| 643 | (car url-callback-arguments))) |
| 644 | ;; Put in the current buffer a forwarding pointer to the new |
| 645 | ;; destination buffer. |
| 646 | ;; FIXME: This is a hack to fix url-retrieve-synchronously |
| 647 | ;; without changing the API. Instead url-retrieve should |
| 648 | ;; either simply not return the "destination" buffer, or it |
| 649 | ;; should take an optional `dest-buf' argument. |
| 650 | (set (make-local-variable 'url-redirect-buffer) |
| 651 | (url-retrieve-internal |
| 652 | redirect-uri url-callback-function |
| 653 | url-callback-arguments |
| 654 | (url-silent url-current-object) |
| 655 | (not (url-use-cookies url-current-object)))) |
| 656 | (url-mark-buffer-as-dead buffer)) |
| 657 | ;; We hit url-max-redirections, so issue an error and |
| 658 | ;; stop redirecting. |
| 659 | (url-http-debug "Maximum redirections reached") |
| 660 | (setf (car url-callback-arguments) |
| 661 | (nconc (list :error (list 'error 'http-redirect-limit |
| 662 | redirect-uri)) |
| 663 | (car url-callback-arguments))) |
| 664 | (setq success t)))))) |
| 665 | (4 ; Client error |
| 666 | ;; 400 Bad Request |
| 667 | ;; 401 Unauthorized |
| 668 | ;; 402 Payment required |
| 669 | ;; 403 Forbidden |
| 670 | ;; 404 Not found |
| 671 | ;; 405 Method not allowed |
| 672 | ;; 406 Not acceptable |
| 673 | ;; 407 Proxy authentication required |
| 674 | ;; 408 Request time-out |
| 675 | ;; 409 Conflict |
| 676 | ;; 410 Gone |
| 677 | ;; 411 Length required |
| 678 | ;; 412 Precondition failed |
| 679 | ;; 413 Request entity too large |
| 680 | ;; 414 Request-URI too large |
| 681 | ;; 415 Unsupported media type |
| 682 | ;; 416 Requested range not satisfiable |
| 683 | ;; 417 Expectation failed |
| 684 | ;; 422 Unprocessable Entity (Added by DAV) |
| 685 | ;; 423 Locked |
| 686 | ;; 424 Failed Dependency |
| 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 | (setq success t)) |
| 704 | (`not-found ; 404 |
| 705 | ;; Not found |
| 706 | (setq success 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 | (setq success 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 | (setq success 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 | (setq success 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 | (setq success t)) |
| 740 | (`gone ; 410 |
| 741 | ;; The requested resource is no longer available at the |
| 742 | ;; server and no forwarding address is known. |
| 743 | (setq success 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 | (setq success 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 | (setq success 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 | (setq success 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 | (setq success 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 | (setq success 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 | (setq success 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 | (setq success t))) |
| 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))))) |
| 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) |
| 802 | (pcase url-http-response-status |
| 803 | (`not-implemented ; 501 |
| 804 | ;; The server does not support the functionality required to |
| 805 | ;; fulfill the request. |
| 806 | nil) |
| 807 | (`bad-gateway ; 502 |
| 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) |
| 812 | (`service-unavailable ; 503 |
| 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) |
| 821 | (`gateway-timeout ; 504 |
| 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) |
| 828 | (`http-version-not-supported ; 505 |
| 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) |
| 833 | (`insufficient-storage ; 507 (DAV) |
| 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. |
| 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))))) |
| 848 | (_ |
| 849 | (error "Unknown class of HTTP response code: %d (%d)" |
| 850 | class url-http-response-status))) |
| 851 | (if (not success) |
| 852 | (url-mark-buffer-as-dead buffer)) |
| 853 | (url-http-debug "Finished parsing HTTP headers: %S" success) |
| 854 | (widen) |
| 855 | success)) |
| 856 | |
| 857 | ;; Miscellaneous |
| 858 | (defun url-http-activate-callback () |
| 859 | "Activate callback specified when this buffer was created." |
| 860 | (url-http-mark-connection-as-free (url-host url-current-object) |
| 861 | (url-port url-current-object) |
| 862 | url-http-process) |
| 863 | (url-http-debug "Activating callback in buffer (%s)" (buffer-name)) |
| 864 | (apply url-callback-function url-callback-arguments)) |
| 865 | |
| 866 | ;; ) |
| 867 | |
| 868 | ;; These unfortunately cannot be macros... please ignore them! |
| 869 | (defun url-http-idle-sentinel (proc why) |
| 870 | "Remove (now defunct) process PROC from the list of open connections." |
| 871 | (maphash (lambda (key val) |
| 872 | (if (memq proc val) |
| 873 | (puthash key (delq proc val) url-http-open-connections))) |
| 874 | url-http-open-connections)) |
| 875 | |
| 876 | (defun url-http-end-of-document-sentinel (proc why) |
| 877 | ;; Sentinel used to handle (i) terminated old HTTP/0.9 connections, |
| 878 | ;; and (ii) closed connection due to reusing a HTTP connection which |
| 879 | ;; we believed was still alive, but which the server closed on us. |
| 880 | ;; We handle case (ii) by calling `url-http' again. |
| 881 | (url-http-debug "url-http-end-of-document-sentinel in buffer (%s)" |
| 882 | (process-buffer proc)) |
| 883 | (url-http-idle-sentinel proc why) |
| 884 | (when (buffer-name (process-buffer proc)) |
| 885 | (with-current-buffer (process-buffer proc) |
| 886 | (goto-char (point-min)) |
| 887 | (cond ((not (looking-at "HTTP/")) |
| 888 | (if url-http-no-retry |
| 889 | ;; HTTP/0.9 just gets passed back no matter what |
| 890 | (url-http-activate-callback) |
| 891 | ;; Call `url-http' again if our connection expired. |
| 892 | (erase-buffer) |
| 893 | (url-http url-current-object url-callback-function |
| 894 | url-callback-arguments (current-buffer)))) |
| 895 | ((url-http-parse-headers) |
| 896 | (url-http-activate-callback)))))) |
| 897 | |
| 898 | (defun url-http-simple-after-change-function (st nd length) |
| 899 | ;; Function used when we do NOT know how long the document is going to be |
| 900 | ;; Just _very_ simple 'downloaded %d' type of info. |
| 901 | (url-lazy-message "Reading %s..." (url-pretty-length nd))) |
| 902 | |
| 903 | (defun url-http-content-length-after-change-function (st nd length) |
| 904 | "Function used when we DO know how long the document is going to be. |
| 905 | More sophisticated percentage downloaded, etc. |
| 906 | Also does minimal parsing of HTTP headers and will actually cause |
| 907 | the callback to be triggered." |
| 908 | (if url-http-content-type |
| 909 | (url-display-percentage |
| 910 | "Reading [%s]... %s of %s (%d%%)" |
| 911 | (url-percentage (- nd url-http-end-of-headers) |
| 912 | url-http-content-length) |
| 913 | url-http-content-type |
| 914 | (url-pretty-length (- nd url-http-end-of-headers)) |
| 915 | (url-pretty-length url-http-content-length) |
| 916 | (url-percentage (- nd url-http-end-of-headers) |
| 917 | url-http-content-length)) |
| 918 | (url-display-percentage |
| 919 | "Reading... %s of %s (%d%%)" |
| 920 | (url-percentage (- nd url-http-end-of-headers) |
| 921 | url-http-content-length) |
| 922 | (url-pretty-length (- nd url-http-end-of-headers)) |
| 923 | (url-pretty-length url-http-content-length) |
| 924 | (url-percentage (- nd url-http-end-of-headers) |
| 925 | url-http-content-length))) |
| 926 | |
| 927 | (if (> (- nd url-http-end-of-headers) url-http-content-length) |
| 928 | (progn |
| 929 | ;; Found the end of the document! Wheee! |
| 930 | (url-display-percentage nil nil) |
| 931 | (url-lazy-message "Reading... done.") |
| 932 | (if (url-http-parse-headers) |
| 933 | (url-http-activate-callback))))) |
| 934 | |
| 935 | (defun url-http-chunked-encoding-after-change-function (st nd length) |
| 936 | "Function used when dealing with 'chunked' encoding. |
| 937 | Cannot give a sophisticated percentage, but we need a different |
| 938 | function to look for the special 0-length chunk that signifies |
| 939 | the end of the document." |
| 940 | (save-excursion |
| 941 | (goto-char st) |
| 942 | (let ((read-next-chunk t) |
| 943 | (case-fold-search t) |
| 944 | (regexp nil) |
| 945 | (no-initial-crlf nil)) |
| 946 | ;; We need to loop thru looking for more chunks even within |
| 947 | ;; one after-change-function call. |
| 948 | (while read-next-chunk |
| 949 | (setq no-initial-crlf (= 0 url-http-chunked-counter)) |
| 950 | (if url-http-content-type |
| 951 | (url-display-percentage nil |
| 952 | "Reading [%s]... chunk #%d" |
| 953 | url-http-content-type url-http-chunked-counter) |
| 954 | (url-display-percentage nil |
| 955 | "Reading... chunk #%d" |
| 956 | url-http-chunked-counter)) |
| 957 | (url-http-debug "Reading chunk %d (%d %d %d)" |
| 958 | url-http-chunked-counter st nd length) |
| 959 | (setq regexp (if no-initial-crlf |
| 960 | "\\([0-9a-z]+\\).*\r?\n" |
| 961 | "\r?\n\\([0-9a-z]+\\).*\r?\n")) |
| 962 | |
| 963 | (if url-http-chunked-start |
| 964 | ;; We know how long the chunk is supposed to be, skip over |
| 965 | ;; leading crap if possible. |
| 966 | (if (> nd (+ url-http-chunked-start url-http-chunked-length)) |
| 967 | (progn |
| 968 | (url-http-debug "Got to the end of chunk #%d!" |
| 969 | url-http-chunked-counter) |
| 970 | (goto-char (+ url-http-chunked-start |
| 971 | url-http-chunked-length))) |
| 972 | (url-http-debug "Still need %d bytes to hit end of chunk" |
| 973 | (- (+ url-http-chunked-start |
| 974 | url-http-chunked-length) |
| 975 | nd)) |
| 976 | (setq read-next-chunk nil))) |
| 977 | (if (not read-next-chunk) |
| 978 | (url-http-debug "Still spinning for next chunk...") |
| 979 | (if no-initial-crlf (skip-chars-forward "\r\n")) |
| 980 | (if (not (looking-at regexp)) |
| 981 | (progn |
| 982 | ;; Must not have received the entirety of the chunk header, |
| 983 | ;; need to spin some more. |
| 984 | (url-http-debug "Did not see start of chunk @ %d!" (point)) |
| 985 | (setq read-next-chunk nil)) |
| 986 | (add-text-properties (match-beginning 0) (match-end 0) |
| 987 | (list 'start-open t |
| 988 | 'end-open t |
| 989 | 'chunked-encoding t |
| 990 | 'face 'cursor |
| 991 | 'invisible t)) |
| 992 | (setq url-http-chunked-length (string-to-number (buffer-substring |
| 993 | (match-beginning 1) |
| 994 | (match-end 1)) |
| 995 | 16) |
| 996 | url-http-chunked-counter (1+ url-http-chunked-counter) |
| 997 | url-http-chunked-start (set-marker |
| 998 | (or url-http-chunked-start |
| 999 | (make-marker)) |
| 1000 | (match-end 0))) |
| 1001 | ; (if (not url-http-debug) |
| 1002 | (delete-region (match-beginning 0) (match-end 0));) |
| 1003 | (url-http-debug "Saw start of chunk %d (length=%d, start=%d" |
| 1004 | url-http-chunked-counter url-http-chunked-length |
| 1005 | (marker-position url-http-chunked-start)) |
| 1006 | (if (= 0 url-http-chunked-length) |
| 1007 | (progn |
| 1008 | ;; Found the end of the document! Wheee! |
| 1009 | (url-http-debug "Saw end of stream chunk!") |
| 1010 | (setq read-next-chunk nil) |
| 1011 | (url-display-percentage nil nil) |
| 1012 | ;; Every chunk, even the last 0-length one, is |
| 1013 | ;; terminated by CRLF. Skip it. |
| 1014 | (when (looking-at "\r?\n") |
| 1015 | (url-http-debug "Removing terminator of last chunk") |
| 1016 | (delete-region (match-beginning 0) (match-end 0))) |
| 1017 | (if (re-search-forward "^\r*$" nil t) |
| 1018 | (url-http-debug "Saw end of trailers...")) |
| 1019 | (if (url-http-parse-headers) |
| 1020 | (url-http-activate-callback)))))))))) |
| 1021 | |
| 1022 | (defun url-http-wait-for-headers-change-function (st nd length) |
| 1023 | ;; This will wait for the headers to arrive and then splice in the |
| 1024 | ;; next appropriate after-change-function, etc. |
| 1025 | (url-http-debug "url-http-wait-for-headers-change-function (%s)" |
| 1026 | (buffer-name)) |
| 1027 | (let ((end-of-headers nil) |
| 1028 | (old-http nil) |
| 1029 | (process-buffer (current-buffer)) |
| 1030 | (content-length nil)) |
| 1031 | (when (not (bobp)) |
| 1032 | (goto-char (point-min)) |
| 1033 | (if (and (looking-at ".*\n") ; have one line at least |
| 1034 | (not (looking-at "^HTTP/[1-9]\\.[0-9]"))) |
| 1035 | ;; Not HTTP/x.y data, must be 0.9 |
| 1036 | ;; God, I wish this could die. |
| 1037 | (setq end-of-headers t |
| 1038 | url-http-end-of-headers 0 |
| 1039 | old-http t) |
| 1040 | (when (re-search-forward "^\r*$" nil t) |
| 1041 | ;; Saw the end of the headers |
| 1042 | (url-http-debug "Saw end of headers... (%s)" (buffer-name)) |
| 1043 | (setq url-http-end-of-headers (set-marker (make-marker) |
| 1044 | (point)) |
| 1045 | end-of-headers t) |
| 1046 | (setq nd (- nd (url-http-clean-headers))))) |
| 1047 | |
| 1048 | (if (not end-of-headers) |
| 1049 | ;; Haven't seen the end of the headers yet, need to wait |
| 1050 | ;; for more data to arrive. |
| 1051 | nil |
| 1052 | (unless old-http |
| 1053 | (url-http-parse-response) |
| 1054 | (mail-narrow-to-head) |
| 1055 | (setq url-http-transfer-encoding (mail-fetch-field |
| 1056 | "transfer-encoding") |
| 1057 | url-http-content-type (mail-fetch-field "content-type")) |
| 1058 | (if (mail-fetch-field "content-length") |
| 1059 | (setq url-http-content-length |
| 1060 | (string-to-number (mail-fetch-field "content-length")))) |
| 1061 | (widen)) |
| 1062 | (when url-http-transfer-encoding |
| 1063 | (setq url-http-transfer-encoding |
| 1064 | (downcase url-http-transfer-encoding))) |
| 1065 | |
| 1066 | (cond |
| 1067 | ((null url-http-response-status) |
| 1068 | ;; We got back a headerless malformed response from the |
| 1069 | ;; server. |
| 1070 | (url-http-activate-callback)) |
| 1071 | ((or (= url-http-response-status 204) |
| 1072 | (= url-http-response-status 205)) |
| 1073 | (url-http-debug "%d response must have headers only (%s)." |
| 1074 | url-http-response-status (buffer-name)) |
| 1075 | (when (url-http-parse-headers) |
| 1076 | (url-http-activate-callback))) |
| 1077 | ((string= "HEAD" url-http-method) |
| 1078 | ;; A HEAD request is _ALWAYS_ terminated by the header |
| 1079 | ;; information, regardless of any entity headers, |
| 1080 | ;; according to section 4.4 of the HTTP/1.1 draft. |
| 1081 | (url-http-debug "HEAD request must have headers only (%s)." |
| 1082 | (buffer-name)) |
| 1083 | (when (url-http-parse-headers) |
| 1084 | (url-http-activate-callback))) |
| 1085 | ((string= "CONNECT" url-http-method) |
| 1086 | ;; A CONNECT request is finished, but we cannot stick this |
| 1087 | ;; back on the free connection list |
| 1088 | (url-http-debug "CONNECT request must have headers only.") |
| 1089 | (when (url-http-parse-headers) |
| 1090 | (url-http-activate-callback))) |
| 1091 | ((equal url-http-response-status 304) |
| 1092 | ;; Only allowed to have a header section. We have to handle |
| 1093 | ;; this here instead of in url-http-parse-headers because if |
| 1094 | ;; you have a cached copy of something without a known |
| 1095 | ;; content-length, and try to retrieve it from the cache, we'd |
| 1096 | ;; fall into the 'being dumb' section and wait for the |
| 1097 | ;; connection to terminate, which means we'd wait for 10 |
| 1098 | ;; seconds for the keep-alives to time out on some servers. |
| 1099 | (when (url-http-parse-headers) |
| 1100 | (url-http-activate-callback))) |
| 1101 | (old-http |
| 1102 | ;; HTTP/0.9 always signaled end-of-connection by closing the |
| 1103 | ;; connection. |
| 1104 | (url-http-debug |
| 1105 | "Saw HTTP/0.9 response, connection closed means end of document.") |
| 1106 | (setq url-http-after-change-function |
| 1107 | 'url-http-simple-after-change-function)) |
| 1108 | ((equal url-http-transfer-encoding "chunked") |
| 1109 | (url-http-debug "Saw chunked encoding.") |
| 1110 | (setq url-http-after-change-function |
| 1111 | 'url-http-chunked-encoding-after-change-function) |
| 1112 | (when (> nd url-http-end-of-headers) |
| 1113 | (url-http-debug |
| 1114 | "Calling initial chunked-encoding for extra data at end of headers") |
| 1115 | (url-http-chunked-encoding-after-change-function |
| 1116 | (marker-position url-http-end-of-headers) nd |
| 1117 | (- nd url-http-end-of-headers)))) |
| 1118 | ((integerp url-http-content-length) |
| 1119 | (url-http-debug |
| 1120 | "Got a content-length, being smart about document end.") |
| 1121 | (setq url-http-after-change-function |
| 1122 | 'url-http-content-length-after-change-function) |
| 1123 | (cond |
| 1124 | ((= 0 url-http-content-length) |
| 1125 | ;; We got a NULL body! Activate the callback |
| 1126 | ;; immediately! |
| 1127 | (url-http-debug |
| 1128 | "Got 0-length content-length, activating callback immediately.") |
| 1129 | (when (url-http-parse-headers) |
| 1130 | (url-http-activate-callback))) |
| 1131 | ((> nd url-http-end-of-headers) |
| 1132 | ;; Have some leftover data |
| 1133 | (url-http-debug "Calling initial content-length for extra data at end of headers") |
| 1134 | (url-http-content-length-after-change-function |
| 1135 | (marker-position url-http-end-of-headers) |
| 1136 | nd |
| 1137 | (- nd url-http-end-of-headers))) |
| 1138 | (t |
| 1139 | nil))) |
| 1140 | (t |
| 1141 | (url-http-debug "No content-length, being dumb.") |
| 1142 | (setq url-http-after-change-function |
| 1143 | 'url-http-simple-after-change-function))))) |
| 1144 | ;; We are still at the beginning of the buffer... must just be |
| 1145 | ;; waiting for a response. |
| 1146 | (url-http-debug "Spinning waiting for headers...") |
| 1147 | (when (eq process-buffer (current-buffer)) |
| 1148 | (goto-char (point-max))))) |
| 1149 | |
| 1150 | (defun url-http (url callback cbargs &optional retry-buffer) |
| 1151 | "Retrieve URL via HTTP asynchronously. |
| 1152 | URL must be a parsed URL. See `url-generic-parse-url' for details. |
| 1153 | |
| 1154 | When retrieval is completed, execute the function CALLBACK, using |
| 1155 | the arguments listed in CBARGS. The first element in CBARGS |
| 1156 | should be a plist describing what has happened so far during the |
| 1157 | request, as described in the docstring of `url-retrieve' (if in |
| 1158 | doubt, specify nil). |
| 1159 | |
| 1160 | Optional arg RETRY-BUFFER, if non-nil, specifies the buffer of a |
| 1161 | previous `url-http' call, which is being re-attempted." |
| 1162 | (cl-check-type url vector "Need a pre-parsed URL.") |
| 1163 | (let* ((host (url-host (or url-using-proxy url))) |
| 1164 | (port (url-port (or url-using-proxy url))) |
| 1165 | (connection (url-http-find-free-connection host port)) |
| 1166 | (buffer (or retry-buffer |
| 1167 | (generate-new-buffer |
| 1168 | (format " *http %s:%d*" host port))))) |
| 1169 | (if (not connection) |
| 1170 | ;; Failed to open the connection for some reason |
| 1171 | (progn |
| 1172 | (kill-buffer buffer) |
| 1173 | (setq buffer nil) |
| 1174 | (error "Could not create connection to %s:%d" host port)) |
| 1175 | (with-current-buffer buffer |
| 1176 | (mm-disable-multibyte) |
| 1177 | (setq url-current-object url |
| 1178 | mode-line-format "%b [%s]") |
| 1179 | |
| 1180 | (dolist (var '(url-http-end-of-headers |
| 1181 | url-http-content-type |
| 1182 | url-http-content-length |
| 1183 | url-http-transfer-encoding |
| 1184 | url-http-after-change-function |
| 1185 | url-http-response-version |
| 1186 | url-http-response-status |
| 1187 | url-http-chunked-length |
| 1188 | url-http-chunked-counter |
| 1189 | url-http-chunked-start |
| 1190 | url-callback-function |
| 1191 | url-callback-arguments |
| 1192 | url-show-status |
| 1193 | url-http-process |
| 1194 | url-http-method |
| 1195 | url-http-extra-headers |
| 1196 | url-http-data |
| 1197 | url-http-target-url |
| 1198 | url-http-no-retry |
| 1199 | url-http-connection-opened |
| 1200 | url-http-proxy)) |
| 1201 | (set (make-local-variable var) nil)) |
| 1202 | |
| 1203 | (setq url-http-method (or url-request-method "GET") |
| 1204 | url-http-extra-headers url-request-extra-headers |
| 1205 | url-http-data url-request-data |
| 1206 | url-http-process connection |
| 1207 | url-http-chunked-length nil |
| 1208 | url-http-chunked-start nil |
| 1209 | url-http-chunked-counter 0 |
| 1210 | url-callback-function callback |
| 1211 | url-callback-arguments cbargs |
| 1212 | url-http-after-change-function 'url-http-wait-for-headers-change-function |
| 1213 | url-http-target-url url-current-object |
| 1214 | url-http-no-retry retry-buffer |
| 1215 | url-http-connection-opened nil |
| 1216 | url-http-proxy url-using-proxy) |
| 1217 | |
| 1218 | (set-process-buffer connection buffer) |
| 1219 | (set-process-filter connection 'url-http-generic-filter) |
| 1220 | (let ((status (process-status connection))) |
| 1221 | (cond |
| 1222 | ((eq status 'connect) |
| 1223 | ;; Asynchronous connection |
| 1224 | (set-process-sentinel connection 'url-http-async-sentinel)) |
| 1225 | ((eq status 'failed) |
| 1226 | ;; Asynchronous connection failed |
| 1227 | (error "Could not create connection to %s:%d" host port)) |
| 1228 | (t |
| 1229 | (set-process-sentinel connection |
| 1230 | 'url-http-end-of-document-sentinel) |
| 1231 | (process-send-string connection (url-http-create-request))))))) |
| 1232 | buffer)) |
| 1233 | |
| 1234 | (defun url-http-async-sentinel (proc why) |
| 1235 | ;; We are performing an asynchronous connection, and a status change |
| 1236 | ;; has occurred. |
| 1237 | (when (buffer-name (process-buffer proc)) |
| 1238 | (with-current-buffer (process-buffer proc) |
| 1239 | (cond |
| 1240 | (url-http-connection-opened |
| 1241 | (setq url-http-no-retry t) |
| 1242 | (url-http-end-of-document-sentinel proc why)) |
| 1243 | ((string= (substring why 0 4) "open") |
| 1244 | (setq url-http-connection-opened t) |
| 1245 | (condition-case error |
| 1246 | (process-send-string proc (url-http-create-request)) |
| 1247 | (file-error |
| 1248 | (setq url-http-connection-opened nil) |
| 1249 | (message "HTTP error: %s" error)))) |
| 1250 | (t |
| 1251 | (setf (car url-callback-arguments) |
| 1252 | (nconc (list :error (list 'error 'connection-failed why |
| 1253 | :host (url-host (or url-http-proxy url-current-object)) |
| 1254 | :service (url-port (or url-http-proxy url-current-object)))) |
| 1255 | (car url-callback-arguments))) |
| 1256 | (url-http-activate-callback)))))) |
| 1257 | |
| 1258 | ;; Since Emacs 19/20 does not allow you to change the |
| 1259 | ;; `after-change-functions' hook in the midst of running them, we fake |
| 1260 | ;; an after change by hooking into the process filter and inserting |
| 1261 | ;; the data ourselves. This is slightly less efficient, but there |
| 1262 | ;; were tons of weird ways the after-change code was biting us in the |
| 1263 | ;; shorts. |
| 1264 | ;; FIXME this can probably be simplified since the above is no longer true. |
| 1265 | (defun url-http-generic-filter (proc data) |
| 1266 | ;; Sometimes we get a zero-length data chunk after the process has |
| 1267 | ;; been changed to 'free', which means it has no buffer associated |
| 1268 | ;; with it. Do nothing if there is no buffer, or 0 length data. |
| 1269 | (and (process-buffer proc) |
| 1270 | (/= (length data) 0) |
| 1271 | (with-current-buffer (process-buffer proc) |
| 1272 | (url-http-debug "Calling after change function `%s' for `%S'" url-http-after-change-function proc) |
| 1273 | (funcall url-http-after-change-function |
| 1274 | (point-max) |
| 1275 | (progn |
| 1276 | (goto-char (point-max)) |
| 1277 | (insert data) |
| 1278 | (point-max)) |
| 1279 | (length data))))) |
| 1280 | |
| 1281 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; |
| 1282 | ;;; file-name-handler stuff from here on out |
| 1283 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; |
| 1284 | (defalias 'url-http-symbol-value-in-buffer |
| 1285 | (if (fboundp 'symbol-value-in-buffer) |
| 1286 | 'symbol-value-in-buffer |
| 1287 | (lambda (symbol buffer &optional unbound-value) |
| 1288 | "Return the value of SYMBOL in BUFFER, or UNBOUND-VALUE if it is unbound." |
| 1289 | (with-current-buffer buffer |
| 1290 | (if (not (boundp symbol)) |
| 1291 | unbound-value |
| 1292 | (symbol-value symbol)))))) |
| 1293 | |
| 1294 | (defun url-http-head (url) |
| 1295 | (let ((url-request-method "HEAD") |
| 1296 | (url-request-data nil)) |
| 1297 | (url-retrieve-synchronously url))) |
| 1298 | |
| 1299 | (defun url-http-file-exists-p (url) |
| 1300 | (let ((status nil) |
| 1301 | (exists nil) |
| 1302 | (buffer (url-http-head url))) |
| 1303 | (if (not buffer) |
| 1304 | (setq exists nil) |
| 1305 | (setq status (url-http-symbol-value-in-buffer 'url-http-response-status |
| 1306 | buffer 500) |
| 1307 | exists (and (integerp status) |
| 1308 | (>= status 200) (< status 300))) |
| 1309 | (kill-buffer buffer)) |
| 1310 | exists)) |
| 1311 | |
| 1312 | (defalias 'url-http-file-readable-p 'url-http-file-exists-p) |
| 1313 | |
| 1314 | (defun url-http-head-file-attributes (url &optional id-format) |
| 1315 | (let ((buffer (url-http-head url))) |
| 1316 | (when buffer |
| 1317 | (prog1 |
| 1318 | (list |
| 1319 | nil ;dir / link / normal file |
| 1320 | 1 ;number of links to file. |
| 1321 | 0 0 ;uid ; gid |
| 1322 | nil nil nil ;atime ; mtime ; ctime |
| 1323 | (url-http-symbol-value-in-buffer 'url-http-content-length |
| 1324 | buffer -1) |
| 1325 | (eval-when-compile (make-string 10 ?-)) |
| 1326 | nil nil nil) ;whether gid would change ; inode ; device. |
| 1327 | (kill-buffer buffer))))) |
| 1328 | |
| 1329 | (declare-function url-dav-file-attributes "url-dav" (url &optional id-format)) |
| 1330 | |
| 1331 | (defun url-http-file-attributes (url &optional id-format) |
| 1332 | (if (url-dav-supported-p url) |
| 1333 | (url-dav-file-attributes url id-format) |
| 1334 | (url-http-head-file-attributes url id-format))) |
| 1335 | |
| 1336 | (defun url-http-options (url) |
| 1337 | "Return a property list describing options available for URL. |
| 1338 | This list is retrieved using the `OPTIONS' HTTP method. |
| 1339 | |
| 1340 | Property list members: |
| 1341 | |
| 1342 | methods |
| 1343 | A list of symbols specifying what HTTP methods the resource |
| 1344 | supports. |
| 1345 | |
| 1346 | dav |
| 1347 | A list of numbers specifying what DAV protocol/schema versions are |
| 1348 | supported. |
| 1349 | |
| 1350 | dasl |
| 1351 | A list of supported DASL search types supported (string form) |
| 1352 | |
| 1353 | ranges |
| 1354 | A list of the units available for use in partial document fetches. |
| 1355 | |
| 1356 | p3p |
| 1357 | The `Platform For Privacy Protection' description for the resource. |
| 1358 | Currently this is just the raw header contents. This is likely to |
| 1359 | change once P3P is formally supported by the URL package or |
| 1360 | Emacs/W3." |
| 1361 | (let* ((url-request-method "OPTIONS") |
| 1362 | (url-request-data nil) |
| 1363 | (buffer (url-retrieve-synchronously url)) |
| 1364 | (header nil) |
| 1365 | (options nil)) |
| 1366 | (when (and buffer (= 2 (/ (url-http-symbol-value-in-buffer |
| 1367 | 'url-http-response-status buffer 0) 100))) |
| 1368 | ;; Only parse the options if we got a 2xx response code! |
| 1369 | (with-current-buffer buffer |
| 1370 | (save-restriction |
| 1371 | (save-match-data |
| 1372 | (mail-narrow-to-head) |
| 1373 | |
| 1374 | ;; Figure out what methods are supported. |
| 1375 | (when (setq header (mail-fetch-field "allow")) |
| 1376 | (setq options (plist-put |
| 1377 | options 'methods |
| 1378 | (mapcar 'intern (split-string header "[ ,]+"))))) |
| 1379 | |
| 1380 | ;; Check for DAV |
| 1381 | (when (setq header (mail-fetch-field "dav")) |
| 1382 | (setq options (plist-put |
| 1383 | options 'dav |
| 1384 | (delq 0 |
| 1385 | (mapcar 'string-to-number |
| 1386 | (split-string header "[, ]+")))))) |
| 1387 | |
| 1388 | ;; Now for DASL |
| 1389 | (when (setq header (mail-fetch-field "dasl")) |
| 1390 | (setq options (plist-put |
| 1391 | options 'dasl |
| 1392 | (split-string header "[, ]+")))) |
| 1393 | |
| 1394 | ;; P3P - should get more detailed here. FIXME |
| 1395 | (when (setq header (mail-fetch-field "p3p")) |
| 1396 | (setq options (plist-put options 'p3p header))) |
| 1397 | |
| 1398 | ;; Check for whether they accept byte-range requests. |
| 1399 | (when (setq header (mail-fetch-field "accept-ranges")) |
| 1400 | (setq options (plist-put |
| 1401 | options 'ranges |
| 1402 | (delq 'none |
| 1403 | (mapcar 'intern |
| 1404 | (split-string header "[, ]+")))))) |
| 1405 | )))) |
| 1406 | (if buffer (kill-buffer buffer)) |
| 1407 | options)) |
| 1408 | |
| 1409 | ;; HTTPS. This used to be in url-https.el, but that file collides |
| 1410 | ;; with url-http.el on systems with 8-character file names. |
| 1411 | (require 'tls) |
| 1412 | |
| 1413 | (defconst url-https-default-port 443 "Default HTTPS port.") |
| 1414 | (defconst url-https-asynchronous-p t "HTTPS retrievals are asynchronous.") |
| 1415 | |
| 1416 | ;; FIXME what is the point of this alias being an autoload? |
| 1417 | ;; Trying to use it will not cause url-http to be loaded, |
| 1418 | ;; since the full alias just gets dumped into loaddefs.el. |
| 1419 | |
| 1420 | ;;;###autoload (autoload 'url-default-expander "url-expand") |
| 1421 | ;;;###autoload |
| 1422 | (defalias 'url-https-expand-file-name 'url-default-expander) |
| 1423 | |
| 1424 | (defmacro url-https-create-secure-wrapper (method args) |
| 1425 | `(defun ,(intern (format (if method "url-https-%s" "url-https") method)) ,args |
| 1426 | ,(format "HTTPS wrapper around `%s' call." (or method "url-http")) |
| 1427 | (let ((url-gateway-method 'tls)) |
| 1428 | (,(intern (format (if method "url-http-%s" "url-http") method)) |
| 1429 | ,@(remove '&rest (remove '&optional args)))))) |
| 1430 | |
| 1431 | ;;;###autoload (autoload 'url-https "url-http") |
| 1432 | (url-https-create-secure-wrapper nil (url callback cbargs)) |
| 1433 | ;;;###autoload (autoload 'url-https-file-exists-p "url-http") |
| 1434 | (url-https-create-secure-wrapper file-exists-p (url)) |
| 1435 | ;;;###autoload (autoload 'url-https-file-readable-p "url-http") |
| 1436 | (url-https-create-secure-wrapper file-readable-p (url)) |
| 1437 | ;;;###autoload (autoload 'url-https-file-attributes "url-http") |
| 1438 | (url-https-create-secure-wrapper file-attributes (url &optional id-format)) |
| 1439 | |
| 1440 | (provide 'url-http) |
| 1441 | |
| 1442 | ;;; url-http.el ends here |