cgit.sxemacs.org Git - packages/blob - xemacs-packages/w3/lisp/url-http.el

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