cage
/
tinmop
mirror of https://codeberg.org/cage/tinmop/
1
0
Fork 0
Code Issues

- [GUI] added button to refresh the gemlogs subcriptions.

This commit is contained in:
cage 2023-06-18 14:48:40 +02:00
parent 97fd09adf0
commit 7aa707bfb6
9 changed files with 90 additions and 49 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

1
src/gemini/package.lisp
View File

@ -210,4 +210,5 @@
(:shadowing-import-from :misc :random-elt :shuffle)
(:export
:subscribe
:refresh-subscription-low-level
:refresh))

42
src/gemini/subscription.lisp
View File

@ -63,27 +63,33 @@ This function return the 'post-title' substring."
(db:gemini-subscribe-url url title subtitle))
t))))
(defun refresh-subscription-low-level (url)
(when-let* ((data (slurp-gemini-url url))
(page (text-utils:to-s data))
(parsed (parse-gemini-file page :initialize-parser t))
(gemlog-iri (iri:iri-parse url)))
(let ((links (remove-if-not (lambda (a) (link-post-timestamp-p (name a)))
(sexp->links parsed
(uri:host gemlog-iri)
(uri:port gemlog-iri)
(uri:path gemlog-iri)
(uri:query gemlog-iri))))
(new-posts-count 0))
(loop for link in links do
(when (not (db:find-gemlog-entry (to-s (target link))))
(incf new-posts-count)
(let ((date (link-post-timestamp (name link))))
(db:add-gemlog-entries (to-s gemlog-iri)
(target link)
(link-post-title (name link))
date
nil))))
new-posts-count)))
(defun refresh (url)
"Refresh gemlog entries that can be found at 'url'. The gemlog must
be subscribed before (see: 'gemini-subscription:subcribe'"
(handler-case
(when-let* ((data (slurp-gemini-url url))
(page (text-utils:to-s data))
(parsed (parse-gemini-file page :initialize-parser t))
(gemlog-iri (iri:iri-parse url)))
(let ((links (remove-if-not (lambda (a) (link-post-timestamp-p (name a)))
(sexp->links parsed
(uri:host gemlog-iri)
(uri:port gemlog-iri)
(uri:path gemlog-iri)
(uri:query gemlog-iri)))))
(loop for link in links do
(when (not (db:find-gemlog-entry (to-s (target link))))
(let ((date (link-post-timestamp (name link))))
(db:add-gemlog-entries (to-s gemlog-iri)
(target link)
(link-post-title (name link))
date
nil))))))
(refresh-subscription-low-level url)
(gemini-client:gemini-tofu-error (e)
(ui:ask-input-on-tofu-error e (lambda () (refresh url))))))

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

@ -116,7 +116,7 @@
(resync-rows certificate-frame (all-rows))
(gui:exit-from-toplevel (gui:master import-window)))
(error (e)
(client-main-window::notify-request-error e)))))))
(gui-goodies:notify-request-error e)))))))
(defmethod initialize-instance :after ((object import-window) &key (certificate-frame nil)
&allow-other-keys)

19
src/gui/client/gemlog-window.lisp
View File

@ -82,6 +82,15 @@
(let ((new-rows (all-rows)))
(resync-rows gemlog-frame new-rows)))))))
(defun refresh-gemlogs-clsr (gemlog-frame)
(lambda ()
(when (gui:children (gui-goodies:tree gemlog-frame) gui:+treeview-root+)
(ev:with-enqueued-process-and-unblock ()
(gui-goodies::with-notify-errors
(comm:make-request :gemini-gemlog-refresh-all-subscriptions 1)
(let ((new-rows (all-rows)))
(resync-rows gemlog-frame new-rows)))))))
(defun open-gemlog-clsr (main-window treeview-gemlogs)
(lambda (e)
(declare (ignore e))
@ -110,11 +119,17 @@
(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")))
:command (unsubscribe-gemlog-clsr table)))
(refresh-button (make-instance 'gui:button
:master buttons-frame
:image icons:*refresh*
:command (refresh-gemlogs-clsr table))))
(gui-goodies:attach-tooltips (unsubscribe-button (_ "unsubscribe from selected gemlog"))
(refresh-button (_ "refresh all subscription")))
(gui:grid table 0 0 :sticky :nwe)
(gui:grid buttons-frame 1 0 :sticky :s)
(gui:grid unsubscribe-button 0 0 :sticky :s)
(gui:grid refresh-button 0 1 :sticky :s)
(gui:bind (gui:treeview (gui-goodies:tree table))
#$<<TreeviewSelect>>$
(open-gemlog-clsr main-window table)))

16
src/gui/client/gui-goodies.lisp
View File

