diff options
Diffstat (limited to 'lisp/url/url-http.el')
| -rw-r--r-- | lisp/url/url-http.el | 187 |
1 files changed, 120 insertions, 67 deletions
diff --git a/lisp/url/url-http.el b/lisp/url/url-http.el index 1bcfc10645d..527760118d4 100644 --- a/lisp/url/url-http.el +++ b/lisp/url/url-http.el @@ -54,6 +54,7 @@ (defvar url-http-target-url) (defvar url-http-transfer-encoding) (defvar url-show-status) +(defvar url-http-referer) (require 'url-gw) (require 'url-parse) @@ -149,15 +150,6 @@ request.") ;; These routines will allow us to implement persistent HTTP ;; connections. (defsubst url-http-debug (&rest args) - (if quit-flag - (let ((proc (get-buffer-process (current-buffer)))) - ;; The user hit C-g, honor it! Some things can get in an - ;; incredibly tight loop (chunked encoding) - (if proc - (progn - (set-process-sentinel proc nil) - (set-process-filter proc nil))) - (error "Transfer interrupted!"))) (apply 'url-debug 'http args)) (defun url-http-mark-connection-as-busy (host port proc) @@ -238,6 +230,35 @@ request.") emacs-info os-info)) " "))) +(defun url-http--get-referer (url) + (url-http-debug "getting referer from buffer: buffer:%S target-url:%S lastloc:%S" (current-buffer) url url-current-lastloc) + (when url-current-lastloc + (if (not (url-p url-current-lastloc)) + (setq url-current-lastloc (url-generic-parse-url url-current-lastloc))) + (let ((referer (copy-sequence url-current-lastloc))) + (setf (url-host referer) (puny-encode-domain (url-host referer))) + (let ((referer-string (url-recreate-url referer))) + (when (and (not (memq url-privacy-level '(low high paranoid))) + (not (and (listp url-privacy-level) + (memq 'lastloc url-privacy-level)))) + ;; url-privacy-level allows referer. But url-lastloc-privacy-level + ;; may restrict who we send it to. + (cl-case url-lastloc-privacy-level + (host-match + (let ((referer-host (url-host referer)) + (url-host (url-host url))) + (when (string= referer-host url-host) + referer-string))) + (domain-match + (let ((referer-domain (url-domain referer)) + (url-domain (url-domain url))) + (when (and referer-domain + url-domain + (string= referer-domain url-domain)) + referer-string))) + (otherwise + referer-string))))))) + ;; Building an HTTP request (defun url-http-user-agent-string () "Compute a User-Agent string. @@ -254,8 +275,9 @@ The string is based on `url-privacy-level' and `url-user-agent'." ((eq url-user-agent 'default) (url-http--user-agent-default-string)))))) (if ua-string (format "User-Agent: %s\r\n" (string-trim ua-string)) ""))) -(defun url-http-create-request (&optional ref-url) - "Create an HTTP request for `url-http-target-url', referred to by REF-URL." +(defun url-http-create-request () + "Create an HTTP request for `url-http-target-url'. +Use `url-http-referer' as the Referer-header (subject to `url-privacy-level')." (let* ((extra-headers) (request nil) (no-cache (cdr-safe (assoc "Pragma" url-http-extra-headers))) @@ -268,13 +290,14 @@ The string is based on `url-privacy-level' and `url-user-agent'." 'url-http-proxy-basic-auth-storage)) (url-get-authentication url-http-proxy nil 'any nil)))) (real-fname (url-filename url-http-target-url)) - (host (url-http--encode-string (url-host url-http-target-url))) + (host (url-host url-http-target-url)) (auth (if (cdr-safe (assoc "Authorization" url-http-extra-headers)) nil (url-get-authentication (or (and (boundp 'proxy-info) proxy-info) - url-http-target-url) nil 'any nil)))) + url-http-target-url) nil 'any nil))) + (ref-url (url-http--encode-string url-http-referer))) (if (equal "" real-fname) (setq real-fname "/")) (setq no-cache (and no-cache (string-match "no-cache" no-cache))) @@ -288,12 +311,6 @@ The string is based on `url-privacy-level' and `url-user-agent'." (string= ref-url ""))) (setq ref-url nil)) - ;; We do not want to expose the referrer if the user is paranoid. - (if (or (memq url-privacy-level '(low high paranoid)) - (and (listp url-privacy-level) - (memq 'lastloc url-privacy-level))) - (setq ref-url nil)) - ;; url-http-extra-headers contains an assoc-list of ;; header/value pairs that we need to put into the request. (setq extra-headers (mapconcat @@ -329,9 +346,11 @@ The string is based on `url-privacy-level' and `url-user-agent'." (url-scheme-get-property (url-type url-http-target-url) 'default-port)) (format - "Host: %s:%d\r\n" (puny-encode-domain host) + "Host: %s:%d\r\n" (url-http--encode-string + (puny-encode-domain host)) (url-port url-http-target-url)) - (format "Host: %s\r\n" (puny-encode-domain host))) + (format "Host: %s\r\n" + (url-http--encode-string (puny-encode-domain host)))) ;; Who its from (if url-personal-mail-address (concat @@ -485,11 +504,11 @@ Return the number of characters removed." (url-http-debug "url-http-parse-response called in (%s)" (buffer-name)) (goto-char (point-min)) (skip-chars-forward " \t\n") ; Skip any blank crap - (skip-chars-forward "HTTP/") ; Skip HTTP Version + (skip-chars-forward "/HPT") ; Skip HTTP Version "HTTP/". (setq url-http-response-version (buffer-substring (point) (progn - (skip-chars-forward "[0-9].") + (skip-chars-forward "0-9.") (point)))) (setq url-http-response-status (read (current-buffer)))) @@ -511,6 +530,23 @@ work correctly." (declare-function gnutls-peer-status "gnutls.c" (proc)) (declare-function gnutls-negotiate "gnutls.el" t t) +(defun url-http--insert-file-helper (buffer url &optional visit) + (with-current-buffer buffer + (when (bound-and-true-p url-http-response-status) + ;; Don't signal an error if VISIT is non-nil, because + ;; 'insert-file-contents' doesn't. This is required to + ;; support, e.g., 'browse-url-emacs', which is a fancy way of + ;; visiting the HTML source of a URL: in that case, we want to + ;; display a file buffer even if the URL does not exist and + ;; 'url-retrieve-synchronously' returns 404 or whatever. + (unless (or visit + (and (>= url-http-response-status 200) + (< url-http-response-status 300))) + (let ((desc (nth 2 (assq url-http-response-status url-http-codes)))) + (kill-buffer buffer) + ;; Signal file-error per bug#16733. + (signal 'file-error (list url desc))))))) + (defun url-http-parse-headers () "Parse and handle HTTP specific headers. Return t if and only if the current buffer is still active and @@ -585,7 +621,7 @@ should be shown to the user." ;; 206 Partial content ;; 207 Multi-status (Added by DAV) (pcase status-symbol - ((or `no-content `reset-content) + ((or 'no-content 'reset-content) ;; No new data, just stay at the same document (url-mark-buffer-as-dead buffer)) (_ @@ -606,7 +642,7 @@ should be shown to the user." (let ((redirect-uri (or (mail-fetch-field "Location") (mail-fetch-field "URI")))) (pcase status-symbol - (`multiple-choices ; 300 + ('multiple-choices ; 300 ;; Quoth the spec (section 10.3.1) ;; ------------------------------- ;; The requested resource corresponds to any one of a set of @@ -623,20 +659,26 @@ should be shown to the user." ;; We do not support agent-driven negotiation, so we just ;; redirect to the preferred URI if one is provided. nil) - (`see-other ; 303 + ('found ; 302 + ;; 302 Found was ambiguously defined in the standards, but + ;; it's now recommended that it's treated like 303 instead + ;; of 307, since that's what most servers expect. + (setq url-http-method "GET" + url-http-data nil)) + ('see-other ; 303 ;; The response to the request can be found under a different ;; URI and SHOULD be retrieved using a GET method on that ;; resource. (setq url-http-method "GET" url-http-data nil)) - (`not-modified ; 304 + ('not-modified ; 304 ;; The 304 response MUST NOT contain a message-body. (url-http-debug "Extracting document from cache... (%s)" (url-cache-create-filename (url-view-url t))) (url-cache-extract (url-cache-create-filename (url-view-url t))) (setq redirect-uri nil success t)) - (`use-proxy ; 305 + ('use-proxy ; 305 ;; The requested resource MUST be accessed through the ;; proxy given by the Location field. The Location field ;; gives the URI of the proxy. The recipient is expected @@ -734,50 +776,50 @@ should be shown to the user." ;; 424 Failed Dependency (setq success (pcase status-symbol - (`unauthorized ; 401 + ('unauthorized ; 401 ;; The request requires user authentication. The response ;; MUST include a WWW-Authenticate header field containing a ;; challenge applicable to the requested resource. The ;; client MAY repeat the request with a suitable ;; Authorization header field. (url-http-handle-authentication nil)) - (`payment-required ; 402 + ('payment-required ; 402 ;; This code is reserved for future use (url-mark-buffer-as-dead buffer) (error "Somebody wants you to give them money")) - (`forbidden ; 403 + ('forbidden ; 403 ;; The server understood the request, but is refusing to ;; fulfill it. Authorization will not help and the request ;; SHOULD NOT be repeated. t) - (`not-found ; 404 + ('not-found ; 404 ;; Not found t) - (`method-not-allowed ; 405 + ('method-not-allowed ; 405 ;; The method specified in the Request-Line is not allowed ;; for the resource identified by the Request-URI. The ;; response MUST include an Allow header containing a list of ;; valid methods for the requested resource. t) - (`not-acceptable ; 406 + ('not-acceptable ; 406 ;; The resource identified by the request is only capable of ;; generating response entities which have content ;; characteristics not acceptable according to the accept ;; headers sent in the request. t) - (`proxy-authentication-required ; 407 + ('proxy-authentication-required ; 407 ;; This code is similar to 401 (Unauthorized), but indicates ;; that the client must first authenticate itself with the ;; proxy. The proxy MUST return a Proxy-Authenticate header ;; field containing a challenge applicable to the proxy for ;; the requested resource. (url-http-handle-authentication t)) - (`request-timeout ; 408 + ('request-timeout ; 408 ;; The client did not produce a request within the time that ;; the server was prepared to wait. The client MAY repeat ;; the request without modifications at any later time. t) - (`conflict ; 409 + ('conflict ; 409 ;; The request could not be completed due to a conflict with ;; the current state of the resource. This code is only ;; allowed in situations where it is expected that the user @@ -786,11 +828,11 @@ should be shown to the user." ;; information for the user to recognize the source of the ;; conflict. t) - (`gone ; 410 + ('gone ; 410 ;; The requested resource is no longer available at the ;; server and no forwarding address is known. t) - (`length-required ; 411 + ('length-required ; 411 ;; The server refuses to accept the request without a defined ;; Content-Length. The client MAY repeat the request if it ;; adds a valid Content-Length header field containing the @@ -800,29 +842,29 @@ should be shown to the user." ;; `url-http-create-request' automatically calculates the ;; content-length. t) - (`precondition-failed ; 412 + ('precondition-failed ; 412 ;; The precondition given in one or more of the ;; request-header fields evaluated to false when it was ;; tested on the server. t) - ((or `request-entity-too-large `request-uri-too-large) ; 413 414 + ((or 'request-entity-too-large 'request-uri-too-large) ; 413 414 ;; The server is refusing to process a request because the ;; request entity|URI is larger than the server is willing or ;; able to process. t) - (`unsupported-media-type ; 415 + ('unsupported-media-type ; 415 ;; The server is refusing to service the request because the ;; entity of the request is in a format not supported by the ;; requested resource for the requested method. t) - (`requested-range-not-satisfiable ; 416 + ('requested-range-not-satisfiable ; 416 ;; A server SHOULD return a response with this status code if ;; a request included a Range request-header field, and none ;; of the range-specifier values in this field overlap the ;; current extent of the selected resource, and the request ;; did not include an If-Range request-header field. t) - (`expectation-failed ; 417 + ('expectation-failed ; 417 ;; The expectation given in an Expect request-header field ;; could not be met by this server, or, if the server is a ;; proxy, the server has unambiguous evidence that the @@ -849,16 +891,16 @@ should be shown to the user." ;; 507 Insufficient storage (setq success t) (pcase url-http-response-status - (`not-implemented ; 501 + ('not-implemented ; 501 ;; The server does not support the functionality required to ;; fulfill the request. nil) - (`bad-gateway ; 502 + ('bad-gateway ; 502 ;; The server, while acting as a gateway or proxy, received ;; an invalid response from the upstream server it accessed ;; in attempting to fulfill the request. nil) - (`service-unavailable ; 503 + ('service-unavailable ; 503 ;; The server is currently unable to handle the request due ;; to a temporary overloading or maintenance of the server. ;; The implication is that this is a temporary condition @@ -867,19 +909,19 @@ should be shown to the user." ;; header. If no Retry-After is given, the client SHOULD ;; handle the response as it would for a 500 response. nil) - (`gateway-timeout ; 504 + ('gateway-timeout ; 504 ;; The server, while acting as a gateway or proxy, did not ;; receive a timely response from the upstream server ;; specified by the URI (e.g. HTTP, FTP, LDAP) or some other ;; auxiliary server (e.g. DNS) it needed to access in ;; attempting to complete the request. nil) - (`http-version-not-supported ; 505 + ('http-version-not-supported ; 505 ;; The server does not support, or refuses to support, the ;; HTTP protocol version that was used in the request ;; message. nil) - (`insufficient-storage ; 507 (DAV) + ('insufficient-storage ; 507 (DAV) ;; The method could not be performed on the resource ;; because the server is unable to store the representation ;; needed to successfully complete the request. This @@ -905,7 +947,8 @@ should be shown to the user." (goto-char (point-min)) success)) -(declare-function zlib-decompress-region "decompress.c" (start end)) +(declare-function zlib-decompress-region "decompress.c" + (start end &optional allow-partial)) (defun url-handle-content-transfer-encoding () (let ((encoding (mail-fetch-field "content-encoding"))) @@ -917,7 +960,7 @@ should be shown to the user." (widen) (goto-char (point-min)) (when (search-forward "\n\n") - (zlib-decompress-region (point) (point-max))))))) + (zlib-decompress-region (point) (point-max) t)))))) ;; Miscellaneous (defun url-http-activate-callback () @@ -973,7 +1016,8 @@ should be shown to the user." (defun url-http-simple-after-change-function (_st _nd _length) ;; Function used when we do NOT know how long the document is going to be ;; Just _very_ simple 'downloaded %d' type of info. - (url-lazy-message "Reading %s..." (file-size-human-readable (buffer-size)))) + (url-lazy-message "Reading %s..." + (file-size-human-readable (buffer-size) 'iec " "))) (defun url-http-content-length-after-change-function (_st nd _length) "Function used when we DO know how long the document is going to be. @@ -986,16 +1030,16 @@ the callback to be triggered." (url-percentage (- nd url-http-end-of-headers) url-http-content-length) url-http-content-type - (file-size-human-readable (- nd url-http-end-of-headers)) - (file-size-human-readable url-http-content-length) + (file-size-human-readable (- nd url-http-end-of-headers) 'iec " ") + (file-size-human-readable url-http-content-length 'iec " ") (url-percentage (- nd url-http-end-of-headers) url-http-content-length)) (url-display-percentage "Reading... %s of %s (%d%%)" (url-percentage (- nd url-http-end-of-headers) url-http-content-length) - (file-size-human-readable (- nd url-http-end-of-headers)) - (file-size-human-readable url-http-content-length) + (file-size-human-readable (- nd url-http-end-of-headers) 'iec " ") + (file-size-human-readable url-http-content-length 'iec " ") (url-percentage (- nd url-http-end-of-headers) url-http-content-length))) @@ -1054,10 +1098,16 @@ the end of the document." (if no-initial-crlf (skip-chars-forward "\r\n")) (if (not (looking-at regexp)) (progn - ;; Must not have received the entirety of the chunk header, + ;; Must not have received the entirety of the chunk header, ;; need to spin some more. (url-http-debug "Did not see start of chunk @ %d!" (point)) (setq read-next-chunk nil)) + ;; The data we got may have started in the middle of the + ;; initial chunk header, so move back to the start of the + ;; line and re-compute. + (when (= url-http-chunked-counter 0) + (beginning-of-line) + (looking-at regexp)) (add-text-properties (match-beginning 0) (match-end 0) (list 'start-open t 'end-open t @@ -1073,8 +1123,7 @@ the end of the document." (or url-http-chunked-start (make-marker)) (match-end 0))) -; (if (not url-http-debug) - (delete-region (match-beginning 0) (match-end 0));) + (delete-region (match-beginning 0) (match-end 0)) (url-http-debug "Saw start of chunk %d (length=%d, start=%d" url-http-chunked-counter url-http-chunked-length (marker-position url-http-chunked-start)) @@ -1258,7 +1307,8 @@ The return value of this function is the retrieval buffer." (mime-accept-string url-mime-accept-string) (buffer (or retry-buffer (generate-new-buffer - (format " *http %s:%d*" (url-host url) (url-port url)))))) + (format " *http %s:%d*" (url-host url) (url-port url))))) + (referer (url-http--encode-string (url-http--get-referer url)))) (if (not connection) ;; Failed to open the connection for some reason (progn @@ -1293,7 +1343,8 @@ The return value of this function is the retrieval buffer." url-http-no-retry url-http-connection-opened url-mime-accept-string - url-http-proxy)) + url-http-proxy + url-http-referer)) (set (make-local-variable var) nil)) (setq url-http-method (or url-request-method "GET") @@ -1311,15 +1362,16 @@ The return value of this function is the retrieval buffer." url-http-no-retry retry-buffer url-http-connection-opened nil url-mime-accept-string mime-accept-string - url-http-proxy url-using-proxy) + url-http-proxy url-using-proxy + url-http-referer referer) (set-process-buffer connection buffer) (set-process-filter connection 'url-http-generic-filter) (pcase (process-status connection) - (`connect + ('connect ;; Asynchronous connection (set-process-sentinel connection 'url-http-async-sentinel)) - (`failed + ('failed ;; Asynchronous connection failed (error "Could not create connection to %s:%d" (url-host url) (url-port url))) @@ -1375,7 +1427,9 @@ The return value of this function is the retrieval buffer." 'url-http-wait-for-headers-change-function) (set-process-filter tls-connection 'url-http-generic-filter) (process-send-string tls-connection - (url-http-create-request))) + ;; Use the non-proxy form of the request + (let (url-http-proxy) + (url-http-create-request)))) (gnutls-error (url-http-activate-callback) (error "gnutls-error: %s" e)) @@ -1563,7 +1617,6 @@ p3p ;; HTTPS. This used to be in url-https.el, but that file collides ;; with url-http.el on systems with 8-character file names. -(require 'tls) (defconst url-https-asynchronous-p t "HTTPS retrievals are asynchronous.") |