From e58b4b24cfa554b93a0d02e14a9dfc38c40d0742 Mon Sep 17 00:00:00 2001
From: Lars Ingebrigtsen <larsi@gnus.org>
Date: Wed, 19 Jan 2022 17:50:21 +0100
Subject: [PATCH] Add text for suspicious links

* lisp/international/textsec-check.el (textsec-check): Note `link'.
(textsec-propertize): Fix typo.

* lisp/international/textsec.el (textsec-link-suspicious-p): New
function.

* lisp/net/shr.el (shr-tag-a): Check for sus links.
---
 lisp/international/textsec-check.el      |  6 +++---
 lisp/international/textsec.el            | 26 ++++++++++++++++++++++++
 lisp/net/shr.el                          |  7 ++++++-
 test/lisp/international/textsec-tests.el | 18 ++++++++++++++++
 4 files changed, 53 insertions(+), 4 deletions(-)

diff --git a/lisp/international/textsec-check.el b/lisp/international/textsec-check.el
index 464845d5b63..8f641e5a66d 100644
--- a/lisp/international/textsec-check.el
+++ b/lisp/international/textsec-check.el
@@ -44,8 +44,8 @@ If nil, these checks are disabled."
 If STRING is suspicious, a string explaining the possible problem
 is returned.
 
-Available types include `url', `domain', `local-address', `name',
-`email-address', and `email-address-headers'.
+Available types include `url', `link', `domain', `local-address',
+`name', `email-address', and `email-address-headers'.
 
 If the `textsec-check' user option is nil, these checks are
 disabled, and this function always returns nil."
@@ -67,7 +67,7 @@ verbatim.
 
 See `texsec-check' for further information about TYPE."
   (let ((warning (textsec-check string type)))
-    (if (not wardning)
+    (if (not warning)
         string
       (propertize string
                   'face 'textsec-suspicious
diff --git a/lisp/international/textsec.el b/lisp/international/textsec.el
index 4e9fb10ad77..89ef38e93e0 100644
--- a/lisp/international/textsec.el
+++ b/lisp/international/textsec.el
@@ -376,6 +376,32 @@ potential problem."
     (and (url-host parsed)
          (textsec-domain-suspicious-p (url-host parsed)))))
 
+(defun textsec-link-suspicious-p (link)
+  "Say whether LINK is suspicious.
+LINK should be a cons cell where the first element is the URL,
+and the second element is the link text.
+
+This function will return non-nil if it seems like the link text
+is misleading about where the URL takes you.  This is typical
+when the link text looks like an URL itself, but doesn't lead to
+the same domain as the URL."
+  (let ((url (car link))
+        (text (string-trim (cdr link))))
+    (when (string-match-p "\\`[a-z]+\\.[.a-z]+\\'" text)
+      (setq text (concat "http://" text)))
+    (let ((udomain (url-host (url-generic-parse-url url)))
+          (tdomain (url-host (url-generic-parse-url text))))
+      (and udomain
+           tdomain
+           (not (equal udomain tdomain))
+           ;; One may be a sub-domain of the other, but don't allow too
+           ;; short domains.
+           (not (or (and (string-suffix-p udomain tdomain)
+                         (url-domsuf-cookie-allowed-p udomain))
+                    (and (string-suffix-p tdomain udomain)
+                         (url-domsuf-cookie-allowed-p tdomain))))
+           (format "Text `%s' doesn't point to link URL `%s'" text url)))))
+
 (provide 'textsec)
 
 ;;; textsec.el ends here
diff --git a/lisp/net/shr.el b/lisp/net/shr.el
index c3950acd3d8..79a8e9ba262 100644
--- a/lisp/net/shr.el
+++ b/lisp/net/shr.el
@@ -1469,7 +1469,12 @@ ones, in case fg and bg are nil."
     (when url
       (shr-urlify (or shr-start start) (shr-expand-url url) title)
       ;; Check whether the URL is suspicious.
-      (when-let ((warning (textsec-check (shr-expand-url url) 'url)))
+      (when-let ((warning (or (textsec-check (shr-expand-url url) 'url)
+                              (textsec-check (cons (shr-expand-url url)
+                                                   (buffer-substring
+                                                    (or shr-start start)
+                                                    (point)))
+                                             'link))))
         (add-text-properties (or shr-start start) (point)
                              (list 'face '(shr-link textsec-suspicious)))
         (insert (propertize "⚠️" 'help-echo warning))))))
diff --git a/test/lisp/international/textsec-tests.el b/test/lisp/international/textsec-tests.el
index c7cf56757cd..416490aa085 100644
--- a/test/lisp/international/textsec-tests.el
+++ b/test/lisp/international/textsec-tests.el
@@ -168,4 +168,22 @@
   (should-not (textsec-url-suspicious-p "http://example.ru/bar"))
   (should (textsec-url-suspicious-p "http://Сгсе.ru/bar")))
 
+(ert-deftest test-suspicious-link ()
+  (should-not (textsec-link-suspicious-p
+               (cons "https://gnu.org/" "Hello")))
+  (should-not (textsec-link-suspicious-p
+               (cons "https://gnu.org/" "https://gnu.org/")))
+  (should-not (textsec-link-suspicious-p
+               (cons "https://gnu.org/" "https://www.gnu.org/")))
+  (should-not (textsec-link-suspicious-p
+               (cons "https://www.gnu.org/" "https://gnu.org/")))
+  (should (textsec-link-suspicious-p
+           (cons "https://www.gnu.org/" "https://org/")))
+  (should (textsec-link-suspicious-p
+           (cons "https://www.gnu.org/" "https://fsf.org/")))
+  (should (textsec-link-suspicious-p
+           (cons "https://www.gnu.org/" "http://fsf.org/")))
+  (should (textsec-link-suspicious-p
+           (cons "https://www.gnu.org/" "fsf.org"))))
+
 ;;; textsec-tests.el ends here
-- 
2.39.5