From 93950ca530dec24ec6328c0af8d7e23334088a9b Mon Sep 17 00:00:00 2001 From: cage Date: Thu, 11 Jun 2020 17:28:39 +0200 Subject: [PATCH] - 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. --- etc/shared.conf | 8 ++- src/api-client.lisp | 57 +++++++++++----- src/db.lisp | 60 +++++++++++++++-- src/package.lisp | 6 ++ src/program-events.lisp | 115 +++++++++++++++++++++++--------- src/software-configuration.lisp | 85 ++++++++++++++--------- src/ui-goodies.lisp | 16 +++-- 7 files changed, 252 insertions(+), 95 deletions(-) diff --git a/etc/shared.conf b/etc/shared.conf index d3cf3f9..69e947a 100644 --- a/etc/shared.conf +++ b/etc/shared.conf @@ -75,4 +75,10 @@ color-regexp = "/[^/]+/" #ffff00 italic color-regexp = "⯀" green bold -color-regexp = "The poll has expired" #ff00ff bold \ No newline at end of file +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" \ No newline at end of file diff --git a/src/api-client.lisp b/src/api-client.lisp index 288f2bd..36ef24a 100644 --- a/src/api-client.lisp +++ b/src/api-client.lisp @@ -284,23 +284,29 @@ 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 - folder - &key - local - only-media - max-id - since-id - min-id - (limit 20)) +(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 update the program reflectings the changes in the timeline (saves @@ -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)) diff --git a/src/db.lisp b/src/db.lisp index 2d748ee..0aab07e 100644 --- a/src/db.lisp +++ b/src/db.lisp @@ -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+ diff --git a/src/package.lisp b/src/package.lisp index c4b067c..fc9c5a2 100644 --- a/src/package.lisp +++ b/src/package.lisp @@ -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 diff --git a/src/program-events.lisp b/src/program-events.lisp index 7463fd1..f4a8655 100644 --- a/src/program-events.lisp +++ b/src/program-events.lisp @@ -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)) - (< (priority a) - (priority b))))) + (cond + ((= (priority a) +maximum-event-priority+) + t) + ((= (priority b) +maximum-event-priority+) + nil) + (t + (< (priority a) + (priority b))))))) (defun queue-equals-predicate (a b) (= (event-id a) @@ -259,43 +267,86 @@ (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 - :initform nil - :initarg :timeline-type - :accessor timeline-type) + ((kind + :initform nil + :initarg :kind + :accessor kind) + (timeline-type + :initform nil + :initarg :timeline-type + :accessor timeline-type) (folder - :initform nil - :initarg :folder - :accessor folder) + :initform nil + :initarg :folder + :accessor folder) (local - :initform nil - :initarg :localp - :reader localp - :writer (setf local)) + :initform nil + :initarg :localp + :reader localp + :writer (setf local)) (min-id - :initform nil - :initarg :min-id - :accessor min-id))) + :initform nil + :initarg :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))) - #+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 - (db:update-db status - :timeline timeline-type - :folder folder - :skip-ignored-p t)) - (db:renumber-timeline-message-index timeline-type - folder - :account-id nil))) + (let ((statuses (payload 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) + (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) ()) diff --git a/src/software-configuration.lisp b/src/software-configuration.lisp index 427b587..261d73c 100644 --- a/src/software-configuration.lisp +++ b/src/software-configuration.lisp @@ -17,57 +17,60 @@ (in-package :software-configuration) -;; CONFIG := (ENTRIES)* -;; ENTRIES := COMMENT* +;; CONFIG := (ENTRIES)* +;; ENTRIES := COMMENT* ;; (USE-FILE +;; | IGNORE-USER-RE-ASSIGN ;; | COLOR-RE-ASSIGN ;; | SERVER-ASSIGN ;; | USERNAME-ASSIGN ;; | GENERIC-ASSIGN) ;; COMMENT* -;; SERVER-ASSIGN := SERVER-KEY BLANKS ASSIGN BLANKS GENERIC-VALUE BLANKS -;; USERNAME-ASSIGN := USERNAME-KEY BLANKS ASSIGN BLANKS GENERIC-VALUE BLANKS -;; GENERIC-ASSIGN := (and key blanks assign blanks +;; SERVER-ASSIGN := SERVER-KEY BLANKS ASSIGN BLANKS GENERIC-VALUE BLANKS +;; USERNAME-ASSIGN := USERNAME-KEY BLANKS ASSIGN BLANKS GENERIC-VALUE BLANKS +;; GENERIC-ASSIGN := (and key blanks assign blanks ;; (or quoted-string ;; hexcolor ;; colorname ;; generic-value) ; the order in this list *is* important ;; blanks) -;; COLOR-RE-ASSIGN := COLOR-RE-KEY ASSIGN REGEXP FG-COLOR (? ATTRIBUTE-VALUE) -;; USE-FILE := (AND USE BLANKS FILEPATH BLANKS) -;; KEY := FIELD (FIELD-SEPARATOR KEY)* -;; BLANKS := (BLANK)* -;; FILEPATH := QUOTED-STRING -;; USE := "use" -;; SERVER-KEY := "server" -;; USERNAME-KEY := "username" -;; COLOR-RE-KEY := "color-regexp" -;; REGEXP := QUOTED-STRING -;; QUOTED-STRING := #\" (not #\") #\" -;; FIELD := ( (or ESCAPED-CHARACTER +;; 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)* +;; BLANKS := (BLANK)* +;; FILEPATH := QUOTED-STRING +;; USE := "use" +;; 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 ;; (not #\# ASSIGN BLANK FIELD-SEPARATOR) )* -;; COMMENT := BLANKS #\# (not #\Newline)* BLANKS -;; FIELD-SEPARATOR := #\. -;; GENERIC-VALUE := KEY -;; ASSIGN := #\= -;; BLANK := (or #\space #\Newline #\Tab) -;; BG-COLOR := COLOR -;; FG-COLOR := COLOR -;; COLOR := HEX-COLOR | COLOR-NAME -;; HEX-COLOR := HEXCOLOR-PREFIX +;; COMMENT := BLANKS #\# (not #\Newline)* BLANKS +;; FIELD-SEPARATOR := #\. +;; GENERIC-VALUE := KEY +;; ASSIGN := #\= +;; BLANK := (or #\space #\Newline #\Tab) +;; BG-COLOR := COLOR +;; FG-COLOR := COLOR +;; COLOR := HEX-COLOR | COLOR-NAME +;; HEX-COLOR := HEXCOLOR-PREFIX ;; HEXDIGIT HEXDIGIT -> red ;; HEXDIGIT HEXDIGIT -> green ;; HEXDIGIT HEXDIGIT -> blue -;; ESCAPED-CHARACTER := #\\ any-character -;; HEXCOLOR-PREFIX := #\# -;; HEX-DIGIT := (and (character-ranges #\0 #\9) +;; ESCAPED-CHARACTER := #\\ any-character +;; HEXCOLOR-PREFIX := #\# +;; HEX-DIGIT := (and (character-ranges #\0 #\9) ;; (character-ranges #\a #\f) ;; (character-ranges #\A #\f) -;; ATTRIBUTE-VALUE := "bold" +;; ATTRIBUTE-VALUE := "bold" ;; | "italic" ;; | "underline" ;; | "blink" -;; COLOR-NAME := "black" +;; COLOR-NAME := "black" ;; | "red" ;; | "green" ;; | "yellow" @@ -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* @@ -770,7 +789,7 @@ +key-value+)) (defun date-fmt (window-key) - (let* ((raw (access:accesses *software-configuration* + (let* ((raw (access:accesses *software-configuration* window-key +key-date-format+ +key-value+))) diff --git a/src/ui-goodies.lisp b/src/ui-goodies.lisp index b8212b0..768dc1b 100644 --- a/src/ui-goodies.lisp +++ b/src/ui-goodies.lisp @@ -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,8 +517,10 @@ folder \"mentions\"." (client:update-timeline timeline kind folder - :min-id max-id - :local localp) + :recover-from-skipped-statuses t + :recover-count recover-count + :min-id max-id + :local localp) (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 @@ -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,8 +546,10 @@ Starting from the oldest toot and going back." (client:update-timeline timeline kind folder - :max-id min-id - :local localp) + :recover-count recover-count + :recover-from-skipped-statuses t + :max-id min-id + :local localp) (let ((refresh-event (make-instance 'refresh-thread-windows-event))) (push-event refresh-event))))) (notify-procedure #'update