diff --git a/src/gemini/package.lisp b/src/gemini/package.lisp index a21ee62..3e5b86f 100644 --- a/src/gemini/package.lisp +++ b/src/gemini/package.lisp @@ -210,4 +210,5 @@ (:shadowing-import-from :misc :random-elt :shuffle) (:export :subscribe + :refresh-subscription-low-level :refresh)) diff --git a/src/gemini/subscription.lisp b/src/gemini/subscription.lisp index 2aecede..4b80b70 100644 --- a/src/gemini/subscription.lisp +++ b/src/gemini/subscription.lisp @@ -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)))))) diff --git a/src/gui/client/certificates-window.lisp b/src/gui/client/certificates-window.lisp index 20a7d85..d4161d3 100644 --- a/src/gui/client/certificates-window.lisp +++ b/src/gui/client/certificates-window.lisp @@ -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) diff --git a/src/gui/client/gemlog-window.lisp b/src/gui/client/gemlog-window.lisp index 90eb032..85cf573 100644 --- a/src/gui/client/gemlog-window.lisp +++ b/src/gui/client/gemlog-window.lisp @@ -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)) #$<>$ (open-gemlog-clsr main-window table))) diff --git a/src/gui/client/gui-goodies.lisp b/src/gui/client/gui-goodies.lisp index 4058dfd..95b6594 100644 --- a/src/gui/client/gui-goodies.lisp +++ b/src/gui/client/gui-goodies.lisp @@ -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)))) diff --git a/src/gui/client/main-window.lisp b/src/gui/client/main-window.lisp index 5f43075..aa81430 100644 --- a/src/gui/client/main-window.lisp +++ b/src/gui/client/main-window.lisp @@ -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)) diff --git a/src/gui/server/public-api-gemini-gemlog.lisp b/src/gui/server/public-api-gemini-gemlog.lisp index 394ce3c..5d7d68b 100644 --- a/src/gui/server/public-api-gemini-gemlog.lisp +++ b/src/gui/server/public-api-gemini-gemlog.lisp @@ -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)))) diff --git a/src/gui/server/public-api.lisp b/src/gui/server/public-api.lisp index e4fa464..c3cb257 100644 --- a/src/gui/server/public-api.lisp +++ b/src/gui/server/public-api.lisp @@ -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 diff --git a/src/package.lisp b/src/package.lisp index 602585b..ff2234a 100644 --- a/src/package.lisp +++ b/src/package.lisp @@ -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