- [fediverse] fixed RE to match a mention.

This changes is needed to prevent mention lookup code to find the wrong acct, as matching is based only from the username (that is the string on the left of the '@'). Two different acct can share the same username, so the old code returned the first acct the db provided matching the username, not necessarily the correct one.

  E.g.

  table mention
  username | acct
  ---------+----------
  foo      |  foo@bar
  foo      |  foo@baz

  looking for the first row that match "foo" → "foo@bar", but the post mentioned the "foo@baz"

  now the table has changed to;

  username |  acct      | status-id
  ---------+------------+----------
  foo      |  foo@bar   | 1
  foo      |  foo@baz   | 2

  search looks for the first row that match "foo" for the status-id = 1: the correct value is returned: 'foo@baz'.

  this changes is not a solution, for example in a table like this:

  username |  acct      | status-id
  ---------+------------+----------
  foo      |  foo@bar   | 1
  ---------+------------+----------
  foo      |  foo@bar   | 2
  ---------+------------+---------
  foo      |  foo@baz   | 2

  the same query as the one above can return the wrong row, containing "foo@bar"

- changed function name: 'html-utils:strip-footnote-reference' → 'html-utils:strip-footnote-reference-word'.

src/db.lisp

@@ -412,7 +412,7 @@
                            +make-close+)))
 
 (defun make-mention ()
-  (query-low-level (strcat (prepare-table +table-mention+)
+  (query-low-level (strcat (prepare-table +table-mention+ :integer-id-p t :autoincrementp t)
                            " username              TEXT    NOT NULL,"
                            ;; this is the actual user identification
                            " acct                  TEXT    NOT NULL,"
@@ -420,7 +420,7 @@
                            " url                   TEXT    NOT NULL,"
                            ;; local value, timestamp
                            " \"date-added\"        TEXT NOT NULL,"
-                           " UNIQUE(id) ON CONFLICT FAIL"
+                           " \"status-id\"         TEXT NOT NULL"
                            +make-close+)))
 
 (defun make-followed-user ()
@@ -1327,25 +1327,29 @@ than (swconf:config-purge-history-days-offset) days in the past"
                            +tag-separator+)
         "")))
 
-(defmethod update-db ((object tooter:mention) &key &allow-other-keys)
+(defmethod update-db ((object tooter:mention) &key (status-id nil) &allow-other-keys)
   (with-accessors ((id               tooter:id)
                    (username         tooter:username)
                    (account-name     tooter:account-name)
                    (url              tooter:url)) object
+    (assert status-id)
     (let ((actual-username (clean-chars username))
           (actual-acct     (clean-chars account-name))
           (now             (prepare-for-db (local-time-obj-now))))
-      (insert-or-update +table-mention+
-                        (:id
-                         :username
-                         :acct
-                         :url
-                         :date-added)
-                        (id
-                         actual-username
-                         actual-acct
-                         url
-                         now)))))
+      (when (not (mentioned-username->account actual-username
+                                              status-id
+                                              :add-mention-prefix nil))
+        (query (make-insert +table-mention+
+                            (:username
+                             :acct
+                             :url
+                             :date-added
+                             :status-id)
+                            (actual-username
+                             actual-acct
+                             url
+                             now
+                             status-id)))))))
 
 (defmethod update-db ((object tooter:status)
                       &key
@@ -1378,7 +1382,7 @@ than (swconf:config-purge-history-days-offset) days in the past"
                    (poll                   tooter:poll)
                    (mentions               tooter:mentions)) object
     (update-db account)
-    (mapcar #'update-db mentions)
+    (mapcar (lambda (a) (update-db a :status-id id)) mentions)
     (let* ((account-id          (tooter:id account))
            (actual-created-at   (decode-datetime-string created-at))
            (actual-application  (prepare-for-db application))
@@ -1924,11 +1928,12 @@ the message identified by the tuple."
             (cons (msg-utils:add-mention-prefix local-name)
                   (msg-utils:add-mention-prefix username))))))
 
