From 50a11fb60368fb39923b843c886d2d37f16df289 Mon Sep 17 00:00:00 2001 From: cage Date: Sun, 3 Mar 2024 18:04:22 +0100 Subject: [PATCH] - [GUI] fixed managing of gemini responses when a titan request was performed (TOFU errors, TLS certificate password etc.); - fixed error arising when 'debug-gemini-gui' was called with more than two arguments. --- src/gemini/dummy-server.lisp | 11 +++ src/gui/client/titan-window.lisp | 74 ++++++++++++++++---- src/gui/server/public-api-gemini-stream.lisp | 10 ++- src/json-rpc2.lisp | 6 +- 4 files changed, 82 insertions(+), 19 deletions(-) diff --git a/src/gemini/dummy-server.lisp b/src/gemini/dummy-server.lisp index 72ff7b9..f78c34a 100644 --- a/src/gemini/dummy-server.lisp +++ b/src/gemini/dummy-server.lisp @@ -72,6 +72,17 @@ and key stored in the file pointed by the filesystem path stream) (close stream) (get-data))) + ((cl-ppcre:scan "^titan" request) + (format t "titan request reading first byte ~a~%" (read-byte stream)) + (let ((response (format nil + "~a text/gemini~a~a#OK~%" + (code gemini-client::+20+) + #\return #\newline))) + (format t "sending: ~a~%" response) + (sleep 1) + (write-sequence (text-utils:string->octets response) + stream) + (close stream))) (t (let ((response (format nil "~a text/gemini~a~a#OK~%" diff --git a/src/gui/client/titan-window.lisp b/src/gui/client/titan-window.lisp index f8097f0..6c1b7b3 100644 --- a/src/gui/client/titan-window.lisp +++ b/src/gui/client/titan-window.lisp @@ -78,20 +78,66 @@ (when (not has-error-p) (let ((parameters (gemini-client:make-titan-parameters mime size (gui:text token-entry)))) (setf (uri:path url) (strcat (uri:path url) parameters)) - (ev:with-enqueued-process-and-unblock () - (gui-goodies::with-notify-errors - (gui-goodies:with-busy* (frame) - (comm:make-request :titan-save-token - 1 - base-url - (gui:text token-entry)) - (comm:make-request :gemini-request - 1 - (to-s url) - nil - titan-data - nil) - (client-main-window::print-info-message (_ "Data uploaded"))))))))))) + (gui-goodies:with-notify-errors + (ev:with-enqueued-process-and-unblock () + (comm:make-request :titan-save-token + 1 + base-url + (gui:text token-entry))) + (let ((connecting-response (cev:enqueue-request-and-wait-results :gemini-request + 1 + ev:+maximum-event-priority+ + (to-s url) + nil + titan-data))) + (multiple-value-bind (status-code + status-description + meta + cached + original-iri) + (client-main-window::displace-gemini-response connecting-response) + (declare (ignore cached)) + (cond + ((or (gemini-client:header-input-p status-code) + (gemini-client:header-sensitive-input-p status-code)) + (error "Server returned an invalid response ~a" status-code)) + ((= status-code comm:+tofu-error-status-code+) + (when (gui:ask-yesno (_ "The certificate for this address has changed, replace the old with the one I just received?") + :title (_ "Server certificate error") + :parent frame) + (cev:enqueue-request-and-wait-results :gemini-delete-tofu-certificate + 1 + ev:+maximum-event-priority+ + original-iri) + (funcall (launch-titan-request-clsr frame)))) + ((or (gemini-client:header-temporary-failure-p status-code) + (gemini-client:header-permanent-failure-p status-code) + (gemini-client:header-certificate-failure-p status-code)) + (error "Server returned an failure response ~a ~a" + status-code + status-description)) + ((= status-code + comm:+certificate-password-not-found-error-status-code+) + (let* ((certificate-path meta) + (message (format nil + (_ "Provide the password to unlock certificate for ~a") + (uri:path url))) + (password (gui-goodies::password-dialog (gui:root-toplevel) + (_ "Unlock certificate") + message)) + (actual-password (if (string-empty-p password) + "" + password))) + (cev:enqueue-request-and-wait-results :gemini-save-certificate-key-password + 1 + ev:+maximum-event-priority+ + certificate-path + actual-password) + (funcall (launch-titan-request-clsr frame)))) + ((gemini-client:header-redirect-p status-code) + (error "redirection in titan not yet implemented")) + ((gemini-client:header-success-p status-code) + (gui-goodies:info-dialog frame (_ "Data uploaded"))))))))))))) (defmethod initialize-instance :after ((object titan-frame) &key (url "") &allow-other-keys) (with-accessors ((url-entry url-entry) diff --git a/src/gui/server/public-api-gemini-stream.lisp b/src/gui/server/public-api-gemini-stream.lisp index 33b3c04..bf50c7c 100644 --- a/src/gui/server/public-api-gemini-stream.lisp +++ b/src/gui/server/public-api-gemini-stream.lisp @@ -24,8 +24,9 @@ (a:define-constant +certificate-password-not-found-error-status-code+ -2 :test #'=) (defun debug-gemini-gui (&rest data) - (apply #'gemini-client:debug-gemini (append (list (strcat "[gui] " (first data)) - (rest data))))) + (apply #'gemini-client:debug-gemini + (strcat "[gui] " (first data)) + (rest data))) (defmethod yason:encode ((object iri-complete-response) &optional (stream *standard-output*)) (let ((json:*symbol-encoder* #'json:encode-symbol-as-lowercase) @@ -221,12 +222,14 @@ (os-utils:ssl-key-has-empty-password-p cached-key)) (gemini-client:substitute-cache-certificate-password cached-certificate "") (%gemini-request iri + :titan-data titan-data :do-nothing-if-exists-in-db do-nothing-if-exists-in-db :certificate-key cached-key :certificate-key-password "" :certificate cached-certificate)) (cached-key-password (%gemini-request iri + :titan-data titan-data :do-nothing-if-exists-in-db do-nothing-if-exists-in-db :certificate-key cached-key :certificate-key-password cached-key-password @@ -278,6 +281,7 @@ (progn (debug-gemini-gui "caching *not* found for ~a" actual-iri) (%gemini-request actual-iri + :titan-data titan-data :certificate-key certificate-key :certificate certificate :use-cached-file-if-exists nil @@ -288,7 +292,7 @@ (handler-case (gemini-remove-stream actual-iri) (error (e) - (debug-gemini-gui "error removing stream ~a: ~a" url e))) + (debug-gemini-gui "error removing stream: ~a" e))) (gemini-client:request-dispatch url gemini-client::dispatch-table :certificate certificate diff --git a/src/json-rpc2.lisp b/src/json-rpc2.lisp index 874d09f..e8c4871 100644 --- a/src/json-rpc2.lisp +++ b/src/json-rpc2.lisp @@ -366,9 +366,11 @@ :transaction-id (id request) :text (format nil - "Number of parameters (arity) not compatible with function: expected ~a got ~a." + "Number of parameters (arity) not compatible with function: expected ~a got ~a for ~a." (length (params fun)) - (length (params request))))) + (length (params request)) + (function-id request)))) + (t (let* ((params (params request)) (called-by-name-p (called-by-name-p fun params)))