mirror of https://codeberg.org/cage/tinmop/
1406 lines
66 KiB
Common Lisp
1406 lines
66 KiB
Common Lisp
(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
|
|
:initform +stream-status-streaming+
|
|
: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))
|
|
|
|
(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))
|
|
|
|
(defparameter *gemini-streams-db* ())
|
|
|
|
(defun push-db-stream (stream-object)
|
|
(pushnew stream-object
|
|
*gemini-streams-db*
|
|
:test (lambda (a b)
|
|
(string= (server-stream-handle a)
|
|
(server-stream-handle b))))
|
|
*gemini-streams-db*)
|
|
|
|
(defun remove-db-stream (stream-object)
|
|
(setf *gemini-streams-db*
|
|
(remove stream-object *gemini-streams-db*))
|
|
*gemini-streams-db*)
|
|
|
|
(defmethod abort-downloading ((object gemini-stream))
|
|
(setf (status object) +stream-status-canceled+))
|
|
|
|
(defun remove-all-db-stream ()
|
|
(map nil
|
|
(lambda (a) (abort-downloading a))
|
|
*gemini-streams-db*)
|
|
(setf *gemini-streams-db* ())
|
|
*gemini-streams-db*)
|
|
|
|
(defun find-db-stream-if (predicate)
|
|
(find-if predicate *gemini-streams-db*))
|
|
|
|
(defun find-db-stream-url (url)
|
|
(find-db-stream-if (lambda (a) (string= (server-stream-handle a) url))))
|
|
|
|
(defun find-streaming-stream-url ()
|
|
(find-db-stream-if (lambda (a) (eq (status a) +stream-status-streaming+))))
|
|
|
|
(defun notify-request-error (error)
|
|
(gui-goodies:error-dialog gui-goodies:*toplevel* error))
|
|
|
|
(defgeneric stop-stream-thread (object))
|
|
|
|
(defmethod stop-stream-thread ((object gemini-stream))
|
|
(with-accessors ((fetching-thread fetching-thread)) object
|
|
(abort-downloading object)
|
|
(when (and (bt:threadp fetching-thread)
|
|
(bt:thread-alive-p fetching-thread))
|
|
(bt:join-thread fetching-thread)))
|
|
object)
|
|
|
|
(defmethod stop-stream-thread ((object string))
|
|
(let ((stream-wrapper (find-db-stream-url object)))
|
|
(stop-stream-thread stream-wrapper)))
|
|
|
|
(defun stop-steaming-stream-thread ()
|
|
(let ((stream-wrapper (find-streaming-stream-url)))
|
|
(stop-stream-thread stream-wrapper)))
|
|
|
|
(defun maybe-stop-steaming-stream-thread ()
|
|
(a:when-let ((stream-wrapper (find-streaming-stream-url)))
|
|
(stop-stream-thread stream-wrapper)))
|
|
|
|
(defmacro with-notify-errors (&body body)
|
|
`(handler-case
|
|
(progn ,@body)
|
|
(comm:rpc-error-response (e)
|
|
#+debug-mode (misc:dbg "backend comunication RPC error ~a" e)
|
|
(notify-request-error (format nil
|
|
(_ "~a: ~a")
|
|
(comm:code e)
|
|
(conditions:text e))))
|
|
(error (e)
|
|
#+debug-mode (misc:dbg "backend comunication error ~a" e)
|
|
(notify-request-error e))))
|
|
|
|
(defun enqueue-request-notify-error (method-name id &rest args)
|
|
(ev:with-enqueued-process-and-unblock ()
|
|
(with-notify-errors
|
|
(apply #'comm:make-request method-name id args))))
|
|
|
|
(defun render-toc (main-window iri)
|
|
(with-notify-errors
|
|
(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))))
|
|
(setf (toc-char-width main-window) toc-widget-width)
|
|
(loop for ct from 0
|
|
for toc-item in toc do
|
|
(gui:listbox-append (toc-listbox (toc-frame main-window))
|
|
(getf toc-item :text)))
|
|
(setf (toc-data (toc-frame main-window))
|
|
(loop for toc-item in toc collect (getf toc-item :header-group-id)))))
|
|
main-window)))
|
|
|
|
(defun slurp-gemini-stream (main-window iri stream-wrapper &key
|
|
(use-cache t)
|
|
(process-function #'identity)
|
|
(aborting-function (constantly nil)))
|
|
(enqueue-request-notify-error :gemini-request 1 iri use-cache)
|
|
(labels ((stream-exausted-p ()
|
|
(let ((status-completed (comm:make-request :gemini-stream-completed-p
|
|
1
|
|
iri)))
|
|
status-completed))
|
|
(loop-fetch (&optional (last-lines-fetched-count 0))
|
|
(ev:with-enqueued-process-and-unblock ()
|
|
(with-notify-errors
|
|
(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))
|
|
(when (not (or (funcall aborting-function)
|
|
(and (stream-exausted-p)
|
|
next-start-fetching)))
|
|
(loop-fetch (+ last-lines-fetched-count
|
|
next-start-fetching))))))))
|
|
(loop-fetch)
|
|
(ev:with-enqueued-process-and-unblock ()
|
|
(print-info-message (_ "Stream finished"))
|
|
(render-toc main-window iri))
|
|
(if (cev:enqueue-request-and-wait-results :gemini-bookmarked-p
|
|
1
|
|
ev:+standard-event-priority+
|
|
iri)
|
|
(ev:with-enqueued-process-and-unblock ()
|
|
(set-bookmark-button-true main-window))
|
|
(ev:with-enqueued-process-and-unblock ()
|
|
(set-bookmark-button-false main-window)))
|
|
(ev:with-enqueued-process-and-unblock ()
|
|
(set-gemlog-toolbar-button-appearance main-window iri))
|
|
(ev:with-enqueued-process-and-unblock ()
|
|
(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)))))
|
|
|
|
(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)))
|
|
|
|
(defun start-streaming-thread (main-window iri
|
|
&key
|
|
(use-cache t)
|
|
(process-function #'identity)
|
|
(status +stream-status-streaming+))
|
|
(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))
|
|
(flet ((aborting-function ()
|
|
(eq (status stream-wrapper) +stream-status-canceled+)))
|
|
(print-info-message (_ "Stream started"))
|
|
(let ((stream-thread (bt:make-thread (lambda ()
|
|
(slurp-gemini-stream main-window
|
|
iri
|
|
stream-wrapper
|
|
:use-cache use-cache
|
|
:process-function
|
|
process-function
|
|
:aborting-function
|
|
#'aborting-function)))))
|
|
(setf (fetching-thread stream-wrapper) stream-thread)
|
|
stream-wrapper)))))
|
|
|
|
(defun initialize-menu (parent main-window)
|
|
(let* ((bar (gui:make-menubar parent))
|
|
(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"))))
|
|
(gui:make-menubutton tools
|
|
(_ "Certificates")
|
|
#'menu:show-certificates
|
|
:accelerator (client-configuration:get-keybinding :certificates))
|
|
(gui:make-menubutton tools
|
|
(_ "Streams")
|
|
#'menu:show-streams
|
|
:accelerator (client-configuration:get-keybinding :stream))
|
|
(gui:make-menubutton tools
|
|
(_ "Search")
|
|
(menu:show-search-frame-clsr main-window)
|
|
:accelerator (client-configuration:get-keybinding :search))
|
|
(gui:make-menubutton file
|
|
(_ "Quit")
|
|
#'menu:quit
|
|
:accelerator (client-configuration:get-keybinding :quit))
|
|
(gui:make-menubutton help
|
|
(_ "About")
|
|
#'menu:help-about
|
|
:accelerator (client-configuration:get-keybinding :about))
|
|
(gui:make-menubutton bookmarks
|
|
(_ "Show")
|
|
(menu:show-bookmarks-clsr main-window)
|
|
:accelerator (client-configuration:config-keybinding-bookmark-show))
|
|
(gui:make-menubutton bookmarks (_ "Manage") (menu:manage-bookmarks-clsr main-window))
|
|
(gui:make-menubutton tour
|
|
(_ "Manage")
|
|
#'menu:show-tour
|
|
:accelerator (client-configuration:config-keybinding-tour-manage))
|
|
(gui:make-menubutton tour
|
|
(_ "Shuffle")
|
|
(lambda () (client-tour-window:enqueue-shuffle-tour))
|
|
:accelerator (client-configuration:config-keybinding-tour-shuffle))
|
|
(gui:make-menubutton gemlogs
|
|
(_ "Show")
|
|
#'menu:manage-gemlogs
|
|
:accelerator (client-configuration:get-keybinding :gemlog))))
|
|
|
|
(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)
|
|
(up-button
|
|
:initform nil
|
|
:initarg :up-button
|
|
:accessor up-button)
|
|
(go-button
|
|
:initform nil
|
|
:initarg :go-button
|
|
:accessor go-button)
|
|
(bookmark-button
|
|
:initform nil
|
|
:initarg :bookmark-button
|
|
:accessor bookmark-button)
|
|
(tour-button
|
|
:initform nil
|
|
:initarg :tour-button
|
|
:accessor tour-button)
|
|
(subscribe-button
|
|
:initform nil
|
|
:initarg :subscribe-button
|
|
:accessor subscribe-button)
|
|
(inline-images-button
|
|
:initform nil
|
|
:initarg :inline-images-button
|
|
:accessor inline-images-button)))
|
|
|
|
(defun autocomplete-iri-clsr (toolbar)
|
|
(declare (ignore toolbar))
|
|
(lambda (hint)
|
|
(if (or (complete:expand-iri-as-local-path-p hint)
|
|
(> (length hint) 2))
|
|
(with-notify-errors
|
|
(let ((match-results (cev:enqueue-request-and-wait-results :complete-net-address
|
|
1
|
|
ev:+maximum-event-priority+
|
|
hint)))
|
|
(values (getf match-results :matches)
|
|
(getf match-results :indices))))
|
|
hint)))
|
|
|
|
(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)
|
|
|
|
(gen-ir-access pre-alt-text)
|
|
|
|
(defun link-click-mouse-1-callback-clsr (link-value main-window
|
|
&key
|
|
(use-cache t)
|
|
(status +stream-status-streaming+))
|
|
(with-accessors ((tool-bar tool-bar)) main-window
|
|
(with-accessors ((iri-entry iri-entry)) tool-bar
|
|
(lambda ()
|
|
(set-address-bar-text main-window link-value)
|
|
(gui:focus (toc-frame main-window))
|
|
(open-iri link-value main-window use-cache :status status)))))
|
|
|
|
(defun absolutize-link (request-iri 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))))
|
|
|
|
(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)
|
|
(ev:with-enqueued-process-and-unblock ()
|
|
(comm:make-request :gemini-save-url-db-history 1 iri))
|
|
(slurp-non-text-data main-window iri :try-to-open nil))))))
|
|
|
|
(defun inline-image-p (link-value)
|
|
(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)))
|
|
|
|
(defun inline-possible-p (link-value)
|
|
(inline-image-p link-value))
|
|
|
|
(defun inline-type (link-value)
|
|
(when (inline-image-p link-value)
|
|
:inline-image))
|
|
|
|
(defun inline-image (main-window link-value line-index)
|
|
(let* ((file-path (slurp-iri main-window link-value))
|
|
(image (gui:make-image file-path))
|
|
(coordinates `(+ (:line ,line-index :char 0) 1 :lines)))
|
|
(gui:insert-image (gemtext-widget main-window) image coordinates)
|
|
(with-accessors ((ir-lines ir-lines)
|
|
(ir-rendered-lines ir-rendered-lines)) main-window
|
|
(let* ((parent-line (elt ir-lines (- line-index 1)))
|
|
(new-line (copy-list parent-line)))
|
|
(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-lines
|
|
""
|
|
line-index))))))
|
|
|
|
(defun inline-all-images (main-window)
|
|
(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))))
|
|
(inline-image main-window link-value line-number)))))
|
|
|
|
(defun inline-all-images-clsr (main-window)
|
|
(lambda ()
|
|
(inline-all-images main-window)))
|
|
|
|
(defun contextual-menu-link-clrs (link-name link-value main-window line-count)
|
|
(labels ((add-to-tour-callback ()
|
|
(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)))))
|
|
(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))))
|
|
(open-inline-callback ()
|
|
(if (inline-possible-p link-value)
|
|
(gui-goodies:with-busy* (main-window)
|
|
(inline-image main-window link-value line-count))
|
|
(funcall (link-click-mouse-1-callback-clsr link-value main-window)))))
|
|
(lambda ()
|
|
(let* ((popup-menu (gui:make-menu nil (_"link menu")))
|
|
(x (gui:screen-mouse-x))
|
|
(y (gui:screen-mouse-y)))
|
|
(when (inline-possible-p link-value)
|
|
(gui:make-menubutton popup-menu (_ "Inline") #'open-inline-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 (_ "Copy link to the clipboard") #'copy-link-callback)
|
|
(gui:make-menubutton popup-menu
|
|
(_ "Open link in background")
|
|
#'download-background-callback)
|
|
(gui:popup popup-menu x y)))))
|
|
|
|
(defmethod maybe-re-emphatize-lines (gemtext-widget from to)
|
|
(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 (client-configuration:font-text-bold))
|
|
(gui:tag-raise gemtext-widget (gui:match-tag-name match))))))
|
|
|
|
(defun collect-ir-lines (request-iri main-window lines)
|
|
(with-accessors ((ir-lines ir-lines)
|
|
(ir-rendered-lines ir-rendered-lines)
|
|
(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)))
|
|
(key->font (key)
|
|
(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))))
|
|
(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)
|
|
(:h1
|
|
(gui-conf:gemini-h1-justification))
|
|
(:h2
|
|
(gui-conf:gemini-h2-justification))
|
|
(:h3
|
|
(gui-conf:gemini-h3-justification))
|
|
(:quote
|
|
(gui-conf:gemini-quote-justification))
|
|
((:pre :pre-end :as-is)
|
|
(gui-conf:gemini-preformatted-text-justification))))
|
|
(linkify (line line-number)
|
|
(multiple-value-bind (link-bg link-fg)
|
|
(gui-conf:gemini-link-colors)
|
|
(let* ((link-font (gui-conf:gemini-link-font-configuration))
|
|
(link-value (ir-href line))
|
|
(target-iri (absolutize-link request-iri link-value))
|
|
(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-text (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))))))
|
|
(vector-push-extend link-text ir-rendered-lines)
|
|
(let ((new-text-line-start `(:line ,line-number :char 0)))
|
|
(gui:append-text gemtext-widget (a:last-elt ir-rendered-lines))
|
|
(gui:make-link-button gemtext-widget
|
|
new-text-line-start
|
|
`(- :end 1 :chars)
|
|
link-font
|
|
link-fg
|
|
link-bg
|
|
(link-click-mouse-1-callback-clsr target-iri
|
|
main-window)
|
|
:button-3-callback
|
|
(contextual-menu-link-clrs link-name
|
|
target-iri
|
|
main-window
|
|
line-number)
|
|
:over-callback
|
|
(lambda () (print-info-message target-iri))
|
|
:leave-callback
|
|
(lambda () (print-info-message "")))
|
|
(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 "")
|
|
(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)
|
|
tag)))))
|
|
(loop with render-line-count = 0
|
|
with starting-pre-block-line = -1
|
|
with ending-pre-block-line = -1
|
|
with current-pre-block-alt-text = nil
|
|
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)
|
|
(incf render-line-count)
|
|
(render-line :vertical-space (a:last-elt ir-rendered-lines) render-line-count))
|
|
(:as-is
|
|
(vector-push-extend (ir-line line) ir-rendered-lines)
|
|
(incf render-line-count)
|
|
(render-line :as-is
|
|
(a:last-elt ir-rendered-lines)
|
|
render-line-count
|
|
:wrap :none))
|
|
(:text
|
|
(vector-push-extend (ir-line line) ir-rendered-lines)
|
|
(incf render-line-count)
|
|
(render-line :text (a:last-elt ir-rendered-lines) render-line-count)
|
|
(maybe-re-emphatize-lines gemtext-widget
|
|
`(:line ,render-line-count :char 0)
|
|
`(:line ,render-line-count :char :end)))
|
|
(:h1
|
|
(push-prefixed (gui-conf:gemini-h1-prefix) line)
|
|
(incf render-line-count)
|
|
(render-line :h1 (a:last-elt ir-rendered-lines) render-line-count))
|
|
(:h2
|
|
(push-prefixed (gui-conf:gemini-h1-prefix) line)
|
|
(incf render-line-count)
|
|
(render-line :h2 (a:last-elt ir-rendered-lines) render-line-count))
|
|
(:h3
|
|
(push-prefixed (gui-conf:gemini-h1-prefix) line)
|
|
(incf render-line-count)
|
|
(render-line :h3 (a:last-elt ir-rendered-lines) render-line-count))
|
|
(:li
|
|
(push-prefixed (gui-conf:gemini-bullet-prefix) line)
|
|
(incf render-line-count)
|
|
(render-line :li (a:last-elt ir-rendered-lines) render-line-count)
|
|
(maybe-re-emphatize-lines gemtext-widget
|
|
`(:line ,render-line-count :char 0)
|
|
`(:line ,render-line-count :char :end)))
|
|
(:quote
|
|
(push-prefixed (gui-conf:gemini-quote-prefix) line)
|
|
(incf render-line-count)
|
|
(render-line :quote (a:last-elt ir-rendered-lines) render-line-count))
|
|
(:pre
|
|
(vector-push-extend (format nil "") ir-rendered-lines)
|
|
(incf render-line-count)
|
|
(setf starting-pre-block-line (1+ render-line-count))
|
|
(setf current-pre-block-alt-text (ir-pre-alt-text line))
|
|
(render-line :pre
|
|
(a:last-elt ir-rendered-lines)
|
|
render-line-count
|
|
:wrap :none))
|
|
(:pre-end
|
|
(vector-push-extend (format nil "") ir-rendered-lines)
|
|
(setf ending-pre-block-line (1+ render-line-count))
|
|
(incf render-line-count)
|
|
(render-line :pre-end (a:last-elt ir-rendered-lines) render-line-count))
|
|
(:a
|
|
(incf render-line-count)
|
|
(linkify line render-line-count))))))))
|
|
|
|
(defun displace-gemini-response (response)
|
|
(values (getf response :status)
|
|
(getf response :status-description)
|
|
(getf response :meta)
|
|
(getf response :cached)
|
|
(getf response :iri)))
|
|
|
|
(defun render-monospaced-text (main-window lines)
|
|
(ev:with-enqueued-process-and-unblock ()
|
|
(clean-gemtext main-window)
|
|
(gui:configure (gemtext-widget main-window)
|
|
:font (gui-conf:gemini-preformatted-text-font-configuration))
|
|
(set-text-gemtext main-window lines)))
|
|
|
|
(defun open-local-path (path main-window &key (force-rendering nil))
|
|
(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 ()
|
|
(clean-gemtext main-window)
|
|
(collect-ir-lines path gui-goodies:*main-frame* parsed-lines)))
|
|
(if force-rendering
|
|
(let ((lines (cev:enqueue-request-and-wait-results :gemini-slurp-local-file
|
|
1
|
|
ev:+standard-event-priority+
|
|
path)))
|
|
(render-monospaced-text main-window lines))
|
|
(client-os-utils:open-resource-with-external-program main-window path))))
|
|
((fs:directory-exists-p path)
|
|
(gui:choose-directory :initial-dir path :parent main-window :mustexist t))
|
|
(t
|
|
(notify-request-error (format nil (_ "No such file or directory: ~a") path)))))
|
|
|
|
(defun render-gemtext-string (main-window parsed-lines &key (links-path-prefix ""))
|
|
(ev:with-enqueued-process-and-unblock ()
|
|
(clean-gemtext main-window)
|
|
(collect-ir-lines links-path-prefix gui-goodies:*main-frame* parsed-lines)))
|
|
|
|
(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)))
|
|
|
|
(defun open-iri (iri main-window use-cache &key (status +stream-status-streaming+))
|
|
(handler-case
|
|
(let ((parsed-iri (iri:iri-parse iri)))
|
|
(cond
|
|
((iri:iri= iri (internal-iri-bookmark))
|
|
(initialize-ir-lines main-window)
|
|
(funcall (menu:show-bookmarks-clsr main-window)))
|
|
((iri:iri= iri (internal-iri-gemlogs))
|
|
(menu:manage-gemlogs))
|
|
((gemini-parser:gemini-iri-p iri)
|
|
(start-stream-iri (iri-ensure-path iri)
|
|
main-window
|
|
use-cache
|
|
status))
|
|
((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 iri))))
|
|
(error (e)
|
|
(notify-request-error e))))
|
|
|
|
(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)))
|
|
(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))))
|
|
|
|
(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)))
|
|
|
|
(defun slurp-non-text-data (main-window iri &key (try-to-open t))
|
|
(labels ((wait-until-download-complete (stream-info support-file)
|
|
(if (string-equal (getf stream-info :stream-status)
|
|
:completed)
|
|
(if try-to-open
|
|
(client-os-utils:open-resource-with-external-program main-window support-file)
|
|
(getf stream-info :support-file))
|
|
(wait-enough-data)))
|
|
(buffer-filled-enough-to-open-p (buffer-size read-so-far)
|
|
(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+))))
|
|
(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
|
|
(if (or wait-for-download
|
|
(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)))
|
|
(if (buffer-filled-enough-to-open-p buffer-size read-so-far)
|
|
(client-os-utils:open-resource-with-external-program main-window
|
|
support-file)
|
|
(wait-enough-data))))
|
|
(wait-until-download-complete stream-info support-file))))))
|
|
(wait-enough-data)))
|
|
|
|
(defun start-stream-iri (iri main-window use-cache &optional (status +stream-status-streaming+))
|
|
(let ((connecting-response (cev:enqueue-request-and-wait-results :gemini-request
|
|
1
|
|
ev:+maximum-event-priority+
|
|
iri
|
|
use-cache)))
|
|
(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)))
|
|
(start-stream-iri actual-iri main-window nil)))
|
|
((gemini-client:header-sensitive-input-p status-code)
|
|
(let ((actual-iri (get-user-request-query iri meta main-window :sensitive t)))
|
|
(start-stream-iri actual-iri main-window nil)))
|
|
((= status-code comm:+tofu-error-status-code+)
|
|
(when (gui:ask-yesno (_ "The certificate for this address has changed, replace the old with the one I just received?")
|
|
:title (_ "Server certificate error")
|
|
:parent main-window)
|
|
(cev:enqueue-request-and-wait-results :gemini-delete-certificate
|
|
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))
|
|
(let ((error-gemtext (cev:enqueue-request-and-wait-results :make-error-page
|
|
1
|
|
ev:+standard-event-priority+
|
|
iri
|
|
status-code
|
|
status-description
|
|
meta)))
|
|
(render-gemtext-string main-window error-gemtext)))
|
|
((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))))
|
|
((gemini-client:header-success-p status-code)
|
|
(ev:with-enqueued-process-and-unblock ()
|
|
(comm:make-request :gemini-save-url-db-history 1 iri))
|
|
(cond
|
|
((eq status +stream-status-streaming+)
|
|
(cond
|
|
((gemini-client:gemini-file-stream-p meta)
|
|
(maybe-stop-steaming-stream-thread)
|
|
(clean-gemtext main-window)
|
|
(initialize-ir-lines main-window)
|
|
(start-streaming-thread main-window
|
|
iri
|
|
:use-cache nil
|
|
: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
|
|
(when (not (eq (status stream-wrapper)
|
|
+stream-status-canceled+))
|
|
(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))))
|
|
((eq status +stream-status-downloading+)
|
|
(when (not (find-db-stream-url iri))
|
|
(let ((background-stream (make-instance 'gemini-stream
|
|
:server-stream-handle iri
|
|
:status status)))
|
|
(push-db-stream background-stream))))
|
|
(t
|
|
(error "Unrecognized stream status for address ~s: ~s" iri status))))))))
|
|
|
|
(defun open-iri-clsr (main-window use-cache)
|
|
(lambda ()
|
|
(with-accessors ((tool-bar tool-bar)) main-window
|
|
(with-accessors ((iri-entry iri-entry)) tool-bar
|
|
(let ((iri (trim-blanks (gui:text iri-entry))))
|
|
(gui-mw::hide-candidates iri-entry)
|
|
(open-iri iri main-window use-cache))))))
|
|
|
|
(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))))))
|
|
|
|
(defun reload-iri-clsr (main-window)
|
|
(lambda ()
|
|
(with-accessors ((tool-bar tool-bar)) main-window
|
|
(with-accessors ((iri-entry iri-entry)) tool-bar
|
|
(let ((iri (get-address-bar-text main-window)))
|
|
(open-iri iri main-window nil))))))
|
|
|
|
(defun up-iri-clsr (main-window)
|
|
(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
|
|
ev:+standard-event-priority+
|
|
(gui:text iri-entry))))
|
|
(when (string-not-empty-p to-parent-iri)
|
|
(set-address-bar-text main-window to-parent-iri)
|
|
(open-iri to-parent-iri main-window t)))))))
|
|
|
|
(defun back-iri-clsr (main-window)
|
|
(lambda ()
|
|
(with-accessors ((tool-bar tool-bar)) main-window
|
|
(with-accessors ((iri-entry iri-entry)) tool-bar
|
|
(let ((iri-visited (cev:enqueue-request-and-wait-results :gemini-pop-url-from-history
|
|
1
|
|
ev:+standard-event-priority+)))
|
|
(when (string-not-empty-p iri-visited)
|
|
(set-address-bar-text main-window iri-visited)
|
|
(open-iri iri-visited main-window t)))))))
|
|
|
|
(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*))
|
|
|
|
(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)
|
|
(lambda ()
|
|
(with-accessors ((tool-bar tool-bar)) main-window
|
|
(with-accessors ((iri-entry iri-entry)) tool-bar
|
|
(let* ((iri (gui:text iri-entry))
|
|
(bookmarkedp (cev:enqueue-request-and-wait-results :gemini-bookmarked-p
|
|
1
|
|
ev:+standard-event-priority+
|
|
iri)))
|
|
(if bookmarkedp
|
|
(ev:with-enqueued-process-and-unblock ()
|
|
(comm:make-request :gemini-bookmark-delete 1 iri)
|
|
(set-bookmark-button-false main-window))
|
|
(client-bookmark-window:init-window main-window (gui:text iri-entry))))))))
|
|
|
|
(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)))))))))
|
|
|
|
(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)))))
|
|
|
|
(defun setup-main-window-events (main-window)
|
|
(with-accessors ((tool-bar tool-bar)
|
|
(toc-frame toc-frame)
|
|
(gemtext-widget gemtext-widget)
|
|
(ir-lines ir-lines)) main-window
|
|
(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
|
|
(let ((entry-autocomplete (gui-mw:autocomplete-entry-widget iri-entry))
|
|
(toc-listbox (gui:listbox (toc-listbox toc-frame))))
|
|
(gui:bind entry-autocomplete
|
|
#$<KeyPress-Return>$
|
|
(lambda (e)
|
|
(declare (ignore e))
|
|
(gui:focus toc-frame)
|
|
(funcall (open-iri-clsr main-window t)))
|
|
:append nil)
|
|
(gui:bind toc-listbox
|
|
#$<<ListboxSelect>>$
|
|
(toc-callback-clsr main-window))
|
|
(gui:bind gemtext-widget
|
|
#$<Enter>$
|
|
(lambda (e)
|
|
(declare (ignore e))
|
|
(gui:configure-mouse-pointer gemtext-widget (gui:find-cursor :xterm))))
|
|
(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))))))
|
|
|
|
(defmethod initialize-instance :after ((object tool-bar) &key &allow-other-keys)
|
|
(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
|
|
(gui:configure object :relief :raised)
|
|
(setf iri-entry (make-instance 'gui-mw:autocomplete-entry
|
|
:master object
|
|
:autocomplete-function (autocomplete-iri-clsr object)))
|
|
(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*))
|
|
(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)
|
|
(gui:grid-columnconfigure object 3 :weight 2)
|
|
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)))
|
|
|
|
(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))))))
|
|
|
|
(defmethod initialize-instance :after ((object toc-frame) &key &allow-other-keys)
|
|
(with-accessors ((toc-listbox toc-listbox)
|
|
(toc-data toc-data)) object
|
|
(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)
|
|
(gui:configure (gui:listbox toc-listbox) :width (gui-conf:config-toc-minimum-width))
|
|
(gui:configure (gui:listbox toc-listbox)
|
|
:font (gui-conf:toc-font-configuration))
|
|
(gui:grid toc-listbox 0 0
|
|
:sticky :nswe
|
|
:ipadx +minimum-padding+
|
|
:ipady +minimum-padding+)
|
|
(gui-goodies:gui-resize-grid-all object)))
|
|
|
|
(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)
|
|
|
|
(defclass main-frame (gui:frame)
|
|
((gemtext-widget
|
|
:initform nil
|
|
:initarg :gemtext-widget
|
|
:accessor gemtext-widget)
|
|
(tool-bar
|
|
:initform nil
|
|
:initarg :tool-bar
|
|
:accessor tool-bar)
|
|
(toc-frame
|
|
:initform nil
|
|
:initarg :toc-frame
|
|
:accessor toc-frame)
|
|
(info-frame
|
|
:initform nil
|
|
:initarg :info-frame
|
|
:accessor info-frame)
|
|
(info-text
|
|
:initform nil
|
|
:initarg :info-text
|
|
:accessor info-text)
|
|
(search-frame
|
|
:initform nil
|
|
:initarg :search-frame
|
|
:accessor search-frame)
|
|
(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
|
|
:accessor ir-lines)))
|
|
|
|
(defmethod initialize-instance :after ((object main-frame) &key &allow-other-keys)
|
|
(with-accessors ((main-window main-window)
|
|
(tool-bar tool-bar)
|
|
(toc-frame toc-frame)
|
|
(info-frame info-frame)
|
|
(search-frame search-frame)
|
|
(info-text info-text)
|
|
(gemtext-widget gemtext-widget)) object
|
|
(setf tool-bar (make-instance 'tool-bar :master object))
|
|
(set-bookmark-button-false object)
|
|
(setf toc-frame (make-instance 'toc-frame :master object))
|
|
(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
|
|
:background (gui-conf:gemini-window-colors)
|
|
:selectbackground select-bg
|
|
:selectforeground select-fg
|
|
:padx padding-pixel
|
|
:master object
|
|
:read-only t
|
|
:font gemtext-font))))
|
|
(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+)
|
|
(setf search-frame (client-search-frame:init-window object))
|
|
(gui:grid info-text 0 0 :sticky :news)
|
|
(gui-goodies:gui-resize-grid-all info-frame)
|
|
(gui:grid tool-bar 0 0 :sticky :new :columnspan 2)
|
|
(gui:grid toc-frame 1 0 :sticky :nsw)
|
|
(gui:grid gemtext-widget 1 1 :sticky :news)
|
|
(gui:grid search-frame 3 0 :sticky :news :columnspan 2)
|
|
(gui:grid-forget search-frame)
|
|
(gui:grid info-frame 4 0 :sticky :news :columnspan 2)
|
|
(gui:grid-columnconfigure object 1 :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))
|
|
|
|
(defgeneric toc-char-width (object))
|
|
|
|
(defgeneric toc-clear (object))
|
|
|
|
(defmethod toc-char-width ((object main-frame))
|
|
(gui:cget (gui:listbox (toc-listbox (toc-frame object)))
|
|
:width))
|
|
|
|
(defmethod toc-clear ((object main-frame))
|
|
(gui:listbox-delete (toc-listbox (toc-frame object))))
|
|
|
|
(defmethod (setf toc-char-width) (new-width (object main-frame))
|
|
(gui:configure (gui:listbox (toc-listbox (toc-frame object))) :width new-width))
|
|
|
|
(defun print-info-message (message &key
|
|
(color (gui-goodies:parse-color "black"))
|
|
(bold nil))
|
|
(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))
|
|
|
|
(defun clean-gemtext (main-window)
|
|
(setf (gui:text (gemtext-widget main-window)) ""))
|
|
|
|
(defun set-text-gemtext (main-window text)
|
|
(setf (gui:text (gemtext-widget main-window)) text))
|
|
|
|
(defun set-address-bar-text (main-window text)
|
|
(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)))
|
|
|
|
(defun get-address-bar-text (main-window)
|
|
(trim-blanks (gui:text (iri-entry (tool-bar main-window)))))
|
|
|
|
(defun initialize-keybindings (main-window)
|
|
(gui:bind (gui:root-toplevel)
|
|
(client-configuration:get-keybinding :quit)
|
|
(lambda (e)
|
|
(declare (ignore e))
|
|
(menu:quit)))
|
|
(gui:bind (gui:root-toplevel)
|
|
(client-configuration:get-keybinding :search)
|
|
(lambda (e)
|
|
(declare (ignore e))
|
|
(funcall (menu:show-search-frame-clsr main-window)))
|
|
:exclusive t)
|
|
(gui:bind (gui:root-toplevel)
|
|
(client-configuration:get-keybinding :stream)
|
|
(lambda (e)
|
|
(declare (ignore e))
|
|
(menu:show-streams))
|
|
:exclusive t)
|
|
(gui:bind (gui:root-toplevel)
|
|
(client-configuration:get-keybinding :certificates)
|
|
(lambda (e)
|
|
(declare (ignore e))
|
|
(menu:show-certificates))
|
|
:exclusive t)
|
|
(gui:bind (gui:root-toplevel)
|
|
(client-configuration:config-keybinding-tour-manage)
|
|
(lambda (e)
|
|
(declare (ignore e))
|
|
(menu:show-tour))
|
|
:exclusive t)
|
|
(gui:bind (gui:root-toplevel)
|
|
(client-configuration:get-keybinding :gemlog)
|
|
(lambda (e)
|
|
(declare (ignore e))
|
|
(menu:manage-gemlogs))
|
|
:exclusive t)
|
|
(gui:bind (gui:root-toplevel)
|
|
(client-configuration:get-keybinding :about)
|
|
(lambda (e)
|
|
(declare (ignore e))
|
|
(menu:help-about))
|
|
:exclusive t)
|
|
(gui:bind (gui:root-toplevel)
|
|
(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 (gui:root-toplevel)
|
|
(client-configuration:config-keybinding-tour-shuffle)
|
|
(lambda (e)
|
|
(declare (ignore e))
|
|
(client-tour-window:enqueue-shuffle-tour))
|
|
:exclusive t)
|
|
(gui:bind (gui:root-toplevel)
|
|
(client-configuration:config-keybinding-tour-next)
|
|
(lambda (e)
|
|
(declare (ignore e))
|
|
(funcall (tour-visit-next-iri-clsr main-window)))
|
|
:exclusive t)
|
|
(gui:bind (gui:root-toplevel)
|
|
(client-configuration:get-keybinding :back)
|
|
(lambda (e)
|
|
(declare (ignore e))
|
|
(funcall (back-iri-clsr main-window)))
|
|
:exclusive t)
|
|
(gui:bind (gui:root-toplevel)
|
|
(client-configuration:get-keybinding :up)
|
|
(lambda (e)
|
|
(declare (ignore e))
|
|
(funcall (up-iri-clsr main-window)))
|
|
:exclusive t)
|
|
(gui:bind (gui:root-toplevel)
|
|
(client-configuration:config-keybinding-bookmark-toggle)
|
|
(lambda (e)
|
|
(declare (ignore e))
|
|
(funcall (toggle-bookmark-iri-clsr main-window)))
|
|
:exclusive t)
|
|
(gui:bind (gui:root-toplevel)
|
|
(client-configuration:config-keybinding-bookmark-show)
|
|
(lambda (e)
|
|
(declare (ignore e))
|
|
(funcall (menu:show-bookmarks-clsr main-window)))
|
|
:exclusive t))
|
|
|
|
(defun init-main-window ()
|
|
(setf gui:*debug-tk* nil)
|
|
(gui:with-nodgui (:title +program-name+ :debugger-class 'gui:graphical-condition-handler)
|
|
(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)
|
|
(initialize-keybindings main-frame)
|
|
(gui-goodies:gui-resize-grid-all gui-goodies:*toplevel*))))
|