(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))))) (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") :underline 0)) (tools (gui:make-menu bar (_ "Tools") :underline 0)) (tour (gui:make-menu bar (_ "Tour") :underline 1)) (bookmarks (gui:make-menu bar (_ "Bookmarks") :underline 0)) (gemlogs (gui:make-menu bar (_ "Gemlogs") :underline 0)) (help (gui:make-menu bar (_ "Help") :underline 0))) (gui:make-menubutton tools (_ "Certificates") #'menu:show-certificates :underline 0) (gui:make-menubutton tools (_ "Streams") #'menu:show-streams :underline 0) (gui:make-menubutton tools (_ "Search") (menu:show-search-frame-clsr main-window) :underline 1) (gui:make-menubutton file (_ "Quit") #'menu:quit :underline 0) (gui:make-menubutton help (_ "About") #'menu:help-about :underline 0) (gui:make-menubutton bookmarks (_ "Show") (menu:show-bookmarks-clsr main-window) :underline 0) (gui:make-menubutton bookmarks (_ "Manage") (menu:manage-bookmarks-clsr main-window) :underline 0) (gui:make-menubutton tour (_ "Manage") #'menu:show-tour :underline 0) (gui:make-menubutton tour (_ "Shuffle") (lambda () (client-tour-window:enqueue-shuffle-tour)) :underline 0) (gui:make-menubutton gemlogs (_ "Show") #'menu:manage-gemlogs :underline 0))) (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))) (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 () (setf (gui:text iri-entry) link-value) (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 contextual-menu-link-clrs (link-name link-value main-window) (flet ((add-to-tour-callback () (ev:with-enqueued-process-and-unblock () (comm:make-request :tour-add-link 1 link-value link-name))) (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))))) (lambda () (let* ((popup-menu (gui:make-menu nil (_"link menu")))) (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 (gui:screen-mouse-x) (gui:screen-mouse-y)))))) (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 (gui:make-indices-end) 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) :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)) (: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)) (: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 open-iri (iri main-window use-cache &key (status +stream-status-streaming+)) (handler-case (let ((parsed-iri (iri:iri-parse iri))) (cond ((gemini-parser:gemini-iri-p iri) (start-stream-iri iri main-window use-cache status)) ((or (null (uri:scheme parsed-iri)) (string= (uri:scheme parsed-iri) constants:+file-scheme+)) (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) (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))) (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 wait-for-download (maybe-open-if-completed 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)))) (maybe-open-if-completed 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 meta :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) (cond ((eq status +stream-status-streaming+) (cond ((gemini-client:gemini-file-stream-p meta) (maybe-stop-steaming-stream-thread) (clean-gemtext 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 (trim-blanks (gui:text iri-entry)))) (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 (gui:text iri-entry) 1 ev:+standard-event-priority+))) (when (string-not-empty-p to-parent-iri) (setf (gui:text iri-entry) 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) (setf (gui:text iri-entry) 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 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 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)) tool-bar (let ((entry-autocomplete (gui-mw:autocomplete-entry-widget iri-entry)) (toc-listbox (gui:listbox (toc-listbox toc-frame)))) (gui:bind entry-autocomplete #$$ (lambda (e) (declare (ignore e)) (funcall (open-iri-clsr main-window t))) :append nil) (gui:bind toc-listbox #$<>$ (toc-callback-clsr main-window)) (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) (bookmark-iri-clsr main-window)) (setf (gui:command tour-button) (tour-visit-next-iri-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)) 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*)) (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"))) (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 tour-button 0 6 :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 #$$ (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))) (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)) (setf gemtext-widget (make-instance 'gui:scrolled-text :master object :read-only t :font (gui-conf:gemini-text-font-configuration))) (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) (setf (gui:text (iri-entry (tool-bar main-window))) text)) (defun init-main-window () (let ((gui:*debug-tk* nil)) (gui:with-nodgui (:title +program-name+) (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) (gui-goodies:gui-resize-grid-all gui-goodies:*toplevel*)))))