- added support for announcements.

etc/default-theme.conf

@@ -19,6 +19,10 @@
 # - underline
 # - blink
 
+announcements.icon                                   = "📣"
+
+announcements.separator                              = "∴ ∴ ∴"
+
 left-arrow                                           = "←"
 
 # The text that starts the title section of a window
@@ -155,12 +159,13 @@ thread-window.modeline.foreground                    = yellow
 
 # shown as a prefix for mentions in the modeline
 
-thread-window.modeline.notification-icon.value       = "📣"
+thread-window.modeline.notification-icon.value       = "🔔"
 
 # this  variable  customize the  information  that  the modeline  will
 # shows, values prefixed with a '%' will be expanded, allowe values to
 # be expanded are:
 
+# - %A announcements notification
 # - %m mentions count
 # - %u user account
 # - %s server connected to
@@ -171,7 +176,7 @@ thread-window.modeline.notification-icon.value       = "📣"
 # - %tags in selected messages (if any)
 # - %% a percent sign
 
-thread-window.modeline.value                         = "%m %u@%s ◈ %k %r/%t ◈ folder: %f ◈ tags: %h"
+thread-window.modeline.value                         = "%A %m %u@%s ◈ %k %r/%t ◈ folder: %f ◈ tags: %h"
 
 # this is  the only width  you have to  specify as the  others windows
 # just fills the void left by this one

etc/init.lisp

@@ -159,6 +159,8 @@
 
 (define-key "C-a"       #'show-about-window)
 
+(define-key "A"         #'show-announcements)
+
 (define-key "C-h A"     #'apropos-help-global)
 
 (define-key "C-h a"     #'apropos-help)

src/api-client.lisp

@@ -268,13 +268,23 @@ Returns nil if the user did not provided a server in the configuration file"
          ,@remaining-forms))))
 
 (defun-api-call get-announcements ()
-    "Get all the non dismissed announcements"
+  "Get all the non dismissed announcements"
-  (tooter:get-announcements *client* :with-dismissed nil))
+  (let ((all-announcements (tooter:get-announcements *client* :with-dismissed nil)))
+    ;; even if asked for non dismissed posts, the server returns all the
+    ;; announcements anyway...
+    (remove-if #'tooter:readp all-announcements)))
 
 (defun-api-call dismiss-announcement (announcement-id)
-  "Dismisse an announcement identified by `announcement-id'"
+  "Dismiss an announcement identified by `announcement-id'"
   (tooter:dismiss-announcement *client* announcement-id))
 
+(defun dismiss-all-announcements (&optional announcements)
+  (loop for announcement in (or announcements
+                                (get-announcements))
+        do
+           (dismiss-announcement (tooter:id announcement)))
+  announcements)
+
 (defun-api-call favourite-status (status-id)
     "Favourite a status identified by `status-id'"
   (tooter:favourite *client*

src/package.lisp

@@ -1435,6 +1435,8 @@
    :config-gopher-line-prefix-attribute
    :config-gopher-line-prefix-foreground
    :config-default-post-language
+   :config-announcements-separator
+   :config-announcements-icon
    :link-regex->program-to-use
    :link-regex->program-to-use-buffer-size
    :use-tinmop-as-external-program-p
@@ -1745,6 +1747,8 @@
    :redraw-window-event
    :send-to-pipe-event
    :print-mentions-event
+   :show-announcements-event
+   :check-announcements-event
    :delete-all-notifications-event
    :dispatch-program-events
    :dispatch-program-events-or-wait))
@@ -1804,6 +1808,7 @@
    :defun-api-call
    :get-announcements
    :dismiss-announcement
+   :dismiss-all-announcements
    :favourite-status
    :unfavourite-status
    :reblog-status
@@ -2372,6 +2377,8 @@
    :timeline-type
    :timeline-folder
    :mentions-count
+   :add-announcements-notification
+   :remove-announcements-notification
    :grow-tree-to-fit-window
    :fit-timeline-to-window
    :go-message-down
@@ -3154,7 +3161,8 @@
    :file-explorer-download-mirror
    :clear-cache
    :print-mentions
-   :delete-notifications))
+   :delete-notifications
+   :show-announcements))
 
 (defpackage :scheduled-events
   (:use

src/program-events.lisp

@@ -1872,6 +1872,34 @@
            (windows:win-clear message-window)
            (windows:draw message-window)))))))
 
