code.delx.au - gnu-emacs/blob - lisp/url/url-http.el

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