From 6a1ea415f77cbc29efe45c47b317e407ba921b28 Mon Sep 17 00:00:00 2001 From: cage Date: Sat, 6 Feb 2021 15:49:09 +0100 Subject: [PATCH] - [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. --- src/gemini-viewer.lisp | 71 +++++++++++++------------ src/gemini/client.lisp | 114 +++++++++++++++++++++++++++++++++------- src/gemini/package.lisp | 4 ++ tinmop.asd | 3 +- 4 files changed, 137 insertions(+), 55 deletions(-) diff --git a/src/gemini-viewer.lisp b/src/gemini-viewer.lisp index 9642ab0..e51b441 100644 --- a/src/gemini-viewer.lisp +++ b/src/gemini-viewer.lisp @@ -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))) + (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,25 +444,29 @@ (_ "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)) - (request (gemini-parser:make-gemini-iri host - path - :query query - :port port - :fragment fragment) - :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 + (gemini-client:debug-gemini "caching *not* found for ~a" actual-iri) + (request (gemini-parser:make-gemini-iri host + path + :query query + :port port + :fragment fragment) + :certificate-key certificate-key + :certificate certificate + :use-cached-file-if-exists nil + :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 diff --git a/src/gemini/client.lisp b/src/gemini/client.lisp index 230f560..34a5bc0 100644 --- a/src/gemini/client.lisp +++ b/src/gemini/client.lisp @@ -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,22 +453,23 @@ 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)) - (cond - ((response-success-p status) - (let ((data (misc:make-fresh-array 0 0 '(unsigned-byte 8) nil))) - (loop for new-byte = (read-byte response nil nil) - 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))))))) + (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))) + (loop for new-byte = (read-byte response nil nil) + while new-byte do + (vector-push-extend new-byte data)) + (close-ssl-socket socket) + data))))) + (with-request-dispatch-table ((:others-responses #'default-dispatch + :redirect #'redirect-dispatch) + :ignore-warning t) + (request-dispatch url dispatch-table)))) diff --git a/src/gemini/package.lisp b/src/gemini/package.lisp index 9fd65e0..352ad13 100644 --- a/src/gemini/package.lisp +++ b/src/gemini/package.lisp @@ -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)) diff --git a/tinmop.asd b/tinmop.asd index 873f45d..1fc1d0a 100644 --- a/tinmop.asd +++ b/tinmop.asd @@ -141,4 +141,5 @@ (:file "x509-tests") (:file "idn-tests"))))) -;; (push :debug-mode *features*) +;;(push :debug-mode *features*) +(push :debug-gemini-request *features*)