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

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