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)))
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)))

2
src/modeline-window.lisp
View File

@ -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)

2
src/package.lisp
View File

@ -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

3
src/program-events.lisp
View File

@ -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

168
src/software-configuration.lisp
View File

@ -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*