cage/tinmop
1
0
Fork 0
mirror of https://codeberg.org/cage/tinmop/ synced 2025-02-17 08:10:36 +01:00
Code Issues

- [GUI] started connecting JSON API with GUI;

Browse Source 
- [RPC] reworked 'slurp-gemini-stream' to use events queue;

- [GUI] fixed dispatching of events
This commit is contained in:
cage 2023-02-09 16:28:53 +01:00
parent abef1cfe33
commit 282b36d712
10 changed files with 148 additions and 74 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

1
src/gemini-viewer.lisp
View File

@ -456,6 +456,7 @@
for line-as-array = (with-print-error-message
(read-line-into-array download-stream))
while line-as-array do
(sleep 3)
(gemini-client:debug-gemini "[stream] gemini file stream raw data line : ~a"
line-as-array)
(if (downloading-allowed-p wrapper-object)

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

@ -45,62 +45,70 @@
(write-byte (logand object #xff) *server-stream*)
(finish-output *server-stream*))
(defun close-server ()
(send-to-server (rpc:encode-to-string (rpc:make-request "quit-program" 1))))
(defparameter *request-lock* (bt:make-lock))
(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))
(misc:with-lock (*request-lock*)
(apply #'make-request (string-downcase (symbol-name method)) id args)))
(define-condition rpc-error-response (conditions:text-error)
((data
:initform nil
:initarg :data
:reader data)
(code
:initform nil
:initarg :code
:reader code)
(id
:initform nil
:initarg :id
:reader id))
(:report (lambda (condition stream)
(format stream
"id: ~a (~a) ~a data ~a"
(id condition)
(code condition)
(conditions:text condition)
(data condition))))
(:documentation "Error failed rpc request"))
(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))))
(if (rpc:error-response-p raw-response)
(multiple-value-bind (id message code data)
(rpc:extract-error raw-response)
(error 'rpc-error-response
:id id
:code code
:data data
:text message))
(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 close-server ()
(make-request :quit-program 1))
(defun start-client ()
(with-output-to-string (stream)
(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)))
(let ((process (os-utils:run-external-program "/home/cage/lisp/tinmop/tinmop" ;+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))
*server-process* process))
(error (_ "Unable to create server process"))))))
(defun start-client* ()

56
src/gui/client/main-window.lisp
View File

@ -62,6 +62,47 @@
(defun find-db-stream-url (url)
(find-db-stream-if (lambda (a) (string= (server-stream-handle a) url))))
(defmacro with-enqueue-request ((method-name id &rest args) &body on-error)
`(ev:with-enqueued-process-and-unblock ()
(handler-case
(comm:make-request ,method-name ,id ,@args)
(error (the-error) ; anaphora
(declare (ignorable the-error))
,@on-error))))
(defun notify-request-error (e)
(misc:dbg "got error ~a" e))
(defun slurp-gemini-stream (iri &key
(use-cache t)
(process-function #'identity)
(aborting-function (constantly nil)))
(with-enqueue-request (:gemini-request 1 iri use-cache)
(notify-request-error the-error))
(labels ((stream-exausted-p ()
(let ((status-completed (with-enqueue-request (:gemini-stream-completed-p 1 iri)
(notify-request-error the-error))))
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 ()
(handler-case
(progn
(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))))
(error (e)
(notify-request-error e)))))))
(loop-fetch)))
(defun start-streaming-thread (iri &key
(use-cache t)
(process-function #'identity)
@ -73,12 +114,12 @@
(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)))))
(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))))))
@ -205,3 +246,6 @@
(let ((main-frame (make-instance 'main-frame)))
(gui:grid main-frame 0 0 :sticky :nswe)
(gui-goodies:gui-resize-grid-all gui:*tk*)))))
;; (let ((test-iri "gemini://omg.pebcak.club/"))
;; (slurp-gemini-stream test-iri
;; :process-function (lambda (lines) (misc:dbg "lines ~a" lines))))))))

3
src/gui/client/menu-command.lisp
View File

@ -7,5 +7,6 @@
(gui:pack editor))))
(defun quit ()
;;(serv:close-server)
(comm:close-server)
(client-events:stop-events-loop)
(gui:break-mainloop))

6
src/gui/server/json-rpc-communication.lisp
View File

@ -49,9 +49,6 @@
(write-byte +command-delimiter+ *server-output-stream*)
(finish-output *server-output-stream*))
(defun quit-server ()
(os-utils:exit-program))
(defun start-server ()
(init-gemini-window)
(prepare-rpc
@ -71,5 +68,4 @@
(error (e)
(send-to-client (format nil (_ "Error: ~a~%") e))
(setf *stop-server* t))))
(send-to-client "Bye!")
(quit-server)))
(send-to-client "Bye!")))

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

@ -29,7 +29,7 @@
(fs:clean-temporary-directories)
(fs:clean-temporary-files)
(db-utils:close-db)
(os-utils:exit-program))
(setf *stop-server* t))
(defmacro prepare-rpc (&body body)
`(let ((rpc:*function-db* '()))

20
src/json-rpc2.lisp
View File

@ -497,5 +497,23 @@
(maybe-log-message (format nil "request parse error: ~a" e))
(make-response nil nil :error-object +error-parse+))))
(defgeneric make-json-extract-key (object))
(defmethod make-json-extract-key ((object string))
(make-json-extract-key (make-keyword (string-upcase object))))
(defmethod make-json-extract-key ((object symbol))
object)
(defun extract-results (response)
(getf response :result))
(getf response (make-json-extract-key +key-result+)))
(defun error-response-p (response)
(getf response (make-json-extract-key +key-error+)))
(defun extract-error (response)
(let ((error-field (getf response (make-json-extract-key +key-error+))))
(values (getf error-field (make-json-extract-key +key-id+))
(getf error-field (make-json-extract-key +key-error-message+))
(getf error-field (make-json-extract-key +key-error-code+))
(getf error-field (make-json-extract-key +key-error-data+)))))

11
src/main.lisp
View File

@ -147,11 +147,9 @@ etc.) happened"
(handler-case
(modules:load-module command-line:*module-file*)
(error ()
(ui:notify (format nil
(_ "Unable to load module ~a")
command-line:*module-file*)
:as-error t)))
(json-rpc-communication:start-server))))
(format *error-output* (_ "Unable to load module ~a")
command-line:*module-file*))))
(json-rpc-communication:start-server)))
(defun tui-init ()
"Initialize the program"
@ -264,7 +262,8 @@ etc.) happened"
(rpc-server-init)))
(command-line:*rpc-client-mode*
(rpc-client-load-configuration)
(json-rpc-communication:start-client)
(client-events:start-events-loop)
(json-rpc-communication::start-client)
(client-main-window:init-main-window))
(command-line:*print-lisp-dependencies*
(misc:all-program-dependencies t))

