diff --git a/Makefile.am b/Makefile.am index 2fa8c53..af9d113 100644 --- a/Makefile.am +++ b/Makefile.am @@ -43,6 +43,7 @@ confdir = $(sysconfdir)/$(PACKAGE) dist_conf_DATA = etc/init.lisp etc/default-theme.conf etc/shared.conf etc/gui.conf nobase_dist_pkgdata_DATA = data/error-pages/51 \ +data/error-pages/header-51.png \ data/icons/fmw_arrow-down.png \ data/icons/fmw_arrow-up.png \ data/icons/fmw_back.png \ diff --git a/Makefile.in b/Makefile.in index 2c76742..f35288b 100644 --- a/Makefile.in +++ b/Makefile.in @@ -408,6 +408,7 @@ doc/tinmop.org doc/send-toot.lisp NEWS.org ChangeLog AUTHORS confdir = $(sysconfdir)/$(PACKAGE) dist_conf_DATA = etc/init.lisp etc/default-theme.conf etc/shared.conf etc/gui.conf nobase_dist_pkgdata_DATA = data/error-pages/51 \ +data/error-pages/header-51.png \ data/icons/fmw_arrow-down.png \ data/icons/fmw_arrow-up.png \ data/icons/fmw_back.png \ diff --git a/data/error-pages/51 b/data/error-pages/51 index c636147..9d2ebb5 100644 --- a/data/error-pages/51 +++ b/data/error-pages/51 @@ -1,8 +1,7 @@ # Error! -### {url} -### not found +=> ./header-51.png picture of crashed rocket 🫤 -### Server replied: +## {url} was not found -### {meta} +### Server replied: ˝{meta}˝ diff --git a/data/error-pages/header-51.png b/data/error-pages/header-51.png new file mode 100644 index 0000000..d98b4aa Binary files /dev/null and b/data/error-pages/header-51.png differ diff --git a/src/gui/client/main-window.lisp b/src/gui/client/main-window.lisp index 31fab07..03cb294 100644 --- a/src/gui/client/main-window.lisp +++ b/src/gui/client/main-window.lisp @@ -338,53 +338,57 @@ query)))) (defun slurp-iri (main-window iri) - (let ((connecting-response (cev:enqueue-request-and-wait-results :gemini-request - 1 - ev:+maximum-event-priority+ - iri - t - nil))) - (multiple-value-bind (status-code - status-description - meta - cached - original-iri) - (displace-gemini-response connecting-response) - (declare (ignore original-iri cached)) - (cond - ((gemini-client:header-input-p status-code) - (let ((actual-iri (get-user-request-query iri meta main-window))) - (slurp-iri main-window actual-iri))) - ((gemini-client:header-sensitive-input-p status-code) - (let ((actual-iri (get-user-request-query iri meta main-window :sensitive t))) - (slurp-iri main-window actual-iri))) - ((= status-code comm:+tofu-error-status-code+) - (when (gui:ask-yesno meta - :title (_ "Server certificate error") - :parent main-window) - (cev:enqueue-request-and-wait-results :gemini-delete-certificate - 1 - ev:+maximum-event-priority+ - iri) - (slurp-iri main-window iri))) - ((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)) - (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") - :parent main-window) - (let ((redirect-iri (if (iri:absolute-url-p meta) - meta - (absolutize-link iri meta)))) - (slurp-iri redirect-iri main-window)))) - ((gemini-client:header-success-p status-code) - (slurp-non-text-data main-window iri :try-to-open nil)))))) + (if (not (iri:absolute-url-p iri)) + (if (fs:file-exists-p iri) + iri + (error (_ "file ~a not found" iri))) + (let ((connecting-response (cev:enqueue-request-and-wait-results :gemini-request + 1 + ev:+maximum-event-priority+ + iri + t + nil))) + (multiple-value-bind (status-code + status-description + meta + cached + original-iri) + (displace-gemini-response connecting-response) + (declare (ignore original-iri cached)) + (cond + ((gemini-client:header-input-p status-code) + (let ((actual-iri (get-user-request-query iri meta main-window))) + (slurp-iri main-window actual-iri))) + ((gemini-client:header-sensitive-input-p status-code) + (let ((actual-iri (get-user-request-query iri meta main-window :sensitive t))) + (slurp-iri main-window actual-iri))) + ((= status-code comm:+tofu-error-status-code+) + (when (gui:ask-yesno meta + :title (_ "Server certificate error") + :parent main-window) + (cev:enqueue-request-and-wait-results :gemini-delete-certificate + 1 + ev:+maximum-event-priority+ + iri) + (slurp-iri main-window iri))) + ((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)) + (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") + :parent main-window) + (let ((redirect-iri (if (iri:absolute-url-p meta) + meta + (absolutize-link iri meta)))) + (slurp-iri redirect-iri main-window)))) + ((gemini-client:header-success-p status-code) + (slurp-non-text-data main-window iri :try-to-open nil))))))) (defun inline-image-p (link-value) (a:when-let* ((parsed (iri:iri-parse link-value :null-on-error t)) @@ -428,14 +432,19 @@ (1- line-index))))))) (defun inline-all-images (main-window) + "Note that this functions assumes that all remote IRI resources are +absolute (i.e. with scheme component), non absulute IRI are considered +local file paths." (gui-goodies:with-busy* (main-window) (loop for line across (ir-lines main-window) for line-number from 1 when (and (string= (getf line :type) "a") (inline-image-p (getf line :href))) do - (let ((link-value (absolutize-link (get-address-bar-text main-window) - (getf line :href)))) + (let ((link-value (if (fs:file-exists-p (getf line :href)) + (getf line :href) + (absolutize-link (get-address-bar-text main-window) + (getf line :href))))) (inline-image main-window link-value line-number) (incf line-number))))) @@ -979,7 +988,9 @@ status-code status-description meta))) - (render-gemtext-string main-window error-gemtext))) + (render-gemtext-string main-window error-gemtext) + (ev:with-enqueued-process-and-unblock () + (inline-all-images main-window)))) ((gemini-client:header-redirect-p status-code) (when (gui:ask-yesno (format nil (_ "Follow redirection to ~a?") meta) :title (_ "Redirection") diff --git a/src/gui/client/scheduler.lisp b/src/gui/client/scheduler.lisp index 461aa15..93a1027 100644 --- a/src/gui/client/scheduler.lisp +++ b/src/gui/client/scheduler.lisp @@ -40,19 +40,24 @@ (funcall (function ,event-fn))) (gui:after ,frequency (function ,event-fn))))))) +(defun notify (message) + (when gui-goodies:*main-frame* + (client-main-window:print-info-message message))) + (define-scheduled-procedure (refresh-gemlog-subscriptions +refresh-gemlog-subscriptions-frequency+) - (client-main-window:print-info-message (_ "Gemlogs subscriptions updating in progress…")) + + (notify (_ "Gemlogs subscriptions updating in progress…")) (comm:make-request :gemini-gemlog-refresh-all-subscriptions 1) - (client-main-window:print-info-message (_ "Gemlogs subscriptions updated"))) + (notify (_ "Gemlogs subscriptions updated"))) (define-scheduled-procedure (purge-gemlogs +purge-gemlog-entries-frequency+) (comm:make-request :gemini-purge-gemlog-entries 1) - (client-main-window:print-info-message (_ "Old gemlog posts deleted"))) + (notify (_ "Old gemlog posts deleted"))) (define-scheduled-procedure (purge-history +purge-history-frequency+) (comm:make-request :purge-history 1) - (client-main-window:print-info-message (_ "Old history entries removed"))) + (notify (_ "Old history entries removed"))) (defun start () (refresh-gemlog-subscriptions :start-on-boot t) diff --git a/src/gui/server/public-api-gemini-stream.lisp b/src/gui/server/public-api-gemini-stream.lisp index 849b892..36473df 100644 --- a/src/gui/server/public-api-gemini-stream.lisp +++ b/src/gui/server/public-api-gemini-stream.lisp @@ -517,10 +517,12 @@ (defmethod yason:encode ((object gemini-toc) &optional (stream *standard-output*)) (encode-flat-array-of-plists (unbox object) stream)) -(defun gemini-parse-string (string) +(defun gemini-parse-string (string &optional (wrap t)) (let ((parsed-lines (gemini-parser:parse-gemini-file string :initialize-parser t))) - (make-instance 'parsed-lines-slice - :contents (rearrange-parsed-line-for-encoding parsed-lines)))) + (if wrap + (make-instance 'parsed-lines-slice + :contents (rearrange-parsed-line-for-encoding parsed-lines)) + parsed-lines))) (defun gemini-parse-local-file (path) (if (fs:file-exists-p path) @@ -537,21 +539,30 @@ (a:define-constant +error-template-meta-placeholder+ "{meta}" :test #'string=) (defun construct-error-page (iri code meta) - (ignore-errors - (a:when-let* ((file-path (res:get-data-file (fs:cat-parent-dir +error-pages-path+ - (to-s code)))) - (template (fs:slurp-file file-path))) - (setf template (cl-ppcre:regex-replace-all +error-template-url-placeholder+ - template - iri)) - (setf template (cl-ppcre:regex-replace-all +error-template-meta-placeholder+ - template - meta))))) + (a:when-let* ((file-path (ignore-errors + (res:get-data-file (fs:cat-parent-dir +error-pages-path+ + (to-s code))))) + (template (fs:slurp-file file-path))) + (setf template (cl-ppcre:regex-replace-all +error-template-url-placeholder+ + template + iri)) + (setf template (cl-ppcre:regex-replace-all +error-template-meta-placeholder+ + template + meta)) + (let ((parsed-file (gemini-parse-string template nil))) + (loop for line in parsed-file + when (eq (first line) :a) + do + (let ((link-value (res:get-data-file + (fs:cat-parent-dir +error-pages-path+ + (second (assoc :href (second line))))))) + (setf (second (assoc :href (second line))) link-value))) + (make-instance 'parsed-lines-slice + :contents (rearrange-parsed-line-for-encoding parsed-file))))) (defun make-error-page (iri code description meta) (let ((error-gemtext (construct-error-page iri code meta))) - (if error-gemtext - (gemini-parse-string error-gemtext) + (or error-gemtext (let* ((separator (make-string 10 :initial-element gemini-parser::+h2-underline+)) (gemtext (with-output-to-string (stream) (write-sequence (gemini-parser:geminize-h2 (format nil