mirror of https://codeberg.org/cage/tinmop/
- updated Makefiles;
- allowed loading a local file in 'slurp-iri' if the IRI argument lacks scheme, and authority components; - allowed inlining of images from local path; - allowed linking of local resources in error page; - inlined images automatically in error pages.
This commit is contained in:
parent
3716531de7
commit
88c86f2def
|
@ -43,6 +43,7 @@ confdir = $(sysconfdir)/$(PACKAGE)
|
||||||
dist_conf_DATA = etc/init.lisp etc/default-theme.conf etc/shared.conf etc/gui.conf
|
dist_conf_DATA = etc/init.lisp etc/default-theme.conf etc/shared.conf etc/gui.conf
|
||||||
|
|
||||||
nobase_dist_pkgdata_DATA = data/error-pages/51 \
|
nobase_dist_pkgdata_DATA = data/error-pages/51 \
|
||||||
|
data/error-pages/header-51.png \
|
||||||
data/icons/fmw_arrow-down.png \
|
data/icons/fmw_arrow-down.png \
|
||||||
data/icons/fmw_arrow-up.png \
|
data/icons/fmw_arrow-up.png \
|
||||||
data/icons/fmw_back.png \
|
data/icons/fmw_back.png \
|
||||||
|
|
|
@ -408,6 +408,7 @@ doc/tinmop.org doc/send-toot.lisp NEWS.org ChangeLog AUTHORS
|
||||||
confdir = $(sysconfdir)/$(PACKAGE)
|
confdir = $(sysconfdir)/$(PACKAGE)
|
||||||
dist_conf_DATA = etc/init.lisp etc/default-theme.conf etc/shared.conf etc/gui.conf
|
dist_conf_DATA = etc/init.lisp etc/default-theme.conf etc/shared.conf etc/gui.conf
|
||||||
nobase_dist_pkgdata_DATA = data/error-pages/51 \
|
nobase_dist_pkgdata_DATA = data/error-pages/51 \
|
||||||
|
data/error-pages/header-51.png \
|
||||||
data/icons/fmw_arrow-down.png \
|
data/icons/fmw_arrow-down.png \
|
||||||
data/icons/fmw_arrow-up.png \
|
data/icons/fmw_arrow-up.png \
|
||||||
data/icons/fmw_back.png \
|
data/icons/fmw_back.png \
|
||||||
|
|
|
@ -1,8 +1,7 @@
|
||||||
# Error!
|
# Error!
|
||||||
|
|
||||||
### {url}
|
=> ./header-51.png picture of crashed rocket 🫤
|
||||||
### not found
|
|
||||||
|
|
||||||
### Server replied:
|
## {url} was not found
|
||||||
|
|
||||||
### {meta}
|
### Server replied: ˝{meta}˝
|
||||||
|
|
Binary file not shown.
After Width: | Height: | Size: 76 KiB |
|
@ -338,53 +338,57 @@
|
||||||
query))))
|
query))))
|
||||||
|
|
||||||
(defun slurp-iri (main-window iri)
|
(defun slurp-iri (main-window iri)
|
||||||
(let ((connecting-response (cev:enqueue-request-and-wait-results :gemini-request
|
(if (not (iri:absolute-url-p iri))
|
||||||
1
|
(if (fs:file-exists-p iri)
|
||||||
ev:+maximum-event-priority+
|
iri
|
||||||
iri
|
(error (_ "file ~a not found" iri)))
|
||||||
t
|
(let ((connecting-response (cev:enqueue-request-and-wait-results :gemini-request
|
||||||
nil)))
|
1
|
||||||
(multiple-value-bind (status-code
|
ev:+maximum-event-priority+
|
||||||
status-description
|
iri
|
||||||
meta
|
t
|
||||||
cached
|
nil)))
|
||||||
original-iri)
|
(multiple-value-bind (status-code
|
||||||
(displace-gemini-response connecting-response)
|
status-description
|
||||||
(declare (ignore original-iri cached))
|
meta
|
||||||
(cond
|
cached
|
||||||
((gemini-client:header-input-p status-code)
|
original-iri)
|
||||||
(let ((actual-iri (get-user-request-query iri meta main-window)))
|
(displace-gemini-response connecting-response)
|
||||||
(slurp-iri main-window actual-iri)))
|
(declare (ignore original-iri cached))
|
||||||
((gemini-client:header-sensitive-input-p status-code)
|
(cond
|
||||||
(let ((actual-iri (get-user-request-query iri meta main-window :sensitive t)))
|
((gemini-client:header-input-p status-code)
|
||||||
(slurp-iri main-window actual-iri)))
|
(let ((actual-iri (get-user-request-query iri meta main-window)))
|
||||||
((= status-code comm:+tofu-error-status-code+)
|
(slurp-iri main-window actual-iri)))
|
||||||
(when (gui:ask-yesno meta
|
((gemini-client:header-sensitive-input-p status-code)
|
||||||
:title (_ "Server certificate error")
|
(let ((actual-iri (get-user-request-query iri meta main-window :sensitive t)))
|
||||||
:parent main-window)
|
(slurp-iri main-window actual-iri)))
|
||||||
(cev:enqueue-request-and-wait-results :gemini-delete-certificate
|
((= status-code comm:+tofu-error-status-code+)
|
||||||
1
|
(when (gui:ask-yesno meta
|
||||||
ev:+maximum-event-priority+
|
:title (_ "Server certificate error")
|
||||||
iri)
|
:parent main-window)
|
||||||
(slurp-iri main-window iri)))
|
(cev:enqueue-request-and-wait-results :gemini-delete-certificate
|
||||||
((or (gemini-client:header-temporary-failure-p status-code)
|
1
|
||||||
(gemini-client:header-permanent-failure-p status-code)
|
ev:+maximum-event-priority+
|
||||||
(gemini-client:header-certificate-failure-p status-code))
|
iri)
|
||||||
(gui-goodies:notify-request-error (format nil
|
(slurp-iri main-window iri)))
|
||||||
"Error getting ~a (~a ~a)"
|
((or (gemini-client:header-temporary-failure-p status-code)
|
||||||
iri
|
(gemini-client:header-permanent-failure-p status-code)
|
||||||
status-code
|
(gemini-client:header-certificate-failure-p status-code))
|
||||||
status-description)))
|
(gui-goodies:notify-request-error (format nil
|
||||||
((gemini-client:header-redirect-p status-code)
|
"Error getting ~a (~a ~a)"
|
||||||
(when (gui:ask-yesno (format nil (_ "Follow redirection to ~a?") meta)
|
iri
|
||||||
:title (_ "Redirection")
|
status-code
|
||||||
:parent main-window)
|
status-description)))
|
||||||
(let ((redirect-iri (if (iri:absolute-url-p meta)
|
((gemini-client:header-redirect-p status-code)
|
||||||
meta
|
(when (gui:ask-yesno (format nil (_ "Follow redirection to ~a?") meta)
|
||||||
(absolutize-link iri meta))))
|
:title (_ "Redirection")
|
||||||
(slurp-iri redirect-iri main-window))))
|
:parent main-window)
|
||||||
((gemini-client:header-success-p status-code)
|
(let ((redirect-iri (if (iri:absolute-url-p meta)
|
||||||
(slurp-non-text-data main-window iri :try-to-open nil))))))
|
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)
|
(defun inline-image-p (link-value)
|
||||||
(a:when-let* ((parsed (iri:iri-parse link-value :null-on-error t))
|
(a:when-let* ((parsed (iri:iri-parse link-value :null-on-error t))
|
||||||
|
@ -428,14 +432,19 @@
|
||||||
(1- line-index)))))))
|
(1- line-index)))))))
|
||||||
|
|
||||||
(defun inline-all-images (main-window)
|
(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)
|
(gui-goodies:with-busy* (main-window)
|
||||||
(loop for line across (ir-lines main-window)
|
(loop for line across (ir-lines main-window)
|
||||||
for line-number from 1
|
for line-number from 1
|
||||||
when (and (string= (getf line :type) "a")
|
when (and (string= (getf line :type) "a")
|
||||||
(inline-image-p (getf line :href)))
|
(inline-image-p (getf line :href)))
|
||||||
do
|
do
|
||||||
(let ((link-value (absolutize-link (get-address-bar-text main-window)
|
(let ((link-value (if (fs:file-exists-p (getf line :href))
|
||||||
(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)
|
(inline-image main-window link-value line-number)
|
||||||
(incf line-number)))))
|
(incf line-number)))))
|
||||||
|
|
||||||
|
@ -979,7 +988,9 @@
|
||||||
status-code
|
status-code
|
||||||
status-description
|
status-description
|
||||||
meta)))
|
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)
|
((gemini-client:header-redirect-p status-code)
|
||||||
(when (gui:ask-yesno (format nil (_ "Follow redirection to ~a?") meta)
|
(when (gui:ask-yesno (format nil (_ "Follow redirection to ~a?") meta)
|
||||||
:title (_ "Redirection")
|
:title (_ "Redirection")
|
||||||
|
|
|
@ -40,19 +40,24 @@
|
||||||
(funcall (function ,event-fn)))
|
(funcall (function ,event-fn)))
|
||||||
(gui:after ,frequency (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
|
(define-scheduled-procedure (refresh-gemlog-subscriptions
|
||||||
+refresh-gemlog-subscriptions-frequency+)
|
+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)
|
(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+)
|
(define-scheduled-procedure (purge-gemlogs +purge-gemlog-entries-frequency+)
|
||||||
(comm:make-request :gemini-purge-gemlog-entries 1)
|
(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+)
|
(define-scheduled-procedure (purge-history +purge-history-frequency+)
|
||||||
(comm:make-request :purge-history 1)
|
(comm:make-request :purge-history 1)
|
||||||
(client-main-window:print-info-message (_ "Old history entries removed")))
|
(notify (_ "Old history entries removed")))
|
||||||
|
|
||||||
(defun start ()
|
(defun start ()
|
||||||
(refresh-gemlog-subscriptions :start-on-boot t)
|
(refresh-gemlog-subscriptions :start-on-boot t)
|
||||||
|
|
|
@ -517,10 +517,12 @@
|
||||||
(defmethod yason:encode ((object gemini-toc) &optional (stream *standard-output*))
|
(defmethod yason:encode ((object gemini-toc) &optional (stream *standard-output*))
|
||||||
(encode-flat-array-of-plists (unbox object) stream))
|
(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)))
|
(let ((parsed-lines (gemini-parser:parse-gemini-file string :initialize-parser t)))
|
||||||
(make-instance 'parsed-lines-slice
|
(if wrap
|
||||||
:contents (rearrange-parsed-line-for-encoding parsed-lines))))
|
(make-instance 'parsed-lines-slice
|
||||||
|
:contents (rearrange-parsed-line-for-encoding parsed-lines))
|
||||||
|
parsed-lines)))
|
||||||
|
|
||||||
(defun gemini-parse-local-file (path)
|
(defun gemini-parse-local-file (path)
|
||||||
(if (fs:file-exists-p path)
|
(if (fs:file-exists-p path)
|
||||||
|
@ -537,21 +539,30 @@
|
||||||
(a:define-constant +error-template-meta-placeholder+ "{meta}" :test #'string=)
|
(a:define-constant +error-template-meta-placeholder+ "{meta}" :test #'string=)
|
||||||
|
|
||||||
(defun construct-error-page (iri code meta)
|
(defun construct-error-page (iri code meta)
|
||||||
(ignore-errors
|
(a:when-let* ((file-path (ignore-errors
|
||||||
(a:when-let* ((file-path (res:get-data-file (fs:cat-parent-dir +error-pages-path+
|
(res:get-data-file (fs:cat-parent-dir +error-pages-path+
|
||||||
(to-s code))))
|
(to-s code)))))
|
||||||
(template (fs:slurp-file file-path)))
|
(template (fs:slurp-file file-path)))
|
||||||
(setf template (cl-ppcre:regex-replace-all +error-template-url-placeholder+
|
(setf template (cl-ppcre:regex-replace-all +error-template-url-placeholder+
|
||||||
template
|
template
|
||||||
iri))
|
iri))
|
||||||
(setf template (cl-ppcre:regex-replace-all +error-template-meta-placeholder+
|
(setf template (cl-ppcre:regex-replace-all +error-template-meta-placeholder+
|
||||||
template
|
template
|
||||||
meta)))))
|
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)
|
(defun make-error-page (iri code description meta)
|
||||||
(let ((error-gemtext (construct-error-page iri code meta)))
|
(let ((error-gemtext (construct-error-page iri code meta)))
|
||||||
(if error-gemtext
|
(or error-gemtext
|
||||||
(gemini-parse-string error-gemtext)
|
|
||||||
(let* ((separator (make-string 10 :initial-element gemini-parser::+h2-underline+))
|
(let* ((separator (make-string 10 :initial-element gemini-parser::+h2-underline+))
|
||||||
(gemtext (with-output-to-string (stream)
|
(gemtext (with-output-to-string (stream)
|
||||||
(write-sequence (gemini-parser:geminize-h2 (format nil
|
(write-sequence (gemini-parser:geminize-h2 (format nil
|
||||||
|
|
Loading…
Reference in New Issue