From 5674bf455a9a35f072dc0da52a97ae2b6218e7e1 Mon Sep 17 00:00:00 2001 From: cage Date: Sat, 6 May 2023 12:48:01 +0200 Subject: [PATCH] - [GUI] added widget for gemlogs showing and unsubscribing. --- src/db.lisp | 2 +- src/gui/client/gemlog-window.lisp | 118 +++++++++++++++++++ src/gui/client/main-window.lisp | 7 +- src/gui/client/menu-command.lisp | 5 + src/gui/client/stream-window.lisp | 2 +- src/gui/server/public-api-gemini-gemlog.lisp | 43 +++++++ src/gui/server/public-api.lisp | 7 ++ src/package.lisp | 23 +++- src/program-events.lisp | 69 +++++------ tinmop.asd | 2 + 10 files changed, 239 insertions(+), 39 deletions(-) create mode 100644 src/gui/client/gemlog-window.lisp create mode 100644 src/gui/server/public-api-gemini-gemlog.lisp diff --git a/src/db.lisp b/src/db.lisp index 7f9ea18..75d6bc9 100644 --- a/src/db.lisp +++ b/src/db.lisp @@ -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)) diff --git a/src/gui/client/gemlog-window.lisp b/src/gui/client/gemlog-window.lisp new file mode 100644 index 0000000..3e55cec --- /dev/null +++ b/src/gui/client/gemlog-window.lisp @@ -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)) + #$<>$ + (open-gemlog-clsr main-window table))) + (gui:transient toplevel master))) diff --git a/src/gui/client/main-window.lisp b/src/gui/client/main-window.lisp index ca38d81..b77195b 100644 --- a/src/gui/client/main-window.lisp +++ b/src/gui/client/main-window.lisp @@ -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 diff --git a/src/gui/client/menu-command.lisp b/src/gui/client/menu-command.lisp index 48c6073..f5ab09e 100644 --- a/src/gui/client/menu-command.lisp +++ b/src/gui/client/menu-command.lisp @@ -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))) diff --git a/src/gui/client/stream-window.lisp b/src/gui/client/stream-window.lisp index ef8abcd..d84becc 100644 --- a/src/gui/client/stream-window.lisp +++ b/src/gui/client/stream-window.lisp @@ -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))))) diff --git a/src/gui/server/public-api-gemini-gemlog.lisp b/src/gui/server/public-api-gemini-gemlog.lisp new file mode 100644 index 0000000..984f9cd --- /dev/null +++ b/src/gui/server/public-api-gemini-gemlog.lisp @@ -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))) diff --git a/src/gui/server/public-api.lisp b/src/gui/server/public-api.lisp index 8506e69..25ddf1e 100644 --- a/src/gui/server/public-api.lisp +++ b/src/gui/server/public-api.lisp @@ -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)) diff --git a/src/package.lisp b/src/package.lisp index 03d90a3..c1a0f83 100644 --- a/src/package.lisp +++ b/src/package.lisp @@ -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 diff --git a/src/program-events.lisp b/src/program-events.lisp index b8a50dd..9c4609c 100644 --- a/src/program-events.lisp +++ b/src/program-events.lisp @@ -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 diff --git a/tinmop.asd b/tinmop.asd index 00a5a24..f39243f 100644 --- a/tinmop.asd +++ b/tinmop.asd @@ -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")