procyberian/emacs
1
0
Fork 0
Code Issues Pull requests Projects Releases Packages Wiki Activity Actions

Change gnutls-verify-error to be first-match

Browse source 
* doc/misc/url.texi (Customization): Describe the new user
option url-lastloc-privacy-level.

* lisp/net/eww.el (eww-render): Set url-current-lastloc to the
url we are rendering, to get the referer header right on
subsequent requests.

* lisp/url/url-http.el (url-http--get-referer): New function
to determine which referer to send, if any, considering the
users privacy settings and the target url we are visiting.
(url-http-referer): New variable keeping track of the referer
computed by url-http--get-referer
(url-http-create-request): Use url-http-referer instead of the
optional argument to set up the referer header.  Leave
checking of privacy settings to url-http--get-referer.
(url-http): Set up url-http-referer by using
url-http--get-referer.

* lisp/url/url-queue.el (url-queue): New struct member
context-buffer for keeping track of the context a queued job
started from.
(url-queue-retrieve): Store the current buffer in the queue
object.
(url-queue-start-retrieve): Make sure url-retrieve is called
in the context of the original buffer, if available.

* lisp/url/url-util.el (url-domain): New function to determine
the domain of a given URL.

* lisp/url/url-vars.el (url-current-lastloc): New variable to
keep track of the desired "last location" (referer header).
(url-lastloc-privacy-level): New custom setting for more
fine-grained control over how lastloc (referer) is sent to
servers (Bug#27012).
This commit is contained in:
Peder O. Klingenberg 2018-04-13 15:08:18 +02:00 • committed by Lars Ingebrigtsen
parent fa41693799
commit 9822a6a570
6 changed files with 126 additions and 22 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

14
doc/misc/url.texi
View file

@ -1291,6 +1291,20 @@ It may also be a list of the types of messages to be logged.
@end defopt
@defopt url-privacy-level
@end defopt
@defopt url-lastloc-privacy-level
Provided @code{lastloc} is not prohibited by @code{url-privacy-level},
this determines who we send our last location to. @code{none} means
we include our last location in every outgoing request.
@code{domain-match} means we send it only if the domain of our last
location matches the domain of the URI we are requesting.
@code{host-match} means we only send our last location back to the
same host. The default is @code{domain-match}.
Using @code{domain-match} for this option requires emacs to make one
or more DNS requests each time a new host is contacted, to determine
the domain of the host. Results of these lookups are cached, so
repeated visits do not require repeated domain lookups.
@end defopt
@defopt url-uncompressor-alist
@end defopt
@defopt url-passwd-entry-func

7
lisp/net/eww.el
View file

@ -272,7 +272,7 @@ word(s) will be searched for via `eww-search-prefix'."
(insert (format "Loading %s..." url))
(goto-char (point-min)))
(url-retrieve url 'eww-render
(list url nil (current-buffer))))
(list url nil (current-buffer))))
(defun eww--dwim-expand-url (url)
(setq url (string-trim url))
@ -370,7 +370,10 @@ Currently this means either text/html or application/xhtml+xml."
;; Save the https peer status.
(plist-put eww-data :peer (plist-get status :peer))
;; Make buffer listings more informative.
(setq list-buffers-directory url))
(setq list-buffers-directory url)
;; Let the URL library have a handle to the current URL for
;; referer purposes.
(setq url-current-lastloc (url-generic-parse-url url)))
(unwind-protect
(progn
(cond

52
lisp/url/url-http.el
View file

@ -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,34 @@ 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 url-current-lastloc)
(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 +283,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', using `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)))
@ -274,7 +304,8 @@ The string is based on `url-privacy-level' and `url-user-agent'."
(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-referer))
(if (equal "" real-fname)
(setq real-fname "/"))
(setq no-cache (and no-cache (string-match "no-cache" no-cache)))
@ -288,12 +319,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
@ -1264,7 +1289,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--get-referer url)))
(if (not connection)
;; Failed to open the connection for some reason
(progn
@ -1299,7 +1325,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")
@ -1317,7 +1344,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)

18
lisp/url/url-queue.el
View file

@ -52,7 +52,7 @@
(cl-defstruct url-queue
url callback cbargs silentp
buffer start-time pre-triggered
inhibit-cookiesp)
inhibit-cookiesp context-buffer)
;;;###autoload
(defun url-queue-retrieve (url callback &optional cbargs silent inhibit-cookies)
@ -67,7 +67,8 @@ The variable `url-queue-timeout' sets a timeout."
:callback callback
:cbargs cbargs
:silentp silent
:inhibit-cookiesp inhibit-cookies))))
:inhibit-cookiesp inhibit-cookies
:context-buffer (current-buffer)))))
(url-queue-setup-runners))
;; To ensure asynch behavior, we start the required number of queue
@ -147,11 +148,14 @@ The variable `url-queue-timeout' sets a timeout."
(defun url-queue-start-retrieve (job)
(setf (url-queue-buffer job)
(ignore-errors
(let ((url-request-noninteractive t))
(url-retrieve (url-queue-url job)
#'url-queue-callback-function (list job)
(url-queue-silentp job)
(url-queue-inhibit-cookiesp job))))))
(with-current-buffer (if (buffer-live-p (url-queue-context-buffer job))
(url-queue-context-buffer job)
(current-buffer))
(let ((url-request-noninteractive t))
(url-retrieve (url-queue-url job)
#'url-queue-callback-function (list job)
(url-queue-silentp job)
(url-queue-inhibit-cookiesp job)))))))
(defun url-queue-prune-old-entries ()
(let (dead-jobs)

29
lisp/url/url-util.el
View file

@ -627,6 +627,35 @@ Creates FILE and its parent directories if they do not exist."
(error "Danger: `%s' is a symbolic link" file))
(set-file-modes file #o0600))))
(autoload 'dns-query "dns")
(defvar url--domain-cache (make-hash-table :test 'equal :size 17)
"Cache to minimize dns lookups.")
;;;###autoload
(defun url-domain (url)
"Return the domain of the host of the url, or nil if url does
not contain a registered name."
;; Determining the domain of a name can not be done with simple
;; textual manipulations. a.b.c is either host a in domain b.c
;; (www.google.com), or domain a.b.c with no separate host
;; (bbc.co.uk). Instead of guessing based on tld (which in any case
;; may be inaccurate in the face of subdelegations), we look for
;; domain delegations in DNS.
;;
;; Domain delegations change rarely enough that we won't bother with
;; cache invalidation, I think.
(let* ((host-parts (split-string (url-host url) "\\."))
(result (gethash host-parts url--domain-cache 'not-found)))
(when (eq result 'not-found)
(setq result
(cl-loop for parts on host-parts
for dom = (mapconcat #'identity parts ".")
when (dns-query dom 'SOA)
return dom))
(puthash host-parts result url--domain-cache))
result))
(provide 'url-util)
;;; url-util.el ends here

28
lisp/url/url-vars.el
View file

@ -60,10 +60,18 @@
(defvar url-current-mime-headers nil
"A parsed representation of the MIME headers for the current URL.")
(defvar url-current-lastloc nil
"A parsed representation of the URL to be considered as the last location.
Use of this value on outbound connections is subject to
`url-privacy-level' and `url-lastloc-privacy-level'. This is never set
by the url library, applications are expected to set this
variable in buffers representing a displayed location.")
(mapc 'make-variable-buffer-local
'(
url-current-object
url-current-mime-headers
url-current-lastloc
))
(defcustom url-honor-refresh-requests t
@ -117,7 +125,7 @@ Valid symbols are:
email -- the email address
os -- the operating system info
emacs -- the version of Emacs
lastloc -- the last location
lastloc -- the last location (see also `url-lastloc-privacy-level')
agent -- do not send the User-Agent string
cookies -- never accept HTTP cookies
@ -150,6 +158,24 @@ variable."
(const :tag "No cookies" :value cookie)))
:group 'url)
(defcustom url-lastloc-privacy-level 'domain-match
"Further restrictions on sending the last location.
This value is only consulted if `url-privacy-level' permits
sending last location in the first place.
Valid values are:
none -- Always send last location.
domain-match -- Send last location if the new location is within the
same domain
host-match -- Send last location if the new location is on the
same host
"
:version "26.1"
:type '(radio (const :tag "Always send" none)
(const :tag "Domains match" domain-match)
(const :tag "Hosts match" host-match))
:group 'url)
(defvar url-inhibit-uncompression nil "Do not do decompression if non-nil.")
(defcustom url-uncompressor-alist '((".z" . "x-gzip")