cage
/
tinmop
mirror of https://codeberg.org/cage/tinmop/
1
0
Fork 0
Code Issues

- fixed skipping of ignored users 

When a set  of downloaded statuses contains one or  more status from
  an ignored user restarts the download process again starting from the
  last (or first, if going backward) downloaded status (ordered by ID).

  This way we could skip over a bunch of ignored status.

  The number of download restarting iteration is limited to 3

- added a  configuration directive  to ignore  usernames that  match a
  regular exception.
This commit is contained in:
cage 2020-06-11 17:28:39 +02:00
parent 0895409af5
commit 93950ca530
7 changed files with 252 additions and 95 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

6
etc/shared.conf
View File

@ -76,3 +76,9 @@ color-regexp = "/[^/]+/" #ffff00 italic
color-regexp = "⯀" green bold
color-regexp = "The poll has expired" #ff00ff bold
# you can filter off users using regexp
# ignore-user-regexp = "@domain-name$"
# ignore-user-regexp = "^user-name@domain-name"

41
src/api-client.lisp
View File

@ -284,22 +284,28 @@ authorizations was performed with success."
(string< (tooter:id a)
(tooter:id b)))
(defun update-pagination-statuses-so-far (statuses timeline folder)
(defun update-pagination-statuses-so-far (statuses timeline folder
&key
(event-priority program-events:+standard-event-priority+))
(loop for status in statuses do
(let ((add-fetched-event (make-instance 'program-events:add-pagination-status-event
:priority event-priority
:status-id (tooter:id status)
:timeline timeline
:folder folder)))
(program-events:push-event add-fetched-event))))
(defun-w-lock update-timeline (timeline kind
(defun-w-lock update-timeline (timeline
kind
folder
&key
recover-from-skipped-statuses
local
only-media
max-id
since-id
min-id
(recover-count 0)
(limit 20))
*client-lock*
"Update a timeline, this function will fetch new messages and generate and event to
@ -316,16 +322,25 @@ authorizations was performed with success."
(expand-status-tree node-status))))
(event (make-instance 'program-events:save-timeline-in-db-event
:payload trees
:kind kind
:timeline-type timeline
:folder folder
:localp local
:min-id min-id)))
:min-id min-id
:max-id max-id
:recover-count recover-count
:recover-from-skipped-statuses
recover-from-skipped-statuses)))
;; note that, because events are enqueued with priority and the
;; first instanced event has better priority the another instanced
;; first instanced event has better priority than another instanced
;; later, the events generated by the function below will run
;; after the save-timeline-in-db-event; in this case it does not
;; matter, though
(update-pagination-statuses-so-far timeline-statuses timeline folder)
;; after the save-timeline-in-db-event, that is because we give the
;; event generated by 'update-pagination-statuses-so-far' the maximum priority
(update-pagination-statuses-so-far timeline-statuses
timeline
folder
:event-priority
program-events:+maximum-event-priority+)
(program-events:push-event event)))
(defun-w-lock get-timeline-tag (tag &key min-id (limit 20))
@ -340,7 +355,10 @@ authorizations was performed with success."
:min-id min-id
:limit limit))
(defun-w-lock update-timeline-tag (tag folder &key min-id (limit 20))
(defun-w-lock update-timeline-tag (tag folder &key
(recover-count 0)
min-id
(limit 20))
*client-lock*
"Update a tag timeline, this function will fetch new messages (that
contains tag `tag') and generate and event to update the program
@ -357,10 +375,13 @@ authorizations was performed with success."
:timeline-type db:+federated-timeline+
:folder folder
:localp nil
:min-id min-id)))
:min-id min-id
:recover-count recover-count)))
(update-pagination-statuses-so-far timeline-statuses
db:+default-tag-timeline+
folder)
folder
:event-priority
program-events:+maximum-event-priority+)
(program-events:push-event save-timeline-in-db-event))))
(defun tag-name (tag &key (return-empty-string-if-nil nil))

60
src/db.lisp
View File

@ -95,6 +95,9 @@
(define-constant +table-ignored-status+ :ignored-status
:test #'eq)
(define-constant +table-skipped-status+ :skipped-status
:test #'eq)
(define-constant +table-pagination-status+ :pagination-status
:test #'eq)
@ -455,6 +458,15 @@
" \"created-at\" TEXT NOT NULL"
+make-close+)))
(defun make-skipped-status ()
(query-low-level (strcat (prepare-table +table-skipped-status+ :autoincrementp t)
" \"status-id\" TEXT NOT NULL, "
" timeline TEXT NOT NULL, "
" folder TEXT NOT NULL, "
;; timestamp
" \"created-at\" TEXT NOT NULL"
+make-close+)))
(defun make-pagination-status ()
(query-low-level (strcat (prepare-table +table-pagination-status+ :autoincrementp t)
" \"status-id\" TEXT NOT NULL, "
@ -468,6 +480,7 @@
(create-table-index +table-followed-user+ '(:user-id))
(create-table-index +table-subscribed-tag+ '(:id))
(create-table-index +table-ignored-status+ '(:folder :timeline :status-id))
(create-table-index +table-skipped-status+ '(:folder :timeline :status-id))
(create-table-index +table-pagination-status+ '(:folder :timeline :status-id))
(create-table-index +table-conversation+ '(:id))
(create-table-index +table-cache+ '(:id :key)))
@ -489,6 +502,8 @@
+table-attachment+
+table-conversation+
+table-pagination-status+
+table-ignored-status+
+table-skipped-status+
+table-poll-option+
+table-poll+))
@ -511,6 +526,7 @@
(make-followed-user)
(make-status)
(make-ignored-status)
(make-skipped-status)
(make-attachment)
(make-subscribed-tag)
(make-tag-histogram)
@ -564,6 +580,24 @@
"Delete a row from a `table' by column named `:id' with value `id'"
(query (delete-from table (where (:= :id id)))))
(defun account-ignored-p (account-id)
"Returns non nil if this account has been setted as ignored by the user"
(let* ((db-account-row (fetch-from-id :account account-id))
(account-known-p db-account-row))
(and account-known-p
(db-getf db-account-row
:ignoredp nil))))
(defun user-ignored-p (account-id)
"Returns non nil if this account must be ignored"
(or (db:account-ignored-p account-id)
(when-let ((ignore-regexps (swconf:ignore-users-regexps))
(username (db:user-id->username account-id)))
(loop for ignore-re in ignore-regexps do
(when (cl-ppcre:scan ignore-re username)
(return-from user-ignored-p t)))
nil)))
(defun acct->user (acct)
"Convert `acct' (acct is synonyym for username in mastodon account)
to the corresponding row in table +table-account+"
@ -995,10 +1029,6 @@ than (swconf:config-purge-history-days-offset) days in the past"
(:and (:= :day actual-day)
(:= :tag tag)))))))))
(defun account-ignored-p (account-id)
(db-getf (fetch-from-id :account account-id)
:ignoredp nil))
(defmethod update-db ((object tooter:status)
&key
(timeline +local-timeline+)
@ -1050,7 +1080,7 @@ than (swconf:config-purge-history-days-offset) days in the past"
(reblog-id (if parent
(prepare-for-db (tooter:id parent))
(prepare-for-db nil)))
(account-ignored-p (account-ignored-p account-id))
(account-ignored-p (user-ignored-p account-id))
(status-ignored-p (status-ignored-p id folder timeline)))
(when (not (and skip-ignored-p
(or status-ignored-p
@ -2093,6 +2123,16 @@ account that wrote the status identified by `status-id'"
(:= :folder folder)
(:= :timeline timeline))))))
(defun status-skipped-p (status-id folder timeline)
"Return non nil if this status should be skipped because belong to an ignored account
(id timeline and folder is the tuple that is primary key for table
:status)"
(query (select :*
(from +table-skipped-status+)
(where (:and (:= :status-id status-id)
(:= :folder folder)
(:= :timeline timeline))))))
(defmacro with-db-current-timestamp ((timestamp) &body body)
`(let ((,timestamp (prepare-for-db (local-time-obj-now))))
,@body))
@ -2106,6 +2146,16 @@ account that wrote the status identified by `status-id'"
(:status-id :folder :timeline :created-at)
(status-id folder timeline now))))))
(defun add-to-status-skipped (status-id folder timeline)
"Skips this status (id timeline and folder is the tuple that is
primary key for table :status), if in this table the
status has been downloaded from the net and ignored because belog to an ignored account."
(when (not (status-skipped-p status-id folder timeline))
(with-db-current-timestamp (now)
(query (make-insert +table-skipped-status+
(:status-id :folder :timeline :created-at)
(status-id folder timeline now))))))
(defun add-to-followers (user-id)
(with-db-current-timestamp (now)
(query (make-insert +table-followed-user+

6
src/package.lisp
View File

@ -681,6 +681,8 @@
:fetch-from-id
:fetch-single
:delete-by-id
:account-ignored-p
:user-ignored-p
:acct->user
:acct->id
:username->id
@ -783,7 +785,9 @@
:all-unfollowed-usernames
:all-ignored-usernames
:status-ignored-p
:status-skipped-p
:add-to-status-ignored
:add-to-status-skipped
:add-to-followers
:remove-from-followers
:forget-all-statuses-marked-deleted
@ -936,6 +940,7 @@
:quote-char
:max-attachments-allowed
:color-regexps
:ignore-users-regexps
:win-bg
:win-fg
:win-height
@ -1094,6 +1099,7 @@
(:export
:+standard-event-priority+
:+minimum-event-priority+
:+maximum-event-priority+
:*process-events-immediately*
:program-event
:event-id

63
src/program-events.lisp
View File

@ -31,6 +31,8 @@
(define-constant +minimum-event-priority+ -1 :test #'=)
(define-constant +maximum-event-priority+ -2 :test #'=)
;; keep this function stricly monotonic otherwise the order of
;; elements in priority queue is going to be messed up
(defun-w-lock next-id () *id-lock*
@ -86,8 +88,14 @@
(if same-priority-p
(< (event-id a)
(event-id b))
(cond
((= (priority a) +maximum-event-priority+)
t)
((= (priority b) +maximum-event-priority+)
nil)
(t
(< (priority a)
(priority b)))))
(priority b)))))))
(defun queue-equals-predicate (a b)
(= (event-id a)
@ -259,8 +267,14 @@
(let ((win (payload object)))
(mtree:remove-child specials:*main-window* win)))
(define-constant +max-recover-count+ 3)
(defclass save-timeline-in-db-event (program-event)
((timeline-type
((kind
:initform nil
:initarg :kind
:accessor kind)
(timeline-type
:initform nil
:initarg :timeline-type
:accessor timeline-type)
@ -276,26 +290,63 @@
(min-id
:initform nil
:initarg :min-id
:accessor min-id)))
:accessor min-id)
(max-id
:initform nil
:initarg :max-id
:accessor max-id)
(recover-from-skipped-statuses
:initform nil
:initarg :recover-from-skipped-statuses
:reader recover-from-skipped-statuses-p
:writer recover-from-skipped-statuses)
(recover-count
:initform 0
:initarg :recover-count
:accessor recover-count)))
(defmethod process-event ((object save-timeline-in-db-event))
"Update a timeline, save messages, performs topological sorts"
(let ((statuses (payload object))
(timeline-type (timeline-type object))
(folder (folder object)))
(ignored-count 0))
(with-accessors ((timeline-type timeline-type)
(folder folder)
(min-id min-id)
(max-id max-id)
(kind kind)
(recover-count recover-count)) object
#+debug-mode
(let ((dump (with-output-to-string (stream)
(mapcar (lambda (toot) (tooter::present toot stream))
statuses))))
(dbg "statuses ~a" dump))
(loop for status in statuses do
(let ((account-id (tooter:id (tooter:account status)))
(status-id (tooter:id status)))
(when (and (db:user-ignored-p account-id)
(not (db:status-skipped-p status-id folder timeline-type)))
(db:add-to-status-skipped status-id folder timeline-type)
(incf ignored-count)))
(db:update-db status
:timeline timeline-type
:folder folder
:skip-ignored-p t))
(db:renumber-timeline-message-index timeline-type
folder
:account-id nil)))
:account-id nil)
(when (and recover-count
(< recover-count +max-recover-count+)
(> ignored-count 0)
(recover-from-skipped-statuses-p object))
(let ((going-backward max-id)
(going-forward (or (and (null max-id)
(null min-id))
min-id)))
(cond
(going-forward
(ui:update-current-timeline (1+ recover-count)))
(going-backward
(ui:update-current-timeline-backwards (1+ recover-count)))))))))
(defclass fetch-remote-status-event (program-event) ())

21
src/software-configuration.lisp
View File

@ -20,6 +20,7 @@
;; CONFIG := (ENTRIES)*
;; ENTRIES := COMMENT*
;; (USE-FILE
;; | IGNORE-USER-RE-ASSIGN
;; | COLOR-RE-ASSIGN
;; | SERVER-ASSIGN
;; | USERNAME-ASSIGN
@ -33,6 +34,7 @@
;; colorname
;; generic-value) ; the order in this list *is* important
;; blanks)
;; IGNORE-USER-RE-ASSIGN := IGNORE-USER-RE-KEY ASSIGN REGEXP
;; COLOR-RE-ASSIGN := COLOR-RE-KEY ASSIGN REGEXP FG-COLOR (? ATTRIBUTE-VALUE)
;; USE-FILE := (AND USE BLANKS FILEPATH BLANKS)
;; KEY := FIELD (FIELD-SEPARATOR KEY)*
@ -42,6 +44,7 @@
;; SERVER-KEY := "server"
;; USERNAME-KEY := "username"
;; COLOR-RE-KEY := "color-regexp"
;; IGNORE-USER-RE-KEY := "ignore-user-regexp"
;; REGEXP := QUOTED-STRING
;; QUOTED-STRING := #\" (not #\") #\"
;; FIELD := ( (or ESCAPED-CHARACTER
@ -224,6 +227,7 @@
(and color-name-p color)
(and (not color-name-p) color)
attributes))))
(defrule attribute-value (or "bold"
"italic"
"underline"
@ -239,6 +243,14 @@
(:function remove-if-null)
(:function build-color-re-assign))
(defrule ignore-user-re-key "ignore-user-regexp"
(:constant :ignore-user-re))
(defrule ignore-user-re-assign
(and ignore-user-re-key blanks
assign blanks regexp blanks)
(:function (lambda (a) (list (first a) (fifth a)))))
(defrule server-key "server"
(:constant :server))
@ -271,6 +283,7 @@
(and (* comment)
(or use-file
color-re-assign
ignore-user-re-assign
server-assign
username-assign
generic-assign)
@ -376,6 +389,7 @@
read
unread
color-re
ignore-user-re
purge-history-days-offset
purge-cache-days-offset)
@ -388,7 +402,8 @@
(let ((key (first entry))
(value (second entry)))
(cond
((eq +key-color-re+ key)
((or (eq +key-color-re+ key)
(eq +key-ignore-user-re+ key))
(setf (access:accesses *software-configuration* key)
(append (access:accesses *software-configuration* key)
(list value))))
@ -520,6 +535,10 @@
(access:accesses *software-configuration*
+key-color-re+))
(defun ignore-users-regexps ()
(access:accesses *software-configuration*
+key-ignore-user-re+))
(defmacro gen-win-key-access (fn-suffix key)
`(defun ,(misc:format-fn-symbol t "win-~a" fn-suffix) (win-key)
(access:accesses *software-configuration*

8
src/ui-goodies.lisp
View File

@ -501,7 +501,7 @@ and if fetch local (again, to server) statuses only."
((string= timeline db:+home-timeline+)
(values :home nil))))
(defun update-current-timeline ()
(defun update-current-timeline (&optional (recover-count 0))
"Update current timeline
This command also checks notifications about mentioning the user
@ -517,6 +517,8 @@ folder \"mentions\"."
(client:update-timeline timeline
kind
folder
:recover-from-skipped-statuses t
:recover-count recover-count
:min-id max-id
:local localp)
(let ((update-mentions-event (make-instance 'update-mentions-event))
@ -530,7 +532,7 @@ folder \"mentions\"."
:ending-message (_ "Messages downloaded.")
:life-start (* (swconf:config-notification-life) 5))))))
(defun update-current-timeline-backwards ()
(defun update-current-timeline-backwards (&optional (recover-count 0))
"Update current timeline backwards
Starting from the oldest toot and going back."
@ -544,6 +546,8 @@ Starting from the oldest toot and going back."
(client:update-timeline timeline
kind
folder
:recover-count recover-count
:recover-from-skipped-statuses t
:max-id min-id
:local localp)
(let ((refresh-event (make-instance 'refresh-thread-windows-event)))