From 1bfc086391c3ee0ae8a5ae667b67f1109aa74dc9 Mon Sep 17 00:00:00 2001
From: Lars Ingebrigtsen <larsi@gnus.org>
Date: Wed, 19 Jan 2022 16:37:05 +0100
Subject: [PATCH] Make shr mark links with suspicious URLs

* lisp/international/textsec-check.el (textsec-propertize): New
function.
(textsec-check): Only check, don't alter STRING.

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

* lisp/net/shr.el (shr-tag-a): Mark suspicious links.
---
 lisp/international/textsec-check.el      | 35 ++++++++++++++++--------
 lisp/international/textsec.el            |  8 ++++++
 lisp/net/shr.el                          |  7 ++++-
 test/lisp/international/textsec-tests.el |  4 +++
 4 files changed, 41 insertions(+), 13 deletions(-)

diff --git a/lisp/international/textsec-check.el b/lisp/international/textsec-check.el
index ff1b985d93a..464845d5b63 100644
--- a/lisp/international/textsec-check.el
+++ b/lisp/international/textsec-check.el
@@ -41,26 +41,37 @@ If nil, these checks are disabled."
 ;;;###autoload
 (defun textsec-check (string type)
   "Test whether STRING is suspicious when considered as TYPE.
-If STRING is suspicious, text properties will be added to the
-string to mark it as suspicious, and with tooltip texts that says
-what's suspicious about it.
+If STRING is suspicious, a string explaining the possible problem
+is returned.
 
-Available types include `domain', `local-address', `name',
+Available types include `url', `domain', `local-address', `name',
 `email-address', and `email-address-headers'.
 
-If the `textsec-check' user option is nil, these checks are disabled."
+If the `textsec-check' user option is nil, these checks are
+disabled, and this function always returns nil."
   (if (not textsec-check)
-      string
+      nil
     (require 'textsec)
     (let ((func (intern (format "textsec-%s-suspicious-p" type))))
       (unless (fboundp func)
         (error "%s is not a valid function" func))
-      (let ((warning (funcall func string)))
-        (if (not warning)
-            string
-          (propertize string
-                      'face 'textsec-suspicious
-                      'help-echo warning))))))
+      (funcall func string))))
+
+;;;###autoload
+(defun textsec-propertize (string type)
+  "Test whether STRING is suspicious when considered as TYPE.
+If STRING is suspicious, text properties will be added to the
+string to mark it as suspicious, and with tooltip texts that says
+what's suspicious about it.  Otherwise STRING is returned
+verbatim.
+
+See `texsec-check' for further information about TYPE."
+  (let ((warning (textsec-check string type)))
+    (if (not wardning)
+        string
+      (propertize string
+                  'face 'textsec-suspicious
+                  'help-echo warning))))
 
 (provide 'textsec-check)
 
diff --git a/lisp/international/textsec.el b/lisp/international/textsec.el
index a7b9ed9f9b9..90c37bf2b3b 100644
--- a/lisp/international/textsec.el
+++ b/lisp/international/textsec.el
@@ -29,6 +29,7 @@
 (require 'idna-mapping)
 (require 'puny)
 (require 'mail-parse)
+(require 'url)
 
 (defvar textsec--char-scripts nil)
 
@@ -366,6 +367,13 @@ and `textsec-name-suspicious-p'."
        (textsec-email-address-suspicious-p  address)
        (and name (textsec-name-suspicious-p name))))))
 
+(defun textsec-url-suspicious-p (url)
+  "Say whether EMAIL looks suspicious.
+If it isn't, return nil.  If it is, return a string explaining the
+potential problem."
+  (let ((parsed (url-generic-parse-url url)))
+    (textsec-domain-suspicious-p (url-host parsed))))
+
 (provide 'textsec)
 
 ;;; textsec.el ends here
diff --git a/lisp/net/shr.el b/lisp/net/shr.el
index 7363874cf3c..3ace872474c 100644
--- a/lisp/net/shr.el
+++ b/lisp/net/shr.el
@@ -1467,7 +1467,12 @@ ones, in case fg and bg are nil."
                          (dom-attr dom 'name)))) ; Obsolete since HTML5.
       (push (cons id (point)) shr--link-targets))
     (when url
-      (shr-urlify (or shr-start start) (shr-expand-url url) title))))
+      (shr-urlify (or shr-start start) (shr-expand-url url) title)
+      (when-let ((warning (textsec-check (shr-expand-url url) 'url)))
+        (add-text-properties (or shr-start start) (point)
+                             (list 'help-echo warning
+                                   'face '(shr-link textsec-suspicious)))
+        (insert "⚠️")))))
 
 (defun shr-tag-abbr (dom)
   (let ((title (dom-attr dom 'title))
diff --git a/test/lisp/international/textsec-tests.el b/test/lisp/international/textsec-tests.el
index c6268d14c7d..c7cf56757cd 100644
--- a/test/lisp/international/textsec-tests.el
+++ b/test/lisp/international/textsec-tests.el
@@ -164,4 +164,8 @@
   (should (textsec-email-address-header-suspicious-p
            "דגבא <foo@bar.com>")))
 
+(ert-deftest test-suspicious-url ()
+  (should-not (textsec-url-suspicious-p "http://example.ru/bar"))
+  (should (textsec-url-suspicious-p "http://Сгсе.ru/bar")))
+
 ;;; textsec-tests.el ends here
-- 
2.39.2