From: Lars Ingebrigtsen <larsi@gnus.org>
Date: Sun, 6 Mar 2022 16:41:18 +0000 (+0100)
Subject: Fix problem with fetching images via Cloudflare
X-Git-Tag: emacs-29.0.90~1990
X-Git-Url: http://git.eshelyaron.com/gitweb/?a=commitdiff_plain;h=56bdfe78208149fa864842d47bfd08d1bc4d6d10;p=emacs.git

Fix problem with fetching images via Cloudflare

* lisp/url/url-http.el (url-http): Factor out url-interactive-p.
* lisp/url/url-auth.el (url-basic-auth):
(url-basic-auth):
(url-digest-prompt-creds): Use it to not query the user.

* lisp/url/url-queue.el (url-queue-start-retrieve): Don't send a
bogus empty Authorization header (bug#54246) -- this triggers
Cloudflare's anti-attack software.  Instead rely on
url-request-noninteractive.

* lisp/url/url-vars.el (url-interactive-p): New utility function.
---

diff --git a/lisp/url/url-auth.el b/lisp/url/url-auth.el
index 585010d21c5..dd658b1b68b 100644
--- a/lisp/url/url-auth.el
+++ b/lisp/url/url-auth.el
@@ -87,11 +87,13 @@ instead of the filename inheritance method."
      ((and prompt (not byserv))
       (setq user (or
 		  (url-do-auth-source-search server type :user)
-		  (read-string (url-auth-user-prompt href realm)
-			       (or user (user-real-login-name))))
+                  (and (url-interactive-p)
+		       (read-string (url-auth-user-prompt href realm)
+			            (or user (user-real-login-name)))))
 	    pass (or
 		  (url-do-auth-source-search server type :secret)
-		  (read-passwd "Password: " nil (or pass ""))))
+                  (and (url-interactive-p)
+		       (read-passwd "Password: " nil (or pass "")))))
       (set url-basic-auth-storage
 	   (cons (list server
 		       (cons file
@@ -117,11 +119,13 @@ instead of the filename inheritance method."
 	  (progn
 	    (setq user (or
 			(url-do-auth-source-search server type :user)
-			(read-string (url-auth-user-prompt href realm)
-				     (user-real-login-name)))
+                        (and (url-interactive-p)
+			     (read-string (url-auth-user-prompt href realm)
+				          (user-real-login-name))))
 		  pass (or
 			(url-do-auth-source-search server type :secret)
-			(read-passwd "Password: "))
+                        (and (url-interactive-p)
+			     (read-passwd "Password: ")))
 		  retval (base64-encode-string (format "%s:%s" user pass) t)
 		  byserv (assoc server (symbol-value url-basic-auth-storage)))
 	    (setcdr byserv
@@ -233,11 +237,13 @@ CREDS is a plist that may have properties `:user' and `:secret'."
   ;; plist-put modify the same plist.
   (setq creds
         (plist-put creds :user
-                   (read-string (url-auth-user-prompt url realm)
-                                (or (plist-get creds :user)
-                                    (user-real-login-name)))))
+                   (and (url-interactive-p)
+                        (read-string (url-auth-user-prompt url realm)
+                                     (or (plist-get creds :user)
+                                         (user-real-login-name))))))
   (plist-put creds :secret
-             (read-passwd "Password: " nil (plist-get creds :secret))))
+             (and (url-interactive-p)
+                  (read-passwd "Password: " nil (plist-get creds :secret)))))
 
 (defun url-digest-auth-directory-id-assoc (dirkey keylist)
   "Find the best match for DIRKEY in key alist KEYLIST.
diff --git a/lisp/url/url-http.el b/lisp/url/url-http.el
index 16c3a6a1e62..daeba17031d 100644
--- a/lisp/url/url-http.el
+++ b/lisp/url/url-http.el
@@ -1304,9 +1304,7 @@ The return value of this function is the retrieval buffer."
   (cl-check-type url url "Need a pre-parsed URL.")
   (let* (;; (host (url-host (or url-using-proxy url)))
 	 ;; (port (url-port (or url-using-proxy url)))
-	 (nsm-noninteractive (or url-request-noninteractive
-				 (and (boundp 'url-http-noninteractive)
-				      url-http-noninteractive)))
+	 (nsm-noninteractive (not (url-interactive-p)))
          ;; The following binding is needed in url-open-stream, which
          ;; is called from url-http-find-free-connection.
          (url-current-object url)
diff --git a/lisp/url/url-queue.el b/lisp/url/url-queue.el
index 152300bda55..b2e24607e11 100644
--- a/lisp/url/url-queue.el
+++ b/lisp/url/url-queue.el
@@ -161,11 +161,7 @@ The variable `url-queue-timeout' sets a timeout."
                                    (url-queue-context-buffer job)
                                  (current-buffer))
 	    (let ((url-request-noninteractive t)
-                  (url-allow-non-local-files t)
-                  ;; This will disable querying the user for
-                  ;; credentials if one of the things we're fetching
-                  ;; in the background return a header requesting it.
-                  (url-request-extra-headers '(("Authorization" . ""))))
+                  (url-allow-non-local-files t))
               (url-retrieve (url-queue-url job)
                             #'url-queue-callback-function (list job)
                             (url-queue-silentp job)
diff --git a/lisp/url/url-vars.el b/lisp/url/url-vars.el
index 83c089a930a..9e91bf0670e 100644
--- a/lisp/url/url-vars.el
+++ b/lisp/url/url-vars.el
@@ -424,6 +424,11 @@ Should be one of:
 This should be set, e.g. by mail user agents rendering HTML to avoid
 `bugs' which call home.")
 
+(defun url-interactive-p ()
+  "Say whether the current request is from a interactive context."
+  (not (or url-request-noninteractive
+           (bound-and-true-p 'url-http-noninteractive))))
+
 ;; Obsolete
 
 (defconst url-version "Emacs" "Version number of URL package.")