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

- added optional key password argument to gemini and titan requests.

This commit is contained in:
cage 2024-02-11 15:06:41 +01:00
parent 5155749080
commit 56ad43f5dd
6 changed files with 96 additions and 60 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

37
src/gemini/client.lisp
View File

@ -434,7 +434,8 @@
(port +gemini-default-port+) (port +gemini-default-port+)
(fragment nil) (fragment nil)
(client-certificate nil) (client-certificate nil)
(certificate-key nil)) (certificate-key nil)
(certificate-key-password nil))
(let* ((iri (make-gemini-iri (idn:host-unicode->ascii host) (let* ((iri (make-gemini-iri (idn:host-unicode->ascii host)
(percent-encode-path path) (percent-encode-path path)
:query (percent-encode-query query) :query (percent-encode-query query)
@ -452,6 +453,8 @@
(ssl-stream (cl+ssl:make-ssl-client-stream stream (ssl-stream (cl+ssl:make-ssl-client-stream stream
:certificate client-certificate :certificate client-certificate
:key certificate-key :key certificate-key
:password
certificate-key-password
:external-format nil ; unsigned byte 8 :external-format nil ; unsigned byte 8
:unwrap-stream-p t :unwrap-stream-p t
:verify nil :verify nil
@ -476,7 +479,11 @@
"received an unknown response from server ~s ~a ~s ~s" "received an unknown response from server ~s ~a ~s ~s"
iri status code-description meta)))) 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) (multiple-value-bind (actual-iri host path query port)
(displace-iri (iri:iri-parse url)) (displace-iri (iri:iri-parse url))
(declare (ignore actual-iri)) (declare (ignore actual-iri))
@ -489,10 +496,11 @@
size size
token token
data data
:query query :query query
:port port :port port
:certificate-key certificate-key :certificate-key certificate-key
:client-certificate certificate) :certificate-key-password certificate-key-password
:client-certificate certificate)
(close-ssl-socket socket) (close-ssl-socket socket)
(values status description meta response socket))) (values status description meta response socket)))
((null mime-type) ((null mime-type)
@ -503,7 +511,8 @@
(defun request-dispatch (url manage-functions (defun request-dispatch (url manage-functions
&key &key
(certificate nil) (certificate nil)
(certificate-key nil)) (certificate-key nil)
(certificate-key-password nil))
(flet ((make-titan-request () (flet ((make-titan-request ()
(multiple-value-bind (no-parameters-path titan-data size mime token) (multiple-value-bind (no-parameters-path titan-data size mime token)
(funcall (getf manage-functions :titan-upload (funcall (getf manage-functions :titan-upload
@ -521,7 +530,8 @@
size size
token token
:certificate certificate :certificate certificate
:certificate-key certificate-key)))) :certificate-key certificate-key
:certificate-key-password certificate-key-password))))
(let ((parsed-iri (iri:iri-parse url))) (let ((parsed-iri (iri:iri-parse url)))
(multiple-value-bind (actual-iri host path query port) (multiple-value-bind (actual-iri host path query port)
(displace-iri parsed-iri) (displace-iri parsed-iri)
@ -530,11 +540,12 @@
(make-titan-request) (make-titan-request)
(gemini-client:request host (gemini-client:request host
path path
:certificate-key certificate-key :certificate-key certificate-key
:client-certificate certificate :certificate-key-password certificate-key-password
:query query :client-certificate certificate
:port port :query query
:fragment nil)) :port port
:fragment nil))
(flet ((call-appropriate-function (response-type) (flet ((call-appropriate-function (response-type)
(funcall (getf manage-functions (funcall (getf manage-functions
response-type response-type

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

@ -31,38 +31,50 @@ and key stored in the file pointed by the filesystem path
"generated certificate and private key in ~s ~s respectively~%" "generated certificate and private key in ~s ~s respectively~%"
certificate certificate
key) key)
(let ((server (usocket:socket-listen "127.0.0.1" port :element-type '(unsigned-byte 8)))) (let ((server (usocket:socket-listen "127.0.0.1" port :element-type '(unsigned-byte 8)))
(format t "SSL server listening on port ~d~%" port) (client-cert-fingerprint nil))
(unwind-protect (format t "SSL server listening on port ~d~%" port)
(labels ((get-data () (labels ((get-data ()
(let* ((client-socket (usocket:socket-accept server)) (format t "start~%")
(client-stream (usocket:socket-stream client-socket))) (let* ((client-socket (usocket:socket-accept server)))
(format t "opening socket~%") (format t "accepted ~a~%" client-socket)
(let ((ctx (cl+ssl:make-context :verify-mode cl+ssl:+ssl-verify-peer+ (make-thread (lambda ()
:verify-callback 'no-verify))) (let ((client-stream (usocket:socket-stream client-socket)))
(cl+ssl:with-global-context (ctx :auto-free-p t) (format t "opening socket~%")
(let* ((stream (cl+ssl:make-ssl-server-stream client-stream (let ((ctx (cl+ssl:make-context :verify-mode cl+ssl:+ssl-verify-peer+
:external-format :verify-callback 'no-verify)))
nil (cl+ssl:with-global-context (ctx :auto-free-p t)
:certificate (let* ((stream (cl+ssl:make-ssl-server-stream client-stream
certificate :external-format
:key nil
key)) :certificate
(client-cert-fingerprint (x509:certificate-fingerprint stream))) certificate
(let* ((data (misc:read-line-into-array stream)) :key
(request (text-utils:trim-blanks (text-utils:to-s data)))) key)))
(format t (setf client-cert-fingerprint (x509:certificate-fingerprint stream))
"request ~s fingerprint ~a~%" (let* ((data (misc:read-line-into-array stream))
request (request (text-utils:trim-blanks (text-utils:to-s data))))
client-cert-fingerprint) (format t
(when (null client-cert-fingerprint) "request ~s fingerprint ~a~%"
(let ((response (format nil request
"~a please provide a certificate~a~a" client-cert-fingerprint)
(code gemini-client::+60+) (if (null client-cert-fingerprint)
#\return #\newline))) (let ((response (format nil
(write-sequence (text-utils:string->octets response) "~a please provide a certificate~a~a"
stream) (code gemini-client::+60+)
(close stream) #\return #\newline)))
(get-data)))))))))) (format t "sending: ~a~%" response)
(get-data)) (write-sequence (text-utils:string->octets response)
(usocket:socket-close server))))) 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))))))

21
src/gemini/titan.lisp
View File

@ -62,7 +62,9 @@
(get-value +titan-token-key+))))) (get-value +titan-token-key+)))))
(defgeneric titan-request (host path mime-type size token data (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) (defmethod titan-request (host path mime-type (size integer) token (data string)
&key &key
@ -70,7 +72,8 @@
(port +gemini-default-port+) (port +gemini-default-port+)
(fragment nil) (fragment nil)
(client-certificate 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)) (flex:with-input-from-sequence (stream (text-utils:string->octets data))
(titan-request host (titan-request host
path path
@ -82,7 +85,8 @@
:port port :port port
:fragment fragment :fragment fragment
:client-certificate client-certificate :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) (defmethod titan-request (host path mime-type (size integer) token (data pathname)
&key &key
@ -90,7 +94,8 @@
(port +gemini-default-port+) (port +gemini-default-port+)
(fragment nil) (fragment nil)
(client-certificate nil) (client-certificate nil)
(certificate-key nil)) (certificate-key nil)
(certificate-key-password nil))
(with-open-file (stream (with-open-file (stream
data data
:direction :input :direction :input
@ -106,7 +111,8 @@
:port port :port port
:fragment fragment :fragment fragment
:client-certificate client-certificate :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) (defmethod titan-request (host path mime-type (size integer) token (data stream)
&key &key
@ -114,7 +120,8 @@
(port +gemini-default-port+) (port +gemini-default-port+)
(fragment nil) (fragment nil)
(client-certificate nil) (client-certificate nil)
(certificate-key nil)) (certificate-key nil)
(certificate-key-password nil))
(let* ((iri (make-gemini-iri (idn:host-unicode->ascii host) (let* ((iri (make-gemini-iri (idn:host-unicode->ascii host)
(strcat (percent-encode-path path) (strcat (percent-encode-path path)
(make-titan-parameters mime-type (make-titan-parameters mime-type
@ -139,6 +146,8 @@
:external-format nil ; unsigned byte 8 :external-format nil ; unsigned byte 8
:unwrap-stream-p t :unwrap-stream-p t
:verify nil :verify nil
:password
certificate-key-password
:hostname ssl-hostname)) :hostname ssl-hostname))
(request (format nil "~a~a~a" iri #\return #\newline)) (request (format nil "~a~a~a" iri #\return #\newline))
(cert-hash (crypto-shortcuts:sha512 (x509:dump-certificate ssl-stream)))) (cert-hash (crypto-shortcuts:sha512 (x509:dump-certificate ssl-stream))))

3
src/gui/client/titan-window.lisp
View File

@ -89,7 +89,8 @@
1 1
(to-s url) (to-s url)
nil nil
titan-data) titan-data
nil)
(client-main-window::print-info-message (_ "Data uploaded"))))))))))) (client-main-window::print-info-message (_ "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)

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

@ -260,7 +260,10 @@
do-nothing-if-exists-in-db)))) do-nothing-if-exists-in-db))))
(progn (progn
(debug-gemini-gui "ignoring cache for ~a" actual-iri) (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:request-dispatch url
gemini-client::dispatch-table gemini-client::dispatch-table
:certificate certificate :certificate certificate

8
tinmop.asd
View File

@ -199,7 +199,7 @@
(:file "idn-tests") (:file "idn-tests")
(:file "json-rpc2-tests"))))) (:file "json-rpc2-tests")))))
;;(push :debug-mode *features*) ;; (push :debug-mode *features*)
;;(push :debug-sql *features*) ;; (push :debug-sql *features*)
;;(push :debug-gemini-request *features*) ;; (push :debug-gemini-request *features*)
;;(push :debug-json-rpc *features*) ;; (push :debug-json-rpc *features*)