diff --git a/LICENSES.org b/LICENSES.org index 9610df5..08ec531 100644 --- a/LICENSES.org +++ b/LICENSES.org @@ -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 diff --git a/data/icons/search.png b/data/icons/search.png new file mode 100644 index 0000000..9cbc361 Binary files /dev/null and b/data/icons/search.png differ diff --git a/src/gui/client/icons.lisp b/src/gui/client/icons.lisp new file mode 100644 index 0000000..04d5621 --- /dev/null +++ b/src/gui/client/icons.lisp @@ -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+))) diff --git a/src/gui/client/json-rpc-communication.lisp b/src/gui/client/json-rpc-communication.lisp index 36f55fe..4c5cada 100644 --- a/src/gui/client/json-rpc-communication.lisp +++ b/src/gui/client/json-rpc-communication.lisp @@ -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 diff --git a/src/gui/client/main-window.lisp b/src/gui/client/main-window.lisp new file mode 100644 index 0000000..0d02f2d --- /dev/null +++ b/src/gui/client/main-window.lisp @@ -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+)))) diff --git a/src/gui/client/menu-command.lisp b/src/gui/client/menu-command.lisp new file mode 100644 index 0000000..782b08b --- /dev/null +++ b/src/gui/client/menu-command.lisp @@ -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)) diff --git a/src/gui/server/public-api-gemini-stream.lisp b/src/gui/server/public-api-gemini-stream.lisp index 217c20d..755a5ab 100644 --- a/src/gui/server/public-api-gemini-stream.lisp +++ b/src/gui/server/public-api-gemini-stream.lisp @@ -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)) diff --git a/src/gui/server/public-api.lisp b/src/gui/server/public-api.lisp index 4c3fcda..557fd62 100644 --- a/src/gui/server/public-api.lisp +++ b/src/gui/server/public-api.lisp @@ -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) diff --git a/src/json-rpc2.lisp b/src/json-rpc2.lisp index 522e5fb..9510b96 100644 --- a/src/json-rpc2.lisp +++ b/src/json-rpc2.lisp @@ -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)) diff --git a/src/main.lisp b/src/main.lisp index f07e9fb..50f89a9 100644 --- a/src/main.lisp +++ b/src/main.lisp @@ -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* diff --git a/src/package.lisp b/src/package.lisp index d29addf..f7fe268 100644 --- a/src/package.lisp +++ b/src/package.lisp @@ -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)) diff --git a/tinmop.asd b/tinmop.asd index bcbc2fc..9189e75 100644 --- a/tinmop.asd +++ b/tinmop.asd @@ -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")