From 37d657cff5b15eb4fa22529a2389091381d60dc0 Mon Sep 17 00:00:00 2001 From: cage Date: Tue, 29 Nov 2022 18:55:03 +0100 Subject: [PATCH] - added a configuration directive to filter out unwanted hashtags. --- src/db.lisp | 18 +++- src/modeline-window.lisp | 2 +- src/package.lisp | 2 + src/program-events.lisp | 3 + src/software-configuration.lisp | 168 +++++++++++++++++--------------- 5 files changed, 112 insertions(+), 81 deletions(-) diff --git a/src/db.lisp b/src/db.lisp index 0518618..941d271 100644 --- a/src/db.lisp +++ b/src/db.lisp @@ -761,6 +761,14 @@ (return-from boost-ignored-p t))) nil)) +(defun tags-ignored-p (tags) + "Returns non nil if theh tags of a status must be filtered out" + (when-let ((ignore-regexps (swconf:ignore-tag-regexps))) + (loop for ignore-re in ignore-regexps do + (when (cl-ppcre:scan ignore-re tags) + (return-from tags-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+" @@ -1216,6 +1224,13 @@ than (swconf:config-purge-history-days-offset) days in the past" (:and (:= :day actual-day) (:= :tag tag))))))))) +(defun concat-tags (status) + (with-accessors ((tags tooter:tags)) status + (if tags + (join-with-strings (mapcar #'client:tag-name tags) + +tag-separator+) + ""))) + (defmethod update-db ((object tooter:status) &key (timeline +local-timeline+) @@ -1252,8 +1267,7 @@ than (swconf:config-purge-history-days-offset) days in the past" (tag-names (if tags (mapcar #'client:tag-name tags) "")) - (actual-tags (join-with-strings tag-names - +tag-separator+)) + (actual-tags (concat-tags object)) (actual-language (prepare-for-db language)) ;; use string-downcase as a workaround because tooter return an upcased keyword (actual-visibility (string-downcase (prepare-for-db visibility))) diff --git a/src/modeline-window.lisp b/src/modeline-window.lisp index ebf5a07..f535b5a 100644 --- a/src/modeline-window.lisp +++ b/src/modeline-window.lisp @@ -82,7 +82,7 @@ (mapping-code->fn mapping-code->fn) (parsed-modeline parsed-modeline)) object ;; parsed is like '("foo" (:key "a") "bar" ...) - (let ((res (make-tui-string ""))) + (let ((res (make-tui-string ""))) (loop for i in parsed-modeline do (let ((executed (cond ((listp i) diff --git a/src/package.lisp b/src/package.lisp index 2c21813..75d9d6c 100644 --- a/src/package.lisp +++ b/src/package.lisp @@ -861,6 +861,7 @@ :account-ignored-p :user-ignored-p :boost-ignored-p + :tags-ignored-p :acct->user :acct->id :username->id @@ -1241,6 +1242,7 @@ :color-regexps :ignore-users-regexps :ignore-users-boost-regexps + :ignore-tag-regexps :win-bg :win-fg :win-height diff --git a/src/program-events.lisp b/src/program-events.lisp index 19e0b7c..a71472d 100644 --- a/src/program-events.lisp +++ b/src/program-events.lisp @@ -388,6 +388,7 @@ (status-id (tooter:id status)) (language (tooter:language status)) (rebloggedp (tooter:parent status)) + (tags (db::concat-tags status)) (skip-this-status nil)) (when force-saving-of-ignored-status-p (db:remove-from-status-ignored status-id folder timeline-type)) @@ -398,6 +399,8 @@ language)) (and rebloggedp (db:boost-ignored-p account-id)) + (and (text-utils:string-not-empty-p tags) + (db:tags-ignored-p tags)) (hooks:run-hook-until-success 'hooks:*skip-message-hook* status timeline-type diff --git a/src/software-configuration.lisp b/src/software-configuration.lisp index 4b79962..053adb4 100644 --- a/src/software-configuration.lisp +++ b/src/software-configuration.lisp @@ -17,85 +17,87 @@ (in-package :software-configuration) -;; CONFIG := (ENTRIES)* -;; ENTRIES := COMMENT* -;; (USE-FILE -;; | IGNORE-USER-RE-ASSIGN -;; | IGNORE-USER-BOOST-RE-ASSIGN -;; | COLOR-RE-ASSIGN -;; | SERVER-ASSIGN -;; | USERNAME-ASSIGN -;; | OPEN-LINK-HELPER -;; | POST-ALLOWED-LANGUAGE -;; | GENERIC-ASSIGN) -;; COMMENT* -;; SERVER-ASSIGN := SERVER-KEY BLANKS ASSIGN BLANKS GENERIC-VALUE BLANKS -;; USERNAME-ASSIGN := USERNAME-KEY BLANKS WITH BLANKS GENERIC-VALUE BLANKS -;; OPEN-LINK-HELPER := OPEN-LINK-HELPER-KEY BLANKS ASSIGN BLANKS -;; REGEXP PROGRAM-NAME BLANKS USE-CACHE? NOWAIT? -;; GENERIC-ASSIGN := (and key blanks assign blanks -;; (or quoted-string -;; hexcolor -;; colorname -;; generic-value) ; the order in this list *is* important -;; blanks) -;; IGNORE-USER-RE-ASSIGN := IGNORE-USER-RE-KEY ASSIGN REGEXP +;; CONFIG := (ENTRIES)* +;; ENTRIES := COMMENT* +;; (USE-FILE +;; | IGNORE-USER-RE-ASSIGN +;; | IGNORE-USER-BOOST-RE-ASSIGN +;; | IGNORE-TAG-RE-ASSIGN +;; | COLOR-RE-ASSIGN +;; | SERVER-ASSIGN +;; | USERNAME-ASSIGN +;; | OPEN-LINK-HELPER +;; | POST-ALLOWED-LANGUAGE +;; | GENERIC-ASSIGN) +;; COMMENT* +;; SERVER-ASSIGN := SERVER-KEY BLANKS ASSIGN BLANKS GENERIC-VALUE BLANKS +;; USERNAME-ASSIGN := USERNAME-KEY BLANKS WITH BLANKS GENERIC-VALUE BLANKS +;; OPEN-LINK-HELPER := OPEN-LINK-HELPER-KEY BLANKS ASSIGN BLANKS +;; REGEXP PROGRAM-NAME BLANKS USE-CACHE? NOWAIT? +;; GENERIC-ASSIGN := (and key blanks assign blanks +;; (or quoted-string +;; hexcolor +;; colorname +;; generic-value) ; the order in this list *is* important +;; blanks) +;; IGNORE-USER-RE-ASSIGN := IGNORE-USER-RE-KEY ASSIGN REGEXP ;; IGNORE-USER-BOOST-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) -;; POST-ALLOWED-LANGUAGE := "post-allowed-language" BLANKS ASSIGN REGEXP -;; KEY := FIELD (FIELD-SEPARATOR KEY)* -;; BLANKS := (BLANK)* -;; FILEPATH := QUOTED-STRING -;; PROGRAM-NAME := QUOTED-STRING -;; USE-CACHE := USE BLANKS CACHE -;; NOWAIT := NO BLANKS WAIT BLANKS (BUFFER-LABEL BLANKS DIGIT+)? -;; NO := "no" -;; WAIT := "wait" -;; CACHE := "cache" -;; USE := "use" -;; SERVER-KEY := "server" -;; USERNAME-KEY := "username" -;; COLOR-RE-KEY := "color-regexp" -;; IGNORE-USER-RE-KEY := "ignore-user-regexp" -;; OPEN := "open" -;; OPEN-LINK-HELPER-KEY := OPEN -;; WITH-KEY := "with" -;; BUFFER-LABEL := "buffer" -;; 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 -;; HEXDIGIT HEXDIGIT -> red -;; HEXDIGIT HEXDIGIT -> green -;; HEXDIGIT HEXDIGIT -> blue -;; ESCAPED-CHARACTER := #\\ any-character -;; HEXCOLOR-PREFIX := #\# -;; HEX-DIGIT := (and (character-ranges #\0 #\9) -;; (character-ranges #\a #\f) -;; (character-ranges #\A #\f) -;; DIGIT := (character-ranges #\0 #\9) -;; ATTRIBUTE-VALUE := "bold" -;; | "italic" -;; | "underline" -;; | "blink" -;; COLOR-NAME := "black" -;; | "red" -;; | "green" -;; | "yellow" -;; | "blue" -;; | "magenta" -;; | "cyan" -;; | "white" +;; IGNORE-TAG-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) +;; POST-ALLOWED-LANGUAGE := "post-allowed-language" BLANKS ASSIGN REGEXP +;; KEY := FIELD (FIELD-SEPARATOR KEY)* +;; BLANKS := (BLANK)* +;; FILEPATH := QUOTED-STRING +;; PROGRAM-NAME := QUOTED-STRING +;; USE-CACHE := USE BLANKS CACHE +;; NOWAIT := NO BLANKS WAIT BLANKS (BUFFER-LABEL BLANKS DIGIT+)? +;; NO := "no" +;; WAIT := "wait" +;; CACHE := "cache" +;; USE := "use" +;; SERVER-KEY := "server" +;; USERNAME-KEY := "username" +;; COLOR-RE-KEY := "color-regexp" +;; IGNORE-USER-RE-KEY := "ignore-user-regexp" +;; OPEN := "open" +;; OPEN-LINK-HELPER-KEY := OPEN +;; WITH-KEY := "with" +;; BUFFER-LABEL := "buffer" +;; 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 +;; HEXDIGIT HEXDIGIT -> red +;; HEXDIGIT HEXDIGIT -> green +;; HEXDIGIT HEXDIGIT -> blue +;; ESCAPED-CHARACTER := #\\ any-character +;; HEXCOLOR-PREFIX := #\# +;; HEX-DIGIT := (and (character-ranges #\0 #\9) +;; (character-ranges #\a #\f) +;; (character-ranges #\A #\f) +;; DIGIT := (character-ranges #\0 #\9) +;; ATTRIBUTE-VALUE := "bold" +;; | "italic" +;; | "underline" +;; | "blink" +;; COLOR-NAME := "black" +;; | "red" +;; | "green" +;; | "yellow" +;; | "blue" +;; | "magenta" +;; | "cyan" +;; | "white" (define-constant +conf-filename+ "main.conf" :test #'string=) @@ -272,6 +274,9 @@ (defrule ignore-user-boost-re-key "ignore-user-boost-regexp" (:constant :ignore-user-boost-re)) +(defrule ignore-tag-re-assign "ignore-tag-regexp" + (:constant :ignore-tag-re)) + (defrule ignore-user-re-assign (and ignore-user-re-key blanks assign blanks regexp blanks) @@ -439,6 +444,7 @@ color-re-assign ignore-user-re-assign ignore-user-boost-re-assign + ignore-tag-re-assign server-assign username-assign open-link-helper @@ -622,6 +628,7 @@ color-re ignore-user-re ignore-user-boost-re + ignore-tag-re post-allowed-language purge-history-days-offset purge-cache-days-offset @@ -644,6 +651,7 @@ ((or (eq +key-color-re+ key) (eq +key-ignore-user-re+ key) (eq +key-ignore-user-boost-re+ key) + (eq +key-ignore-tag-re+ key) (eq +key-open-link-helper+ key) (eq +key-post-allowed-language+ key)) (setf (access:accesses *software-configuration* key) @@ -967,6 +975,10 @@ (access:accesses *software-configuration* +key-ignore-user-boost-re+)) +(defun ignore-tag-regexps () + (access:accesses *software-configuration* + +key-ignore-tag-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*