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

- [RPC] added API for generate the TOC from a gemtext; 

- removed duplicated code (used the class 'box:box' instead of struct 'json-rpc-communication:box).
This commit is contained in:
cage 2023-01-15 15:54:49 +01:00
parent 3824e29171
commit 045819b4a4
8 changed files with 133 additions and 61 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

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

@ -130,14 +130,6 @@
(format t "sending ~a~%" request)
(send-to-server request)
(format t "returned ~s~%" (read-from-server))))
(loop repeat 2 do
(let ((request (rpc:encode-to-string (rpc:make-request "gemini-request"
1
(strcat test-iri "/~cage/")
t))))
(format t "sending ~a~%" request)
(send-to-server request)
(format t "returned ~s~%" (read-from-server))))
(sleep 3)
(let ((info-request (rpc:encode-to-string (rpc:make-request "gemini-stream-info"
1
@ -176,5 +168,10 @@
(format t "sending ~a~%" certificates)
(send-to-server certificates)
(format t "returned ~s~%" (read-from-server)))
(let ((toc (rpc:encode-to-string
(rpc:make-request "gemini-toc" 1 test-iri))))
(format t "sending ~a~%" toc)
(send-to-server toc)
(format t "returned ~s~%" (read-from-server)))
(close-server))
(error (_ "Unable to create server process"))))))

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

