cage
/
tinmop
mirror of https://codeberg.org/cage/tinmop/
1
0
Fork 0
Code Issues

- [GUI] added a bit of scaffolding for the interface; 

- [GUI/RPC] added  method to start and retrieve a gemini stream's data.
This commit is contained in:
cage 2023-02-05 14:07:13 +01:00
parent 90ae6193e8
commit c0e2b43d3e
12 changed files with 287 additions and 15 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

6
LICENSES.org
View File

@ -544,3 +544,9 @@
shall not be used in advertising or otherwise to promote the sale,
use or other dealings in these Data Files or Software without prior
written authorization of the copyright holder.
- data/icons/search.png
https://commons.wikimedia.org/wiki/File:Farm-Fresh_magnifier.png
FatCow Web Hosting
[CC BY 3.0 us (https://creativecommons.org/licenses/by/3.0/us/deed.en)],
via Wikimedia Commons

BIN
data/icons/search.png Normal file
View File

Binary file not shown.
Side by Side

After

Width:  |  Height:  |  Size: 1.9 KiB

18
src/gui/client/icons.lisp Normal file
View File

@ -0,0 +1,18 @@
(in-package :icons)
(a:define-constant +icon-dir+ "/icons/" :test #'string=)
(a:define-constant +icon-search+ "search" :test #'string=)
(defparameter *icon-search* nil)
(defun load-icon (filename)
(let ((path (if (not (re:scan "(?i)png$" filename))
(res:get-config-file (strcat +icon-dir+ filename ".png"))
(res:get-config-file (strcat +icon-dir+ filename)))))
(with-open-file (stream path :element-type '(unsigned-byte 8))
(let ((data (gui-utils:read-into-array stream (file-length stream))))
(gui:make-image data)))))
(defun load-icons ()
(setf *icon-search* (load-icon +icon-search+)))

59
src/gui/client/json-rpc-communication.lisp
View File

@ -48,9 +48,64 @@
(defun close-server ()
(send-to-server (rpc:encode-to-string (rpc:make-request "quit-program" 1))))
(defgeneric make-request (method id &rest args))
(defmethod make-request ((method symbol) id &rest args)
(apply #'make-request (string-downcase (symbol-name method)) id args))
(defmethod make-request ((method string) id &rest args)
(let ((request (rpc:encode-to-string (apply #'rpc:make-request method id args))))
(send-to-server request)
(let ((raw-response (read-from-server)))
(values (rpc:extract-results raw-response)
raw-response))))
(defun slurp-gemini-stream (iri &key
(use-cache t)
(process-function #'identity)
(aborting-function (constantly nil)))
(make-request :gemini-request 1 iri use-cache)
(flet ((stream-exausted-p ()
(let ((status-completed (make-request :gemini-stream-completed-p 1 iri)))
status-completed)))
(loop with last-lines-fetched-count = 0
while (not (or (funcall aborting-function)
(stream-exausted-p)))
do
(a:when-let* ((last-lines-fetched (make-request :gemini-stream-parsed-line-slice
1
iri
last-lines-fetched-count
nil))
(next-start-fetching (length last-lines-fetched)))
(incf last-lines-fetched-count next-start-fetching)
(funcall process-function last-lines-fetched)))))
(defun start-client ()
(with-output-to-string (stream)
(let* ((test-iri "gemini://")
(let* ((test-iri "gemini://omg.pebcak.club/")
(process (os-utils:run-external-program +program-name+
(list (format nil
"-~a"
command-line:+start-server-command-line+))
:search t
:wait nil
:output :stream
:input :stream
:error :stream)))
(if process
(let ((process-stream (make-two-way-stream (os-utils:process-output process)
(os-utils:process-input process))))
(setf *server-stream* process-stream
*server-process* process)
(slurp-gemini-stream test-iri
:process-function (lambda (lines) (format t "lines ~s~%" lines)))
(close-server))
(error (_ "Unable to create server process"))))))
(defun start-client* ()
(with-output-to-string (stream)
(let* ((test-iri "gemini://omg.pebcak.club/")
(process (os-utils:run-external-program "/home/cage/lisp/tinmop/tinmop" ;+program-name+
(list (format nil
"-~a"
@ -80,6 +135,8 @@
(format t "sending ~a~%" info-request)
(send-to-server info-request)
(format t "returned ~s~%" (read-from-server)))
(let ((status-request (make-request "gemini-stream-completed-p" 1 test-iri)))
(format t "returned ~s~%" status-request))
(let ((line-request (rpc:encode-to-string (rpc:make-request "gemini-stream-parsed-line"
1
test-iri

117
src/gui/client/main-window.lisp Normal file
View File

@ -0,0 +1,117 @@
(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+))))

11
src/gui/client/menu-command.lisp Normal file
View File

@ -0,0 +1,11 @@
(in-package :client-menu-command)
(defun help-about ()
(gui:with-modal-toplevel (toplevel :master nil :title (_ "About"))
(let* ((editor (gui:make-text toplevel)))
(setf (gui:text editor) (format nil +help-about-message+))
(gui:pack editor))))
(defun quit ()
(serv:close-server)
(gui:break-mainloop))

20
src/gui/server/public-api-gemini-stream.lisp
View File

@ -53,12 +53,12 @@
gemini-format-p)))
(gemini-viewer:push-db-stream gemini-stream)
(gemini-viewer::downloading-start-thread gemini-stream
thread-fn
host
port
path
query
fragment))))
thread-fn
host
port
path
query
fragment))))
(cond
((gemini-client:gemini-file-stream-p meta)
(gemini-client:debug-gemini "response is a gemini document stream")
@ -309,6 +309,14 @@
(defun gemini-all-stream-info ()
gw:*gemini-streams-db*)
(defun gemini-stream-status (iri)
(let ((stream (gemini-stream-info iri)))
(gw:stream-status stream)))
(defun gemini-stream-completed-p (iri)
(let ((status (gemini-stream-status iri)))
(eq status :completed)))
(defun build-gemini-toc (iri)
(a:when-let* ((ordered-headers-tag '(:h1 :h2 :h3))
(stream-wrapper (gw:find-db-stream-url iri))

6
src/gui/server/public-api.lisp
View File

@ -57,6 +57,12 @@
"line-number-start" 1
"line-number-end" 2)
(gen-rpc "gemini-all-stream-info" 'gemini-all-stream-info)
(gen-rpc "gemini-stream-status"
'gemini-stream-status
"iri" 0)
(gen-rpc "gemini-stream-completed-p"
'gemini-stream-completed-p
"iri" 0)
(gen-rpc "gemini-current-url" 'gemini-current-url)
(gen-rpc "gemini-pop-url-from-history" 'gemini-pop-url-from-history)
(gen-rpc "gemini-certificates" 'gemini-certificates)

3
src/json-rpc2.lisp
View File

@ -496,3 +496,6 @@
(error (e)
(maybe-log-message (format nil "request parse error: ~a" e))
(make-response nil nil :error-object +error-parse+))))
(defun extract-results (response)
(getf response :result))

9
src/main.lisp
View File

@ -150,7 +150,8 @@ etc.) happened"
(ui:notify (format nil
(_ "Unable to load module ~a")
command-line:*module-file*)
:as-error t))))))
:as-error t)))
(json-rpc-communication:start-server))))
(defun tui-init ()
"Initialize the program"
@ -260,11 +261,11 @@ etc.) happened"
(cond
(command-line:*rpc-server-mode*
(db-utils:with-ready-database (:connect nil)
(rpc-server-init)
(json-rpc-communication:start-server)))
(rpc-server-init)))
(command-line:*rpc-client-mode*
(rpc-client-load-configuration)
(json-rpc-communication:start-client))
(json-rpc-communication:start-client)
(client-main-window:init-main-window))
(command-line:*print-lisp-dependencies*
(misc:all-program-dependencies t))
(command-line:*script-file*

47
src/package.lisp
View File

@ -3168,6 +3168,7 @@
:json-rpc-error
:make-rpc-error
:elaborate-request
:extract-results
:transaction-id
:code
:text))
@ -3203,6 +3204,8 @@
:metadata
:init-gemini-window
:start-server
:close-server
:slurp-gemini-stream
:start-client))
(defpackage :client-configuration
@ -3252,6 +3255,39 @@
:stop-events-loop
:start-events-loop))
(defpackage :icons
(:use :cl
:config
:constants
:misc
:text-utils)
(:local-nicknames (:serv :json-rpc-communication)
(:re :cl-ppcre)
(:a :alexandria)
(:gui :nodgui)
(:gui-utils :nodgui.utils))
(:export
:+icon-dir+
:load-icon
:load-icons))
(defpackage :client-menu-command
(:use
:cl
:config
:constants
:text-utils
:misc-utils)
(:local-nicknames (:serv :json-rpc-communication)
(:re :cl-ppcre)
(:a :alexandria)
(:gui :nodgui)
(:gui-mw :nodgui.mw)
(:gui-shapes :nodgui.shapes))
(:export
:help-about
:quit))
(defpackage :client-main-window
(:use
:cl
@ -3259,9 +3295,14 @@
:constants
:text-utils
:misc-utils)
(:local-nicknames (:re :cl-ppcre)
(:a :alexandria)
(:ev :program-events))
(:local-nicknames (:serv :json-rpc-communication)
(:re :cl-ppcre)
(:a :alexandria)
(:ev :program-events)
(:gui :nodgui)
(:gui-mw :nodgui.mw)
(:gui-shapes :nodgui.shapes)
(:menu :client-menu-command))
(:export
:init-main-window))

6
tinmop.asd
View File

@ -26,6 +26,7 @@
:cl-ppcre-unicode
:tooter
:croatoan
:nodgui
:osicat
:flexi-streams
:cl-spark
@ -158,7 +159,10 @@
:pathname "gui/client"
:components ((:file "client-configuration")
(:file "program-events")
(:file "json-rpc-communication")))
(:file "json-rpc-communication")
(:file "icons")
(:file "menu-command")
(:file "main-window")))
(:file "main")
(:module tests
:components ((:file "package")