cage/tinmop
1
0
Fork 0
mirror of https://codeberg.org/cage/tinmop/ synced 2025-03-08 10:47:37 +01:00
Code Issues

- [GUI] added widget for gemlogs showing and unsubscribing.

Browse Source
This commit is contained in:
cage 2023-05-06 12:48:01 +02:00
parent 53a6a6e9ab
commit 5674bf455a
10 changed files with 239 additions and 39 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

2
src/db.lisp
View File

@ -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))

118
src/gui/client/gemlog-window.lisp Normal file
View File

@ -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)))

7
src/gui/client/main-window.lisp
View File

@ -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

5
src/gui/client/menu-command.lisp
View File

@ -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)))

2
src/gui/client/stream-window.lisp
View File

@ -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)))))

43
src/gui/server/public-api-gemini-gemlog.lisp Normal file
View File

@ -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)))

7
src/gui/server/public-api.lisp
View File

@ -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))

23
src/package.lisp
View File

@ -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

69
src/program-events.lisp
View File

@ -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

2
tinmop.asd
View File

@ -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")