2022-12-30 11:07:30 +01:00
|
|
|
;; 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)
|
2023-01-01 14:57:08 +01:00
|
|
|
(error (format nil "TOFU error: ~a" e)))
|
2022-12-30 11:07:30 +01:00
|
|
|
(conditions:not-implemented-error (e)
|
2023-01-01 14:57:08 +01:00
|
|
|
(error (format nil (_ "Error: ~a") e)))
|
2022-12-30 11:07:30 +01:00
|
|
|
(gemini-client:gemini-protocol-error (e)
|
2023-01-01 14:57:08 +01:00
|
|
|
(error (format nil "~a" e)))
|
2022-12-30 11:07:30 +01:00
|
|
|
(error (e)
|
2023-01-01 14:57:08 +01:00
|
|
|
(error (format nil (_ "Error getting ~s: ~a") url e)))
|
2022-12-30 11:07:30 +01:00
|
|
|
(condition (c)
|
2023-01-01 14:57:08 +01:00
|
|
|
(error (format nil (_ "Error getting ~s: ~a") url c))))))
|
2022-12-30 11:07:30 +01:00
|
|
|
|
|
|
|
(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)
|
2023-01-01 11:11:40 +01:00
|
|
|
(flet ((contains-chldren-p (node)
|
|
|
|
(evenp (length node))))
|
2023-01-01 20:05:20 +01:00
|
|
|
(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)))))))))
|
2022-12-30 11:07:30 +01:00
|
|
|
|
|
|
|
(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)))
|
|
|
|
(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)))))
|
|
|
|
|
2023-01-01 18:31:27 +01:00
|
|
|
(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))))
|
|
|
|
|
2022-12-30 11:07:30 +01:00
|
|
|
(defun gemini-stream-info (iri)
|
2023-01-01 20:05:20 +01:00
|
|
|
(let ((stream-wrapper (gw:find-db-stream-url iri)))
|
|
|
|
(if stream-wrapper
|
|
|
|
(rpc::render-as-list stream-wrapper)
|
|
|
|
(error "no such stream"))))
|
2022-12-30 11:07:30 +01:00
|
|
|
|
|
|
|
(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)
|
2023-01-01 18:31:27 +01:00
|
|
|
(gen-rpc "gemini-stream-parsed-line"
|
|
|
|
'gemini-stream-parsed-line
|
|
|
|
"iri" 0
|
|
|
|
"line-number" 1)
|
2022-12-30 11:07:30 +01:00
|
|
|
,@body))
|