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