cage/tinmop
1
0
Fork 0
mirror of https://codeberg.org/cage/tinmop/ synced 2025-02-21 08:50:51 +01:00
Code Issues

- added optional notification of statuses mentioning the user;

Browse Source 
- protected reblogged timeline from accidental deletiion;
- added the posiibility to force expanding of a message tree.
This commit is contained in:
cage 2020-05-30 09:53:12 +02:00
parent 8ab80a1f40
commit 9895843b21
10 changed files with 241 additions and 41 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

2
etc/init.lisp
View File

@ -201,6 +201,8 @@
(define-key "r" #'reply-message *thread-keymap*)
(define-key "R" #'refresh-thread *thread-keymap*)
(define-key "v" #'open-message-attach *thread-keymap*)
(define-key "V" #'open-message-link *thread-keymap*)

84
src/api-client.lisp
View File

@ -269,7 +269,7 @@ authorizations was performed with success."
- only-media get status with attachments only
- max-id get status until this id
- min-id starts getting messages newer than this id
- since-id cut the messages got starting drom this id
- since-id cut the messages got starting from this id
- limit gets a maimum of messages up to this value."
(tooter:timeline *client*
kind
@ -320,7 +320,6 @@ authorizations was performed with success."
:folder folder
:localp local
:min-id min-id)))
;; note that, because events are enqueued with priority and the
;; first instanced event has better priority the another instanced
;; later, the events generated by the function below will run
@ -599,6 +598,87 @@ returns nil if the credentials are invalid"
(assert (stringp id))
(tooter:polls *client* id))
(defun-w-lock get-notifications (&key
(max-id nil)
(min-id nil)
(since-id nil)
(limit 10)
(exclude-types nil)
(account-id nil))
*client-lock*
"get notifications
- max-id get notification until this id
- min-id starts getting notification newer than this id
- since-id cut the notifications starting from this id
- limit gets a maimum of messages up to this value
- exclude-types list types of modifications that will not be fetched."
(tooter:notifications *client*
:max-id max-id
:min-id min-id
:since-id since-id
:limit limit
:exclude-types exclude-types
:account-id account-id))
(defun mentions (max-id)
"Get the latest mentions, starting from `min-id` (pass nil to get
the latest 15 mentions)."
(get-notifications :max-id max-id
:exclude-types '(:follow
:favourite
:reblog)))
(defun-w-lock delete-notification (notification-id)
*client-lock*
"Delete a notification identified by `notification-id'"
(tooter:delete-notification-deprecated *client* notification-id))
(defun sort-id< (list)
"Sort entities by id in descending order"
(sort list #'status-id<))
(defun all-mentions ()
"Get all mentions"
(let ((mentions-so-far (sort-id< (mentions nil))))
(when mentions-so-far
(labels ((%mentions ()
(when-let* ((min-id (tooter:id (first mentions-so-far)))
(mentions (sort-id< (mentions min-id))))
(loop for mention in mentions do
(pushnew mention mentions-so-far :test (make-id=)))
(setf mentions-so-far (sort-id< mentions-so-far))
(when mentions
(%mentions)))))
(%mentions)))
mentions-so-far))
(defun update-mentions-folder (&key (delete-mentions-on-server t))
(when-let* ((all-mentions (all-mentions))
(trees (flatten (loop for mention in all-mentions collect
(expand-status-tree (tooter:status mention)))))
(event (make-instance 'program-events:save-timeline-in-db-event
:payload trees
:timeline-type db:+home-timeline+
:folder db:+mentions-status-folder+
:localp t
:min-id nil)))
(when delete-mentions-on-server
(map nil
(lambda (m) (delete-notification (tooter:id m)))
all-mentions))
(program-events:push-event event)
all-mentions))
(defun expand-status-thread (status-id timeline folder)
(when-let* ((tree (expand-status-tree status-id))
(event (make-instance 'program-events:save-timeline-in-db-event
:payload tree
:timeline-type timeline
:folder folder)))
(program-events:push-event event)
tree))
(defgeneric climb-fetch-statuses (object &optional branch))
(defmethod climb-fetch-statuses ((object tooter:status) &optional (branch ()))

14
src/command-line.lisp
View File

@ -59,7 +59,13 @@
:short #\e
:arg-parser #'identity
:meta-var (_ "SCRIPT-FILE")
:long "execute-script")))
:long "execute-script")
(:name :notify-mentions
:description (_ "Notify messages that mentions the user")
:short #\m
:arg-parser #'identity
:long "notify-mentions")))
(defparameter *start-folder* nil)
@ -73,6 +79,8 @@
(defparameter *reset-timeline-pagination* nil)
(defparameter *notify-mentions* nil)
(defun exit-on-error (e)
(format *error-output* "~a~%" e)
(os-utils:exit-program 1))
@ -101,4 +109,6 @@
(when (getf options :execute)
(setf *script-file* (getf options :execute)))
(when (getf options :check-follows-requests)
(setf *check-follow-requests* (getf options :check-follows-requests))))))
(setf *check-follow-requests* (getf options :check-follows-requests)))
(when (getf options :notify-mentions)
(setf *notify-mentions* (getf options :check-follows-requests))))))

