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

- [GUI] started adding feature to inline bitmaps.

This commit is contained in:
cage 2023-05-12 14:04:08 +02:00
parent 786775f106
commit b73c0856f2
1 changed files with 103 additions and 34 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

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

@ -318,40 +318,106 @@
path path
query)))) 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)))
(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))
(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 contextual-menu-link-clrs (link-name link-value main-window) (defun contextual-menu-link-clrs (link-name link-value main-window)
(flet ((add-to-tour-callback () (labels ((add-to-tour-callback ()
(ev:with-enqueued-process-and-unblock () (ev:with-enqueued-process-and-unblock ()
(comm:make-request :tour-add-link (comm:make-request :tour-add-link
1 1
link-value link-value
link-name))) link-name)))
(download-background-callback () (download-background-callback ()
(open-iri link-value main-window nil :status +stream-status-downloading+)) (open-iri link-value main-window nil :status +stream-status-downloading+))
(copy-link-callback () (copy-link-callback ()
(os-utils:copy-to-clipboard link-value) (os-utils:copy-to-clipboard link-value)
(print-info-message (format nil (print-info-message (format nil
(_ "~s has been copied to the clipboard") (_ "~s has been copied to the clipboard")
link-value))) link-value)))
(bookmark-link-callback () (bookmark-link-callback ()
(let ((bookmarkedp (cev:enqueue-request-and-wait-results :gemini-bookmarked-p (let ((bookmarkedp (cev:enqueue-request-and-wait-results :gemini-bookmarked-p
1 1
ev:+standard-event-priority+ ev:+standard-event-priority+
link-value))) link-value)))
(if bookmarkedp (if bookmarkedp
(print-info-message (format nil (print-info-message (format nil
(_ "~s already bookmarked") (_ "~s already bookmarked")
link-value) link-value)
:bold t) :bold t)
(client-bookmark-window:init-window main-window link-value))))) (client-bookmark-window:init-window main-window link-value))))
(inline-possible-p ()
(or (re:scan "(?i)jpg$" link-value)
(re:scan "(?i)jpeg$" link-value)
(re:scan "(?i)png$" link-value)
(re:scan "(?i)gif$" link-value)
(re:scan "(?i)bmp$" link-value)
(re:scan "(?i)tga$" link-value)))
(open-inline-clsr (x y)
(lambda ()
(if (inline-possible-p)
(let* ((file-path (slurp-iri main-window link-value))
(image (gui:make-image file-path))
(coordinates `(+ (:x ,x :y ,y) 1 :lines)))
(gui:insert-image (gemtext-widget main-window) image coordinates))
(funcall (link-click-mouse-1-callback-clsr link-value main-window))))))
(lambda () (lambda ()
(let* ((popup-menu (gui:make-menu nil (_"link menu")))) (let* ((popup-menu (gui:make-menu nil (_"link menu")))
(x (gui:screen-mouse-x))
(y (gui:screen-mouse-y)))
(gui:make-menubutton popup-menu (_ "Inline") (open-inline-clsr x y))
(gui:make-menubutton popup-menu (_ "Add link to bookmarks") #'bookmark-link-callback) (gui:make-menubutton popup-menu (_ "Add link to bookmarks") #'bookmark-link-callback)
(gui:make-menubutton popup-menu (_ "Add link to tour") #'add-to-tour-callback) (gui:make-menubutton popup-menu (_ "Add link to tour") #'add-to-tour-callback)
(gui:make-menubutton popup-menu (_ "Copy link to the clipboard") #'copy-link-callback) (gui:make-menubutton popup-menu (_ "Copy link to the clipboard") #'copy-link-callback)
(gui:make-menubutton popup-menu (gui:make-menubutton popup-menu
(_ "Open link in background") (_ "Open link in background")
#'download-background-callback) #'download-background-callback)
(gui:popup popup-menu (gui:screen-mouse-x) (gui:screen-mouse-y)))))) (gui:popup popup-menu x y)))))
(defun collect-ir-lines (request-iri main-window lines) (defun collect-ir-lines (request-iri main-window lines)
(with-accessors ((ir-lines ir-lines) (with-accessors ((ir-lines ir-lines)
@ -630,13 +696,15 @@
(maybe-open-if-completed stream-info support-file)))) (maybe-open-if-completed stream-info support-file))))
(wait-enough-data))) (wait-enough-data)))
(defun slurp-non-text-data (main-window iri) (defun slurp-non-text-data (main-window iri &key (try-to-open t))
(labels ((maybe-open-if-completed (stream-info support-file) (labels ((wait-until-download-complete (stream-info support-file)
(if (string-equal (getf stream-info :stream-status) (if (string-equal (getf stream-info :stream-status)
:completed) :completed)
(client-os-utils:open-resource-with-external-program main-window support-file) (if try-to-open
(client-os-utils:open-resource-with-external-program main-window support-file)
(getf stream-info :support-file))
(wait-enough-data))) (wait-enough-data)))
(buffer-filled-enough--to-open-p (buffer-size read-so-far) (buffer-filled-enough-to-open-p (buffer-size read-so-far)
(let ((filled-configuration-threshold (and buffer-size (let ((filled-configuration-threshold (and buffer-size
(> read-so-far buffer-size)))) (> read-so-far buffer-size))))
(or filled-configuration-threshold (or filled-configuration-threshold
@ -654,14 +722,15 @@
(swconf:link-regex->program-to-use support-file) (swconf:link-regex->program-to-use support-file)
(declare (ignore y)) (declare (ignore y))
(if program-exists (if program-exists
(if wait-for-download (if (or wait-for-download
(maybe-open-if-completed stream-info support-file) (not try-to-open))
(wait-until-download-complete stream-info support-file)
(let ((buffer-size (swconf:link-regex->program-to-use-buffer-size support-file))) (let ((buffer-size (swconf:link-regex->program-to-use-buffer-size support-file)))
(if (buffer-filled-enough--to-open-p buffer-size read-so-far) (if (buffer-filled-enough-to-open-p buffer-size read-so-far)
(client-os-utils:open-resource-with-external-program main-window (client-os-utils:open-resource-with-external-program main-window
support-file) support-file)
(wait-enough-data)))) (wait-enough-data))))
(maybe-open-if-completed stream-info support-file)))))) (wait-until-download-complete stream-info support-file))))))
(wait-enough-data))) (wait-enough-data)))
(defun start-stream-iri (iri main-window use-cache &optional (status +stream-status-streaming+)) (defun start-stream-iri (iri main-window use-cache &optional (status +stream-status-streaming+))