code.delx.au - gnu-emacs-elpa/blob - packages/url-http-ntlm/url-http-ntlm-parse-headers-24.5.el

   1 ;;; url-http-ntlm-parse-headers-24.5.el --- Override url-http-parse-headers
   2
   3 ;; Copyright (C) 1999, 2001, 2004-2016 Free Software Foundation, Inc.
   4
   5 ;; Author: Bill Perry <wmperry@gnu.org>
   6 ;; Keywords: comm, data, processes
   7
   8 ;; This file is part of GNU Emacs.
   9 ;;
  10 ;; GNU Emacs is free software: you can redistribute it and/or modify
  11 ;; it under the terms of the GNU General Public License as published by
  12 ;; the Free Software Foundation, either version 3 of the License, or
  13 ;; (at your option) any later version.
  14
  15 ;; GNU Emacs is distributed in the hope that it will be useful,
  16 ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
  17 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  18 ;; GNU General Public License for more details.
  19
  20 ;; You should have received a copy of the GNU General Public License
  21 ;; along with GNU Emacs.  If not, see <http://www.gnu.org/licenses/>.
  22
  23 ;;; Commentary:
  24
  25 ;; Override url-http-parse-headers to clear Authorization headers
  26 ;; from url-http-extra-headers prior to executing a redirect.  The
  27 ;; only change is to apply this backward-compatible patch:
  28 ;;
  29 ;; diff --git a/lisp/url/url-http.el b/lisp/url/url-http.el
  30 ;; index 680097a..2ff497f 100644
  31 ;; --- a/lisp/url/url-http.el
  32 ;; +++ b/lisp/url/url-http.el
  33 ;; @@ -617,6 +617,12 @@ should be shown to the user."
  34 ;;                 ;; compute the redirection relative to the URL of the proxy.
  35 ;;             (setq redirect-uri
  36 ;;                   (url-expand-file-name redirect-uri url-http-target-url)))
  37 ;; +       ;; Do not automatically include an authorization header in the
  38 ;; +       ;; redirect.  If needed it will be regenerated by the relevant
  39 ;; +       ;; auth scheme when the new request happens.
  40 ;; +       (setq url-http-extra-headers
  41 ;; +             (cl-remove "Authorization"
  42 ;; +                        url-http-extra-headers :key 'car :test 'equal))
  43 ;;             (let ((url-request-method url-http-method)
  44 ;;               (url-request-data url-http-data)
  45 ;;               (url-request-extra-headers url-http-extra-headers))
  46 ;;
  47 ;;; Code:
  48
  49 (require 'cl-lib)
  50
  51 (defvar url-callback-arguments)
  52 (defvar url-callback-function)
  53 (defvar url-current-object)
  54 (defvar url-http-after-change-function)
  55 (defvar url-http-chunked-counter)
  56 (defvar url-http-chunked-length)
  57 (defvar url-http-chunked-start)
  58 (defvar url-http-connection-opened)
  59 (defvar url-http-content-length)
  60 (defvar url-http-content-type)
  61 (defvar url-http-data)
  62 (defvar url-http-end-of-headers)
  63 (defvar url-http-extra-headers)
  64 (defvar url-http-method)
  65 (defvar url-http-no-retry)
  66 (defvar url-http-process)
  67 (defvar url-http-proxy)
  68 (defvar url-http-response-status)
  69 (defvar url-http-response-version)
  70 (defvar url-http-target-url)
  71 (defvar url-http-transfer-encoding)
  72 (defvar url-show-status)
  73
  74 (require 'url-gw)
  75 (require 'url-parse)
  76 (require 'url-cookie)
  77 (require 'mail-parse)
  78 (require 'url-auth)
  79 (require 'url)
  80 (autoload 'url-cache-create-filename "url-cache")
  81 (require 'url-http)
  82
  83 (defun url-http-parse-headers ()
  84  "Parse and handle HTTP specific headers.
  85 Return t if and only if the current buffer is still active and
  86 should be shown to the user."
  87   ;; The comments after each status code handled are taken from RFC
  88   ;; 2616 (HTTP/1.1)
  89   (url-http-mark-connection-as-free (url-host url-current-object)
  90                                     (url-port url-current-object)
  91                                     url-http-process)
  92
  93   (if (or (not (boundp 'url-http-end-of-headers))
  94           (not url-http-end-of-headers))
  95       (error "Trying to parse headers in odd buffer: %s" (buffer-name)))
  96   (goto-char (point-min))
  97   (url-http-debug "url-http-parse-headers called in (%s)" (buffer-name))
  98   (url-http-parse-response)
  99   (mail-narrow-to-head)
 100   ;;(narrow-to-region (point-min) url-http-end-of-headers)
 101   (let ((connection (mail-fetch-field "Connection")))
 102     ;; In HTTP 1.0, keep the connection only if there is a
 103     ;; "Connection: keep-alive" header.
 104     ;; In HTTP 1.1 (and greater), keep the connection unless there is a
 105     ;; "Connection: close" header
 106     (cond
 107      ((string= url-http-response-version "1.0")
 108       (unless (and connection
 109                    (string= (downcase connection) "keep-alive"))
 110         (delete-process url-http-process)))
 111      (t
 112       (when (and connection
 113                  (string= (downcase connection) "close"))
 114         (delete-process url-http-process)))))
 115   (let* ((buffer (current-buffer))
 116          (class (/ url-http-response-status 100))
 117          (success nil)
 118          ;; other status symbols: jewelry and luxury cars
 119          (status-symbol (cadr (assq url-http-response-status url-http-codes))))
 120     (url-http-debug "Parsed HTTP headers: class=%d status=%d"
 121                     class url-http-response-status)
 122     (when (url-use-cookies url-http-target-url)
 123       (url-http-handle-cookies))
 124
 125     (pcase class
 126       ;; Classes of response codes
 127       ;;
 128       ;; 5xx = Server Error
 129       ;; 4xx = Client Error
 130       ;; 3xx = Redirection
 131       ;; 2xx = Successful
 132       ;; 1xx = Informational
 133       (1                                ; Information messages
 134        ;; 100 = Continue with request
 135        ;; 101 = Switching protocols
 136        ;; 102 = Processing (Added by DAV)
 137        (url-mark-buffer-as-dead buffer)
 138        (error "HTTP responses in class 1xx not supported (%d)"
 139               url-http-response-status))
 140       (2                                ; Success
 141        ;; 200 Ok
 142        ;; 201 Created
 143        ;; 202 Accepted
 144        ;; 203 Non-authoritative information
 145        ;; 204 No content
 146        ;; 205 Reset content
 147        ;; 206 Partial content
 148        ;; 207 Multi-status (Added by DAV)
 149        (pcase status-symbol
 150          ((or `no-content `reset-content)
 151           ;; No new data, just stay at the same document
 152           (url-mark-buffer-as-dead buffer))
 153          (_
 154           ;; Generic success for all others.  Store in the cache, and
 155           ;; mark it as successful.
 156           (widen)
 157           (if (and url-automatic-caching (equal url-http-method "GET"))
 158               (url-store-in-cache buffer))))
 159        (setq success t))
 160       (3                                ; Redirection
 161        ;; 300 Multiple choices
 162        ;; 301 Moved permanently
 163        ;; 302 Found
 164        ;; 303 See other
 165        ;; 304 Not modified
 166        ;; 305 Use proxy
 167        ;; 307 Temporary redirect
 168        (let ((redirect-uri (or (mail-fetch-field "Location")
 169                                (mail-fetch-field "URI"))))
 170          (pcase status-symbol
 171            (`multiple-choices       ; 300
 172             ;; Quoth the spec (section 10.3.1)
 173             ;; -------------------------------
 174             ;; The requested resource corresponds to any one of a set of
 175             ;; representations, each with its own specific location and
 176             ;; agent-driven negotiation information is being provided so
 177             ;; that the user can select a preferred representation and
 178             ;; redirect its request to that location.
 179             ;; [...]
 180             ;; If the server has a preferred choice of representation, it
 181             ;; SHOULD include the specific URI for that representation in
 182             ;; the Location field; user agents MAY use the Location field
 183             ;; value for automatic redirection.
 184             ;; -------------------------------
 185             ;; We do not support agent-driven negotiation, so we just
 186             ;; redirect to the preferred URI if one is provided.
 187             nil)
 188            ((or `moved-permanently `found `temporary-redirect) ; 301 302 307
 189             ;; If the 301|302 status code is received in response to a
 190             ;; request other than GET or HEAD, the user agent MUST NOT
 191             ;; automatically redirect the request unless it can be
 192             ;; confirmed by the user, since this might change the
 193             ;; conditions under which the request was issued.
 194             (unless (member url-http-method '("HEAD" "GET"))
 195               (setq redirect-uri nil)))
 196            (`see-other                  ; 303
 197             ;; The response to the request can be found under a different
 198             ;; URI and SHOULD be retrieved using a GET method on that
 199             ;; resource.
 200             (setq url-http-method "GET"
 201                   url-http-data nil))
 202            (`not-modified               ; 304
 203             ;; The 304 response MUST NOT contain a message-body.
 204             (url-http-debug "Extracting document from cache... (%s)"
 205                             (url-cache-create-filename (url-view-url t)))
 206             (url-cache-extract (url-cache-create-filename (url-view-url t)))
 207             (setq redirect-uri nil
 208                   success t))
 209            (`use-proxy                  ; 305
 210             ;; The requested resource MUST be accessed through the
 211             ;; proxy given by the Location field.  The Location field
 212             ;; gives the URI of the proxy.  The recipient is expected
 213             ;; to repeat this single request via the proxy.  305
 214             ;; responses MUST only be generated by origin servers.
 215             (error "Redirection thru a proxy server not supported: %s"
 216                    redirect-uri))
 217            (_
 218             ;; Treat everything like '300'
 219             nil))
 220          (when redirect-uri
 221            ;; Clean off any whitespace and/or <...> cruft.
 222            (if (string-match "\\([^ \t]+\\)[ \t]" redirect-uri)
 223                (setq redirect-uri (match-string 1 redirect-uri)))
 224            (if (string-match "^<\\(.*\\)>$" redirect-uri)
 225                (setq redirect-uri (match-string 1 redirect-uri)))
 226
 227            ;; Some stupid sites (like sourceforge) send a
 228            ;; non-fully-qualified URL (ie: /), which royally confuses
 229            ;; the URL library.
 230            (if (not (string-match url-nonrelative-link redirect-uri))
 231                ;; Be careful to use the real target URL, otherwise we may
 232                ;; compute the redirection relative to the URL of the proxy.
 233                (setq redirect-uri
 234                      (url-expand-file-name redirect-uri url-http-target-url)))
 235            ;; Do not automatically include an authorization header in the
 236            ;; redirect.  If needed it will be regenerated by the relevant
 237            ;; auth scheme when the new request happens.
 238            (setq url-http-extra-headers
 239                  (cl-remove "Authorization"
 240                             url-http-extra-headers :key 'car :test 'equal))
 241            (let ((url-request-method url-http-method)
 242                  (url-request-data url-http-data)
 243                  (url-request-extra-headers url-http-extra-headers))
 244              ;; Check existing number of redirects
 245              (if (or (< url-max-redirections 0)
 246                      (and (> url-max-redirections 0)
 247                           (let ((events (car url-callback-arguments))
 248                                 (old-redirects 0))
 249                             (while events
 250                               (if (eq (car events) :redirect)
 251                                   (setq old-redirects (1+ old-redirects)))
 252                               (and (setq events (cdr events))
 253                                    (setq events (cdr events))))
 254                             (< old-redirects url-max-redirections))))
 255                  ;; url-max-redirections hasn't been reached, so go
 256                  ;; ahead and redirect.
 257                  (progn
 258                    ;; Remember that the request was redirected.
 259                    (setf (car url-callback-arguments)
 260                          (nconc (list :redirect redirect-uri)
 261                                 (car url-callback-arguments)))
 262                    ;; Put in the current buffer a forwarding pointer to the new
 263                    ;; destination buffer.
 264                    ;; FIXME: This is a hack to fix url-retrieve-synchronously
 265                    ;; without changing the API.  Instead url-retrieve should
 266                    ;; either simply not return the "destination" buffer, or it
 267                    ;; should take an optional `dest-buf' argument.
 268                    (set (make-local-variable 'url-redirect-buffer)
 269                         (url-retrieve-internal
 270                          redirect-uri url-callback-function
 271                          url-callback-arguments
 272                          (url-silent url-current-object)
 273                          (not (url-use-cookies url-current-object))))
 274                    (url-mark-buffer-as-dead buffer))
 275                ;; We hit url-max-redirections, so issue an error and
 276                ;; stop redirecting.
 277                (url-http-debug "Maximum redirections reached")
 278                (setf (car url-callback-arguments)
 279                      (nconc (list :error (list 'error 'http-redirect-limit
 280                                                redirect-uri))
 281                             (car url-callback-arguments)))
 282                (setq success t))))))
 283       (4                                ; Client error
 284        ;; 400 Bad Request
 285        ;; 401 Unauthorized
 286        ;; 402 Payment required
 287        ;; 403 Forbidden
 288        ;; 404 Not found
 289        ;; 405 Method not allowed
 290        ;; 406 Not acceptable
 291        ;; 407 Proxy authentication required
 292        ;; 408 Request time-out
 293        ;; 409 Conflict
 294        ;; 410 Gone
 295        ;; 411 Length required
 296        ;; 412 Precondition failed
 297        ;; 413 Request entity too large
 298        ;; 414 Request-URI too large
 299        ;; 415 Unsupported media type
 300        ;; 416 Requested range not satisfiable
 301        ;; 417 Expectation failed
 302        ;; 422 Unprocessable Entity (Added by DAV)
 303        ;; 423 Locked
 304        ;; 424 Failed Dependency
 305        (setq success
 306              (pcase status-symbol
 307                (`unauthorized                   ; 401
 308                 ;; The request requires user authentication.  The response
 309                 ;; MUST include a WWW-Authenticate header field containing a
 310                 ;; challenge applicable to the requested resource.  The
 311                 ;; client MAY repeat the request with a suitable
 312                 ;; Authorization header field.
 313                 (url-http-handle-authentication nil))
 314                (`payment-required              ; 402
 315                 ;; This code is reserved for future use
 316                 (url-mark-buffer-as-dead buffer)
 317                 (error "Somebody wants you to give them money"))
 318                (`forbidden                      ; 403
 319                 ;; The server understood the request, but is refusing to
 320                 ;; fulfill it.  Authorization will not help and the request
 321                 ;; SHOULD NOT be repeated.
 322                 t)
 323                (`not-found                      ; 404
 324                 ;; Not found
 325                 t)
 326                (`method-not-allowed             ; 405
 327                 ;; The method specified in the Request-Line is not allowed
 328                 ;; for the resource identified by the Request-URI.  The
 329                 ;; response MUST include an Allow header containing a list of
 330                 ;; valid methods for the requested resource.
 331                 t)
 332                (`not-acceptable         ; 406
 333                 ;; The resource identified by the request is only capable of
 334                 ;; generating response entities which have content
 335                 ;; characteristics not acceptable according to the accept
 336                 ;; headers sent in the request.
 337                 t)
 338                (`proxy-authentication-required ; 407
 339                 ;; This code is similar to 401 (Unauthorized), but indicates
 340                 ;; that the client must first authenticate itself with the
 341                 ;; proxy.  The proxy MUST return a Proxy-Authenticate header
 342                 ;; field containing a challenge applicable to the proxy for
 343                 ;; the requested resource.
 344                 (url-http-handle-authentication t))
 345                (`request-timeout                ; 408
 346                 ;; The client did not produce a request within the time that
 347                 ;; the server was prepared to wait.  The client MAY repeat
 348                 ;; the request without modifications at any later time.
 349                 t)
 350                (`conflict                       ; 409
 351                 ;; The request could not be completed due to a conflict with
 352                 ;; the current state of the resource.  This code is only
 353                 ;; allowed in situations where it is expected that the user
 354                 ;; might be able to resolve the conflict and resubmit the
 355                 ;; request.  The response body SHOULD include enough
 356                 ;; information for the user to recognize the source of the
 357                 ;; conflict.
 358                 t)
 359                (`gone                          ; 410
 360                 ;; The requested resource is no longer available at the
 361                 ;; server and no forwarding address is known.
 362                 t)
 363                (`length-required                ; 411
 364                 ;; The server refuses to accept the request without a defined
 365                 ;; Content-Length.  The client MAY repeat the request if it
 366                 ;; adds a valid Content-Length header field containing the
 367                 ;; length of the message-body in the request message.
 368                 ;;
 369                 ;; NOTE - this will never happen because
 370                 ;; `url-http-create-request' automatically calculates the
 371                 ;; content-length.
 372                 t)
 373                (`precondition-failed            ; 412
 374                 ;; The precondition given in one or more of the
 375                 ;; request-header fields evaluated to false when it was
 376                 ;; tested on the server.
 377                 t)
 378                ((or `request-entity-too-large `request-uri-too-large) ; 413 414
 379                 ;; The server is refusing to process a request because the
 380                 ;; request entity|URI is larger than the server is willing or
 381                 ;; able to process.
 382                 t)
 383                (`unsupported-media-type ; 415
 384                 ;; The server is refusing to service the request because the
 385                 ;; entity of the request is in a format not supported by the
 386                 ;; requested resource for the requested method.
 387                 t)
 388                (`requested-range-not-satisfiable ; 416
 389                 ;; A server SHOULD return a response with this status code if
 390                 ;; a request included a Range request-header field, and none
 391                 ;; of the range-specifier values in this field overlap the
 392                 ;; current extent of the selected resource, and the request
 393                 ;; did not include an If-Range request-header field.
 394                 t)
 395                (`expectation-failed             ; 417
 396                 ;; The expectation given in an Expect request-header field
 397                 ;; could not be met by this server, or, if the server is a
 398                 ;; proxy, the server has unambiguous evidence that the
 399                 ;; request could not be met by the next-hop server.
 400                 t)
 401                (_
 402                 ;; The request could not be understood by the server due to
 403                 ;; malformed syntax.  The client SHOULD NOT repeat the
 404                 ;; request without modifications.
 405                 t)))
 406        ;; Tell the callback that an error occurred, and what the
 407        ;; status code was.
 408        (when success
 409          (setf (car url-callback-arguments)
 410                (nconc (list :error (list 'error 'http url-http-response-status))
 411                       (car url-callback-arguments)))))
 412       (5
 413        ;; 500 Internal server error
 414        ;; 501 Not implemented
 415        ;; 502 Bad gateway
 416        ;; 503 Service unavailable
 417        ;; 504 Gateway time-out
 418        ;; 505 HTTP version not supported
 419        ;; 507 Insufficient storage
 420        (setq success t)
 421        (pcase url-http-response-status
 422          (`not-implemented              ; 501
 423           ;; The server does not support the functionality required to
 424           ;; fulfill the request.
 425           nil)
 426          (`bad-gateway                  ; 502
 427           ;; The server, while acting as a gateway or proxy, received
 428           ;; an invalid response from the upstream server it accessed
 429           ;; in attempting to fulfill the request.
 430           nil)
 431          (`service-unavailable          ; 503
 432           ;; The server is currently unable to handle the request due
 433           ;; to a temporary overloading or maintenance of the server.
 434           ;; The implication is that this is a temporary condition
 435           ;; which will be alleviated after some delay.  If known, the
 436           ;; length of the delay MAY be indicated in a Retry-After
 437           ;; header.  If no Retry-After is given, the client SHOULD
 438           ;; handle the response as it would for a 500 response.
 439           nil)
 440          (`gateway-timeout              ; 504
 441           ;; The server, while acting as a gateway or proxy, did not
 442           ;; receive a timely response from the upstream server
 443           ;; specified by the URI (e.g. HTTP, FTP, LDAP) or some other
 444           ;; auxiliary server (e.g. DNS) it needed to access in
 445           ;; attempting to complete the request.
 446           nil)
 447          (`http-version-not-supported   ; 505
 448           ;; The server does not support, or refuses to support, the
 449           ;; HTTP protocol version that was used in the request
 450           ;; message.
 451           nil)
 452          (`insufficient-storage         ; 507 (DAV)
 453           ;; The method could not be performed on the resource
 454           ;; because the server is unable to store the representation
 455           ;; needed to successfully complete the request.  This
 456           ;; condition is considered to be temporary.  If the request
 457           ;; which received this status code was the result of a user
 458           ;; action, the request MUST NOT be repeated until it is
 459           ;; requested by a separate user action.
 460           nil))
 461        ;; Tell the callback that an error occurred, and what the
 462        ;; status code was.
 463        (when success
 464          (setf (car url-callback-arguments)
 465                (nconc (list :error (list 'error 'http url-http-response-status))
 466                       (car url-callback-arguments)))))
 467       (_
 468        (error "Unknown class of HTTP response code: %d (%d)"
 469               class url-http-response-status)))
 470     (if (not success)
 471         (url-mark-buffer-as-dead buffer)
 472       (url-handle-content-transfer-encoding))
 473     (url-http-debug "Finished parsing HTTP headers: %S" success)
 474     (widen)
 475     (goto-char (point-min))
 476     success))
 477
 478 (provide 'url-http-ntlm-parse-headers-24.5)
 479
 480 ;; url-http-ntlm-parse-headers-24.5.el ends here