mirror of
https://codeberg.org/cage/tinmop/
synced 2025-02-21 08:50:51 +01:00
- added optional key password argument to gemini and titan requests.
This commit is contained in:
cage
parent
5155749080
commit
56ad43f5dd
@ -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
|
||||
|
||||
@ -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))))))
|
||||
|
||||
@ -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))))
|
||||
|
||||
@ -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)
|
||||
|
||||
@ -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
|
||||
|
||||
@ -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*)
|
||||
|
||||
Loading…
x
Reference in New Issue
Block a user