2023-02-05 14:07:13 +01:00
|
|
|
(in-package :client-main-window)
|
|
|
|
|
|
|
|
(named-readtables:in-readtable nodgui.syntax:nodgui-syntax)
|
|
|
|
|
|
|
|
(defclass gemini-stream ()
|
|
|
|
((server-stream-handle
|
|
|
|
:initform nil
|
|
|
|
:initarg :server-stream-handle
|
|
|
|
:accessor server-stream-handle)
|
|
|
|
(status
|
2023-03-06 18:38:46 +01:00
|
|
|
:initform +stream-status-streaming+
|
2023-02-05 14:07:13 +01:00
|
|
|
:initarg :status
|
|
|
|
:accessor status)
|
|
|
|
(status-lock
|
|
|
|
:initform (bt:make-lock)
|
|
|
|
:reader status-lock)
|
|
|
|
(fetching-thread
|
|
|
|
:initform nil
|
|
|
|
:initarg :fetching-thread
|
|
|
|
:accessor fetching-thread)))
|
|
|
|
|
|
|
|
(defgeneric status (object))
|
|
|
|
|
2023-09-16 19:05:33 +02:00
|
|
|
(defgeneric streaming-url (object))
|
|
|
|
|
2023-02-05 14:07:13 +01:00
|
|
|
(defmethod status ((object gemini-stream))
|
|
|
|
(misc:with-lock ((status-lock object))
|
|
|
|
(slot-value object 'status)))
|
|
|
|
|
|
|
|
(defmethod (setf status) ((object gemini-stream) val)
|
|
|
|
(misc:with-lock ((status-lock object))
|
|
|
|
(setf (slot-value object 'status) val)
|
|
|
|
val))
|
|
|
|
|
2023-09-16 19:05:33 +02:00
|
|
|
(defmethod streaming-url ((object gemini-stream))
|
|
|
|
(server-stream-handle object))
|
|
|
|
|
2023-02-05 14:07:13 +01:00
|
|
|
(defparameter *gemini-streams-db* ())
|
|
|
|
|
2023-09-16 19:05:33 +02:00
|
|
|
(defparameter *gemini-streams-db-lock* (bt:make-lock "gemini-streams-db-lock"))
|
|
|
|
|
2023-02-05 14:07:13 +01:00
|
|
|
(defun push-db-stream (stream-object)
|
2023-09-16 19:05:33 +02:00
|
|
|
(misc:with-lock (*gemini-streams-db-lock*)
|
|
|
|
(pushnew stream-object
|
|
|
|
*gemini-streams-db*
|
|
|
|
:test (lambda (a b)
|
|
|
|
(string= (server-stream-handle a)
|
|
|
|
(server-stream-handle b))))
|
|
|
|
*gemini-streams-db*))
|
2023-02-05 14:07:13 +01:00
|
|
|
|
|
|
|
(defun remove-db-stream (stream-object)
|
2023-09-16 19:05:33 +02:00
|
|
|
(misc:with-lock (*gemini-streams-db-lock*)
|
|
|
|
(setf *gemini-streams-db*
|
|
|
|
(remove stream-object *gemini-streams-db*))
|
|
|
|
*gemini-streams-db*))
|
2023-02-05 14:07:13 +01:00
|
|
|
|
|
|
|
(defmethod abort-downloading ((object gemini-stream))
|
2023-03-06 18:38:46 +01:00
|
|
|
(setf (status object) +stream-status-canceled+))
|
2023-02-05 14:07:13 +01:00
|
|
|
|
|
|
|
(defun remove-all-db-stream ()
|
2023-09-16 19:05:33 +02:00
|
|
|
(misc:with-lock (*gemini-streams-db-lock*)
|
|
|
|
(map nil
|
|
|
|
(lambda (a) (abort-downloading a))
|
|
|
|
*gemini-streams-db*)
|
|
|
|
(setf *gemini-streams-db* ())
|
|
|
|
*gemini-streams-db*))
|
2023-02-05 14:07:13 +01:00
|
|
|
|
|
|
|
(defun find-db-stream-if (predicate)
|
2023-09-16 19:05:33 +02:00
|
|
|
(misc:with-lock (*gemini-streams-db-lock*)
|
|
|
|
(find-if predicate *gemini-streams-db*)))
|
2023-02-05 14:07:13 +01:00
|
|
|
|
|
|
|
(defun find-db-stream-url (url)
|
|
|
|
(find-db-stream-if (lambda (a) (string= (server-stream-handle a) url))))
|
|
|
|
|
2023-03-06 18:38:46 +01:00
|
|
|
(defun find-streaming-stream-url ()
|
|
|
|
(find-db-stream-if (lambda (a) (eq (status a) +stream-status-streaming+))))
|
|
|
|
|
|
|
|
(defgeneric stop-stream-thread (object))
|
|
|
|
|
|
|
|
(defmethod stop-stream-thread ((object gemini-stream))
|
|
|
|
(with-accessors ((fetching-thread fetching-thread)) object
|
2023-04-02 17:05:14 +02:00
|
|
|
(abort-downloading object)
|
|
|
|
(when (and (bt:threadp fetching-thread)
|
|
|
|
(bt:thread-alive-p fetching-thread))
|
2023-03-11 14:12:30 +01:00
|
|
|
(bt:join-thread fetching-thread)))
|
|
|
|
object)
|
2023-03-06 18:38:46 +01:00
|
|
|
|
|
|
|
(defmethod stop-stream-thread ((object string))
|
|
|
|
(let ((stream-wrapper (find-db-stream-url object)))
|
|
|
|
(stop-stream-thread stream-wrapper)))
|
|
|
|
|
2023-08-16 15:36:39 +02:00
|
|
|
(defun stop-streaming-stream-thread ()
|
2023-03-06 18:38:46 +01:00
|
|
|
(let ((stream-wrapper (find-streaming-stream-url)))
|
|
|
|
(stop-stream-thread stream-wrapper)))
|
|
|
|
|
2023-08-16 15:36:39 +02:00
|
|
|
(defun maybe-stop-streaming-stream-thread ()
|
2023-03-06 18:38:46 +01:00
|
|
|
(a:when-let ((stream-wrapper (find-streaming-stream-url)))
|
|
|
|
(stop-stream-thread stream-wrapper)))
|
|
|
|
|
2023-02-19 16:15:10 +01:00
|
|
|
(defun enqueue-request-notify-error (method-name id &rest args)
|
|
|
|
(ev:with-enqueued-process-and-unblock ()
|
2023-06-18 14:48:40 +02:00
|
|
|
(gui-goodies:with-notify-errors
|
2023-02-19 16:15:10 +01:00
|
|
|
(apply #'comm:make-request method-name id args))))
|
|
|
|
|
2023-03-19 13:00:28 +01:00
|
|
|
(defun render-toc (main-window iri)
|
2023-06-18 14:48:40 +02:00
|
|
|
(gui-goodies:with-notify-errors
|
2023-03-19 13:00:28 +01:00
|
|
|
(toc-clear main-window)
|
|
|
|
(let* ((toc-max-width (gui-conf:config-toc-maximum-width))
|
|
|
|
(toc (comm:make-request :gemini-table-of-contents
|
|
|
|
1
|
|
|
|
iri
|
|
|
|
toc-max-width)))
|
|
|
|
(when toc
|
|
|
|
(let ((toc-widget-width (length (getf (first toc) :text))))
|
|
|
|
(loop for ct from 0
|
|
|
|
for toc-item in toc do
|
|
|
|
(gui:listbox-append (toc-listbox (toc-frame main-window))
|
2023-03-19 14:32:11 +01:00
|
|
|
(getf toc-item :text)))
|
|
|
|
(setf (toc-data (toc-frame main-window))
|
2023-05-20 16:50:31 +02:00
|
|
|
(loop for toc-item in toc collect (getf toc-item :header-group-id)))
|
|
|
|
(fit-toc-char-width main-window toc-widget-width)))
|
2023-03-19 14:32:11 +01:00
|
|
|
main-window)))
|
2023-03-19 13:00:28 +01:00
|
|
|
|
2023-05-23 18:38:01 +02:00
|
|
|
(defun slurp-gemini-stream (main-window iri stream-wrapper
|
|
|
|
&key
|
|
|
|
(use-cache t)
|
|
|
|
(process-function #'identity)
|
|
|
|
(aborting-function (constantly nil)))
|
|
|
|
(ev:with-enqueued-process-and-unblock ()
|
|
|
|
(set-focus-to-gemtext main-window))
|
2023-07-09 19:14:45 +02:00
|
|
|
(enqueue-request-notify-error :gemini-request 1 iri use-cache nil)
|
2023-02-09 16:28:53 +01:00
|
|
|
(labels ((stream-exausted-p ()
|
2023-03-19 12:21:51 +01:00
|
|
|
(let ((status-completed (comm:make-request :gemini-stream-completed-p
|
|
|
|
1
|
|
|
|
iri)))
|
2023-02-09 16:28:53 +01:00
|
|
|
status-completed))
|
2023-08-16 16:14:25 +02:00
|
|
|
(perform-after-stream-exausted-actions ()
|
2023-09-16 19:05:33 +02:00
|
|
|
(a:when-let ((current-streaming-stream (find-streaming-stream-url)))
|
|
|
|
(setf (status current-streaming-stream) +stream-status-completed+))
|
2023-08-16 16:14:25 +02:00
|
|
|
(print-info-message (_ "Stream finished"))
|
|
|
|
(gui:configure-mouse-pointer (gemtext-widget main-window) :xterm)
|
|
|
|
(render-toc main-window iri)
|
|
|
|
(a:when-let* ((fragment (uri:fragment (iri:iri-parse iri)))
|
|
|
|
(regexp (gemini-viewer::fragment->regex fragment)))
|
|
|
|
(setf (gui:text (client-search-frame::entry (search-frame main-window)))
|
|
|
|
regexp)
|
|
|
|
(funcall (client-search-frame::start-search-clsr (search-frame main-window)
|
|
|
|
(gemtext-widget main-window)
|
|
|
|
nil)
|
|
|
|
nil)))
|
2023-02-09 16:28:53 +01:00
|
|
|
(loop-fetch (&optional (last-lines-fetched-count 0))
|
2023-03-17 12:27:46 +01:00
|
|
|
(ev:with-enqueued-process-and-unblock ()
|
2023-06-18 14:48:40 +02:00
|
|
|
(gui-goodies:with-notify-errors
|
2023-03-17 12:27:46 +01:00
|
|
|
(let* ((last-lines-fetched (comm:make-request :gemini-stream-parsed-line-slice
|
|
|
|
1
|
|
|
|
iri
|
|
|
|
last-lines-fetched-count
|
|
|
|
nil))
|
|
|
|
(next-start-fetching (length last-lines-fetched)))
|
|
|
|
(when last-lines-fetched
|
|
|
|
(funcall process-function stream-wrapper last-lines-fetched))
|
2023-08-16 16:14:25 +02:00
|
|
|
(if (not (or (funcall aborting-function)
|
2023-03-17 12:27:46 +01:00
|
|
|
(and (stream-exausted-p)
|
2023-06-30 14:45:54 +02:00
|
|
|
(<= next-start-fetching 0))))
|
2023-08-16 16:14:25 +02:00
|
|
|
(loop-fetch (+ last-lines-fetched-count
|
|
|
|
next-start-fetching))
|
|
|
|
(perform-after-stream-exausted-actions)))))))
|
2023-03-18 20:27:24 +01:00
|
|
|
(loop-fetch)
|
2023-04-09 10:05:59 +02:00
|
|
|
(if (cev:enqueue-request-and-wait-results :gemini-bookmarked-p
|
2023-05-07 12:21:29 +02:00
|
|
|
1
|
|
|
|
ev:+standard-event-priority+
|
|
|
|
iri)
|
2023-05-23 18:38:01 +02:00
|
|
|
(ev:with-enqueued-process-and-unblock ()
|
|
|
|
(set-bookmark-button-true main-window))
|
|
|
|
(ev:with-enqueued-process-and-unblock ()
|
|
|
|
(set-bookmark-button-false main-window)))
|
2023-05-07 12:21:29 +02:00
|
|
|
(ev:with-enqueued-process-and-unblock ()
|
2023-09-16 19:05:33 +02:00
|
|
|
(set-gemlog-toolbar-button-appearance main-window iri))
|
|
|
|
(ev:with-enqueued-process-and-unblock (program-events:+minimum-event-priority+)
|
|
|
|
(client-stream-frame::refresh-all-streams
|
|
|
|
(client-stream-frame::table (stream-frame main-window))
|
2023-09-17 14:41:59 +02:00
|
|
|
#'client-stream-frame::make-requests-all-rows))))
|
2023-05-07 12:46:33 +02:00
|
|
|
|
|
|
|
(defun set-gemlog-toolbar-button-appearance (main-window iri)
|
|
|
|
(if (comm:make-request :gemini-gemlog-subscribed-p 1 iri)
|
|
|
|
(set-subscribe-button-subscribed main-window)
|
|
|
|
(set-subscribe-button-unsubscribed main-window)))
|
2023-03-18 20:27:24 +01:00
|
|
|
|
|
|
|
(defun start-streaming-thread (main-window iri
|
|
|
|
&key
|
|
|
|
(use-cache t)
|
|
|
|
(process-function #'identity)
|
|
|
|
(status +stream-status-streaming+))
|
2023-03-06 18:38:46 +01:00
|
|
|
(let ((existing-stream (find-db-stream-url iri)))
|
|
|
|
(when existing-stream
|
|
|
|
(stop-stream-thread existing-stream)
|
|
|
|
(setf (status existing-stream) status))
|
|
|
|
(let ((stream-wrapper (or existing-stream
|
|
|
|
(make-instance 'gemini-stream
|
|
|
|
:server-stream-handle iri
|
|
|
|
:status status))))
|
|
|
|
(when (not existing-stream)
|
|
|
|
(push-db-stream stream-wrapper))
|
2023-02-05 14:07:13 +01:00
|
|
|
(flet ((aborting-function ()
|
2023-03-06 18:38:46 +01:00
|
|
|
(eq (status stream-wrapper) +stream-status-canceled+)))
|
2023-04-14 17:13:41 +02:00
|
|
|
(print-info-message (_ "Stream started"))
|
2023-02-05 14:07:13 +01:00
|
|
|
(let ((stream-thread (bt:make-thread (lambda ()
|
2023-03-18 20:27:24 +01:00
|
|
|
(slurp-gemini-stream main-window
|
|
|
|
iri
|
2023-03-15 17:18:38 +01:00
|
|
|
stream-wrapper
|
2023-02-09 16:28:53 +01:00
|
|
|
:use-cache use-cache
|
|
|
|
:process-function
|
|
|
|
process-function
|
|
|
|
:aborting-function
|
|
|
|
#'aborting-function)))))
|
2023-02-05 14:07:13 +01:00
|
|
|
(setf (fetching-thread stream-wrapper) stream-thread)
|
2023-03-06 18:38:46 +01:00
|
|
|
stream-wrapper)))))
|
|
|
|
|
2023-04-09 11:29:01 +02:00
|
|
|
(defun initialize-menu (parent main-window)
|
|
|
|
(let* ((bar (gui:make-menubar parent))
|
2023-05-14 16:25:13 +02:00
|
|
|
(file (gui:make-menu bar (_ "File")))
|
|
|
|
(tools (gui:make-menu bar (_ "Tools")))
|
|
|
|
(tour (gui:make-menu bar (_ "Tour")))
|
|
|
|
(bookmarks (gui:make-menu bar (_ "Bookmarks")))
|
|
|
|
(gemlogs (gui:make-menu bar (_ "Gemlogs")))
|
|
|
|
(help (gui:make-menu bar (_ "Help"))))
|
2023-05-13 21:20:49 +02:00
|
|
|
(gui:make-menubutton tools
|
|
|
|
(_ "Certificates")
|
|
|
|
#'menu:show-certificates
|
|
|
|
:accelerator (client-configuration:get-keybinding :certificates))
|
2023-05-13 18:53:05 +02:00
|
|
|
(gui:make-menubutton tools
|
|
|
|
(_ "Search")
|
|
|
|
(menu:show-search-frame-clsr main-window)
|
|
|
|
:accelerator (client-configuration:get-keybinding :search))
|
2023-07-29 11:41:12 +02:00
|
|
|
(gui:make-menubutton tools
|
|
|
|
(_ "Streams")
|
|
|
|
#'menu:show-streams
|
|
|
|
:accelerator (client-configuration:get-keybinding :stream))
|
2023-05-13 18:53:05 +02:00
|
|
|
(gui:make-menubutton file
|
|
|
|
(_ "Quit")
|
|
|
|
#'menu:quit
|
|
|
|
:accelerator (client-configuration:get-keybinding :quit))
|
2023-05-13 21:20:49 +02:00
|
|
|
(gui:make-menubutton help
|
|
|
|
(_ "About")
|
|
|
|
#'menu:help-about
|
|
|
|
:accelerator (client-configuration:get-keybinding :about))
|
2023-05-14 17:33:31 +02:00
|
|
|
(gui:make-menubutton bookmarks
|
|
|
|
(_ "Show")
|
|
|
|
(menu:show-bookmarks-clsr main-window)
|
|
|
|
:accelerator (client-configuration:config-keybinding-bookmark-show))
|
2023-05-14 17:22:41 +02:00
|
|
|
(gui:make-menubutton bookmarks (_ "Manage") (menu:manage-bookmarks-clsr main-window))
|
2023-05-13 21:20:49 +02:00
|
|
|
(gui:make-menubutton tour
|
|
|
|
(_ "Manage")
|
|
|
|
#'menu:show-tour
|
2023-05-14 14:44:47 +02:00
|
|
|
:accelerator (client-configuration:config-keybinding-tour-manage))
|
2023-04-14 15:09:38 +02:00
|
|
|
(gui:make-menubutton tour
|
|
|
|
(_ "Shuffle")
|
|
|
|
(lambda () (client-tour-window:enqueue-shuffle-tour))
|
2023-05-14 14:44:47 +02:00
|
|
|
:accelerator (client-configuration:config-keybinding-tour-shuffle))
|
2023-05-13 21:20:49 +02:00
|
|
|
(gui:make-menubutton gemlogs
|
|
|
|
(_ "Show")
|
|
|
|
#'menu:manage-gemlogs
|
|
|
|
:accelerator (client-configuration:get-keybinding :gemlog))))
|
2023-02-05 14:07:13 +01:00
|
|
|
|
2023-02-08 13:02:26 +01:00
|
|
|
(defclass tool-bar (gui:frame)
|
|
|
|
((iri-entry
|
|
|
|
:initform nil
|
|
|
|
:initarg :iri-entry
|
|
|
|
:accessor iri-entry)
|
|
|
|
(back-button
|
|
|
|
:initform nil
|
|
|
|
:initarg :back-button
|
|
|
|
:accessor back-button)
|
|
|
|
(reload-button
|
|
|
|
:initform nil
|
|
|
|
:initarg :reload-button
|
|
|
|
:accessor reload-button)
|
2023-02-18 13:02:56 +01:00
|
|
|
(up-button
|
|
|
|
:initform nil
|
|
|
|
:initarg :up-button
|
|
|
|
:accessor up-button)
|
2023-02-08 13:02:26 +01:00
|
|
|
(go-button
|
|
|
|
:initform nil
|
|
|
|
:initarg :go-button
|
2023-04-09 10:05:59 +02:00
|
|
|
:accessor go-button)
|
|
|
|
(bookmark-button
|
|
|
|
:initform nil
|
|
|
|
:initarg :bookmark-button
|
2023-04-13 15:03:57 +02:00
|
|
|
:accessor bookmark-button)
|
|
|
|
(tour-button
|
|
|
|
:initform nil
|
|
|
|
:initarg :tour-button
|
2023-05-07 12:21:29 +02:00
|
|
|
:accessor tour-button)
|
|
|
|
(subscribe-button
|
|
|
|
:initform nil
|
|
|
|
:initarg :subscribe-button
|
2023-05-13 14:45:45 +02:00
|
|
|
:accessor subscribe-button)
|
|
|
|
(inline-images-button
|
|
|
|
:initform nil
|
|
|
|
:initarg :inline-images-button
|
|
|
|
:accessor inline-images-button)))
|
2023-02-08 13:02:26 +01:00
|
|
|
|
|
|
|
(defun autocomplete-iri-clsr (toolbar)
|
|
|
|
(declare (ignore toolbar))
|
|
|
|
(lambda (hint)
|
2023-03-02 18:17:19 +01:00
|
|
|
(if (or (complete:expand-iri-as-local-path-p hint)
|
|
|
|
(> (length hint) 2))
|
2023-06-18 14:48:40 +02:00
|
|
|
(gui-goodies:with-notify-errors
|
2023-02-19 14:52:53 +01:00
|
|
|
(let ((match-results (cev:enqueue-request-and-wait-results :complete-net-address
|
|
|
|
1
|
|
|
|
ev:+maximum-event-priority+
|
|
|
|
hint)))
|
2023-02-17 14:30:33 +01:00
|
|
|
(values (getf match-results :matches)
|
|
|
|
(getf match-results :indices))))
|
2023-02-09 17:04:29 +01:00
|
|
|
hint)))
|
2023-02-08 13:02:26 +01:00
|
|
|
|
2023-02-25 11:41:01 +01:00
|
|
|
(defmacro gen-ir-access (key)
|
|
|
|
`(defun ,(misc:format-fn-symbol t "ir-~a" key) (line)
|
|
|
|
(getf line ,(a:make-keyword key))))
|
|
|
|
|
|
|
|
(gen-ir-access type)
|
|
|
|
|
|
|
|
(gen-ir-access source-id)
|
|
|
|
|
|
|
|
(gen-ir-access header-group-id)
|
|
|
|
|
|
|
|
(gen-ir-access source-line)
|
|
|
|
|
|
|
|
(gen-ir-access line)
|
|
|
|
|
|
|
|
(gen-ir-access href)
|
|
|
|
|
2023-02-28 18:48:34 +01:00
|
|
|
(gen-ir-access pre-alt-text)
|
|
|
|
|
2023-04-13 17:54:54 +02:00
|
|
|
(defun link-click-mouse-1-callback-clsr (link-value main-window
|
|
|
|
&key
|
|
|
|
(use-cache t)
|
|
|
|
(status +stream-status-streaming+))
|
2023-04-07 12:30:54 +02:00
|
|
|
(with-accessors ((tool-bar tool-bar)) main-window
|
|
|
|
(with-accessors ((iri-entry iri-entry)) tool-bar
|
|
|
|
(lambda ()
|
2023-05-13 21:20:49 +02:00
|
|
|
(set-address-bar-text main-window link-value)
|
2023-05-14 16:25:13 +02:00
|
|
|
(gui:focus (toc-frame main-window))
|
2023-07-22 11:15:22 +02:00
|
|
|
(open-iri link-value
|
|
|
|
main-window
|
|
|
|
use-cache :status status)))))
|
|
|
|
|
|
|
|
(defun remove-standard-port (iri)
|
|
|
|
(let ((copy (iri:copy-iri (iri:iri-parse iri))))
|
|
|
|
(when (and (uri:port copy)
|
|
|
|
(uri:host copy)
|
|
|
|
(= (uri:port copy)
|
|
|
|
gemini-constants:+gemini-default-port+))
|
|
|
|
(setf (uri:port copy) nil))
|
|
|
|
(to-s copy)))
|
2023-02-28 18:48:34 +01:00
|
|
|
|
2023-03-08 16:16:55 +01:00
|
|
|
(defun absolutize-link (request-iri link-value)
|
2023-09-10 21:47:08 +02:00
|
|
|
(if (iri:absolute-url-p link-value)
|
|
|
|
link-value
|
|
|
|
(let ((parsed-request-iri (iri:iri-parse request-iri)))
|
|
|
|
(multiple-value-bind (x host path query port y w z)
|
|
|
|
(gemini-client:displace-iri parsed-request-iri)
|
|
|
|
(declare (ignore x y w z))
|
|
|
|
(gemini-parser:absolutize-link link-value
|
|
|
|
host
|
|
|
|
port
|
|
|
|
path
|
|
|
|
query)))))
|
2023-03-08 16:16:55 +01:00
|
|
|
|
2023-05-12 14:04:08 +02:00
|
|
|
(defun slurp-iri (main-window iri)
|
2023-07-21 14:30:16 +02:00
|
|
|
(if (not (iri:absolute-url-p iri))
|
|
|
|
(if (fs:file-exists-p iri)
|
|
|
|
iri
|
2023-07-22 11:15:22 +02:00
|
|
|
(error (_ "file ~a not found") iri))
|
2023-07-21 14:30:16 +02:00
|
|
|
(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)
|
2023-07-22 11:38:47 +02:00
|
|
|
(a:when-let ((actual-iri (get-user-request-query iri
|
|
|
|
meta
|
|
|
|
main-window)))
|
2023-07-21 14:30:16 +02:00
|
|
|
(slurp-iri main-window actual-iri)))
|
|
|
|
((gemini-client:header-sensitive-input-p status-code)
|
2023-07-22 11:38:47 +02:00
|
|
|
(a:when-let ((actual-iri (get-user-request-query iri
|
|
|
|
meta
|
|
|
|
main-window
|
|
|
|
:sensitive t)))
|
2023-07-21 14:30:16 +02:00
|
|
|
(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)
|
2024-02-11 12:07:07 +01:00
|
|
|
(cev:enqueue-request-and-wait-results :gemini-delete-tofu-certificate
|
2023-07-21 14:30:16 +02:00
|
|
|
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)))))))
|
2023-05-12 14:04:08 +02:00
|
|
|
|
2023-09-09 15:06:35 +02:00
|
|
|
(defun supports-tk-image-extension-p ()
|
|
|
|
gui::*tkimg-loaded-p*)
|
|
|
|
|
2023-05-13 14:45:45 +02:00
|
|
|
(defun inline-image-p (link-value)
|
2023-06-24 12:01:31 +02:00
|
|
|
(a:when-let* ((parsed (iri:iri-parse link-value :null-on-error t))
|
|
|
|
(path (uri:path parsed)))
|
|
|
|
(and (or (gemini-client:absolute-gemini-url-p link-value)
|
|
|
|
(not (iri:absolute-url-p link-value)))
|
|
|
|
(or (re:scan "(?i)jpg$" path)
|
|
|
|
(re:scan "(?i)jpeg$" path)
|
|
|
|
(re:scan "(?i)png$" path)
|
|
|
|
(re:scan "(?i)gif$" path)
|
2023-09-09 15:06:35 +02:00
|
|
|
(and (supports-tk-image-extension-p)
|
|
|
|
(re:scan "(?i)bmp$" path))
|
2023-06-24 12:01:31 +02:00
|
|
|
(re:scan "(?i)tga$" path)))))
|
2023-05-13 14:45:45 +02:00
|
|
|
|
|
|
|
(defun inline-possible-p (link-value)
|
|
|
|
(inline-image-p link-value))
|
|
|
|
|
|
|
|
(defun inline-type (link-value)
|
|
|
|
(when (inline-image-p link-value)
|
|
|
|
:inline-image))
|
|
|
|
|
2023-09-09 15:06:35 +02:00
|
|
|
(defun scale-pixmap (main-window file type)
|
|
|
|
(let* ((pixmap (nodgui.pixmap:slurp-pixmap type file))
|
|
|
|
(gemtext-widget-width (gemtext-widget-pixel-width main-window))
|
|
|
|
(pixmap-w (nodgui.pixmap:width pixmap))
|
|
|
|
(ratio (/ 1 (/ pixmap-w
|
2023-09-09 15:21:27 +02:00
|
|
|
(* gemtext-widget-width
|
|
|
|
(client-configuration:config-inline-scaling-ratio))))))
|
2023-09-09 15:06:35 +02:00
|
|
|
(if (< ratio 1.0)
|
|
|
|
(nodgui.pixmap:scale-bilinear pixmap ratio ratio)
|
|
|
|
pixmap)))
|
|
|
|
|
|
|
|
(defun scale-jpeg (main-window file)
|
|
|
|
(scale-pixmap main-window file 'nodgui.pixmap:jpeg))
|
|
|
|
|
|
|
|
(defun scale-targa (main-window file)
|
|
|
|
(scale-pixmap main-window file 'nodgui.pixmap:tga))
|
|
|
|
|
2023-09-11 19:08:28 +02:00
|
|
|
(defun scale-png (main-window file)
|
|
|
|
(scale-pixmap main-window file 'nodgui.pixmap:png))
|
|
|
|
|
2023-05-13 14:45:45 +02:00
|
|
|
(defun inline-image (main-window link-value line-index)
|
2023-09-09 15:06:35 +02:00
|
|
|
(multiple-value-bind (file-path mime-type)
|
|
|
|
(slurp-iri main-window (remove-standard-port link-value))
|
|
|
|
(let ((image (cond
|
|
|
|
((string= mime-type +mime-type-jpg+)
|
|
|
|
(scale-jpeg main-window file-path))
|
2023-12-24 22:22:57 +01:00
|
|
|
((member mime-type
|
|
|
|
'("image/x-tga" "image/x-targa")
|
2023-12-24 22:34:09 +01:00
|
|
|
:test #'string=)
|
2023-09-09 15:06:35 +02:00
|
|
|
(scale-targa main-window file-path))
|
2023-09-11 19:08:28 +02:00
|
|
|
((string= mime-type +mime-type-png+)
|
|
|
|
(scale-png main-window file-path))
|
2023-09-09 15:06:35 +02:00
|
|
|
(t
|
|
|
|
(gui:make-image file-path))))
|
|
|
|
(coordinates `(+ (:line ,line-index :char 0) 1 :lines)))
|
|
|
|
(with-accessors ((ir-lines ir-lines)
|
|
|
|
(ir-rendered-lines ir-rendered-lines)
|
|
|
|
(gemtext-widget gemtext-widget)) main-window
|
|
|
|
(let* ((parent-line (elt ir-lines (- line-index 1)))
|
|
|
|
(new-line (copy-list parent-line)))
|
|
|
|
(gui:move-cursor-to gemtext-widget coordinates)
|
|
|
|
(gui:insert-text gemtext-widget (format nil "~%"))
|
|
|
|
(gui:insert-image gemtext-widget image coordinates)
|
|
|
|
(setf (getf new-line :type) (inline-type link-value))
|
|
|
|
(setf ir-lines
|
|
|
|
(fresh-vector-insert@ ir-lines
|
|
|
|
new-line
|
|
|
|
line-index))
|
|
|
|
(setf ir-rendered-lines
|
|
|
|
(fresh-vector-insert@ ir-rendered-lines
|
|
|
|
""
|
|
|
|
line-index)))))))
|
2023-05-13 14:45:45 +02:00
|
|
|
|
|
|
|
(defun inline-all-images (main-window)
|
2023-07-21 14:30:16 +02:00
|
|
|
"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."
|
2023-09-09 15:06:35 +02:00
|
|
|
(labels ((inline-single-image (lines line-number)
|
|
|
|
(when (< (1- line-number) (length lines))
|
|
|
|
(let ((line (elt lines (1- line-number))))
|
|
|
|
(if (and (string= (getf line :type) "a")
|
|
|
|
(inline-image-p (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)
|
|
|
|
(inline-single-image (ir-lines main-window) (+ line-number 1)))
|
|
|
|
(inline-single-image (ir-lines main-window) (+ line-number 1)))))))
|
|
|
|
(inline-single-image (ir-lines main-window) 1)))
|
2023-05-13 14:45:45 +02:00
|
|
|
|
|
|
|
(defun inline-all-images-clsr (main-window)
|
|
|
|
(lambda ()
|
|
|
|
(inline-all-images main-window)))
|
|
|
|
|
2023-10-29 12:41:17 +01:00
|
|
|
(defun enqueue-add-link-to-tour (link-value link-name)
|
|
|
|
(ev:with-enqueued-process-and-unblock ()
|
|
|
|
(comm:make-request :tour-add-link
|
|
|
|
1
|
|
|
|
link-value
|
|
|
|
link-name)
|
|
|
|
(print-info-message (format nil
|
|
|
|
(_ "~a added to tour")
|
|
|
|
(if (string-not-empty-p link-name)
|
|
|
|
link-name
|
|
|
|
link-value)))))
|
|
|
|
|
2023-06-07 16:31:30 +02:00
|
|
|
(defun contextual-menu-link-clrs (link-name link-value main-window)
|
2023-05-12 14:04:08 +02:00
|
|
|
(labels ((add-to-tour-callback ()
|
2023-10-29 12:41:17 +01:00
|
|
|
(enqueue-add-link-to-tour link-value link-name))
|
2023-05-12 14:04:08 +02:00
|
|
|
(download-background-callback ()
|
|
|
|
(open-iri link-value main-window nil :status +stream-status-downloading+))
|
|
|
|
(copy-link-callback ()
|
|
|
|
(os-utils:copy-to-clipboard link-value)
|
|
|
|
(print-info-message (format nil
|
|
|
|
(_ "~s has been copied to the clipboard")
|
|
|
|
link-value)))
|
|
|
|
(bookmark-link-callback ()
|
|
|
|
(let ((bookmarkedp (cev:enqueue-request-and-wait-results :gemini-bookmarked-p
|
|
|
|
1
|
|
|
|
ev:+standard-event-priority+
|
|
|
|
link-value)))
|
|
|
|
(if bookmarkedp
|
|
|
|
(print-info-message (format nil
|
|
|
|
(_ "~s already bookmarked")
|
|
|
|
link-value)
|
|
|
|
:bold t)
|
|
|
|
(client-bookmark-window:init-window main-window link-value))))
|
2023-06-07 16:31:30 +02:00
|
|
|
(open-inline-clsr (line-number)
|
|
|
|
(lambda ()
|
|
|
|
(if (inline-possible-p link-value)
|
|
|
|
(gui-goodies:with-busy* (main-window)
|
|
|
|
(inline-image main-window link-value line-number))
|
2023-07-12 15:08:47 +02:00
|
|
|
(funcall (link-click-mouse-1-callback-clsr link-value main-window)))))
|
|
|
|
(save-link-as-callback ()
|
2023-07-12 15:29:49 +02:00
|
|
|
(a:when-let* ((suggested-file-name (fs:path-last-element link-value))
|
2023-07-12 15:43:52 +02:00
|
|
|
(extension (fs:get-extension suggested-file-name))
|
|
|
|
(extensions-mask (list (list (format nil
|
|
|
|
(_ "Files ~s")
|
|
|
|
extension)
|
|
|
|
(format nil
|
|
|
|
"*~a"
|
|
|
|
extension))
|
|
|
|
'("All Files" "*")))
|
2023-07-12 15:29:49 +02:00
|
|
|
(output-file (gui:get-save-file :initial-file suggested-file-name
|
|
|
|
:initial-dir "."
|
2023-07-12 15:43:52 +02:00
|
|
|
:file-types extensions-mask
|
2023-07-12 15:08:47 +02:00
|
|
|
:parent main-window
|
|
|
|
:title (_ "Choose a file for saving")))
|
2023-07-12 15:36:05 +02:00
|
|
|
(input-file (when (string-not-empty-p output-file)
|
|
|
|
(gui-goodies:with-busy* (main-window)
|
|
|
|
(slurp-iri main-window link-value)))))
|
2023-07-12 15:08:47 +02:00
|
|
|
(fs:copy-a-file input-file output-file :overwrite t))))
|
2023-04-13 17:54:54 +02:00
|
|
|
(lambda ()
|
2023-05-12 14:04:08 +02:00
|
|
|
(let* ((popup-menu (gui:make-menu nil (_"link menu")))
|
|
|
|
(x (gui:screen-mouse-x))
|
2023-06-07 16:31:30 +02:00
|
|
|
(y (gui:screen-mouse-y))
|
|
|
|
(relative-x (- x (gui:root-x (gemtext-widget main-window))))
|
|
|
|
(relative-y (- y (gui:root-y (gemtext-widget main-window)))))
|
|
|
|
(gui:move-cursor-to (gemtext-widget main-window)`(:x ,relative-x :y ,relative-y))
|
2023-05-13 11:54:52 +02:00
|
|
|
(when (inline-possible-p link-value)
|
2023-06-07 16:31:30 +02:00
|
|
|
(gui:make-menubutton popup-menu
|
|
|
|
(_ "Inline")
|
|
|
|
(open-inline-clsr (gui:cursor-index (gemtext-widget main-window)))))
|
2023-04-13 18:33:32 +02:00
|
|
|
(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)
|
2023-07-12 15:08:47 +02:00
|
|
|
(gui:make-menubutton popup-menu (_ "Add link to bookmarks") #'bookmark-link-callback)
|
|
|
|
(when (or (gemini-client:absolute-gemini-url-p link-value)
|
|
|
|
(not (iri:absolute-url-p link-value)))
|
|
|
|
(gui:make-menubutton popup-menu (_ "Save link as…") #'save-link-as-callback))
|
2023-04-13 18:33:32 +02:00
|
|
|
(gui:make-menubutton popup-menu
|
|
|
|
(_ "Open link in background")
|
|
|
|
#'download-background-callback)
|
2023-05-12 14:04:08 +02:00
|
|
|
(gui:popup popup-menu x y)))))
|
2023-04-12 17:48:12 +02:00
|
|
|
|
2023-05-31 15:05:21 +02:00
|
|
|
(defun scale-font (font scaling)
|
|
|
|
(when scaling
|
2023-06-01 19:22:58 +02:00
|
|
|
(let* ((font-size (parse-integer (getf (gui:font-actual font) :size)))
|
|
|
|
(new-font-size (round (* font-size scaling))))
|
2023-05-31 15:05:21 +02:00
|
|
|
(gui:font-configure font :size new-font-size)))
|
|
|
|
font)
|
|
|
|
|
|
|
|
(defun maybe-re-emphatize-lines (main-window from to)
|
|
|
|
(with-accessors ((gemtext-font-scaling gemtext-font-scaling)
|
|
|
|
(gemtext-widget gemtext-widget)) main-window
|
|
|
|
(when (client-configuration:emphasize-wrapped-asterisk-p)
|
|
|
|
(let ((matches (gui:search-all-text gemtext-widget
|
|
|
|
"\\*[^*]+\\*"
|
|
|
|
:start-index from
|
|
|
|
:end-index to)))
|
|
|
|
(loop for match in matches do
|
|
|
|
(gui:tag-configure gemtext-widget
|
|
|
|
(gui:match-tag-name match)
|
|
|
|
:font (scale-font (client-configuration:font-text-bold)
|
|
|
|
gemtext-font-scaling))
|
|
|
|
(gui:tag-raise gemtext-widget (gui:match-tag-name match)))))))
|
2023-05-17 18:24:11 +02:00
|
|
|
|
2023-06-02 09:58:18 +02:00
|
|
|
(defun linkify (line)
|
|
|
|
(let* ((link-value (ir-href line))
|
|
|
|
(link-name (or (ir-line line)
|
|
|
|
link-value))
|
|
|
|
(prefix-gemini (gui-conf:gemini-link-prefix-to-gemini))
|
|
|
|
(prefix-www (gui-conf:gemini-link-prefix-to-http))
|
|
|
|
(prefix-other (gui-conf:gemini-link-prefix-to-other))
|
|
|
|
(link-rendered-label (if (text-utils:starting-emoji link-name)
|
|
|
|
(format nil
|
|
|
|
"~a~a"
|
|
|
|
(trim-blanks prefix-other)
|
|
|
|
link-name)
|
|
|
|
(cond
|
|
|
|
((gemini-parser::gemini-link-iri-p link-value)
|
|
|
|
(format nil "~a~a" prefix-gemini link-name))
|
|
|
|
((html-utils::http-link-iri-p link-value)
|
|
|
|
(format nil "~a~a" prefix-www link-name))
|
|
|
|
(t
|
|
|
|
(format nil "~a~a" prefix-other link-name))))))
|
|
|
|
(values link-rendered-label link-name link-value)))
|
|
|
|
|
2023-06-07 16:31:30 +02:00
|
|
|
(defun colorize-emoji (main-window line-index &optional (start 0))
|
2023-06-04 15:31:56 +02:00
|
|
|
(with-accessors ((ir-lines ir-lines)
|
|
|
|
(ir-rendered-lines ir-rendered-lines)
|
|
|
|
(gemtext-widget gemtext-widget)) main-window
|
|
|
|
(let ((line (coerce (elt ir-rendered-lines line-index) 'list)))
|
|
|
|
(loop for i from start below (length line)
|
|
|
|
with skip-index = 0
|
|
|
|
do
|
|
|
|
(let ((emoji-code-points (starting-emoji (subseq line skip-index))))
|
|
|
|
(if emoji-code-points
|
|
|
|
(let ((tag (gui:tag-create gemtext-widget
|
|
|
|
(gui::create-tag-name)
|
|
|
|
`(:char ,i :line ,(1+ line-index))
|
|
|
|
`(:char ,(1+ i) :line ,(1+ line-index)))))
|
|
|
|
(gui:tag-configure gemtext-widget
|
|
|
|
tag
|
2023-06-07 16:31:30 +02:00
|
|
|
:font (gui:font-create (gui::create-name)
|
|
|
|
:family "Noto Color Emoji"
|
|
|
|
:size 11))
|
2023-06-04 15:31:56 +02:00
|
|
|
(incf skip-index (length emoji-code-points)))
|
2023-06-07 16:31:30 +02:00
|
|
|
(incf skip-index)))))))
|
2023-06-04 15:31:56 +02:00
|
|
|
|
2023-06-30 14:45:54 +02:00
|
|
|
(defun render-ir-lines (request-iri main-window &key (starting-index 0))
|
2023-05-31 15:05:21 +02:00
|
|
|
(with-accessors ((ir-lines ir-lines)
|
|
|
|
(ir-rendered-lines ir-rendered-lines)
|
|
|
|
(gemtext-font-scaling gemtext-font-scaling)
|
|
|
|
(gemtext-widget gemtext-widget)) main-window
|
2023-08-15 20:05:09 +02:00
|
|
|
(let ((font-cache '()))
|
|
|
|
(labels ((key->font (key)
|
|
|
|
(or (cdr (assoc :key font-cache))
|
|
|
|
(let ((font (ecase key
|
|
|
|
((:vertical-space :text :li)
|
|
|
|
(gui-conf:gemini-text-font-configuration))
|
|
|
|
(:h1
|
|
|
|
(gui-conf:gemini-h1-font-configuration))
|
|
|
|
(:h2
|
|
|
|
(gui-conf:gemini-h2-font-configuration))
|
|
|
|
(:h3
|
|
|
|
(gui-conf:gemini-h3-font-configuration))
|
|
|
|
(:quote
|
|
|
|
(gui-conf:gemini-quote-font-configuration))
|
|
|
|
((:pre :pre-end :as-is)
|
|
|
|
(gui-conf:gemini-preformatted-text-font-configuration))
|
|
|
|
(:a
|
|
|
|
(gui-conf:gemini-link-font-configuration)))))
|
|
|
|
(scale-font font gemtext-font-scaling)
|
|
|
|
(setf font-cache (acons key font font-cache))
|
|
|
|
font)))
|
|
|
|
(key->colors (key)
|
|
|
|
(ecase key
|
|
|
|
((:vertical-space :text :li)
|
|
|
|
(gui-conf:gemini-window-colors))
|
|
|
|
(:h1
|
|
|
|
(gui-conf:gemini-h1-colors))
|
|
|
|
(:h2
|
|
|
|
(gui-conf:gemini-h2-colors))
|
|
|
|
(:h3
|
|
|
|
(gui-conf:gemini-h3-colors))
|
|
|
|
(:quote
|
|
|
|
(gui-conf:gemini-quote-colors))
|
|
|
|
((:pre :pre-end :as-is)
|
|
|
|
(gui-conf:gemini-preformatted-text-colors))
|
|
|
|
(:a
|
|
|
|
(gui-conf:gemini-link-colors))))
|
|
|
|
(key->justification (key)
|
|
|
|
(ecase key
|
|
|
|
((:vertical-space :text :li :a)
|
|
|
|
:left)
|
2023-06-02 09:58:18 +02:00
|
|
|
(:h1
|
2023-08-15 20:05:09 +02:00
|
|
|
(gui-conf:gemini-h1-justification))
|
2023-06-02 09:58:18 +02:00
|
|
|
(:h2
|
2023-08-15 20:05:09 +02:00
|
|
|
(gui-conf:gemini-h2-justification))
|
2023-06-02 09:58:18 +02:00
|
|
|
(:h3
|
2023-08-15 20:05:09 +02:00
|
|
|
(gui-conf:gemini-h3-justification))
|
|
|
|
(:quote
|
|
|
|
(gui-conf:gemini-quote-justification))
|
|
|
|
((:pre :pre-end :as-is)
|
|
|
|
(gui-conf:gemini-preformatted-text-justification))))
|
|
|
|
(render-link (line link-rendered-label line-number)
|
|
|
|
(multiple-value-bind (link-bg link-fg)
|
|
|
|
(gui-conf:gemini-link-colors)
|
|
|
|
(let ((link-font (key->font :a)))
|
|
|
|
(multiple-value-bind (x link-name link-value)
|
|
|
|
(linkify line)
|
|
|
|
(declare (ignore x))
|
|
|
|
(let ((target-iri (remove-standard-port (absolutize-link request-iri
|
|
|
|
link-value)))
|
|
|
|
(new-text-line-start `(:line ,line-number :char 0)))
|
|
|
|
(gui:append-text gemtext-widget link-rendered-label)
|
2023-10-29 12:41:17 +01:00
|
|
|
(let* ((tag-link-other-bindings
|
|
|
|
(list (cons #$<Control-1>$
|
|
|
|
(lambda () (enqueue-add-link-to-tour target-iri
|
|
|
|
link-name)))))
|
|
|
|
(tag-link (gui:make-link-button gemtext-widget
|
2023-08-15 20:05:09 +02:00
|
|
|
new-text-line-start
|
|
|
|
`(- :end 1 :chars)
|
|
|
|
link-font
|
|
|
|
link-fg
|
|
|
|
link-bg
|
|
|
|
(link-click-mouse-1-callback-clsr target-iri
|
|
|
|
main-window)
|
|
|
|
:cursor-outside
|
|
|
|
(gui:find-cursor :xterm)
|
|
|
|
:button-3-callback
|
|
|
|
(contextual-menu-link-clrs link-name
|
|
|
|
target-iri
|
|
|
|
main-window)
|
2023-10-29 12:41:17 +01:00
|
|
|
:button-2-callback
|
|
|
|
(lambda ()
|
|
|
|
(open-iri target-iri
|
|
|
|
main-window
|
|
|
|
nil
|
|
|
|
:status +stream-status-downloading+))
|
2023-08-15 20:05:09 +02:00
|
|
|
:over-callback
|
|
|
|
(lambda () (print-info-message target-iri))
|
|
|
|
:leave-callback
|
2023-10-29 12:41:17 +01:00
|
|
|
(lambda () (print-info-message ""))
|
|
|
|
:other-bindings
|
|
|
|
tag-link-other-bindings)))
|
2023-08-15 20:05:09 +02:00
|
|
|
(gui:tag-lower gemtext-widget tag-link)
|
|
|
|
(gui:append-line gemtext-widget "")))))))
|
|
|
|
(render-line (key text line-number &key (wrap :word))
|
|
|
|
(let ((font (key->font key))
|
|
|
|
(justification (key->justification key))
|
|
|
|
(start-index `(:line ,line-number :char 0)))
|
|
|
|
(gui:append-text gemtext-widget text)
|
|
|
|
(gui:append-line gemtext-widget "")
|
|
|
|
(when (not (member key '(:text :vertical-space)))
|
|
|
|
(multiple-value-bind (background foreground)
|
|
|
|
(key->colors key)
|
|
|
|
(let ((tag (gui:tag-create gemtext-widget
|
|
|
|
(gui::create-tag-name)
|
|
|
|
start-index
|
|
|
|
(gui:make-indices-end))))
|
|
|
|
(gui:tag-configure gemtext-widget
|
|
|
|
tag
|
|
|
|
:wrap wrap
|
|
|
|
:font font
|
|
|
|
:foreground foreground
|
|
|
|
:background background
|
|
|
|
:justify justification)
|
|
|
|
;; does not works because of a TK bug
|
|
|
|
;;(colorize-emoji main-window (1- line-number))
|
|
|
|
(gui:tag-lower gemtext-widget tag)))))))
|
|
|
|
(gui:configure gemtext-widget :font (key->font :text))
|
|
|
|
(loop with render-line-count = starting-index
|
|
|
|
with current-pre-block-alt-text = nil
|
|
|
|
for rendered-line across (subseq ir-rendered-lines starting-index)
|
|
|
|
for ir-line across (subseq ir-lines starting-index)
|
2023-08-17 16:00:32 +02:00
|
|
|
until (interrupt-rendering-p main-window)
|
2023-08-15 20:05:09 +02:00
|
|
|
do
|
|
|
|
(let ((type (ir-type ir-line)))
|
|
|
|
(ecase (format-keyword type)
|
|
|
|
(:vertical-space
|
|
|
|
(incf render-line-count)
|
|
|
|
(render-line :vertical-space rendered-line render-line-count))
|
|
|
|
(:as-is
|
|
|
|
(incf render-line-count)
|
|
|
|
(render-line :as-is
|
|
|
|
rendered-line
|
|
|
|
render-line-count
|
|
|
|
:wrap :none))
|
|
|
|
(:text
|
|
|
|
(incf render-line-count)
|
|
|
|
(render-line :text rendered-line render-line-count)
|
|
|
|
(maybe-re-emphatize-lines main-window
|
|
|
|
`(:line ,render-line-count :char 0)
|
|
|
|
`(:line ,render-line-count :char :end)))
|
|
|
|
(:h1
|
|
|
|
(incf render-line-count)
|
|
|
|
(render-line :h1 rendered-line render-line-count))
|
|
|
|
(:h2
|
|
|
|
(incf render-line-count)
|
|
|
|
(render-line :h2 rendered-line render-line-count))
|
|
|
|
(:h3
|
|
|
|
(incf render-line-count)
|
|
|
|
(render-line :h3 rendered-line render-line-count))
|
|
|
|
(:li
|
|
|
|
(incf render-line-count)
|
|
|
|
(render-line :li rendered-line render-line-count)
|
|
|
|
(maybe-re-emphatize-lines main-window
|
|
|
|
`(:line ,render-line-count :char 0)
|
|
|
|
`(:line ,render-line-count :char :end)))
|
|
|
|
(:quote
|
|
|
|
(incf render-line-count)
|
|
|
|
(render-line :quote rendered-line render-line-count))
|
|
|
|
(:pre
|
|
|
|
(incf render-line-count)
|
|
|
|
(setf current-pre-block-alt-text (ir-pre-alt-text ir-line))
|
|
|
|
(render-line :pre
|
|
|
|
rendered-line
|
|
|
|
render-line-count
|
|
|
|
:wrap :none))
|
|
|
|
(:pre-end
|
|
|
|
(incf render-line-count)
|
|
|
|
(render-line :pre-end rendered-line render-line-count))
|
|
|
|
(:a
|
|
|
|
(incf render-line-count)
|
|
|
|
(render-link ir-line rendered-line render-line-count)))))))))
|
2023-06-02 09:58:18 +02:00
|
|
|
|
|
|
|
(defun collect-ir-lines (request-iri main-window lines)
|
|
|
|
(with-accessors ((ir-lines ir-lines)
|
|
|
|
(ir-rendered-lines ir-rendered-lines)
|
|
|
|
(gemtext-font-scaling gemtext-font-scaling)
|
|
|
|
(gemtext-widget gemtext-widget)) main-window
|
|
|
|
(labels ((push-prefixed (prefix ir)
|
|
|
|
(let ((raw-line (format nil "~a~a" prefix (ir-line ir))))
|
|
|
|
(vector-push-extend raw-line ir-rendered-lines)))
|
|
|
|
(collect-link (line)
|
|
|
|
(vector-push-extend (linkify line) ir-rendered-lines)))
|
2023-06-30 17:17:09 +02:00
|
|
|
(let ((starting-index (if (vector-empty-p ir-lines)
|
2023-06-30 14:45:54 +02:00
|
|
|
0
|
|
|
|
(length ir-lines))))
|
|
|
|
(loop for line in lines do
|
|
|
|
(vector-push-extend line ir-lines)
|
|
|
|
(let ((type (ir-type line)))
|
|
|
|
(ecase (format-keyword type)
|
|
|
|
(:vertical-space
|
|
|
|
(vector-push-extend (format nil "") ir-rendered-lines))
|
|
|
|
(:as-is
|
|
|
|
(vector-push-extend (ir-line line) ir-rendered-lines))
|
|
|
|
(:text
|
|
|
|
(vector-push-extend (ir-line line) ir-rendered-lines))
|
|
|
|
(:h1
|
|
|
|
(push-prefixed (gui-conf:gemini-h1-prefix) line))
|
|
|
|
(:h2
|
|
|
|
(push-prefixed (gui-conf:gemini-h1-prefix) line))
|
|
|
|
(:h3
|
|
|
|
(push-prefixed (gui-conf:gemini-h1-prefix) line))
|
|
|
|
(:li
|
|
|
|
(push-prefixed (gui-conf:gemini-bullet-prefix) line))
|
|
|
|
(:quote
|
|
|
|
(push-prefixed (gui-conf:gemini-quote-prefix) line))
|
|
|
|
(:pre
|
|
|
|
(vector-push-extend (format nil "") ir-rendered-lines))
|
|
|
|
(:pre-end
|
|
|
|
(vector-push-extend (format nil "") ir-rendered-lines))
|
|
|
|
(:a
|
|
|
|
(collect-link line)))))
|
|
|
|
(render-ir-lines request-iri main-window :starting-index starting-index)))))
|
2023-02-25 11:41:01 +01:00
|
|
|
|
|
|
|
(defun displace-gemini-response (response)
|
|
|
|
(values (getf response :status)
|
|
|
|
(getf response :status-description)
|
|
|
|
(getf response :meta)
|
|
|
|
(getf response :cached)
|
|
|
|
(getf response :iri)))
|
|
|
|
|
2023-03-15 17:42:22 +01:00
|
|
|
(defun render-monospaced-text (main-window lines)
|
|
|
|
(ev:with-enqueued-process-and-unblock ()
|
2023-06-25 11:27:40 +02:00
|
|
|
(clear-gemtext main-window)
|
2023-03-15 17:42:22 +01:00
|
|
|
(gui:configure (gemtext-widget main-window)
|
|
|
|
:font (gui-conf:gemini-preformatted-text-font-configuration))
|
|
|
|
(set-text-gemtext main-window lines)))
|
|
|
|
|
2023-03-14 18:50:47 +01:00
|
|
|
(defun open-local-path (path main-window &key (force-rendering nil))
|
2023-03-06 18:38:46 +01:00
|
|
|
(cond
|
|
|
|
((fs:file-exists-p path)
|
|
|
|
(if (fs:has-extension path +gemini-file-extension+)
|
|
|
|
(let ((parsed-lines (cev:enqueue-request-and-wait-results :gemini-parse-local-file
|
|
|
|
1
|
|
|
|
ev:+standard-event-priority+
|
|
|
|
path)))
|
|
|
|
(ev:with-enqueued-process-and-unblock ()
|
2023-06-25 11:27:40 +02:00
|
|
|
(clear-gemtext main-window)
|
2023-06-24 11:10:13 +02:00
|
|
|
(collect-ir-lines path gui-goodies:*main-frame* parsed-lines)
|
|
|
|
(render-toc main-window path)))
|
2023-03-14 18:50:47 +01:00
|
|
|
(if force-rendering
|
|
|
|
(let ((lines (cev:enqueue-request-and-wait-results :gemini-slurp-local-file
|
|
|
|
1
|
|
|
|
ev:+standard-event-priority+
|
|
|
|
path)))
|
2023-03-15 17:42:22 +01:00
|
|
|
(render-monospaced-text main-window lines))
|
2023-03-14 18:50:47 +01:00
|
|
|
(client-os-utils:open-resource-with-external-program main-window path))))
|
2023-03-08 16:16:55 +01:00
|
|
|
((fs:directory-exists-p path)
|
2023-03-11 14:12:30 +01:00
|
|
|
(gui:choose-directory :initial-dir path :parent main-window :mustexist t))
|
|
|
|
(t
|
2023-06-18 14:48:40 +02:00
|
|
|
(gui-goodies:notify-request-error (format nil (_ "No such file or directory: ~a") path)))))
|
2023-03-06 18:38:46 +01:00
|
|
|
|
2023-03-12 15:36:13 +01:00
|
|
|
(defun render-gemtext-string (main-window parsed-lines &key (links-path-prefix ""))
|
|
|
|
(ev:with-enqueued-process-and-unblock ()
|
2023-06-25 11:27:40 +02:00
|
|
|
(clear-gemtext main-window)
|
2023-07-16 14:55:29 +02:00
|
|
|
(initialize-ir-lines main-window)
|
2023-03-12 15:36:13 +01:00
|
|
|
(collect-ir-lines links-path-prefix gui-goodies:*main-frame* parsed-lines)))
|
|
|
|
|
2023-05-18 17:45:35 +02:00
|
|
|
(defun iri-ensure-path (iri)
|
|
|
|
(let ((parsed (iri:iri-parse iri :null-on-error t)))
|
|
|
|
(if (and parsed
|
|
|
|
(null (uri:path parsed)))
|
|
|
|
(strcat iri "/")
|
|
|
|
iri)))
|
|
|
|
|
2023-04-13 17:54:54 +02:00
|
|
|
(defun open-iri (iri main-window use-cache &key (status +stream-status-streaming+))
|
2023-07-22 11:15:22 +02:00
|
|
|
(let ((actual-iri (remove-standard-port iri)))
|
|
|
|
(handler-case
|
|
|
|
(let ((parsed-iri (iri:iri-parse actual-iri)))
|
|
|
|
(cond
|
|
|
|
((iri:iri= actual-iri (internal-iri-bookmark))
|
|
|
|
(initialize-ir-lines main-window)
|
|
|
|
(funcall (menu:show-bookmarks-clsr main-window)))
|
|
|
|
((iri:iri= actual-iri (internal-iri-gemlogs))
|
|
|
|
(menu:manage-gemlogs))
|
|
|
|
((gemini-client:absolute-titan-url-p actual-iri)
|
|
|
|
(client-titan-window:init-window main-window actual-iri))
|
|
|
|
((gemini-parser:gemini-iri-p actual-iri)
|
2023-07-27 16:26:33 +02:00
|
|
|
(let ((stream-frame (stream-frame main-window)))
|
|
|
|
(start-stream-iri (iri-ensure-path actual-iri)
|
|
|
|
main-window
|
|
|
|
use-cache
|
|
|
|
status)
|
|
|
|
(client-stream-frame::refresh-all-streams
|
|
|
|
(client-stream-frame::table stream-frame))))
|
2023-07-22 11:15:22 +02:00
|
|
|
((or (null (uri:scheme parsed-iri))
|
|
|
|
(string= (uri:scheme parsed-iri)
|
|
|
|
constants:+file-scheme+))
|
|
|
|
(initialize-ir-lines main-window)
|
|
|
|
(open-local-path (uri:path parsed-iri) main-window))
|
|
|
|
(t
|
|
|
|
(client-os-utils:open-resource-with-external-program main-window actual-iri))))
|
|
|
|
(error (e)
|
|
|
|
(gui-goodies:notify-request-error e)))))
|
2023-03-02 18:17:19 +01:00
|
|
|
|
2023-03-12 12:35:01 +01:00
|
|
|
(defun get-user-request-query (iri meta main-window &key (sensitive nil))
|
|
|
|
(let* ((parsed-iri (iri:iri-parse iri))
|
|
|
|
(prompt (format nil
|
|
|
|
(_ "The server asks:~2%~a")
|
|
|
|
meta))
|
|
|
|
(button-label (_ "Submit"))
|
|
|
|
(dialog-title (_ "Input query"))
|
|
|
|
(dialog-function (if sensitive
|
|
|
|
#'gui-goodies:password-dialog
|
|
|
|
#'gui-mw:text-input-dialog))
|
|
|
|
(raw-input (funcall dialog-function
|
|
|
|
main-window
|
|
|
|
dialog-title
|
|
|
|
prompt
|
|
|
|
:button-message button-label))
|
|
|
|
(encoded-input (maybe-percent-encode raw-input)))
|
2023-07-22 11:38:47 +02:00
|
|
|
(when (string-not-empty-p raw-input)
|
|
|
|
(multiple-value-bind (actual-iri host path query port fragment)
|
|
|
|
(gemini-client:displace-iri parsed-iri)
|
|
|
|
(declare (ignore actual-iri query fragment))
|
|
|
|
(gemini-parser:make-gemini-iri host
|
|
|
|
path
|
|
|
|
:query encoded-input
|
|
|
|
:port port)))))
|
2023-03-12 12:35:01 +01:00
|
|
|
|
2023-03-15 17:42:22 +01:00
|
|
|
(defun slurp-text-data (main-window iri)
|
|
|
|
(labels ((maybe-open-if-completed (stream-info support-file)
|
|
|
|
(if (string-equal (getf stream-info :stream-status)
|
|
|
|
:completed)
|
|
|
|
(client-os-utils:open-resource-with-external-program main-window support-file)
|
|
|
|
(wait-enough-data)))
|
|
|
|
(wait-enough-data ()
|
|
|
|
(let* ((stream-info (cev:enqueue-request-and-wait-results :gemini-stream-info
|
|
|
|
1
|
|
|
|
ev:+maximum-event-priority+
|
|
|
|
iri))
|
|
|
|
(support-file (getf stream-info :support-file)))
|
|
|
|
(maybe-open-if-completed stream-info support-file))))
|
|
|
|
(wait-enough-data)))
|
|
|
|
|
2023-05-12 14:04:08 +02:00
|
|
|
(defun slurp-non-text-data (main-window iri &key (try-to-open t))
|
|
|
|
(labels ((wait-until-download-complete (stream-info support-file)
|
2023-03-15 17:18:38 +01:00
|
|
|
(if (string-equal (getf stream-info :stream-status)
|
|
|
|
:completed)
|
2023-05-12 14:04:08 +02:00
|
|
|
(if try-to-open
|
|
|
|
(client-os-utils:open-resource-with-external-program main-window support-file)
|
2023-09-09 15:06:35 +02:00
|
|
|
(values (getf stream-info :support-file)
|
|
|
|
(getf stream-info :meta)))
|
2023-03-15 17:18:38 +01:00
|
|
|
(wait-enough-data)))
|
2023-05-12 14:04:08 +02:00
|
|
|
(buffer-filled-enough-to-open-p (buffer-size read-so-far)
|
2023-03-15 17:24:32 +01:00
|
|
|
(let ((filled-configuration-threshold (and buffer-size
|
|
|
|
(> read-so-far buffer-size))))
|
|
|
|
(or filled-configuration-threshold
|
|
|
|
(> read-so-far
|
|
|
|
swconf:+buffer-minimum-size-to-open+))))
|
2023-03-15 17:18:38 +01:00
|
|
|
(wait-enough-data ()
|
|
|
|
(let* ((stream-info
|
|
|
|
(cev:enqueue-request-and-wait-results :gemini-stream-info
|
|
|
|
1
|
|
|
|
ev:+maximum-event-priority+
|
|
|
|
iri))
|
|
|
|
(read-so-far (getf stream-info :octect-count -1))
|
|
|
|
(support-file (getf stream-info :support-file)))
|
|
|
|
(multiple-value-bind (program-exists y wait-for-download)
|
|
|
|
(swconf:link-regex->program-to-use support-file)
|
|
|
|
(declare (ignore y))
|
|
|
|
(if program-exists
|
2023-05-12 14:04:08 +02:00
|
|
|
(if (or wait-for-download
|
|
|
|
(not try-to-open))
|
|
|
|
(wait-until-download-complete stream-info support-file)
|
2023-03-15 17:18:38 +01:00
|
|
|
(let ((buffer-size (swconf:link-regex->program-to-use-buffer-size support-file)))
|
2023-05-12 14:04:08 +02:00
|
|
|
(if (buffer-filled-enough-to-open-p buffer-size read-so-far)
|
2023-03-15 17:24:32 +01:00
|
|
|
(client-os-utils:open-resource-with-external-program main-window
|
|
|
|
support-file)
|
2023-03-15 17:18:38 +01:00
|
|
|
(wait-enough-data))))
|
2023-05-12 14:04:08 +02:00
|
|
|
(wait-until-download-complete stream-info support-file))))))
|
2023-03-15 17:18:38 +01:00
|
|
|
(wait-enough-data)))
|
|
|
|
|
2023-03-06 18:38:46 +01:00
|
|
|
(defun start-stream-iri (iri main-window use-cache &optional (status +stream-status-streaming+))
|
2023-03-02 18:17:19 +01:00
|
|
|
(let ((connecting-response (cev:enqueue-request-and-wait-results :gemini-request
|
|
|
|
1
|
|
|
|
ev:+maximum-event-priority+
|
|
|
|
iri
|
2023-07-09 19:14:45 +02:00
|
|
|
use-cache
|
|
|
|
nil)))
|
2023-03-02 18:17:19 +01:00
|
|
|
(multiple-value-bind (status-code
|
|
|
|
status-description
|
|
|
|
meta
|
|
|
|
cached
|
|
|
|
original-iri)
|
|
|
|
(displace-gemini-response connecting-response)
|
2023-03-12 12:35:01 +01:00
|
|
|
(declare (ignore original-iri cached))
|
2023-03-02 18:17:19 +01:00
|
|
|
(cond
|
2023-03-12 12:35:01 +01:00
|
|
|
((gemini-client:header-input-p status-code)
|
2023-07-22 11:38:47 +02:00
|
|
|
(a:when-let ((actual-iri (get-user-request-query iri meta main-window)))
|
2023-03-12 12:35:01 +01:00
|
|
|
(start-stream-iri actual-iri main-window nil)))
|
|
|
|
((gemini-client:header-sensitive-input-p status-code)
|
2023-07-22 11:38:47 +02:00
|
|
|
(a:when-let ((actual-iri (get-user-request-query iri meta main-window :sensitive t)))
|
2023-03-12 12:35:01 +01:00
|
|
|
(start-stream-iri actual-iri main-window nil)))
|
2023-03-11 13:12:28 +01:00
|
|
|
((= status-code comm:+tofu-error-status-code+)
|
2023-05-18 19:11:20 +02:00
|
|
|
(when (gui:ask-yesno (_ "The certificate for this address has changed, replace the old with the one I just received?")
|
2023-03-11 13:12:28 +01:00
|
|
|
:title (_ "Server certificate error")
|
|
|
|
:parent main-window)
|
2024-02-11 12:07:07 +01:00
|
|
|
(cev:enqueue-request-and-wait-results :gemini-delete-tofu-certificate
|
2023-03-11 13:12:28 +01:00
|
|
|
1
|
|
|
|
ev:+maximum-event-priority+
|
|
|
|
iri)
|
|
|
|
(start-stream-iri iri main-window use-cache status)))
|
|
|
|
((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))
|
2023-03-12 15:36:13 +01:00
|
|
|
(let ((error-gemtext (cev:enqueue-request-and-wait-results :make-error-page
|
|
|
|
1
|
|
|
|
ev:+standard-event-priority+
|
|
|
|
iri
|
|
|
|
status-code
|
|
|
|
status-description
|
|
|
|
meta)))
|
2023-07-21 14:30:16 +02:00
|
|
|
(render-gemtext-string main-window error-gemtext)
|
|
|
|
(ev:with-enqueued-process-and-unblock ()
|
|
|
|
(inline-all-images main-window))))
|
2023-03-08 16:16:55 +01:00
|
|
|
((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))))
|
|
|
|
(start-stream-iri redirect-iri main-window use-cache status))))
|
2023-03-02 18:17:19 +01:00
|
|
|
((gemini-client:header-success-p status-code)
|
2023-03-06 18:38:46 +01:00
|
|
|
(cond
|
|
|
|
((eq status +stream-status-streaming+)
|
2023-03-15 17:42:22 +01:00
|
|
|
(cond
|
|
|
|
((gemini-client:gemini-file-stream-p meta)
|
2023-05-30 19:17:25 +02:00
|
|
|
(ev:with-enqueued-process-and-unblock ()
|
|
|
|
(comm:make-request :gemini-save-url-db-history 1 iri))
|
2023-08-16 15:36:39 +02:00
|
|
|
(maybe-stop-streaming-stream-thread)
|
2023-06-25 11:27:40 +02:00
|
|
|
(clear-gemtext main-window)
|
2023-05-14 12:54:10 +02:00
|
|
|
(initialize-ir-lines main-window)
|
2023-03-18 20:27:24 +01:00
|
|
|
(start-streaming-thread main-window
|
|
|
|
iri
|
2023-06-30 14:45:54 +02:00
|
|
|
:use-cache t
|
2023-03-15 17:42:22 +01:00
|
|
|
:status status
|
|
|
|
:process-function
|
|
|
|
(lambda (stream-wrapper lines)
|
|
|
|
;; this test ensures that the
|
|
|
|
;; collecting events left on
|
|
|
|
;; the queue won't be actually
|
|
|
|
;; processed, just discarded
|
2023-09-16 19:05:33 +02:00
|
|
|
(when (eq (status stream-wrapper)
|
|
|
|
+stream-status-streaming+)
|
2023-03-15 17:42:22 +01:00
|
|
|
(collect-ir-lines iri main-window lines)))))
|
|
|
|
((gemini-client:text-file-stream-p meta)
|
|
|
|
(slurp-text-data main-window iri))
|
|
|
|
(t
|
|
|
|
(slurp-non-text-data main-window iri))))
|
2023-03-06 18:38:46 +01:00
|
|
|
((eq status +stream-status-downloading+)
|
|
|
|
(when (not (find-db-stream-url iri))
|
2023-04-13 17:54:54 +02:00
|
|
|
(let ((background-stream (make-instance 'gemini-stream
|
|
|
|
:server-stream-handle iri
|
|
|
|
:status status)))
|
|
|
|
(push-db-stream background-stream))))
|
2023-03-06 18:38:46 +01:00
|
|
|
(t
|
|
|
|
(error "Unrecognized stream status for address ~s: ~s" iri status))))))))
|
2023-03-02 18:17:19 +01:00
|
|
|
|
|
|
|
(defun open-iri-clsr (main-window use-cache)
|
2023-02-19 14:52:53 +01:00
|
|
|
(lambda ()
|
2023-02-25 11:41:01 +01:00
|
|
|
(with-accessors ((tool-bar tool-bar)) main-window
|
|
|
|
(with-accessors ((iri-entry iri-entry)) tool-bar
|
2023-04-03 19:53:05 +02:00
|
|
|
(let ((iri (trim-blanks (gui:text iri-entry))))
|
2023-03-08 21:02:41 +01:00
|
|
|
(gui-mw::hide-candidates iri-entry)
|
2023-03-02 18:17:19 +01:00
|
|
|
(open-iri iri main-window use-cache))))))
|
2023-02-19 14:52:53 +01:00
|
|
|
|
2023-03-19 14:32:11 +01:00
|
|
|
(defun toc-callback-clsr (main-window)
|
|
|
|
(with-accessors ((toc-frame toc-frame)
|
|
|
|
(gemtext-widget gemtext-widget)
|
|
|
|
(ir-lines ir-lines)) main-window
|
|
|
|
(let ((toc-listbox (gui:listbox (toc-listbox toc-frame))))
|
|
|
|
(lambda (event)
|
|
|
|
(declare (ignore event))
|
|
|
|
(a:when-let* ((index-item (first (gui:listbox-get-selection-index toc-listbox)))
|
|
|
|
(selected-group-id (elt (toc-data toc-frame) index-item))
|
|
|
|
(line-position (position-if (lambda (a)
|
|
|
|
(a:when-let ((gid (getf a
|
|
|
|
:header-group-id)))
|
|
|
|
(= selected-group-id gid)))
|
|
|
|
ir-lines))
|
|
|
|
(line-index (1+ line-position)))
|
|
|
|
(gui:scroll-until-line-on-top gemtext-widget line-index))))))
|
|
|
|
|
2023-04-06 15:06:31 +02:00
|
|
|
(defun reload-iri-clsr (main-window)
|
|
|
|
(lambda ()
|
|
|
|
(with-accessors ((tool-bar tool-bar)) main-window
|
|
|
|
(with-accessors ((iri-entry iri-entry)) tool-bar
|
2023-05-13 14:45:45 +02:00
|
|
|
(let ((iri (get-address-bar-text main-window)))
|
2023-04-06 15:06:31 +02:00
|
|
|
(open-iri iri main-window nil))))))
|
|
|
|
|
2023-04-06 18:57:20 +02:00
|
|
|
(defun up-iri-clsr (main-window)
|
2023-04-06 15:06:31 +02:00
|
|
|
(lambda ()
|
|
|
|
(with-accessors ((tool-bar tool-bar)) main-window
|
|
|
|
(with-accessors ((iri-entry iri-entry)) tool-bar
|
|
|
|
(let ((to-parent-iri (cev:enqueue-request-and-wait-results :iri-to-parent-path
|
|
|
|
1
|
2023-05-12 14:22:39 +02:00
|
|
|
ev:+standard-event-priority+
|
|
|
|
(gui:text iri-entry))))
|
2023-04-06 15:06:31 +02:00
|
|
|
(when (string-not-empty-p to-parent-iri)
|
2023-05-13 21:20:49 +02:00
|
|
|
(set-address-bar-text main-window to-parent-iri)
|
2023-04-06 15:06:31 +02:00
|
|
|
(open-iri to-parent-iri main-window t)))))))
|
|
|
|
|
2023-04-06 18:57:20 +02:00
|
|
|
(defun back-iri-clsr (main-window)
|
2023-04-06 15:06:31 +02:00
|
|
|
(lambda ()
|
|
|
|
(with-accessors ((tool-bar tool-bar)) main-window
|
|
|
|
(with-accessors ((iri-entry iri-entry)) tool-bar
|
2023-04-06 18:57:20 +02:00
|
|
|
(let ((iri-visited (cev:enqueue-request-and-wait-results :gemini-pop-url-from-history
|
2023-04-06 15:06:31 +02:00
|
|
|
1
|
2023-04-06 18:57:20 +02:00
|
|
|
ev:+standard-event-priority+)))
|
2023-04-06 15:06:31 +02:00
|
|
|
(when (string-not-empty-p iri-visited)
|
2023-05-13 21:20:49 +02:00
|
|
|
(set-address-bar-text main-window iri-visited)
|
2023-04-06 15:06:31 +02:00
|
|
|
(open-iri iri-visited main-window t)))))))
|
|
|
|
|
2023-04-09 10:05:59 +02:00
|
|
|
(defun set-bookmark-button-image (main-window image)
|
|
|
|
(with-accessors ((tool-bar tool-bar)) main-window
|
|
|
|
(with-accessors ((bookmark-button bookmark-button)) tool-bar
|
|
|
|
(gui:configure bookmark-button :image image))))
|
|
|
|
|
|
|
|
(defun set-bookmark-button-false (main-window)
|
|
|
|
(set-bookmark-button-image main-window icons:*star-yellow*))
|
|
|
|
|
|
|
|
(defun set-bookmark-button-true (main-window)
|
|
|
|
(set-bookmark-button-image main-window icons:*star-blue*))
|
|
|
|
|
2023-05-07 12:21:29 +02:00
|
|
|
(defun set-subscribe-button-image (main-window image)
|
|
|
|
(with-accessors ((tool-bar tool-bar)) main-window
|
|
|
|
(with-accessors ((subscribe-button subscribe-button)) tool-bar
|
|
|
|
(gui:configure subscribe-button :image image))))
|
|
|
|
|
|
|
|
(defun set-subscribe-button-unsubscribed (main-window)
|
|
|
|
(set-subscribe-button-image main-window icons:*gemlog-subscribe*))
|
|
|
|
|
|
|
|
(defun set-subscribe-button-subscribed (main-window)
|
|
|
|
(set-subscribe-button-image main-window icons:*gemlog-unsubscribe*))
|
|
|
|
|
|
|
|
(defun toggle-bookmark-iri-clsr (main-window)
|
2023-04-09 10:05:59 +02:00
|
|
|
(lambda ()
|
|
|
|
(with-accessors ((tool-bar tool-bar)) main-window
|
|
|
|
(with-accessors ((iri-entry iri-entry)) tool-bar
|
|
|
|
(let* ((iri (gui:text iri-entry))
|
2023-04-13 18:33:32 +02:00
|
|
|
(bookmarkedp (cev:enqueue-request-and-wait-results :gemini-bookmarked-p
|
|
|
|
1
|
|
|
|
ev:+standard-event-priority+
|
|
|
|
iri)))
|
|
|
|
(if bookmarkedp
|
2023-04-09 10:05:59 +02:00
|
|
|
(ev:with-enqueued-process-and-unblock ()
|
|
|
|
(comm:make-request :gemini-bookmark-delete 1 iri)
|
|
|
|
(set-bookmark-button-false main-window))
|
2023-04-13 18:33:32 +02:00
|
|
|
(client-bookmark-window:init-window main-window (gui:text iri-entry))))))))
|
2023-04-09 10:05:59 +02:00
|
|
|
|
2023-05-07 12:21:29 +02:00
|
|
|
(defun toggle-subscribtion-iri-clsr (main-window)
|
|
|
|
(lambda ()
|
|
|
|
(with-accessors ((tool-bar tool-bar)) main-window
|
|
|
|
(with-accessors ((iri-entry iri-entry)) tool-bar
|
|
|
|
(ev:with-enqueued-process-and-unblock ()
|
|
|
|
(let* ((iri (gui:text iri-entry))
|
|
|
|
(subscribedp (comm:make-request :gemini-gemlog-subscribed-p
|
|
|
|
1
|
|
|
|
iri)))
|
|
|
|
(if subscribedp
|
|
|
|
(progn
|
|
|
|
(comm:make-request :gemini-gemlog-unsubscribe 1 iri)
|
|
|
|
(set-subscribe-button-unsubscribed main-window))
|
|
|
|
(progn
|
|
|
|
(comm:make-request :gemini-gemlog-subscribe 1 iri)
|
|
|
|
(set-subscribe-button-subscribed main-window)))))))))
|
|
|
|
|
2023-04-13 15:03:57 +02:00
|
|
|
(defun tour-visit-next-iri-clsr (main-window)
|
|
|
|
(lambda ()
|
|
|
|
(let ((next-link (cev:enqueue-request-and-wait-results :tour-pop-link
|
|
|
|
1
|
|
|
|
ev:+standard-event-priority+)))
|
|
|
|
(if next-link
|
|
|
|
(funcall (link-click-mouse-1-callback-clsr (getf next-link :link-value)
|
|
|
|
main-window))
|
|
|
|
(print-info-message (_ "Tour is terminated") :bold t)))))
|
|
|
|
|
2023-02-18 14:28:57 +01:00
|
|
|
(defun setup-main-window-events (main-window)
|
2023-03-19 14:32:11 +01:00
|
|
|
(with-accessors ((tool-bar tool-bar)
|
|
|
|
(toc-frame toc-frame)
|
|
|
|
(gemtext-widget gemtext-widget)
|
|
|
|
(ir-lines ir-lines)) main-window
|
2023-05-13 14:45:45 +02:00
|
|
|
(with-accessors ((iri-entry iri-entry)
|
|
|
|
(back-button back-button)
|
|
|
|
(reload-button reload-button)
|
|
|
|
(up-button up-button)
|
|
|
|
(go-button go-button)
|
|
|
|
(bookmark-button bookmark-button)
|
|
|
|
(tour-button tour-button)
|
|
|
|
(subscribe-button subscribe-button)
|
|
|
|
(inline-images-button inline-images-button)) tool-bar
|
2023-03-19 14:32:11 +01:00
|
|
|
(let ((entry-autocomplete (gui-mw:autocomplete-entry-widget iri-entry))
|
|
|
|
(toc-listbox (gui:listbox (toc-listbox toc-frame))))
|
2023-02-25 11:41:01 +01:00
|
|
|
(gui:bind entry-autocomplete
|
|
|
|
#$<KeyPress-Return>$
|
|
|
|
(lambda (e)
|
|
|
|
(declare (ignore e))
|
2023-05-14 16:25:13 +02:00
|
|
|
(gui:focus toc-frame)
|
2023-03-02 18:17:19 +01:00
|
|
|
(funcall (open-iri-clsr main-window t)))
|
2023-03-19 14:32:11 +01:00
|
|
|
:append nil)
|
|
|
|
(gui:bind toc-listbox
|
|
|
|
#$<<ListboxSelect>>$
|
|
|
|
(toc-callback-clsr main-window))
|
2023-05-13 14:45:45 +02:00
|
|
|
(setf (gui:command go-button) (open-iri-clsr main-window t))
|
|
|
|
(setf (gui:command reload-button) (reload-iri-clsr main-window))
|
|
|
|
(setf (gui:command back-button) (back-iri-clsr main-window))
|
|
|
|
(setf (gui:command up-button) (up-iri-clsr main-window))
|
|
|
|
(setf (gui:command bookmark-button) (toggle-bookmark-iri-clsr main-window))
|
|
|
|
(setf (gui:command tour-button) (tour-visit-next-iri-clsr main-window))
|
|
|
|
(setf (gui:command subscribe-button) (toggle-subscribtion-iri-clsr main-window))
|
|
|
|
(setf (gui:command inline-images-button) (inline-all-images-clsr main-window))))))
|
2023-04-05 20:11:50 +02:00
|
|
|
|
|
|
|
(defmethod initialize-instance :after ((object tool-bar) &key &allow-other-keys)
|
2023-05-13 14:45:45 +02:00
|
|
|
(with-accessors ((iri-entry iri-entry)
|
|
|
|
(back-button back-button)
|
|
|
|
(reload-button reload-button)
|
|
|
|
(up-button up-button)
|
|
|
|
(go-button go-button)
|
|
|
|
(bookmark-button bookmark-button)
|
|
|
|
(tour-button tour-button)
|
|
|
|
(subscribe-button subscribe-button)
|
|
|
|
(inline-images-button inline-images-button)) object
|
2023-02-08 13:02:26 +01:00
|
|
|
(gui:configure object :relief :raised)
|
2023-02-18 13:02:56 +01:00
|
|
|
(setf iri-entry (make-instance 'gui-mw:autocomplete-entry
|
|
|
|
:master object
|
|
|
|
:autocomplete-function (autocomplete-iri-clsr object)))
|
2023-05-07 12:21:29 +02:00
|
|
|
(setf back-button (make-instance 'gui:button :master object :image icons:*back*))
|
|
|
|
(setf reload-button (make-instance 'gui:button :master object :image icons:*refresh*))
|
|
|
|
(setf go-button (make-instance 'gui:button :master object :image icons:*open-iri*))
|
|
|
|
(setf up-button (make-instance 'gui:button :master object :image icons:*up*))
|
|
|
|
(setf bookmark-button (make-instance 'gui:button :master object))
|
|
|
|
(setf tour-button (make-instance 'gui:button :master object :image icons:*bus-go*))
|
|
|
|
(setf subscribe-button (make-instance 'gui:button
|
|
|
|
:master object
|
|
|
|
:image icons:*gemlog-subscribe*))
|
2023-05-13 14:45:45 +02:00
|
|
|
(setf inline-images-button (make-instance 'gui:button
|
|
|
|
:master object
|
|
|
|
:image icons:*inline-images*))
|
|
|
|
(gui-goodies:attach-tooltips (back-button (_ "go back"))
|
|
|
|
(reload-button (_ "reload address"))
|
|
|
|
(go-button (_ "go to address"))
|
|
|
|
(up-button (_ "one level up"))
|
|
|
|
(bookmark-button (_ "add or remove bookmark"))
|
|
|
|
(tour-button (_ "go to the next link in tour"))
|
|
|
|
(subscribe-button (_ "subscribe/unsubscribe to this gemlog"))
|
|
|
|
(inline-images-button (_ "inline images")))
|
|
|
|
(gui:grid back-button 0 0 :sticky :nsw)
|
|
|
|
(gui:grid reload-button 0 1 :sticky :nsw)
|
|
|
|
(gui:grid up-button 0 2 :sticky :nsw)
|
|
|
|
(gui:grid iri-entry 0 3 :sticky :nswe :padx +minimum-padding+)
|
|
|
|
(gui:grid go-button 0 4 :sticky :nsw)
|
|
|
|
(gui:grid bookmark-button 0 5 :sticky :nsw)
|
|
|
|
(gui:grid subscribe-button 0 6 :sticky :nsw)
|
|
|
|
(gui:grid tour-button 0 7 :sticky :nsw)
|
|
|
|
(gui:grid inline-images-button 0 8 :sticky :nsw)
|
2023-04-07 12:27:05 +02:00
|
|
|
(gui:grid-columnconfigure object 3 :weight 2)
|
2023-02-08 13:02:26 +01:00
|
|
|
object))
|
|
|
|
|
|
|
|
(defclass toc-frame (gui:frame)
|
|
|
|
((toc-listbox
|
|
|
|
:initform nil
|
|
|
|
:initarg :toc-listbox
|
|
|
|
:accessor toc-listbox)
|
|
|
|
(toc-data
|
|
|
|
:initform nil
|
|
|
|
:initarg :toc-data
|
|
|
|
:accessor toc-data)))
|
|
|
|
|
2023-04-05 20:11:50 +02:00
|
|
|
(defun setup-on-motion-higlight-toc-entry (toc-listbox)
|
|
|
|
(with-accessors ((listbox gui:listbox)) toc-listbox
|
|
|
|
(gui:bind listbox
|
|
|
|
#$<Motion>$
|
|
|
|
(lambda (event)
|
|
|
|
(let* ((y (gui:event-y event))
|
|
|
|
(selected-index (gui:listbox-nearest listbox y)))
|
|
|
|
(gui:listbox-clear listbox)
|
|
|
|
(gui:listbox-select listbox selected-index))))))
|
|
|
|
|
2023-02-08 13:02:26 +01:00
|
|
|
(defmethod initialize-instance :after ((object toc-frame) &key &allow-other-keys)
|
|
|
|
(with-accessors ((toc-listbox toc-listbox)
|
|
|
|
(toc-data toc-data)) object
|
2023-04-05 20:11:50 +02:00
|
|
|
(setf toc-listbox
|
|
|
|
(make-instance 'gui:scrolled-listbox
|
|
|
|
:cursor (gui:find-cursor :hand2)
|
|
|
|
:master object
|
|
|
|
:name nil
|
|
|
|
:select-mode :single))
|
|
|
|
(setup-on-motion-higlight-toc-entry toc-listbox)
|
2023-03-19 13:00:28 +01:00
|
|
|
(gui:configure (gui:listbox toc-listbox) :width (gui-conf:config-toc-minimum-width))
|
2023-03-18 20:27:24 +01:00
|
|
|
(gui:configure (gui:listbox toc-listbox)
|
|
|
|
:font (gui-conf:toc-font-configuration))
|
2023-02-08 13:02:26 +01:00
|
|
|
(gui:grid toc-listbox 0 0
|
|
|
|
:sticky :nswe
|
|
|
|
:ipadx +minimum-padding+
|
|
|
|
:ipady +minimum-padding+)
|
2023-03-11 14:24:51 +01:00
|
|
|
(gui-goodies:gui-resize-grid-all object)))
|
2023-02-08 13:02:26 +01:00
|
|
|
|
2023-05-14 12:50:54 +02:00
|
|
|
(defun initialize-ir-lines (main-window)
|
|
|
|
(setf (ir-rendered-lines main-window) (misc:make-fresh-array 0)
|
|
|
|
(ir-lines main-window) (misc:make-fresh-array 0))
|
|
|
|
main-window)
|
|
|
|
|
2023-02-08 13:02:26 +01:00
|
|
|
(defclass main-frame (gui:frame)
|
2023-04-09 11:29:01 +02:00
|
|
|
((gemtext-widget
|
2023-02-21 20:20:19 +01:00
|
|
|
:initform nil
|
|
|
|
:initarg :gemtext-widget
|
|
|
|
:accessor gemtext-widget)
|
2023-05-31 15:05:21 +02:00
|
|
|
(gemtext-font-scaling
|
2023-06-01 19:22:58 +02:00
|
|
|
:initform 1.0
|
2023-05-31 15:05:21 +02:00
|
|
|
:initarg :gemtext-font-scaling
|
|
|
|
:accessor gemtext-font-scaling)
|
2023-02-05 14:07:13 +01:00
|
|
|
(tool-bar
|
|
|
|
:initform nil
|
|
|
|
:initarg :tool-bar
|
|
|
|
:accessor tool-bar)
|
2023-02-08 13:02:26 +01:00
|
|
|
(toc-frame
|
2023-02-05 14:07:13 +01:00
|
|
|
:initform nil
|
2023-02-08 13:02:26 +01:00
|
|
|
:initarg :toc-frame
|
|
|
|
:accessor toc-frame)
|
|
|
|
(info-frame
|
2023-02-05 14:07:13 +01:00
|
|
|
:initform nil
|
2023-02-08 13:02:26 +01:00
|
|
|
:initarg :info-frame
|
2023-02-21 20:20:19 +01:00
|
|
|
:accessor info-frame)
|
|
|
|
(info-text
|
|
|
|
:initform nil
|
|
|
|
:initarg :info-text
|
2023-02-25 11:41:01 +01:00
|
|
|
:accessor info-text)
|
2023-04-10 14:12:00 +02:00
|
|
|
(search-frame
|
|
|
|
:initform nil
|
|
|
|
:initarg :search-frame
|
|
|
|
:accessor search-frame)
|
2023-07-26 14:37:15 +02:00
|
|
|
(stream-frame
|
|
|
|
:initform nil
|
|
|
|
:initarg :stream-frame
|
|
|
|
:accessor stream-frame)
|
2023-05-20 16:50:31 +02:00
|
|
|
(gemini-paned-frame
|
|
|
|
:initform nil
|
|
|
|
:initarg :gemini-paned-frame
|
|
|
|
:accessor gemini-paned-frame)
|
2023-07-28 16:56:32 +02:00
|
|
|
(main-paned-frame
|
|
|
|
:initform nil
|
|
|
|
:initarg :main-paned-frame
|
|
|
|
:accessor main-paned-frame)
|
2023-02-25 11:41:01 +01:00
|
|
|
(ir-rendered-lines
|
|
|
|
:initform (misc:make-fresh-array 0)
|
|
|
|
:initarg :ir-rendered-lines
|
|
|
|
:accessor ir-rendered-lines)
|
|
|
|
(ir-lines
|
|
|
|
:initform (misc:make-fresh-array 0)
|
|
|
|
:initarg :ir-lines
|
2023-08-17 16:00:32 +02:00
|
|
|
:accessor ir-lines)
|
|
|
|
(interrupt-rendering-lock
|
|
|
|
:initform (bt:make-lock "render-lock")
|
|
|
|
:initarg :interrupt-rendering-lock
|
|
|
|
:accessor interrupt-rendering-lock)
|
|
|
|
(interrupt-rendering
|
|
|
|
:initform nil
|
|
|
|
:initarg :interrupt-rendering)))
|
2023-02-08 13:02:26 +01:00
|
|
|
|
|
|
|
(defmethod initialize-instance :after ((object main-frame) &key &allow-other-keys)
|
2023-05-20 16:50:31 +02:00
|
|
|
(with-accessors ((main-window main-window)
|
|
|
|
(tool-bar tool-bar)
|
|
|
|
(toc-frame toc-frame)
|
|
|
|
(info-frame info-frame)
|
|
|
|
(search-frame search-frame)
|
2023-07-26 14:37:15 +02:00
|
|
|
(stream-frame stream-frame)
|
2023-05-20 16:50:31 +02:00
|
|
|
(info-text info-text)
|
|
|
|
(gemtext-widget gemtext-widget)
|
2023-07-28 16:56:32 +02:00
|
|
|
(gemini-paned-frame gemini-paned-frame)
|
|
|
|
(main-paned-frame main-paned-frame)) object
|
|
|
|
(setf main-paned-frame (make-instance 'gui:paned-window
|
|
|
|
:orientation :vertical
|
|
|
|
:master object))
|
2023-05-20 16:50:31 +02:00
|
|
|
(setf gemini-paned-frame (make-instance 'gui:paned-window
|
|
|
|
:orientation :horizontal
|
2023-07-28 16:56:32 +02:00
|
|
|
:master main-paned-frame))
|
2023-05-20 16:50:31 +02:00
|
|
|
(setf tool-bar (make-instance 'tool-bar :master object))
|
|
|
|
(set-bookmark-button-false object)
|
|
|
|
(setf toc-frame (make-instance 'toc-frame :master gemini-paned-frame))
|
|
|
|
(let* ((gemtext-font (gui-conf:gemini-text-font-configuration))
|
|
|
|
(padding (client-configuration:config-gemtext-padding))
|
|
|
|
(padding-pixel (* padding (gui:font-measure gemtext-font "0"))))
|
|
|
|
(multiple-value-bind (select-bg select-fg)
|
|
|
|
(gui-conf:main-window-select-colors)
|
|
|
|
(setf gemtext-widget (make-instance 'gui:scrolled-text
|
2023-08-18 15:05:18 +02:00
|
|
|
:background (gui-conf:gemini-window-colors)
|
2023-05-20 16:50:31 +02:00
|
|
|
:selectbackground select-bg
|
|
|
|
:selectforeground select-fg
|
2023-08-17 16:41:25 +02:00
|
|
|
:insertwidth 0
|
2023-08-18 15:05:18 +02:00
|
|
|
:takefocus (nodgui.utils:lisp-bool->tcl nil)
|
|
|
|
:padx padding-pixel
|
|
|
|
:master gemini-paned-frame
|
|
|
|
:read-only t
|
|
|
|
:font gemtext-font)))
|
2023-05-20 16:50:31 +02:00
|
|
|
(gui:configure gemtext-widget :wrap :word))
|
|
|
|
(setf info-frame (make-instance 'gui:frame :master object :relief :sunken :borderwidth 1))
|
|
|
|
(setf info-text (make-instance 'gui:text :height 2 :wrap :none :master info-frame))
|
|
|
|
(gui:configure info-text :font gui:+tk-small-caption-font+)
|
2023-07-27 15:55:20 +02:00
|
|
|
(setf search-frame (client-search-frame:init-frame object))
|
2023-08-18 15:05:18 +02:00
|
|
|
(setf stream-frame (client-stream-frame:init-frame main-paned-frame object))
|
2023-05-20 16:50:31 +02:00
|
|
|
(gui:grid info-text 0 0 :sticky :news)
|
|
|
|
(gui-goodies:gui-resize-grid-all info-frame)
|
|
|
|
(gui:grid tool-bar 0 0 :sticky :news)
|
2023-07-29 11:59:42 +02:00
|
|
|
(when (client-configuration:config-toc-show-p)
|
|
|
|
(gui:add-pane gemini-paned-frame toc-frame))
|
2023-05-20 16:50:31 +02:00
|
|
|
(gui:add-pane gemini-paned-frame gemtext-widget)
|
2023-07-28 16:56:32 +02:00
|
|
|
(gui:add-pane main-paned-frame gemini-paned-frame :weight 2)
|
2023-07-29 11:59:42 +02:00
|
|
|
(when (client-configuration:config-stream-frame-show-p)
|
|
|
|
(gui:add-pane main-paned-frame stream-frame))
|
2023-07-28 16:56:32 +02:00
|
|
|
(gui:grid main-paned-frame 1 0 :sticky :news)
|
2023-05-20 16:50:31 +02:00
|
|
|
(gui:grid search-frame 2 0 :sticky :news)
|
|
|
|
(gui:grid-forget search-frame)
|
2023-07-26 14:37:15 +02:00
|
|
|
(gui:grid info-frame 4 0 :sticky :ews)
|
2023-05-20 16:50:31 +02:00
|
|
|
(gui:grid-columnconfigure object 0 :weight 1)
|
|
|
|
(gui:grid-rowconfigure object 1 :weight 1)
|
|
|
|
(setup-main-window-events object)
|
|
|
|
(gui:focus (nodgui.mw:autocomplete-entry-widget (iri-entry (tool-bar object))))
|
|
|
|
object))
|
2023-02-05 14:07:13 +01:00
|
|
|
|
2023-08-17 16:00:32 +02:00
|
|
|
(defgeneric interrupt-rendering-p (object))
|
|
|
|
|
|
|
|
(defgeneric interrupt-rendering (object))
|
|
|
|
|
|
|
|
(defgeneric restart-rendering (object))
|
|
|
|
|
2023-03-19 13:00:28 +01:00
|
|
|
(defgeneric toc-char-width (object))
|
|
|
|
|
2023-09-09 15:06:35 +02:00
|
|
|
(defgeneric gemtext-widget-pixel-width (object))
|
|
|
|
|
2023-03-19 13:00:28 +01:00
|
|
|
(defgeneric toc-clear (object))
|
|
|
|
|
|
|
|
(defmethod toc-char-width ((object main-frame))
|
|
|
|
(gui:cget (gui:listbox (toc-listbox (toc-frame object)))
|
|
|
|
:width))
|
|
|
|
|
2023-09-09 15:06:35 +02:00
|
|
|
(defmethod gemtext-widget-pixel-width ((object main-frame))
|
|
|
|
(gui:window-width (gui:inner-text (gemtext-widget object))))
|
|
|
|
|
2023-03-19 13:00:28 +01:00
|
|
|
(defmethod toc-clear ((object main-frame))
|
|
|
|
(gui:listbox-delete (toc-listbox (toc-frame object))))
|
|
|
|
|
2023-05-20 16:50:31 +02:00
|
|
|
(defgeneric fit-toc-char-width (object new-width))
|
|
|
|
|
2023-08-17 16:00:32 +02:00
|
|
|
(defmethod interrupt-rendering-p ((object main-frame))
|
|
|
|
(misc:with-lock ((interrupt-rendering-lock object))
|
|
|
|
(slot-value object 'interrupt-rendering)))
|
|
|
|
|
|
|
|
(defun set-interrupt-rendering-state (main-frame value)
|
|
|
|
(misc:with-lock ((interrupt-rendering-lock main-frame))
|
|
|
|
(setf (slot-value main-frame 'interrupt-rendering) value)))
|
|
|
|
|
|
|
|
(defmethod interrupt-rendering ((object main-frame))
|
|
|
|
(set-interrupt-rendering-state object t))
|
|
|
|
|
|
|
|
(defmethod restart-rendering ((object main-frame))
|
|
|
|
(set-interrupt-rendering-state object nil))
|
|
|
|
|
2023-05-20 16:50:31 +02:00
|
|
|
(defmethod fit-toc-char-width ((object main-frame) new-width)
|
|
|
|
(with-accessors ((toc-frame toc-frame)
|
|
|
|
(gemini-paned-frame gemini-paned-frame)) object
|
|
|
|
(a:when-let* ((inner-listbox (gui:listbox (toc-listbox (toc-frame object))))
|
|
|
|
(listbox-items (gui:listbox-all-values inner-listbox))
|
|
|
|
(font (gui:cget inner-listbox :font))
|
|
|
|
(longest-value (reduce (lambda (a b)
|
|
|
|
(if (> (length a) (length b))
|
|
|
|
a
|
|
|
|
b))
|
|
|
|
listbox-items))
|
|
|
|
(width-pixel (gui:font-measure font (strcat longest-value "MM"))))
|
|
|
|
(gui:configure inner-listbox :width new-width)
|
2023-05-20 17:31:11 +02:00
|
|
|
(when (client-configuration:config-toc-autoresize-p)
|
|
|
|
(gui:sash-place gemini-paned-frame 0 width-pixel)))))
|
2023-03-19 13:00:28 +01:00
|
|
|
|
2023-03-03 17:04:40 +01:00
|
|
|
(defun print-info-message (message &key
|
|
|
|
(color (gui-goodies:parse-color "black"))
|
2023-07-14 15:41:48 +02:00
|
|
|
(bold t))
|
2023-02-22 15:58:30 +01:00
|
|
|
(let ((info-widget (info-text gui-goodies:*main-frame*)))
|
|
|
|
(setf (gui:text info-widget) message)
|
|
|
|
(let ((color-tag (gui:tag-create info-widget
|
|
|
|
(nodgui.utils:create-tag-name)
|
|
|
|
(gui:make-indices-start)
|
|
|
|
(gui:make-indices-end))))
|
|
|
|
(if bold
|
|
|
|
(gui:tag-configure info-widget
|
|
|
|
color-tag
|
|
|
|
:foreground color
|
|
|
|
:font "bold")
|
|
|
|
(gui:tag-configure info-widget
|
|
|
|
color-tag
|
|
|
|
:foreground color)))))
|
|
|
|
|
|
|
|
(defun print-error-message (message)
|
|
|
|
(print-info-message message :color (gui-goodies:parse-color "red") :bold t))
|
|
|
|
|
2023-06-25 11:27:40 +02:00
|
|
|
(defun clear-gemtext (main-window)
|
|
|
|
(setf (gui:text (gemtext-widget main-window)) "")
|
|
|
|
(gui:configure-mouse-pointer (gemtext-widget main-window) :xterm))
|
2023-03-06 18:38:46 +01:00
|
|
|
|
|
|
|
(defun set-text-gemtext (main-window text)
|
|
|
|
(setf (gui:text (gemtext-widget main-window)) text))
|
|
|
|
|
2023-04-09 11:29:01 +02:00
|
|
|
(defun set-address-bar-text (main-window text)
|
2023-05-13 21:20:49 +02:00
|
|
|
(let* ((autocomplete-entry (iri-entry (tool-bar main-window)))
|
|
|
|
(entry (nodgui.mw:autocomplete-entry-widget autocomplete-entry)))
|
|
|
|
(setf (gui:text (iri-entry (tool-bar main-window))) text)
|
|
|
|
(gui:clear-selection entry)))
|
2023-04-09 11:29:01 +02:00
|
|
|
|
2023-05-23 18:38:01 +02:00
|
|
|
(defun set-focus-to-gemtext (main-window)
|
|
|
|
(gui:focus (gui:inner-text (gemtext-widget main-window))))
|
|
|
|
|
2023-05-13 14:45:45 +02:00
|
|
|
(defun get-address-bar-text (main-window)
|
|
|
|
(trim-blanks (gui:text (iri-entry (tool-bar main-window)))))
|
|
|
|
|
2023-08-18 15:05:18 +02:00
|
|
|
(defmacro with-interrupt-rendering-enqueue-restart-rendering
|
|
|
|
((main-window &optional (priority program-events:+standard-event-priority+)) &body body)
|
|
|
|
`(progn
|
|
|
|
(interrupt-rendering ,main-window)
|
|
|
|
(ev:with-enqueued-process-and-unblock ,priority
|
|
|
|
(restart-rendering ,main-window)
|
|
|
|
,@body)))
|
|
|
|
|
2023-06-01 19:22:58 +02:00
|
|
|
(defun scale-gemtext (main-window offset)
|
2023-09-16 19:05:33 +02:00
|
|
|
(let ((saved-active-stream (find-streaming-stream-url)))
|
|
|
|
(interrupt-rendering main-window)
|
|
|
|
(maybe-stop-streaming-stream-thread)
|
|
|
|
(when saved-active-stream
|
|
|
|
(open-iri (streaming-url saved-active-stream) main-window t))
|
|
|
|
(ev:with-enqueued-process-and-unblock (program-events:+minimum-event-priority+)
|
|
|
|
(restart-rendering main-window)
|
|
|
|
(clear-gemtext main-window)
|
|
|
|
(setf (gemtext-font-scaling main-window)
|
|
|
|
(if offset
|
|
|
|
(max 0.1 (+ (gemtext-font-scaling main-window) offset))
|
|
|
|
1.0))
|
|
|
|
(render-ir-lines (get-address-bar-text main-window) main-window))))
|
2023-06-01 19:22:58 +02:00
|
|
|
|
2023-06-10 16:02:21 +02:00
|
|
|
(defun initialize-keybindings (main-window target)
|
|
|
|
(gui:bind target
|
|
|
|
(client-configuration:get-keybinding :quit)
|
|
|
|
(lambda (e)
|
|
|
|
(declare (ignore e))
|
|
|
|
(menu:quit)))
|
|
|
|
(gui:bind target
|
|
|
|
(client-configuration:get-keybinding :search)
|
|
|
|
(lambda (e)
|
|
|
|
(declare (ignore e))
|
|
|
|
(funcall (menu:show-search-frame-clsr main-window)))
|
|
|
|
:exclusive t)
|
|
|
|
(gui:bind target
|
|
|
|
(client-configuration:get-keybinding :stream)
|
|
|
|
(lambda (e)
|
|
|
|
(declare (ignore e))
|
|
|
|
(menu:show-streams))
|
|
|
|
:exclusive t)
|
|
|
|
(gui:bind target
|
|
|
|
(client-configuration:get-keybinding :certificates)
|
|
|
|
(lambda (e)
|
|
|
|
(declare (ignore e))
|
|
|
|
(menu:show-certificates))
|
|
|
|
:exclusive t)
|
|
|
|
(gui:bind target
|
|
|
|
(client-configuration:config-keybinding-tour-manage)
|
|
|
|
(lambda (e)
|
|
|
|
(declare (ignore e))
|
|
|
|
(menu:show-tour))
|
|
|
|
:exclusive t)
|
|
|
|
(gui:bind target
|
|
|
|
(client-configuration:get-keybinding :gemlog)
|
|
|
|
(lambda (e)
|
|
|
|
(declare (ignore e))
|
|
|
|
(menu:manage-gemlogs))
|
|
|
|
:exclusive t)
|
|
|
|
(gui:bind target
|
|
|
|
(client-configuration:get-keybinding :about)
|
|
|
|
(lambda (e)
|
|
|
|
(declare (ignore e))
|
|
|
|
(menu:help-about))
|
|
|
|
:exclusive t)
|
|
|
|
(gui:bind target
|
|
|
|
(client-configuration:get-keybinding :type-address)
|
|
|
|
(lambda (e)
|
|
|
|
(declare (ignore e))
|
|
|
|
(let* ((autocomplete-entry (iri-entry (tool-bar main-window)))
|
|
|
|
(entry (nodgui.mw:autocomplete-entry-widget autocomplete-entry)))
|
|
|
|
(gui:focus entry)
|
|
|
|
(gui:set-selection entry 0 :end)))
|
|
|
|
:exclusive t)
|
|
|
|
(gui:bind target
|
|
|
|
(client-configuration:config-keybinding-tour-shuffle)
|
|
|
|
(lambda (e)
|
|
|
|
(declare (ignore e))
|
|
|
|
(client-tour-window:enqueue-shuffle-tour))
|
|
|
|
:exclusive t)
|
|
|
|
(gui:bind target
|
|
|
|
(client-configuration:config-keybinding-tour-next)
|
|
|
|
(lambda (e)
|
|
|
|
(declare (ignore e))
|
|
|
|
(funcall (tour-visit-next-iri-clsr main-window)))
|
|
|
|
:exclusive t)
|
|
|
|
(gui:bind target
|
|
|
|
(client-configuration:get-keybinding :back)
|
|
|
|
(lambda (e)
|
|
|
|
(declare (ignore e))
|
|
|
|
(funcall (back-iri-clsr main-window)))
|
|
|
|
:exclusive t)
|
|
|
|
(gui:bind target
|
|
|
|
(client-configuration:get-keybinding :up)
|
|
|
|
(lambda (e)
|
|
|
|
(declare (ignore e))
|
|
|
|
(funcall (up-iri-clsr main-window)))
|
|
|
|
:exclusive t)
|
|
|
|
(gui:bind target
|
|
|
|
(client-configuration:config-keybinding-bookmark-toggle)
|
|
|
|
(lambda (e)
|
|
|
|
(declare (ignore e))
|
|
|
|
(funcall (toggle-bookmark-iri-clsr main-window)))
|
|
|
|
:exclusive t)
|
|
|
|
(gui:bind target
|
|
|
|
(client-configuration:config-keybinding-bookmark-show)
|
|
|
|
(lambda (e)
|
|
|
|
(declare (ignore e))
|
|
|
|
(funcall (menu:show-bookmarks-clsr main-window)))
|
|
|
|
:exclusive t)
|
|
|
|
(gui:bind target
|
|
|
|
(client-configuration:config-keybinding-gemtext-scaling-increase)
|
|
|
|
(lambda (e)
|
|
|
|
(declare (ignore e))
|
|
|
|
(scale-gemtext main-window 0.1))
|
|
|
|
:exclusive t)
|
|
|
|
(gui:bind target
|
|
|
|
(client-configuration:config-keybinding-gemtext-scaling-decrease)
|
|
|
|
(lambda (e)
|
|
|
|
(declare (ignore e))
|
|
|
|
(scale-gemtext main-window -0.1))
|
|
|
|
:exclusive t)
|
|
|
|
(gui:bind target
|
|
|
|
(client-configuration:config-keybinding-gemtext-scaling-reset)
|
|
|
|
(lambda (e)
|
|
|
|
(declare (ignore e))
|
|
|
|
(scale-gemtext main-window nil))
|
2023-06-10 18:44:05 +02:00
|
|
|
:exclusive t)
|
|
|
|
(gui:bind target
|
|
|
|
(client-configuration:config-keybinding-gemtext-refresh)
|
|
|
|
(lambda (e)
|
|
|
|
(declare (ignore e))
|
|
|
|
(funcall (reload-iri-clsr main-window)))
|
2023-08-16 18:09:58 +02:00
|
|
|
:exclusive t)
|
2023-08-16 18:16:05 +02:00
|
|
|
(gui:bind target
|
|
|
|
#$<Control-MouseWheel>$
|
|
|
|
(lambda (e)
|
|
|
|
(let ((clockwise (< (gui:event-delta e) 0)))
|
|
|
|
(if clockwise
|
|
|
|
(scale-gemtext main-window 0.1)
|
|
|
|
(scale-gemtext main-window -0.1))))
|
|
|
|
:exclusive t)
|
2023-08-16 18:09:58 +02:00
|
|
|
(gui:bind target
|
|
|
|
#$<Control-4>$
|
|
|
|
(lambda (e)
|
|
|
|
(declare (ignore e))
|
|
|
|
(scale-gemtext main-window 0.1))
|
|
|
|
:exclusive t)
|
|
|
|
(gui:bind target
|
|
|
|
#$<Control-5>$
|
|
|
|
(lambda (e)
|
|
|
|
(declare (ignore e))
|
|
|
|
(scale-gemtext main-window -0.1))
|
2023-06-10 16:02:21 +02:00
|
|
|
:exclusive t))
|
2023-05-13 18:53:05 +02:00
|
|
|
|
2023-05-21 15:59:59 +02:00
|
|
|
(defun init-main-window (starting-iri)
|
2023-05-14 16:25:13 +02:00
|
|
|
(setf gui:*debug-tk* nil)
|
2023-05-17 20:57:35 +02:00
|
|
|
(gui:with-nodgui (:title +program-name+ :debugger-class 'gui:graphical-condition-handler)
|
2023-05-14 16:25:13 +02:00
|
|
|
(icons:load-icons)
|
|
|
|
(setf gui-goodies:*toplevel* gui:*tk*)
|
|
|
|
(setf gui-goodies:*gui-server* gui:*wish*)
|
|
|
|
(client-events:start-events-loop)
|
|
|
|
(let ((main-frame (make-instance 'main-frame)))
|
|
|
|
(setf gui-goodies:*main-frame* main-frame)
|
|
|
|
(initialize-menu gui:*tk* main-frame)
|
|
|
|
(gui:grid main-frame 0 0 :sticky :nswe)
|
2023-06-10 16:02:21 +02:00
|
|
|
(initialize-keybindings main-frame (gui:inner-text (gemtext-widget main-frame)))
|
2023-06-13 18:34:15 +02:00
|
|
|
(initialize-keybindings main-frame (gui:root-toplevel))
|
2023-05-21 15:59:59 +02:00
|
|
|
(gui-goodies:gui-resize-grid-all gui-goodies:*toplevel*)
|
|
|
|
(gui:wait-complete-redraw)
|
|
|
|
(when (string-not-empty-p starting-iri)
|
2023-08-15 22:05:37 +02:00
|
|
|
(handler-case
|
|
|
|
(set-address-bar-text main-frame (fs:relative-file-path->absolute starting-iri))
|
|
|
|
(error ()
|
|
|
|
(set-address-bar-text main-frame starting-iri)))
|
2023-07-12 16:27:24 +02:00
|
|
|
(open-iri starting-iri main-frame nil))
|
|
|
|
(client-scheduler:start))))
|