@ -133,3 +133,19 @@
(truncate (min (/ (gui:screen-width) 2
(gui:font-measure gui:+tk-text-font+ "0"))))
(truncate (/ (gui:screen-width) 2))))
(defun notify-request-error (error)
(error-dialog gui-goodies:*toplevel* error))
(defmacro with-notify-errors (&body body)
`(handler-case
(progn ,@body)
(comm:rpc-error-response (e)
#+debug-mode (misc:dbg "backend comunication RPC error ~a" e)
(notify-request-error (format nil
(_ "~a: ~a")
(comm:code e)
(conditions:text e))))
(error (e)
#+debug-mode (misc:dbg "backend comunication error ~a" e)
(notify-request-error e))))

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

@ -64,9 +64,6 @@
(defun find-streaming-stream-url ()
(find-db-stream-if (lambda (a) (eq (status a) +stream-status-streaming+))))
(defun notify-request-error (error)
(gui-goodies:error-dialog gui-goodies:*toplevel* error))
(defgeneric stop-stream-thread (object))
(defmethod stop-stream-thread ((object gemini-stream))
@ -89,26 +86,13 @@
(a:when-let ((stream-wrapper (find-streaming-stream-url)))
(stop-stream-thread stream-wrapper)))
(defmacro with-notify-errors (&body body)
`(handler-case
(progn ,@body)
(comm:rpc-error-response (e)
#+debug-mode (misc:dbg "backend comunication RPC error ~a" e)
(notify-request-error (format nil
(_ "~a: ~a")
(comm:code e)
(conditions:text e))))
(error (e)
#+debug-mode (misc:dbg "backend comunication error ~a" e)
(notify-request-error e))))
(defun enqueue-request-notify-error (method-name id &rest args)
(ev:with-enqueued-process-and-unblock ()
(with-notify-errors
(gui-goodies:with-notify-errors
(apply #'comm:make-request method-name id args))))
(defun render-toc (main-window iri)
(with-notify-errors
(gui-goodies:with-notify-errors
(toc-clear main-window)
(let* ((toc-max-width (gui-conf:config-toc-maximum-width))
(toc (comm:make-request :gemini-table-of-contents
@ -141,7 +125,7 @@
status-completed))
(loop-fetch (&optional (last-lines-fetched-count 0))
(ev:with-enqueued-process-and-unblock ()
(with-notify-errors
(gui-goodies:with-notify-errors
(let* ((last-lines-fetched (comm:make-request :gemini-stream-parsed-line-slice
1
iri
@ -303,7 +287,7 @@
(lambda (hint)
(if (or (complete:expand-iri-as-local-path-p hint)
(> (length hint) 2))
(with-notify-errors
(gui-goodies:with-notify-errors
(let ((match-results (cev:enqueue-request-and-wait-results :complete-net-address
1
ev:+maximum-event-priority+
@ -384,11 +368,11 @@
((or (gemini-client:header-temporary-failure-p status-code)
(gemini-client:header-permanent-failure-p status-code)
(gemini-client:header-certificate-failure-p status-code))
(notify-request-error (format nil
"Error getting ~a (~a ~a)"
iri
status-code
status-description)))
(gui-goodies:notify-request-error (format nil
"Error getting ~a (~a ~a)"
iri
status-code
status-description)))
((gemini-client:header-redirect-p status-code)
(when (gui:ask-yesno (format nil (_ "Follow redirection to ~a?") meta)
:title (_ "Redirection")
@ -807,7 +791,7 @@
((fs:directory-exists-p path)
(gui:choose-directory :initial-dir path :parent main-window :mustexist t))
(t
(notify-request-error (format nil (_ "No such file or directory: ~a") path)))))
(gui-goodies:notify-request-error (format nil (_ "No such file or directory: ~a") path)))))
(defun render-gemtext-string (main-window parsed-lines &key (links-path-prefix ""))
(ev:with-enqueued-process-and-unblock ()
@ -843,7 +827,7 @@
(t
(client-os-utils:open-resource-with-external-program main-window iri))))
(error (e)
(notify-request-error e))))
(gui-goodies:notify-request-error e))))
(defun get-user-request-query (iri meta main-window &key (sensitive nil))
(let* ((parsed-iri (iri:iri-parse iri))

15
src/gui/server/public-api-gemini-gemlog.lisp
View File

@ -46,3 +46,18 @@
subtitle
table)))
(gemini-parse-string page)))
(defun gemini-gemlog-refresh-subscription (gemlog-url)
(list (cons "url" gemlog-url)
(cons "new-posts" (gemini-subscription:refresh-subscription-low-level gemlog-url))))
(defclass gemini-gemlog-subscriptions-refreshed (box) ())
(defmethod yason:encode ((object gemini-gemlog-subscriptions-refreshed) &optional (stream *standard-output*))
(encode-flat-array-of-plists (unbox object) stream))
(defun gemini-gemlog-refresh-all-subscriptions ()
(let ((all-subscribed-gemlogs (mapcar #'db:row-url (db:gemini-all-subscriptions))))
(loop for subscription in all-subscribed-gemlogs
collect
(gemini-gemlog-refresh-subscription subscription))))

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

@ -121,6 +121,8 @@
(gen-rpc "gemini-gemlog-subscribe" 'gemini-gemlog-subscribe "iri" 0)
(gen-rpc "gemini-gemlog-subscribed-p" 'gemini-gemlog-subscribed-p "iri" 0)
(gen-rpc "gemini-gemlog-all-subscription" 'gemini-gemlog-all-subscription)
(gen-rpc "gemini-gemlog-refresh-all-subscriptions"
'gemini-gemlog-refresh-all-subscriptions)
(gen-rpc "gemini-gemlog-unsubscribe" 'gemini-gemlog-unsubscribe "iri" 0)
(gen-rpc "gemini-gemlog-entries" 'gemini-gemlog-entries
"iri" 0

4
src/package.lisp
View File

@ -3417,7 +3417,9 @@
:table-frame
:tree
:rows
:quite-good-dialog-width))
:quite-good-dialog-width
:notify-request-error
:with-notify-errors))
(defpackage :client-menu-command
(:use