diff --git a/src/gemini/client.lisp b/src/gemini/client.lisp index c494ceb..24d6f96 100644 --- a/src/gemini/client.lisp +++ b/src/gemini/client.lisp @@ -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)) diff --git a/src/gemini/dummy-server.lisp b/src/gemini/dummy-server.lisp index c643cfd..72ff7b9 100644 --- a/src/gemini/dummy-server.lisp +++ b/src/gemini/dummy-server.lisp @@ -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)))))) diff --git a/src/gui/server/public-api-gemini-stream.lisp b/src/gui/server/public-api-gemini-stream.lisp index 7283c49..33b3c04 100644 --- a/src/gui/server/public-api-gemini-stream.lisp +++ b/src/gui/server/public-api-gemini-stream.lisp @@ -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)