[Emacs-diffs] master 9822a6a: Change gnutls-verify-error to be first-match

[Lars Ingebrigtsen]

branch: master
commit 9822a6a5708227897432f47d3f676c646b7bd4b2
Author: Peder O. Klingenberg <address@hidden>
Commit: Lars Ingebrigtsen <address@hidden>

    Change gnutls-verify-error to be first-match
    
    * 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).
---
 doc/misc/url.texi     | 14 ++++++++++++++
 lisp/net/eww.el       |  7 +++++--
 lisp/url/url-http.el  | 52 +++++++++++++++++++++++++++++++++++++++------------
 lisp/url/url-queue.el | 18 +++++++++++-------
 lisp/url/url-util.el  | 29 ++++++++++++++++++++++++++++
 lisp/url/url-vars.el  | 28 ++++++++++++++++++++++++++-
 6 files changed, 126 insertions(+), 22 deletions(-)

diff --git a/doc/misc/url.texi b/doc/misc/url.texi
index 1acf5f2..fb0a55b 100644
--- a/doc/misc/url.texi
+++ b/doc/misc/url.texi
@@ -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
address@hidden 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.
address@hidden means we send it only if the domain of our last
+location matches the domain of the URI we are requesting.
address@hidden 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.
address@hidden defopt
 @defopt url-uncompressor-alist
 @end defopt
 @defopt url-passwd-entry-func
diff --git a/lisp/net/eww.el b/lisp/net/eww.el
index 6b7fa05..3f1a1ae 100644
--- a/lisp/net/eww.el
+++ b/lisp/net/eww.el
@@ -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
diff --git a/lisp/url/url-http.el b/lisp/url/url-http.el
index e2d7a50..45e887b 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,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)
diff --git a/lisp/url/url-queue.el b/lisp/url/url-queue.el
index cd30d94..cfa8e9a 100644
--- a/lisp/url/url-queue.el
+++ b/lisp/url/url-queue.el
@@ -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)
diff --git a/lisp/url/url-util.el b/lisp/url/url-util.el
index 85bfb65..77e0150 100644
--- a/lisp/url/url-util.el
+++ b/lisp/url/url-util.el
@@ -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
diff --git a/lisp/url/url-vars.el b/lisp/url/url-vars.el
index 62abcff..6ef2168 100644
--- a/lisp/url/url-vars.el
+++ b/lisp/url/url-vars.el
@@ -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")