(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 #$$ (lambda (e) (declare (ignore e)) (gui:focus toc-frame) (funcall (open-iri-clsr main-window t))) :append nil) (gui:bind toc-listbox #$<>$ (toc-callback-clsr main-window)) (gui:bind gemtext-widget #$$ (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 #$$ (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*))))