mirror of
https://codeberg.org/cage/tinmop/
synced 2025-02-02 04:36:43 +01:00
- 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'.
This commit is contained in:
cage
parent
f1df366cba
commit
59a9b69605
@ -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*)
|
||||
|
||||
@ -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 '()))
|
||||
|
||||
@ -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)
|
||||
|
||||
@ -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)
|
||||
|
||||
@ -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
|
||||
|
||||
@ -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) ())
|
||||
|
||||
@ -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
|
||||
|
||||
@ -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)))
|
||||
|
||||
Loading…
x
Reference in New Issue
Block a user