mirror of https://codeberg.org/cage/tinmop/
- added parameter 'initialize-parser' (default to nil), to reset
parser state in 'sexp->text-rows'; - added 'add-metadata-to-parsed-gemini-lines' This function will add attributes (like ':header-group-id') to the sexp representation of a gemini stream (structure: (tag ((attribute-key attribute value)...) text line) ) - [JSON-RPC API] added a couple of public API function.
This commit is contained in:
cage
parent
a87ea3b2ae
commit
3114264505
|
|
@ -574,7 +574,8 @@
|
|||
:text-line text
|
||||
:group-id header-group-id))
|
||||
|
||||
(defun sexp->text-rows (parsed-gemini theme)
|
||||
(defun sexp->text-rows (parsed-gemini theme &key (initialize-parser nil))
|
||||
"This function maintains an internal state, see `with-initialized-parser' macro"
|
||||
(labels ((header-prefix (prefix header)
|
||||
(strcat prefix header))
|
||||
(header-prefix-h1 (header)
|
||||
|
|
@ -710,7 +711,9 @@
|
|||
(add-source-metadata res source-line-id source-line)))
|
||||
(build-rows ()
|
||||
(flatten (loop for node in parsed-gemini collect (build-row node)))))
|
||||
(build-rows)))
|
||||
(if initialize-parser
|
||||
(with-initialized-parser (build-rows))
|
||||
(build-rows))))
|
||||
|
||||
(defun parse-gemini-file (data &key (initialize-parser nil))
|
||||
(flet ((parse-data (data)
|
||||
|
|
@ -739,6 +742,65 @@
|
|||
(with-initialized-parser (parse-data data))
|
||||
(parse-data data))))
|
||||
|
||||
(defun add-metadata-to-parsed-gemini-lines (parsed-gemini &key (initialize-parser nil))
|
||||
(labels ((trim (a)
|
||||
(trim-blanks a))
|
||||
(pre-alt-text (node)
|
||||
(trim (html-utils:attribute-value (html-utils:find-attribute :alt node))))
|
||||
(add-attribute (node key value)
|
||||
(html-utils:add-attribute key value node))
|
||||
(add-source-id (node source-id)
|
||||
(add-attribute node :source-id source-id))
|
||||
(add-header-group-id (node group-id)
|
||||
(add-attribute node :header-group-id group-id))
|
||||
(add-pre-alt-text (node alt-text)
|
||||
(add-attribute node :pre-alt-text alt-text))
|
||||
(add-pre-group-id (node group-id)
|
||||
(add-attribute node :pre-group-id group-id))
|
||||
(build-attributes (node)
|
||||
(let ((source-line-id (next-source-line-id))
|
||||
(res (cond
|
||||
((null node)
|
||||
(html-utils:make-tag-node :vertical-space nil nil))
|
||||
((html-utils:tag= :as-is node)
|
||||
(add-pre-group-id (add-pre-alt-text (add-header-group-id node
|
||||
(current-header-group-id))
|
||||
(current-pre-alt-text))
|
||||
(current-pre-group-id)))
|
||||
((html-utils:tag= :text node)
|
||||
(add-header-group-id node
|
||||
(current-header-group-id)))
|
||||
((or (html-utils:tag= :h1 node)
|
||||
(html-utils:tag= :h2 node)
|
||||
(html-utils:tag= :h3 node))
|
||||
(add-header-group-id node (next-header-group-id)))
|
||||
((html-utils:tag= :li node)
|
||||
(add-header-group-id node
|
||||
(current-header-group-id)))
|
||||
((html-utils:tag= :quote node)
|
||||
(add-header-group-id node
|
||||
(current-header-group-id)))
|
||||
((html-utils:tag= :pre node)
|
||||
(let ((current-alt-text (pre-alt-text node)))
|
||||
(set-pre-alt-text current-alt-text)
|
||||
(add-pre-group-id (add-pre-alt-text (add-header-group-id node
|
||||
(current-header-group-id))
|
||||
(current-pre-alt-text))
|
||||
(next-pre-group-id))))
|
||||
((html-utils:tag= :pre-end node)
|
||||
node)
|
||||
((html-utils:tag= :a node)
|
||||
(add-header-group-id node
|
||||
(current-header-group-id))))))
|
||||
(add-source-id res source-line-id)))
|
||||
(build-rows ()
|
||||
(loop for node in parsed-gemini
|
||||
collect
|
||||
(build-attributes node))))
|
||||
(if initialize-parser
|
||||
(with-initialized-parser (build-rows))
|
||||
(build-rows))))
|
||||
|
||||
;; response header
|
||||
|
||||
(define-constant +max-meta-length+ 1024 :test #'=)
|
||||
|
|
|
|||
|
|
@ -118,9 +118,20 @@
|
|||
(os-utils:process-input process))))
|
||||
(setf *server-stream* process-stream
|
||||
*server-process* process)
|
||||
(let ((request (rpc:jsonify (rpc:make-request "complete-net-address" 1 "foo"))))
|
||||
(format t "sending ~a~%" request)
|
||||
(send-to-server request)
|
||||
(format t "returned ~s~%" (read-from-server))
|
||||
(close-server)))
|
||||
(loop repeat 2 do
|
||||
(let ((request (rpc:jsonify (rpc:make-request "gemini-request"
|
||||
1
|
||||
"gemini://"
|
||||
t))))
|
||||
(format t "sending ~a~%" request)
|
||||
(send-to-server request)
|
||||
(format t "returned ~s~%" (read-from-server))))
|
||||
(let ((info-request (rpc:jsonify (rpc:make-request "gemini-stream-info"
|
||||
1
|
||||
"gemini://"))))
|
||||
(sleep 10)
|
||||
(format t "sending ~a~%" info-request)
|
||||
(send-to-server info-request)
|
||||
(format t "returned ~s~%" (read-from-server)))
|
||||
(close-server))
|
||||
(error (_ "Unable to create server process"))))))
|
||||
|
|
|
|||
|
|
@ -0,0 +1,277 @@
|
|||
;; 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)
|
||||
|
||||
(defun make-rpc-parameters (&rest params)
|
||||
(loop for (a b) on params by 'cddr collect (cons a b)))
|
||||
|
||||
(defmacro gen-rpc (public-function-name function-symbol &rest parameters)
|
||||
`(rpc:register-function ,public-function-name
|
||||
,function-symbol
|
||||
(make-rpc-parameters ,@parameters)))
|
||||
|
||||
(defun complete-net-address (hint)
|
||||
(let ((prompt (ui:open-url-prompt)))
|
||||
(funcall (complete:make-complete-gemini-iri-fn prompt) hint)))
|
||||
|
||||
(defun request-success-dispatched-fn (status code-description meta response socket iri parsed-iri)
|
||||
(declare (ignore iri))
|
||||
(multiple-value-bind (actual-iri host path query port fragment)
|
||||
(gemini-client:displace-iri parsed-iri )
|
||||
(gemini-client:debug-gemini "response is a stream")
|
||||
(labels ((make-text-based-stream (gemini-format-p)
|
||||
(let* ((starting-status :streaming)
|
||||
(gemini-stream (make-instance 'gemini-viewer::gemini-file-stream
|
||||
:host host
|
||||
:port port
|
||||
:path path
|
||||
:query query
|
||||
:fragment fragment
|
||||
:meta meta
|
||||
:status-code status
|
||||
:status-code-description
|
||||
code-description
|
||||
:stream-status starting-status
|
||||
:download-iri actual-iri
|
||||
:download-stream response
|
||||
:download-socket socket))
|
||||
(favicon (gemini-viewer::fetch-favicon parsed-iri))
|
||||
(thread-fn (gemini-viewer::request-stream-gemini-document-thread gemini-stream
|
||||
host
|
||||
port
|
||||
path
|
||||
query
|
||||
fragment
|
||||
favicon
|
||||
gemini-format-p)))
|
||||
(gemini-viewer:push-db-stream gemini-stream)
|
||||
(gemini-viewer::downloading-start-thread gemini-stream
|
||||
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")
|
||||
(make-text-based-stream t)
|
||||
(make-gemini-response gemini-client:+success+ meta actual-iri))
|
||||
((gemini-client:text-file-stream-p meta)
|
||||
(gemini-client:debug-gemini "response is a text stream")
|
||||
(make-text-based-stream nil)
|
||||
(make-gemini-response gemini-client:+success+ meta actual-iri))
|
||||
(t
|
||||
(let* ((starting-status :streaming)
|
||||
(gemini-stream (make-instance 'gemini-others-data-stream
|
||||
:stream-status starting-status
|
||||
:download-stream response
|
||||
:download-socket socket))
|
||||
(thread-fn (gemini-viewer::request-stream-other-document-thread gemini-stream
|
||||
socket
|
||||
host
|
||||
port
|
||||
path
|
||||
query
|
||||
fragment
|
||||
status
|
||||
code-description
|
||||
meta)))
|
||||
(gemini-client:debug-gemini "response is *not* a gemini file stream")
|
||||
(gemini-viewer::downloading-start-thread gemini-stream
|
||||
thread-fn
|
||||
host
|
||||
port
|
||||
path
|
||||
query
|
||||
fragment)
|
||||
(make-gemini-response gemini-client:+success+ meta actual-iri)))))))
|
||||
|
||||
(defun make-gemini-response (code meta iri &key (cached nil))
|
||||
(list (cons "status" (gemini-client:code code))
|
||||
(cons "status-description" (gemini-client:description code))
|
||||
(cons "meta" meta)
|
||||
(cons "cached" cached)
|
||||
(cons "iri" iri)))
|
||||
|
||||
(a:define-constant +gemini-response-error-code+ -32011 :test #'=)
|
||||
|
||||
(defun make-gemini-response-error (message)
|
||||
(rpc:make-response nil
|
||||
nil
|
||||
:error-object (rpc::make-response-error +gemini-response-error-code+
|
||||
message)))
|
||||
|
||||
(defun %gemini-request (url &key
|
||||
(certificate nil)
|
||||
(certificate-key nil)
|
||||
(use-cached-file-if-exists nil)
|
||||
(do-nothing-if-exists-in-db nil))
|
||||
(labels ((redirect-dispatch (status code-description meta response socket iri parsed-iri)
|
||||
(declare (ignore parsed-iri code-description response socket))
|
||||
(gemini-client:debug-gemini "response redirect to: ~s" meta)
|
||||
(make-gemini-response status meta iri))
|
||||
(input-dispatch (status code-description meta response socket iri parsed-iri)
|
||||
(declare (ignore code-description response socket parsed-iri))
|
||||
(gemini-client:debug-gemini "response requested input: ~s" meta)
|
||||
(make-gemini-response status meta iri))
|
||||
(sensitive-input-dispatch (status code-description meta response socket iri parsed-iri)
|
||||
(declare (ignore code-description response socket parsed-iri))
|
||||
(gemini-client:debug-gemini "response requested sensitive input: ~s"
|
||||
meta)
|
||||
(make-gemini-response status meta iri))
|
||||
(certificate-request-dispatch (status
|
||||
code-description
|
||||
meta
|
||||
response
|
||||
socket iri
|
||||
parsed-iri)
|
||||
(declare (ignore status code-description response socket meta parsed-iri))
|
||||
(gemini-client:debug-gemini "response requested certificate")
|
||||
(multiple-value-bind (cached-certificate cached-key)
|
||||
(gemini-client:fetch-cached-certificate iri)
|
||||
(%gemini-request iri
|
||||
:do-nothing-if-exists-in-db do-nothing-if-exists-in-db
|
||||
:certificate-key cached-key
|
||||
:certificate cached-certificate))))
|
||||
(handler-case
|
||||
(gemini-client:with-request-dispatch-table ((:certificate-requested
|
||||
#'certificate-request-dispatch
|
||||
:input-requested
|
||||
#'input-dispatch
|
||||
:sensitive-input-requested
|
||||
#'sensitive-input-dispatch
|
||||
:redirect
|
||||
#'redirect-dispatch
|
||||
:success
|
||||
#'request-success-dispatched-fn)
|
||||
:ignore-warning nil)
|
||||
(gemini-client:debug-gemini "viewer requesting iri ~s" url)
|
||||
(let ((actual-iri (gemini-client:displace-iri (iri:iri-parse url))))
|
||||
(if use-cached-file-if-exists
|
||||
(progn
|
||||
(gemini-client:debug-gemini "checking cache")
|
||||
(if (gemini-viewer:find-db-stream-url actual-iri)
|
||||
(progn
|
||||
(gemini-client:debug-gemini "caching found for ~a" actual-iri)
|
||||
(make-gemini-response gemini-client:+success+ nil
|
||||
actual-iri
|
||||
:cached t))
|
||||
(progn
|
||||
(gemini-client:debug-gemini "caching *not* found for ~a" actual-iri)
|
||||
(%gemini-request actual-iri
|
||||
:certificate-key certificate-key
|
||||
:certificate certificate
|
||||
:use-cached-file-if-exists nil
|
||||
:do-nothing-if-exists-in-db
|
||||
do-nothing-if-exists-in-db))))
|
||||
(gemini-client:request-dispatch url
|
||||
gemini-client::dispatch-table
|
||||
:certificate certificate
|
||||
:certificate-key certificate-key))))
|
||||
(gemini-client:gemini-tofu-error (e)
|
||||
(make-gemini-response-error (format nil "TOFU error: ~a" e)))
|
||||
(conditions:not-implemented-error (e)
|
||||
(make-gemini-response-error (format nil (_ "Error: ~a") e)))
|
||||
(gemini-client:gemini-protocol-error (e)
|
||||
(make-gemini-response-error (format nil "~a" e)))
|
||||
(error (e)
|
||||
(make-gemini-response-error (format nil (_ "Error getting ~s: ~a") url e)))
|
||||
(condition (c)
|
||||
(make-gemini-response-error (format nil (_ "Error getting ~s: ~a") url c))))))
|
||||
|
||||
(defun gemini-request (iri use-cache)
|
||||
(%gemini-request iri :use-cached-file-if-exists use-cache))
|
||||
|
||||
(defgeneric rearrange-for-encoding (object))
|
||||
|
||||
(defmethod rearrange-for-encoding (object)
|
||||
object)
|
||||
|
||||
(defmethod rearrange-for-encoding ((object symbol))
|
||||
(string-downcase (symbol-name object)))
|
||||
|
||||
(defun rearrange-parsed-line-for-encoding (lines)
|
||||
(cons "lines"
|
||||
(loop for line in lines
|
||||
collect
|
||||
(let ((flattened (mapcar #'rearrange-for-encoding (a:flatten line))))
|
||||
;;(misc:dbg "flattened ~s" flattened)
|
||||
(if flattened
|
||||
(append (list (cons "type" (first flattened)))
|
||||
(loop for (a b) on (subseq flattened 1 (1- (length flattened)))
|
||||
by 'cddr
|
||||
collect
|
||||
(cons a b))
|
||||
(list (cons "line" (a:last-elt flattened))))
|
||||
nil)))))
|
||||
|
||||
(defmethod rpc::render-as-list ((object gw:gemini-stream))
|
||||
(with-accessors ((stream-status gw:stream-status)
|
||||
(download-iri gw:download-iri)
|
||||
(start-time gw:start-time)
|
||||
(support-file gw:support-file)
|
||||
(parsed-lines gw:parsed-lines)
|
||||
(octect-count gw:octect-count)
|
||||
(port gw:port)
|
||||
(status-code gw:status-code)
|
||||
(status-code-description gw:status-code-description)
|
||||
(meta gw:meta)
|
||||
(path gw:path)
|
||||
(query gw:query)
|
||||
(fragment gw:fragment)
|
||||
(host gw:host)) object
|
||||
(let ((actual-start-time (db-utils:decode-datetime-string start-time))
|
||||
(actual-parsed-lines (rearrange-parsed-line-for-encoding parsed-lines)))
|
||||
(misc:dbg "flattened ~s" actual-parsed-lines)
|
||||
(list (cons "stream-status" stream-status)
|
||||
(cons "download-iri" download-iri)
|
||||
(cons "start-time" actual-start-time)
|
||||
(cons "support-file" support-file)
|
||||
(cons "parsed-lines" actual-parsed-lines)
|
||||
(cons "octect-count" octect-count)
|
||||
(cons "port" port)
|
||||
(cons "status-code" status-code)
|
||||
(cons "status-code-description" status-code-description)
|
||||
(cons "meta" meta)
|
||||
(cons "path" path)
|
||||
(cons "query" query)
|
||||
(cons "fragment" fragment)
|
||||
(cons "host" host)))))
|
||||
|
||||
(defun gemini-stream-info (iri)
|
||||
(a:when-let ((stream-wrapper (gw:find-db-stream-url iri)))
|
||||
(rpc::render-as-list stream-wrapper)))
|
||||
|
||||
(defmacro prepare-rpc (&body body)
|
||||
`(let ((rpc:*function-db* '()))
|
||||
(gen-rpc "add"
|
||||
'+
|
||||
"a" 0
|
||||
"b" 1)
|
||||
(gen-rpc "complete-net-address"
|
||||
'complete-net-address
|
||||
"hint" 0)
|
||||
(gen-rpc "gemini-request"
|
||||
'gemini-request
|
||||
"iri" 0
|
||||
"use-cache" 1)
|
||||
(gen-rpc "gemini-stream-info"
|
||||
'gemini-stream-info
|
||||
"iri" 0)
|
||||
,@body))
|
||||
|
|
@ -257,7 +257,8 @@
|
|||
(with-accessors ((payload payload)) object
|
||||
(with-output-to-string (stream)
|
||||
(yason:with-output (stream)
|
||||
(let ((yason:*list-encoder* #'yason:encode-alist))
|
||||
(let ((yason:*list-encoder* #'yason:encode-alist)
|
||||
(yason:*symbol-encoder* #'yason:encode-symbol-as-lowercase))
|
||||
(yason:encode-alist (render-as-list payload)))))))
|
||||
|
||||
(defmethod jsonify ((object rpc-request))
|
||||
|
|
@ -395,6 +396,8 @@
|
|||
(displace-single-request request)
|
||||
(let* ((request (apply #'make-request method id params))
|
||||
(elaborated (call-function request)))
|
||||
#+(and debug-mode debug-json-rpc)
|
||||
(misc:dbg "jsonrpc request ~s results ~s" request elaborated)
|
||||
(when id
|
||||
;; if id is null is a notification (i.e. the client
|
||||
;; does not care about an answer)
|
||||
|
|
|
|||
|
|
@ -2641,17 +2641,22 @@
|
|||
:history-back
|
||||
:view-source
|
||||
:gemini-stream
|
||||
:stream-status
|
||||
:download-iri
|
||||
:start-time
|
||||
:download-stream
|
||||
:download-socket
|
||||
:support-file
|
||||
:parsed-lines
|
||||
:support-file
|
||||
:octect-count
|
||||
:port
|
||||
:status-code
|
||||
:status-code-description
|
||||
:meta
|
||||
:path
|
||||
:query
|
||||
:fragment
|
||||
:host
|
||||
:thread
|
||||
:abort-downloading
|
||||
|
|
@ -3033,6 +3038,8 @@
|
|||
:make-notification
|
||||
:make-notification*
|
||||
:make-batch
|
||||
:make-response-error
|
||||
:make-response
|
||||
:jsonify
|
||||
:json-rpc-error
|
||||
:elaborate-request
|
||||
|
|
@ -3063,8 +3070,8 @@
|
|||
(:local-nicknames (:re :cl-ppcre-unicode)
|
||||
(:a :alexandria)
|
||||
(:rpc :json-rpc2)
|
||||
(:json :yason))
|
||||
|
||||
(:json :yason)
|
||||
(:gw :gemini-viewer))
|
||||
(:export
|
||||
:start-server
|
||||
:start-client))
|
||||
|
|
|
|||
Loading…
Reference in New Issue