mirror of https://codeberg.org/cage/tinmop/
- [fediverse] reworked mentions expansion's code to prevent missing mentions
(see c790da4407);
- changed function's name: 'mentioned-username->account' -> 'mentioned-username->acct'.
This commit is contained in:
cage
parent
e1fae66272
commit
316ad365e2
25
src/db.lisp
25
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)
|
||||
|
|
|
|||
|
|
@ -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)))
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
Loading…
Reference in New Issue