cage
/
tinmop
mirror of https://codeberg.org/cage/tinmop/
1
0
Fork 0
Code Issues

- [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.
This commit is contained in:
cage 2024-03-03 18:04:22 +01:00
parent 191cff72d3
commit 50a11fb603
4 changed files with 82 additions and 19 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

11
src/gemini/dummy-server.lisp
View File

@ -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~%"

74
src/gui/client/titan-window.lisp
View File

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

10
src/gui/server/public-api-gemini-stream.lisp
View File

@ -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

6
src/json-rpc2.lisp
View File

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