diff --git a/src/db.lisp b/src/db.lisp index 42756aa..6d7d6d0 100644 --- a/src/db.lisp +++ b/src/db.lisp @@ -1459,6 +1459,30 @@ forms a messages thread" node))) (add-children results)))) +(defun message->thread-users (timeline folder status-id + &key + (names-as-mention t)) + "Given a tuple that identify a message (`timeline' `folder' `status-id'), +returns an alist of (local-username . acct). + +if `names-as-mention' is non nil prepends '@' to the names." + (let ((all-messages (mtree:collect-nodes-data (message-id->tree timeline folder status-id))) + (results ())) + (loop for message in all-messages do + (let* ((user-id (db-getf message :account-id)) + (account (user-id->user user-id)) + (local-name (db-getf account :username)) + (username (user-id->username user-id)) + (pair (if names-as-mention + (cons (msg-utils:add-mention-prefix local-name) + (msg-utils:add-mention-prefix username)) + (cons local-name username)))) + (pushnew pair results :test (lambda (a b) (and (string= (car a) + (car b)) + (string= (cdr a) + (cdr b))))))) + results)) + (defmacro gen-access-message-row (name column) "Convenience macro to generate function to access a value of a table row." diff --git a/src/message-rendering-utils.lisp b/src/message-rendering-utils.lisp index 10df7f6..3a49ed8 100644 --- a/src/message-rendering-utils.lisp +++ b/src/message-rendering-utils.lisp @@ -39,6 +39,22 @@ (when (mention-p first-mention) first-mention))))) +(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)) + (loop for pair in usernames-table do + (when-let* ((local-mention (car pair)) + (local-mention-re (strcat " " local-mention)) + (actual-mention (find-all-username 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) (subject sending-message:subject) diff --git a/src/mtree-utils.lisp b/src/mtree-utils.lisp index ea8a310..6fd63e3 100644 --- a/src/mtree-utils.lisp +++ b/src/mtree-utils.lisp @@ -154,6 +154,8 @@ (defgeneric count-nodes (object)) +(defgeneric collect-nodes-data (object)) + (defgeneric mtree-equal (tree-1 tree-2 &key key-fn compare-fn)) (defgeneric root-node (object)) @@ -429,6 +431,12 @@ (incf results))) results)) +(defmethod collect-nodes-data ((object m-tree)) + (let ((results ())) + (top-down-visit object #'(lambda (n) + (push (data n) results))) + results)) + (defmethod mtree-equal ((tree-1 m-tree) (tree-2 m-tree) &key (key-fn #'identity) diff --git a/src/package.lisp b/src/package.lisp index 8c5430e..54c0950 100644 --- a/src/package.lisp +++ b/src/package.lisp @@ -465,6 +465,7 @@ :find-child-if :count-leaves :count-nodes + :collect-nodes-data :mtree-equal :root-node :sorted-m-tree @@ -721,6 +722,7 @@ :message-root :message-children :message-root->tree + :message->thread-users :message-id->tree :message-from-timeline-folder-message-index :message-index->tree @@ -1620,6 +1622,7 @@ (:export :add-mention-prefix :strip-mention-prefix + :local-mention->acct :crypto-message-destination-user :maybe-crypt-message :attachment-type->description diff --git a/src/ui-goodies.lisp b/src/ui-goodies.lisp index 63fe71c..37c8f24 100644 --- a/src/ui-goodies.lisp +++ b/src/ui-goodies.lisp @@ -806,7 +806,7 @@ Force the checking for new message in the thread the selected message belong." exceeding) exceeding))) -(defun compose-message (&optional reply-id subject (visibility +status-public-visibility+)) +(defun compose-message (&optional timeline folder reply-id subject (visibility +status-public-visibility+)) "Compose a new message" (setf *message-to-send* (make-instance 'sending-message:message-ready-to-send :visibility visibility @@ -841,14 +841,20 @@ Force the checking for new message in the thread the selected message belong." (lines (split-lines quoted-text)) (quote-mark (swconf:quote-char)) (quoted-lines (mapcar (lambda (a) (strcat quote-mark a)) - lines))) + lines)) + (thread-users (db:message->thread-users timeline + folder + reply-id))) (with-open-file (stream file :if-exists :append :direction :output :element-type 'character) (format stream "~a~%" (msg-utils:add-mention-prefix reply-username)) (loop for line in quoted-lines do - (format stream "~a~%" line)))))) + (let ((line-fixed-mentions + (message-rendering-utils:local-mention->acct line + thread-users))) + (format stream "~a~%" line-fixed-mentions))))))) (add-signature (file) (when-let ((signature (message-rendering-utils:signature))) (with-open-file (stream @@ -877,11 +883,13 @@ Force the checking for new message in the thread the selected message belong." "Reply to message" (when-let* ((win specials:*thread-window*) (selected-message (line-oriented-window:selected-row-fields win)) + (timeline (thread-window:timeline-type win)) + (folder (thread-window:timeline-folder win)) (username (db:row-message-username selected-message)) (visibility (db:row-message-visibility selected-message)) (reply-id (db:row-message-status-id selected-message))) (let ((subject (db:row-message-subject selected-message))) - (compose-message reply-id subject visibility)))) + (compose-message timeline folder reply-id subject visibility)))) (defun send-message () "Send message"