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