cage
/
tinmop
mirror of https://codeberg.org/cage/tinmop/
1
0
Fork 0
Code Issues

- [gemini] rewritten gemini-viewer:request using gemini-client:request-dispatch machinery; 

hopefully this should made the function easier to read (by human) and extend.
This commit is contained in:
cage 2021-02-07 12:39:28 +01:00
parent 08c803bfba
commit dc9e23e3c0
3 changed files with 278 additions and 238 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

2
src/conditions.lisp
View File

@ -30,6 +30,8 @@
(define-condition not-implemented-error (text-error) (define-condition not-implemented-error (text-error)
() ()
(:report (lambda (condition stream)
(format stream "~a" (text condition))))
(:documentation "Error for not-implemented features")) (:documentation "Error for not-implemented features"))
(define-condition null-reference (text-error) (define-condition null-reference (text-error)

420
src/gemini-viewer.lisp
View File

@ -429,216 +429,230 @@
(%fill-buffer))))))) (%fill-buffer)))))))
(%fill-buffer)))))) (%fill-buffer))))))
(defun request-fallback-dispatched (status code-description meta response socket iri parsed-iri)
(declare (ignore response socket parsed-iri))
(error (make-condition 'conditions:not-implemented-error
:text (format nil
"received an unknown response from server ~s ~a ~s ~s"
iri status code-description meta))))
(defun request-success-dispatched-clrs (enqueue)
(lambda (status code-description meta response socket iri parsed-iri)
(declare (ignore iri))
(labels ((starting-status (meta)
(if (gemini-client:gemini-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)
(declare (ignore actual-iri))
(gemini-client:debug-gemini "response is a stream")
(if (gemini-client:gemini-file-stream-p meta)
(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))
(enqueue-event (make-instance 'program-events:gemini-enqueue-download-event
:payload gemini-stream)))
(gemini-client:debug-gemini "response is a gemini file stream")
(program-events:push-event enqueue-event)
(downloading-start-thread gemini-stream
thread-fn
host
port
path
query
fragment))
(let* ((starting-status (starting-status meta))
(gemini-stream (make-instance 'gemini-others-data-stream
: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 (defun request (url &key
(enqueue nil) (enqueue nil)
(certificate nil) (certificate nil)
(certificate-key nil) (certificate-key nil)
(use-cached-file-if-exists nil) (use-cached-file-if-exists nil)
(do-nothing-if-exists-in-db t)) (do-nothing-if-exists-in-db t))
(let ((parsed-iri (ignore-errors (iri:iri-parse url)))) (labels ((get-user-input (hide-input url prompt)
(gemini-client:debug-gemini "viewer requesting iri ~s" url) (multiple-value-bind (actual-iri host path query port fragment)
(maybe-initialize-metadata specials:*message-window*) (gemini-client:displace-iri (iri:iri-parse url))
(cond (declare (ignore actual-iri query fragment))
((null parsed-iri) (flet ((on-input-complete (input)
(ui:error-message (format nil (when (string-not-empty-p input)
(_ "Could not understand the address ~s") (db-utils:with-ready-database (:connect nil)
url))) (let ((encoded-input (maybe-percent-encode input)))
(use-cached-file-if-exists (request (gemini-parser:make-gemini-iri host
(gemini-client:debug-gemini "checking cache") path
(multiple-value-bind (actual-iri host path query port fragment) :query
(gemini-client:displace-iri parsed-iri) encoded-input
(if (find-db-stream-url actual-iri) :port port)
(progn :certificate-key certificate-key
(gemini-client:debug-gemini "caching found for ~a" actual-iri) :certificate certificate
(add-url-to-history specials:*message-window* actual-iri) :do-nothing-if-exists-in-db nil))))))
(db-entry-to-foreground actual-iri)) (ui:ask-string-input #'on-input-complete
(progn :priority
(gemini-client:debug-gemini "caching *not* found for ~a" actual-iri) program-events:+minimum-event-priority+
(request (gemini-parser:make-gemini-iri host :hide-input hide-input
path :prompt (format nil
:query query (_ "Server ~s asks: ~s ")
:port port host
:fragment fragment) prompt)))))
:certificate-key certificate-key (redirect-dispatch (status code-description meta response socket iri parsed-iri)
:certificate certificate (declare (ignore status code-description response socket iri))
:use-cached-file-if-exists nil (gemini-client:debug-gemini "response redirect to: ~s" meta)
:do-nothing-if-exists-in-db (flet ((on-input-complete (maybe-accepted)
do-nothing-if-exists-in-db))))) (when (ui::boolean-input-accepted-p maybe-accepted)
(t (let ((new-url (gemini-client:build-redirect-iri meta
(multiple-value-bind (actual-iri host path query port fragment) parsed-iri)))
(gemini-client:displace-iri parsed-iri) (db-utils:with-ready-database (:connect nil)
(when (not (and do-nothing-if-exists-in-db (request new-url
(find-db-stream-url actual-iri))) :certificate-key certificate-key
(when (null enqueue) :certificate certificate))))))
(ensure-just-one-stream-rendering)) (ui:ask-string-input #'on-input-complete
(handler-case :priority program-events:+minimum-event-priority+
(labels ((starting-status (meta) :prompt
(if (gemini-client:gemini-file-stream-p meta) (format nil
(if enqueue (_ "Redirects to ~s, follows redirect? [y/N] ")
:streaming meta))))
:rendering) (input-dispatch (status code-description meta response socket iri parsed-iri)
(if enqueue (declare (ignore status code-description response socket parsed-iri))
:streaming (gemini-client:debug-gemini "response requested input: ~s" meta)
:running))) (get-user-input nil iri meta))
(get-user-input (hide-input host prompt) (sensitive-input-dispatch (status code-description meta response socket iri parsed-iri)
(flet ((on-input-complete (input) (declare (ignore status code-description response socket parsed-iri))
(when (string-not-empty-p input) (gemini-client:debug-gemini "response requested sensitive input: ~s"
(db-utils:with-ready-database (:connect nil) meta)
(let ((encoded-input (maybe-percent-encode input))) (get-user-input t iri meta))
(request (gemini-parser:make-gemini-iri host (certificate-request-dispatch (status
path code-description
:query meta
encoded-input response
:port port socket iri
:fragment fragment) parsed-iri)
:certificate-key certificate-key (declare (ignore status code-description response socket meta parsed-iri))
:certificate certificate (gemini-client:debug-gemini "response requested certificate")
:do-nothing-if-exists-in-db nil)))))) (multiple-value-bind (cached-certificate cached-key)
(ui:ask-string-input #'on-input-complete (gemini-client:fetch-cached-certificate iri)
:priority (request iri
program-events:+minimum-event-priority+ :enqueue enqueue
:hide-input hide-input :do-nothing-if-exists-in-db do-nothing-if-exists-in-db
:prompt (format nil :certificate-key cached-key
(_ "Server ~s asks: ~s ") :certificate cached-certificate))))
host (handler-case
prompt))))) (gemini-client:with-request-dispatch-table ((:certificate-requested
(multiple-value-bind (status code-description meta response socket) #'certificate-request-dispatch
(gemini-client:request host :input-requested
path #'input-dispatch
:certificate-key certificate-key :sensitive-input-requested
:client-certificate certificate #'sensitive-input-dispatch
:query query :redirect
:port port #'redirect-dispatch
:fragment fragment) :success
(add-url-to-history specials:*message-window* actual-iri) (request-success-dispatched-clrs enqueue)
(cond :fallback
((gemini-client:response-redirect-p status) #'request-fallback-dispatched)
(gemini-client:debug-gemini "response redirect to: ~s" meta) :ignore-warning nil)
(flet ((on-input-complete (maybe-accepted) (gemini-client:debug-gemini "viewer requesting iri ~s" url)
(when (ui::boolean-input-accepted-p maybe-accepted) (maybe-initialize-metadata specials:*message-window*)
(let ((new-url (gemini-client:build-redirect-iri meta (let ((actual-iri (gemini-client:displace-iri (iri:iri-parse url))))
parsed-iri))) (if use-cached-file-if-exists
(db-utils:with-ready-database (:connect nil) (progn
(request new-url (gemini-client:debug-gemini "checking cache")
:certificate-key certificate-key (if (find-db-stream-url actual-iri)
:certificate certificate)))))) (progn
(ui:ask-string-input #'on-input-complete (gemini-client:debug-gemini "caching found for ~a" actual-iri)
:priority program-events:+minimum-event-priority+ (add-url-to-history specials:*message-window* actual-iri)
:prompt (db-entry-to-foreground actual-iri))
(format nil (progn
(_ "Redirects to ~s, follows redirect? [y/N] ") (gemini-client:debug-gemini "caching *not* found for ~a" actual-iri)
meta))))
((gemini-client:response-certificate-requested-p status)
(gemini-client:debug-gemini "response requested certificate")
(multiple-value-bind (cached-certificate cached-key)
(gemini-client:fetch-cached-certificate actual-iri)
(request actual-iri (request actual-iri
:enqueue enqueue :certificate-key certificate-key
:do-nothing-if-exists-in-db do-nothing-if-exists-in-db :certificate certificate
:certificate-key cached-key :use-cached-file-if-exists nil
:certificate cached-certificate))) :do-nothing-if-exists-in-db
((gemini-client:response-input-p status) do-nothing-if-exists-in-db))))
(gemini-client:debug-gemini "response requested input: ~s" meta) (when (not (and do-nothing-if-exists-in-db
(get-user-input nil host meta)) (find-db-stream-url actual-iri)))
((gemini-client:response-sensitive-input-p status) (when (null enqueue)
(gemini-client:debug-gemini "response requested sensitive input: ~s" (ensure-just-one-stream-rendering))
meta) (add-url-to-history specials:*message-window* actual-iri)
(get-user-input t host meta)) (gemini-client:request-dispatch url gemini-client::dispatch-table)))))
((streamp response) (gemini-client:gemini-tofu-error (e)
(gemini-client:debug-gemini "response is a stream") (let ((host (gemini-client:host e)))
(if (gemini-client:gemini-file-stream-p meta) (flet ((on-input-complete (maybe-accepted)
(let* ((starting-status (starting-status meta)) (when (ui::boolean-input-accepted-p maybe-accepted)
(gemini-stream (make-instance 'gemini-file-stream (db-utils:with-ready-database (:connect nil)
:host host (db:tofu-delete host)
:port port (request url
:path path :enqueue enqueue
:query query :certificate certificate
:fragment fragment :certificate-key certificate-key
:meta meta :do-nothing-if-exists-in-db
:status-code status do-nothing-if-exists-in-db)))))
:status-code-description (ui:ask-string-input #'on-input-complete
code-description :prompt
:stream-status starting-status (format nil
:download-stream response (_ "Host ~s signature changed! This is a potential security risk! Ignore this warning? [y/N] ")
:download-socket socket)) host)
(favicon (fetch-favicon parsed-iri)) :priority program-events:+standard-event-priority+))))
(thread-fn (conditions:not-implemented-error (e)
(request-stream-gemini-document-thread gemini-stream (ui:notify (format nil (_ "Error: ~a") e)
host :as-error t))
port (gemini-client:gemini-protocol-error (e)
path (ui:notify (format nil "~a" e)
query :as-error t))
fragment #-debug-mode
favicon)) (error (e)
(enqueue-event (make-instance 'program-events:gemini-enqueue-download-event (ui:notify (format nil
:payload gemini-stream))) (_ "Error getting ~s: ~a")
(gemini-client:debug-gemini "response is a gemini file stream") url
(program-events:push-event enqueue-event) e)
(downloading-start-thread gemini-stream :as-error t)))))
thread-fn
host
port
path
query
fragment))
(let* ((starting-status (starting-status meta))
(gemini-stream (make-instance 'gemini-others-data-stream
: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)))))))
(gemini-client:gemini-tofu-error (e)
(let ((host (gemini-client:host e)))
(flet ((on-input-complete (maybe-accepted)
(when (ui::boolean-input-accepted-p maybe-accepted)
(db-utils:with-ready-database (:connect nil)
(db:tofu-delete host)
(request url
:enqueue enqueue
:certificate certificate
:certificate-key certificate-key
:do-nothing-if-exists-in-db
do-nothing-if-exists-in-db)))))
(ui:ask-string-input #'on-input-complete
:prompt
(format nil
(_ "Host ~s signature changed! This is a potential security risk! Ignore this warning? [y/N] ")
host)
:priority program-events:+standard-event-priority+))))
(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)))))))))
(defun history-back (window) (defun history-back (window)
(when-let* ((metadata (message-window:metadata window)) (when-let* ((metadata (message-window:metadata window))

94
src/gemini/client.lisp
View File

@ -320,6 +320,7 @@
fragment))) fragment)))
(defun debug-gemini (&rest data) (defun debug-gemini (&rest data)
(declare (ignorable data))
#+(and debug-mode #+(and debug-mode
debug-gemini-request) debug-gemini-request)
(apply #'misc:dbg (text-utils:strcat "[gemini] " (first data)) (rest data))) (apply #'misc:dbg (text-utils:strcat "[gemini] " (first data)) (rest data)))
@ -377,40 +378,65 @@
(flet ((call-appropriate-function (response-type) (flet ((call-appropriate-function (response-type)
(funcall (getf manage-functions (funcall (getf manage-functions
response-type response-type
(lambda (status code-description meta response socket iri) (lambda (status code-description meta response socket iri parsed-iri)
(declare (ignore status code-description meta response socket iri)))) (declare (ignore status code-description meta response socket iri parsed-iri))))
status code-description meta response socket actual-iri))) status
code-description
meta
response
socket
actual-iri
parsed-iri)))
(cond (cond
((gemini-client:response-redirect-p status) ((gemini-client:response-redirect-p status)
(call-appropriate-function :redirect)) (call-appropriate-function :redirect))
((gemini-client:response-certificate-requested-p status) ((gemini-client:response-certificate-requested-p status)
(call-appropriate-function :certificate-requested)) (call-appropriate-function :certificate-requested))
((gemini-client:response-success-p status)
(call-appropriate-function :success))
((gemini-client:response-input-p status) ((gemini-client:response-input-p status)
(call-appropriate-function :input-requested)) (call-appropriate-function :input-requested))
((gemini-client:response-sensitive-input-p status) ((gemini-client:response-sensitive-input-p status)
(call-appropriate-function :sensitive-input-requested)) (call-appropriate-function :sensitive-input-requested))
(t (t
(call-appropriate-function :others-responses)))))))) (call-appropriate-function :fallback))))))))
(define-constant +allowed-dispatch-keys+ '(:redirect
:certificate-requested
:success
:input-requested
:sensitive-input-requested
:fallback)
:test #'equalp)
(defmacro with-request-dispatch-table ((table &key (ignore-warning nil)) &body body) (defmacro with-request-dispatch-table ((table &key (ignore-warning nil)) &body body)
"Anaphoric, the anaphora is `dispatch-table'" "Anaphoric, the anaphora is `dispatch-table'"
(assert (listp table)) (assert (listp table))
(if (null table) (let* ((unknown-keys (loop for i in (remove-if-not #'keywordp table)
(error "Empty dispatch-table") when (not (find i +allowed-dispatch-keys+))
(progn collect i)))
(when (not ignore-warning) (if (null table)
(when (null (getf table :redirect)) (error "Empty dispatch-table")
(warn "No dispatch for redirect found")) (progn
(when (null (getf table :certificate-requested)) (when (not ignore-warning)
(warn "No dispatch for certificate request")) (when unknown-keys
(when (null (getf table :input-requested)) (warn (format nil
(warn "No dispatch for input request")) "found unkown keys in dispatch-table table: ~s"
(when (null (getf table :sensitive-input-requested)) unknown-keys)))
(warn "No dispatch for sensitive-input request"))) (when (null (getf table :redirect))
(when (null (getf table :others-responses)) (warn "No dispatch for redirect found"))
(error "No dispatch for others responses")) (when (null (getf table :certificate-requested))
`(let ((dispatch-table (list ,@table))) (warn "No dispatch for certificate request"))
,@body)))) (when (null (getf table :success))
(warn "No dispatch for success found"))
(when (null (getf table :input-requested))
(warn "No dispatch for input request"))
(when (null (getf table :sensitive-input-requested))
(warn "No dispatch for sensitive-input request"))
(when (null (getf table :fallback))
(warn "No dispatch for others responses")))
`(let ((dispatch-table (list ,@table)))
,@body)))))
(defun gemini-file-stream-p (meta) (defun gemini-file-stream-p (meta)
(gemini-client:mime-gemini-p meta)) (gemini-client:mime-gemini-p meta))
@ -453,23 +479,21 @@ use as there is a chance that it would not returns. Anyway for gemlog
subscription (for example) could be used. subscription (for example) could be used.
TODO: Add client certificate." TODO: Add client certificate."
(labels ((redirect-dispatch (status code-description meta response socket iri) (labels ((redirect-dispatch (status code-description meta response socket iri parsed-iri)
(declare (ignore status code-description response socket)) (declare (ignore status code-description response socket parsed-iri))
(when (< redirect-count +maximum-redirections+) (when (< redirect-count +maximum-redirections+)
(slurp-gemini-url (build-redirect-iri meta iri) (1+ redirect-count)))) (slurp-gemini-url (build-redirect-iri meta iri) (1+ redirect-count))))
(default-dispatch (status code-description meta response socket iri) (success-dispatch (status code-description meta response socket iri parsed-iri)
(declare (ignorable code-description iri meta)) (declare (ignorable code-description iri meta parsed-iri))
(debug-gemini "response data: ~s ~s ~s ~s ~s ~s" (debug-gemini "success response data: ~s ~s ~s ~s ~s ~s"
status code-description meta response socket iri) status code-description meta response socket iri)
(cond (let ((data (misc:make-fresh-array 0 0 '(unsigned-byte 8) nil)))
((response-success-p status) (loop for new-byte = (read-byte response nil nil)
(let ((data (misc:make-fresh-array 0 0 '(unsigned-byte 8) nil))) while new-byte do
(loop for new-byte = (read-byte response nil nil) (vector-push-extend new-byte data))
while new-byte do (close-ssl-socket socket)
(vector-push-extend new-byte data)) data)))
(close-ssl-socket socket) (with-request-dispatch-table ((:success #'success-dispatch
data))))) :redirect #'redirect-dispatch)
(with-request-dispatch-table ((:others-responses #'default-dispatch
:redirect #'redirect-dispatch)
:ignore-warning t) :ignore-warning t)
(request-dispatch url dispatch-table)))) (request-dispatch url dispatch-table))))