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

- [GUI] added timeout test for dummy server; 

- [GUI] returned a more useful error message to user when a timeout occurred.
This commit is contained in:
cage 2024-02-25 16:28:16 +01:00
parent b7e139a205
commit 904fb6cf7e
3 changed files with 68 additions and 44 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

76
src/gemini/client.lisp
View File

@ -421,13 +421,24 @@
#+debug-gemini-request #+debug-gemini-request
(apply #'misc:dbg (text-utils:strcat "[gemini] " (first data)) (rest data))) (apply #'misc:dbg (text-utils:strcat "[gemini] " (first data)) (rest data)))
#+sbcl
(define-constant +open-socket-response-deadline+ 10
:test #'=
:documentation "timeout, in seconds, for opening socket")
(defun open-tls-socket (host port) (defun open-tls-socket (host port)
(flet ((open-socket (hostname) (flet ((open-socket (hostname)
(usocket:socket-connect hostname (usocket:socket-connect hostname
port port
:element-type '(unsigned-byte 8)))) :element-type '(unsigned-byte 8))))
(or (ignore-errors (open-socket host)) #+sbcl (sb-sys:with-deadline (:seconds +open-socket-response-deadline+)
(open-socket (idn:host-unicode->ascii host))))) (open-socket (idn:host-unicode->ascii host)))
#-sbcl (open-socket (idn:host-unicode->ascii host))))
#+sbcl
(define-constant +read-response-deadline+ 10
:test #'=
:documentation "timeout, in seconds, for reading response from remote server")
(defun request (host path &key (defun request (host path &key
(query nil) (query nil)
@ -443,34 +454,39 @@
:fragment (percent-encode-fragment fragment))) :fragment (percent-encode-fragment fragment)))
(ctx (cl+ssl:make-context :verify-mode cl+ssl:+ssl-verify-none+))) (ctx (cl+ssl:make-context :verify-mode cl+ssl:+ssl-verify-none+)))
(cl+ssl:with-global-context (ctx :auto-free-p t) (cl+ssl:with-global-context (ctx :auto-free-p t)
(let ((socket (open-tls-socket host port))) (handler-case
(hooks:run-hooks 'hooks:*after-gemini-socket*) (let ((socket (open-tls-socket host port)))
(let* ((stream (usocket:socket-stream socket)) (hooks:run-hooks 'hooks:*after-gemini-socket*)
(ssl-hostname (if (or (iri:ipv4-address-p host) (let* ((stream (usocket:socket-stream socket))
(iri:ipv6-address-p host)) (ssl-hostname (if (or (iri:ipv4-address-p host)
nil (iri:ipv6-address-p host))
host)) nil
(ssl-stream (cl+ssl:make-ssl-client-stream stream host))
:certificate client-certificate (ssl-stream (cl+ssl:make-ssl-client-stream stream
:key certificate-key :certificate client-certificate
:password :key certificate-key
certificate-key-password :password
:external-format nil ; unsigned byte 8 certificate-key-password
:unwrap-stream-p t :external-format nil ; unsigned byte 8
:verify nil :unwrap-stream-p t
:hostname ssl-hostname)) :verify nil
(request (format nil "~a~a~a" iri #\return #\newline)) :hostname ssl-hostname))
(cert-hash (crypto-shortcuts:sha512 (x509:dump-certificate ssl-stream)))) (request (format nil "~a~a~a" iri #\return #\newline))
(debug-gemini "sending request ~a" request) (cert-hash (crypto-shortcuts:sha512 (x509:dump-certificate ssl-stream))))
(if (not (db:tofu-passes-p host cert-hash)) (debug-gemini "sending request ~a" request)
(error 'gemini-tofu-error :host host) (if (not (db:tofu-passes-p host cert-hash))
(progn (error 'gemini-tofu-error :host host)
(write-sequence (string->octets request) ssl-stream) (progn
(force-output ssl-stream) (write-sequence (string->octets request) ssl-stream)
(hooks:run-hooks 'hooks:*after-gemini-request-sent*) (force-output ssl-stream)
(multiple-value-bind (status description meta response) (hooks:run-hooks 'hooks:*after-gemini-request-sent*)
(parse-response ssl-stream) (multiple-value-bind (status description meta response)
(values status description meta response socket))))))))) #+sbcl (sb-sys:with-deadline (:seconds +read-response-deadline+)
(parse-response ssl-stream))
#-sbcl (parse-response ssl-stream)
(values status description meta response socket))))))
(error (e)
(error e))))))
(defun missing-dispath-function (status code-description meta response socket iri parsed-iri) (defun missing-dispath-function (status code-description meta response socket iri parsed-iri)
(declare (ignore response socket parsed-iri)) (declare (ignore response socket parsed-iri))

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

@ -58,7 +58,11 @@ and key stored in the file pointed by the filesystem path
"request ~s fingerprint ~a~%" "request ~s fingerprint ~a~%"
request request
client-cert-fingerprint) client-cert-fingerprint)
(if (null client-cert-fingerprint) (cond
((cl-ppcre:scan "timeout" request)
(format t "timeout...~%")
(sleep 3600))
((null client-cert-fingerprint)
(let ((response (format nil (let ((response (format nil
"~a please provide a certificate~a~a" "~a please provide a certificate~a~a"
(code gemini-client::+60+) (code gemini-client::+60+)
@ -67,14 +71,15 @@ and key stored in the file pointed by the filesystem path
(write-sequence (text-utils:string->octets response) (write-sequence (text-utils:string->octets response)
stream) stream)
(close stream) (close stream)
(get-data)) (get-data)))
(let ((response (format nil (t
"~a text/gemini~a~a#OK~%" (let ((response (format nil
(code gemini-client::+20+) "~a text/gemini~a~a#OK~%"
#\return #\newline))) (code gemini-client::+20+)
(format t "sending: ~a~%" response) #\return #\newline)))
(write-sequence (text-utils:string->octets response) (format t "sending: ~a~%" response)
stream) (write-sequence (text-utils:string->octets response)
(close stream) stream)
(get-data))))))))))))) (close stream)
(get-data))))))))))))))
(loop (get-data)))))) (loop (get-data))))))

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

@ -288,7 +288,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" e))) (debug-gemini-gui "error removing stream ~a: ~a" url e)))
(gemini-client:request-dispatch url (gemini-client:request-dispatch url
gemini-client::dispatch-table gemini-client::dispatch-table
:certificate certificate :certificate certificate
@ -301,10 +301,13 @@
(format nil "~a" e) (format nil "~a" e)
url)) url))
(conditions:not-implemented-error (e) (conditions:not-implemented-error (e)
(error (_ "Error: ~a") e)) (error (_ "Error getting ~s: ~a") url e))
(gemini-client:gemini-protocol-error (e) (gemini-client:gemini-protocol-error (e)
(make-gemini-response (gemini-client:error-code e) (make-gemini-response (gemini-client:error-code e)
(gemini-client:error-description e) (format nil
"~s: ~a"
url
(gemini-client:error-description e))
(gemini-client:meta e) (gemini-client:meta e)
url)) url))
(error (e) (error (e)