procyberian/emacs
1
0
Fork 0
Code Issues Pull requests Projects Releases Packages Wiki Activity Actions

Expand textsec-link-suspicious-p checking

Browse source 
* lisp/international/textsec.el (textsec-link-suspicious-p): Check
the text more thoroughly for link-like things.
This commit is contained in:
Lars Ingebrigtsen 2022-01-20 07:57:13 +01:00
parent 7e7974154b
commit f9f12086fb
2 changed files with 35 additions and 17 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

44
lisp/international/textsec.el
View file

@ -389,22 +389,34 @@ 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)))))
(let* ((url (car link))
(text (string-trim (cdr link)))
(text-bits (seq-filter (lambda (bit)
(string-match-p "\\`[^.]+\\.[^.]+.*\\'" bit))
(split-string text))))
(when text-bits
(setq text-bits (seq-map (lambda (string)
(if (not (string-match-p "\\`[^:]+:" string))
(concat "http://" string)
string))
text-bits)))
(catch 'found
(dolist (text (or text-bits (list text)))
(let ((udomain (url-host (url-generic-parse-url url)))
(tdomain (url-host (url-generic-parse-url text))))
(cond
((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)))))
(throw 'found
(format "Text `%s' doesn't point to link URL `%s'"
text url)))))))))
(provide 'textsec)

8
test/lisp/international/textsec-tests.el
View file

@ -189,6 +189,12 @@
(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"))))
(cons "https://www.gnu.org/" "fsf.org")))
(should (textsec-link-suspicious-p
(cons "https://www.gnu.org/"
"This is a link that doesn't point to fsf.org")))
)
;;; textsec-tests.el ends here