mirror of https://codeberg.org/cage/tinmop/
208 lines
7.2 KiB
Common Lisp
208 lines
7.2 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 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 ()
|
|
(serv: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))
|
|
(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)
|
|
(go-button
|
|
:initform nil
|
|
:initarg :go-button
|
|
:accessor go-button)))
|
|
|
|
(defun autocomplete-iri-clsr (toolbar)
|
|
(declare (ignore toolbar))
|
|
(lambda (hint)
|
|
hint))
|
|
|
|
(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)
|
|
(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*))
|
|
(gui-goodies:attach-tooltips (back-button (_ "go back"))
|
|
(go-button (_ "go to address"))
|
|
(reload-button (_ "reload address")))
|
|
(gui:grid back-button 0 1 :sticky :nsw :padx +minimum-padding+)
|
|
(gui:grid iri-entry 0 2 :sticky :we :padx +minimum-padding+)
|
|
(gui:grid go-button 0 3 :sticky :e :padx +minimum-padding+)
|
|
(gui:grid reload-button 0 4 :sticky :e)
|
|
(gui:grid-columnconfigure object 2 :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)))
|
|
|
|
(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 ()
|
|
(let ((gui:*debug-tk* nil))
|
|
(gui:with-nodgui (:title +program-name+)
|
|
(icons:load-icons)
|
|
(initialize-menu gui:*tk*)
|
|
(let ((main-frame (make-instance 'main-frame)))
|
|
(gui:grid main-frame 0 0 :sticky :nswe)
|
|
(gui-goodies:gui-resize-grid-all gui:*tk*)))))
|