+(defclass show-announcements-event (program-event) ())
+
+(defmethod process-event ((object show-announcements-event))
+  "Shows a window with all announcements"
+  (when-let* ((all-announcements (api-client:get-announcements))
+              (all-texts         (mapcar #'html-utils:html->text
+                                         (mapcar #'tooter:content all-announcements)))
+              (lines             (reduce #'append
+                                         (mapcar #'text-utils:split-lines all-texts)))
+              (window-content    (text-utils:join-with-strings* (swconf:config-announcements-separator)
+                                                                lines)))
+    (api-client:dismiss-all-announcements all-announcements)
+    (line-oriented-window:make-blocking-list-dialog-window specials:*main-window*
+                                                           window-content
+                                                           window-content
+                                                           nil
+                                                           (_ "Announcements "))
+    (push-event (make-instance 'check-announcements-event))))
+
+(defclass check-announcements-event (program-event) ())
+
+(defmethod process-event ((object check-announcements-event))
+  "Shows a window with all announcements"
+  (if (api-client:get-announcements)
+      (thread-window:add-announcements-notification specials:*thread-window*)
+      (thread-window:remove-announcements-notification specials:*thread-window*))
+  (windows:draw specials:*thread-window*))
+
 ;;;; end events
 
 (defun dispatch-program-events ()

src/scheduled-events.lisp

@@ -23,7 +23,9 @@
 
 (define-constant +refresh-gemlog-subscriptions-frequency+ 50000 :test #'=)
 
-(define-constant +purge-gemlog-entries+                   30000 :test #'=)
+(define-constant +purge-gemlog-entries-frequency+         30000 :test #'=)
+
+(define-constant +announcements-check-frequency+          10000 :test #'=)
 
 (defun triggedp (ticks frequency)
   (= (rem ticks frequency)
@@ -50,7 +52,7 @@
                          +refresh-gemlog-subscriptions-frequency+)
   (ui:gemlog-refresh-all))
 
-(gen-scheduler-function (purge-gemlog-entries +purge-gemlog-entries+)
+(gen-scheduler-function (purge-gemlog-entries +purge-gemlog-entries-frequency+)
   (ui:notify (_ "Removing old gemlog posts…"))
   (db:purge-seen-gemlog-entries)
   (ui:notify (_ "Removed")))
@@ -63,6 +65,11 @@
                                      :chat (message-window:metadata *message-window*))))
       (program-events:push-event show-event))))
 
+(gen-scheduler-function (look-for-announcements
+                         +announcements-check-frequency+)
+  (when *thread-window*
+    (program-events:push-event (make-instance 'program-events:check-announcements-event))))
+
 (gen-at-boot-function purge-history
   (db:purge-history))
 
@@ -77,6 +84,8 @@
   (when (api-pleroma:instance-pleroma-p)
     (refresh-all-chats-messages ticks)
     (refresh-all-chats-data ticks))
+  (when (not (api-pleroma:instance-pleroma-p))
+    (look-for-announcements ticks))
   (refresh-gemlog-subscriptions ticks)
   (purge-gemlog-entries ticks)
   (purge-history)

src/software-configuration.lisp

@@ -552,6 +552,7 @@
                    notify-window
                    gempub-library-window
                    notification-icon
+                   icon
                    life
                    quick-help
                    more-choices
@@ -589,6 +590,8 @@
                    command-window
                    file-explorer
                    command-separator
+                   separator
+                   announcements
                    gemini
                    gemlog
                    gempub
@@ -1596,12 +1599,19 @@
                                                          +key-input+
                                                          +key-foreground+))))
 
-(gen-simple-access (default-post-language
+(gen-simple-access (default-post-language)
-                    :transform-value-fn identity)
                     +key-default+
                     +key-post+
                     +key-language+)
 
+(gen-simple-access (announcements-separator)
+                    +key-announcements+
+                    +key-separator+)
+
+(gen-simple-access (announcements-icon)
+                    +key-announcements+
+                    +key-icon+)
+
 ;;;;;; tests
 
 (defun trivial-configuration-missing-value-check ()
@@ -1630,6 +1640,7 @@
                    #'message-window-line-mark-values
                    #'message-window-attachments-header
                    #'config-post-allowed-language
-                   #'config-default-post-language)
+                   #'config-default-post-language
+                   #'config-announcements-separator)
         do
            (funcall fn)))

src/thread-window.lisp

@@ -116,7 +116,12 @@
    (mentions
     :initform ()
     :initarg  :mentions
-    :accessor mentions)))
+    :accessor mentions)
+   (announcements
+    :initform nil
+    :initarg  :announcements
+    :accessor announcements)))
+
 
 (defmacro lambda-ignore-args (args &body body)
   `(lambda (,@args)
@@ -193,6 +198,15 @@
                   (length mentions)))
         "")))
 
+(defun expand-announcements (window)
+  (with-accessors ((announcements announcements)) window
+    (if announcements
+        (with-tuify-results (window)
+          (format nil
+                  "~a"
+                  (swconf:config-announcements-icon)))
+        "")))
+
 (defun default-expander ()
   (list (cons "%" (lambda (w) (with-tuify-results (w) "%")))
         (cons "s" (lambda (w) (with-tuify-results (w) (swconf:config-server-name))))
@@ -202,7 +216,8 @@
         (cons "h" #'expand-message-hashtags)
         (cons "t" #'expand-total-messages)
         (cons "r" #'expand-redp-messages)
-        (cons "m" #'expand-mentions)))
+        (cons "m" #'expand-mentions)
+        (cons "A" #'expand-announcements)))
 
 (defmethod initialize-instance :after ((object thread-window) &key &allow-other-keys)
   (with-accessors ((mapping-code->fn mapping-code->fn)) object
@@ -324,6 +339,10 @@
 
 (defgeneric remove-mention (object status-id))
 
+(defgeneric add-announcements-notification (object))
+
+(defgeneric remove-announcements-notification (object))
+
 (defun message-root (tree)
   (mtree:root-node tree))
 
@@ -1021,6 +1040,12 @@ db:renumber-timeline-message-index."
                      mentions))
     object))
 
+(defmethod add-announcements-notification ((object thread-window))
+  (setf (announcements object) t))
+
+(defmethod remove-announcements-notification ((object thread-window))
+  (setf (announcements object) nil))
+
 (defgeneric marked-to-delete-p (object))
 
 (defmethod marked-to-delete-p ((object line))

src/ui-goodies.lisp

@@ -3478,3 +3478,8 @@ gemini client certificates!)."
   "Delete all the notification from server"
   (info-message (_ "Getting all notification, please wait…"))
   (push-event (make-instance 'delete-all-notifications-event)))
+
+(defun show-announcements ()
+  "Show an informative window about instance's announcements"
+  (info-message (_ "Getting all announcements, please wait…"))
+  (push-event (make-instance 'show-announcements-event)))