mirror of https://codeberg.org/cage/tinmop/
- [RPC] refactored public API in multiple files.
This commit is contained in:
cage
parent
b0140d6fc6
commit
9b63978329
|
|
@ -0,0 +1,39 @@
|
|||
;; 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 (gemini-certificates (:include box)))
|
||||
|
||||
(defmethod yason:encode ((object gemini-certificates) &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)
|
||||
(yason:with-array ()
|
||||
(loop for certificate in (gemini-certificates-payload object) do
|
||||
(yason:encode-array-element certificate))))))
|
||||
|
||||
(defun gemini-certificates ()
|
||||
(make-gemini-certificates :payload (db:find-tls-certificates-rows)))
|
||||
|
||||
(defun invalidate-cached-value (cache-key)
|
||||
(db:cache-invalidate cache-key)
|
||||
t)
|
||||
|
||||
(defun gemini-delete-certificate (cache-key)
|
||||
(invalidate-cached-value cache-key))
|
||||
|
|
@ -0,0 +1,310 @@
|
|||
;; 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 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")
|
||||
(gemini-viewer:push-url-to-history *gemini-window* actual-iri)
|
||||
(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)))
|
||||
|
||||
(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)
|
||||
(gemini-viewer:push-url-to-history *gemini-window* 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)
|
||||
(error (format nil "TOFU error: ~a" e)))
|
||||
(conditions:not-implemented-error (e)
|
||||
(error (format nil (_ "Error: ~a") e)))
|
||||
(gemini-client:gemini-protocol-error (e)
|
||||
(error (format nil "~a" e)))
|
||||
(error (e)
|
||||
(error (format nil (_ "Error getting ~s: ~a") url e)))
|
||||
(condition (c)
|
||||
(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)
|
||||
(flet ((contains-children-p (node)
|
||||
(evenp (length node))))
|
||||
(loop for line in lines
|
||||
collect
|
||||
(let ((flattened (mapcar #'rearrange-for-encoding (a:flatten line))))
|
||||
(if (contains-children-p flattened)
|
||||
(append (list "type")
|
||||
(subseq flattened 0 (1- (length flattened)))
|
||||
(list "line" (a:last-elt flattened)))
|
||||
(cons "type" flattened))))))
|
||||
|
||||
(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)
|
||||
(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))
|
||||
(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)))))))))
|
||||
|
||||
(defun gemini-stream-parsed-line (iri line-number)
|
||||
(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 (:include box)))
|
||||
|
||||
(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-payload 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 :payload res))))))))
|
||||
|
||||
(defun gemini-stream-info (iri)
|
||||
(let ((stream-wrapper (gw:find-db-stream-url iri)))
|
||||
(if stream-wrapper
|
||||
stream-wrapper
|
||||
(error "no such stream"))))
|
||||
|
||||
(defun gemini-all-stream-info ()
|
||||
gw:*gemini-streams-db*)
|
||||
|
|
@ -0,0 +1,38 @@
|
|||
;; 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 tour-shuffle ()
|
||||
(shuffle-tour *gemini-window*))
|
||||
|
||||
(defun tour-add-link (link-value link-label)
|
||||
(add-tour-link *gemini-window*
|
||||
(make-instance 'gemini-parser:gemini-link
|
||||
:name link-label
|
||||
:target link-value)))
|
||||
|
||||
(defun tour-pop-link ()
|
||||
(a:when-let ((link (pop-tour-link *gemini-window*)))
|
||||
(list :link-value (gemini-parser:target link)
|
||||
:link-label (gemini-parser:name link))))
|
||||
|
||||
(defun tour-delete-link (url)
|
||||
(delete-tour-link-element *gemini-window* url))
|
||||
|
||||
(defun clear-tour ()
|
||||
(clear-tour-link *gemini-window*))
|
||||
|
|
@ -25,342 +25,6 @@
|
|||
,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")
|
||||
(gemini-viewer:push-url-to-history *gemini-window* actual-iri)
|
||||
(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)))
|
||||
|
||||
(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)
|
||||
(gemini-viewer:push-url-to-history *gemini-window* 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)
|
||||
(error (format nil "TOFU error: ~a" e)))
|
||||
(conditions:not-implemented-error (e)
|
||||
(error (format nil (_ "Error: ~a") e)))
|
||||
(gemini-client:gemini-protocol-error (e)
|
||||
(error (format nil "~a" e)))
|
||||
(error (e)
|
||||
(error (format nil (_ "Error getting ~s: ~a") url e)))
|
||||
(condition (c)
|
||||
(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)
|
||||
(flet ((contains-children-p (node)
|
||||
(evenp (length node))))
|
||||
(loop for line in lines
|
||||
collect
|
||||
(let ((flattened (mapcar #'rearrange-for-encoding (a:flatten line))))
|
||||
(if (contains-children-p flattened)
|
||||
(append (list "type")
|
||||
(subseq flattened 0 (1- (length flattened)))
|
||||
(list "line" (a:last-elt flattened)))
|
||||
(cons "type" flattened))))))
|
||||
|
||||
(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)
|
||||
(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))
|
||||
(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)))))))))
|
||||
|
||||
(defun gemini-stream-parsed-line (iri line-number)
|
||||
(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 box
|
||||
(payload))
|
||||
|
||||
(defstruct (parsed-lines-slice (:include box)))
|
||||
|
||||
(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-payload 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 :payload res))))))))
|
||||
|
||||
(defun gemini-stream-info (iri)
|
||||
(let ((stream-wrapper (gw:find-db-stream-url iri)))
|
||||
(if stream-wrapper
|
||||
stream-wrapper
|
||||
(error "no such stream"))))
|
||||
|
||||
(defun gemini-all-stream-info ()
|
||||
gw:*gemini-streams-db*)
|
||||
|
||||
(defstruct (gemini-certificates (:include box)))
|
||||
|
||||
(defmethod yason:encode ((object gemini-certificates) &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)
|
||||
(yason:with-array ()
|
||||
(loop for certificate in (gemini-certificates-payload object) do
|
||||
(yason:encode-array-element certificate))))))
|
||||
|
||||
(defun gemini-certificates ()
|
||||
(make-gemini-certificates :payload (db:find-tls-certificates-rows)))
|
||||
|
||||
(defun invalidate-cached-value (cache-key)
|
||||
(db:cache-invalidate cache-key)
|
||||
t)
|
||||
|
||||
(defun gemini-delete-certificate (cache-key)
|
||||
(invalidate-cached-value cache-key))
|
||||
|
||||
(defun tour-shuffle ()
|
||||
(shuffle-tour *gemini-window*))
|
||||
|
||||
(defun tour-add-link (link-value link-label)
|
||||
(add-tour-link *gemini-window*
|
||||
(make-instance 'gemini-parser:gemini-link
|
||||
:name link-label
|
||||
:target link-value)))
|
||||
|
||||
(defun tour-pop-link ()
|
||||
(a:when-let ((link (pop-tour-link *gemini-window*)))
|
||||
(list :link-value (gemini-parser:target link)
|
||||
:link-label (gemini-parser:name link))))
|
||||
|
||||
(defun tour-delete-link (url)
|
||||
(delete-tour-link-element *gemini-window* url))
|
||||
|
||||
(defun clear-tour ()
|
||||
(clear-tour-link *gemini-window*))
|
||||
|
||||
(defun quit-program ()
|
||||
(fs:clean-temporary-directories)
|
||||
(fs:clean-temporary-files)
|
||||
|
|
|
|||
|
|
@ -149,6 +149,9 @@
|
|||
(:module gui-server
|
||||
:pathname "gui/server"
|
||||
:components ((:file "main-window-server-side")
|
||||
(:file "public-api-gemini-stream")
|
||||
(:file "public-api-gemini-certificates")
|
||||
(:file "public-api-gemini-tour-links")
|
||||
(:file "public-api")
|
||||
(:file "json-rpc-communication")))
|
||||
(:module gui-client
|
||||
|
|
|
|||
Loading…
Reference in New Issue