cage
/
tinmop
mirror of https://codeberg.org/cage/tinmop/
1
0
Fork 0
Code Issues

- [fediverse] reworked mention in messages.

This commit is contained in:
cage 2024-09-22 17:40:41 +02:00
parent ec2f480b25
commit b0f9466876
4 changed files with 91 additions and 40 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

56
src/db.lisp
View File

@ -80,6 +80,9 @@
(a:define-constant +table-account+ :account (a:define-constant +table-account+ :account
:test #'eq) :test #'eq)
(a:define-constant +table-mention+ :mention
:test #'eq)
(a:define-constant +table-poll-option+ :poll-option (a:define-constant +table-poll-option+ :poll-option
:test #'eq) :test #'eq)
@ -408,6 +411,16 @@
" UNIQUE(id) ON CONFLICT FAIL" " UNIQUE(id) ON CONFLICT FAIL"
+make-close+))) +make-close+)))
(defun make-mention ()
(query-low-level (strcat (prepare-table +table-mention+)
" username TEXT NOT NULL,"
;; this is the actual user identification
" acct TEXT NOT NULL,"
;; profile homepage
" url TEXT NOT NULL,"
" UNIQUE(id) ON CONFLICT FAIL"
+make-close+)))
(defun make-followed-user () (defun make-followed-user ()
(query-low-level (strcat (prepare-table +table-followed-user+ :integer-id-p t :autoincrementp t) (query-low-level (strcat (prepare-table +table-followed-user+ :integer-id-p t :autoincrementp t)
" \"user-id\" TEXT " " \"user-id\" TEXT "
@ -679,6 +692,7 @@
+table-input-history+ +table-input-history+
+table-status+ +table-status+
+table-account+ +table-account+
+table-mention+
+table-followed-user+ +table-followed-user+
+table-subscribed-tag+ +table-subscribed-tag+
+table-tag-histogram+ +table-tag-histogram+
@ -716,6 +730,7 @@
(make-input-history) (make-input-history)
(make-crypto-data) (make-crypto-data)
(make-account) (make-account)
(make-mention)
(make-followed-user) (make-followed-user)
(make-status) (make-status)
(make-ignored-status) (make-ignored-status)
@ -1302,6 +1317,25 @@ than (swconf:config-purge-history-days-offset) days in the past"
+tag-separator+) +tag-separator+)
""))) "")))
(defmethod update-db ((object tooter:mention) &key &allow-other-keys)
(with-accessors ((id tooter:id)
(username tooter:username)
(account-name tooter:account-name)
(url tooter:url)) object
(flet ((clean-chars (string)
(remove-corrupting-utf8-chars string)))
(let ((actual-username (clean-chars username))
(actual-acct (clean-chars account-name)))
(insert-or-update +table-mention+
(:id
:username
:acct
:url)
(id
actual-username
actual-acct
url))))))
(defmethod update-db ((object tooter:status) (defmethod update-db ((object tooter:status)
&key &key
(timeline +local-timeline+) (timeline +local-timeline+)
@ -1330,8 +1364,10 @@ than (swconf:config-purge-history-days-offset) days in the past"
(tags tooter:tags) (tags tooter:tags)
(application tooter:application) (application tooter:application)
(media-attachments tooter:media-attachments) (media-attachments tooter:media-attachments)
(poll tooter:poll)) object (poll tooter:poll)
(mentions tooter:mentions)) object
(update-db account) (update-db account)
(mapcar #'update-db mentions)
(let* ((account-id (tooter:id account)) (let* ((account-id (tooter:id account))
(actual-created-at (decode-datetime-string created-at)) (actual-created-at (decode-datetime-string created-at))
(actual-application (prepare-for-db application)) (actual-application (prepare-for-db application))
@ -1860,16 +1896,28 @@ the message identified by the tuple."
(cdr b))))))) (cdr b)))))))
results)) results))
(defun mention-local->global-alist () (defun all-mentioned-accounts ()
"Returns an alist of all known accounts as ('@'local-username . '@'acct)." "Returns an alist of all known accounts as ('@'local-username . '@'acct)."
(let* ((query (select (:username :acct) (from +table-account+))) (let* ((query (select (:username :acct) (from +table-mention+)))
(rows (fetch-all-rows query))) (rows (fetch-all-rows query)))
(loop for row in rows collect (loop for row in rows
collect
(let ((local-name (db-getf row :username)) (let ((local-name (db-getf row :username))
(username (db-getf row :acct))) (username (db-getf row :acct)))
(cons (msg-utils:add-mention-prefix local-name) (cons (msg-utils:add-mention-prefix local-name)
(msg-utils:add-mention-prefix username)))))) (msg-utils:add-mention-prefix username))))))
(defun mentioned-username->account (username &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))))
(rows (mapcar #'second
(fetch-all-rows query))))
(if add-mention-prefix
(mapcar #'msg-utils:add-mention-prefix rows)
rows)))
(defmacro gen-access-message-row (name column (defmacro gen-access-message-row (name column
&key &key
(default nil) (default nil)

43
src/message-rendering-utils.lisp
View File

@ -41,27 +41,36 @@
(when (mention-p first-mention) (when (mention-p first-mention)
first-mention))))) first-mention)))))
(defun line-find-all-usernames (message-line)
(let ((words (split-words message-line)))
(mapcar (lambda (a) (subseq a (length +mention-prefix+))) ; remove the @
(remove-if-not (lambda (word)
(cl-ppcre:scan (strcat "^" +mention-prefix+) word))
words))))
(defun usernames->usernames-table (message)
"Returns a list of pairs ('@'username . '@'acct)."
(let ((usernames '()))
(loop for line in (split-lines message)
do
(let ((usernames-in-line (line-find-all-usernames line)))
(setf usernames
(concatenate 'list
usernames
usernames-in-line))))
(mapcar (lambda (username)
(cons (add-mention-prefix username)
(db:mentioned-username->account username)))
usernames)))
(defun local-mention->acct (text-line usernames-table) (defun local-mention->acct (text-line usernames-table)
"Substitute in `text-line' '@user' with '@user@server', if '@user' "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'"
(flet ((find-all-username (key) (let ((results text-line))
(let ((found (mapcar #'cdr (loop for (local-mention . actual-mention) in usernames-table do
(remove-if-not (lambda (a) (string= (car a) key)) (let ((local-mention-re (strcat " " local-mention)))
usernames-table))))
(join-with-strings found ", "))))
(let ((results text-line)
(local-mention-prefix (strcat " " +mention-prefix+))
(local-mention-temp-prefix (strcat " " +temp-mention-prefix+)))
(setf results (regex-replace-all local-mention-prefix
results
local-mention-temp-prefix))
(loop for pair in usernames-table do
(when-let* ((local-mention (car pair))
(local-mention-re (strcat " " local-mention))
(actual-mention (strcat " "
(find-all-username local-mention))))
(setf results (regex-replace-all local-mention-re results actual-mention)))) (setf results (regex-replace-all local-mention-re results actual-mention))))
results))) results))
(defun crypto-message-destination-user (message-data) (defun crypto-message-destination-user (message-data)
(with-accessors ((body sending-message:body) (with-accessors ((body sending-message:body)

3
src/package.lisp
View File

@ -986,6 +986,8 @@
:message-children :message-children
:message-root->tree :message-root->tree
:message->thread-users :message->thread-users
:all-mentioned-accounts
:mentioned-username->account
:message-id->tree :message-id->tree
:message-from-timeline-folder-message-index :message-from-timeline-folder-message-index
:message-index->tree :message-index->tree
@ -2425,6 +2427,7 @@
(:export (:export
:+temp-mention-prefix+ :+temp-mention-prefix+
:add-mention-prefix :add-mention-prefix
:usernames->usernames-table
:strip-mention-prefix :strip-mention-prefix
:local-mention->acct :local-mention->acct
:crypto-message-destination-user :crypto-message-destination-user

19
src/ui-goodies.lisp
View File

@ -1350,7 +1350,7 @@ It an existing file path is provided the command will refuse to run."
exceeding) exceeding)
exceeding))) exceeding)))
(defun compose-message (&key timeline folder reply-id subject (visibility +status-public-visibility+) (message-header-text nil)) (defun compose-message (&key reply-id subject (visibility +status-public-visibility+) (message-header-text nil))
"Compose a new message" "Compose a new message"
(setf *message-to-send* (make-instance 'sending-message:message-ready-to-send (setf *message-to-send* (make-instance 'sending-message:message-ready-to-send
:visibility visibility :visibility visibility
@ -1386,13 +1386,8 @@ It an existing file path is provided the command will refuse to run."
(quote-mark (swconf:quote-char)) (quote-mark (swconf:quote-char))
(quoted-lines (mapcar (lambda (a) (strcat quote-mark a)) (quoted-lines (mapcar (lambda (a) (strcat quote-mark a))
lines)) lines))
(thread-users (db:message->thread-users timeline (mentioned-users-table
folder (message-rendering-utils:usernames->usernames-table quoted-text)))
reply-id
:local-name-prefix
message-rendering-utils:+temp-mention-prefix+
:acct-prefix
+mention-prefix+)))
(with-open-file (stream file (with-open-file (stream file
:if-exists :append :if-exists :append
:direction :output :direction :output
@ -1401,7 +1396,7 @@ It an existing file path is provided the command will refuse to run."
(loop for line in quoted-lines do (loop for line in quoted-lines do
(let ((line-fixed-mentions (let ((line-fixed-mentions
(message-rendering-utils:local-mention->acct line (message-rendering-utils:local-mention->acct line
thread-users))) mentioned-users-table)))
(format stream "~a~%" line-fixed-mentions))))))) (format stream "~a~%" line-fixed-mentions)))))))
(add-signature (file) (add-signature (file)
(when-let ((signature (message-rendering-utils:signature))) (when-let ((signature (message-rendering-utils:signature)))
@ -1488,15 +1483,11 @@ It an existing file path is provided the command will refuse to run."
(actual-message (if (db:row-message-reblog-id selected-message) (actual-message (if (db:row-message-reblog-id selected-message)
(db:find-message-id (db:row-message-reblog-id selected-message)) (db:find-message-id (db:row-message-reblog-id selected-message))
selected-message)) selected-message))
(timeline (db:row-message-timeline actual-message))
(folder (thread-window:timeline-folder win))
(username (db:row-message-username actual-message)) (username (db:row-message-username actual-message))
(visibility (db:row-message-visibility actual-message)) (visibility (db:row-message-visibility actual-message))
(reply-id (actual-author-message-id actual-message))) (reply-id (actual-author-message-id actual-message)))
(let* ((subject (db:row-message-subject actual-message))) (let* ((subject (db:row-message-subject actual-message)))
(compose-message :timeline timeline (compose-message :reply-id reply-id
:folder folder
:reply-id reply-id
:subject subject :subject subject
:visibility visibility)))) :visibility visibility))))