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.

diff --git a/lisp/international/textsec-check.el b/lisp/international/textsec-check.el
index ff1b985d93af1c70ba779b37b746e6307e217840..464845d5b63485940019183c1204ff9f38d5b04c 100644 (file)
--- 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 a7b9ed9f9b9b1c98cf6f9f1f21bac7ad489b6da9..90c37bf2b3bc2195c034b4760f28fc5ab6ba6a15 100644 (file)
--- 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 7363874cf3cf4f5e554ef3b8d804c2e12c7d231a..3ace872474cf96615f133b339185fd8c99edf982 100644 (file)
--- 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 c6268d14c7d1a91eb420e419ea889f30b0a5c619..c7cf56757cd34b09f11a30dbc886b70278781bea 100644 (file)
--- 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