diff --git a/src/gemini/client.lisp b/src/gemini/client.lisp index ddb0ff4..721e82c 100644 --- a/src/gemini/client.lisp +++ b/src/gemini/client.lisp @@ -434,7 +434,8 @@ (port +gemini-default-port+) (fragment nil) (client-certificate nil) - (certificate-key nil)) + (certificate-key nil) + (certificate-key-password nil)) (let* ((iri (make-gemini-iri (idn:host-unicode->ascii host) (percent-encode-path path) :query (percent-encode-query query) @@ -452,6 +453,8 @@ (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 @@ -476,7 +479,11 @@ "received an unknown response from server ~s ~a ~s ~s" iri status code-description meta)))) -(defun start-titan-request (url no-parameters-path data mime-type size token &key (certificate nil) (certificate-key nil)) +(defun start-titan-request (url no-parameters-path data mime-type size token + &key + (certificate nil) + (certificate-key nil) + (certificate-key-password)) (multiple-value-bind (actual-iri host path query port) (displace-iri (iri:iri-parse url)) (declare (ignore actual-iri)) @@ -489,10 +496,11 @@ size token data - :query query - :port port - :certificate-key certificate-key - :client-certificate certificate) + :query query + :port port + :certificate-key certificate-key + :certificate-key-password certificate-key-password + :client-certificate certificate) (close-ssl-socket socket) (values status description meta response socket))) ((null mime-type) @@ -503,7 +511,8 @@ (defun request-dispatch (url manage-functions &key (certificate nil) - (certificate-key nil)) + (certificate-key nil) + (certificate-key-password nil)) (flet ((make-titan-request () (multiple-value-bind (no-parameters-path titan-data size mime token) (funcall (getf manage-functions :titan-upload @@ -521,7 +530,8 @@ size token :certificate certificate - :certificate-key certificate-key)))) + :certificate-key certificate-key + :certificate-key-password certificate-key-password)))) (let ((parsed-iri (iri:iri-parse url))) (multiple-value-bind (actual-iri host path query port) (displace-iri parsed-iri) @@ -530,11 +540,12 @@ (make-titan-request) (gemini-client:request host path - :certificate-key certificate-key - :client-certificate certificate - :query query - :port port - :fragment nil)) + :certificate-key certificate-key + :certificate-key-password certificate-key-password + :client-certificate certificate + :query query + :port port + :fragment nil)) (flet ((call-appropriate-function (response-type) (funcall (getf manage-functions response-type diff --git a/src/gemini/dummy-server.lisp b/src/gemini/dummy-server.lisp index c970059..c643cfd 100644 --- a/src/gemini/dummy-server.lisp +++ b/src/gemini/dummy-server.lisp @@ -31,38 +31,50 @@ and key stored in the file pointed by the filesystem path "generated certificate and private key in ~s ~s respectively~%" certificate key) - (let ((server (usocket:socket-listen "127.0.0.1" port :element-type '(unsigned-byte 8)))) - (format t "SSL server listening on port ~d~%" port) - (unwind-protect - (labels ((get-data () - (let* ((client-socket (usocket:socket-accept server)) - (client-stream (usocket:socket-stream client-socket))) - (format t "opening socket~%") - (let ((ctx (cl+ssl:make-context :verify-mode cl+ssl:+ssl-verify-peer+ - :verify-callback 'no-verify))) - (cl+ssl:with-global-context (ctx :auto-free-p t) - (let* ((stream (cl+ssl:make-ssl-server-stream client-stream - :external-format - nil - :certificate - certificate - :key - key)) - (client-cert-fingerprint (x509:certificate-fingerprint stream))) - (let* ((data (misc:read-line-into-array stream)) - (request (text-utils:trim-blanks (text-utils:to-s data)))) - (format t - "request ~s fingerprint ~a~%" - request - client-cert-fingerprint) - (when (null client-cert-fingerprint) - (let ((response (format nil - "~a please provide a certificate~a~a" - (code gemini-client::+60+) - #\return #\newline))) - (write-sequence (text-utils:string->octets response) - stream) - (close stream) - (get-data)))))))))) - (get-data)) - (usocket:socket-close server))))) + (let ((server (usocket:socket-listen "127.0.0.1" port :element-type '(unsigned-byte 8))) + (client-cert-fingerprint nil)) + (format t "SSL server listening on port ~d~%" port) + (labels ((get-data () + (format t "start~%") + (let* ((client-socket (usocket:socket-accept server))) + (format t "accepted ~a~%" client-socket) + (make-thread (lambda () + (let ((client-stream (usocket:socket-stream client-socket))) + (format t "opening socket~%") + (let ((ctx (cl+ssl:make-context :verify-mode cl+ssl:+ssl-verify-peer+ + :verify-callback 'no-verify))) + (cl+ssl:with-global-context (ctx :auto-free-p t) + (let* ((stream (cl+ssl:make-ssl-server-stream client-stream + :external-format + nil + :certificate + certificate + :key + key))) + (setf client-cert-fingerprint (x509:certificate-fingerprint stream)) + (let* ((data (misc:read-line-into-array stream)) + (request (text-utils:trim-blanks (text-utils:to-s data)))) + (format t + "request ~s fingerprint ~a~%" + request + client-cert-fingerprint) + (if (null client-cert-fingerprint) + (let ((response (format nil + "~a please provide a certificate~a~a" + (code gemini-client::+60+) + #\return #\newline))) + (format t "sending: ~a~%" response) + (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))))))))))))) + (loop (get-data)))))) diff --git a/src/gemini/titan.lisp b/src/gemini/titan.lisp index c0b5389..40c72c6 100644 --- a/src/gemini/titan.lisp +++ b/src/gemini/titan.lisp @@ -62,7 +62,9 @@ (get-value +titan-token-key+))))) (defgeneric titan-request (host path mime-type size token data - &key query port fragment client-certificate certificate-key)) + &key + query port fragment client-certificate certificate-key + certificate-key-password)) (defmethod titan-request (host path mime-type (size integer) token (data string) &key @@ -70,7 +72,8 @@ (port +gemini-default-port+) (fragment nil) (client-certificate nil) - (certificate-key nil)) + (certificate-key nil) + (certificate-key-password nil)) (flex:with-input-from-sequence (stream (text-utils:string->octets data)) (titan-request host path @@ -82,7 +85,8 @@ :port port :fragment fragment :client-certificate client-certificate - :certificate-key certificate-key))) + :certificate-key certificate-key + :certificate-key-password certificate-key-password))) (defmethod titan-request (host path mime-type (size integer) token (data pathname) &key @@ -90,7 +94,8 @@ (port +gemini-default-port+) (fragment nil) (client-certificate nil) - (certificate-key nil)) + (certificate-key nil) + (certificate-key-password nil)) (with-open-file (stream data :direction :input @@ -106,7 +111,8 @@ :port port :fragment fragment :client-certificate client-certificate - :certificate-key certificate-key))) + :certificate-key certificate-key + :certificate-key-password certificate-key-password))) (defmethod titan-request (host path mime-type (size integer) token (data stream) &key @@ -114,7 +120,8 @@ (port +gemini-default-port+) (fragment nil) (client-certificate nil) - (certificate-key nil)) + (certificate-key nil) + (certificate-key-password nil)) (let* ((iri (make-gemini-iri (idn:host-unicode->ascii host) (strcat (percent-encode-path path) (make-titan-parameters mime-type @@ -139,6 +146,8 @@ :external-format nil ; unsigned byte 8 :unwrap-stream-p t :verify nil + :password + certificate-key-password :hostname ssl-hostname)) (request (format nil "~a~a~a" iri #\return #\newline)) (cert-hash (crypto-shortcuts:sha512 (x509:dump-certificate ssl-stream)))) diff --git a/src/gui/client/titan-window.lisp b/src/gui/client/titan-window.lisp index 6312095..f8097f0 100644 --- a/src/gui/client/titan-window.lisp +++ b/src/gui/client/titan-window.lisp @@ -89,7 +89,8 @@ 1 (to-s url) nil - titan-data) + titan-data + nil) (client-main-window::print-info-message (_ "Data uploaded"))))))))))) (defmethod initialize-instance :after ((object titan-frame) &key (url "") &allow-other-keys) diff --git a/src/gui/server/public-api-gemini-stream.lisp b/src/gui/server/public-api-gemini-stream.lisp index 20c7ec0..5922dce 100644 --- a/src/gui/server/public-api-gemini-stream.lisp +++ b/src/gui/server/public-api-gemini-stream.lisp @@ -260,7 +260,10 @@ do-nothing-if-exists-in-db)))) (progn (debug-gemini-gui "ignoring cache for ~a" actual-iri) - (ignore-errors (gemini-remove-stream actual-iri)) + (handler-case + (gemini-remove-stream actual-iri) + (error (e) + (debug-gemini-gui "error removing stream ~a" e))) (gemini-client:request-dispatch url gemini-client::dispatch-table :certificate certificate diff --git a/tinmop.asd b/tinmop.asd index 315cd0c..bb6dab9 100644 --- a/tinmop.asd +++ b/tinmop.asd @@ -199,7 +199,7 @@ (:file "idn-tests") (:file "json-rpc2-tests"))))) -;;(push :debug-mode *features*) -;;(push :debug-sql *features*) -;;(push :debug-gemini-request *features*) -;;(push :debug-json-rpc *features*) +;; (push :debug-mode *features*) +;; (push :debug-sql *features*) +;; (push :debug-gemini-request *features*) +;; (push :debug-json-rpc *features*)