mirror of https://codeberg.org/cage/tinmop/
- [GUI] added widget for gemlogs showing and unsubscribing.
This commit is contained in:
cage
parent
53a6a6e9ab
commit
5674bf455a
|
|
@ -3092,7 +3092,7 @@ than `days-in-the-past' days (default: `(swconf:config-purge-cache-days-offset)'
|
|||
:gemini-subscription.url))))
|
||||
:seen-count))
|
||||
(from +table-gemini-subscription+)
|
||||
(order-by (:desc :unseen-count) :title)))
|
||||
(order-by (:desc :unseen-count) :title :subtitle :url)))
|
||||
(rows (fetch-all-rows query)))
|
||||
rows))
|
||||
|
||||
|
|
|
|||
|
|
@ -0,0 +1,118 @@
|
|||
(in-package :client-gemlog-window)
|
||||
|
||||
(named-readtables:in-readtable nodgui.syntax:nodgui-syntax)
|
||||
|
||||
(defclass gemlog-frame (gui-goodies:table-frame) ())
|
||||
|
||||
(defun build-column-values (unseen-count
|
||||
seen-count
|
||||
title
|
||||
subtitle)
|
||||
(list unseen-count
|
||||
seen-count
|
||||
title
|
||||
subtitle))
|
||||
|
||||
(defmacro build-column-value-accessor (name index)
|
||||
(assert (>= index 0))
|
||||
(assert (symbolp name))
|
||||
`(defun ,(format-fn-symbol t "column-~a" name) (fields)
|
||||
(elt fields ,index)))
|
||||
|
||||
(build-column-value-accessor unseen-count 0)
|
||||
|
||||
(build-column-value-accessor seen-count 1)
|
||||
|
||||
(build-column-value-accessor title 2)
|
||||
|
||||
(build-column-value-accessor subtitle 3)
|
||||
|
||||
(defun resync-rows (gemlog-frame new-rows)
|
||||
(with-accessors ((tree gui-goodies:tree)
|
||||
(rows gui-goodies:rows)) gemlog-frame
|
||||
(gui:treeview-delete-all tree)
|
||||
(setf rows new-rows)
|
||||
(loop for row in rows do
|
||||
(let* ((iri (db:row-url row))
|
||||
(seen-count (to-s (db:row-seen-count row)))
|
||||
(unseen-count (to-s (db:row-unseen-count row)))
|
||||
(title (db:row-title row))
|
||||
(subtitle (db:row-subtitle row))
|
||||
(tree-row (make-instance 'gui:tree-item
|
||||
:id iri
|
||||
:text iri
|
||||
:column-values (build-column-values unseen-count
|
||||
seen-count
|
||||
title
|
||||
subtitle)
|
||||
:index gui:+treeview-last-index+)))
|
||||
(gui:treeview-insert-item tree :item tree-row)))
|
||||
(gui:treeview-refit-columns-width (gui-goodies:tree gemlog-frame))
|
||||
gemlog-frame))
|
||||
|
||||
(defun all-rows ()
|
||||
(cev:enqueue-request-and-wait-results :gemini-gemlog-all-subscription
|
||||
1
|
||||
ev:+standard-event-priority+))
|
||||
|
||||
(defmethod initialize-instance :after ((object gemlog-frame) &key &allow-other-keys)
|
||||
(with-accessors ((tree gui-goodies:tree)
|
||||
(rows gui-goodies:rows)) object
|
||||
(let ((new-rows (all-rows))
|
||||
(treeview (make-instance 'gui:scrolled-treeview
|
||||
:master object
|
||||
:pack '(:side :top :expand t :fill :both)
|
||||
:columns (list (_ "Unread")
|
||||
(_ "Read")
|
||||
(_ "Title")
|
||||
(_ "Subtitle")))))
|
||||
(setf tree treeview)
|
||||
(gui:treeview-heading tree gui:+treeview-first-column-id+
|
||||
:text (_ "Address"))
|
||||
(resync-rows object new-rows)
|
||||
object)))
|
||||
|
||||
(defun unsubscribe-gemlog-clsr (gemlog-frame)
|
||||
(lambda ()
|
||||
(a:when-let* ((selections (gui:treeview-get-selection (gui-goodies:tree gemlog-frame))))
|
||||
(loop for selection in selections do
|
||||
(let ((url (gui:id selection)))
|
||||
(ev:with-enqueued-process-and-unblock ()
|
||||
(comm:make-request :gemini-gemlog-unsubscribe 1 url))
|
||||
(let ((new-rows (all-rows)))
|
||||
(resync-rows gemlog-frame new-rows)))))))
|
||||
|
||||
(defun open-gemlog-clsr (main-window treeview-gemlogs)
|
||||
(lambda (e)
|
||||
(declare (ignore e))
|
||||
(a:when-let* ((selections (gui:treeview-get-selection (gui-goodies:tree treeview-gemlogs)))
|
||||
(selection (first selections)))
|
||||
(let* ((url (gui:id selection))
|
||||
(fields (gui:column-values selection))
|
||||
(title (column-title fields))
|
||||
(subtitle (column-subtitle fields)))
|
||||
(ev:with-enqueued-process-and-unblock ()
|
||||
(let ((parsed-gemlog-entries (comm:make-request :gemini-gemlog-entries
|
||||
1
|
||||
url
|
||||
title
|
||||
subtitle)))
|
||||
(client-main-window:clean-gemtext gui-goodies:*main-frame*)
|
||||
(client-main-window::collect-ir-lines url main-window parsed-gemlog-entries)))))))
|
||||
|
||||
(defun init-window (master main-window)
|
||||
(gui:with-toplevel (toplevel :master master :title (_ "Gemlogs"))
|
||||
(let* ((table (make-instance 'gemlog-frame :master toplevel))
|
||||
(buttons-frame (make-instance 'gui:frame :master toplevel))
|
||||
(unsubscribe-button (make-instance 'gui:button
|
||||
:master buttons-frame
|
||||
:image icons:*document-delete*
|
||||
:command (unsubscribe-gemlog-clsr table))))
|
||||
(gui-goodies:attach-tooltips (unsubscribe-button (_ "unsubscribe from selected gemlog")))
|
||||
(gui:grid table 0 0 :sticky :nwe)
|
||||
(gui:grid buttons-frame 1 0 :sticky :s)
|
||||
(gui:grid unsubscribe-button 0 0 :sticky :s)
|
||||
(gui:bind (gui:treeview (gui-goodies:tree table))
|
||||
#$<<TreeviewSelect>>$
|
||||
(open-gemlog-clsr main-window table)))
|
||||
(gui:transient toplevel master)))
|
||||
|
|
@ -199,14 +199,14 @@
|
|||
(let* ((bar (gui:make-menubar parent))
|
||||
(file (gui:make-menu bar (_ "File") :underline 0))
|
||||
(tools (gui:make-menu bar (_ "Tools") :underline 0))
|
||||
(tour (gui:make-menu bar (_ "Tour") :underline 0))
|
||||
(tour (gui:make-menu bar (_ "Tour") :underline 1))
|
||||
(bookmarks (gui:make-menu bar (_ "Bookmarks") :underline 0))
|
||||
(gemlogs (gui:make-menu bar (_ "Gemlogs") :underline 0))
|
||||
(help (gui:make-menu bar (_ "Help") :underline 0)))
|
||||
(gui:make-menubutton tools (_ "Certificates") #'menu:show-certificates :underline 0)
|
||||
(gui:make-menubutton tools (_ "Streams") #'menu:show-streams :underline 0)
|
||||
(gui:make-menubutton tools (_ "Search") (menu:show-search-frame-clsr main-window)
|
||||
:underline 1)
|
||||
|
||||
(gui:make-menubutton file (_ "Quit") #'menu:quit :underline 0)
|
||||
(gui:make-menubutton help (_ "About") #'menu:help-about :underline 0)
|
||||
(gui:make-menubutton bookmarks
|
||||
|
|
@ -221,7 +221,8 @@
|
|||
(gui:make-menubutton tour
|
||||
(_ "Shuffle")
|
||||
(lambda () (client-tour-window:enqueue-shuffle-tour))
|
||||
:underline 0)))
|
||||
:underline 0)
|
||||
(gui:make-menubutton gemlogs (_ "Show") #'menu:manage-gemlogs :underline 0)))
|
||||
|
||||
(defclass tool-bar (gui:frame)
|
||||
((iri-entry
|
||||
|
|
|
|||
|
|
@ -73,3 +73,8 @@
|
|||
(defun show-tour ()
|
||||
(let ((master gui-goodies:*toplevel*))
|
||||
(client-tour-window:init-window master)))
|
||||
|
||||
(defun manage-gemlogs ()
|
||||
(let ((master gui-goodies:*toplevel*)
|
||||
(main-window gui-goodies:*main-frame*))
|
||||
(client-gemlog-window:init-window master main-window)))
|
||||
|
|
|
|||
|
|
@ -64,7 +64,7 @@
|
|||
(lambda ()
|
||||
(a:when-let* ((selections (gui:treeview-get-selection (gui-goodies:tree stream-frame)))
|
||||
(selection (first selections)))
|
||||
(let* ((url (gui:id selection))
|
||||
(let* ((url (gui:id selection))
|
||||
(new-rows (all-rows)))
|
||||
(client-main-window::open-iri url gui-goodies:*main-frame* t)
|
||||
(resync-rows stream-frame new-rows)))))
|
||||
|
|
|
|||
|
|
@ -0,0 +1,43 @@
|
|||
;; tinmop: an humble gemini and pleroma client
|
||||
;; Copyright © cage
|
||||
|
||||
;; This program is free software: you can redistribute it and/or modify
|
||||
;; it under the terms of the GNU General Public License as published by
|
||||
;; the Free Software Foundation, either version 3 of the License, or
|
||||
;; (at your option) any later version.
|
||||
|
||||
;; This program is distributed in the hope that it will be useful,
|
||||
;; but WITHOUT ANY WARRANTY; without even the implied warranty of
|
||||
;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
|
||||
;; GNU General Public License for more details.
|
||||
|
||||
;; You should have received a copy of the GNU General Public License
|
||||
;; along with this program.
|
||||
;; If not, see [[http://www.gnu.org/licenses/][http://www.gnu.org/licenses/]].
|
||||
|
||||
(in-package :json-rpc-communication)
|
||||
|
||||
(defclass iri-complete-response (box) ())
|
||||
|
||||
(defun gemini-gemlog-subscribe (iri)
|
||||
(gemini-subscription::subscribe iri))
|
||||
|
||||
(defclass gemini-gemlog-subscriptions (box) ())
|
||||
|
||||
(defmethod yason:encode ((object gemini-gemlog-subscriptions) &optional (stream *standard-output*))
|
||||
(encode-flat-array-of-plists (unbox object) stream))
|
||||
|
||||
(defun gemini-gemlog-all-subscription ()
|
||||
(let ((table (db:gemini-all-subscriptions)))
|
||||
(make-instance 'gemini-gemlog-subscriptions
|
||||
:contents table)))
|
||||
|
||||
(defun gemini-gemlog-unsubscribe (iri)
|
||||
(db:gemini-cancel-subscription iri))
|
||||
|
||||
(defun gemini-gemlog-entries (iri title subtitle)
|
||||
(let* ((table (db:gemlog-entries iri))
|
||||
(page (program-events::build-gemlog-page title
|
||||
subtitle
|
||||
table)))
|
||||
(gemini-parse-string page)))
|
||||
|
|
@ -115,6 +115,13 @@
|
|||
(gen-rpc "gemini-bookmark-delete" 'gemini-bookmark-delete "iri" 0)
|
||||
(gen-rpc "gemini-bookmark-table" 'gemini-bookmark-table)
|
||||
(gen-rpc "gemini-bookmarked-p" 'gemini-bookmarked-p "iri" 0)
|
||||
(gen-rpc "gemini-gemlog-subscribe" 'gemini-gemlog-subscribe "iri" 0)
|
||||
(gen-rpc "gemini-gemlog-all-subscription" 'gemini-gemlog-all-subscription)
|
||||
(gen-rpc "gemini-gemlog-unsubscribe" 'gemini-gemlog-unsubscribe "iri" 0)
|
||||
(gen-rpc "gemini-gemlog-entries" 'gemini-gemlog-entries
|
||||
"iri" 0
|
||||
"title" 1
|
||||
"subtitle" 2)
|
||||
(gen-rpc "iri-to-parent-path" 'iri-to-parent-path "iri" 0)
|
||||
(gen-rpc "quit-program" 'quit-program)
|
||||
,@body))
|
||||
|
|
|
|||
|
|
@ -3419,7 +3419,8 @@
|
|||
:show-bookmarks-clsr
|
||||
:manage-bookmarks-clsr
|
||||
:show-search-frame-clsr
|
||||
:show-tour))
|
||||
:show-tour
|
||||
:manage-gemlogs))
|
||||
|
||||
(defpackage :client-certificates-window
|
||||
(:use
|
||||
|
|
@ -3504,6 +3505,26 @@
|
|||
:init-window
|
||||
:manage-bookmarks))
|
||||
|
||||
(defpackage :client-gemlog-window
|
||||
(:use
|
||||
:cl
|
||||
:config
|
||||
:constants
|
||||
:text-utils
|
||||
:misc-utils)
|
||||
(:local-nicknames (:cert-win :client-certificates-window)
|
||||
(:comm :json-rpc-communication)
|
||||
(:re :cl-ppcre)
|
||||
(:a :alexandria)
|
||||
(:ev :program-events)
|
||||
(:cev :client-events)
|
||||
(:gui :nodgui)
|
||||
(:gui-mw :nodgui.mw)
|
||||
(:gui-shapes :nodgui.shapes)
|
||||
(:menu :client-menu-command))
|
||||
(:export
|
||||
:init-window))
|
||||
|
||||
(defpackage :client-search-frame
|
||||
(:use
|
||||
:cl
|
||||
|
|
|
|||
|
|
@ -1486,44 +1486,47 @@
|
|||
:initarg :entries
|
||||
:accessor entries)))
|
||||
|
||||
(defun build-gemlog-page (title subtitle entries)
|
||||
(with-output-to-string (stream)
|
||||
(format stream
|
||||
"~a~2%"
|
||||
(gemini-parser:geminize-h1 title))
|
||||
(if subtitle
|
||||
(format stream
|
||||
"~a~2%"
|
||||
(gemini-parser:geminize-h2 subtitle))
|
||||
(format stream
|
||||
"~a~2%"
|
||||
(gemini-parser:geminize-h2 (_ "No subtitle"))))
|
||||
(loop for entry in entries do
|
||||
(let* ((link (db:row-post-link entry))
|
||||
(date-format (swconf:date-fmt swconf:+key-message-window+))
|
||||
(date (db:row-post-date entry))
|
||||
(encoded-date (db-utils:encode-datetime-string date))
|
||||
(title (text-utils:strcat (format-time encoded-date date-format)
|
||||
" "
|
||||
(db:row-post-title entry)))
|
||||
(seenp (db-utils:db-not-nil-p (db:row-post-seenp entry))))
|
||||
(format stream
|
||||
(_ "~a ~:[(not opened)~;(opened)~]~%")
|
||||
(gemini-parser:render-gemini-link link
|
||||
title)
|
||||
seenp)))))
|
||||
|
||||
(defmethod process-event ((object gemlog-show-event))
|
||||
(with-accessors ((title title)
|
||||
(subtitle subtitle)
|
||||
(entries entries)
|
||||
(gemlog-url gemlog-url)) object
|
||||
(let* ((gemini-page (with-output-to-string (stream)
|
||||
(format stream
|
||||
"~a~2%"
|
||||
(gemini-parser:geminize-h1 title))
|
||||
(if subtitle
|
||||
(format stream
|
||||
"~a~2%"
|
||||
(gemini-parser:geminize-h2 subtitle))
|
||||
(format stream
|
||||
"~a~2%"
|
||||
(gemini-parser:geminize-h2 (_ "No subtitle"))))
|
||||
(loop for entry in entries do
|
||||
(let* ((link (db:row-post-link entry))
|
||||
(date-format (swconf:date-fmt swconf:+key-message-window+))
|
||||
(date (db:row-post-date entry))
|
||||
(encoded-date (db-utils:encode-datetime-string date))
|
||||
(title (text-utils:strcat (format-time encoded-date date-format)
|
||||
" "
|
||||
(db:row-post-title entry)))
|
||||
(seenp (db-utils:db-not-nil-p (db:row-post-seenp entry))))
|
||||
(format stream
|
||||
(_ "~a ~:[(not opened)~;(opened)~]~%")
|
||||
(gemini-parser:render-gemini-link link
|
||||
title)
|
||||
seenp)))))
|
||||
(url (iri:iri-parse gemlog-url))
|
||||
(parsed (gemini-parser:parse-gemini-file gemini-page :initialize-parser t))
|
||||
(links (gemini-parser:sexp->links parsed
|
||||
(uri:host url)
|
||||
(uri:port url)
|
||||
(uri:path url)
|
||||
(uri:query url)))
|
||||
(theme gemini-client:*gemini-page-theme*))
|
||||
(let* ((gemini-page (build-gemlog-page title subtitle entries))
|
||||
(url (iri:iri-parse gemlog-url))
|
||||
(parsed (gemini-parser:parse-gemini-file gemini-page :initialize-parser t))
|
||||
(links (gemini-parser:sexp->links parsed
|
||||
(uri:host url)
|
||||
(uri:port url)
|
||||
(uri:path url)
|
||||
(uri:query url)))
|
||||
(theme gemini-client:*gemini-page-theme*))
|
||||
(gemini-viewer:maybe-initialize-metadata specials:*message-window*)
|
||||
(refresh-gemini-message-window links
|
||||
gemini-page
|
||||
|
|
|
|||
|
|
@ -154,6 +154,7 @@
|
|||
(:file "public-api-gemini-certificates")
|
||||
(:file "public-api-gemini-tour-links")
|
||||
(:file "public-api-gemini-bookmark")
|
||||
(:file "public-api-gemini-gemlog")
|
||||
(:file "public-api")
|
||||
(:file "json-rpc-communication")))
|
||||
(:module gui-client
|
||||
|
|
@ -170,6 +171,7 @@
|
|||
(:file "tour-window")
|
||||
(:file "stream-window")
|
||||
(:file "bookmark-window")
|
||||
(:file "gemlog-window")
|
||||
(:file "menu-command")
|
||||
(:file "internal-paths")
|
||||
(:file "search-frame")
|
||||
|
|
|
|||
Loading…
Reference in New Issue