From 59a9b696051bb78e48085669897cb55fb262e8d5 Mon Sep 17 00:00:00 2001 From: cage Date: Sun, 1 Jan 2023 11:11:40 +0100 Subject: [PATCH] - added a new command 'delete-notifications'; - retrofitted 'add-metadata-to-parsed-gemini-lines' into the main gemini parser; - fixed json generation of parsed lines in 'gemini-stream-info'. --- etc/init.lisp | 2 + src/api-client.lisp | 51 ++++++--- src/gemini/gemini-parser.lisp | 168 +++++++++++++++-------------- src/gui/public-api.lisp | 36 ++++--- src/package.lisp | 8 +- src/program-events.lisp | 32 ++++-- src/tests/gemini-parser-tests.lisp | 6 +- src/ui-goodies.lisp | 5 + 8 files changed, 190 insertions(+), 118 deletions(-) diff --git a/etc/init.lisp b/etc/init.lisp index 56f4a6d..7002e8c 100644 --- a/etc/init.lisp +++ b/etc/init.lisp @@ -378,6 +378,8 @@ (define-key "M" #'print-mentions *thread-keymap*) +(define-key "N d" #'delete-notifications *thread-keymap*) + ;; message window keymap (define-key "up" #'message-scroll-up *message-keymap*) diff --git a/src/api-client.lisp b/src/api-client.lisp index 7a3b048..1c08ba2 100644 --- a/src/api-client.lisp +++ b/src/api-client.lisp @@ -733,9 +733,9 @@ numerical indices identifying the option voting for" :poll :follow-request)) -(defun mentions (max-id &optional (excluded-types (remove :mention +(defun notifications (max-id &optional (excluded-types (remove :mention *all-notification-types*))) - "Get the latest mentions, starting from `min-id` (pass nil to get + "Get the latest mentions, starting from `max-id` (pass nil to get the latest 15 mentions)." (get-notifications :max-id max-id :exclude-types excluded-types)) @@ -748,20 +748,43 @@ the latest 15 mentions)." "Sort entities by id in descending order" (sort list #'status-id<)) +(defun sort-id> (list) + "Sort entities by id in descending order" + (nreverse (sort list #'status-id<))) + (defun all-mentions () "Get all mentions" - (let ((mentions-so-far (sort-id< (mentions nil)))) - (when mentions-so-far - (labels ((%mentions () - (when-let* ((min-id (tooter:id (first mentions-so-far))) - (mentions (sort-id< (mentions min-id)))) - (loop for mention in mentions do - (pushnew mention mentions-so-far :test (make-id=))) - (setf mentions-so-far (sort-id< mentions-so-far)) - (when mentions - (%mentions))))) - (%mentions))) - mentions-so-far)) + (all-notifications (remove :mention *all-notification-types*))) + +(defun all-notifications (excluded-types) + "Get all notifications" + (let ((notifications-so-far (sort-id< (notifications nil excluded-types)))) + (when notifications-so-far + (labels ((%notifications () + (when-let* ((min-id (tooter:id (first notifications-so-far))) + (notifications (sort-id< (notifications min-id excluded-types)))) + + (loop for notification in notifications do + (pushnew notification notifications-so-far :test (make-id=))) + (setf notifications-so-far (sort-id< notifications-so-far)) + (when notifications + (%notifications))))) + (%notifications))) + notifications-so-far)) + +(defun delete-all-notifications (&optional (progress-fn nil)) + (when-let ((notifications (all-notifications nil))) + (loop for notification in notifications do + (delete-notification (tooter:id notification)) + (when (functionp progress-fn) + (funcall progress-fn notification))))) + +(defun notification->text (notification) + (let ((raw-text (format nil + "type: ~a from ~a" + (tooter:kind notification) + (tooter:account-name (tooter:account notification))))) + (tui:make-tui-string raw-text))) (defun update-mentions-folder (&key (delete-mentions-on-server t)) (let ((trees '())) diff --git a/src/gemini/gemini-parser.lisp b/src/gemini/gemini-parser.lisp index 4016b3f..834d9a4 100644 --- a/src/gemini/gemini-parser.lisp +++ b/src/gemini/gemini-parser.lisp @@ -589,7 +589,9 @@ (defun sexp->text-rows (parsed-gemini theme &key (initialize-parser nil)) "This function maintains an internal state, see `with-initialized-parser' macro" - (labels ((header-prefix (prefix header) + (labels ((trim (a) + (trim-blanks a)) + (header-prefix (prefix header) (strcat prefix header)) (header-prefix-h1 (header) (header-prefix (h1-prefix theme) header)) @@ -601,15 +603,22 @@ (let* ((size (length text)) (underline (build-string size underline-char))) underline)) - (make-header (level text underline-char) - (let ((underline (build-underline text underline-char)) - (header-group-id (next-header-group-id))) + (make-header (level text underline-char header-group-id) + (let ((underline (build-underline text underline-char))) (list (make-header-line text header-group-id level nil) (make-header-line underline header-group-id level t)))) + (extract-attribute-value-line (node key) + (html-utils:attribute-value (html-utils:find-attribute key node))) (extract-source-line (node) - (html-utils:attribute-value (html-utils:find-attribute :source-line node))) - (trim (a) - (trim-blanks a)) + (extract-attribute-value-line node :source-line)) + (extract-source-line-id (node) + (extract-attribute-value-line node :source-id)) + (extract-header-group-id (node) + (extract-attribute-value-line node :header-group-id)) + (extract-pre-alt-text (node) + (trim (extract-attribute-value-line node :pre-alt-text))) + (extract-pre-group-id (node) + (extract-attribute-value-line node :pre-group-id)) (text-value (node &key (trim t)) (let ((text (first (html-utils:children node)))) (if trim @@ -621,7 +630,7 @@ (if (text-utils:starting-emoji link-name) (format nil "~a~a" - (text-utils:trim-blanks (link-prefix-other theme)) + (trim (link-prefix-other theme)) link-name) (format nil "~a~a" @@ -641,11 +650,9 @@ :attributes (link-attributes theme) :fgcolor (link-fg theme) :bgcolor (link-bg theme)))) - (pre-alt-text (node) - (trim (html-utils:attribute-value (html-utils:find-attribute :alt node)))) - (make-vertical-space () + (make-vertical-space (header-group-id) (make-instance 'vertical-space - :group-id (current-header-group-id))) + :group-id header-group-id)) (add-source-metadata (thing source-line-id source-line) (cond ((typep thing 'list) @@ -659,68 +666,69 @@ (setf (source-line thing) source-line) thing))) (build-row (node) - (let ((source-line (extract-source-line node)) - (source-line-id (next-source-line-id)) - (res (cond - ((null node) - (make-vertical-space)) - ((html-utils:tag= :as-is node) - (let* ((line (text-value node :trim nil)) - (fg (preformatted-fg theme)) - (line (tui:make-tui-string (format nil "~a" line) - :fgcolor fg))) - (make-pre-line (list line) - (current-header-group-id) - (current-pre-group-id) - (current-pre-alt-text)))) - ((html-utils:tag= :text node) - (let ((text (text-value node :trim t))) - (if (string-not-empty-p text) - (make-simple-line (format nil "~a~%" text) - (current-header-group-id)) - (make-vertical-space)))) - ((html-utils:tag= :h1 node) - (make-header 1 - (header-prefix-h1 (text-value node)) - +h1-underline+)) - ((html-utils:tag= :h2 node) - (make-header 2 - (header-prefix-h2 (text-value node)) - +h2-underline+)) - ((html-utils:tag= :h3 node) - (make-header 3 - (header-prefix-h3 (text-value node)) - +h3-underline+)) - ((html-utils:tag= :li node) - (let* ((text (format nil - "~a ~a" - (bullet-prefix theme) - (text-value node)))) - (make-unordered-list-line text (current-header-group-id)))) - ((html-utils:tag= :quote node) - (let* ((line (text-value node :trim nil)) - (quote-prefix (quote-prefix theme)) - (header-group-id (current-header-group-id))) - (make-quoted-lines line header-group-id quote-prefix))) - ((html-utils:tag= :pre node) - (let ((current-alt-text (pre-alt-text node)) - (pre-group-id (next-pre-group-id)) - (current-group-id (current-header-group-id)) - (fg (preformatted-fg theme))) - (set-pre-alt-text current-alt-text) - (make-pre-start current-alt-text current-group-id pre-group-id fg))) - ((html-utils:tag= :pre-end node) - (make-pre-end)) - ((html-utils:tag= :a node) - (let* ((link-name (text-value node :trim nil)) - (link-value (html-utils:attribute-value - (html-utils:find-attribute :href - node))) - (link-text (if link-name - (linkify link-name link-value) - (linkify link-value link-value))) - (header-group-id (current-header-group-id))) - (make-link-line link-text link-name link-value header-group-id)))))) + (let* ((source-line (extract-source-line node)) + (source-line-id (extract-source-line-id node)) + (header-group-id (extract-header-group-id node)) + (pre-alt-text (extract-pre-alt-text node)) + (pre-group-id (extract-pre-group-id node)) + (res (cond + ((html-utils:tag= :vertical-space node) + (make-vertical-space header-group-id)) + ((html-utils:tag= :as-is node) + (let* ((line (text-value node :trim nil)) + (fg (preformatted-fg theme)) + (line (tui:make-tui-string (format nil "~a" line) + :fgcolor fg))) + (make-pre-line (list line) + header-group-id + pre-group-id + pre-alt-text))) + ((html-utils:tag= :text node) + (let ((text (text-value node :trim t))) + (if (string-not-empty-p text) + (make-simple-line (format nil "~a~%" text) + header-group-id) + (make-vertical-space header-group-id)))) + ((html-utils:tag= :h1 node) + (make-header 1 + (header-prefix-h1 (text-value node)) + +h1-underline+ + header-group-id)) + ((html-utils:tag= :h2 node) + (make-header 2 + (header-prefix-h2 (text-value node)) + +h2-underline+ + header-group-id)) + ((html-utils:tag= :h3 node) + (make-header 3 + (header-prefix-h3 (text-value node)) + +h3-underline+ + header-group-id)) + ((html-utils:tag= :li node) + (let* ((text (format nil + "~a ~a" + (bullet-prefix theme) + (text-value node)))) + (make-unordered-list-line text header-group-id))) + ((html-utils:tag= :quote node) + (let* ((line (text-value node :trim nil)) + (quote-prefix (quote-prefix theme))) + (make-quoted-lines line header-group-id quote-prefix))) + ((html-utils:tag= :pre node) + (let ((fg (preformatted-fg theme))) + (make-pre-start pre-alt-text header-group-id pre-group-id fg))) + ((html-utils:tag= :pre-end node) + (make-pre-end)) + ((html-utils:tag= :a node) + (let* ((link-name (text-value node :trim nil)) + (link-value (html-utils:attribute-value + (html-utils:find-attribute :href + node))) + (link-text (if link-name + (linkify link-name link-value) + (linkify link-value link-value))) + (header-group-id header-group-id)) + (make-link-line link-text link-name link-value header-group-id)))))) (add-source-metadata res source-line-id source-line))) (build-rows () (flatten (loop for node in parsed-gemini collect (build-row node))))) @@ -728,7 +736,7 @@ (with-initialized-parser (build-rows)) (build-rows)))) -(defun parse-gemini-file (data &key (initialize-parser nil)) +(defun parse-gemini-file (data &key (initialize-parser nil) (add-metadata t)) (flet ((parse-data (data) (let* ((lines (if (string= (format nil "~%") data) (list (format nil "~%")) @@ -750,10 +758,14 @@ (mapcar (lambda (a b) (when b (html-utils:add-attribute :source-line a b))) - lines parsed)))) + lines parsed))) + (maybe-annotate-data (parsed-data) + (if add-metadata + (add-metadata-to-parsed-gemini-lines parsed-data) + parsed-data))) (if initialize-parser - (with-initialized-parser (parse-data data)) - (parse-data data)))) + (with-initialized-parser (maybe-annotate-data (parse-data data))) + (maybe-annotate-data (parse-data data))))) (defun add-metadata-to-parsed-gemini-lines (parsed-gemini &key (initialize-parser nil)) (labels ((trim (a) diff --git a/src/gui/public-api.lisp b/src/gui/public-api.lisp index 282da89..4560a05 100644 --- a/src/gui/public-api.lisp +++ b/src/gui/public-api.lisp @@ -207,19 +207,28 @@ (string-downcase (symbol-name object))) (defun rearrange-parsed-line-for-encoding (lines) - (cons "lines" - (loop for line in lines - collect - (let ((flattened (mapcar #'rearrange-for-encoding (a:flatten line)))) - ;;(misc:dbg "flattened ~s" flattened) - (if flattened - (append (list (cons "type" (first flattened))) - (loop for (a b) on (subseq flattened 1 (1- (length flattened))) - by 'cddr - collect - (cons a b)) - (list (cons "line" (a:last-elt flattened)))) - nil))))) + (flet ((contains-chldren-p (node) + (evenp (length node)))) + (cons "lines" + (loop for line in lines + collect + (let ((flattened (mapcar #'rearrange-for-encoding (a:flatten line)))) + (misc:dbg "flattened ~s ~s" flattened (contains-chldren-p flattened)) + (when flattened + (if (contains-chldren-p flattened) + (append (list (cons "type" (first flattened))) + (loop for (a b) on (subseq flattened + 1 + (1- (length flattened))) + by 'cddr + collect + (cons a b)) + (list (cons "line" (a:last-elt flattened)))) + (append (list (cons "type" (first flattened))) + (loop for (a b) on (subseq flattened 1) + by 'cddr + collect + (cons a b)))))))))) (defmethod rpc::render-as-list ((object gw:gemini-stream)) (with-accessors ((stream-status gw:stream-status) @@ -238,7 +247,6 @@ (host gw:host)) object (let ((actual-start-time (db-utils:decode-datetime-string start-time)) (actual-parsed-lines (rearrange-parsed-line-for-encoding parsed-lines))) - (misc:dbg "flattened ~s" actual-parsed-lines) (list (cons "stream-status" stream-status) (cons "download-iri" download-iri) (cons "start-time" actual-start-time) diff --git a/src/package.lisp b/src/package.lisp index 64960e2..4bbfd96 100644 --- a/src/package.lisp +++ b/src/package.lisp @@ -1589,6 +1589,7 @@ :redraw-window-event :send-to-pipe-event :print-mentions-event + :delete-all-notifications-event :function-event :with-enqueued-process :dispatch-program-events)) @@ -1687,9 +1688,13 @@ :poll-vote :get-notifications :delete-notification + :notification->text :sort-id< + :sott-id> :id= :all-mentions + :all-notifications + :delete-all-notifications :update-mentions-folder :expand-status-thread :make-placeholder-tag-histogram @@ -2983,7 +2988,8 @@ :file-explorer-upload-mirror :file-explorer-download-mirror :clear-cache - :print-mentions)) + :print-mentions + :delete-notifications)) (defpackage :scheduled-events (:use diff --git a/src/program-events.lisp b/src/program-events.lisp index 0826366..36f168f 100644 --- a/src/program-events.lisp +++ b/src/program-events.lisp @@ -1702,24 +1702,38 @@ (mentions (thread-window::mentions thread-window)) (message-window specials:*message-window*)) (if mentions - (labels ((print-mention (notification) - (let ((raw-text (format nil - "type: ~a from ~a" - (tooter:kind notification) - (tooter:account-name (tooter:account notification))))) - (tui:make-tui-string raw-text))) - (make-rows (mentions) + (labels ((make-rows (mentions) (mapcar (lambda (mention) (make-instance 'line-oriented-window:line :fields (list :original-object mention) - :normal-text (print-mention mention) - :selected-text (print-mention mention))) + :normal-text (api-client:notification->text mention) + :selected-text (api-client:notification->text mention))) mentions))) (line-oriented-window:update-all-rows message-window (make-rows mentions)) (windows:win-clear message-window) (windows:draw message-window)) (ui:info-message (_ "No mentions"))))) +(defclass delete-all-notifications-event (program-event) ()) + +(defmethod process-event ((object delete-all-notifications-event)) + "Delete all the notification from server" + (let ((message-window specials:*message-window*)) + (line-oriented-window:update-all-rows message-window '()) + (api-client:delete-all-notifications + (lambda (notification) + (with-enqueued-process () + (let* ((message (format nil + (_ "Deleting: ~a") + (api-client:notification->text notification))) + (row (make-instance 'line-oriented-window:line + :fields (list :original-object notification) + :normal-text message + :selected-text message))) + (line-oriented-window:append-new-rows message-window (list row)) + (windows:win-clear message-window) + (windows:draw message-window))))))) + ;;;; general usage (defclass function-event (program-event) ()) diff --git a/src/tests/gemini-parser-tests.lisp b/src/tests/gemini-parser-tests.lisp index 47925f5..762e18e 100644 --- a/src/tests/gemini-parser-tests.lisp +++ b/src/tests/gemini-parser-tests.lisp @@ -61,7 +61,8 @@ baz (defun parse-stream () (make-threads-parse (lambda () (gemini-parser:parse-gemini-file *gemini-stream* - :initialize-parser t)))) + :initialize-parser t + :add-metadata nil)))) (deftest parse-test (gemini-parser-suite) (assert-equality (lambda (a b) (tree-equal a b :test #'string=)) @@ -166,7 +167,8 @@ baz (make-threads-parse (lambda () (gemini-parser:with-initialized-parser (gemini-parser:add-metadata-to-parsed-gemini-lines - (gemini-parser:parse-gemini-file *gemini-stream*)))))) + (gemini-parser:parse-gemini-file *gemini-stream* + :add-metadata nil)))))) (deftest annotate-test ((gemini-parser-suite) (parse-test)) (assert-equality (lambda (a b) (tree-equal a b diff --git a/src/ui-goodies.lisp b/src/ui-goodies.lisp index 7db2477..a82f826 100644 --- a/src/ui-goodies.lisp +++ b/src/ui-goodies.lisp @@ -3457,4 +3457,9 @@ gemini client certificates!)." (defun print-mentions () "Print the mentions" + (info-message (_ "Getting all notification, please wait...")) (push-event (make-instance 'print-mentions-event))) + +(defun delete-notifications () + "Delete all the notification from server" + (push-event (make-instance 'delete-all-notifications-event)))