lisp/url/url-http.el

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