mirror of https://codeberg.org/cage/tinmop/
387 lines
21 KiB
Common Lisp
387 lines
21 KiB
Common Lisp
;; 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))))))))
|
|
|
|
(defclass parsed-lines-slice (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 (unbox 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-instance 'parsed-lines-slice :contents 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*)
|
|
|
|
(defun build-gemini-toc (iri)
|
|
(a:when-let* ((ordered-headers-tag '(:h1 :h2 :h3))
|
|
(stream-wrapper (gw:find-db-stream-url iri))
|
|
(parsed-lines (gw:parsed-lines stream-wrapper))
|
|
(headers (remove-if-not (lambda (a) (member (html-utils:tag a)
|
|
ordered-headers-tag))
|
|
parsed-lines)))
|
|
(flet ((extract-level (header)
|
|
(let ((tag (html-utils:tag header)))
|
|
(1+ (position tag ordered-headers-tag))))
|
|
(extract-gid (header)
|
|
(let ((attribute (html-utils:find-attribute :header-group-id header)))
|
|
(html-utils:attribute-value attribute)))
|
|
(extract-header-text (header)
|
|
(first (html-utils:children header)))
|
|
(find-longest-string (text-list)
|
|
(reduce (lambda (a b)
|
|
(if (>= (length a) (length b))
|
|
a
|
|
b))
|
|
text-list)))
|
|
(a:when-let* ((toc (message-window:gemini-sexp->toc-plist headers
|
|
#'identity
|
|
#'extract-level
|
|
#'extract-gid
|
|
#'extract-header-text))
|
|
(toc-text (mapcar (lambda (a) (getf a :header)) toc))
|
|
(longest-text (find-longest-string toc-text))
|
|
(max-text-length (length longest-text))
|
|
(toc-numbers (mapcar (lambda (a)
|
|
(let ((numbers-as-text
|
|
(mapcar (lambda (a)
|
|
(format nil "~a" a))
|
|
(getf a :number))))
|
|
(join-with-strings numbers-as-text ".")))
|
|
toc))
|
|
(longest-number (find-longest-string toc-numbers))
|
|
(max-number-length (length longest-number))
|
|
(max-non-padded-text-size (+ max-text-length max-number-length))
|
|
(toc-entries-text (loop for text in toc-text
|
|
for number in toc-numbers
|
|
collect
|
|
(let* ((text-length (+ (length text)
|
|
(length number)))
|
|
(padding-size (- max-non-padded-text-size
|
|
text-length))
|
|
(padding (make-string padding-size
|
|
:initial-element (swconf:gemini-toc-padding-char))))
|
|
(strcat number
|
|
padding
|
|
text)))))
|
|
(values
|
|
(loop for toc-entry in toc
|
|
for text in toc-entries-text
|
|
collect
|
|
(list :header-group-id (getf toc-entry :group-id)
|
|
:text text))
|
|
toc)))))
|
|
|
|
(defclass gemini-toc (box) ())
|
|
|
|
(defun encode-flat-array-of-plists (list stream)
|
|
(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 element in list do
|
|
(json:encode-array-element element))))))
|
|
|
|
(defun gemini-table-of-contents (iri)
|
|
(make-instance 'gemini-toc :contents (build-gemini-toc iri)))
|
|
|
|
(defmethod yason:encode ((object gemini-toc) &optional (stream *standard-output*))
|
|
(encode-flat-array-of-plists (unbox object) stream))
|