lisp/url/url-http.el

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