mirror of
https://codeberg.org/cage/tinmop/
synced 2025-01-30 04:14:47 +01:00
- tried to fix mentioning of non local user in reply.
This commit is contained in:
parent
c27f36696d
commit
7b48939deb
24
src/db.lisp
24
src/db.lisp
@ -1459,6 +1459,30 @@ forms a messages thread"
|
|||||||
node)))
|
node)))
|
||||||
(add-children results))))
|
(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)
|
(defmacro gen-access-message-row (name column)
|
||||||
"Convenience macro to generate function to access a value of a table
|
"Convenience macro to generate function to access a value of a table
|
||||||
row."
|
row."
|
||||||
|
@ -39,6 +39,22 @@
|
|||||||
(when (mention-p first-mention)
|
(when (mention-p first-mention)
|
||||||
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)
|
(defun crypto-message-destination-user (message-data)
|
||||||
(with-accessors ((body sending-message:body)
|
(with-accessors ((body sending-message:body)
|
||||||
(subject sending-message:subject)
|
(subject sending-message:subject)
|
||||||
|
@ -154,6 +154,8 @@
|
|||||||
|
|
||||||
(defgeneric count-nodes (object))
|
(defgeneric count-nodes (object))
|
||||||
|
|
||||||
|
(defgeneric collect-nodes-data (object))
|
||||||
|
|
||||||
(defgeneric mtree-equal (tree-1 tree-2 &key key-fn compare-fn))
|
(defgeneric mtree-equal (tree-1 tree-2 &key key-fn compare-fn))
|
||||||
|
|
||||||
(defgeneric root-node (object))
|
(defgeneric root-node (object))
|
||||||
@ -429,6 +431,12 @@
|
|||||||
(incf results)))
|
(incf results)))
|
||||||
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)
|
(defmethod mtree-equal ((tree-1 m-tree) (tree-2 m-tree)
|
||||||
&key
|
&key
|
||||||
(key-fn #'identity)
|
(key-fn #'identity)
|
||||||
|
@ -465,6 +465,7 @@
|
|||||||
:find-child-if
|
:find-child-if
|
||||||
:count-leaves
|
:count-leaves
|
||||||
:count-nodes
|
:count-nodes
|
||||||
|
:collect-nodes-data
|
||||||
:mtree-equal
|
:mtree-equal
|
||||||
:root-node
|
:root-node
|
||||||
:sorted-m-tree
|
:sorted-m-tree
|
||||||
@ -721,6 +722,7 @@
|
|||||||
:message-root
|
:message-root
|
||||||
:message-children
|
:message-children
|
||||||
:message-root->tree
|
:message-root->tree
|
||||||
|
:message->thread-users
|
||||||
:message-id->tree
|
:message-id->tree
|
||||||
:message-from-timeline-folder-message-index
|
:message-from-timeline-folder-message-index
|
||||||
:message-index->tree
|
:message-index->tree
|
||||||
@ -1620,6 +1622,7 @@
|
|||||||
(:export
|
(:export
|
||||||
:add-mention-prefix
|
:add-mention-prefix
|
||||||
:strip-mention-prefix
|
:strip-mention-prefix
|
||||||
|
:local-mention->acct
|
||||||
:crypto-message-destination-user
|
:crypto-message-destination-user
|
||||||
:maybe-crypt-message
|
:maybe-crypt-message
|
||||||
:attachment-type->description
|
:attachment-type->description
|
||||||
|
@ -806,7 +806,7 @@ Force the checking for new message in the thread the selected message belong."
|
|||||||
exceeding)
|
exceeding)
|
||||||
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"
|
"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
|
||||||
@ -841,14 +841,20 @@ Force the checking for new message in the thread the selected message belong."
|
|||||||
(lines (split-lines quoted-text))
|
(lines (split-lines quoted-text))
|
||||||
(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
|
||||||
|
folder
|
||||||
|
reply-id)))
|
||||||
(with-open-file (stream file
|
(with-open-file (stream file
|
||||||
:if-exists :append
|
:if-exists :append
|
||||||
:direction :output
|
:direction :output
|
||||||
:element-type 'character)
|
:element-type 'character)
|
||||||
(format stream "~a~%" (msg-utils:add-mention-prefix reply-username))
|
(format stream "~a~%" (msg-utils:add-mention-prefix reply-username))
|
||||||
(loop for line in quoted-lines do
|
(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)
|
(add-signature (file)
|
||||||
(when-let ((signature (message-rendering-utils:signature)))
|
(when-let ((signature (message-rendering-utils:signature)))
|
||||||
(with-open-file (stream
|
(with-open-file (stream
|
||||||
@ -877,11 +883,13 @@ Force the checking for new message in the thread the selected message belong."
|
|||||||
"Reply to message"
|
"Reply to message"
|
||||||
(when-let* ((win specials:*thread-window*)
|
(when-let* ((win specials:*thread-window*)
|
||||||
(selected-message (line-oriented-window:selected-row-fields win))
|
(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))
|
(username (db:row-message-username selected-message))
|
||||||
(visibility (db:row-message-visibility selected-message))
|
(visibility (db:row-message-visibility selected-message))
|
||||||
(reply-id (db:row-message-status-id selected-message)))
|
(reply-id (db:row-message-status-id selected-message)))
|
||||||
(let ((subject (db:row-message-subject 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 ()
|
(defun send-message ()
|
||||||
"Send message"
|
"Send message"
|
||||||
|
Loading…
x
Reference in New Issue
Block a user