mirror of https://codeberg.org/cage/tinmop/
- [gemini]
- added some messages to debug protocol;
- asking for query event got minimum priority to prevent being
hidden by informational messages on the command line (e.g the
message that inform the user that the client is going back in
history);
- always stream contents that are repsonses to a query;
- added gemini-client:request-dispatch and rewritten
gemini-client:slurp-gemini-url based on the former.
This commit is contained in:
cage
parent
986ea84313
commit
6a1ea415f7
|
|
@ -317,7 +317,7 @@
|
|||
(flet ((fetch-from-cache (key)
|
||||
(assoc-value cache key :test #'string=)))
|
||||
(multiple-value-bind (actual-iri host path query port fragment)
|
||||
(displace-iri parsed-url)
|
||||
(gemini-client:displace-iri parsed-url)
|
||||
(declare (ignore actual-iri path query fragment))
|
||||
(or (fetch-from-cache host)
|
||||
(ignore-errors
|
||||
|
|
@ -367,9 +367,13 @@
|
|||
named download-loop
|
||||
for line-as-array = (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 (babel:octets-to-string line-as-array :errorp nil))
|
||||
(event (make-gemini-download-event line wrapper-object t)))
|
||||
(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)
|
||||
(maybe-render-line event))
|
||||
|
|
@ -425,25 +429,6 @@
|
|||
(%fill-buffer)))))))
|
||||
(%fill-buffer))))))
|
||||
|
||||
(defun displace-iri (iri)
|
||||
(let* ((host (uri:host iri))
|
||||
(path (uri:path iri))
|
||||
(query (uri:query iri))
|
||||
(fragment (uri:fragment iri))
|
||||
(port (or (uri:port iri)
|
||||
gemini-client:+gemini-default-port+))
|
||||
(actual-iri (gemini-parser:make-gemini-iri host
|
||||
path
|
||||
:query query
|
||||
:port port
|
||||
:fragment fragment)))
|
||||
(values actual-iri
|
||||
host
|
||||
path
|
||||
query
|
||||
port
|
||||
fragment)))
|
||||
|
||||
(defun request (url &key
|
||||
(enqueue nil)
|
||||
(certificate nil)
|
||||
|
|
@ -451,6 +436,7 @@
|
|||
(use-cached-file-if-exists nil)
|
||||
(do-nothing-if-exists-in-db t))
|
||||
(let ((parsed-iri (ignore-errors (iri:iri-parse url))))
|
||||
(gemini-client:debug-gemini "viewer requesting iri ~s" url)
|
||||
(maybe-initialize-metadata specials:*message-window*)
|
||||
(cond
|
||||
((null parsed-iri)
|
||||
|
|
@ -458,12 +444,16 @@
|
|||
(_ "Could not understand the address ~s")
|
||||
url)))
|
||||
(use-cached-file-if-exists
|
||||
(gemini-client:debug-gemini "checking cache")
|
||||
(multiple-value-bind (actual-iri host path query port fragment)
|
||||
(displace-iri parsed-iri)
|
||||
(gemini-client:displace-iri parsed-iri)
|
||||
(if (find-db-stream-url actual-iri)
|
||||
(progn
|
||||
(gemini-client:debug-gemini "caching found for ~a" actual-iri)
|
||||
(add-url-to-history specials:*message-window* actual-iri)
|
||||
(db-entry-to-foreground actual-iri))
|
||||
(progn
|
||||
(gemini-client:debug-gemini "caching *not* found for ~a" actual-iri)
|
||||
(request (gemini-parser:make-gemini-iri host
|
||||
path
|
||||
:query query
|
||||
|
|
@ -473,10 +463,10 @@
|
|||
:certificate certificate
|
||||
:use-cached-file-if-exists nil
|
||||
:do-nothing-if-exists-in-db
|
||||
do-nothing-if-exists-in-db))))
|
||||
do-nothing-if-exists-in-db)))))
|
||||
(t
|
||||
(multiple-value-bind (actual-iri host path query port fragment)
|
||||
(displace-iri parsed-iri)
|
||||
(gemini-client:displace-iri parsed-iri)
|
||||
(when (not (and do-nothing-if-exists-in-db
|
||||
(find-db-stream-url actual-iri)))
|
||||
(when (null enqueue)
|
||||
|
|
@ -520,8 +510,11 @@
|
|||
:port port
|
||||
:fragment fragment)
|
||||
:certificate-key certificate-key
|
||||
:certificate certificate))))))
|
||||
: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 ")
|
||||
|
|
@ -538,6 +531,7 @@
|
|||
(add-url-to-history specials:*message-window* actual-iri)
|
||||
(cond
|
||||
((gemini-client:response-redirect-p status)
|
||||
(gemini-client:debug-gemini "response redirect to: ~s" meta)
|
||||
(flet ((on-input-complete (maybe-accepted)
|
||||
(when (ui::boolean-input-accepted-p maybe-accepted)
|
||||
(let ((new-url (gemini-client:build-redirect-iri meta
|
||||
|
|
@ -553,6 +547,7 @@
|
|||
(_ "Redirects to ~s, follows redirect? [y/N] ")
|
||||
meta))))
|
||||
((gemini-client:response-certificate-requested-p status)
|
||||
(gemini-client:debug-gemini "response requested certificate")
|
||||
(multiple-value-bind (cached-certificate cached-key)
|
||||
(fetch-cached-certificate actual-iri)
|
||||
(request actual-iri
|
||||
|
|
@ -561,10 +556,14 @@
|
|||
:certificate-key cached-key
|
||||
:certificate cached-certificate)))
|
||||
((gemini-client:response-input-p status)
|
||||
(gemini-client:debug-gemini "response requested input: ~s" meta)
|
||||
(get-user-input nil host meta))
|
||||
((gemini-client:response-sensitive-input-p status)
|
||||
(gemini-client:debug-gemini "response requested sensitive input: ~s"
|
||||
meta)
|
||||
(get-user-input t host meta))
|
||||
((streamp response)
|
||||
(gemini-client:debug-gemini "response is a stream")
|
||||
(if (gemini-file-stream-p meta)
|
||||
(let* ((starting-status (starting-status meta))
|
||||
(gemini-stream (make-instance 'gemini-file-stream
|
||||
|
|
@ -591,6 +590,7 @@
|
|||
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
|
||||
|
|
@ -617,6 +617,7 @@
|
|||
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
|
||||
|
|
|
|||
|
|
@ -300,6 +300,30 @@
|
|||
(defun percent-encode-fragment (fragment)
|
||||
(maybe-percent-encode fragment))
|
||||
|
||||
(defun displace-iri (iri)
|
||||
(let* ((host (uri:host iri))
|
||||
(path (uri:path iri))
|
||||
(query (uri:query iri))
|
||||
(fragment (uri:fragment iri))
|
||||
(port (or (uri:port iri)
|
||||
+gemini-default-port+))
|
||||
(actual-iri (gemini-parser:make-gemini-iri host
|
||||
path
|
||||
:query query
|
||||
:port port
|
||||
:fragment fragment)))
|
||||
(values actual-iri
|
||||
host
|
||||
path
|
||||
query
|
||||
port
|
||||
fragment)))
|
||||
|
||||
(defun debug-gemini (&rest data)
|
||||
#+(and debug-mode
|
||||
debug-gemini-request)
|
||||
(apply #'misc:dbg (text-utils:strcat "[gemini] " (first data)) (rest data)))
|
||||
|
||||
(defun request (host path &key
|
||||
(query nil)
|
||||
(port +gemini-default-port+)
|
||||
|
|
@ -328,6 +352,7 @@
|
|||
:hostname host))
|
||||
(request (format nil "~a~a~a" iri #\return #\newline))
|
||||
(cert-hash (crypto-shortcuts:sha512 (x509:dump-certificate ssl-stream))))
|
||||
(debug-gemini "sending request ~a" request)
|
||||
(if (not (db:tofu-passes-p host cert-hash))
|
||||
(error 'gemini-tofu-error :host host)
|
||||
(progn
|
||||
|
|
@ -337,6 +362,56 @@
|
|||
(parse-response ssl-stream)
|
||||
(values status description meta response socket)))))))))))
|
||||
|
||||
(defun request-dispatch (url manage-functions &key (certificate nil) (certificate-key nil))
|
||||
(let ((parsed-iri (iri:iri-parse url)))
|
||||
(multiple-value-bind (actual-iri host path query port fragment)
|
||||
(displace-iri parsed-iri)
|
||||
(multiple-value-bind (status code-description meta response socket)
|
||||
(gemini-client:request host
|
||||
path
|
||||
:certificate-key certificate-key
|
||||
:client-certificate certificate
|
||||
:query query
|
||||
:port port
|
||||
:fragment fragment)
|
||||
(flet ((call-appropriate-function (response-type)
|
||||
(funcall (getf manage-functions
|
||||
response-type
|
||||
(lambda (status code-description meta response socket iri)
|
||||
(declare (ignore status code-description meta response socket iri))))
|
||||
status code-description meta response socket actual-iri)))
|
||||
(cond
|
||||
((gemini-client:response-redirect-p status)
|
||||
(call-appropriate-function :redirect))
|
||||
((gemini-client:response-certificate-requested-p status)
|
||||
(call-appropriate-function :certificate-requested))
|
||||
((gemini-client:response-input-p status)
|
||||
(call-appropriate-function :input-requested))
|
||||
((gemini-client:response-sensitive-input-p status)
|
||||
(call-appropriate-function :sensitive-input-requested))
|
||||
(t
|
||||
(call-appropriate-function :others-responses))))))))
|
||||
|
||||
(defmacro with-request-dispatch-table ((table &key (ignore-warning nil)) &body body)
|
||||
"Anaphoric, the anaphora is `dispatch-table'"
|
||||
(assert (listp table))
|
||||
(if (null table)
|
||||
(error "Empty dispatch-table")
|
||||
(progn
|
||||
(when (not ignore-warning)
|
||||
(when (null (getf table :redirect))
|
||||
(warn "No dispatch for redirect found"))
|
||||
(when (null (getf table :certificate-requested))
|
||||
(warn "No dispatch for certificate request"))
|
||||
(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 :others-responses))
|
||||
(error "No dispatch for others responses"))
|
||||
`(let ((dispatch-table (list ,@table)))
|
||||
,@body))))
|
||||
|
||||
(defun gemini-file-stream-p (meta)
|
||||
(gemini-client:mime-gemini-p meta))
|
||||
|
||||
|
|
@ -378,14 +453,14 @@ use as there is a chance that it would not returns. Anyway for gemlog
|
|||
subscription (for example) could be used.
|
||||
|
||||
TODO: Add client certificate."
|
||||
(let ((iri (iri:iri-parse url)))
|
||||
(multiple-value-bind (status description meta response socket)
|
||||
(request (uri:host iri)
|
||||
(uri:path iri)
|
||||
:query (uri:query iri)
|
||||
:port (uri:port iri)
|
||||
:fragment (uri:fragment iri))
|
||||
(declare (ignore description))
|
||||
(labels ((redirect-dispatch (status code-description meta response socket iri)
|
||||
(declare (ignore status code-description response socket))
|
||||
(when (< redirect-count +maximum-redirections+)
|
||||
(slurp-gemini-url (build-redirect-iri meta iri) (1+ redirect-count))))
|
||||
(default-dispatch (status code-description meta response socket iri)
|
||||
(declare (ignorable code-description iri meta))
|
||||
(debug-gemini "response data: ~s ~s ~s ~s ~s ~s"
|
||||
status code-description meta response socket iri)
|
||||
(cond
|
||||
((response-success-p status)
|
||||
(let ((data (misc:make-fresh-array 0 0 '(unsigned-byte 8) nil)))
|
||||
|
|
@ -393,7 +468,8 @@ TODO: Add client certificate."
|
|||
while new-byte do
|
||||
(vector-push-extend new-byte data))
|
||||
(close-ssl-socket socket)
|
||||
data))
|
||||
((and (response-redirect-p status)
|
||||
(< redirect-count +maximum-redirections+))
|
||||
(slurp-gemini-url (build-redirect-iri meta iri) (1+ redirect-count)))))))
|
||||
data)))))
|
||||
(with-request-dispatch-table ((:others-responses #'default-dispatch
|
||||
:redirect #'redirect-dispatch)
|
||||
:ignore-warning t)
|
||||
(request-dispatch url dispatch-table))))
|
||||
|
|
|
|||
|
|
@ -113,10 +113,14 @@
|
|||
:links
|
||||
:text-rendering-theme
|
||||
:gemini-file-response-p
|
||||
:displace-iri
|
||||
:close-ssl-socket
|
||||
:make-client-certificate
|
||||
:debug-gemini
|
||||
:request
|
||||
:gemini-file-stream-p
|
||||
:request-dispatch
|
||||
:with-request-dispatch-table
|
||||
:fetch-cached-certificate
|
||||
:build-redirect-iri
|
||||
:slurp-gemini-url))
|
||||
|
|
|
|||
|
|
@ -141,4 +141,5 @@
|
|||
(:file "x509-tests")
|
||||
(:file "idn-tests")))))
|
||||
|
||||
;; (push :debug-mode *features*)
|
||||
;;(push :debug-mode *features*)
|
||||
(push :debug-gemini-request *features*)
|
||||
|
|
|
|||
Loading…
Reference in New Issue