mirror of https://codeberg.org/cage/tinmop/
- [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:
parent
191cff72d3
commit
50a11fb603
|
@ -72,6 +72,17 @@ and key stored in the file pointed by the filesystem path
|
||||||
stream)
|
stream)
|
||||||
(close stream)
|
(close stream)
|
||||||
(get-data)))
|
(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
|
(t
|
||||||
(let ((response (format nil
|
(let ((response (format nil
|
||||||
"~a text/gemini~a~a#OK~%"
|
"~a text/gemini~a~a#OK~%"
|
||||||
|
|
|
@ -78,20 +78,66 @@
|
||||||
(when (not has-error-p)
|
(when (not has-error-p)
|
||||||
(let ((parameters (gemini-client:make-titan-parameters mime size (gui:text token-entry))))
|
(let ((parameters (gemini-client:make-titan-parameters mime size (gui:text token-entry))))
|
||||||
(setf (uri:path url) (strcat (uri:path url) parameters))
|
(setf (uri:path url) (strcat (uri:path url) parameters))
|
||||||
(ev:with-enqueued-process-and-unblock ()
|
(gui-goodies:with-notify-errors
|
||||||
(gui-goodies::with-notify-errors
|
(ev:with-enqueued-process-and-unblock ()
|
||||||
(gui-goodies:with-busy* (frame)
|
(comm:make-request :titan-save-token
|
||||||
(comm:make-request :titan-save-token
|
1
|
||||||
1
|
base-url
|
||||||
base-url
|
(gui:text token-entry)))
|
||||||
(gui:text token-entry))
|
(let ((connecting-response (cev:enqueue-request-and-wait-results :gemini-request
|
||||||
(comm:make-request :gemini-request
|
1
|
||||||
1
|
ev:+maximum-event-priority+
|
||||||
(to-s url)
|
(to-s url)
|
||||||
nil
|
nil
|
||||||
titan-data
|
titan-data)))
|
||||||
nil)
|
(multiple-value-bind (status-code
|
||||||
(client-main-window::print-info-message (_ "Data uploaded")))))))))))
|
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)
|
(defmethod initialize-instance :after ((object titan-frame) &key (url "") &allow-other-keys)
|
||||||
(with-accessors ((url-entry url-entry)
|
(with-accessors ((url-entry url-entry)
|
||||||
|
|
|
@ -24,8 +24,9 @@
|
||||||
(a:define-constant +certificate-password-not-found-error-status-code+ -2 :test #'=)
|
(a:define-constant +certificate-password-not-found-error-status-code+ -2 :test #'=)
|
||||||
|
|
||||||
(defun debug-gemini-gui (&rest data)
|
(defun debug-gemini-gui (&rest data)
|
||||||
(apply #'gemini-client:debug-gemini (append (list (strcat "[gui] " (first data))
|
(apply #'gemini-client:debug-gemini
|
||||||
(rest data)))))
|
(strcat "[gui] " (first data))
|
||||||
|
(rest data)))
|
||||||
|
|
||||||
(defmethod yason:encode ((object iri-complete-response) &optional (stream *standard-output*))
|
(defmethod yason:encode ((object iri-complete-response) &optional (stream *standard-output*))
|
||||||
(let ((json:*symbol-encoder* #'json:encode-symbol-as-lowercase)
|
(let ((json:*symbol-encoder* #'json:encode-symbol-as-lowercase)
|
||||||
|
@ -221,12 +222,14 @@
|
||||||
(os-utils:ssl-key-has-empty-password-p cached-key))
|
(os-utils:ssl-key-has-empty-password-p cached-key))
|
||||||
(gemini-client:substitute-cache-certificate-password cached-certificate "")
|
(gemini-client:substitute-cache-certificate-password cached-certificate "")
|
||||||
(%gemini-request iri
|
(%gemini-request iri
|
||||||
|
:titan-data titan-data
|
||||||
:do-nothing-if-exists-in-db do-nothing-if-exists-in-db
|
:do-nothing-if-exists-in-db do-nothing-if-exists-in-db
|
||||||
:certificate-key cached-key
|
:certificate-key cached-key
|
||||||
:certificate-key-password ""
|
:certificate-key-password ""
|
||||||
:certificate cached-certificate))
|
:certificate cached-certificate))
|
||||||
(cached-key-password
|
(cached-key-password
|
||||||
(%gemini-request iri
|
(%gemini-request iri
|
||||||
|
:titan-data titan-data
|
||||||
:do-nothing-if-exists-in-db do-nothing-if-exists-in-db
|
:do-nothing-if-exists-in-db do-nothing-if-exists-in-db
|
||||||
:certificate-key cached-key
|
:certificate-key cached-key
|
||||||
:certificate-key-password cached-key-password
|
:certificate-key-password cached-key-password
|
||||||
|
@ -278,6 +281,7 @@
|
||||||
(progn
|
(progn
|
||||||
(debug-gemini-gui "caching *not* found for ~a" actual-iri)
|
(debug-gemini-gui "caching *not* found for ~a" actual-iri)
|
||||||
(%gemini-request actual-iri
|
(%gemini-request actual-iri
|
||||||
|
:titan-data titan-data
|
||||||
:certificate-key certificate-key
|
:certificate-key certificate-key
|
||||||
:certificate certificate
|
:certificate certificate
|
||||||
:use-cached-file-if-exists nil
|
:use-cached-file-if-exists nil
|
||||||
|
@ -288,7 +292,7 @@
|
||||||
(handler-case
|
(handler-case
|
||||||
(gemini-remove-stream actual-iri)
|
(gemini-remove-stream actual-iri)
|
||||||
(error (e)
|
(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:request-dispatch url
|
||||||
gemini-client::dispatch-table
|
gemini-client::dispatch-table
|
||||||
:certificate certificate
|
:certificate certificate
|
||||||
|
|
|
@ -366,9 +366,11 @@
|
||||||
:transaction-id (id request)
|
:transaction-id (id request)
|
||||||
:text
|
:text
|
||||||
(format nil
|
(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 fun))
|
||||||
(length (params request)))))
|
(length (params request))
|
||||||
|
(function-id request))))
|
||||||
|
|
||||||
(t
|
(t
|
||||||
(let* ((params (params request))
|
(let* ((params (params request))
|
||||||
(called-by-name-p (called-by-name-p fun params)))
|
(called-by-name-p (called-by-name-p fun params)))
|
||||||
|
|
Loading…
Reference in New Issue