diff --git a/src/conditions.lisp b/src/conditions.lisp index 76fc72b..1ac58fc 100644 --- a/src/conditions.lisp +++ b/src/conditions.lisp @@ -30,6 +30,8 @@ (define-condition not-implemented-error (text-error) () + (:report (lambda (condition stream) + (format stream "~a" (text condition)))) (:documentation "Error for not-implemented features")) (define-condition null-reference (text-error) diff --git a/src/gemini-viewer.lisp b/src/gemini-viewer.lisp index fb72859..5ff89cf 100644 --- a/src/gemini-viewer.lisp +++ b/src/gemini-viewer.lisp @@ -429,216 +429,230 @@ (%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 (enqueue nil) (certificate nil) (certificate-key nil) (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) - (ui:error-message (format nil - (_ "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) - (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 - :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) - (gemini-client:displace-iri parsed-iri) - (when (not (and do-nothing-if-exists-in-db - (find-db-stream-url actual-iri))) - (when (null enqueue) - (ensure-just-one-stream-rendering)) - (handler-case - (labels ((starting-status (meta) - (if (gemini-client:gemini-file-stream-p meta) - (if enqueue - :streaming - :rendering) - (if enqueue - :streaming - :running))) - (get-user-input (hide-input host prompt) - (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 - :fragment fragment) - :certificate-key certificate-key - :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))))) - (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) - (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 - parsed-iri))) - (db-utils:with-ready-database (:connect nil) - (request new-url - :certificate-key certificate-key - :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)))) - ((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) + (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 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) + (let ((new-url (gemini-client:build-redirect-iri meta + parsed-iri))) + (db-utils:with-ready-database (:connect nil) + (request new-url + :certificate-key certificate-key + :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) + (gemini-client:fetch-cached-certificate iri) + (request iri + :enqueue enqueue + :do-nothing-if-exists-in-db do-nothing-if-exists-in-db + :certificate-key cached-key + :certificate cached-certificate)))) + (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) + :fallback + #'request-fallback-dispatched) + :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) + (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 actual-iri - :enqueue enqueue - :do-nothing-if-exists-in-db do-nothing-if-exists-in-db - :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-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))))))) - (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))))))))) + :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)) + (add-url-to-history specials:*message-window* actual-iri) + (gemini-client:request-dispatch url gemini-client::dispatch-table))))) + (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) (when-let* ((metadata (message-window:metadata window)) diff --git a/src/gemini/client.lisp b/src/gemini/client.lisp index 34a5bc0..f4faff9 100644 --- a/src/gemini/client.lisp +++ b/src/gemini/client.lisp @@ -320,6 +320,7 @@ fragment))) (defun debug-gemini (&rest data) + (declare (ignorable data)) #+(and debug-mode debug-gemini-request) (apply #'misc:dbg (text-utils:strcat "[gemini] " (first data)) (rest data))) @@ -377,40 +378,65 @@ (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))) + (lambda (status code-description meta response socket iri parsed-iri) + (declare (ignore status code-description meta response socket iri parsed-iri)))) + status + code-description + meta + response + socket + actual-iri + parsed-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-success-p status) + (call-appropriate-function :success)) ((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)))))))) + (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) "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)))) + (let* ((unknown-keys (loop for i in (remove-if-not #'keywordp table) + when (not (find i +allowed-dispatch-keys+)) + collect i))) + (if (null table) + (error "Empty dispatch-table") + (progn + (when (not ignore-warning) + (when unknown-keys + (warn (format nil + "found unkown keys in dispatch-table table: ~s" + unknown-keys))) + (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 :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) (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. TODO: Add client certificate." - (labels ((redirect-dispatch (status code-description meta response socket iri) - (declare (ignore status code-description response socket)) + (labels ((redirect-dispatch (status code-description meta response socket iri parsed-iri) + (declare (ignore status code-description response socket parsed-iri)) (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" + (success-dispatch (status code-description meta response socket iri parsed-iri) + (declare (ignorable code-description iri meta parsed-iri)) + (debug-gemini "success 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) + (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 ((:success #'success-dispatch + :redirect #'redirect-dispatch) :ignore-warning t) (request-dispatch url dispatch-table))))