cage/tinmop
1
0
Fork 0
mirror of https://codeberg.org/cage/tinmop/ synced 2025-01-30 04:14:47 +01:00
Code Issues

- tried to fix mentioning of non local user in reply.

Browse Source
This commit is contained in:
cage 2020-07-18 13:03:58 +02:00
parent c27f36696d
commit 7b48939deb
5 changed files with 63 additions and 4 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

24
src/db.lisp
View File

@ -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."

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

@ -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)

8
src/mtree-utils.lisp
View File

@ -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)

3
src/package.lisp
View File

@ -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

16
src/ui-goodies.lisp
View File

@ -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"