15
src/package.lisp
View File

@ -1605,6 +1605,7 @@
:find-event
:function-event
:with-enqueued-process
:with-enqueued-process-and-unblock
:event-on-own-thread
:blocking-caller-event
:push-function-and-wait-results
@ -3172,6 +3173,8 @@
:make-rpc-error
:elaborate-request
:extract-results
:error-response-p
:extract-error
:transaction-id
:code
:text))
@ -3208,7 +3211,7 @@
:init-gemini-window
:start-server
:close-server
:slurp-gemini-stream
:make-request
:start-client))
(defpackage :client-configuration
@ -3264,7 +3267,7 @@
:constants
:misc
:text-utils)
(:local-nicknames (:serv :json-rpc-communication)
(:local-nicknames (:comm :json-rpc-communication)
(:re :cl-ppcre)
(:a :alexandria)
(:gui :nodgui)
@ -3283,7 +3286,7 @@
:cl
:config
:constants)
(:local-nicknames (:serv :json-rpc-communication)
(:local-nicknames (:comm :json-rpc-communication)
(:re :cl-ppcre)
(:a :alexandria)
(:gui :nodgui)
@ -3299,7 +3302,7 @@
:constants
:misc
:text-utils)
(:local-nicknames (:serv :json-rpc-communication)
(:local-nicknames (:comm :json-rpc-communication)
(:re :cl-ppcre)
(:a :alexandria)
(:gui :nodgui)
@ -3327,7 +3330,7 @@
:gui-goodies
:text-utils
:misc-utils)
(:local-nicknames (:serv :json-rpc-communication)
(:local-nicknames (:comm :json-rpc-communication)
(:re :cl-ppcre)
(:a :alexandria)
(:gui :nodgui)
@ -3344,7 +3347,7 @@
:constants
:text-utils
:misc-utils)
(:local-nicknames (:serv :json-rpc-communication)
(:local-nicknames (:comm :json-rpc-communication)
(:re :cl-ppcre)
(:a :alexandria)
(:ev :program-events)

22
src/program-events.lisp
View File

@ -215,6 +215,11 @@
:payload (lambda () ,@body)
:priority ,priority)))
(defmacro with-enqueued-process-and-unblock ((&optional (priority +standard-event-priority+)) &body body)
`(push-event-unblock (make-instance 'function-event
:payload (lambda () ,@body)
:priority ,priority)))
(defclass event-on-own-thread (program-event)
((lock
:initform (bt:make-recursive-lock)
@ -1813,13 +1818,12 @@
(process-event bypassable-event)))))
(defun dispatch-program-events-or-wait ()
(when (event-available-p)
(let ((bypassable-event (pop-event-block)))
(if (and (= (priority bypassable-event)
+minimum-event-priority+)
(event-available-p))
(let ((event (pop-event-block)))
(reinitialize-id bypassable-event)
(let ((bypassable-event (pop-event-block)))
(if (and (= (priority bypassable-event)
+minimum-event-priority+)
(event-available-p))
(let ((event (pop-event-block)))
(reinitialize-id bypassable-event)
(push-event-unblock bypassable-event)
(process-event event))
(process-event bypassable-event)))))
(process-event event))
(process-event bypassable-event))))