From 316ad365e255928a18c20b2a0d5b0c778b0b0565 Mon Sep 17 00:00:00 2001 From: cage Date: Sun, 10 Nov 2024 14:30:14 +0100 Subject: [PATCH] - [fediverse] reworked mentions expansion's code to prevent missing mentions (see c790da44079c803a7d5d4f22db5450458f644515); - changed function's name: 'mentioned-username->account' -> 'mentioned-username->acct'. --- src/db.lisp | 25 ++++++++----- src/message-rendering-utils.lisp | 61 +++++++++++++++++++++++++------- src/package.lisp | 2 +- 3 files changed, 67 insertions(+), 21 deletions(-) diff --git a/src/db.lisp b/src/db.lisp index 1e28834..62795d7 100644 --- a/src/db.lisp +++ b/src/db.lisp @@ -1336,9 +1336,9 @@ than (swconf:config-purge-history-days-offset) days in the past" (let ((actual-username (clean-chars username)) (actual-acct (clean-chars account-name)) (now (prepare-for-db (local-time-obj-now)))) - (when (not (mentioned-username->account actual-username - status-id - :add-mention-prefix nil)) + (when (not (mentioned-username->acct actual-username + status-id + :add-mention-prefix nil)) (query (make-insert +table-mention+ (:username :acct @@ -1928,12 +1928,21 @@ 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 status-id &key (add-mention-prefix t)) +(defun mentioned-username->acct (username status-id + &key + (add-mention-prefix t) + (ignored-acct-list '())) "Returns an alist of all known accounts as ('@'local-username . '@'acct)." - (let* ((query (select :acct - (from +table-mention+) - (where (:and (:= :username username) - (:= :status-id status-id))))) + (let* ((query (if ignored-acct-list + (select :acct + (from +table-mention+) + (where (:and (:= :username username) + (:= :status-id status-id) + (:not (:in :acct ignored-acct-list))))) + (select :acct + (from +table-mention+) + (where (:and (:= :username username) + (:= :status-id status-id)))))) (acct (second (fetch-single query)))) (if add-mention-prefix (msg-utils:add-mention-prefix acct) diff --git a/src/message-rendering-utils.lisp b/src/message-rendering-utils.lisp index 8ed42ae..eb09245 100644 --- a/src/message-rendering-utils.lisp +++ b/src/message-rendering-utils.lisp @@ -47,7 +47,14 @@ words)))) (defun usernames->usernames-table (message status-id) - "Returns a list of pairs ('@'username . '@'acct)." + "Returns a list of pairs (\"'@'username\" . \"'@'acct\"). + +Please note that this table is not a map as the same username can be +followed by different acct e.g.: + +((\"@foo\" . \"@foo@bar\") + (\"@foo\" . \"@foo@baz\")) +" (let ((usernames '())) (loop for line in (split-lines message) do @@ -56,23 +63,53 @@ (concatenate 'list usernames usernames-in-line)))) - (mapcar (lambda (username) - (cons (add-mention-prefix username) - (db:mentioned-username->account username status-id))) - usernames))) + (let ((already-found-acct '())) + (mapcar (lambda (username) + (let ((acct (db:mentioned-username->acct username + status-id + :add-mention-prefix nil + :ignored-acct-list already-found-acct))) + (prog1 + (cons (add-mention-prefix username) + (add-mention-prefix acct)) + (push acct already-found-acct)))) + usernames)))) -(defun local-mention->acct (text-line usernames-table) +(defun local-mention->acct (text-line usernames-table + &optional (replace-function #'cl-ppcre:regex-replace)) "Substitute in `text-line' '@user' with '@user@server', if '@user' - is found as key in the alist `usernames-table'" + is found as key in the alist `usernames-table' note that `usernames-table' is not a map see: `usernames->usernames-table'." (let ((results text-line)) (loop for (local-mention . actual-mention) in usernames-table do (let ((local-mention-re (strcat "(\\s|^)" local-mention - (html-utils:footnote-reference-re :enforce-end-string nil)))) - (setf results (regex-replace-all local-mention-re - results - (strcat " " actual-mention))))) - results)) + "(\\s|$)"))) + (multiple-value-bind (replaced matched) + (funcall replace-function + local-mention-re + results + (strcat " " actual-mention)) + (setf results replaced)))) + ;; NOTE: as `usernames-table' is not a map some mention can not be + ;; replaced properly e.g. + ;; + ;; let 'usernames-table': + ;; + ;; ((\"@foo\" . \"@foo@bar\") + ;; (\"@foo\" . \"@foo@baz\")) + ;; + ;; and line 'line': + ;; + ;; "@foo @foo @foo @foo" + ;; + ;; the heuristic here will replace the first occurence of "@foo" + ;; with the cdr of the first element of the map, the second with + ;; the cdr of the second and so on; any other occurence will be + ;; replaced with the cdr of the first '@foo' in the map. Not + ;; optimal but no mentions should be missed this way. + (if (eq replace-function #'cl-ppcre:regex-replace) + (local-mention->acct results usernames-table #'cl-ppcre:regex-replace-all) + results))) (defun expand-mention (text status-id) (let ((mentioned-users-table (usernames->usernames-table text status-id))) diff --git a/src/package.lisp b/src/package.lisp index 3d67657..8a09650 100644 --- a/src/package.lisp +++ b/src/package.lisp @@ -997,7 +997,7 @@ :message-root->tree :message->thread-users :all-mentioned-accounts - :mentioned-username->account + :mentioned-username->acct :message-id->tree :message-from-timeline-folder-message-index :message-index->tree