-(defun mentioned-username->account (username &key (add-mention-prefix t))
+(defun mentioned-username->account (username status-id &key (add-mention-prefix t))
   "Returns an alist of all known accounts as ('@'local-username . '@'acct)."
   (let* ((query (select :acct
                   (from +table-mention+)
-                  (where (:= :username username))))
+                  (where (:and (:= :username username)
+                               (:= :status-id status-id)))))
          (acct  (second (fetch-single query))))
     (if add-mention-prefix
         (msg-utils:add-mention-prefix acct)

src/html-utils.lisp

@@ -135,15 +135,19 @@
 
 (defun footnote-reference-re (&key (enforce-end-string t))
   (format nil
-          "~a[~a]+~@[$~]"
+          "(~a[~a]+)~@[$~]"
           #\ZERO_WIDTH_SPACE
           +digits-superscripts+
           enforce-end-string))
 
 (let ((scanner (cl-ppcre:create-scanner (footnote-reference-re))))
-  (defun strip-footnote-reference (word)
+  (defun strip-footnote-reference-word (word)
     (cl-ppcre:regex-replace scanner word "")))
 
+(let ((scanner (cl-ppcre:create-scanner (footnote-reference-re :enforce-end-string nil))))
+  (defun strip-all-footnote-reference (string)
+    (cl-ppcre:regex-replace-all scanner string "")))
+
 (defun block-tag-p (node)
   (and (consp node)
        (member node

src/message-rendering-utils.lisp

@@ -40,12 +40,13 @@
   (let ((words                 (split-words message-line))
         (mention-prefix-length (length +mention-prefix+)))
     (mapcar (lambda (a)
-              (html-utils:strip-footnote-reference (subseq a mention-prefix-length))) ; remove the @
+              (html-utils:strip-footnote-reference-word (subseq a
+                                                                mention-prefix-length))) ; remove the #\@
             (remove-if-not (lambda (word)
                              (cl-ppcre:scan (strcat "^" +mention-prefix+) word))
                            words))))
 
-(defun usernames->usernames-table (message)
+(defun usernames->usernames-table (message status-id)
   "Returns a list of pairs ('@'username . '@'acct)."
   (let ((usernames '()))
     (loop for line in (split-lines message)
@@ -57,7 +58,7 @@
                                   usernames-in-line))))
     (mapcar (lambda (username)
               (cons (add-mention-prefix username)
-                    (db:mentioned-username->account username)))
+                    (db:mentioned-username->account username status-id)))
             usernames)))
 
 (defun local-mention->acct (text-line usernames-table)
@@ -73,8 +74,8 @@
                                          (strcat " " actual-mention)))))
     results))
 
-(defun expand-mention (text)
-  (let ((mentioned-users-table (usernames->usernames-table text)))
+(defun expand-mention (text status-id)
+  (let ((mentioned-users-table (usernames->usernames-table text status-id)))
     (with-output-to-string (stream)
       (loop for line in (text-utils:split-lines text) do
         (let ((line-fixed-mentions (local-mention->acct line mentioned-users-table)))

src/package.lisp

@@ -528,7 +528,8 @@
    :position-tag
    :node->link
    :append-footnote-reference
-   :strip-footnote-reference
+   :strip-footnote-reference-word
+   :strip-all-footnote-reference
    :footnote-reference-re
    :html->text))
 

src/program-events.lisp

@@ -2103,7 +2103,7 @@
                                 :direction         :output
                                 :if-exists         :supersede
                                 :if-does-not-exist :create)
-          (let ((mentioned-users-text (msg-utils:expand-mention text)))
+          (let ((mentioned-users-text (msg-utils:expand-mention text status-id)))
             (write-sequence mentioned-users-text stream)))
         (croatoan:end-screen)
         (tui:with-notify-errors

src/ui-goodies.lisp

@@ -1383,7 +1383,9 @@ It an existing file path is provided the command will refuse to run."
                ;; in db (folder, timeline).
                (when-let* ((message        (db:find-message-id reply-id))
                            (reply-username (db:row-message-username message))
-                           (rendered-text  (db:row-message-rendered-text message))
+                           (content        (db:row-message-content message))
+                           (rendered-text  (msg-utils:message-original->text-body content
+                                                                                  :add-link-footnotes nil))
                            (lines          (split-lines rendered-text))
                            (quote-mark     (swconf:quote-char))
                            (quoted-text    (strcat quote-mark
@@ -1397,7 +1399,8 @@ It an existing file path is provided the command will refuse to run."
                                   :direction    :output
                                   :element-type 'character)
                    (format stream "~a~%" (msg-utils:add-mention-prefix reply-username))
-                   (let ((mentioned-users-text (msg-utils:expand-mention quoted-text)))
+                   (let ((mentioned-users-text (msg-utils:expand-mention quoted-text
+                                                                         reply-id)))
                      (write-sequence mentioned-users-text stream))))))
            (add-signature (file)
              (when-let ((signature (message-rendering-utils:signature)))