diff --git a/src/db.lisp b/src/db.lisp index c3f79cd..bf744a8 100644 --- a/src/db.lisp +++ b/src/db.lisp @@ -80,6 +80,9 @@ (a:define-constant +table-account+ :account :test #'eq) +(a:define-constant +table-mention+ :mention + :test #'eq) + (a:define-constant +table-poll-option+ :poll-option :test #'eq) @@ -408,6 +411,16 @@ " UNIQUE(id) ON CONFLICT FAIL" +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 () (query-low-level (strcat (prepare-table +table-followed-user+ :integer-id-p t :autoincrementp t) " \"user-id\" TEXT " @@ -679,6 +692,7 @@ +table-input-history+ +table-status+ +table-account+ + +table-mention+ +table-followed-user+ +table-subscribed-tag+ +table-tag-histogram+ @@ -716,6 +730,7 @@ (make-input-history) (make-crypto-data) (make-account) + (make-mention) (make-followed-user) (make-status) (make-ignored-status) @@ -1302,6 +1317,25 @@ than (swconf:config-purge-history-days-offset) days in the past" +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) &key (timeline +local-timeline+) @@ -1330,8 +1364,10 @@ than (swconf:config-purge-history-days-offset) days in the past" (tags tooter:tags) (application tooter:application) (media-attachments tooter:media-attachments) - (poll tooter:poll)) object + (poll tooter:poll) + (mentions tooter:mentions)) object (update-db account) + (mapcar #'update-db mentions) (let* ((account-id (tooter:id account)) (actual-created-at (decode-datetime-string created-at)) (actual-application (prepare-for-db application)) @@ -1860,15 +1896,27 @@ the message identified by the tuple." (cdr b))))))) results)) -(defun mention-local->global-alist () +(defun all-mentioned-accounts () "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))) - (loop for row in rows collect - (let ((local-name (db-getf row :username)) - (username (db-getf row :acct))) - (cons (msg-utils:add-mention-prefix local-name) - (msg-utils:add-mention-prefix username)))))) + (loop for row in rows + collect + (let ((local-name (db-getf row :username)) + (username (db-getf row :acct))) + (cons (msg-utils:add-mention-prefix local-name) + (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 &key diff --git a/src/message-rendering-utils.lisp b/src/message-rendering-utils.lisp index e6d8915..93360f4 100644 --- a/src/message-rendering-utils.lisp +++ b/src/message-rendering-utils.lisp @@ -41,27 +41,36 @@ (when (mention-p 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) "Substitute in `text-line' '@user' with '@user@server', if '@user' is found as key in the alist `usernames-table'" - (flet ((find-all-username (key) - (let ((found (mapcar #'cdr - (remove-if-not (lambda (a) (string= (car a) key)) - 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)))) - results))) + (let ((results text-line)) + (loop for (local-mention . actual-mention) in usernames-table do + (let ((local-mention-re (strcat " " local-mention))) + (setf results (regex-replace-all local-mention-re results actual-mention)))) + results)) (defun crypto-message-destination-user (message-data) (with-accessors ((body sending-message:body) diff --git a/src/package.lisp b/src/package.lisp index 7f4c590..0929f14 100644 --- a/src/package.lisp +++ b/src/package.lisp @@ -986,6 +986,8 @@ :message-children :message-root->tree :message->thread-users + :all-mentioned-accounts + :mentioned-username->account :message-id->tree :message-from-timeline-folder-message-index :message-index->tree @@ -2425,6 +2427,7 @@ (:export :+temp-mention-prefix+ :add-mention-prefix + :usernames->usernames-table :strip-mention-prefix :local-mention->acct :crypto-message-destination-user diff --git a/src/ui-goodies.lisp b/src/ui-goodies.lisp index 2e2c52c..cdf54cf 100644 --- a/src/ui-goodies.lisp +++ b/src/ui-goodies.lisp @@ -1350,7 +1350,7 @@ It an existing file path is provided the command will refuse to run." 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" (setf *message-to-send* (make-instance 'sending-message:message-ready-to-send :visibility visibility @@ -1386,13 +1386,8 @@ It an existing file path is provided the command will refuse to run." (quote-mark (swconf:quote-char)) (quoted-lines (mapcar (lambda (a) (strcat quote-mark a)) lines)) - (thread-users (db:message->thread-users timeline - folder - reply-id - :local-name-prefix - message-rendering-utils:+temp-mention-prefix+ - :acct-prefix - +mention-prefix+))) + (mentioned-users-table + (message-rendering-utils:usernames->usernames-table quoted-text))) (with-open-file (stream file :if-exists :append :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 (let ((line-fixed-mentions (message-rendering-utils:local-mention->acct line - thread-users))) + mentioned-users-table))) (format stream "~a~%" line-fixed-mentions))))))) (add-signature (file) (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) (db:find-message-id (db:row-message-reblog-id selected-message)) selected-message)) - (timeline (db:row-message-timeline actual-message)) - (folder (thread-window:timeline-folder win)) (username (db:row-message-username actual-message)) (visibility (db:row-message-visibility actual-message)) (reply-id (actual-author-message-id actual-message))) (let* ((subject (db:row-message-subject actual-message))) - (compose-message :timeline timeline - :folder folder - :reply-id reply-id + (compose-message :reply-id reply-id :subject subject :visibility visibility))))