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*)