From dff23fe909fdbfea9c59982d979f5e0566de85d6 Mon Sep 17 00:00:00 2001
From: cage <cage@invalid>
Date: Wed, 13 Oct 2021 15:01:15 +0200
Subject: [PATCH] - allowed skipping posts using language type.

---
 etc/shared.conf                 |  4 ++++
 src/package.lisp                |  1 +
 src/program-events.lisp         |  4 ++++
 src/software-configuration.lisp | 22 +++++++++++++++++++---
 4 files changed, 28 insertions(+), 3 deletions(-)

diff --git a/etc/shared.conf b/etc/shared.conf
index ed74b5d..1b47d07 100644
--- a/etc/shared.conf
+++ b/etc/shared.conf
@@ -37,6 +37,10 @@ purge-cache-days-offset                     = -7
 # chosen editor (as shell command line) for compose a message
 editor                                      = "nano --locking"
 
+# allowed languages post, if the regex does not match the post's language the post is discarded
+
+post-allowed-language                       = ".*"
+
 # update gemlog subscriptions when program starts
 # (default 'no', change to 'yes' if desired)
 start.update.gemlog                         = yes
diff --git a/src/package.lisp b/src/package.lisp
index 5947d93..4a77680 100644
--- a/src/package.lisp
+++ b/src/package.lisp
@@ -1214,6 +1214,7 @@
    :tree-config-rendering-values
    :make-tree-colormap
    :left-arrow
+   :config-post-allowed-language
    :config-purge-history-days-offset
    :config-purge-cage-days-offset
    :config-notification-life
diff --git a/src/program-events.lisp b/src/program-events.lisp
index 30e521d..fd406ac 100644
--- a/src/program-events.lisp
+++ b/src/program-events.lisp
@@ -375,11 +375,15 @@
       (loop for status in statuses do
         (let ((account-id (tooter:id (tooter:account status)))
               (status-id  (tooter:id status))
+              (language   (tooter:language status))
               (skip-this-status nil))
           (when force-saving-of-ignored-status-p
             (db:remove-from-status-ignored status-id folder timeline-type))
           (when (or (and (db:user-ignored-p account-id)
                          (not (db:status-skipped-p status-id folder timeline-type)))
+                    (and language
+                         (cl-ppcre:scan (swconf:config-post-allowed-language)
+                                        language))
                     (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 49e1ff2..07f9fcc 100644
--- a/src/software-configuration.lisp
+++ b/src/software-configuration.lisp
@@ -25,11 +25,13 @@
 ;;                          | 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?
+;; 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
@@ -39,6 +41,7 @@
 ;; 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)
+;; POST-ALLOWED-LANGUAGE := "post-allowed-language" BLANKS ASSIGN REGEXP
 ;; KEY                   := FIELD (FIELD-SEPARATOR KEY)*
 ;; BLANKS                := (BLANK)*
 ;; FILEPATH              := QUOTED-STRING
@@ -360,6 +363,10 @@
                                             (elt args 6)
                                             (elt args 8)
                                             :wait (not (elt args 9)))))))
+
+(defrule post-allowed-language (and "post-allowed-language" blanks assign regexp)
+  (:function remove-if-null))
+
 (defrule filepath quoted-string)
 
 (defparameter *already-included-files* ())
@@ -382,6 +389,7 @@
              server-assign
              username-assign
              open-link-helper
+             post-allowed-language
              generic-assign)
          (* comment))
   (:function second))
@@ -537,6 +545,7 @@
                    password-echo-character
                    color-re
                    ignore-user-re
+                   post-allowed-language
                    purge-history-days-offset
                    purge-cache-days-offset)
 
@@ -556,7 +565,8 @@
         (cond
           ((or (eq +key-color-re+ key)
                (eq +key-ignore-user-re+ key)
-               (eq +key-open-link-helper+ key))
+               (eq +key-open-link-helper+ key)
+               (eq +key-post-allowed-language+ key))
            (setf (access:accesses *software-configuration* key)
                  (append (access:accesses *software-configuration* key)
                          (list value))))
@@ -879,6 +889,11 @@
      (,transform-value-fn (access:accesses *software-configuration*
                                            ,@keys))))
 
+(gen-simple-access (post-allowed-language
+                    :transform-value-fn
+                    (lambda (a) (cl-ppcre:create-scanner a :case-insensitive-mode t)))
+                   +key-post-allowed-language+)
+
 (gen-simple-access (purge-history-days-offset
                     :transform-value-fn
                     (lambda (a)
@@ -1369,6 +1384,7 @@
                    #'message-window-locked-account-mark
                    #'message-window-unlocked-account-mark
                    #'message-window-line-mark-values
-                   #'message-window-attachments-header)
+                   #'message-window-attachments-header
+                   #'config-post-allowed-language)
         do
            (funcall fn)))