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

- [GUI/RPC] added  method to start and retrieve a gemini stream's data.

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

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+)))

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

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+))))

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))

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
+                                                          thread-fn
-                                               host
+                                                          host
-                                               port
+                                                          port
-                                               path
+                                                          path
-                                               query
+                                                          query
-                                               fragment))))
+                                                          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))

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)

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))

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)
+         (rpc-server-init)))
-         (json-rpc-communication:start-server)))
       (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*

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)
+  (:local-nicknames (:serv       :json-rpc-communication)
-                    (:a  :alexandria)
+                    (:re         :cl-ppcre)
-                    (:ev :program-events))
+                    (:a          :alexandria)
+                    (:ev         :program-events)
+                    (:gui        :nodgui)
+                    (:gui-mw     :nodgui.mw)
+                    (:gui-shapes :nodgui.shapes)
+                    (:menu       :client-menu-command))
   (:export
    :init-main-window))
 

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")