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

- 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:
cage 2023-07-21 14:30:16 +02:00
parent 3716531de7
commit 88c86f2def
7 changed files with 101 additions and 73 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

1
Makefile.am
View File

@ -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 \

1
Makefile.in
View File

@ -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 \

7
data/error-pages/51
View File

@ -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}˝

BIN
data/error-pages/header-51.png Normal file
View File

Binary file not shown.
Side by Side

After

Width:  |  Height:  |  Size: 76 KiB

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

@ -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")

13
src/gui/client/scheduler.lisp
View File

@ -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)

41
src/gui/server/public-api-gemini-stream.lisp
View File

@ -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