From c0e2b43d3e0329081fb9fe493dfd9f9cee963606 Mon Sep 17 00:00:00 2001
From: cage <cage@invalid>
Date: Sun, 5 Feb 2023 14:07:13 +0100
Subject: [PATCH] - [GUI] added a bit of scaffolding for the interface;

- [GUI/RPC] added  method to start and retrieve a gemini stream's data.
---
 LICENSES.org                                 |   6 +
 data/icons/search.png                        | Bin 0 -> 1912 bytes
 src/gui/client/icons.lisp                    |  18 +++
 src/gui/client/json-rpc-communication.lisp   |  59 +++++++++-
 src/gui/client/main-window.lisp              | 117 +++++++++++++++++++
 src/gui/client/menu-command.lisp             |  11 ++
 src/gui/server/public-api-gemini-stream.lisp |  20 +++-
 src/gui/server/public-api.lisp               |   6 +
 src/json-rpc2.lisp                           |   3 +
 src/main.lisp                                |   9 +-
 src/package.lisp                             |  47 +++++++-
 tinmop.asd                                   |   6 +-
 12 files changed, 287 insertions(+), 15 deletions(-)
 create mode 100644 data/icons/search.png
 create mode 100644 src/gui/client/icons.lisp
 create mode 100644 src/gui/client/main-window.lisp
 create mode 100644 src/gui/client/menu-command.lisp

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 0000000000000000000000000000000000000000..9cbc3618f5ad94df90ca1cc1d726a76c87687874
GIT binary patch
literal 1912
zcmV-;2Z#8HP)<h;3K|Lk000e1NJLTq001BW001Be1^@s6b9#F80000PbVXQnQ*UN;
zcVTj606}DLVr3vnZDD6+Qe|Oed2z{QJOBU(8c9S!RCwCNmwRj!^%lp!Gdr`h-FCOn
zrC{GnORZukmZ#|pG>RhC_%=of2~iV`G2#OyRH72DiQe4g{&Ce1iA4X<L{mU2T0(6p
zP##f0FoN1GAXK{DZg;n{JG(m%&u@0NDFo>nF?W*F$L##h`JC_X{LY!>48y?x^Wv`d
z+4}Yk3+<BQC62?L1e#?`TEuZ&jDB{?a^&Sr8{hKLE#sO2Jh5_BUd^o9y}7xr*-ed&
zsP<MN$K|@@nej*jzYO@Wx33SOP~^nVr%yF){b<YB-v!{-t#4m$7o{C-E0&|aeojVC
zjvhUR?K^fNk&Lg{_~sis|B4!u0l2lVu4~K7%kOylsny8M%{6cCIX;MvgTLV5&qLt3
z)Z;qU&BB@)xOYJ{md>d(?}b7ky!ZZQjEx2F{nw_A+cSlj0Jv-U-9^nUt^OxhuR?x)
z0m9=kJiB=h&W1JQ7nQ)BTLeMmV6$-q!b1*?;Ns9Z%y4q}@9L#+=VT!m9K{Elx1hJ@
zTTkcCFGn%~5Uk%~!@T)DOIn-F;A0UP5B~crIP%KSx}Y3OYFwx)ln{z*7*FV?4F;V!
zQ!yQ92G8MvcXr~lHFuh8nGac(dkCPO{3fRYurU=LeeCf%uh;wf1NYy@1jaKT_90;}
z!gI@R#636VL8PolV=BUmhDd@Sk~+ZCLY{}1;|3?#(RJuF+7?uzq@)zzA3f$NEb@GI
z;)mn@sQ`GULU~2Srp1dEQfv*okDbK@nZwOB<(OOQ#E6{4sG^!dqnd#j#a2u+pinK?
z?Hnq+r5H6tbR9iw`e448&q)ej6~H0bY`0aEmC<4qT|fHa%JraimK#BqHD#=*6pVt$
zsjL#rs2Jm9y1)|vnaHEkTZXQal(43P`C>kq?@RzBs%poy;$ni=aB^6IBP$zK1#Hh%
zL@9WTg0rmSlY+;o5VIs30oWiCK=JefS{oxDDokJGllji12zf)-q0vJ60ZDS0l^&*o
zlM|`nEU+0IDS#xM9fyNY9ZA{>UDKgz9KkrC(H1ZW=F>`W>QlhxfzB4tVo|h{e4JTq
zvZ|Yzr)5uPFG)Ojo7EEtP*pjW2CWrM6?INWrZZ-uNZ1067TYKb>hqMnj+mN~J{6eG
z6y+n4+#<;?2q}Q1s$1<u2X88%GiMpMVpAff@P!LQwAeu1v@EcO=L;rGfEWdcnr6Vp
zb7tl&xFiX%lZiG`gZ>{2#c@M%mg$4}Vm>nk(4*tyeZDh;AT_b5R0L-e2tdK`coG4U
zAWVC}Up6%iOEpHz6dMjCu(-@l0KmZDAms7LK2w$q01~H8{j{aO{}2q$h6ay;>28Vk
z-v+;|(h<~2U?Wv*X2BUqQcp-wZ%9y~YV`T<7Ztb&VxEU0(&^Z@?*P8-?tU8?sK5Y}
zu5Z5HAMghT4jwuT)!^}XO`Igoh6<7DLN}{iqrfZ}3!bF<h$l6gej0{`RRpN(udGed
z^E~z+=%+2R=_gP8aGLqfq!pVo4fuXNP~<6IRpp(D{2T{nyA=51E{v-V%AdA?*R1hn
znEHpK9DX0>A<$`ASvdx`#9?S8fX~0^KwH}i?#9{m&wstE^DSDTO$ER%Eh@{&Y-je6
z-ygW$J98%T2x6`)3>QtnsP4pY+>K}=3z3)uLD`OcL&XAj7<Wty(#a6021c=U>nCWK
zdoymmbt$r(E>zbwtlzzB`=+Zwq>mw+T7g}=Iy<P5@QM<Dd&!a(%x{>Bx|}HLoMFmZ
zpETmBDrm1cUVtG;IDF(gba(gQ`s-_{jk_R6W2mmFg$IYx^zP#LEo%<2j+mJ8g@i1d
zY<fXKVf7=AKK8%D!h*_q4GkzQD}l%3nP@Jo>ivE{emi#_M~)nU5>M!*Wu-iOi4m!j
z@`4k~TIL|n{u^*=E&BEXO)qp`5rVtI|Ez}>lFgVktG2eWspTn`%Qc_%^~nIN!XuH$
z;qE=V-}CtfMqgRGuCu(V3WAi2o227dZ2uT&`4rSF2;v2T(60#bXK%%#r3QO1D<E@O
z+r>?412jAkAq!fyblr<<H}p1^2his107nB2G%eAxl_11Fh2W-mT@x%tq$>;--8$!r
z_3SjVs%>xF)?4d7kBU5<rmB$g(DIQ5vBrdmDB3M|z1Gvu61m#6GOXfcS+e)L;md5q
z`YdT>#P0d-Y2V#^JY0?8u!2}jOX<|JlAfSH>i&bqRtbe}`~LK(=5g(=35bW<cQp5p
z)x#f-T?&z;oMeSfeResoHNYhh54Ue4h&k|$2~g-=((DAi1Yu;exjE4St~J1A5Zjwi
zhQ08IqDU%qTP2HLq*KIa^xg39UiNfhe!5{rufdt^i!#>n;Om`>=suej!G989GDHbk
yPWo#l*?CK)#6Jy?hRC*hOS<jL>0a=M00RJDa7Sg}Qvxjj0000<MNUMnLSTaFqpvyu

literal 0
HcmV?d00001

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