11
src/complete.lisp
View File

@ -102,10 +102,13 @@ completed) and the common prefix of the completion string."
(lambda (a)
(cl-ppcre:scan (text-utils:strcat "^" hint) a)))
(defun remove-if-hidden (candidates)
(remove-if #'db:hidden-recipient-p candidates))
(defun folder-complete (hint)
"Virtual messages folder in db not filesystem directory"
(when-let ((matching-folders (remove-if-not (starts-with-clsr hint)
(db:all-folders))))
(when-let ((matching-folders (remove-if-hidden (remove-if-not (starts-with-clsr hint)
(db:all-folders)))))
(values matching-folders
(reduce-to-common-prefix matching-folders))))
@ -116,8 +119,8 @@ completed) and the common prefix of the completion string."
(db:all-timelines-in-folder folder
:include-default-timelines t)
(db:default-timelines)))
(matching-timelines (remove-if-not (starts-with-clsr hint)
all-timelines)))
(matching-timelines (remove-if-hidden (remove-if-not (starts-with-clsr hint)
all-timelines))))
(values matching-timelines
(reduce-to-common-prefix matching-timelines)))))

14
src/db.lisp
View File

@ -119,13 +119,19 @@
(define-constant +default-status-folder+ "default"
:test #'string=)
(define-constant +mentions-status-folder+ "mentions"
:test #'string=)
(define-constant +default-tag-timeline+ +federated-timeline+
:test #'string=)
(define-constant +default-converation-timeline+ +federated-timeline+
:test #'string=)
(define-constant +default-reblogged-timeline+ "reblogged"
(define-constant +hidden-recipient-prefix+ #\.
:test #'char=)
(define-constant +default-reblogged-timeline+ ".reblogged"
:test #'string=)
(define-constant +message-index-start+ 1
@ -139,6 +145,12 @@
+local-timeline+
+federated-timeline+))
(defgeneric hidden-recipient-p (object))
(defmethod hidden-recipient-p ((object string))
(char= +hidden-recipient-prefix+
(first-elt object)))
(defun message-index->sequence-index (message-index)
(- message-index +message-index-start+))

13
src/main.lisp
View File

@ -72,8 +72,11 @@ etc.) happened"
(let ((refresh-event (make-instance 'program-events:refresh-thread-windows-event
:new-folder command-line:*start-folder*))
(folder-exists-p (db:folder-exists-p command-line:*start-folder*)))
(when folder-exists-p
(program-events:push-event refresh-event))))
(if folder-exists-p
(program-events:push-event refresh-event)
(ui:error-message (format nil
(_ "Folder ~s does not exists")
command-line:*start-folder*)))))
(defun change-timeline ()
"Change timeline, used in requests of a command line switch"
@ -114,10 +117,10 @@ etc.) happened"
(client:init)
(client:authorize)
(let ((program-events:*process-events-immediately* t))
(when command-line:*start-folder*
(change-folder))
(when command-line:*start-timeline*
(change-timeline)))
(change-timeline))
(when command-line:*start-folder*
(change-folder)))
(when command-line:*reset-timeline-pagination*
(reset-timeline-pagination))
(when command-line:*update-timeline*

13
src/package.lisp
View File

@ -710,10 +710,12 @@
:+home-timeline+
:+direct-timeline+
:+default-status-folder+
:+mentions-status-folder+
:+default-tag-timeline+
:+default-converation-timeline+
:+message-index-start+
:+tag-separator+
:hidden-recipient-p
:default-timelines
:message-index->sequence-index
:timeline-type->description
@ -1070,6 +1072,8 @@
(:shadowing-import-from :misc :random-elt :shuffle)
(:shadowing-import-from :priority-queue :emptyp)
(:export
:+standard-event-priority+
:+minimum-event-priority+
:*process-events-immediately*
:program-event
:event-id
@ -1134,6 +1138,8 @@
:refresh-conversations-window-event
:ignore-conversations-event
:delete-conversations-event
:update-mentions-event
:expand-thread-event
:report-status-event
:add-crypto-data-event
:function-event
@ -1192,6 +1198,11 @@
:bookmark
:unbookmark
:polls
:get-notifications
:delete-notification
:all-mentions
:update-mentions-folder
:expand-status-thread
:make-placeholder-tag-histogram
:init))
@ -1867,6 +1878,7 @@
:change-timeline
:update-current-timeline
:update-current-timeline-backwards
:refresh-thread
:refresh-tags
:favourite-selected-status
:unfavourite-selected-status
@ -1975,6 +1987,7 @@
:*script-file*
:*check-follow-requests*
:*reset-timeline-pagination*
:*notify-mentions*
:manage-opts))
(defpackage :main

76
src/program-events.lisp
View File

@ -23,9 +23,13 @@
;; used only in batch mode from the command line
(defparameter *process-events-immediately* nil
"Used only in batch mode from the command line. Instead of pushing the event on a priority queue that will be picked by a thread process the event immediately")
"Used only in batch mode from the command line. Instead of pushing
the event on a priority queue that will be picked by a thread
process the event immediately")
(define-constant +standard-event-priority+ 10 :test #'=)
(define-constant +standard-event-priority+ 10 :test #'=)
(define-constant +minimum-event-priority+ -1 :test #'=)
;; keep this function stricly monotonic otherwise the order of
;; elements in priority queue is going to be messed up
@ -45,20 +49,30 @@
(priority
:initform +standard-event-priority+
:initarg :priority
:accessor priority)))
:accessor priority)
(notes
:initform nil
:initarg :notes
:accessor notes
:documentation "Someway useful for debugging")))
(defmethod print-object ((object program-event) stream)
(print-unreadable-object (object stream :type t :identity nil)
(format stream "id ~a priority ~a" (event-id object) (priority object))))
(format stream
"id ~a priority ~a notes ~a"
(event-id object)
(priority object)
(notes object))))
(defgeneric process-event (object))
(defgeneric reinitialize-id (object))
(defmethod reinitialize-id ((object program-event))
(setf (event-id object)
(next-id))
object)
(defmacro wrapped-in-lock ((queue) &body body)
(with-gensyms (lock)
`(with-accessors ((,lock lock)) ,queue
(with-lock (,lock)
,@body))))
(defclass events-queue (priority-queue)
((lock
@ -87,14 +101,14 @@
(setf equal-function #'queue-equals-predicate)
(setf compare-function #'queue-compare-predicate)))
(defmacro wrapped-in-lock ((queue) &body body)
(with-gensyms (lock)
`(with-accessors ((,lock lock)) ,queue
(with-lock (,lock)
,@body))))
(defparameter *events-queue* (make-instance 'events-queue))
(defmethod reinitialize-id ((object program-event))
(wrapped-in-lock (*events-queue*)
(setf (event-id object)
(next-id))
object))
(defun push-event (event)
(wrapped-in-lock (*events-queue*)
(if *process-events-immediately*
@ -711,6 +725,30 @@
(api-client:delete-conversation id)
(db:delete-conversation folder))))
(defclass update-mentions-event (program-event) ())
(defmethod process-event ((object update-mentions-event))
(when-let* ((mentions (api-client:update-mentions-folder :delete-mentions-on-server t))
(mentions-count (length mentions)))
(when command-line:*notify-mentions*
(ui:notify (format nil
(n_ "Got ~a notification"
"~Got a notifications"
mentions-count)
mentions-count)))))
(defclass expand-thread-event (program-event event-with-timeline-and-folder)
((status-id
:initform nil
:initarg :status-id
:accessor status-id)))
(defmethod process-event ((object expand-thread-event))
(with-accessors ((new-folder new-folder)
(new-timeline new-timeline)
(status-id status-id)) object
(api-client:expand-status-thread status-id new-timeline new-folder)))
(defclass report-status-event (program-event)
((status-id
:initform nil
@ -784,4 +822,12 @@
(defun dispatch-program-events ()
(when (event-available-p)
(process-event (pop-event))))
(let ((bypassable-event (pop-event)))
(if (and (= (priority bypassable-event)
+minimum-event-priority+)
(event-available-p))
(let ((event (pop-event)))
(reinitialize-id bypassable-event)
(push-event bypassable-event)
(process-event event))
(process-event bypassable-event)))))

15
src/tui-utils.lisp
View File

@ -469,10 +469,11 @@
(print-debug i))))
(defmacro with-notify-errors (&body body)
`(handler-case
(progn
,@body)
(error (e)
(ui:notify (format nil (_ "Error: ~a") e)
:life (* (swconf:config-notification-life) 5)
:as-error t))))
#+debug-mode `(progn ,@body)
#-debug-mode `(handler-case
(progn
,@body)
(error (e)
(ui:notify (format nil (_ "Error: ~a") e)
:life (* (swconf:config-notification-life) 5)
:as-error t))))