@ -17,7 +17,7 @@
(in-package :json-rpc-communication)
(defstruct (gemini-certificates (:include box)))
(defclass gemini-certificates (box) ())
(defmethod yason:encode ((object gemini-certificates) &optional (stream *standard-output*))
(let ((json:*symbol-encoder* #'json:encode-symbol-as-lowercase)
@ -25,11 +25,11 @@
(json:*symbol-key-encoder* #'json:encode-symbol-as-lowercase))
(yason:with-output (stream)
(yason:with-array ()
(loop for certificate in (gemini-certificates-payload object) do
(loop for certificate in (unbox object) do
(yason:encode-array-element certificate))))))
(defun gemini-certificates ()
(make-gemini-certificates :payload (db:find-tls-certificates-rows)))
(make-instance 'gemini-certificates :contents (db:find-tls-certificates-rows)))
(defun invalidate-cached-value (cache-key)
(db:cache-invalidate cache-key)

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

@ -262,7 +262,7 @@
line-number)))))
(first res))))))))
(defstruct (parsed-lines-slice (:include box)))
(defclass parsed-lines-slice (box) ())
(defmethod yason:encode ((object parsed-lines-slice) &optional (stream *standard-output*))
(let ((json:*symbol-encoder* #'json:encode-symbol-as-lowercase)
@ -270,7 +270,7 @@
(json:*symbol-key-encoder* #'json:encode-symbol-as-lowercase))
(yason:with-output (stream)
(json:with-array ()
(loop for parsed-line in (parsed-lines-slice-payload object) do
(loop for parsed-line in (unbox object) do
(json:encode-array-element parsed-line))))))
(defun gemini-stream-parsed-line-slice (iri line-number-start line-number-end)
@ -298,7 +298,7 @@
(let ((res (rearrange-parsed-line-for-encoding (subseq parsed-lines
line-number-start
line-number-end))))
(make-parsed-lines-slice :payload res))))))))
(make-instance 'parsed-lines-slice :contents res))))))))
(defun gemini-stream-info (iri)
(let ((stream-wrapper (gw:find-db-stream-url iri)))
@ -308,3 +308,79 @@
(defun gemini-all-stream-info ()
gw:*gemini-streams-db*)
(defun build-gemini-toc (iri)
(a:when-let* ((ordered-headers-tag '(:h1 :h2 :h3))
(stream-wrapper (gw:find-db-stream-url iri))
(parsed-lines (gw:parsed-lines stream-wrapper))
(headers (remove-if-not (lambda (a) (member (html-utils:tag a)
ordered-headers-tag))
parsed-lines)))
(flet ((extract-level (header)
(let ((tag (html-utils:tag header)))
(1+ (position tag ordered-headers-tag))))
(extract-gid (header)
(let ((attribute (html-utils:find-attribute :header-group-id header)))
(html-utils:attribute-value attribute)))
(extract-header-text (header)
(first (html-utils:children header)))
(find-longest-string (text-list)
(reduce (lambda (a b)
(if (>= (length a) (length b))
a
b))
text-list)))
(a:when-let* ((toc (message-window:gemini-sexp->toc-plist headers
#'identity
#'extract-level
#'extract-gid
#'extract-header-text))
(toc-text (mapcar (lambda (a) (getf a :header)) toc))
(longest-text (find-longest-string toc-text))
(max-text-length (length longest-text))
(toc-numbers (mapcar (lambda (a)
(let ((numbers-as-text
(mapcar (lambda (a)
(format nil "~a" a))
(getf a :number))))
(join-with-strings numbers-as-text ".")))
toc))
(longest-number (find-longest-string toc-numbers))
(max-number-length (length longest-number))
(max-non-padded-text-size (+ max-text-length max-number-length))
(toc-entries-text (loop for text in toc-text
for number in toc-numbers
collect
(let* ((text-length (+ (length text)
(length number)))
(padding-size (- max-non-padded-text-size
text-length))
(padding (make-string padding-size
:initial-element (swconf:gemini-toc-padding-char))))
(strcat number
padding
text)))))
(values
(loop for toc-entry in toc
for text in toc-entries-text
collect
(list :header-group-id (getf toc-entry :group-id)
:text text))
toc)))))
(defclass gemini-toc (box) ())
(defun encode-flat-array-of-plists (list stream)
(let ((json:*symbol-encoder* #'json:encode-symbol-as-lowercase)
(yason:*list-encoder* #'yason:encode-plist)
(json:*symbol-key-encoder* #'json:encode-symbol-as-lowercase))
(yason:with-output (stream)
(json:with-array ()
(loop for element in list do
(json:encode-array-element element))))))
(defun gemini-table-of-contents (iri)
(make-instance 'gemini-toc :contents (build-gemini-toc iri)))
(defmethod yason:encode ((object gemini-toc) &optional (stream *standard-output*))
(encode-flat-array-of-plists (unbox object) stream))

21
src/gui/server/public-api-structs.lisp
View File

@ -1,21 +0,0 @@
;; tinmop: an humble gemini and pleroma client
;; Copyright (C) 2022 cage
;; This program is free software: you can redistribute it and/or modify
;; it under the terms of the GNU General Public License as published by
;; the Free Software Foundation, either version 3 of the License, or
;; (at your option) any later version.
;; This program is distributed in the hope that it will be useful,
;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
;; GNU General Public License for more details.
;; You should have received a copy of the GNU General Public License
;; along with this program.
;; If not, see [[http://www.gnu.org/licenses/][http://www.gnu.org/licenses/]].
(in-package :json-rpc-communication)
(defstruct box
(payload))

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

@ -17,9 +17,6 @@
(in-package :json-rpc-communication)
(defstruct box
(payload))
(defun make-rpc-parameters (&rest params)
(loop for (a b) on params by 'cddr collect (cons a b)))
@ -66,6 +63,9 @@
(gen-rpc "gemini-delete-certificate"
'gemini-delete-certificate
"cache-key" 0)
(gen-rpc "gemini-toc"
'gemini-table-of-contents
"iri" 0)
(gen-rpc "tour-shuffle" 'tour-shuffle)
(gen-rpc "tour-add-link"
'tour-add-link

63
src/message-window.lisp
View File

@ -66,7 +66,7 @@
(defgeneric viewport-width (object))
(defgeneric generate-toc (object))
(defgeneric generate-gemini-toc (object))
(defun gemini-window-p* (window)
(display-gemini-text-p window))
@ -695,31 +695,50 @@
(row-move object line-found)
(draw object)))
(defun gemini-sexp->toc-plist (all-headers
extract-header-fn
extract-level-fn
extract-gid-fn
extract-header-line-fn)
(let* ((toc-number (make-list gemini-parser:+max-header-level+ :initial-element 0))
(current-gid -1)
(toc (loop for row in all-headers
collect
(let* ((header (funcall extract-header-fn row))
(level (funcall extract-level-fn header))
(gid (funcall extract-gid-fn header)))
(when (/= gid current-gid)
(setf current-gid gid)
(incf (elt toc-number (1- level)))
(loop for i from level below (length toc-number) do
(setf (elt toc-number i) 0))
(loop for i from (- level 2 ) downto 0
when (= (elt toc-number i) 0) do
(setf (elt toc-number i) 1))
(list :header (funcall extract-header-line-fn header)
:group-id gid
:number (subseq toc-number
0
level)))))))
(remove-if #'null toc)))
(defmethod generate-gemini-toc ((object message-window))
(let* ((toc-number (make-list gemini-parser:+max-header-level+ :initial-element 0))
(current-gid -1)
(all-headers (remove-if-not (lambda (a)
(let* ((all-headers (remove-if-not (lambda (a)
(typep (row-get-original-object a)
'gemini-parser:header-line))
(rows object)))
(toc (loop for row in all-headers
collect
(let* ((header (row-get-original-object row))
(level (gemini-parser:level header))
(gid (gemini-parser:group-id header)))
(when (/= gid current-gid)
(setf current-gid gid)
(incf (elt toc-number (1- level)))
(loop for i from level below (length toc-number) do
(setf (elt toc-number i) 0))
(loop for i from (- level 2 ) downto 0
when (= (elt toc-number i) 0) do
(setf (elt toc-number i) 1))
(list :header (first (gemini-parser:lines header))
:group-id gid
:number (subseq toc-number
0
level)))))))
(toc (gemini-sexp->toc-plist all-headers
#'row-get-original-object
#'gemini-parser:level
#'gemini-parser:group-id
(lambda (header)
;; just the first line
;; contains the header
;; text the second
;; contains the
;; underline
(first (gemini-parser:lines header))))))
(remove-if #'null toc)))
(defun gemini-toc-header (fields)

2
src/package.lisp
View File

@ -2401,6 +2401,7 @@
:scroll-previous-page
:search-regex
:jump-to-group-id
:gemini-sexp->toc-plist
:generate-gemini-toc
:gemini-toc-entry
:gemini-toc-group-id
@ -3182,6 +3183,7 @@
:cl
:config
:constants
:box
:text-utils
:misc-utils)
(:local-nicknames (:re :cl-ppcre)

1
tinmop.asd
View File

@ -149,7 +149,6 @@
(:module gui-server
:pathname "gui/server"
:components ((:file "main-window-server-side")
(:file "public-api-structs")
(:file "public-api-gemini-stream")
(:file "public-api-gemini-certificates")
(:file "public-api-gemini-tour-links")