;;; textsec.el --- Functions for handling homoglyphs and the like  -*- lexical-binding: t; -*-

;; Copyright (C) 2022-2024 Free Software Foundation, Inc.

;; This file is part of GNU Emacs.

;; GNU Emacs is free software: you can redistribute it and/or modify
;; it under the terms of the GNU General Public License as published by
;; the Free Software Foundation, either version 3 of the License, or
;; (at your option) any later version.

;; GNU Emacs is distributed in the hope that it will be useful,
;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
;; GNU General Public License for more details.

;; You should have received a copy of the GNU General Public License
;; along with GNU Emacs.  If not, see <https://www.gnu.org/licenses/>.

;;; Commentary:

;;

;;; Code:

(require 'cl-lib)
(require 'uni-confusable)
(require 'ucs-normalize)
(require 'idna-mapping)
(require 'puny)
(require 'mail-parse)
(require 'url)

(defvar textsec--char-scripts nil)

(eval-and-compile
  (defun textsec--create-script-table (data)
    "Create the textsec--char-scripts char table."
    (setq textsec--char-scripts (make-char-table nil))
    (dolist (scripts data)
      (dolist (range (cadr scripts))
        (set-char-table-range textsec--char-scripts
                              range (car scripts)))))
  (require 'uni-scripts))

(defun textsec-scripts (string)
  "Return a list of Unicode scripts used by characters in STRING.
The return value is a list where for each character in STRING,
there is a list of script symbols for that character.  Thus, each
script's symbol can appear more than once; use `textsec-covering-scripts'
to obtain a list in which each script appears at most once.
The script symbols returned by this function follow the Unicode Script
property of characters as defined by the Unicode Standard Annex 24 (UAX#24).
See the Unicode UCD file Scripts.txt for the scripts defined by Unicode."
  (seq-map (lambda (char)
             (elt textsec--char-scripts char))
           string))

(defun textsec-single-script-p (string)
  "Return non-nil if STRING's characters belong to a single Unicode script.

Note that the concept of \"single script\" used by this function
isn't obvious -- some mixtures of scripts count as a \"single
script\".  See

  https://www.unicode.org/reports/tr39/#Mixed_Script_Detection

for details.  The Unicode script property of a characters is defined by
the Unicode Standard Annex 24 (UAX#24)."
  (let ((scripts (mapcar
                  (lambda (s)
                    (append s
                            ;; Some scripts used in East Asia are
                            ;; commonly used across borders, so we add
                            ;; those.
                            (mapcan (lambda (script)
                                      (copy-sequence
                                       (textsec--augment-script script)))
                                    s)))
                         (textsec-scripts string))))
    (catch 'empty
      (cl-loop for s1 in scripts
               do (cl-loop for s2 in scripts
                           ;; Common/inherited chars can be used in
                           ;; text with all scripts.
                           when (and (not (memq 'common s1))
                                     (not (memq 'common s2))
                                     (not (memq 'inherited s1))
                                     (not (memq 'inherited s2))
                                     (not (seq-intersection s1 s2)))
                           do (throw 'empty nil)))
      t)))

(defun textsec--augment-script (script)
  (cond
   ((eq script 'han)
    '(hangul japan korea))
   ((or (eq script 'hiragana)
        (eq script 'katakana))
    '(japan))
   ((or (eq script 'hangul)
        (eq script 'bopomofo))
    '(korea))))

(defun textsec-covering-scripts (string)
  "Return a minimal list of scripts used by characters in STRING.
Note that a string may have several different minimal cover sets.
The return value is a list of script symbols.
The script property of characters is defined by the Unicode Standard
Annex 24 (UAX#24)."
  (let* ((scripts (textsec-scripts string))
         (set (car scripts)))
    (dolist (s scripts)
      (setq set (seq-union set (seq-difference s set))))
    (sort (delq 'common (delq 'inherited set)) #'string<)))

(defun textsec-restriction-level (string)
  "Return the restriction level for which STRING qualifies.
The return value is a symbol.
Levels are (in decreasing order of restrictiveness) `ascii-only',
`single-script', `highly-restrictive', `moderately-restrictive',
`minimally-restrictive' and `unrestricted'."
  (let ((scripts (textsec-covering-scripts string)))
  (cond
   ((string-match "\\`[[:ascii:]]+\\'" string)
    'ascii-only)
   ((textsec-single-script-p string)
    'single-script)
   ((or (null (seq-difference scripts '(latin han hiragana katakana)))
        (null (seq-difference scripts '(latin han bopomofo)))
        (null (seq-difference scripts '(latin han hangul))))
    'highly-restrictive)
   ((and (= (length scripts) 2)
         (memq 'latin scripts)
         ;; This list comes from
         ;; https://www.unicode.org/reports/tr31/#Table_Recommended_Scripts
         ;; (but without latin, cyrillic and greek).
         (seq-intersection scripts
                           '(arabic
                             armenian
                             bengali
                             bopomofo
                             devanagari
                             ethiopic
                             georgian
                             gujarati
                             gurmukhi
                             hangul
                             han
                             hebrew
                             hiragana
                             katakana
                             kannada
                             khmer
                             lao
                             malayalam
                             myanmar
                             oriya
                             sinhala
                             tamil
                             telugu
                             thaana
                             thai
                             tibetan)))
    ;; The string is covered by Latin and any one other Recommended
    ;; script, except Cyrillic, Greek.
    'moderately-restrictive)
   ;; Fixme `minimally-restrictive' -- needs well-formedness criteria
   ;; and Identifier Profile.
   (t
    'unrestricted))))

(defun textsec-mixed-numbers-p (string)
  "Return non-nil if STRING includes numbers from different decimal systems.

This function examines only characters in STRING whose Unicode general
category, as reported by `get-char-code-property' with its second
argument \\='general-category, is Decimal_Numbers (Nd).  It returns
non-nil if it finds numerical characters from different numerical
systems.  For example, ASCII digit characters and ARABIC-INDIC DIGIT
characters belong to different decimal systems."
  (>
   (length
    (seq-uniq
     (mapcar
      (lambda (char)
        ;; Compare zeros in the respective decimal systems.
        (- char (get-char-code-property char 'numeric-value)))
      (seq-filter (lambda (char)
                    ;; We're selecting the characters that
                    ;; have a numeric property.
                    (eq (get-char-code-property char 'general-category)
                        'Nd))
                  string))))
   1))

(defun textsec-ascii-confusable-p (string)
  "Return non-nil if non-ASCII STRING can be confused with ASCII on display."
  (and (not (eq (textsec-restriction-level string) 'ascii-only))
       (eq (textsec-restriction-level (textsec-unconfuse-string string))
           'ascii-only)))

(defun textsec-unconfuse-string (string)
  "Return a de-confused version of STRING.
This algorithm is described in:

  https://www.unicode.org/reports/tr39/#Confusable_Detection"
  (ucs-normalize-NFD-string
   (apply #'concat
          (seq-map (lambda (char)
                     (or (gethash char uni-confusable-table)
                         (string char)))
                   (ucs-normalize-NFD-string string)))))

(defun textsec-resolved-script-set (string)
  "Return the resolved script set for STRING.
The value is a list whose members are symbols of the minimal covering
script set for STRING; the value is nil if STRING isn't a single-script
string.
The script property of characters is defined by the Unicode Standard
Annex 24 (UAX#24)."
  (and (textsec-single-script-p string)
       (textsec-covering-scripts string)))

(defun textsec-single-script-confusable-p (string1 string2)
  "Say whether STRING1 and STRING2 are single-script confusables.
Two strings are said to be confusables if they might look very
similarly on display.
The script property of characters is defined by the Unicode Standard
Annex 24 (UAX#24)."
  (and (equal (textsec-unconfuse-string string1)
              (textsec-unconfuse-string string2))
       ;; And they have to have at least one resolved script in
       ;; common.
       (seq-intersection (textsec-resolved-script-set string1)
                         (textsec-resolved-script-set string2))))

(defun textsec-mixed-script-confusable-p (string1 string2)
  "Say whether STRING1 and STRING2 are mixed-script confusables.
Two strings are said to be confusables if they might look very
similarly on display.
The script property of characters is defined by the Unicode Standard
Annex 24 (UAX#24)."
  (and (equal (textsec-unconfuse-string string1)
              (textsec-unconfuse-string string2))
       ;; And they have no resolved scripts in common.
       (null (seq-intersection (textsec-resolved-script-set string1)
                               (textsec-resolved-script-set string2)))))

(defun textsec-whole-script-confusable-p (string1 string2)
  "Say whether two single-script strings STRING1 and STRING2 are confusables.
Two strings are said to be confusables if they might look very
similarly on display.
The script property of characters is defined by the Unicode Standard
Annex 24 (UAX#24)."
  (and (textsec-mixed-script-confusable-p string1 string2)
       (textsec-single-script-p string1)
       (textsec-single-script-p string2)))

(defun textsec--ipvx-address-p (domain)
  "Return non-nil if DOMAIN is an ipv4 or ipv6 address."
  ;; This is a very relaxed pattern for IPv4 or IPv6 addresses.  The
  ;; assumption is that any malformed address accepted by this rule
  ;; will be rejected by the actual address parser eventually.
  (let ((case-fold-search t))
    (rx-let ((ipv4 (** 1 4
                       (** 1 3 (in "0-9"))
                       (? ".")))
             (ipv6 (: (** 1 7
                          (** 0 4 (in "0-9a-f"))
                          ":")
                      (** 0 4 (in "0-9a-f"))
                      (? ":" ipv4))))
      (string-match-p (rx bos (or ipv4 ipv6 (: "[" ipv6 "]")) eos) domain))))

(defun textsec-domain-suspicious-p (domain)
  "Say whether DOMAIN's name looks suspicious.
Return nil if it isn't suspicious.  If it is, return a string explaining
the potential problem.

Domain names are considered suspicious if they use characters
that can look similar to other characters when displayed, or
use characters that are not allowed by Unicode's IDNA mapping,
or use certain other unusual mixtures of characters."
  (catch 'found
    ;; Plain domains aren't suspicious.
    (when (textsec--ipvx-address-p domain)
      (throw 'found nil))
    (seq-do
     (lambda (char)
       (when (eq (elt idna-mapping-table char) t)
         (throw 'found
                (format "Disallowed character%s (#x%x, %s)"
                        (if (eq (get-char-code-property char 'general-category)
                                'Cf)
                            ""
                          (concat ": " (string char)))
                        char
                        (char-to-name char)))))
     domain)
    ;; Does IDNA allow it?
    (unless (puny-highly-restrictive-domain-p domain)
      (throw
       'found
       (format "`%s' mixes characters from different scripts in suspicious ways"
               domain)))
    ;; Check whether any segment of the domain name is confusable with
    ;; an ASCII-only segment.
    (dolist (elem (split-string domain "\\."))
      (when (textsec-ascii-confusable-p elem)
        (throw 'found (format "`%s' is confusable with ASCII" elem))))
    nil))

(defun textsec-local-address-suspicious-p (local)
  "Say whether LOCAL part of an email address looks suspicious.
LOCAL is the part before \"@\" in an email address, a string.

If it isn't suspicious, return nil.  If it is, return a string explaining
the potential problem.

Email addresses are considered suspicious if they use characters
that can look similar to other characters when displayed, or use
certain other unusual mixtures of characters."
  (cond
   ((not (equal local (ucs-normalize-NFKC-string local)))
    (format "`%s' is not in normalized format `%s'"
            local (ucs-normalize-NFKC-string local)))
   ((textsec-mixed-numbers-p local)
    (format "`%s' contains numbers from different number systems" local))
   ((eq (textsec-restriction-level local) 'unrestricted)
    (format "`%s' isn't restrictive enough" local))
   ((string-match-p "\\`\\.\\|\\.\\'\\|\\.\\." local)
    (format "`%s' contains invalid dots" local))))

(defun textsec-bidi-controls-suspicious-p (string)
  "Return non-nil of STRING uses bidirectional controls in suspicious ways.
If STRING doesn't include any suspicious uses of bidirectional
formatting control characters, return nil.  Otherwise, return the
index of the first character in STRING affected by such suspicious
use of bidi controls.  If the returned value is beyond the length
of STRING, it means any text following STRING on display might be
affected by bidi controls in STRING."
  (with-temp-buffer
    ;; We follow STRING with text that's representative of some text
    ;; that could follow it, with the purpose of detecting residual bidi
    ;; state at end of STRING which could then affect the following
    ;; text.
    (insert string "a1א:!")
    (let ((pos (bidi-find-overridden-directionality
                (point-min) (point-max) nil)))
      (and (fixnump pos)
           (1- pos)))))

(defun textsec-name-suspicious-p (name)
  "Say whether NAME looks suspicious.
NAME is a string, for instance, the free-text display name part
of an email address.

If it isn't suspicious, return nil.  If it is, return a string
explaining the potential problem.

Names are considered suspicious if they use characters that can
look similar to other characters when displayed, or use certain
other unusual mixtures of characters."
  (cond
   ((not (equal name (ucs-normalize-NFC-string name)))
    (format "`%s' is not in normalized format `%s'"
            name (ucs-normalize-NFC-string name)))
   ((and (seq-find (lambda (char)
                     (and (member char bidi-control-characters)
                          (not (member char
                                       '( ?\N{left-to-right mark}
                                          ?\N{right-to-left mark}
                                          ?\N{arabic letter mark})))))
                   name)
         ;; We have bidirectional formatting characters, but check
         ;; whether they affect any other characters in suspicious
         ;; ways.  If not, NAME is not suspicious.
         (fixnump (textsec-bidi-controls-suspicious-p name)))
    (format "`%s' contains suspicious uses of bidirectional control characters"
            name))
   ((textsec-suspicious-nonspacing-p name))))

(defun textsec-suspicious-nonspacing-p (string)
  "Say whether STRING uses nonspacing characters in suspicious ways.
If it doesn't, return nil.  If it does, return a string explaining
the potential problem.

Nonspacing characters are those whose general Unicode category is
Mn (nonspacing mark) or Me (enclosing mark).  Examples include
diacritics and accents.

Use of nonspacing characters is considered suspicious if there are
two or more consecutive identical nonspacing characters, or too many
consecutive nonspacing characters."
  (let ((prev nil)
        (nonspace-count 0))
    (catch 'found
      (seq-do
       (lambda (char)
         (let ((nonspacing
                (memq (get-char-code-property char 'general-category)
                      '(Mn Me))))
           (when (and nonspacing
                      (equal char prev))
             (throw 'found "Two identical consecutive nonspacing characters"))
           (setq nonspace-count (if nonspacing
                                    (1+ nonspace-count)
                                  0))
           (when (> nonspace-count 4)
             (throw 'found
                    "Too many consecutive nonspacing characters"))
           (setq prev char)))
       string)
      nil)))

(defun textsec-email-address-suspicious-p (address)
  "Say whether email ADDRESS looks suspicious.
If it isn't, return nil.  If it is, return a string explaining the
potential problem.

ADDRESS should be a string that specifies an email address.
An email address is considered suspicious if either of its two
parts -- the local address name or the domain -- are found to be
suspicious by, respectively, `textsec-local-address-suspicious-p'
and `textsec-domain-suspicious-p'."
  (pcase-let ((`(,local ,domain) (split-string address "@")))
    (or
     (if domain (textsec-domain-suspicious-p domain))
     (textsec-local-address-suspicious-p local))))

(defun textsec-email-address-header-suspicious-p (email)
  "Say whether EMAIL address specification looks suspicious.
If it isn't, return nil.  If it is, return a string explaining the
potential problem.

Note that EMAIL has to be a valid email specification according
to RFC2047bis -- strings that can't be parsed will be flagged as
suspicious.

An email specification is considered suspicious if either of its
two parts -- the address or the name -- are found to be
suspicious by, respectively, `textsec-email-address-suspicious-p'
and `textsec-name-suspicious-p'."
  (catch 'end
    (pcase-let ((`(,address . ,name)
                 (condition-case nil
                     (mail-header-parse-address email t)
                   (error (throw 'end "Email address can't be parsed.")))))
      (or
       (and address (textsec-email-address-suspicious-p address))
       (and name (textsec-name-suspicious-p name))))))

(defun textsec-url-suspicious-p (url)
  "Say whether URL 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)))
    ;; The URL may not have a domain.
    (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))))
    (catch 'found
      (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)))
         ((and tdomain
               (textsec-domain-suspicious-p tdomain))
          (throw 'found
                 (format "Domain `%s' in the link text is suspicious"
                         (bidi-string-strip-control-characters
                          tdomain)))))))))

(provide 'textsec)

;;; textsec.el ends here