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

- added a configuration directive to filter out unwanted hashtags.

This commit is contained in:
cage 2022-11-29 18:55:03 +01:00
parent ba320d849b
commit 37d657cff5
5 changed files with 112 additions and 81 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

18
src/db.lisp
View File

@ -761,6 +761,14 @@
(return-from boost-ignored-p t))) (return-from boost-ignored-p t)))
nil)) 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) (defun acct->user (acct)
"Convert `acct' (acct is synonyym for username in mastodon account) "Convert `acct' (acct is synonyym for username in mastodon account)
to the corresponding row in table +table-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) (:and (:= :day actual-day)
(:= :tag tag))))))))) (:= :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) (defmethod update-db ((object tooter:status)
&key &key
(timeline +local-timeline+) (timeline +local-timeline+)
@ -1252,8 +1267,7 @@ than (swconf:config-purge-history-days-offset) days in the past"
(tag-names (if tags (tag-names (if tags
(mapcar #'client:tag-name tags) (mapcar #'client:tag-name tags)
"")) ""))
(actual-tags (join-with-strings tag-names (actual-tags (concat-tags object))
+tag-separator+))
(actual-language (prepare-for-db language)) (actual-language (prepare-for-db language))
;; use string-downcase as a workaround because tooter return an upcased keyword ;; use string-downcase as a workaround because tooter return an upcased keyword
(actual-visibility (string-downcase (prepare-for-db visibility))) (actual-visibility (string-downcase (prepare-for-db visibility)))

2
src/modeline-window.lisp
View File

@ -82,7 +82,7 @@
(mapping-code->fn mapping-code->fn) (mapping-code->fn mapping-code->fn)
(parsed-modeline parsed-modeline)) object (parsed-modeline parsed-modeline)) object
;; parsed is like '("foo" (:key "a") "bar" ...) ;; parsed is like '("foo" (:key "a") "bar" ...)
(let ((res (make-tui-string ""))) (let ((res (make-tui-string "")))
(loop for i in parsed-modeline do (loop for i in parsed-modeline do
(let ((executed (cond (let ((executed (cond
((listp i) ((listp i)

2
src/package.lisp
View File

@ -861,6 +861,7 @@
:account-ignored-p :account-ignored-p
:user-ignored-p :user-ignored-p
:boost-ignored-p :boost-ignored-p
:tags-ignored-p
:acct->user :acct->user
:acct->id :acct->id
:username->id :username->id
@ -1241,6 +1242,7 @@
:color-regexps :color-regexps
:ignore-users-regexps :ignore-users-regexps
:ignore-users-boost-regexps :ignore-users-boost-regexps
:ignore-tag-regexps
:win-bg :win-bg
:win-fg :win-fg
:win-height :win-height

3
src/program-events.lisp
View File

@ -388,6 +388,7 @@
(status-id (tooter:id status)) (status-id (tooter:id status))
(language (tooter:language status)) (language (tooter:language status))
(rebloggedp (tooter:parent status)) (rebloggedp (tooter:parent status))
(tags (db::concat-tags status))
(skip-this-status nil)) (skip-this-status nil))
(when force-saving-of-ignored-status-p (when force-saving-of-ignored-status-p
(db:remove-from-status-ignored status-id folder timeline-type)) (db:remove-from-status-ignored status-id folder timeline-type))
@ -398,6 +399,8 @@
language)) language))
(and rebloggedp (and rebloggedp
(db:boost-ignored-p account-id)) (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* (hooks:run-hook-until-success 'hooks:*skip-message-hook*
status status
timeline-type timeline-type

168
src/software-configuration.lisp
View File

@ -17,85 +17,87 @@
(in-package :software-configuration) (in-package :software-configuration)
;; CONFIG := (ENTRIES)* ;; CONFIG := (ENTRIES)*
;; ENTRIES := COMMENT* ;; ENTRIES := COMMENT*
;; (USE-FILE ;; (USE-FILE
;; | IGNORE-USER-RE-ASSIGN ;; | IGNORE-USER-RE-ASSIGN
;; | IGNORE-USER-BOOST-RE-ASSIGN ;; | IGNORE-USER-BOOST-RE-ASSIGN
;; | COLOR-RE-ASSIGN ;; | IGNORE-TAG-RE-ASSIGN
;; | SERVER-ASSIGN ;; | COLOR-RE-ASSIGN
;; | USERNAME-ASSIGN ;; | SERVER-ASSIGN
;; | OPEN-LINK-HELPER ;; | USERNAME-ASSIGN
;; | POST-ALLOWED-LANGUAGE ;; | OPEN-LINK-HELPER
;; | GENERIC-ASSIGN) ;; | POST-ALLOWED-LANGUAGE
;; COMMENT* ;; | GENERIC-ASSIGN)
;; SERVER-ASSIGN := SERVER-KEY BLANKS ASSIGN BLANKS GENERIC-VALUE BLANKS ;; COMMENT*
;; USERNAME-ASSIGN := USERNAME-KEY BLANKS WITH BLANKS GENERIC-VALUE BLANKS ;; SERVER-ASSIGN := SERVER-KEY BLANKS ASSIGN BLANKS GENERIC-VALUE BLANKS
;; OPEN-LINK-HELPER := OPEN-LINK-HELPER-KEY BLANKS ASSIGN BLANKS ;; USERNAME-ASSIGN := USERNAME-KEY BLANKS WITH BLANKS GENERIC-VALUE BLANKS
;; REGEXP PROGRAM-NAME BLANKS USE-CACHE? NOWAIT? ;; OPEN-LINK-HELPER := OPEN-LINK-HELPER-KEY BLANKS ASSIGN BLANKS
;; GENERIC-ASSIGN := (and key blanks assign blanks ;; REGEXP PROGRAM-NAME BLANKS USE-CACHE? NOWAIT?
;; (or quoted-string ;; GENERIC-ASSIGN := (and key blanks assign blanks
;; hexcolor ;; (or quoted-string
;; colorname ;; hexcolor
;; generic-value) ; the order in this list *is* important ;; colorname
;; blanks) ;; generic-value) ; the order in this list *is* important
;; IGNORE-USER-RE-ASSIGN := IGNORE-USER-RE-KEY ASSIGN REGEXP ;; blanks)
;; IGNORE-USER-RE-ASSIGN := IGNORE-USER-RE-KEY ASSIGN REGEXP
;; IGNORE-USER-BOOST-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) ;; IGNORE-TAG-RE-ASSIGN := IGNORE-USER-RE-KEY ASSIGN REGEXP
;; USE-FILE := (AND USE BLANKS FILEPATH BLANKS) ;; COLOR-RE-ASSIGN := COLOR-RE-KEY ASSIGN REGEXP FG-COLOR (? ATTRIBUTE-VALUE)
;; POST-ALLOWED-LANGUAGE := "post-allowed-language" BLANKS ASSIGN REGEXP ;; USE-FILE := (AND USE BLANKS FILEPATH BLANKS)
;; KEY := FIELD (FIELD-SEPARATOR KEY)* ;; POST-ALLOWED-LANGUAGE := "post-allowed-language" BLANKS ASSIGN REGEXP
;; BLANKS := (BLANK)* ;; KEY := FIELD (FIELD-SEPARATOR KEY)*
;; FILEPATH := QUOTED-STRING ;; BLANKS := (BLANK)*
;; PROGRAM-NAME := QUOTED-STRING ;; FILEPATH := QUOTED-STRING
;; USE-CACHE := USE BLANKS CACHE ;; PROGRAM-NAME := QUOTED-STRING
;; NOWAIT := NO BLANKS WAIT BLANKS (BUFFER-LABEL BLANKS DIGIT+)? ;; USE-CACHE := USE BLANKS CACHE
;; NO := "no" ;; NOWAIT := NO BLANKS WAIT BLANKS (BUFFER-LABEL BLANKS DIGIT+)?
;; WAIT := "wait" ;; NO := "no"
;; CACHE := "cache" ;; WAIT := "wait"
;; USE := "use" ;; CACHE := "cache"
;; SERVER-KEY := "server" ;; USE := "use"
;; USERNAME-KEY := "username" ;; SERVER-KEY := "server"
;; COLOR-RE-KEY := "color-regexp" ;; USERNAME-KEY := "username"
;; IGNORE-USER-RE-KEY := "ignore-user-regexp" ;; COLOR-RE-KEY := "color-regexp"
;; OPEN := "open" ;; IGNORE-USER-RE-KEY := "ignore-user-regexp"
;; OPEN-LINK-HELPER-KEY := OPEN ;; OPEN := "open"
;; WITH-KEY := "with" ;; OPEN-LINK-HELPER-KEY := OPEN
;; BUFFER-LABEL := "buffer" ;; WITH-KEY := "with"
;; REGEXP := QUOTED-STRING ;; BUFFER-LABEL := "buffer"
;; QUOTED-STRING := #\" (not #\") #\" ;; REGEXP := QUOTED-STRING
;; FIELD := ( (or ESCAPED-CHARACTER ;; QUOTED-STRING := #\" (not #\") #\"
;; (not #\# ASSIGN BLANK FIELD-SEPARATOR) )* ;; FIELD := ( (or ESCAPED-CHARACTER
;; COMMENT := BLANKS #\# (not #\Newline)* BLANKS ;; (not #\# ASSIGN BLANK FIELD-SEPARATOR) )*
;; FIELD-SEPARATOR := #\. ;; COMMENT := BLANKS #\# (not #\Newline)* BLANKS
;; GENERIC-VALUE := KEY ;; FIELD-SEPARATOR := #\.
;; ASSIGN := #\= ;; GENERIC-VALUE := KEY
;; BLANK := (or #\space #\Newline #\Tab) ;; ASSIGN := #\=
;; BG-COLOR := COLOR ;; BLANK := (or #\space #\Newline #\Tab)
;; FG-COLOR := COLOR ;; BG-COLOR := COLOR
;; COLOR := HEX-COLOR | COLOR-NAME ;; FG-COLOR := COLOR
;; HEX-COLOR := HEXCOLOR-PREFIX ;; COLOR := HEX-COLOR | COLOR-NAME
;; HEXDIGIT HEXDIGIT -> red ;; HEX-COLOR := HEXCOLOR-PREFIX
;; HEXDIGIT HEXDIGIT -> green ;; HEXDIGIT HEXDIGIT -> red
;; HEXDIGIT HEXDIGIT -> blue ;; HEXDIGIT HEXDIGIT -> green
;; ESCAPED-CHARACTER := #\\ any-character ;; HEXDIGIT HEXDIGIT -> blue
;; HEXCOLOR-PREFIX := #\# ;; ESCAPED-CHARACTER := #\\ any-character
;; HEX-DIGIT := (and (character-ranges #\0 #\9) ;; HEXCOLOR-PREFIX := #\#
;; (character-ranges #\a #\f) ;; HEX-DIGIT := (and (character-ranges #\0 #\9)
;; (character-ranges #\A #\f) ;; (character-ranges #\a #\f)
;; DIGIT := (character-ranges #\0 #\9) ;; (character-ranges #\A #\f)
;; ATTRIBUTE-VALUE := "bold" ;; DIGIT := (character-ranges #\0 #\9)
;; | "italic" ;; ATTRIBUTE-VALUE := "bold"
;; | "underline" ;; | "italic"
;; | "blink" ;; | "underline"
;; COLOR-NAME := "black" ;; | "blink"
;; | "red" ;; COLOR-NAME := "black"
;; | "green" ;; | "red"
;; | "yellow" ;; | "green"
;; | "blue" ;; | "yellow"
;; | "magenta" ;; | "blue"
;; | "cyan" ;; | "magenta"
;; | "white" ;; | "cyan"
;; | "white"
(define-constant +conf-filename+ "main.conf" :test #'string=) (define-constant +conf-filename+ "main.conf" :test #'string=)
@ -272,6 +274,9 @@
(defrule ignore-user-boost-re-key "ignore-user-boost-regexp" (defrule ignore-user-boost-re-key "ignore-user-boost-regexp"
(:constant :ignore-user-boost-re)) (:constant :ignore-user-boost-re))
(defrule ignore-tag-re-assign "ignore-tag-regexp"
(:constant :ignore-tag-re))
(defrule ignore-user-re-assign (defrule ignore-user-re-assign
(and ignore-user-re-key blanks (and ignore-user-re-key blanks
assign blanks regexp blanks) assign blanks regexp blanks)
@ -439,6 +444,7 @@
color-re-assign color-re-assign
ignore-user-re-assign ignore-user-re-assign
ignore-user-boost-re-assign ignore-user-boost-re-assign
ignore-tag-re-assign
server-assign server-assign
username-assign username-assign
open-link-helper open-link-helper
@ -622,6 +628,7 @@
color-re color-re
ignore-user-re ignore-user-re
ignore-user-boost-re ignore-user-boost-re
ignore-tag-re
post-allowed-language post-allowed-language
purge-history-days-offset purge-history-days-offset
purge-cache-days-offset purge-cache-days-offset
@ -644,6 +651,7 @@
((or (eq +key-color-re+ key) ((or (eq +key-color-re+ key)
(eq +key-ignore-user-re+ key) (eq +key-ignore-user-re+ key)
(eq +key-ignore-user-boost-re+ key) (eq +key-ignore-user-boost-re+ key)
(eq +key-ignore-tag-re+ key)
(eq +key-open-link-helper+ key) (eq +key-open-link-helper+ key)
(eq +key-post-allowed-language+ key)) (eq +key-post-allowed-language+ key))
(setf (access:accesses *software-configuration* key) (setf (access:accesses *software-configuration* key)
@ -967,6 +975,10 @@
(access:accesses *software-configuration* (access:accesses *software-configuration*
+key-ignore-user-boost-re+)) +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) (defmacro gen-win-key-access (fn-suffix key)
`(defun ,(misc:format-fn-symbol t "win-~a" fn-suffix) (win-key) `(defun ,(misc:format-fn-symbol t "win-~a" fn-suffix) (win-key)
(access:accesses *software-configuration* (access:accesses *software-configuration*