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

- log gemini and json, debug messages even if *features* does not 

contains :debug-mode;
- [RPC] fixed 'gemini-stream-info';
- [RPC] added 'gemini-stream-parsed-line-slice';
- [RPC] added error handling for 'gemini-stream-parsed-line';
- [JSON-RPC] fixed encoding of error responses.
This commit is contained in:
cage 2023-01-06 11:56:21 +01:00
parent 8c48c9a567
commit cfb05a6ea1
7 changed files with 215 additions and 132 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

3
src/gemini/client.lisp
View File

@ -345,8 +345,7 @@
(defun debug-gemini (&rest data)
(declare (ignorable data))
#+(and debug-mode
debug-gemini-request)
#+debug-gemini-request
(apply #'misc:dbg (text-utils:strcat "[gemini] " (first data)) (rest data)))
(defun open-tls-socket (host port)

49
src/gui/json-rpc-communication.lisp
View File

@ -38,7 +38,7 @@
:delimiter +command-delimiter+)))
(defun elaborate-json-request (data)
(rpc:jsonify (rpc:elaborate-request data)))
(rpc:encode-to-string (rpc:elaborate-request data)))
(defun read-from-client ()
(read-json *server-input-stream*))
@ -78,9 +78,11 @@
(quit-server)))
(defun read-from-server ()
(json:parse (read-json *server-stream*)
:object-as :plist
:object-key-fn #'format-keyword))
(let ((json (read-json *server-stream*)))
(rpc:maybe-log-message (format nil "json from server: ~a" json))
(json:parse json
:object-as :plist
:object-key-fn #'format-keyword)))
(defgeneric send-to-server (object))
@ -104,7 +106,8 @@
(defun start-client ()
(with-output-to-string (stream)
(let* ((process (os-utils:run-external-program "/home/cage/lisp/tinmop/tinmop" ;+program-name+
(let* ((test-iri "gemini://")
(process (os-utils:run-external-program "/home/cage/lisp/tinmop/tinmop" ;+program-name+
(list (format nil
"-~a"
command-line:+start-server-command-line+))
@ -119,19 +122,35 @@
(setf *server-stream* process-stream
*server-process* process)
(loop repeat 2 do
(let ((request (rpc:jsonify (rpc:make-request "gemini-request"
1
"gemini://"
t))))
(let ((request (rpc:encode-to-string (rpc:make-request "gemini-request"
1
test-iri
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)
(sleep 3)
(let ((info-request (rpc:encode-to-string (rpc:make-request "gemini-stream-info"
1
test-iri))))
(format t "sending ~a~%" info-request)
(send-to-server info-request)
(format t "returned ~s~%" (read-from-server)))
(let ((line-request (rpc:encode-to-string (rpc:make-request "gemini-stream-parsed-line"
1
test-iri
2))))
(format t "sending ~a~%" line-request)
(send-to-server line-request)
(format t "returned ~s~%" (read-from-server)))
(let ((lines-request (rpc:encode-to-string
(rpc:make-request "gemini-stream-parsed-line-slice"
1
test-iri
10
15))))
(format t "sending ~a~%" lines-request)
(send-to-server lines-request)
(format t "returned ~s~%" (read-from-server)))
(close-server))
(error (_ "Unable to create server process"))))))

138
src/gui/public-api.lisp
View File

@ -207,28 +207,18 @@
(string-downcase (symbol-name object)))
(defun rearrange-parsed-line-for-encoding (lines)
(flet ((contains-chldren-p (node)
(flet ((contains-children-p (node)
(evenp (length node))))
(loop for line in lines
collect
(let ((flattened (mapcar #'rearrange-for-encoding (a:flatten line))))
(when flattened
(if (contains-chldren-p 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))))
(append (list (cons "type" (first flattened)))
(loop for (a b) on (subseq flattened 1)
by 'cddr
collect
(cons a b)))))))))
(if (contains-children-p flattened)
(append (list "type")
(subseq flattened 0 (1- (length flattened)))
(list "line" (a:last-elt flattened)))
(cons "type" flattened))))))
(defmethod rpc::render-as-list ((object gw:gemini-stream))
(defmethod yason:encode ((object gw:gemini-stream) &optional (stream *standard-output*))
(with-accessors ((stream-status gw:stream-status)
(download-iri gw:download-iri)
(start-time gw:start-time)
@ -243,36 +233,97 @@
(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)))
(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)))))
(let* ((actual-start-time (db-utils:decode-datetime-string start-time))
(actual-parsed-lines (rearrange-parsed-line-for-encoding parsed-lines))
(info-alist (list (cons "stream-status" stream-status)
(cons "download-iri" download-iri)
(cons "start-time" actual-start-time)
(cons "support-file" support-file)
(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))))
(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-object ()
(loop for ((k . v)) on info-alist do
(json:with-object-element (k)
(json:encode v)))
(json:with-object-element ("lines")
(json:with-array ()
(loop for parsed-line in actual-parsed-lines do
(json:encode-array-element parsed-line))))))))))
(defun gemini-stream-parsed-line (iri line-number)
(a:when-let* ((stream-wrapper (gw:find-db-stream-url iri))
(parsed-lines (gw:parsed-lines stream-wrapper)))
(when (and (integerp line-number)
(>= line-number 0)
(< line-number (length parsed-lines)))
(let ((res (rearrange-parsed-line-for-encoding (list (elt parsed-lines line-number)))))
res))))
(let ((stream-wrapper (gw:find-db-stream-url iri)))
(if (null stream-wrapper)
(error "no such stream")
(let ((parsed-lines (gw:parsed-lines stream-wrapper)))
(cond
((or (not (integerp line-number))
(< line-number 0))
(error (format nil
"Line number argument provided is not a positive integer ~a"
line-number)))
((>= line-number (length parsed-lines))
(error (format nil
"No parsed line available for line number ~a"
line-number)))
(t
(let ((res (rearrange-parsed-line-for-encoding (list (elt parsed-lines
line-number)))))
(first res))))))))
(defstruct parsed-lines-slice
(lines))
(defmethod yason:encode ((object parsed-lines-slice) &optional (stream *standard-output*))
(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 parsed-line in (parsed-lines-slice-lines object) do
(json:encode-array-element parsed-line))))))
(defun gemini-stream-parsed-line-slice (iri line-number-start line-number-end)
(let ((stream-wrapper (gw:find-db-stream-url iri)))
(if (null stream-wrapper)
(error "no such stream")
(let ((parsed-lines (gw:parsed-lines stream-wrapper)))
(cond
((or (not (integerp line-number-start))
(< line-number-start 0))
(error (format nil
"Line number index start argument provided is not a positive integer ~a"
line-number-start)))
((and (integerp line-number-end)
(< line-number-end 0))
(error (format nil
"Line number index end argument provided is not a positive integer ~a"
line-number-end)))
((and (integerp line-number-end)
(>= line-number-end (length parsed-lines)))
(error (format nil
"No parsed line available for line number ~a"
line-number-end)))
(t
(let ((res (rearrange-parsed-line-for-encoding (subseq parsed-lines
line-number-start
line-number-end))))
(make-parsed-lines-slice :lines res))))))))
(defun gemini-stream-info (iri)
(let ((stream-wrapper (gw:find-db-stream-url iri)))
(if stream-wrapper
(rpc::render-as-list stream-wrapper)
stream-wrapper
(error "no such stream"))))
(defmacro prepare-rpc (&body body)
@ -295,4 +346,9 @@
'gemini-stream-parsed-line
"iri" 0
"line-number" 1)
(gen-rpc "gemini-stream-parsed-line-slice"
'gemini-stream-parsed-line-slice
"iri" 0
"line-number-start" 1
"line-number-end" 2)
,@body))

83
src/json-rpc2.lisp
View File

@ -248,45 +248,51 @@
(defun make-notification* (method params)
(apply #'%make-request method nil params))
(defgeneric jsonify (object))
(defclass rpc-response ()
(defclass rpc-response (identificable)
((payload
:initform nil
:initarg :payload
:accessor payload)))
:accessor payload)
(error-response
:initform nil
:initarg :error-response
:accessor error-response)))
(defmethod jsonify ((object rpc-response))
(with-accessors ((payload payload)) object
(with-output-to-string (stream)
(yason:with-output (stream)
(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))
(with-output-to-string (stream)
(let ((yason:*list-encoder* #'yason:encode-alist))
(yason:encode (render-as-list object) stream))))
(defmethod jsonify ((object rpc-request-batch))
(with-output-to-string (stream)
(defmethod yason:encode ((object rpc-response) &optional (stream *standard-output*))
(with-accessors ((payload payload)
(error-response error-response)
(request-id id)) object
(yason:with-output (stream)
(yason:with-array ()
(loop for request in (requests object) do
(let ((yason:*list-encoder* #'yason:encode-alist))
(yason:encode-array-element (render-as-list request))))))))
(let ((yason:*list-encoder* #'yason:encode-alist)
(yason:*symbol-encoder* #'yason:encode-symbol-as-lowercase))
(if error-response
(yason:encode (list (cons +key-name+ +protocol-version+)
(cons +key-error+ error-response)
(cons +key-id+ request-id))
stream)
(progn
(yason:with-object ()
(yason:with-object-element (+key-name+)
(yason:encode +protocol-version+ stream))
(yason:with-object-element (+key-result+)
(yason:encode payload stream))
(yason:with-object-element (+key-id+)
(let ((yason:*list-encoder* #'yason:encode-plist))
(yason:encode request-id stream))))))))))
(defmethod jsonify ((object (eql nil)))
nil)
(defmethod yason:encode ((object rpc-request) &optional (stream *standard-output*))
(let ((yason:*list-encoder* #'yason:encode-alist))
(yason:encode (render-as-list object) stream)))
(defmethod jsonify ((object list))
(defmethod yason:encode ((object rpc-request-batch) &optional (stream *standard-output*))
(yason:with-output (stream)
(yason:with-array ()
(loop for request in (requests object) do
(yason:encode-array-element request)))))
(defun encode-to-string (object)
(with-output-to-string (stream)
(let ((yason:*list-encoder* #'yason:encode-alist))
(yason:with-output (stream)
(yason:with-array ()
(loop for element in object do
(yason:encode-array-element (render-as-list element))))))))
(yason:encode object stream)))
(defgeneric render-as-list (object))
@ -313,14 +319,10 @@
default))))
(defun make-response (results request-id &key (error-object nil))
(make-instance 'rpc-response :payload
(if error-object
(list (cons +key-name+ +protocol-version+)
(cons +key-error+ error-object)
(cons +key-id+ request-id))
(list (cons +key-name+ +protocol-version+)
(cons +key-result+ results)
(cons +key-id+ request-id)))))
(make-instance 'rpc-response
:id request-id
:payload results
:error-response error-object))
(defun supported-version-p (v)
(and v
@ -398,7 +400,7 @@
(defun maybe-log-message (m)
(declare (ignorable m))
#+(and debug-mode debug-json-rpc)
#+debug-json-rpc
(misc:dbg m))
(defun elaborate-single-request (request)
@ -460,6 +462,7 @@
(with-input-from-string (stream raw-request)
(maybe-log-message (format nil "jsonrpc2 raw request~a" raw-request))
(let ((decoded (yason:parse stream :object-as :alist)))
(maybe-log-message (format nil "decoded request ~a~%" decoded))
(if (request-batch-p decoded)
(if (null decoded)
(elaborate-single-request decoded) ;; will build an error response

3
src/package.lisp
View File

@ -3035,6 +3035,7 @@
:alexandria
:yason)
(:export
:maybe-log-message
:generate-request-id
:*function-db*
:register-function
@ -3046,7 +3047,7 @@
:make-batch
:make-response-error
:make-response
:jsonify
:encode-to-string
:json-rpc-error
:elaborate-request
:transaction-id

28
src/program-events.lisp
View File

@ -1714,6 +1714,20 @@
(windows:draw message-window))
(ui:info-message (_ "No mentions")))))
;;;; general usage
(defclass function-event (program-event) ())
(defmethod process-event ((object function-event))
(with-accessors ((payload payload)) object
(assert (functionp payload))
(funcall payload)))
(defmacro with-enqueued-process ((&optional (priority +standard-event-priority+)) &body body)
`(push-event (make-instance 'function-event
:payload (lambda () ,@body)
:priority ,priority)))
(defclass delete-all-notifications-event (program-event) ())
(defmethod process-event ((object delete-all-notifications-event))
@ -1734,20 +1748,6 @@
(windows:win-clear message-window)
(windows:draw message-window)))))))
;;;; general usage
(defclass function-event (program-event) ())
(defmethod process-event ((object function-event))
(with-accessors ((payload payload)) object
(assert (functionp payload))
(funcall payload)))
(defmacro with-enqueued-process ((&optional (priority +standard-event-priority+)) &body body)
`(push-event (make-instance 'function-event
:payload (lambda () ,@body)
:priority ,priority)))
;;;; end events
(defun dispatch-program-events ()

43
src/tests/jsonrpc2-tests.lisp
View File

@ -37,19 +37,23 @@
(register-function "notify_hello" '+ (list (cons "values0" 0)))
,@body))
(defun ->json (a)
(encode-to-string a))
(deftest test-simple (json-rpc2-suite)
(prepare-rpc
(assert-equality #'string=
"{\"jsonrpc\":\"2.0\",\"result\":30,\"id\":1}"
(jsonify (elaborate-request (jsonify (make-request "add"
1
'("b" . 10)
'("a" . 20))))))))
(->json (elaborate-request (->json (make-request "add"
1
'("b" . 10)
'("a" . 20))))))))
(defun transaction-test (req expected-req expected-response &optional (show-json-p nil))
(prepare-rpc
(let* ((json-req (jsonify req))
(json-resp (jsonify (elaborate-request json-req))))
(let* ((json-req (->json req))
(json-resp (->json (elaborate-request json-req))))
(when show-json-p
(format t "~%~a~%~a~%" json-req json-resp))
(assert-equality #'string= expected-req json-req)
@ -57,8 +61,8 @@
(deftest test-sub-positional (json-rpc2-suite)
(transaction-test (make-request "subtract" 1 42 23)
"{\"jsonrpc\":\"2.0\",\"method\":\"subtract\",\"params\":[42,23],\"id\":1}"
"{\"jsonrpc\":\"2.0\",\"result\":19,\"id\":1}"))
"{\"jsonrpc\":\"2.0\",\"method\":\"subtract\",\"params\":[42,23],\"id\":1}"
"{\"jsonrpc\":\"2.0\",\"result\":19,\"id\":1}"))
(deftest test-sub-positional-2 (json-rpc2-suite)
(transaction-test (make-request "subtract" 2 23 42)
@ -66,8 +70,9 @@
"{\"jsonrpc\":\"2.0\",\"result\":-19,\"id\":2}"))
(deftest test-sub-named (json-rpc2-suite)
(transaction-test (make-request "subtract" 3 (cons "subtrahend" 23)
(cons "minuend" 42))
(transaction-test (make-request "subtract" 3
(cons "subtrahend" 23)
(cons "minuend" 42))
(strcat "{\"jsonrpc\":\"2.0\",\"method\":\"subtract\","
"\"params\":{\"subtrahend\":23,\"minuend\":42},\"id\":3}")
"{\"jsonrpc\":\"2.0\",\"result\":19,\"id\":3}"))
@ -83,7 +88,7 @@
(deftest test-notifications (json-rpc2-suite)
(transaction-test (make-notification* "update" '(1 2 3 4 5))
"{\"jsonrpc\":\"2.0\",\"method\":\"update\",\"params\":[1,2,3,4,5]}"
nil))
"null"))
(deftest test-non-existent-method (json-rpc2-suite)
(transaction-test (make-request "foobar" 1)
@ -94,7 +99,7 @@
(deftest test-invalid-json (json-rpc2-suite)
(let* ((json-req "{\"jsonrpc\": \"2.0\", \"method\": \"foobar, \"params\": \"bar\", \"baz]")
(json-resp (jsonify (elaborate-request json-req))))
(json-resp (->json (elaborate-request json-req))))
(assert-true
(string= json-resp
(strcat "{\"jsonrpc\":\"2.0\",\"error\":{\"code\":-32700,"
@ -102,7 +107,7 @@
(deftest test-invalid-request (json-rpc2-suite)
(let* ((json-req "{\"jsonrpc\": \"2.0\", \"method\": 1, \"params\": \"bar\"}")
(json-resp (jsonify (elaborate-request json-req))))
(json-resp (->json (elaborate-request json-req))))
(assert-true
(string= json-resp
(strcat "{\"jsonrpc\":\"2.0\",\"error\":"
@ -124,7 +129,7 @@
"]")))
(assert-equality #'string=
expected
(jsonify (elaborate-request (jsonify req)))))))
(->json (elaborate-request (->json req)))))))
(deftest test-batch-json-invalid (json-rpc2-suite)
(let* ((json-req (strcat "["
@ -132,7 +137,7 @@
"[1,2,4], \"id\": \"1\"},"
"{\"jsonrpc\": \"2.0\", \"method\""
"]"))
(json-resp (jsonify (elaborate-request json-req))))
(json-resp (->json (elaborate-request json-req))))
(assert-true
(string= json-resp
(strcat "{\"jsonrpc\":\"2.0\",\"error\":"
@ -140,7 +145,7 @@
(deftest test-batch-empty-array (json-rpc2-suite)
(let* ((json-req "[]")
(json-resp (jsonify (elaborate-request json-req))))
(json-resp (->json (elaborate-request json-req))))
(assert-true
(string= json-resp
(strcat "{\"jsonrpc\":\"2.0\",\"error\":"
@ -148,7 +153,7 @@
(deftest test-batch-invalid (json-rpc2-suite)
(let* ((json-req "[1]")
(json-resp (jsonify (elaborate-request json-req))))
(json-resp (->json (elaborate-request json-req))))
(assert-true
(string= json-resp
(strcat "["
@ -158,7 +163,7 @@
(deftest test-batch-invalid-2 (json-rpc2-suite)
(let* ((json-req "[1, 2, 3]")
(json-resp (jsonify (elaborate-request json-req))))
(json-resp (->json (elaborate-request json-req))))
(assert-true
(string= json-resp
(strcat "["
@ -177,4 +182,4 @@
"{\"jsonrpc\":\"2.0\",\"method\":\"notify_sum\",\"params\":[1,2,4]},"
"{\"jsonrpc\":\"2.0\",\"method\":\"notify_hello\",\"params\":[7]}"
"]")
nil))
"null"))