Fix Libravatar federation handling

* lisp/image/gravatar.el (gravatar--service-libravatar): Implement
correct algorithm (bug#40354).

diff --git a/lisp/image/gravatar.el b/lisp/image/gravatar.el
index e917033562e71ff38845ea46bd27e7cfb162a64e..7441964095623f528205d8c217ccdba0dec5a2ff 100644 (file)
--- a/lisp/image/gravatar.el
+++ b/lisp/image/gravatar.el
@@ -151,25 +151,64 @@ to track whether you're reading a specific mail."
   (save-match-data
     (if (not (string-match ".+@\\(.+\\)" addr))
         (funcall callback "https://seccdn.libravatar.org/avatar")
-      (let ((domain (match-string 1 addr))
-            (records '(("_avatars-sec" . "https")
-                       ("_avatars" . "http")))
-            func)
-        (setq func
+      (let* ((domain (match-string 1 addr))
+             (records '(("_avatars-sec" . "https")
+                        ("_avatars" . "http")))
+             (func
               (lambda (result)
                 (cond
-                 (result
-                  (funcall callback (format "%s://%s/avatar"
-                                            (cdar records) result)))
-                 ((> (length records) 1)
-                  (pop records)
+                 ((and
+                   result               ;there is a result
+                   (let* ((data (mapcar (lambda (record)
+                                          (dns-get 'data (cdr record)))
+                                        (dns-get 'answers result)))
+                          (priorities (mapcar (lambda (r)
+                                                (dns-get 'priority r))
+                                              data))
+                          (max-priority (if priorities
+                                            (apply #'max priorities)
+                                          0))
+                          (sum 0) top)
+                     ;; Attempt to find all records with the same maximal
+                     ;; priority, and calculate the sum of their weights.
+                     (dolist (ent data)
+                       (when (= max-priority (dns-get 'priority ent))
+                         (setq sum (+ sum (dns-get 'weight ent)))
+                         (push ent top)))
+                     ;; In case there is more than one maximal priority
+                     ;; record, choose one at random, while taking the
+                     ;; individual record weights into consideration.
+                     (catch 'done
+                       (dolist (ent top)
+                         (when (and (or (= 0 sum)
+                                        (<= 0 (random sum)
+                                            (dns-get 'weight ent)))
+                                    ;; Ensure that port and domain data are
+                                    ;; valid. In case non of the results
+                                    ;; were valid, `catch' will evaluate to
+                                    ;; nil, and the next cond clause will be
+                                    ;; tested.
+                                    (<= 1 (dns-get 'port ent) 65535)
+                                    (string-match-p "\\`[-.0-9A-Za-z]+\\'"
+                                                    (dns-get 'target ent)))
+                           (funcall callback
+                                    (url-normalize-url
+                                     (format "%s://%s:%s/avatar"
+                                             (cdar records)
+                                             (dns-get 'target ent)
+                                             (dns-get 'port ent))))
+                           (throw 'done t))
+                         (setq sum (- sum (dns-get 'weight ent))))))))
+                 ((setq records (cdr records))
+                  ;; In case there are at least two methods.
                   (dns-query-asynchronous
                    (concat (caar records) "._tcp." domain)
                    func 'SRV))
-                 (t
-                  (funcall callback "https://seccdn.libravatar.org/avatar")))))
+                 (t                     ;fallback
+                  (funcall callback "https://seccdn.libravatar.org/avatar"))))))
         (dns-query-asynchronous
-         (concat (caar records) "._tcp." domain) func 'SRV)))))
+         (concat (caar records) "._tcp." domain)
+         func 'SRV t)))))
 
 (defun gravatar-hash (mail-address)
   "Return the Gravatar hash for MAIL-ADDRESS."