mirror of https://codeberg.org/cage/tinmop/
- [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:
parent
b7e139a205
commit
904fb6cf7e
|
@ -421,13 +421,24 @@
|
|||
#+debug-gemini-request
|
||||
(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)
|
||||
(flet ((open-socket (hostname)
|
||||
(usocket:socket-connect hostname
|
||||
port
|
||||
:element-type '(unsigned-byte 8))))
|
||||
(or (ignore-errors (open-socket host))
|
||||
(open-socket (idn:host-unicode->ascii host)))))
|
||||
#+sbcl (sb-sys:with-deadline (:seconds +open-socket-response-deadline+)
|
||||
(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
|
||||
(query nil)
|
||||
|
@ -443,34 +454,39 @@
|
|||
:fragment (percent-encode-fragment fragment)))
|
||||
(ctx (cl+ssl:make-context :verify-mode cl+ssl:+ssl-verify-none+)))
|
||||
(cl+ssl:with-global-context (ctx :auto-free-p t)
|
||||
(let ((socket (open-tls-socket host port)))
|
||||
(hooks:run-hooks 'hooks:*after-gemini-socket*)
|
||||
(let* ((stream (usocket:socket-stream socket))
|
||||
(ssl-hostname (if (or (iri:ipv4-address-p host)
|
||||
(iri:ipv6-address-p host))
|
||||
nil
|
||||
host))
|
||||
(ssl-stream (cl+ssl:make-ssl-client-stream stream
|
||||
:certificate client-certificate
|
||||
:key certificate-key
|
||||
:password
|
||||
certificate-key-password
|
||||
:external-format nil ; unsigned byte 8
|
||||
:unwrap-stream-p t
|
||||
:verify nil
|
||||
:hostname ssl-hostname))
|
||||
(request (format nil "~a~a~a" iri #\return #\newline))
|
||||
(cert-hash (crypto-shortcuts:sha512 (x509:dump-certificate ssl-stream))))
|
||||
(debug-gemini "sending request ~a" request)
|
||||
(if (not (db:tofu-passes-p host cert-hash))
|
||||
(error 'gemini-tofu-error :host host)
|
||||
(progn
|
||||
(write-sequence (string->octets request) ssl-stream)
|
||||
(force-output ssl-stream)
|
||||
(hooks:run-hooks 'hooks:*after-gemini-request-sent*)
|
||||
(multiple-value-bind (status description meta response)
|
||||
(parse-response ssl-stream)
|
||||
(values status description meta response socket)))))))))
|
||||
(handler-case
|
||||
(let ((socket (open-tls-socket host port)))
|
||||
(hooks:run-hooks 'hooks:*after-gemini-socket*)
|
||||
(let* ((stream (usocket:socket-stream socket))
|
||||
(ssl-hostname (if (or (iri:ipv4-address-p host)
|
||||
(iri:ipv6-address-p host))
|
||||
nil
|
||||
host))
|
||||
(ssl-stream (cl+ssl:make-ssl-client-stream stream
|
||||
:certificate client-certificate
|
||||
:key certificate-key
|
||||
:password
|
||||
certificate-key-password
|
||||
:external-format nil ; unsigned byte 8
|
||||
:unwrap-stream-p t
|
||||
:verify nil
|
||||
:hostname ssl-hostname))
|
||||
(request (format nil "~a~a~a" iri #\return #\newline))
|
||||
(cert-hash (crypto-shortcuts:sha512 (x509:dump-certificate ssl-stream))))
|
||||
(debug-gemini "sending request ~a" request)
|
||||
(if (not (db:tofu-passes-p host cert-hash))
|
||||
(error 'gemini-tofu-error :host host)
|
||||
(progn
|
||||
(write-sequence (string->octets request) ssl-stream)
|
||||
(force-output ssl-stream)
|
||||
(hooks:run-hooks 'hooks:*after-gemini-request-sent*)
|
||||
(multiple-value-bind (status description meta response)
|
||||
#+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)
|
||||
(declare (ignore response socket parsed-iri))
|
||||
|
|
|
@ -58,7 +58,11 @@ and key stored in the file pointed by the filesystem path
|
|||
"request ~s fingerprint ~a~%"
|
||||
request
|
||||
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
|
||||
"~a please provide a certificate~a~a"
|
||||
(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)
|
||||
stream)
|
||||
(close stream)
|
||||
(get-data))
|
||||
(let ((response (format nil
|
||||
"~a text/gemini~a~a#OK~%"
|
||||
(code gemini-client::+20+)
|
||||
#\return #\newline)))
|
||||
(format t "sending: ~a~%" response)
|
||||
(write-sequence (text-utils:string->octets response)
|
||||
stream)
|
||||
(close stream)
|
||||
(get-data)))))))))))))
|
||||
(get-data)))
|
||||
(t
|
||||
(let ((response (format nil
|
||||
"~a text/gemini~a~a#OK~%"
|
||||
(code gemini-client::+20+)
|
||||
#\return #\newline)))
|
||||
(format t "sending: ~a~%" response)
|
||||
(write-sequence (text-utils:string->octets response)
|
||||
stream)
|
||||
(close stream)
|
||||
(get-data))))))))))))))
|
||||
(loop (get-data))))))
|
||||
|
|
|
@ -288,7 +288,7 @@
|
|||
(handler-case
|
||||
(gemini-remove-stream actual-iri)
|
||||
(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::dispatch-table
|
||||
:certificate certificate
|
||||
|
@ -301,10 +301,13 @@
|
|||
(format nil "~a" e)
|
||||
url))
|
||||
(conditions:not-implemented-error (e)
|
||||
(error (_ "Error: ~a") e))
|
||||
(error (_ "Error getting ~s: ~a") url e))
|
||||
(gemini-client:gemini-protocol-error (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)
|
||||
url))
|
||||
(error (e)
|
||||
|
|
Loading…
Reference in New Issue