mirror of https://codeberg.org/cage/tinmop/
118 lines
3.9 KiB
Common Lisp
118 lines
3.9 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")))
|
|
(help (gui:make-menu bar (_ "Help"))))
|
|
(gui:make-menubutton file (_ "Quit") #'menu:quit :underline 0)
|
|
(gui:make-menubutton help (_ "About") #'menu:help-about :underline 0))))
|
|
|
|
(defclass main-frame (frame)
|
|
((main-window
|
|
:initform nil
|
|
:initarg :main-window
|
|
:accessor main-window)
|
|
(tool-bar
|
|
:initform nil
|
|
:initarg :tool-bar
|
|
:accessor tool-bar)
|
|
(toc-pane
|
|
:initform nil
|
|
:initarg :toc-pane
|
|
:accessor toc-pane)
|
|
(info-pane
|
|
:initform nil
|
|
:initarg :info-pane
|
|
:accessor info-pane)))
|
|
|
|
(defmethod initialize-instance :after ((object main-frame) &key &allow-other-keys))
|
|
|
|
;; (nodgui-utils:gui-resize-grid-all object))))
|
|
|
|
(defun init-main-window ()
|
|
(let ((gui:*debug-tk* nil))
|
|
(gui:with-nodgui (:title +program-name+))))
|