40
src/ui-goodies.lisp
View File

@ -479,9 +479,13 @@ Metadata includes:
(flet ((on-input-complete (new-timeline)
(let* ((refresh-event (make-instance 'refresh-thread-windows-event
:new-timeline new-timeline)))
(if (string-empty-p new-timeline)
(error-message (_ "No timeline specified."))
(push-event refresh-event)))))
(cond
((string-empty-p new-timeline)
(error-message (_ "No timeline specified.")))
((db:hidden-recipient-p new-timeline)
(error-message (_ "This timeline is protected.")))
(t
(push-event refresh-event))))))
(ask-string-input #'on-input-complete
:prompt (_ "Change timeline: ")
:complete-fn (complete:timeline-complete-fn folder)))))
@ -498,7 +502,11 @@ and if fetch local (again, to server) statuses only."
(values :home nil))))
(defun update-current-timeline ()
"Update current timeline"
"Update current timeline
This command also checks notifications about mentioning the user
and (if such mentions exists) download the mentioning toots in the
folder \"mentions\"."
(let* ((timeline (thread-window:timeline-type specials:*thread-window*))
(folder (thread-window:timeline-folder specials:*thread-window*))
(max-id (db:last-pagination-status-id-timeline-folder timeline folder)))
@ -511,7 +519,11 @@ and if fetch local (again, to server) statuses only."
folder
:min-id max-id
:local localp)
(let ((refresh-event (make-instance 'refresh-thread-windows-event)))
(let ((update-mentions-event (make-instance 'update-mentions-event))
(refresh-event (make-instance 'refresh-thread-windows-event)))
;; updating home also triggers the checks for mentions
(when (eq kind :home)
(push-event update-mentions-event))
(push-event refresh-event)))))
(notify-procedure #'update
(_ "Downloading messages.")
@ -541,6 +553,24 @@ Starting from the oldest toot and going back."
:ending-message (_ "Messages downloaded.")
:life-start (* (swconf:config-notification-life) 5))))))
(defun refresh-thread ()
"Check and download a thread
Force the checking for new message in the thread the selected message belong."
(when-let* ((selected-message (line-oriented-window:selected-row-fields specials:*thread-window*))
(timeline (thread-window:timeline-type specials:*thread-window*))
(folder (thread-window:timeline-folder specials:*thread-window*))
(status-id (db:row-message-status-id selected-message))
(expand-event (make-instance 'expand-thread-event
:new-folder folder
:new-timeline timeline
:status-id status-id))
(refresh-event (make-instance 'refresh-thread-windows-event
:priority +minimum-event-priority+)))
(with-blocking-notify-procedure ((_ "Expanding thread"))
(push-event expand-event)
(push-event refresh-event))))
(defun refresh-tags ()
"Update messages for subscribed tags"
(let* ((all-tags (db:all-subscribed-tags-name))