;; 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) (defclass iri-complete-response (box) ()) (a:define-constant +tofu-error-status-code+ -1 :test #'=) (defun debug-gemini-gui (&rest data) (apply #'gemini-client:debug-gemini (append (list (strcat "[gui] " (first data)) (rest data))))) (defmethod yason:encode ((object iri-complete-response) &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-object () (yason:with-object-element (:matches) (yason:encode-array-elements (list->array (getf (unbox object) :matches)))) (yason:with-object-element (:indices) (json:with-array () (loop for indices-group in (getf (unbox object) :indices) do (yason:encode-array-elements (list->array (remove-if #'null indices-group)))))))))) (defun complete-net-address (hint) (let ((prompt (ui:open-url-prompt))) (multiple-value-bind (matched-strings x indices) (funcall (complete:make-complete-gemini-iri-fn prompt) hint) (declare (ignore x)) (make-instance 'iri-complete-response :contents (list :matches matched-strings :indices indices))))) (defun request-stream-other-document-thread (wrapper-object socket host port path query fragment status-code status-code-description meta) (declare (ignorable host port path query fragment status-code status-code-description meta)) (with-accessors ((download-socket gemini-viewer:download-socket) (download-stream gemini-viewer:download-stream) (octect-count gemini-viewer:octect-count) (support-file gemini-viewer:support-file)) wrapper-object (lambda () (a:when-let ((extension (fs:get-extension path))) (setf support-file (fs:temporary-file :extension extension))) (gemini-viewer::with-open-support-file (file-stream support-file) (labels ((download-completed-p (buffer read-so-far) (and buffer (< read-so-far (length buffer)))) (%fill-buffer () (when (gemini-viewer:downloading-allowed-p wrapper-object) (multiple-value-bind (buffer read-so-far) (ignore-errors (read-array download-stream gemini-viewer::+read-buffer-size+)) (gemini-viewer::increment-bytes-count wrapper-object read-so-far) (write-sequence buffer file-stream :start 0 :end read-so-far) (force-output file-stream) (if (download-completed-p buffer read-so-far) (progn (setf (gemini-viewer:stream-status wrapper-object) :completed) (gemini-client:close-ssl-socket socket)) (%fill-buffer)))))) (%fill-buffer)))))) (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 ) (debug-gemini-gui "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 :notify nil :open-with-external-program nil))) (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) (debug-gemini-gui "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:code gemini-client:+success+) (gemini-client:description gemini-client:+success+) meta actual-iri)) (t (let* ((starting-status :streaming) (gemini-stream (make-instance 'gemini-viewer::gemini-others-data-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-stream response :download-socket socket)) (thread-fn (request-stream-other-document-thread gemini-stream socket host port path query fragment status code-description meta))) (debug-gemini-gui "response is *not* a gemini file stream") (gemini-viewer:push-db-stream gemini-stream) (gemini-viewer::downloading-start-thread gemini-stream thread-fn host port path query fragment) (make-gemini-response (gemini-client:code gemini-client:+success+) (gemini-client:description gemini-client:+success+) meta actual-iri))))))) (defun make-gemini-response (status-code status-code-description meta iri &key (cached nil)) (list (cons "status" status-code) (cons "status-description" status-code-description) (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 response socket)) (debug-gemini-gui "response redirect to: ~s" meta) (make-gemini-response status code-description meta iri)) (input-dispatch (status code-description meta response socket iri parsed-iri) (declare (ignore response socket parsed-iri)) (debug-gemini-gui "response requested input: ~s" meta) (make-gemini-response status code-description meta iri)) (sensitive-input-dispatch (status code-description meta response socket iri parsed-iri) (declare (ignore response socket parsed-iri)) (debug-gemini-gui "response requested sensitive input: ~s" meta) (make-gemini-response status code-description meta iri)) (certificate-request-dispatch (status code-description meta response socket iri parsed-iri) (declare (ignore status code-description response socket meta parsed-iri)) (debug-gemini-gui "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 t) (debug-gemini-gui "viewer requesting iri ~s" url) (let ((actual-iri (gemini-client:displace-iri (iri:iri-parse url)))) (db:gemlog-mark-as-seen actual-iri) (if use-cached-file-if-exists (let ((cached-stream (gemini-viewer:find-db-stream-url actual-iri))) (debug-gemini-gui "checking cache") (if cached-stream (progn (debug-gemini-gui "caching found for ~a" actual-iri) (gemini-viewer:push-url-to-history *gemini-window* actual-iri) (make-gemini-response (gw:status-code cached-stream) (gw:status-code-description cached-stream) (gw:meta cached-stream) actual-iri :cached t)) (progn (debug-gemini-gui "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)))) (progn (debug-gemini-gui "ignoring cache for ~a" actual-iri) (ignore-errors (gemini-remove-stream actual-iri)) (gemini-client:request-dispatch url gemini-client::dispatch-table :certificate certificate :certificate-key certificate-key))))) (gemini-client:gemini-tofu-error (e) (make-gemini-response +tofu-error-status-code+ (format nil "~a" e) (format nil "~a" e) url)) (conditions:not-implemented-error (e) (error (_ "Error: ~a") e)) (gemini-client:gemini-protocol-error (e) (make-gemini-response (gemini-client:error-code e) (gemini-client:error-description e) (gemini-client:meta e) url)) (error (e) (error (_ "Error getting ~s: ~a") url e)) (condition (c) (error (_ "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 make-no-such-stream-error (iri) (error (_ "no such stream ~s") iri)) (defun gemini-stream-parsed-line (iri line-number) (let ((stream-wrapper (gw:find-db-stream-url iri))) (if (null stream-wrapper) (make-no-such-stream-error iri) (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) (make-no-such-stream-error iri) (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 (make-no-such-stream-error iri)))) (defun gemini-remove-stream (iri) (let ((stream-wrapper (gw:find-db-stream-url iri))) (if stream-wrapper (gw:remove-db-stream stream-wrapper) (make-no-such-stream-error iri)))) (defun gemini-all-stream-info () gw:*gemini-streams-db*) (defun gemini-stream-status (iri) (let ((stream (gemini-stream-info iri))) (gw:stream-status stream))) (defun gemini-stream-completed-p (iri) (let ((status (gemini-stream-status iri))) (eq status :completed))) (defun parsed-lines-from-remore-iri (iri) (a:when-let ((stream-wrapper (gw:find-db-stream-url iri))) (gw:parsed-lines stream-wrapper))) (defun parsed-lines-from-local-path (path) (gemini-parser:parse-gemini-file (fs:slurp-file path))) (defun parsed-lines->toc (parsed-lines width) (a:when-let* ((ordered-headers-tag '(:h1 :h2 :h3)) (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) (trim-blanks (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 (1+ (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* ((prefix (right-padding number max-number-length :padding-char (swconf:gemini-toc-padding-char)))) (strcat prefix 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 (ellipsize text width))) toc))))) (defun build-gemini-toc (iri width) (a:when-let* ((parsed-lines (if (fs:file-exists-p iri) (parsed-lines-from-local-path iri) (parsed-lines-from-remore-iri iri)))) (parsed-lines->toc parsed-lines width))) (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 width) (make-instance 'gemini-toc :contents (build-gemini-toc iri width))) (defmethod yason:encode ((object gemini-toc) &optional (stream *standard-output*)) (encode-flat-array-of-plists (unbox object) stream)) (defun gemini-parse-string (string) (let ((parsed-lines (gemini-parser:parse-gemini-file string))) (make-instance 'parsed-lines-slice :contents (rearrange-parsed-line-for-encoding parsed-lines)))) (defun gemini-parse-local-file (path) (if (fs:file-exists-p path) (gemini-parse-string (fs:slurp-file path)) (error "No such file ~a" path))) (defun gemini-slurp-local-file (path) (fs:slurp-file path)) (defun make-error-page (iri code description meta) (let* ((separator (make-string 10 :initial-element gemini-parser::+h2-underline+)) (gemtext (with-output-to-string (stream) (write-sequence (gemini-parser:geminize-h2 (format nil "~a ~a~%" code description)) stream) (write-sequence (gemini-parser:geminize-preformatted separator) stream) (write-sequence (format nil "Error connecting to: ~a:~2%" iri) stream) (write-sequence (format nil "~a~%" meta) stream)))) (gemini-parse-string gemtext))) (defun gemini-save-url-db-history (iri) (db:insert-in-history (ui:open-url-prompt) iri))