From 3114264505daf2830664c9618edc926353e21264 Mon Sep 17 00:00:00 2001 From: cage Date: Fri, 30 Dec 2022 11:07:30 +0100 Subject: [PATCH] - 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. --- src/gemini/gemini-parser.lisp | 66 ++++++- src/gui/json-rpc-communication.lisp | 21 ++- src/gui/public-api.lisp | 277 ++++++++++++++++++++++++++++ src/json-rpc2.lisp | 5 +- src/package.lisp | 11 +- 5 files changed, 370 insertions(+), 10 deletions(-) create mode 100644 src/gui/public-api.lisp diff --git a/src/gemini/gemini-parser.lisp b/src/gemini/gemini-parser.lisp index 410f445..ddc8dc2 100644 --- a/src/gemini/gemini-parser.lisp +++ b/src/gemini/gemini-parser.lisp @@ -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 #'=) diff --git a/src/gui/json-rpc-communication.lisp b/src/gui/json-rpc-communication.lisp index b08261c..8de9aec 100644 --- a/src/gui/json-rpc-communication.lisp +++ b/src/gui/json-rpc-communication.lisp @@ -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")))))) diff --git a/src/gui/public-api.lisp b/src/gui/public-api.lisp new file mode 100644 index 0000000..282da89 --- /dev/null +++ b/src/gui/public-api.lisp @@ -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)) diff --git a/src/json-rpc2.lisp b/src/json-rpc2.lisp index 1745dcf..a1f7364 100644 --- a/src/json-rpc2.lisp +++ b/src/json-rpc2.lisp @@ -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) diff --git a/src/package.lisp b/src/package.lisp index 0028de6..64960e2 100644 --- a/src/package.lisp +++ b/src/package.lisp @@ -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))