mirror of
https://codeberg.org/cage/tinmop/
synced 2025-02-16 08:00:35 +01:00
- [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:
parent
3824e29171
commit
045819b4a4
@ -130,14 +130,6 @@
|
|||||||
(format t "sending ~a~%" request)
|
(format t "sending ~a~%" request)
|
||||||
(send-to-server request)
|
(send-to-server request)
|
||||||
(format t "returned ~s~%" (read-from-server))))
|
(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)
|
(sleep 3)
|
||||||
(let ((info-request (rpc:encode-to-string (rpc:make-request "gemini-stream-info"
|
(let ((info-request (rpc:encode-to-string (rpc:make-request "gemini-stream-info"
|
||||||
1
|
1
|
||||||
@ -176,5 +168,10 @@
|
|||||||
(format t "sending ~a~%" certificates)
|
(format t "sending ~a~%" certificates)
|
||||||
(send-to-server certificates)
|
(send-to-server certificates)
|
||||||
(format t "returned ~s~%" (read-from-server)))
|
(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))
|
(close-server))
|
||||||
(error (_ "Unable to create server process"))))))
|
(error (_ "Unable to create server process"))))))
|
||||||
|
@ -17,7 +17,7 @@
|
|||||||
|
|
||||||
(in-package :json-rpc-communication)
|
(in-package :json-rpc-communication)
|
||||||
|
|
||||||
(defstruct (gemini-certificates (:include box)))
|
(defclass gemini-certificates (box) ())
|
||||||
|
|
||||||
(defmethod yason:encode ((object gemini-certificates) &optional (stream *standard-output*))
|
(defmethod yason:encode ((object gemini-certificates) &optional (stream *standard-output*))
|
||||||
(let ((json:*symbol-encoder* #'json:encode-symbol-as-lowercase)
|
(let ((json:*symbol-encoder* #'json:encode-symbol-as-lowercase)
|
||||||
@ -25,11 +25,11 @@
|
|||||||
(json:*symbol-key-encoder* #'json:encode-symbol-as-lowercase))
|
(json:*symbol-key-encoder* #'json:encode-symbol-as-lowercase))
|
||||||
(yason:with-output (stream)
|
(yason:with-output (stream)
|
||||||
(yason:with-array ()
|
(yason:with-array ()
|
||||||
(loop for certificate in (gemini-certificates-payload object) do
|
(loop for certificate in (unbox object) do
|
||||||
(yason:encode-array-element certificate))))))
|
(yason:encode-array-element certificate))))))
|
||||||
|
|
||||||
(defun gemini-certificates ()
|
(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)
|
(defun invalidate-cached-value (cache-key)
|
||||||
(db:cache-invalidate cache-key)
|
(db:cache-invalidate cache-key)
|
||||||
|
@ -262,7 +262,7 @@
|
|||||||
line-number)))))
|
line-number)))))
|
||||||
(first res))))))))
|
(first res))))))))
|
||||||
|
|
||||||
(defstruct (parsed-lines-slice (:include box)))
|
(defclass parsed-lines-slice (box) ())
|
||||||
|
|
||||||
(defmethod yason:encode ((object parsed-lines-slice) &optional (stream *standard-output*))
|
(defmethod yason:encode ((object parsed-lines-slice) &optional (stream *standard-output*))
|
||||||
(let ((json:*symbol-encoder* #'json:encode-symbol-as-lowercase)
|
(let ((json:*symbol-encoder* #'json:encode-symbol-as-lowercase)
|
||||||
@ -270,7 +270,7 @@
|
|||||||
(json:*symbol-key-encoder* #'json:encode-symbol-as-lowercase))
|
(json:*symbol-key-encoder* #'json:encode-symbol-as-lowercase))
|
||||||
(yason:with-output (stream)
|
(yason:with-output (stream)
|
||||||
(json:with-array ()
|
(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))))))
|
(json:encode-array-element parsed-line))))))
|
||||||
|
|
||||||
(defun gemini-stream-parsed-line-slice (iri line-number-start line-number-end)
|
(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
|
(let ((res (rearrange-parsed-line-for-encoding (subseq parsed-lines
|
||||||
line-number-start
|
line-number-start
|
||||||
line-number-end))))
|
line-number-end))))
|
||||||
(make-parsed-lines-slice :payload res))))))))
|
(make-instance 'parsed-lines-slice :contents res))))))))
|
||||||
|
|
||||||
(defun gemini-stream-info (iri)
|
(defun gemini-stream-info (iri)
|
||||||
(let ((stream-wrapper (gw:find-db-stream-url iri)))
|
(let ((stream-wrapper (gw:find-db-stream-url iri)))
|
||||||
@ -308,3 +308,79 @@
|
|||||||
|
|
||||||
(defun gemini-all-stream-info ()
|
(defun gemini-all-stream-info ()
|
||||||
gw:*gemini-streams-db*)
|
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))
|
||||||
|
@ -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))
|
|
@ -17,9 +17,6 @@
|
|||||||
|
|
||||||
(in-package :json-rpc-communication)
|
(in-package :json-rpc-communication)
|
||||||
|
|
||||||
(defstruct box
|
|
||||||
(payload))
|
|
||||||
|
|
||||||
(defun make-rpc-parameters (&rest params)
|
(defun make-rpc-parameters (&rest params)
|
||||||
(loop for (a b) on params by 'cddr collect (cons a b)))
|
(loop for (a b) on params by 'cddr collect (cons a b)))
|
||||||
|
|
||||||
@ -66,6 +63,9 @@
|
|||||||
(gen-rpc "gemini-delete-certificate"
|
(gen-rpc "gemini-delete-certificate"
|
||||||
'gemini-delete-certificate
|
'gemini-delete-certificate
|
||||||
"cache-key" 0)
|
"cache-key" 0)
|
||||||
|
(gen-rpc "gemini-toc"
|
||||||
|
'gemini-table-of-contents
|
||||||
|
"iri" 0)
|
||||||
(gen-rpc "tour-shuffle" 'tour-shuffle)
|
(gen-rpc "tour-shuffle" 'tour-shuffle)
|
||||||
(gen-rpc "tour-add-link"
|
(gen-rpc "tour-add-link"
|
||||||
'tour-add-link
|
'tour-add-link
|
||||||
|
@ -66,7 +66,7 @@
|
|||||||
|
|
||||||
(defgeneric viewport-width (object))
|
(defgeneric viewport-width (object))
|
||||||
|
|
||||||
(defgeneric generate-toc (object))
|
(defgeneric generate-gemini-toc (object))
|
||||||
|
|
||||||
(defun gemini-window-p* (window)
|
(defun gemini-window-p* (window)
|
||||||
(display-gemini-text-p window))
|
(display-gemini-text-p window))
|
||||||
@ -695,31 +695,50 @@
|
|||||||
(row-move object line-found)
|
(row-move object line-found)
|
||||||
(draw object)))
|
(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))
|
(defmethod generate-gemini-toc ((object message-window))
|
||||||
(let* ((toc-number (make-list gemini-parser:+max-header-level+ :initial-element 0))
|
(let* ((all-headers (remove-if-not (lambda (a)
|
||||||
(current-gid -1)
|
|
||||||
(all-headers (remove-if-not (lambda (a)
|
|
||||||
(typep (row-get-original-object a)
|
(typep (row-get-original-object a)
|
||||||
'gemini-parser:header-line))
|
'gemini-parser:header-line))
|
||||||
(rows object)))
|
(rows object)))
|
||||||
(toc (loop for row in all-headers
|
(toc (gemini-sexp->toc-plist all-headers
|
||||||
collect
|
#'row-get-original-object
|
||||||
(let* ((header (row-get-original-object row))
|
#'gemini-parser:level
|
||||||
(level (gemini-parser:level header))
|
#'gemini-parser:group-id
|
||||||
(gid (gemini-parser:group-id header)))
|
(lambda (header)
|
||||||
(when (/= gid current-gid)
|
;; just the first line
|
||||||
(setf current-gid gid)
|
;; contains the header
|
||||||
(incf (elt toc-number (1- level)))
|
;; text the second
|
||||||
(loop for i from level below (length toc-number) do
|
;; contains the
|
||||||
(setf (elt toc-number i) 0))
|
;; underline
|
||||||
(loop for i from (- level 2 ) downto 0
|
(first (gemini-parser:lines header))))))
|
||||||
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)))))))
|
|
||||||
(remove-if #'null toc)))
|
(remove-if #'null toc)))
|
||||||
|
|
||||||
(defun gemini-toc-header (fields)
|
(defun gemini-toc-header (fields)
|
||||||
|
@ -2401,6 +2401,7 @@
|
|||||||
:scroll-previous-page
|
:scroll-previous-page
|
||||||
:search-regex
|
:search-regex
|
||||||
:jump-to-group-id
|
:jump-to-group-id
|
||||||
|
:gemini-sexp->toc-plist
|
||||||
:generate-gemini-toc
|
:generate-gemini-toc
|
||||||
:gemini-toc-entry
|
:gemini-toc-entry
|
||||||
:gemini-toc-group-id
|
:gemini-toc-group-id
|
||||||
@ -3182,6 +3183,7 @@
|
|||||||
:cl
|
:cl
|
||||||
:config
|
:config
|
||||||
:constants
|
:constants
|
||||||
|
:box
|
||||||
:text-utils
|
:text-utils
|
||||||
:misc-utils)
|
:misc-utils)
|
||||||
(:local-nicknames (:re :cl-ppcre)
|
(:local-nicknames (:re :cl-ppcre)
|
||||||
|
@ -149,7 +149,6 @@
|
|||||||
(:module gui-server
|
(:module gui-server
|
||||||
:pathname "gui/server"
|
:pathname "gui/server"
|
||||||
:components ((:file "main-window-server-side")
|
:components ((:file "main-window-server-side")
|
||||||
(:file "public-api-structs")
|
|
||||||
(:file "public-api-gemini-stream")
|
(:file "public-api-gemini-stream")
|
||||||
(:file "public-api-gemini-certificates")
|
(:file "public-api-gemini-certificates")
|
||||||
(:file "public-api-gemini-tour-links")
|
(:file "public-api-gemini-tour-links")
|
||||||
|
Loading…
x
Reference in New Issue
Block a user