diff options
Diffstat (limited to 'lisp/url/url-http.el')
| -rw-r--r-- | lisp/url/url-http.el | 72 |
1 files changed, 55 insertions, 17 deletions
diff --git a/lisp/url/url-http.el b/lisp/url/url-http.el index aed0efab01a..6b5749e1bce 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) @@ -238,6 +239,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 +284,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 +299,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 +320,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 +355,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 @@ -623,6 +651,12 @@ 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) + (`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 @@ -1258,7 +1292,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 +1328,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,7 +1347,8 @@ 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) @@ -1375,7 +1412,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 +1602,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.") |