mirror of https://codeberg.org/cage/tinmop/
293 lines
11 KiB
Common Lisp
293 lines
11 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 :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) :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 notify-request-error (message)
|
|
(gui-goodies:error-dialog gui-goodies:*toplevel* message))
|
|
|
|
(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 slurp-gemini-stream (iri &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 (enqueue-request-notify-error :gemini-stream-completed-p
|
|
1
|
|
iri)))
|
|
|
|
status-completed))
|
|
(loop-fetch (&optional (last-lines-fetched-count 0))
|
|
(when (not (or (funcall aborting-function)
|
|
(stream-exausted-p)))
|
|
(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 last-lines-fetched))
|
|
(loop-fetch (+ last-lines-fetched-count
|
|
next-start-fetching))))))))
|
|
(loop-fetch)))
|
|
|
|
(defun start-streaming-thread (iri &key
|
|
(use-cache t)
|
|
(process-function #'identity)
|
|
(status :streaming))
|
|
(when (not (find-db-stream-url iri))
|
|
(let ((stream-wrapper (make-instance 'gemini-stream
|
|
:server-stream-handle iri
|
|
:status status)))
|
|
(flet ((aborting-function ()
|
|
(eq (status stream-wrapper) :canceled)))
|
|
(let ((stream-thread (bt:make-thread (lambda ()
|
|
(slurp-gemini-stream iri
|
|
:use-cache use-cache
|
|
:process-function
|
|
process-function
|
|
:aborting-function
|
|
#'aborting-function)))))
|
|
(setf (fetching-thread stream-wrapper) stream-thread)
|
|
(push-db-stream stream-wrapper))))))
|
|
|
|
(defun initialize-menu (parent)
|
|
(with-accessors ((main-window main-window)) parent
|
|
(let* ((bar (gui:make-menubar parent))
|
|
(file (gui:make-menu bar (_ "File") :underline 0))
|
|
(help (gui:make-menu bar (_ "Help") :underline 0)))
|
|
(gui:make-menubutton file (_ "Quit") #'menu:quit :underline 0)
|
|
(gui:make-menubutton help (_ "About") #'menu:help-about :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)))
|
|
|
|
(defun autocomplete-iri-clsr (toolbar)
|
|
(declare (ignore toolbar))
|
|
(lambda (hint)
|
|
(if (> (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)))
|
|
|
|
(defun start-stream-iri-clsr (widget use-cache)
|
|
(lambda ()
|
|
(with-accessors ((iri-entry iri-entry)) widget
|
|
(let ((iri (gui:text iri-entry)))
|
|
(slurp-gemini-stream iri
|
|
:use-cache use-cache
|
|
:process-function (lambda (lines)
|
|
(misc:dbg "lines ~a" lines)))))))
|
|
|
|
(defun setup-main-window-events (main-window)
|
|
(with-accessors ((iri-entry iri-entry)
|
|
(back-button back-button)
|
|
(reload-button reload-button)
|
|
(up-button up-button)
|
|
(go-button go-button)) main-window
|
|
(let ((entry-autocomplete (gui-mw:autocomplete-entry-widget iri-entry)))
|
|
(gui:bind entry-autocomplete
|
|
#$<KeyPress-Return>$
|
|
(lambda (e)
|
|
(declare (ignore e))
|
|
(funcall (start-stream-iri-clsr main-window t)))
|
|
:append nil))
|
|
(setf (gui:command go-button) (start-stream-iri-clsr main-window t))))
|
|
|
|
(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)) 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*))
|
|
(gui-goodies:attach-tooltips (back-button (_ "go back"))
|
|
(reload-button (_ "reload address"))
|
|
(go-button (_ "go to address"))
|
|
(up-button (_ "one level up")))
|
|
(gui:grid back-button 0 1 :sticky :nsw)
|
|
(gui:grid iri-entry 0 2 :sticky :we :padx +minimum-padding+)
|
|
(gui:grid go-button 0 3 :sticky :e)
|
|
(gui:grid reload-button 0 4 :sticky :e)
|
|
(gui:grid up-button 0 5 :sticky :e)
|
|
(gui:grid-columnconfigure object 2 :weight 2)
|
|
(setup-main-window-events object)
|
|
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)))
|
|
|
|
(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
|
|
:master object
|
|
:name nil))
|
|
(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)
|
|
((main-window
|
|
:initform nil
|
|
:initarg :main-window
|
|
:accessor main-window)
|
|
(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)))
|
|
|
|
(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)) object
|
|
(setf tool-bar (make-instance 'tool-bar :master object))
|
|
(setf toc-frame (make-instance 'toc-frame :master object))
|
|
(gui:grid tool-bar 0 0 :sticky :new)
|
|
(gui:grid toc-frame 1 0 :sticky :nsw)
|
|
(gui:grid-columnconfigure object :all :weight 1)
|
|
(gui:grid-rowconfigure object 1 :weight 1)
|
|
object))
|
|
|
|
(defun init-main-window ()
|
|
(gui:with-nodgui (:title +program-name+)
|
|
(icons:load-icons)
|
|
(initialize-menu gui:*tk*)
|
|
(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)))
|
|
(gui:grid main-frame 0 0 :sticky :nswe)
|
|
(gui-goodies:gui-resize-grid-all gui:*tk*))))
|