mirror of https://codeberg.org/cage/tinmop/
970 lines
50 KiB
Common Lisp
970 lines
50 KiB
Common Lisp
;; tinmop: a multiprotocol client
|
|
;; Copyright © 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 :gemini-viewer)
|
|
|
|
(defparameter *gemini-db-streams-lock* (make-lock))
|
|
|
|
(define-constant +read-buffer-size+ 2048 :test #'=
|
|
:documentation "Chunk's size of the buffer when reading non gemini contents from stream")
|
|
|
|
(defparameter *gemini-streams-db* ())
|
|
|
|
(defun push-db-stream (stream-object)
|
|
(pushnew stream-object
|
|
*gemini-streams-db*
|
|
:test (lambda (a b)
|
|
(string= (download-iri a)
|
|
(download-iri b))))
|
|
*gemini-streams-db*)
|
|
|
|
(defun remove-db-stream (stream-object)
|
|
(setf *gemini-streams-db*
|
|
(remove stream-object *gemini-streams-db*))
|
|
*gemini-streams-db*)
|
|
|
|
(defun remove-all-db-stream ()
|
|
(map nil
|
|
(lambda (a) (abort-downloading a))
|
|
*gemini-streams-db*)
|
|
(setf *gemini-streams-db* ())
|
|
*gemini-streams-db*)
|
|
|
|
(defun find-db-stream-if (predicate)
|
|
(find-if predicate *gemini-streams-db*))
|
|
|
|
(defun find-db-stream-url (url)
|
|
(find-db-stream-if (lambda (a) (string= (download-iri a) url))))
|
|
|
|
(defun ensure-just-one-stream-rendering ()
|
|
(with-lock-held (*gemini-db-streams-lock*)
|
|
(when-let ((current-rendering (find-db-stream-if (lambda (a)
|
|
(eq (stream-status a)
|
|
:rendering)))))
|
|
(setf (stream-status current-rendering) :streaming))))
|
|
|
|
(defun abort-download-stream (url &key
|
|
(remove-wainting-stream-event t)
|
|
(redraw-stream-window t))
|
|
(when-let ((stream-object (find-db-stream-url url)))
|
|
(abort-downloading stream-object)
|
|
(remove-db-stream stream-object)
|
|
(when remove-wainting-stream-event
|
|
(program-events:remove-event-if (lambda (a)
|
|
(and (typep a
|
|
'program-events:gemini-got-line-event)
|
|
(string= url
|
|
(download-iri stream-object))))))
|
|
(when (and redraw-stream-window
|
|
specials:*gemini-streams-window*)
|
|
(line-oriented-window:resync-rows-db specials:*gemini-streams-window*))))
|
|
|
|
(defun bury-download-stream ()
|
|
(let ((program-events:*process-events-immediately* t)
|
|
(event (make-instance 'program-events:gemini-push-behind-downloading-event
|
|
:priority program-events:+maximum-event-priority+)))
|
|
(program-events:push-event event)))
|
|
|
|
(defun force-rendering-of-cached-file (stream-object)
|
|
;; this is more than a mere setter
|
|
;; and is 'eql' specialized on rendering
|
|
;; it will force displaying of gemini cached file on the screen
|
|
(setf (stream-status stream-object) :rendering))
|
|
|
|
(defun db-entry-to-foreground (iri)
|
|
(when-let* ((stream-object (find-db-stream-url iri)))
|
|
(with-accessors ((support-file support-file)
|
|
(meta meta)) stream-object
|
|
(cond
|
|
((gemini-client:mime-gemini-p meta)
|
|
(ensure-just-one-stream-rendering)
|
|
(force-rendering-of-cached-file stream-object)
|
|
(setf (stream-status stream-object) :completed)
|
|
(ui:open-gemini-toc)
|
|
(program-events:with-enqueued-process ()
|
|
(ui:open-gemini-message-link-window :give-focus nil)))
|
|
((and (gemini-client:text-file-stream-p meta)
|
|
(os-utils:open-resource-with-tinmop-p iri))
|
|
(ensure-just-one-stream-rendering)
|
|
(force-rendering-of-cached-file stream-object)
|
|
(setf (stream-status stream-object) :completed))
|
|
(t
|
|
(os-utils:open-resource-with-external-program support-file t))))))
|
|
|
|
(defclass gemini-stream ()
|
|
((download-thread-lock
|
|
:initform (make-lock "download-gemini")
|
|
:initarg :download-thread-lock
|
|
:accessor download-thread-lock)
|
|
(download-thread-blocked
|
|
:initform nil
|
|
:initarg :download-thread-blocked
|
|
:reader download-thread-blocked-p
|
|
:writer (setf download-thread-blocked))
|
|
(stream-status
|
|
:initform nil
|
|
:initarg :stream-status)
|
|
(download-iri
|
|
:initform nil
|
|
:initarg :download-iri
|
|
:accessor download-iri)
|
|
(start-time
|
|
:initform (db-utils:local-time-obj-now)
|
|
:initarg :start-time
|
|
:accessor start-time)
|
|
(download-stream
|
|
:initform nil
|
|
:initarg :download-stream
|
|
:accessor download-stream)
|
|
(download-socket
|
|
:initform nil
|
|
:initarg :download-socket
|
|
:accessor download-socket)
|
|
(support-file
|
|
:initform (fs:temporary-file)
|
|
:initarg :support-file
|
|
:accessor support-file)
|
|
(parsed-lines
|
|
:initform '()
|
|
:initarg :parsed-lines
|
|
:accessor parsed-lines)
|
|
(octect-count
|
|
:initform 0
|
|
:initarg :octect-count
|
|
:accessor octect-count)
|
|
(port
|
|
:initform nil
|
|
:initarg :port
|
|
:accessor port)
|
|
(status-code
|
|
:initform nil
|
|
:initarg :status-code
|
|
:accessor status-code)
|
|
(status-code-description
|
|
:initform nil
|
|
:initarg :status-code-description
|
|
:accessor status-code-description)
|
|
(meta
|
|
:initform nil
|
|
:initarg :meta
|
|
:accessor meta)
|
|
(path
|
|
:initform nil
|
|
:initarg :path
|
|
:accessor path)
|
|
(query
|
|
:initform nil
|
|
:initarg :query
|
|
:accessor query)
|
|
(fragment
|
|
:initform nil
|
|
:initarg :fragment
|
|
:accessor fragment)
|
|
(host
|
|
:initform nil
|
|
:initarg :host
|
|
:accessor host)
|
|
(thread
|
|
:initform nil
|
|
:initarg :thread
|
|
:accessor thread)))
|
|
|
|
(defmethod print-object ((object gemini-stream) stream)
|
|
(print-unreadable-object (object stream :type t :identity t)
|
|
(format stream
|
|
"~a ~d ~a ~a"
|
|
(download-iri object)
|
|
(octect-count object)
|
|
(meta object)
|
|
(stream-status object))))
|
|
|
|
(defmethod to-tui-string ((object gemini-stream) &key (window nil))
|
|
(flet ((pad (string width)
|
|
(right-padding (ellipsize string width) width)))
|
|
(let* ((window-width (win-width window))
|
|
(url-w (truncate (* window-width 2/3)))
|
|
(octect-count-w (truncate (* window-width 1/9)))
|
|
(meta-w (truncate (* window-width 1/9)))
|
|
(status-w (truncate (* window-width 1/9)))
|
|
(color-re (swconf:color-regexps))
|
|
(fitted-line (format nil
|
|
"~a ~d ~a ~a"
|
|
(pad (download-iri object) url-w)
|
|
(pad (to-s (octect-count object))
|
|
octect-count-w)
|
|
(pad (meta object) meta-w)
|
|
(ellipsize (string-downcase (format nil
|
|
"~s"
|
|
(stream-status object)))
|
|
status-w))))
|
|
(loop for re in color-re do
|
|
(setf fitted-line (colorize-line fitted-line re)))
|
|
(colorized-line->tui-string fitted-line))))
|
|
|
|
(defgeneric abort-downloading (object))
|
|
|
|
(defgeneric allow-downloading (object))
|
|
|
|
(defgeneric downloading-allowed-p (object))
|
|
|
|
(defgeneric downloading-start-thread (object function host port path query fragment))
|
|
|
|
(defmethod abort-downloading ((object gemini-stream))
|
|
(with-accessors ((download-thread-lock download-thread-lock)) object
|
|
(setf (stream-status object) :aborted)
|
|
(with-lock-held (download-thread-lock)
|
|
(setf (download-thread-blocked object) t))))
|
|
|
|
(defmethod allow-downloading ((object gemini-stream))
|
|
(with-accessors ((download-thread-lock download-thread-lock)) object
|
|
(with-lock-held (download-thread-lock)
|
|
(setf (download-thread-blocked object) nil))))
|
|
|
|
(defmethod downloading-allowed-p ((object gemini-stream))
|
|
(with-accessors ((download-thread-lock download-thread-lock)) object
|
|
(with-lock-held (download-thread-lock)
|
|
(not (download-thread-blocked-p object)))))
|
|
|
|
(defmethod (setf stream-status) (val (object gemini-stream))
|
|
(with-accessors ((download-thread-lock download-thread-lock)
|
|
(stream-status stream-status)) object
|
|
(with-lock-held (download-thread-lock)
|
|
(setf (slot-value object 'stream-status) val))))
|
|
|
|
(defmethod stream-status ((object gemini-stream))
|
|
(with-accessors ((download-thread-lock download-thread-lock)) object
|
|
(with-lock-held (download-thread-lock)
|
|
(slot-value object 'stream-status))))
|
|
|
|
(defmethod downloading-start-thread ((object gemini-stream)
|
|
function
|
|
host
|
|
port
|
|
path
|
|
query
|
|
fragment)
|
|
(with-accessors ((start-time start-time)
|
|
(thread thread)
|
|
(stream-status stream-status)
|
|
(download-iri download-iri)) object
|
|
(setf thread (make-thread function))
|
|
(setf start-time (db-utils:local-time-obj-now))
|
|
(setf download-iri (gemini-parser:make-gemini-iri host
|
|
path
|
|
:query query
|
|
:port port
|
|
:fragment fragment))
|
|
object))
|
|
|
|
(defclass gemini-file-stream (gemini-stream) ())
|
|
|
|
(defmethod (setf stream-status) :after ((val (eql :rendering)) (object gemini-file-stream))
|
|
(with-accessors ((download-thread-lock download-thread-lock)
|
|
(support-file support-file)
|
|
(parsed-lines parsed-lines)) object
|
|
(with-lock-held (download-thread-lock)
|
|
(gemini-parser:with-initialized-parser
|
|
(let ((event (make-gemini-download-event (fs:slurp-file support-file)
|
|
parsed-lines
|
|
object
|
|
nil)))
|
|
(program-events:push-event event))))))
|
|
|
|
(defclass gemini-others-data-stream (gemini-stream) ())
|
|
|
|
(defmacro with-open-support-file ((stream file &optional (element-type '(unsigned-byte 8)))
|
|
&body body)
|
|
`(handler-case
|
|
(with-open-file (,stream ,file
|
|
:element-type ',element-type
|
|
:direction :output
|
|
:element-type 'character
|
|
:if-exists :supersede
|
|
:if-does-not-exist :create)
|
|
,@body)
|
|
(file-error (condition)
|
|
(declare (ignore condition))
|
|
nil)))
|
|
|
|
(defgeneric increment-bytes-count (object data &key &allow-other-keys))
|
|
|
|
(defmethod increment-bytes-count ((object gemini-stream) data
|
|
&key (convert-to-octects nil))
|
|
(with-accessors ((octect-count octect-count)) object
|
|
(if convert-to-octects
|
|
(incf octect-count (babel:string-size-in-octets data
|
|
:errorp nil))
|
|
(incf octect-count (length data)))))
|
|
|
|
(defmethod increment-bytes-count ((object gemini-stream) (data number)
|
|
&key &allow-other-keys)
|
|
(with-accessors ((octect-count octect-count)) object
|
|
(incf octect-count data)))
|
|
|
|
(defun make-gemini-download-event (src-data parsed-data stream-object append-text)
|
|
(with-accessors ((download-iri download-iri)
|
|
(host host)
|
|
(port port)
|
|
(path path)
|
|
(meta meta)
|
|
(query query)
|
|
(parsed-lines parsed-lines)
|
|
(status-code status-code)
|
|
(status-code-description status-code-description)) stream-object
|
|
(let* ((links (gemini-parser:sexp->links parsed-data host port path query))
|
|
(response (gemini-client:make-gemini-file-response status-code
|
|
status-code-description
|
|
meta
|
|
parsed-data
|
|
download-iri
|
|
src-data
|
|
links)))
|
|
(make-instance 'program-events:gemini-got-line-event
|
|
:wrapper-object stream-object
|
|
:payload response
|
|
:append-text append-text))))
|
|
|
|
(let ((cache ()))
|
|
(defun fetch-favicon (parsed-url)
|
|
(if (not (swconf:gemini-fetch-favicon-p))
|
|
(swconf:gemini-default-favicon)
|
|
(flet ((fetch-from-cache (key)
|
|
(assoc-value cache key :test #'string=)))
|
|
(multiple-value-bind (actual-iri host path query port fragment)
|
|
(gemini-client:displace-iri parsed-url)
|
|
(declare (ignore actual-iri path query fragment))
|
|
(or (fetch-from-cache host)
|
|
(ignore-errors
|
|
(let* ((favicon-url (gemini-parser:make-gemini-iri host
|
|
"/favicon.txt"
|
|
:port port))
|
|
(response-body (gemini-client:slurp-gemini-url favicon-url))
|
|
(favicon-list (coerce (text-utils:to-s response-body :errorp t)
|
|
'list))
|
|
(emoji (starting-emoji favicon-list))
|
|
(favicon (if emoji
|
|
(coerce emoji 'string)
|
|
(swconf:gemini-default-favicon))))
|
|
(setf cache (acons host favicon cache))
|
|
(fetch-favicon parsed-url)))
|
|
(swconf:gemini-default-favicon)))))))
|
|
|
|
(defun fragment->regex (fragment)
|
|
(when (and fragment
|
|
(swconf:config-gemini-fragment-as-regex-p))
|
|
(if (text-utils:percent-encoded-p fragment)
|
|
(text-utils:percent-decode fragment)
|
|
fragment)))
|
|
|
|
(defun request-stream-gemini-document-thread (wrapper-object host
|
|
port path query fragment favicon
|
|
gemini-format-p
|
|
&key
|
|
(notify t)
|
|
(open-with-external-program t))
|
|
(with-accessors ((download-socket download-socket)
|
|
(download-stream download-stream)
|
|
(octect-count octect-count)
|
|
(support-file support-file)) wrapper-object
|
|
(labels ((rendering-in-tinmop-p ()
|
|
(or gemini-format-p
|
|
(and (os-utils:open-resource-with-tinmop-p (download-iri wrapper-object))
|
|
(eq (stream-status wrapper-object) :rendering))))
|
|
(maybe-render-line (line-event)
|
|
(when (rendering-in-tinmop-p)
|
|
(program-events:push-event line-event)))
|
|
(maybe-change-title (title-event)
|
|
(when (rendering-in-tinmop-p)
|
|
(program-events:push-event title-event)))
|
|
(maybe-render-toc ()
|
|
(when (rendering-in-tinmop-p)
|
|
(ui:open-gemini-toc)))
|
|
(maybe-render-focus-mark ()
|
|
(when (rendering-in-tinmop-p)
|
|
(program-events:with-enqueued-process ()
|
|
(windows:draw-focus-mark *message-window*))))
|
|
(maybe-render-links ()
|
|
(when (rendering-in-tinmop-p)
|
|
(program-events:with-enqueued-process ()
|
|
(ui:open-gemini-message-link-window :give-focus nil))))
|
|
(maybe-render-preformat-wrapper (file-stream wrapper-object)
|
|
(when (and (os-utils:open-resource-with-tinmop-p (download-iri wrapper-object))
|
|
(not gemini-format-p))
|
|
(let* ((preformat-line (format nil "~a~%" gemini-parser:+preformatted-prefix+))
|
|
(parsed-line (gemini-parser:parse-gemini-file preformat-line)))
|
|
(setf (parsed-lines wrapper-object)
|
|
(append (parsed-lines wrapper-object)
|
|
parsed-line))
|
|
(let ((preformat-wrapper-event (make-gemini-download-event preformat-line
|
|
parsed-line
|
|
wrapper-object
|
|
t)))
|
|
(maybe-render-line preformat-wrapper-event)
|
|
(write-sequence preformat-line file-stream)))))
|
|
(array->string (array remove-bom)
|
|
(let ((res (text-utils:to-s array :errorp nil)))
|
|
(if (and (string-not-empty-p res)
|
|
remove-bom
|
|
(char= (first-elt res)
|
|
#\ZERO_WIDTH_NO-BREAK_SPACE))
|
|
(subseq res 1)
|
|
res)))
|
|
(maybe-notify (message)
|
|
(when notify
|
|
(ui:notify message))))
|
|
(lambda ()
|
|
(gemini-parser:with-initialized-parser
|
|
(when-let ((extension (fs:get-extension path)))
|
|
(setf support-file (fs:temporary-file :extension extension)))
|
|
(with-open-support-file (file-stream support-file character)
|
|
(let* ((url (gemini-parser:make-gemini-iri host
|
|
path
|
|
:query query
|
|
:port port
|
|
:fragment fragment))
|
|
(url-header (format nil "~a ~a~2%" favicon url))
|
|
(parsed-url (gemini-parser:parse-gemini-file url-header))
|
|
(url-response (gemini-client:make-gemini-file-response nil
|
|
nil
|
|
nil
|
|
parsed-url
|
|
nil
|
|
""
|
|
nil))
|
|
(url-event (make-instance 'program-events:gemini-got-line-event
|
|
:wrapper-object wrapper-object
|
|
:payload url-response
|
|
:append-text nil))
|
|
(new-title-event (make-instance 'program-events:change-window-title-event
|
|
:payload url-header
|
|
:window *message-window*)))
|
|
(write-sequence url-header file-stream)
|
|
(increment-bytes-count wrapper-object url-header :convert-to-octects t)
|
|
(setf (parsed-lines wrapper-object)
|
|
(gemini-parser:parse-gemini-file url-header))
|
|
(maybe-change-title new-title-event)
|
|
(maybe-render-line url-event)
|
|
(maybe-render-preformat-wrapper file-stream wrapper-object)
|
|
(loop
|
|
named download-loop
|
|
for ct from 0
|
|
for line-as-array = (with-print-error-message
|
|
(read-line-into-array download-stream))
|
|
while line-as-array do
|
|
(gemini-client:debug-gemini "[stream] gemini file stream raw data line : ~a"
|
|
line-as-array)
|
|
(if (downloading-allowed-p wrapper-object)
|
|
(let* ((line (if (= ct 0)
|
|
(array->string line-as-array t)
|
|
(array->string line-as-array nil)))
|
|
(parsed-line (gemini-parser:parse-gemini-file line)))
|
|
(gemini-client:debug-gemini "[stream] gemini file stream got data line : ~a"
|
|
line)
|
|
(write-sequence line file-stream)
|
|
(increment-bytes-count wrapper-object line :convert-to-octects t)
|
|
(setf (parsed-lines wrapper-object)
|
|
(append (parsed-lines wrapper-object)
|
|
parsed-line))
|
|
(let ((event (make-gemini-download-event line
|
|
parsed-line
|
|
wrapper-object
|
|
t)))
|
|
(maybe-render-line event)))
|
|
(progn
|
|
(return-from download-loop nil))))
|
|
(maybe-render-preformat-wrapper file-stream wrapper-object)
|
|
(cond
|
|
((not (downloading-allowed-p wrapper-object))
|
|
(maybe-notify (_ "Gemini document downloading aborted")))
|
|
((rendering-in-tinmop-p)
|
|
(maybe-render-toc)
|
|
(maybe-render-links)
|
|
(maybe-render-focus-mark)
|
|
(maybe-notify (_ "Gemini document downloading completed"))
|
|
(setf (stream-status wrapper-object) :completed)
|
|
(when (and fragment
|
|
(swconf:config-gemini-fragment-as-regex-p))
|
|
(when-let* ((regex (fragment->regex fragment))
|
|
(priority program-events:+standard-event-priority+)
|
|
(event (make-instance 'program-events:search-message-gemini-fragment-event
|
|
:priority priority
|
|
:payload regex)))
|
|
(program-events:push-event event))))
|
|
(open-with-external-program
|
|
(os-utils:open-resource-with-external-program support-file nil)))
|
|
;; (allow-downloading wrapper-object)
|
|
(gemini-client:close-ssl-socket download-socket))))))))
|
|
;; (fs:delete-file-if-exists support-file)))))
|
|
|
|
(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 download-socket)
|
|
(download-stream download-stream)
|
|
(octect-count octect-count)
|
|
(support-file support-file)) wrapper-object
|
|
(lambda ()
|
|
(when-let ((extension (fs:get-extension path)))
|
|
(setf support-file (fs:temporary-file :extension extension)))
|
|
(with-open-support-file (file-stream support-file)
|
|
(let ((partial-content-not-opened t))
|
|
(labels ((download-completed-p (buffer read-so-far)
|
|
(and buffer
|
|
(< read-so-far (length buffer))))
|
|
(opening-partial-contents-p (read-so-far)
|
|
(let ((buffer-size (swconf:link-regex->program-to-use-buffer-size path)))
|
|
(if buffer-size
|
|
(> read-so-far buffer-size)
|
|
(> read-so-far swconf:+buffer-minimum-size-to-open+))))
|
|
(%fill-buffer ()
|
|
(declare (optimize (debug 0) (speed 3)))
|
|
(when (downloading-allowed-p wrapper-object)
|
|
(multiple-value-bind (program-exists y wait-for-download)
|
|
(swconf:link-regex->program-to-use support-file)
|
|
(declare (ignore y))
|
|
(multiple-value-bind (buffer read-so-far)
|
|
(with-print-error-message
|
|
(read-array download-stream +read-buffer-size+))
|
|
(declare ((or null
|
|
(vector (unsigned-byte 8)))
|
|
buffer))
|
|
(declare ((or null fixnum) read-so-far))
|
|
(increment-bytes-count wrapper-object read-so-far)
|
|
(if (download-completed-p buffer read-so-far)
|
|
(progn
|
|
(write-sequence buffer file-stream :start 0 :end read-so-far)
|
|
(force-output file-stream)
|
|
(setf (stream-status wrapper-object) :completed)
|
|
(gemini-client:close-ssl-socket socket)
|
|
(when (or wait-for-download
|
|
partial-content-not-opened)
|
|
(os-utils:open-resource-with-external-program support-file
|
|
nil)))
|
|
(progn
|
|
(write-sequence buffer file-stream)
|
|
(when (and partial-content-not-opened
|
|
program-exists
|
|
(not wait-for-download)
|
|
(opening-partial-contents-p (octect-count wrapper-object)))
|
|
(setf partial-content-not-opened nil)
|
|
(os-utils:open-resource-with-external-program support-file
|
|
nil))
|
|
(%fill-buffer))))))))
|
|
(%fill-buffer)))))))
|
|
|
|
(defun request-success-dispatched-clrs (enqueue)
|
|
(lambda (status code-description meta response socket iri parsed-iri)
|
|
(labels ((starting-status (meta)
|
|
(if (or (gemini-client:gemini-file-stream-p meta)
|
|
(gemini-client:text-file-stream-p meta))
|
|
(if enqueue
|
|
:streaming
|
|
:rendering)
|
|
(if enqueue
|
|
:streaming
|
|
:running))))
|
|
(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 (starting-status meta))
|
|
(gemini-stream (make-instance '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-stream response
|
|
:download-socket socket))
|
|
(favicon (fetch-favicon parsed-iri))
|
|
(thread-fn (request-stream-gemini-document-thread gemini-stream
|
|
host
|
|
port
|
|
path
|
|
query
|
|
fragment
|
|
favicon
|
|
gemini-format-p))
|
|
(enqueue-event (make-instance 'program-events:gemini-enqueue-download-event
|
|
:payload gemini-stream)))
|
|
(program-events:push-event enqueue-event)
|
|
(downloading-start-thread gemini-stream
|
|
thread-fn
|
|
host
|
|
port
|
|
path
|
|
query
|
|
fragment))))
|
|
(cond
|
|
((gemini-client:absolute-titan-url-p iri)
|
|
(gemini-client:debug-gemini "response from titan nothing to do"))
|
|
((gemini-client:gemini-file-stream-p meta)
|
|
(gemini-client:debug-gemini "response is a gemini document stream")
|
|
(push-url-to-history specials:*message-window* actual-iri)
|
|
(make-text-based-stream t))
|
|
((gemini-client:text-file-stream-p meta)
|
|
(gemini-client:debug-gemini "response is a text stream")
|
|
(make-text-based-stream nil))
|
|
(t
|
|
(let* ((starting-status (starting-status meta))
|
|
(gemini-stream (make-instance '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))
|
|
(enqueue-event (make-instance 'program-events:gemini-enqueue-download-event
|
|
:payload gemini-stream)))
|
|
(gemini-client:debug-gemini "response is *not* a gemini file stream")
|
|
(program-events:push-event enqueue-event)
|
|
(downloading-start-thread gemini-stream
|
|
thread-fn
|
|
host
|
|
port
|
|
path
|
|
query
|
|
fragment)))))))))
|
|
|
|
(defun request (url &key
|
|
(titan-data nil)
|
|
(titan-mime nil)
|
|
(titan-size nil)
|
|
(titan-token nil)
|
|
(enqueue nil)
|
|
(certificate nil)
|
|
(certificate-key nil)
|
|
(certificate-key-password nil)
|
|
(use-cached-file-if-exists nil)
|
|
(do-nothing-if-exists-in-db nil))
|
|
(labels ((get-user-input (hide-input url prompt)
|
|
(multiple-value-bind (actual-iri host path query port fragment)
|
|
(gemini-client:displace-iri (iri:iri-parse url))
|
|
(declare (ignore actual-iri query fragment))
|
|
(flet ((on-input-complete (input)
|
|
(when (string-not-empty-p input)
|
|
(db-utils:with-ready-database (:connect nil)
|
|
(let ((encoded-input (maybe-percent-encode input)))
|
|
(request (gemini-parser:make-gemini-iri host
|
|
path
|
|
:query
|
|
encoded-input
|
|
:port port)
|
|
:certificate-key certificate-key
|
|
:certificate-key-password certificate-key-password
|
|
:certificate certificate
|
|
:do-nothing-if-exists-in-db nil))))))
|
|
(ui:ask-string-input #'on-input-complete
|
|
:priority
|
|
program-events:+minimum-event-priority+
|
|
:hide-input hide-input
|
|
:prompt (format nil
|
|
(_ "Server ~s asks: ~s ")
|
|
host
|
|
prompt)))))
|
|
(redirect-dispatch (status code-description meta response socket iri parsed-iri)
|
|
(declare (ignore status code-description response socket iri))
|
|
(gemini-client:debug-gemini "response redirect to: ~s" meta)
|
|
(flet ((on-input-complete (maybe-accepted)
|
|
(when (ui::boolean-input-accepted-p maybe-accepted)
|
|
(pop-url-from-history specials:*message-window*)
|
|
(when-let ((new-url (gemini-client:build-redirect-iri meta
|
|
parsed-iri)))
|
|
(db-utils:with-ready-database (:connect nil)
|
|
(request new-url
|
|
:enqueue enqueue
|
|
:certificate-key certificate-key
|
|
:certificate-key-password certificate-key-password
|
|
:certificate certificate))))))
|
|
(ui:ask-string-input #'on-input-complete
|
|
:priority program-events:+minimum-event-priority+
|
|
:prompt
|
|
(format nil
|
|
(_ "Redirects to ~s, follows redirect? [y/N] ")
|
|
meta))))
|
|
(input-dispatch (status code-description meta response socket iri parsed-iri)
|
|
(declare (ignore status code-description response socket parsed-iri))
|
|
(gemini-client:debug-gemini "response requested input: ~s" meta)
|
|
(get-user-input nil iri meta))
|
|
(sensitive-input-dispatch (status code-description meta response socket iri parsed-iri)
|
|
(declare (ignore status code-description response socket parsed-iri))
|
|
(gemini-client:debug-gemini "response requested sensitive input: ~s"
|
|
meta)
|
|
(get-user-input t iri meta))
|
|
(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
|
|
cached-key-password
|
|
just-created)
|
|
(gemini-client:fetch-cached-certificate iri :if-does-not-exist :create)
|
|
(cond
|
|
((or just-created
|
|
(os-utils:ssl-key-has-empty-password-p cached-key))
|
|
(gemini-client:substitute-cache-certificate-password cached-certificate "")
|
|
(request iri
|
|
:do-nothing-if-exists-in-db do-nothing-if-exists-in-db
|
|
:certificate-key cached-key
|
|
:certificate-key-password ""
|
|
:certificate cached-certificate))
|
|
(cached-key-password
|
|
(request iri
|
|
:do-nothing-if-exists-in-db do-nothing-if-exists-in-db
|
|
:certificate-key cached-key
|
|
:certificate-key-password cached-key-password
|
|
:certificate cached-certificate))
|
|
(t
|
|
(flet ((on-input-complete (password)
|
|
(db-utils:with-ready-database (:connect nil)
|
|
(gemini-client:save-cache-certificate-password cached-certificate
|
|
password)
|
|
(request url
|
|
:enqueue enqueue
|
|
:certificate-key certificate-key
|
|
:certificate-key-password password
|
|
:certificate certificate))))
|
|
(let ((error-message (format nil
|
|
(_"a password to unlock certificate for ~a is needed: ")
|
|
iri)))
|
|
(ui:ask-string-input #'on-input-complete
|
|
:priority program-events:+minimum-event-priority+
|
|
:prompt error-message)))))))
|
|
(titan-upload-dispatch (url)
|
|
(let ((parsed (iri:iri-parse url)))
|
|
(values (gemini-client::remove-titan-parameters-from-path (uri:path parsed))
|
|
titan-data
|
|
titan-size
|
|
titan-mime
|
|
titan-token))))
|
|
(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-clrs enqueue)
|
|
:titan-upload
|
|
#'titan-upload-dispatch)
|
|
:ignore-warning nil)
|
|
(gemini-client:debug-gemini "viewer requesting iri ~s" url)
|
|
(maybe-initialize-metadata specials:*message-window*)
|
|
(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 (find-db-stream-url actual-iri)
|
|
(progn
|
|
(gemini-client:debug-gemini "caching found for ~a" actual-iri)
|
|
(db-entry-to-foreground actual-iri)
|
|
(gemini-viewer:push-url-to-history specials:*message-window*
|
|
actual-iri))
|
|
(progn
|
|
(gemini-client:debug-gemini "caching *not* found for ~a" actual-iri)
|
|
(request actual-iri
|
|
:enqueue enqueue
|
|
:certificate-key certificate-key
|
|
:certificate certificate
|
|
:use-cached-file-if-exists nil
|
|
:do-nothing-if-exists-in-db
|
|
do-nothing-if-exists-in-db))))
|
|
(when (not (and do-nothing-if-exists-in-db
|
|
(find-db-stream-url actual-iri)))
|
|
(when (null enqueue)
|
|
(ensure-just-one-stream-rendering))
|
|
(gemini-client:request-dispatch url
|
|
gemini-client::dispatch-table
|
|
:certificate certificate
|
|
:certificate-key certificate-key
|
|
:certificate-key-password
|
|
certificate-key-password)))))
|
|
(gemini-client:gemini-tofu-error (e)
|
|
(ui:ask-input-on-tofu-error e
|
|
(lambda ()
|
|
(request url
|
|
:enqueue enqueue
|
|
:certificate certificate
|
|
:certificate-key certificate-key
|
|
:do-nothing-if-exists-in-db
|
|
do-nothing-if-exists-in-db))))
|
|
(conditions:not-implemented-error (e)
|
|
(ui:notify (format nil (_ "Error: ~a") e)
|
|
:as-error t))
|
|
(gemini-client:gemini-protocol-error (e)
|
|
(ui:notify (format nil "~a" e)
|
|
:as-error t))
|
|
#-debug-mode
|
|
(error (e)
|
|
(ui:notify (format nil (_ "Error getting ~s: ~a") url e)
|
|
:as-error t))
|
|
#-debug-mode
|
|
(condition (c)
|
|
(ui:notify (format nil (_ "Error getting ~s: ~a") url c)
|
|
:as-error t)))))
|
|
|
|
(defun history-back (window)
|
|
(when-let* ((metadata (message-window:metadata window))
|
|
(history (misc:safe-all-but-last-elt (gemini-metadata-history metadata)))
|
|
(last (last-elt history)))
|
|
(setf (gemini-metadata-history metadata) history)
|
|
(ui:info-message (format nil (_ "Going back to: ~a") last))
|
|
(let ((found (find-db-stream-url last)))
|
|
(if found
|
|
(db-entry-to-foreground last)
|
|
(ui:open-net-address last))))) ; this happens history kept a non gemini iri
|
|
|
|
(defun view-source (window)
|
|
(when-let* ((metadata (message-window:metadata window))
|
|
(source (gemini-metadata-source-file metadata))
|
|
(last (misc:safe-last-elt (gemini-metadata-history metadata))))
|
|
(message-window:prepare-for-rendering window source)
|
|
(draw window)
|
|
(ui:info-message (format nil (_ "Viewing source of: ~a") last))))
|
|
|
|
(defclass gemini-streams-window (focus-marked-window
|
|
simple-line-navigation-window
|
|
title-window
|
|
border-window)
|
|
())
|
|
|
|
(defmethod refresh-config :after ((object gemini-streams-window))
|
|
(open-attach-window:refresh-view-links-window-config object
|
|
swconf:+key-open-gemini-stream-window+)
|
|
(let* ((win-w (truncate (* (win-width specials:*main-window*) 3/4)))
|
|
(win-h (truncate (* (win-height specials:*main-window*) 3/4)))
|
|
(x (truncate (- (/ (win-width specials:*main-window*) 2)
|
|
(/ win-w 2))))
|
|
(y (truncate (- (/ (win-height specials:*main-window*) 2)
|
|
(/ win-h 2)))))
|
|
(win-resize object win-w win-h)
|
|
(win-move object x y)
|
|
object))
|
|
|
|
(defmethod resync-rows-db ((object gemini-streams-window)
|
|
&key
|
|
(redraw t)
|
|
(suggested-message-index nil))
|
|
(with-accessors ((rows rows)
|
|
(selected-line-bg selected-line-bg)
|
|
(selected-line-fg selected-line-fg)) object
|
|
(flet ((make-rows (streams bg fg)
|
|
(mapcar (lambda (stream-object)
|
|
(let ((unselected-line (to-tui-string stream-object :window object)))
|
|
(make-instance 'line
|
|
:normal-text unselected-line
|
|
:selected-text (tui-string->chars-string unselected-line)
|
|
:fields stream-object
|
|
:normal-bg bg
|
|
:normal-fg fg
|
|
:selected-bg fg
|
|
:selected-fg bg)))
|
|
streams)))
|
|
(with-croatoan-window (croatoan-window object)
|
|
(line-oriented-window:update-all-rows object
|
|
(make-rows *gemini-streams-db*
|
|
selected-line-bg
|
|
selected-line-fg))
|
|
(when suggested-message-index
|
|
(select-row object suggested-message-index))
|
|
(when redraw
|
|
(win-clear object)
|
|
(draw object))))))
|
|
|
|
(defun open-gemini-stream-window ()
|
|
(let* ((low-level-window (make-croatoan-window :enable-function-keys t)))
|
|
(setf *gemini-streams-window*
|
|
(make-instance 'gemini-streams-window
|
|
:top-row-padding 0
|
|
:title (_ "Current gemini streams")
|
|
:single-row-height 1
|
|
:uses-border-p t
|
|
:keybindings keybindings:*gemini-downloads-keymap*
|
|
:croatoan-window low-level-window))
|
|
(refresh-config *gemini-streams-window*)
|
|
(resync-rows-db *gemini-streams-window* :redraw nil)
|
|
(when (not (line-oriented-window:rows-empty-p *gemini-streams-window*))
|
|
(select-row *gemini-streams-window* 0))
|
|
(draw *gemini-streams-window*)
|
|
*gemini-streams-window*))
|
|
|
|
(defun load-gemini-url (url &key
|
|
(priority program-events:+standard-event-priority+)
|
|
(give-focus-to-message-window t)
|
|
(use-cached-file-if-exists nil)
|
|
(enqueue nil))
|
|
"Load `url', that is a web resource or a local file. This function
|
|
can be used only when the event polling is enabled (e.g. from user
|
|
command) otherwise te actual code to get the resource will never be
|
|
executed."
|
|
(let* ((event (make-instance 'program-events:gemini-request-event
|
|
:give-focus-to-message-window give-focus-to-message-window
|
|
:priority priority
|
|
:use-cached-file-if-exists use-cached-file-if-exists
|
|
:enqueue enqueue
|
|
:url url)))
|
|
(program-events:push-event event)))
|
|
|
|
(defun post-titan-url (url data size mime token)
|
|
(let* ((event (make-instance 'program-events:titan-post-event
|
|
:data data
|
|
:data data
|
|
:size size
|
|
:mime mime
|
|
:token token
|
|
:url url)))
|
|
(program-events:push-event event)))
|